mirror of
https://github.com/carp-lang/Carp.git
synced 2024-11-04 01:25:04 +03:00
feat: overwrite existing interface implementations (#1094)
* feat: overwrite existing interface implementations This commit alters the behavior of interfaces so that implementations with the same type signature will overwrite previous implementations with that signature--before this was a runtime error. Previously, if a user defined two distinctly named implementations of an interface that shared a type, Carp would panic and error at runtime if the interface was called and resolved to the type, since it couldn't decide which implementation to use from the type alone. After this commit, we instead issue a warning and overwrite existing implementations of the same type, so that defining: ``` (defn foo [] 0) (implements zero foo) ``` will replace `Int.zero` in the `zero` interface's implementation path list and won't result in a runtime error--instead `foo` will be called when `zero` is called in a context in which it returns an int: ``` [WARNING] An implementation of the interface zero with type (Fn [] Int) already exists: Int.zero. It will be replaced by the implementation: foo. This may break a bunch of upstream code! ``` test/interface.carp also has a concrete illustration of this case. * chore: address hlint suggestions * fix: don't print overridden interface implementations in info This commit updates our handling of interface overrides to remove interfaces from the implements meta of a function that was overridden by a new implementation. Similarly, this refactors primitiveInfo to prevent printing binders that do not actually implement an interface. * refactor: incorporate @TimDeve's error message suggestion
This commit is contained in:
parent
5999f58347
commit
d420635762
@ -7,15 +7,18 @@ module Interfaces
|
||||
registerInInterface,
|
||||
retroactivelyRegisterInInterface,
|
||||
interfaceImplementedForTy,
|
||||
removeInterfaceFromImplements,
|
||||
InterfaceError (..),
|
||||
)
|
||||
where
|
||||
|
||||
import ColorText
|
||||
import Constraints
|
||||
import Control.Monad (foldM)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.List (delete, deleteBy)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Env
|
||||
import Lookup
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import Types
|
||||
import Util
|
||||
@ -24,6 +27,7 @@ data InterfaceError
|
||||
= KindMismatch SymPath Ty Ty
|
||||
| TypeMismatch SymPath Ty Ty
|
||||
| NonInterface SymPath
|
||||
| AlreadyImplemented SymPath SymPath SymPath Ty
|
||||
|
||||
instance Show InterfaceError where
|
||||
show (KindMismatch path definitionSignature interfaceSignature) =
|
||||
@ -47,30 +51,79 @@ instance Show InterfaceError where
|
||||
labelStr
|
||||
"INTERFACE ERROR"
|
||||
(show path ++ "Cant' implement the non-interface `" ++ show path ++ "`")
|
||||
show (AlreadyImplemented interfacePath implementationPath replacementPath ty) =
|
||||
"An implementation of the interface " ++ show interfacePath
|
||||
++ " with type "
|
||||
++ show ty
|
||||
++ " already exists: "
|
||||
++ show implementationPath
|
||||
++ ". "
|
||||
++ "It will be replaced by the implementation: "
|
||||
++ show replacementPath
|
||||
++ "."
|
||||
++ "\n"
|
||||
++ "This may result in unexpected behavior."
|
||||
|
||||
-- | Get the first path of an interface implementation that matches a given type signature
|
||||
getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath
|
||||
getFirstMatchingImplementation ctx paths ty =
|
||||
case filter predicate (mapMaybe (`lookupBinder` global) paths) of
|
||||
[] -> Nothing
|
||||
(x : _) -> Just ((getPath . binderXObj) x)
|
||||
where
|
||||
predicate = (== Just ty) . (xobjTy . binderXObj)
|
||||
global = contextGlobalEnv ctx
|
||||
|
||||
-- | Remove an interface from a binder's list of implemented interfaces
|
||||
removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context
|
||||
removeInterfaceFromImplements oldImplPath interface ctx =
|
||||
fromMaybe
|
||||
ctx
|
||||
( lookupBinder oldImplPath (contextGlobalEnv ctx)
|
||||
>>= \binder ->
|
||||
Meta.getBinderMetaValue "implements" binder
|
||||
>>= ( \x ->
|
||||
case x of
|
||||
(XObj (Lst impls) i t) ->
|
||||
pure $ Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
|
||||
_ -> Nothing
|
||||
)
|
||||
>>= (\b -> pure $ ctx {contextGlobalEnv = envInsertAt (contextGlobalEnv ctx) oldImplPath b})
|
||||
)
|
||||
where
|
||||
matchPath xobj xobj' = getPath xobj == getPath xobj'
|
||||
|
||||
-- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
|
||||
-- Checks whether a given form's type matches an interface, and if so, registers the form with the interface.
|
||||
registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> Either String Context
|
||||
registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Context, Maybe InterfaceError)
|
||||
registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
||||
case interface of
|
||||
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
||||
if checkKinds interfaceSignature definitionSignature
|
||||
then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
|
||||
Left _ -> Left (show $ TypeMismatch implPath definitionSignature interfaceSignature)
|
||||
Right _ -> Right (ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)})
|
||||
else Left (show $ KindMismatch implPath definitionSignature interfaceSignature)
|
||||
Left _ -> (ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
|
||||
Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
|
||||
Nothing -> (updatedCtx, Nothing)
|
||||
Just x ->
|
||||
if x == implPath
|
||||
then (updatedCtx, Nothing)
|
||||
else (implReplacedCtx x, Just (AlreadyImplemented ipath x implPath definitionSignature))
|
||||
else (ctx, Just (KindMismatch implPath definitionSignature interfaceSignature))
|
||||
where
|
||||
updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
|
||||
updatedCtx = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
|
||||
implReplacedInterface x = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath (delete x paths))) ii it, isym]) i t
|
||||
implReplacedCtx x = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name (implReplacedInterface x))}
|
||||
_ ->
|
||||
Left (show $ NonInterface (getBinderPath interface))
|
||||
(ctx, Just (NonInterface (getBinderPath interface)))
|
||||
where
|
||||
implPath = getBinderPath implementation
|
||||
typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
(SymPath _ name) = getBinderPath interface
|
||||
ipath@(SymPath _ name) = getBinderPath interface
|
||||
|
||||
-- | Given a binder and an interface path, ensure that the form is
|
||||
-- registered with the interface.
|
||||
registerInInterface :: Context -> Binder -> Binder -> Either String Context
|
||||
registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError)
|
||||
registerInInterface ctx implementation interface =
|
||||
case binderXObj implementation of
|
||||
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
||||
@ -88,18 +141,18 @@ registerInInterface ctx implementation interface =
|
||||
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
||||
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
||||
registerInInterfaceIfNeeded ctx implementation interface t
|
||||
_ -> pure ctx
|
||||
_ -> (ctx, Nothing)
|
||||
|
||||
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
||||
-- retroactively register those forms with the interface once its defined.
|
||||
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
||||
retroactivelyRegisterInInterface ctx interface =
|
||||
-- TODO: Don't use error here?
|
||||
either error id resultCtx
|
||||
-- TODO: Propagate error
|
||||
maybe resultCtx (error . show) err
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
|
||||
resultCtx = foldM (\context binder -> registerInInterface context binder interface) ctx impls
|
||||
(resultCtx, err) = foldl (\(context, _) binder -> registerInInterface context binder interface) (ctx, Nothing) impls
|
||||
|
||||
-- | Checks whether an interface is implemented for a certain type signature,
|
||||
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
||||
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Primitives where
|
||||
@ -20,8 +19,8 @@ import Infer
|
||||
import Info
|
||||
import Interfaces
|
||||
import Lookup
|
||||
import qualified Map
|
||||
import Managed
|
||||
import qualified Map
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import PrimitiveError
|
||||
@ -146,21 +145,18 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), XObj
|
||||
SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
||||
warn :: IO ()
|
||||
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
||||
|
||||
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
||||
addToInterface inter impl =
|
||||
either
|
||||
(addToInterfaceError (contextExecMode ctx))
|
||||
(updateMeta impl)
|
||||
(registerInInterface ctx impl inter)
|
||||
addToInterfaceError :: ExecutionMode -> String -> IO (Context, Either EvalError XObj)
|
||||
addToInterfaceError Check e =
|
||||
putStrLn (machineReadableInfoFromXObj fppl x ++ " " ++ e)
|
||||
>> pure (evalError ctx e (xobjInfo x))
|
||||
where
|
||||
fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
addToInterfaceError _ e =
|
||||
putStrLnWithColor Red e
|
||||
>> pure (evalError ctx e (xobjInfo x))
|
||||
let (newCtx, maybeErr) = registerInInterface ctx impl inter
|
||||
in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
|
||||
|
||||
handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
|
||||
handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
|
||||
emitWarning (show e) >> pure (removeInterfaceFromImplements oldImplPath x context) >>= updateMeta impl
|
||||
handleError context _ e =
|
||||
emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
|
||||
|
||||
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
||||
updateMeta binder context =
|
||||
pure (fromJust update, dynamicNil)
|
||||
@ -171,7 +167,7 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), XObj
|
||||
)
|
||||
<|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
|
||||
)
|
||||
>>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt global (getBinderPath binder) newBinder})
|
||||
>>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt (contextGlobalEnv context) (getBinderPath binder) newBinder})
|
||||
updateImplementations :: Binder -> XObj -> Binder
|
||||
updateImplementations implBinder (XObj (Lst impls) inf ty) =
|
||||
if x `elem` impls
|
||||
@ -234,10 +230,10 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
|
||||
>>= \maybeinterfaces ->
|
||||
pure (mapMaybe (`lookupBinder` getTypeEnv typeEnv) (fromMaybe [] maybeinterfaces))
|
||||
>>= \interfaceBinders ->
|
||||
pure (foldM (`registerInInterface` binder) ctx interfaceBinders)
|
||||
>>= \case
|
||||
Left e -> printError (contextExecMode ctx) e >> pure ctx
|
||||
Right newCtx -> pure newCtx
|
||||
pure (foldl (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders)
|
||||
>>= \(newCtx, err) -> case err of
|
||||
Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
|
||||
Nothing -> pure newCtx
|
||||
printError :: ExecutionMode -> String -> IO ()
|
||||
printError Check e =
|
||||
let fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
@ -296,36 +292,65 @@ notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
|
||||
notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
|
||||
|
||||
primitiveInfo :: Primitive
|
||||
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
|
||||
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] =
|
||||
case path of
|
||||
SymPath [] _ ->
|
||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
||||
>> maybe
|
||||
(notFound ctx target path)
|
||||
(foldM (\_ binder -> printer binder) (ctx, dynamicNil))
|
||||
( fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||
<|> multiLookupBinderEverywhere ctx path
|
||||
)
|
||||
do
|
||||
found <- pure (lookupBinderInTypeEnv ctx path)
|
||||
_ <- printIfFound found
|
||||
_ <- printInterfaceImplementationsOrAll found otherBindings
|
||||
maybe (notFound ctx target path) (const ok) (found <|> fmap head otherBindings)
|
||||
where
|
||||
otherBindings =
|
||||
fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||
<|> multiLookupBinderEverywhere ctx path
|
||||
_ ->
|
||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
||||
>> ( case lookupBinderInContextEnv ctx path of
|
||||
Nothing -> notFound ctx target path
|
||||
Just found -> printer found
|
||||
)
|
||||
do
|
||||
found <- pure (lookupBinderInTypeEnv ctx path)
|
||||
others <- pure (lookupBinderInContextEnv ctx path)
|
||||
_ <- printIfFound found
|
||||
_ <- maybe (pure ()) printer others
|
||||
maybe (notFound ctx target path) (const ok) (found <|> others)
|
||||
where
|
||||
-- TODO: Return IO () here
|
||||
printIfFound :: Maybe Binder -> IO (Context, Either EvalError XObj)
|
||||
printIfFound binder = maybe (pure (ctx, dynamicNil)) printer binder
|
||||
ok :: IO (Context, Either EvalError XObj)
|
||||
ok = pure (ctx, dynamicNil)
|
||||
|
||||
printInterfaceImplementationsOrAll :: Maybe Binder -> Maybe [Binder] -> IO ()
|
||||
printInterfaceImplementationsOrAll interface impls =
|
||||
maybe
|
||||
(pure ())
|
||||
(foldM (\_ binder -> printer binder) ())
|
||||
( ( interface
|
||||
>>= \binder ->
|
||||
pure (xobjObj (binderXObj binder))
|
||||
>>= \obj ->
|
||||
case obj of
|
||||
(Lst [XObj (Interface _ _) _ _, _]) ->
|
||||
fmap (filter (implementsInterface binder)) impls
|
||||
_ -> impls
|
||||
)
|
||||
<|> impls
|
||||
)
|
||||
|
||||
implementsInterface :: Binder -> Binder -> Bool
|
||||
implementsInterface binder binder' =
|
||||
maybe
|
||||
False
|
||||
(\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls)
|
||||
(Meta.getBinderMetaValue "implements" binder')
|
||||
|
||||
printIfFound :: Maybe Binder -> IO ()
|
||||
printIfFound = maybe (pure ()) printer
|
||||
|
||||
printer :: Binder -> IO ()
|
||||
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
|
||||
putStrLnWithColor Blue (forceShowBinder binder)
|
||||
>> putStrLn (" Defined at " ++ prettyInfo i)
|
||||
>> printMeta metaData (contextProj ctx) x
|
||||
>> pure (ctx, dynamicNil)
|
||||
printer binder@(Binder metaData x) =
|
||||
print binder
|
||||
>> printMeta metaData (contextProj ctx) x
|
||||
>> pure (ctx, dynamicNil)
|
||||
|
||||
printMeta :: MetaData -> Project -> XObj -> IO ()
|
||||
printMeta metaData proj x =
|
||||
maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
|
||||
@ -646,9 +671,9 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
)
|
||||
i
|
||||
(Just TypeTy)
|
||||
holderEnv = \name' prev -> Env (Map.fromList []) (Just prev) (Just name') [] ExternalEnv 0
|
||||
holderModule = \name'' prevEnv -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy))
|
||||
folder = \(contx, prev) pathstring -> (contx {contextTypeEnv = TypeEnv $ envInsertAt (getTypeEnv typeEnv) (SymPath (maybeToList (envModuleName prev)) pathstring) (holderModule pathstring prev)}, holderEnv pathstring prev)
|
||||
holderEnv name' prev = Env (Map.fromList []) (Just prev) (Just name') [] ExternalEnv 0
|
||||
holderModule name'' prevEnv = Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy))
|
||||
folder (contx, prev) pathstring = (contx {contextTypeEnv = TypeEnv $ envInsertAt (getTypeEnv typeEnv) (SymPath (maybeToList (envModuleName prev)) pathstring) (holderModule pathstring prev)}, holderEnv pathstring prev)
|
||||
wHolders = fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings)
|
||||
ctx' =
|
||||
( (fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings))
|
||||
@ -666,21 +691,24 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv)
|
||||
Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv)
|
||||
modulePath = SymPath (pathStrings ++ [typeModuleName])
|
||||
ctxWithInterfaceRegistrations =
|
||||
(ctxWithInterfaceRegistrations, err) =
|
||||
-- Since these functions are autogenerated, we treat them as a special case
|
||||
-- and automatically implement the interfaces.
|
||||
foldM
|
||||
(\context (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
|
||||
ctxWithDeps
|
||||
foldl
|
||||
(\(context, _) (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
|
||||
(ctxWithDeps, Nothing)
|
||||
[ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface),
|
||||
(fakeImplBinder (modulePath "str") strSig, strSig, strInterface),
|
||||
(fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface)
|
||||
]
|
||||
case ctxWithInterfaceRegistrations of
|
||||
Left err -> do
|
||||
liftIO (putStrLnWithColor Red err)
|
||||
pure (ctx, dynamicNil)
|
||||
Right ok -> pure (ok, dynamicNil)
|
||||
case err of
|
||||
Just e@AlreadyImplemented {} ->
|
||||
emitWarning (show e)
|
||||
>> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
||||
Just e ->
|
||||
putStrLnWithColor Red (show e)
|
||||
>> pure (ctx, dynamicNil)
|
||||
Nothing -> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
||||
Left err ->
|
||||
pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
|
||||
(_, Nothing) ->
|
||||
@ -707,7 +735,7 @@ primitiveUse _ _ _ = error "primitiveuse"
|
||||
|
||||
-- | Get meta data for a Binder
|
||||
primitiveMeta :: Primitive
|
||||
primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (Str key) _ _] = do
|
||||
primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (Str key) _ _] =
|
||||
pure $ maybe errNotFound foundBinder lookup'
|
||||
where
|
||||
global = contextGlobalEnv ctx
|
||||
@ -762,7 +790,7 @@ primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, XObj (Str _) _ _
|
||||
argumentErr ctx "deftemplate" "a string" "fourth" x
|
||||
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, x, _] =
|
||||
argumentErr ctx "deftemplate" "a string" "third" x
|
||||
primitiveDeftemplate _ ctx [s@(XObj (Sym (SymPath _ _) _) _ _), _, _, _] = do
|
||||
primitiveDeftemplate _ ctx [s@(XObj (Sym (SymPath _ _) _) _ _), _, _, _] =
|
||||
argumentErr ctx "deftemplate" "a symbol without prefix" "first" s
|
||||
primitiveDeftemplate _ ctx [x, _, _, _] =
|
||||
argumentErr ctx "deftemplate" "a symbol" "first" x
|
||||
|
@ -29,6 +29,13 @@
|
||||
(defn monster [scary?] (if scary? @"RAWR" @"meow"))
|
||||
(implements monster monster)
|
||||
|
||||
;; If multiple implementations of the same concrete type are provided,
|
||||
;; one overwrites the other.
|
||||
(defn laugh-monster [times] (String.repeat times "LOL"))
|
||||
(implements monster laugh-monster)
|
||||
(defn pikachu [times] (String.repeat times "pika"))
|
||||
(implements monster pikachu)
|
||||
|
||||
(deftest test
|
||||
(assert-equal test
|
||||
&2
|
||||
@ -47,4 +54,9 @@
|
||||
&(monster false)
|
||||
"Implementations may be global, and an implementation with the same name may
|
||||
be used as a default.")
|
||||
(assert-equal test
|
||||
"pikapikapika"
|
||||
&(monster 3)
|
||||
"Implementations may be overwritten, when multiple implementations of the same type
|
||||
are provided.")
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user