refactor: improve readability of interface functions (#1053)

* refactor: improve readability of interface functions

Also refactors the `define` function for readability.

The old definitions of these functions were quite unwieldy and difficult
to read. This refactor attempts to make the monadic contexts we're
juggling (often 3, Maybe, IO, Either) easier to spot.

* refactor: Add context env updaters; refactor prims

This commit contains a few more cleanups of the interface and define
functions in Primitives. It also defines a new context module for
holding functions that update context environments.

CarpHask.cabal

@@ -47,6 +47,7 @@ library
                        Expand,
                        Scoring,
                        Lookup,
+                       Context,
                        Qualify,
                        Repl,
                        StartingEnv,

src/Context.hs

@@ -0,0 +1,19 @@
+module Context
+  ( insertInGlobalEnv,
+    insertInTypeEnv,
+  )
+where
+
+import Lookup
+import Obj
+import SymPath
+
+insertInGlobalEnv :: Context -> SymPath -> Binder -> Context
+insertInGlobalEnv ctx path binder =
+  let globalEnv = contextGlobalEnv ctx
+   in ctx {contextGlobalEnv = envInsertAt globalEnv path binder}
+
+insertInTypeEnv :: Context -> SymPath -> Binder -> Context
+insertInTypeEnv ctx path binder =
+  let typeEnv = getTypeEnv (contextTypeEnv ctx)
+   in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv path binder)}

src/Interfaces.hs

@@ -11,8 +11,7 @@ where
 
 import ColorText
 import Constraints
-import Data.Either (isRight)
-import Data.List (foldl')
+import Control.Monad (foldM)
 import Lookup
 import Obj
 import Types
@@ -48,58 +47,53 @@ instance Show InterfaceError where
 
 -- 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 -> SymPath -> SymPath -> Ty -> Either String Context
-registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature =
-  maybe (pure ctx) (typeCheck . snd) (lookupInEnv interface typeEnv)
+registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> Either String Context
+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)
+      where
+        updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
+    _ ->
+      Left (show $ NonInterface (getBinderPath interface))
   where
+    implPath = (getBinderPath implementation)
     typeEnv = getTypeEnv (contextTypeEnv ctx)
-    typeCheck binder = case binder of
-      Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
-        if checkKinds interfaceSignature definitionSignature
-          then -- N.B. the xobjs aren't important here--we only care about types,
-          -- thus we pass inter to all three xobj positions.
+    (SymPath _ name) = getBinderPath interface
 
-            if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl]
-              then
-                let updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent path paths)) ii it, isym]) i t
-                 in Right $ ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
-              else Left (show $ TypeMismatch path definitionSignature interfaceSignature)
-          else Left (show $ KindMismatch path definitionSignature interfaceSignature)
-      _ ->
-        Left (show $ NonInterface interface)
-
--- | Given an XObj 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.
-registerInInterface :: Context -> XObj -> SymPath -> Either String Context
-registerInInterface ctx xobj interface =
-  case xobj of
-    XObj (Lst [XObj (Defn _) _ _, XObj (Sym path _) _ _, _, _]) _ (Just t) ->
+registerInInterface :: Context -> Binder -> Binder -> Either String Context
+registerInInterface ctx implementation interface =
+  case (binderXObj implementation) of
+    XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
       -- This is a function, does it belong to an interface?
-      registerInInterfaceIfNeeded ctx path interface t
-    XObj (Lst [XObj (Deftemplate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
+      registerInInterfaceIfNeeded ctx implementation interface t
+    XObj (Lst [XObj (Deftemplate _) _ _, _]) _ (Just t) ->
       -- Templates should also be registered.
-      registerInInterfaceIfNeeded ctx path interface t
-    XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
+      registerInInterfaceIfNeeded ctx implementation interface t
+    XObj (Lst [XObj Def _ _, _, _]) _ (Just t) ->
       -- Global variables can also be part of an interface
-      registerInInterfaceIfNeeded ctx path interface t
+      registerInInterfaceIfNeeded ctx implementation interface t
     -- So can externals!
-    XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-      registerInInterfaceIfNeeded ctx path interface t
+    XObj (Lst [XObj (External _) _ _, _, _]) _ (Just t) ->
+      registerInInterfaceIfNeeded ctx implementation interface t
     -- And instantiated/auto-derived type functions! (e.g. Pair.a)
-    XObj (Lst [XObj (Instantiate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
-      registerInInterfaceIfNeeded ctx path interface t
+    XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
+      registerInInterfaceIfNeeded ctx implementation interface t
     _ -> pure ctx
 
 -- | 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 -> SymPath -> Context
-retroactivelyRegisterInInterface ctx interface@(SymPath _ _) =
+retroactivelyRegisterInInterface :: Context -> Binder -> Context
+retroactivelyRegisterInInterface ctx interface =
   -- TODO: Don't use error here?
   either (\e -> error e) id resultCtx
   where
     env = contextGlobalEnv ctx
-    impls = recursiveLookupAll interface lookupImplementations env
-    resultCtx = foldl' folder (Right ctx) impls
-    folder ctx' binder = either Left register' ctx'
-      where
-        register' ok = registerInInterface ok (binderXObj binder) interface
+    impls = recursiveLookupAll (getPath (binderXObj interface)) lookupImplementations env
+    resultCtx = foldM (\context binder -> registerInInterface context binder interface) ctx impls

src/Obj.hs

@@ -176,6 +176,12 @@ isExternalFunction :: XObj -> Bool
 isExternalFunction (XObj (Lst (XObj (External _) _ _ : _)) _ _) = True
 isExternalFunction _ = False
 
+isTypeDef :: XObj -> Bool
+isTypeDef (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _) = True
+isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
+isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
+isTypeDef _ = False
+
 -- | This instance is needed for the dynamic Dictionary
 instance Ord Obj where
   compare (Str a) (Str b) = compare a b
@@ -299,6 +305,9 @@ getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) =
 getPath (XObj (Sym path _) _ _) = path
 getPath x = SymPath [] (pretty x)
 
+getBinderPath :: Binder -> SymPath
+getBinderPath = getPath . binderXObj
+
 -- | Changes the second form (where the name of definitions are stored) in a list of XObj:s.
 setPath :: XObj -> SymPath -> XObj
 setPath (XObj (Lst (defn@(XObj (Defn _) _ _) : XObj (Sym _ _) si st : rest)) i t) newPath =

src/Primitives.hs

@@ -2,12 +2,13 @@ module Primitives where
 
 import ColorText
 import Commands
+import Context
 import Control.Applicative
 import Control.Monad (foldM, unless, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Either (rights)
 import Data.List (union)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe)
 import Deftype
 import Emit
 import Infer
@@ -151,65 +152,64 @@ primitiveColumn x@(XObj _ i t) ctx args =
     go = maybe err (\info -> (ctx, Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t)))
 
 primitiveImplements :: Primitive
-primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inner@(XObj (Sym impl@(SymPath prefixes name) _) info _)] =
-  let global = contextGlobalEnv ctx
-      def = lookupInEnv impl global
-   in maybe notFound' found def
+primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) info _)] =
+  do
+    (maybeInterface, maybeImpl) <- pure ((lookupInEnv interface tyEnv), (lookupInEnv (SymPath modules name) global))
+    case (maybeInterface, maybeImpl) of
+      (_, Nothing) ->
+        if null modules
+          then pure (evalError ctx "Can't set the `implements` meta on a global definition before it is declared." info)
+          else updateMeta (Meta.stub (SymPath modules name)) ctx
+      (Nothing, Just (_, implBinder)) ->
+        (warn >> updateMeta implBinder ctx)
+      (Just (_, interfaceBinder), Just (_, implBinder)) ->
+        (addToInterface interfaceBinder implBinder)
   where
+    global = contextGlobalEnv ctx
+    tyEnv = getTypeEnv . contextTypeEnv $ ctx
     (SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
-    checkInterface =
-      let warn = do
-            emitWarning
-              ( "The interface " ++ show interface ++ " implemented by " ++ show impl
-                  ++ " at "
-                  ++ prettyInfoFromXObj xobj
-                  ++ " is not defined."
-                  ++ " Did you define it using `definterface`?"
-              )
-          tyEnv = getTypeEnv . contextTypeEnv $ ctx
-       in maybe warn (\_ -> pure ()) (lookupInEnv interface tyEnv)
-    -- If the implementation binding doesn't exist yet, set the implements
-    -- meta. This enables specifying a function as an implementation before
-    -- defining it.
-    --
-    -- This is only allowed for qualified bindings. Allowing forward declarations on global bindings would cause a loop in
-    -- primitiveMetaSet's lookup which is generic.
-    notFound' =
-      if null modules
-        then pure $ evalError ctx "Can't set the `implements` meta on a global definition before it is declared." info
-        else
-          ( checkInterface
-              >> primitiveMetaSet xobj ctx [inner, XObj (Str "implements") (Just dummyInfo) (Just StringTy), XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy)]
-          )
-    found (_, Binder meta defobj) =
-      checkInterface
-        >> either registerError updateImpls (registerInInterface ctx defobj interface)
+    warn =
+      emitWarning
+        ( "The interface "
+            ++ show (getPath x)
+            ++ " is not defined."
+            ++ " Did you define it using `definterface`?"
+        )
+
+    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
-        registerError e = do
-          case contextExecMode ctx of
-            Check ->
-              let fppl = projectFilePathPrintLength (contextProj ctx)
-               in putStrLn (machineReadableInfoFromXObj fppl defobj ++ " " ++ e)
-            _ -> putStrLnWithColor Red e
-          pure $ evalError ctx e (xobjInfo x)
-        updateImpls ctx' = do
-          currentImplementations <- primitiveMeta xobj ctx [inner, XObj (Str "implements") (Just dummyInfo) (Just StringTy)]
-          pure $ either metaError existingImpls (snd currentImplementations)
-          where
-            metaError e = (ctx, Left e)
-            existingImpls is = case is of
-              old@(XObj (Lst impls) inf ty) ->
-                let newImpls =
-                      if x `elem` impls
-                        then old
-                        else XObj (Lst (x : impls)) inf ty
-                    newMeta = Meta.set "implements" newImpls meta
-                 in (ctx' {contextGlobalEnv = envInsertAt global (getPath defobj) (Binder newMeta defobj)}, dynamicNil)
-              _ ->
-                let impls = XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy)
-                    newMeta = Meta.set "implements" impls meta
-                 in (ctx' {contextGlobalEnv = envInsertAt global (getPath defobj) (Binder newMeta defobj)}, dynamicNil)
-            global = contextGlobalEnv ctx
+        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 =
+      pure (fromJust update, dynamicNil)
+      where
+        update =
+          ( ( Meta.getBinderMetaValue "implements" binder
+                >>= pure . updateImplementations binder
+            )
+              <|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
+          )
+            >>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt global (getBinderPath binder) newBinder})
+
+        updateImplementations :: Binder -> XObj -> Binder
+        updateImplementations implBinder (XObj (Lst impls) inf ty) =
+          if x `elem` impls
+            then binder
+            else Meta.updateBinderMeta implBinder "implements" (XObj (Lst (x : impls)) inf ty)
+        updateImplementations implBinder _ =
+          Meta.updateBinderMeta implBinder "implements" (XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy))
 primitiveImplements _ ctx [x, _] =
   pure $ evalError ctx ("`implements` expects symbol arguments.") (xobjInfo x)
 primitiveImplements x@(XObj _ _ _) ctx args =
@@ -221,53 +221,67 @@ primitiveImplements x@(XObj _ _ _) ctx args =
 
 define :: Bool -> Context -> XObj -> IO Context
 define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
-  let previousType =
-        case lookupInEnv (getPath annXObj) globalEnv of
-          Just (_, Binder _ found) -> xobjTy found
-          Nothing -> Nothing
-      previousMeta = existingMeta globalEnv annXObj
-      adjustedMeta =
-        if hidden
-          then Meta.set "hidden" trueXObj previousMeta
-          else previousMeta
-   in case annXObj of
-        XObj (Lst (XObj (Defalias _) _ _ : _)) _ _ ->
-          pure (ctx {contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv typeEnv) (getPath annXObj) (Binder adjustedMeta annXObj))})
-        XObj (Lst (XObj (Deftype _) _ _ : _)) _ _ ->
-          pure (ctx {contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv typeEnv) (getPath annXObj) (Binder adjustedMeta annXObj))})
-        XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _ ->
-          pure (ctx {contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv typeEnv) (getPath annXObj) (Binder adjustedMeta annXObj))})
-        _ ->
-          do
-            when (projectEchoC proj) $
-              putStrLn (toC All (Binder emptyMeta annXObj))
-            case previousType of
-              Just previousTypeUnwrapped ->
-                unless (areUnifiable (forceTy annXObj) previousTypeUnwrapped) $
-                  do
-                    emitWarning
-                      ( "Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj)
-                          ++ "' from "
-                          ++ show previousTypeUnwrapped
-                          ++ " to "
-                          ++ show (forceTy annXObj)
-                      )
-              Nothing -> pure ()
-            case Meta.get "implements" previousMeta of
-              Just (XObj (Lst interfaces) _ _) ->
-                do
-                  let result = foldM (\ctx' (xobj, interface) -> registerInInterface ctx' xobj interface) ctx (zip (cycle [annXObj]) (map getPath interfaces))
-                  case result of
-                    Left err ->
-                      do
-                        case contextExecMode ctx of
-                          Check ->
-                            let fppl = projectFilePathPrintLength (contextProj ctx)
-                             in putStrLn (machineReadableInfoFromXObj fppl annXObj ++ " " ++ err)
-                          _ -> putStrLnWithColor Red err
-                        pure ctx
-                    Right ctx' -> pure (ctx' {contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj)})
-              _ -> pure (ctx {contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj)})
+  pure (hideIt freshBinder)
+    >>= \newBinder ->
+      if isTypeDef annXObj
+        then defineInTypeEnv newBinder
+        else defineInGlobalEnv newBinder
+  where
+    freshBinder = (Binder emptyMeta annXObj)
+
+    defineInTypeEnv :: Binder -> IO Context
+    defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder)
+    defineInGlobalEnv :: Binder -> IO Context
+    defineInGlobalEnv fallbackBinder =
+      do
+        maybeExistingBinder <- pure (lookupInEnv (getPath annXObj) globalEnv)
+        when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj)))
+        case maybeExistingBinder of
+          Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder)
+          Just (_, binder) -> redefineExistingBinder binder
+    redefineExistingBinder :: Binder -> IO Context
+    redefineExistingBinder old@(Binder meta _) =
+      do
+        updatedBinder <- pure (hideIt (Binder meta annXObj))
+        warnTypeChange old
+        updatedContext <- implementInterfaces updatedBinder
+        pure (insertInGlobalEnv updatedContext (getPath annXObj) updatedBinder)
+    hideIt :: Binder -> Binder
+    hideIt binder =
+      if hidden
+        then Meta.updateBinderMeta binder "hidden" trueXObj
+        else binder
+    warnTypeChange :: Binder -> IO ()
+    warnTypeChange binder =
+      unless (areUnifiable (forceTy annXObj) previousType) warn
+      where
+        previousType = forceTy (binderXObj binder)
+        warn =
+          emitWarning
+            ( "Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj)
+                ++ "' from "
+                ++ show previousType
+                ++ " to "
+                ++ show (forceTy annXObj)
+            )
+    implementInterfaces :: Binder -> IO Context
+    implementInterfaces binder =
+      pure
+        ( Meta.getBinderMetaValue "implements" binder
+            >>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces)
+        )
+        >>= \maybeinterfaces ->
+          pure (map snd (catMaybes (map ((flip lookupInEnv) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))))
+            >>= \interfaceBinders ->
+              pure (foldM (\ctx' interface -> registerInInterface ctx' binder interface) ctx interfaceBinders)
+                >>= \result -> case result of
+                  Left e -> ((printError (contextExecMode ctx) e) >> pure ctx)
+                  Right newCtx -> (pure newCtx)
+    printError :: ExecutionMode -> String -> IO ()
+    printError Check e =
+      let fppl = projectFilePathPrintLength (contextProj ctx)
+       in putStrLn (machineReadableInfoFromXObj fppl annXObj ++ " " ++ e)
+    printError _ e = putStrLnWithColor Red e
 
 primitiveRegisterType :: Primitive
 primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] =
@@ -535,7 +549,7 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
         defInterface =
           let interface = defineInterface name t [] (xobjInfo nameXObj)
               typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface))
-              newCtx = retroactivelyRegisterInInterface (ctx {contextTypeEnv = typeEnv'}) path
+              newCtx = retroactivelyRegisterInInterface (ctx {contextTypeEnv = typeEnv'}) (Binder emptyMeta interface)
            in (newCtx, dynamicNil)
         updateInterface binder = case binder of
           Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
@@ -712,13 +726,18 @@ primitiveDeftype xobj ctx (name : rest) =
                     )
                in do
                     ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
-                    let ctxWithInterfaceRegistrations =
+                    let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)))
+                        strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
+                        copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
+                        Just (_, strInterface) = lookupInEnv (SymPath [] "str") (getTypeEnv typeEnv)
+                        Just (_, copyInterface) = lookupInEnv (SymPath [] "copy") (getTypeEnv typeEnv)
+                        ctxWithInterfaceRegistrations =
                           -- 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
-                            [ (SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy, (SymPath [] "str")),
-                              (SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy, (SymPath [] "copy"))
+                            [ ((fakeImplBinder (SymPath (pathStrings ++ [typeModuleName]) "str") strSig), strSig, strInterface),
+                              ((fakeImplBinder (SymPath (pathStrings ++ [typeModuleName]) "copy") copySig), copySig, copyInterface)
                             ]
                     case ctxWithInterfaceRegistrations of
                       Left err -> do