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

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

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

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