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:
Scott Olsen 2020-12-23 16:24:52 -05:00 committed by GitHub
parent 5999f58347
commit d420635762
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 158 additions and 65 deletions

View File

@ -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] ())` ?

View File

@ -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

View File

@ -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.")
)