mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 08:27:45 +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,
|
registerInInterface,
|
||||||
retroactivelyRegisterInInterface,
|
retroactivelyRegisterInInterface,
|
||||||
interfaceImplementedForTy,
|
interfaceImplementedForTy,
|
||||||
|
removeInterfaceFromImplements,
|
||||||
|
InterfaceError (..),
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import ColorText
|
import ColorText
|
||||||
import Constraints
|
import Constraints
|
||||||
import Control.Monad (foldM)
|
import Data.List (delete, deleteBy)
|
||||||
import Data.Maybe (mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import Env
|
import Env
|
||||||
import Lookup
|
import Lookup
|
||||||
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
import Types
|
import Types
|
||||||
import Util
|
import Util
|
||||||
@ -24,6 +27,7 @@ data InterfaceError
|
|||||||
= KindMismatch SymPath Ty Ty
|
= KindMismatch SymPath Ty Ty
|
||||||
| TypeMismatch SymPath Ty Ty
|
| TypeMismatch SymPath Ty Ty
|
||||||
| NonInterface SymPath
|
| NonInterface SymPath
|
||||||
|
| AlreadyImplemented SymPath SymPath SymPath Ty
|
||||||
|
|
||||||
instance Show InterfaceError where
|
instance Show InterfaceError where
|
||||||
show (KindMismatch path definitionSignature interfaceSignature) =
|
show (KindMismatch path definitionSignature interfaceSignature) =
|
||||||
@ -47,30 +51,79 @@ instance Show InterfaceError where
|
|||||||
labelStr
|
labelStr
|
||||||
"INTERFACE ERROR"
|
"INTERFACE ERROR"
|
||||||
(show path ++ "Cant' implement the non-interface `" ++ show path ++ "`")
|
(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.
|
-- 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.
|
-- 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 =
|
registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
||||||
case interface of
|
case interface of
|
||||||
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
||||||
if checkKinds interfaceSignature definitionSignature
|
if checkKinds interfaceSignature definitionSignature
|
||||||
then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
|
then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
|
||||||
Left _ -> Left (show $ TypeMismatch implPath definitionSignature interfaceSignature)
|
Left _ -> (ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
|
||||||
Right _ -> Right (ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)})
|
Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
|
||||||
else Left (show $ KindMismatch implPath definitionSignature interfaceSignature)
|
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
|
where
|
||||||
updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
|
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
|
where
|
||||||
implPath = getBinderPath implementation
|
implPath = getBinderPath implementation
|
||||||
typeEnv = getTypeEnv (contextTypeEnv ctx)
|
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
|
-- | Given a binder and an interface path, ensure that the form is
|
||||||
-- registered with the interface.
|
-- registered with the interface.
|
||||||
registerInInterface :: Context -> Binder -> Binder -> Either String Context
|
registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError)
|
||||||
registerInInterface ctx implementation interface =
|
registerInInterface ctx implementation interface =
|
||||||
case binderXObj implementation of
|
case binderXObj implementation of
|
||||||
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
||||||
@ -88,18 +141,18 @@ registerInInterface ctx implementation interface =
|
|||||||
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
||||||
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
||||||
registerInInterfaceIfNeeded ctx implementation interface t
|
registerInInterfaceIfNeeded ctx implementation interface t
|
||||||
_ -> pure ctx
|
_ -> (ctx, Nothing)
|
||||||
|
|
||||||
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
||||||
-- retroactively register those forms with the interface once its defined.
|
-- retroactively register those forms with the interface once its defined.
|
||||||
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
||||||
retroactivelyRegisterInInterface ctx interface =
|
retroactivelyRegisterInInterface ctx interface =
|
||||||
-- TODO: Don't use error here?
|
-- TODO: Propagate error
|
||||||
either error id resultCtx
|
maybe resultCtx (error . show) err
|
||||||
where
|
where
|
||||||
env = contextGlobalEnv ctx
|
env = contextGlobalEnv ctx
|
||||||
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
|
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,
|
-- | Checks whether an interface is implemented for a certain type signature,
|
||||||
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
module Primitives where
|
module Primitives where
|
||||||
@ -20,8 +19,8 @@ import Infer
|
|||||||
import Info
|
import Info
|
||||||
import Interfaces
|
import Interfaces
|
||||||
import Lookup
|
import Lookup
|
||||||
import qualified Map
|
|
||||||
import Managed
|
import Managed
|
||||||
|
import qualified Map
|
||||||
import qualified Meta
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
import PrimitiveError
|
import PrimitiveError
|
||||||
@ -146,21 +145,18 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), XObj
|
|||||||
SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
||||||
warn :: IO ()
|
warn :: IO ()
|
||||||
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
||||||
|
|
||||||
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
||||||
addToInterface inter impl =
|
addToInterface inter impl =
|
||||||
either
|
let (newCtx, maybeErr) = registerInInterface ctx impl inter
|
||||||
(addToInterfaceError (contextExecMode ctx))
|
in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
|
||||||
(updateMeta impl)
|
|
||||||
(registerInInterface ctx impl inter)
|
handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
|
||||||
addToInterfaceError :: ExecutionMode -> String -> IO (Context, Either EvalError XObj)
|
handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
|
||||||
addToInterfaceError Check e =
|
emitWarning (show e) >> pure (removeInterfaceFromImplements oldImplPath x context) >>= updateMeta impl
|
||||||
putStrLn (machineReadableInfoFromXObj fppl x ++ " " ++ e)
|
handleError context _ e =
|
||||||
>> pure (evalError ctx e (xobjInfo x))
|
emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
|
||||||
where
|
|
||||||
fppl = projectFilePathPrintLength (contextProj ctx)
|
|
||||||
addToInterfaceError _ e =
|
|
||||||
putStrLnWithColor Red e
|
|
||||||
>> pure (evalError ctx e (xobjInfo x))
|
|
||||||
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
||||||
updateMeta binder context =
|
updateMeta binder context =
|
||||||
pure (fromJust update, dynamicNil)
|
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)))
|
<|> 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 :: Binder -> XObj -> Binder
|
||||||
updateImplementations implBinder (XObj (Lst impls) inf ty) =
|
updateImplementations implBinder (XObj (Lst impls) inf ty) =
|
||||||
if x `elem` impls
|
if x `elem` impls
|
||||||
@ -234,10 +230,10 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
|
|||||||
>>= \maybeinterfaces ->
|
>>= \maybeinterfaces ->
|
||||||
pure (mapMaybe (`lookupBinder` getTypeEnv typeEnv) (fromMaybe [] maybeinterfaces))
|
pure (mapMaybe (`lookupBinder` getTypeEnv typeEnv) (fromMaybe [] maybeinterfaces))
|
||||||
>>= \interfaceBinders ->
|
>>= \interfaceBinders ->
|
||||||
pure (foldM (`registerInInterface` binder) ctx interfaceBinders)
|
pure (foldl (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders)
|
||||||
>>= \case
|
>>= \(newCtx, err) -> case err of
|
||||||
Left e -> printError (contextExecMode ctx) e >> pure ctx
|
Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
|
||||||
Right newCtx -> pure newCtx
|
Nothing -> pure newCtx
|
||||||
printError :: ExecutionMode -> String -> IO ()
|
printError :: ExecutionMode -> String -> IO ()
|
||||||
printError Check e =
|
printError Check e =
|
||||||
let fppl = projectFilePathPrintLength (contextProj ctx)
|
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))
|
notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
|
||||||
|
|
||||||
primitiveInfo :: Primitive
|
primitiveInfo :: Primitive
|
||||||
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
|
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] =
|
||||||
case path of
|
case path of
|
||||||
SymPath [] _ ->
|
SymPath [] _ ->
|
||||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
do
|
||||||
>> maybe
|
found <- pure (lookupBinderInTypeEnv ctx path)
|
||||||
(notFound ctx target path)
|
_ <- printIfFound found
|
||||||
(foldM (\_ binder -> printer binder) (ctx, dynamicNil))
|
_ <- printInterfaceImplementationsOrAll found otherBindings
|
||||||
( fmap (: []) (lookupBinderInContextEnv ctx path)
|
maybe (notFound ctx target path) (const ok) (found <|> fmap head otherBindings)
|
||||||
<|> multiLookupBinderEverywhere ctx path
|
where
|
||||||
)
|
otherBindings =
|
||||||
|
fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||||
|
<|> multiLookupBinderEverywhere ctx path
|
||||||
_ ->
|
_ ->
|
||||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
do
|
||||||
>> ( case lookupBinderInContextEnv ctx path of
|
found <- pure (lookupBinderInTypeEnv ctx path)
|
||||||
Nothing -> notFound ctx target path
|
others <- pure (lookupBinderInContextEnv ctx path)
|
||||||
Just found -> printer found
|
_ <- printIfFound found
|
||||||
)
|
_ <- maybe (pure ()) printer others
|
||||||
|
maybe (notFound ctx target path) (const ok) (found <|> others)
|
||||||
where
|
where
|
||||||
-- TODO: Return IO () here
|
ok :: IO (Context, Either EvalError XObj)
|
||||||
printIfFound :: Maybe Binder -> IO (Context, Either EvalError XObj)
|
ok = pure (ctx, dynamicNil)
|
||||||
printIfFound binder = maybe (pure (ctx, dynamicNil)) printer binder
|
|
||||||
|
|
||||||
|
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) _)) =
|
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
|
||||||
putStrLnWithColor Blue (forceShowBinder binder)
|
putStrLnWithColor Blue (forceShowBinder binder)
|
||||||
>> putStrLn (" Defined at " ++ prettyInfo i)
|
>> putStrLn (" Defined at " ++ prettyInfo i)
|
||||||
>> printMeta metaData (contextProj ctx) x
|
>> printMeta metaData (contextProj ctx) x
|
||||||
>> pure (ctx, dynamicNil)
|
|
||||||
printer binder@(Binder metaData x) =
|
printer binder@(Binder metaData x) =
|
||||||
print binder
|
print binder
|
||||||
>> printMeta metaData (contextProj ctx) x
|
>> printMeta metaData (contextProj ctx) x
|
||||||
>> pure (ctx, dynamicNil)
|
|
||||||
printMeta :: MetaData -> Project -> XObj -> IO ()
|
printMeta :: MetaData -> Project -> XObj -> IO ()
|
||||||
printMeta metaData proj x =
|
printMeta metaData proj x =
|
||||||
maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
|
maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
|
||||||
@ -646,9 +671,9 @@ primitiveDeftype xobj ctx (name : rest) =
|
|||||||
)
|
)
|
||||||
i
|
i
|
||||||
(Just TypeTy)
|
(Just TypeTy)
|
||||||
holderEnv = \name' prev -> Env (Map.fromList []) (Just prev) (Just name') [] ExternalEnv 0
|
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))
|
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)
|
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)
|
wHolders = fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings)
|
||||||
ctx' =
|
ctx' =
|
||||||
( (fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings))
|
( (fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings))
|
||||||
@ -666,21 +691,24 @@ primitiveDeftype xobj ctx (name : rest) =
|
|||||||
Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv)
|
Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv)
|
||||||
Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv)
|
Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv)
|
||||||
modulePath = SymPath (pathStrings ++ [typeModuleName])
|
modulePath = SymPath (pathStrings ++ [typeModuleName])
|
||||||
ctxWithInterfaceRegistrations =
|
(ctxWithInterfaceRegistrations, err) =
|
||||||
-- Since these functions are autogenerated, we treat them as a special case
|
-- Since these functions are autogenerated, we treat them as a special case
|
||||||
-- and automatically implement the interfaces.
|
-- and automatically implement the interfaces.
|
||||||
foldM
|
foldl
|
||||||
(\context (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
|
(\(context, _) (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
|
||||||
ctxWithDeps
|
(ctxWithDeps, Nothing)
|
||||||
[ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface),
|
[ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface),
|
||||||
(fakeImplBinder (modulePath "str") strSig, strSig, strInterface),
|
(fakeImplBinder (modulePath "str") strSig, strSig, strInterface),
|
||||||
(fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface)
|
(fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface)
|
||||||
]
|
]
|
||||||
case ctxWithInterfaceRegistrations of
|
case err of
|
||||||
Left err -> do
|
Just e@AlreadyImplemented {} ->
|
||||||
liftIO (putStrLnWithColor Red err)
|
emitWarning (show e)
|
||||||
pure (ctx, dynamicNil)
|
>> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
||||||
Right ok -> pure (ok, dynamicNil)
|
Just e ->
|
||||||
|
putStrLnWithColor Red (show e)
|
||||||
|
>> pure (ctx, dynamicNil)
|
||||||
|
Nothing -> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
||||||
Left err ->
|
Left err ->
|
||||||
pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
|
pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
|
||||||
(_, Nothing) ->
|
(_, Nothing) ->
|
||||||
@ -707,7 +735,7 @@ primitiveUse _ _ _ = error "primitiveuse"
|
|||||||
|
|
||||||
-- | Get meta data for a Binder
|
-- | Get meta data for a Binder
|
||||||
primitiveMeta :: Primitive
|
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'
|
pure $ maybe errNotFound foundBinder lookup'
|
||||||
where
|
where
|
||||||
global = contextGlobalEnv ctx
|
global = contextGlobalEnv ctx
|
||||||
@ -762,7 +790,7 @@ primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, XObj (Str _) _ _
|
|||||||
argumentErr ctx "deftemplate" "a string" "fourth" x
|
argumentErr ctx "deftemplate" "a string" "fourth" x
|
||||||
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, x, _] =
|
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, x, _] =
|
||||||
argumentErr ctx "deftemplate" "a string" "third" 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
|
argumentErr ctx "deftemplate" "a symbol without prefix" "first" s
|
||||||
primitiveDeftemplate _ ctx [x, _, _, _] =
|
primitiveDeftemplate _ ctx [x, _, _, _] =
|
||||||
argumentErr ctx "deftemplate" "a symbol" "first" x
|
argumentErr ctx "deftemplate" "a symbol" "first" x
|
||||||
|
@ -29,6 +29,13 @@
|
|||||||
(defn monster [scary?] (if scary? @"RAWR" @"meow"))
|
(defn monster [scary?] (if scary? @"RAWR" @"meow"))
|
||||||
(implements monster monster)
|
(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
|
(deftest test
|
||||||
(assert-equal test
|
(assert-equal test
|
||||||
&2
|
&2
|
||||||
@ -47,4 +54,9 @@
|
|||||||
&(monster false)
|
&(monster false)
|
||||||
"Implementations may be global, and an implementation with the same name may
|
"Implementations may be global, and an implementation with the same name may
|
||||||
be used as a default.")
|
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