diff --git a/src/Interfaces.hs b/src/Interfaces.hs index 6c2d5fd9..43b4b758 100644 --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -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] ())` ? diff --git a/src/Primitives.hs b/src/Primitives.hs index 9fd33b8f..47ab6b54 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -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 diff --git a/test/interface.carp b/test/interface.carp index 5118982a..470791a4 100644 --- a/test/interface.carp +++ b/test/interface.carp @@ -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.") )