feat: Protocols

CarpHask.cabal

@@ -46,6 +46,7 @@ library
                        Primitives,
                        PrimitiveError
                        Project,
+                       Protocol,
                        Qualify,
                        Reify,
                        RenderDocs,

src/Commands.hs

@@ -950,3 +950,4 @@ commandType ctx (XObj x _ _) =
     typeOf Ref = "ref"
     typeOf Deref = "deref"
     typeOf (Interface _ _) = "interface"
+    typeOf (Protocol _ _) = "protocol"

src/Concretize.hs

@@ -27,6 +27,7 @@ import TypesToC
 import Util
 import Validate
 import Prelude hiding (lookup)
+import Protocol
 
 data Level = Toplevel | Inside
 
@@ -337,13 +338,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
     visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
       case getTypeBinder typeEnv name of
         Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
-          let Just actualType = t
+          let Just actualType = fmap (updateProtocols typeEnv) t
               tys = map (typeFromPath env) interfacePaths
               tysToPathsDict = zip tys interfacePaths
            in case filter (matchingSignature actualType) tysToPathsDict of
                 [] ->
                   pure $ --(trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinLines (map show tysToPathsDict))) $
-                    if allowAmbig
+                    if allowAmbig || containsProtocol actualType
                       then Right xobj -- No exact match of types
                       else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
                 [(theType, singlePath)] ->
@@ -685,7 +686,7 @@ modeFromPath env p =
 concretizeDefinition :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Ty -> Either TypeError (XObj, [XObj])
 concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definition concreteType =
   let SymPath pathStrings name = getPath definition
-      Just polyType = xobjTy definition
+      Just polyType = fmap (updateProtocols typeEnv) (xobjTy definition)
       suffix = polymorphicSuffix polyType concreteType
       newPath = SymPath pathStrings (name ++ suffix)
    in case definition of

src/Constraints.hs

@@ -176,6 +176,18 @@ solveOneInternal mappings constraint =
        in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of
             Left err -> Left err
             Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB])
+    Constraint (ProtocolTy path _) (ProtocolTy path' _) _ _ _ _ ->
+      if path == path'
+        then Right mappings
+        else Left (UnificationFailure constraint mappings)
+    Constraint t (ProtocolTy (SymPath [] key) ts) _ _ _ _ ->
+      if t `elem` ts
+        then Right (Map.insert key t mappings)
+        else Left (UnificationFailure constraint mappings)
+    Constraint (ProtocolTy (SymPath [] key) ts) t _ _ _ _ ->
+      if t `elem` ts
+        then Right (Map.insert key t mappings)
+        else Left (UnificationFailure constraint mappings)
     -- Else
     Constraint aTy bTy _ _ _ _ ->
       if aTy == bTy

src/Emit.hs

@@ -173,6 +173,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
             (Match _) -> dontVisit
             With -> dontVisit
             MetaStub -> dontVisit
+            (Protocol _ _) -> dontVisit
             C c -> pure c
     visitStr' indent str i shouldEscape =
       -- This will allocate a new string every time the code runs:
@@ -925,6 +926,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
       ""
     XObj (Primitive _) _ _ : _ ->
       ""
+    XObj (Protocol _ _) _ _ : _ -> ""
     _ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj)
 toDeclaration _ = error "Missing case."
 

src/Forms.hs

@@ -30,6 +30,7 @@ module Forms
     pattern DoPat,
     pattern WhilePat,
     pattern SetPat,
+    pattern ProtocolPat,
   )
 where
 
@@ -431,5 +432,8 @@ pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym,
 pattern PrimitivePat :: PrimitiveFunctionType -> XObj -> [XObj] -> XObj
 pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat params)]) _ _
 
+pattern ProtocolPat :: XObj -> [SymPath] -> [SymPath] -> XObj
+pattern ProtocolPat name interfaces instances <- XObj (Lst [XObj (Protocol interfaces instances) _ _, name]) _ _
+
 pattern AppPat :: XObj -> [XObj] -> [XObj]
 pattern AppPat f args <- (f : args)

src/InitialTypes.hs

@@ -9,6 +9,7 @@ import qualified Set
 import TypeError
 import Types
 import Util
+import Protocol
 
 -- | Create a fresh type variable (eg. 'VarTy t0', 'VarTy t1', etc...)
 genVarTyWithPrefix :: String -> State Integer Ty
@@ -138,7 +139,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
                 -- Don't rename internal symbols like parameters etc!
                 Just theType
                   | envIsExternal foundEnv -> do
-                    renamed <- renameVarTys theType
+                    renamed <- renameVarTys (updateProtocols typeEnv theType)
                     pure (Right (xobj {xobjTy = Just renamed}))
                   | otherwise -> pure (Right (xobj {xobjTy = Just theType}))
                 Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
@@ -153,7 +154,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
     visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
       do
         freshTy <- case getTypeBinder typeEnv name of
-          Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
+          Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> (renameVarTys (updateProtocols typeEnv interfaceSignature))
           Right (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
           Left _ -> genVarTy
         pure (Right xobj {xobjTy = Just freshTy})

src/Interfaces.hs

@@ -23,6 +23,7 @@ import Obj
 import qualified Qualify
 import Types
 import Util
+import Protocol
 
 data InterfaceError
   = KindMismatch SymPath Ty Ty
@@ -99,7 +100,7 @@ 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
+        then case solve [Constraint (resolveProtocols ctx interfaceSignature) definitionSignature inter inter inter OrdInterfaceImpl] of
           Left _ -> (Right ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
           Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
             Nothing -> (updatedCtx, Nothing)

src/Obj.hs

@@ -128,8 +128,8 @@ instance Show Number where
 -- | The canonical Lisp object.
 data Obj
   = Sym SymPath SymbolMode
-  | MultiSym String [SymPath] -- refering to multiple functions with the same name
-  | InterfaceSym String -- refering to an interface. TODO: rename to InterfaceLookupSym?
+  | MultiSym String [SymPath] -- referring to multiple functions with the same name
+  | InterfaceSym String -- referring to an interface. TODO: rename to InterfaceLookupSym?
   | Num Ty Number
   | Str String
   | Pattern String
@@ -171,6 +171,7 @@ data Obj
   | Deref
   | Interface Ty [SymPath]
   | C String -- C literal
+  | Protocol [SymPath] [SymPath]
   deriving (Show, Eq, Generic)
 
 instance Hashable Obj
@@ -401,6 +402,7 @@ getPath (XObj (Lst (XObj (Mod _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
+getPath (XObj (Lst (XObj (Protocol _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Sym path _) _ _) = path
 getPath x = SymPath [] (pretty x)
 
@@ -486,6 +488,7 @@ pretty = visit 0
         Deref -> "deref"
         Break -> "break"
         Interface _ _ -> "interface"
+        Protocol _ _ -> "defprotocol"
         With -> "with"
 
 prettyUpTo :: Int -> XObj -> String
@@ -551,6 +554,7 @@ prettyUpTo lim xobj =
         Deref -> ""
         Break -> ""
         Interface _ _ -> ""
+        Protocol _ _ -> ""
         With -> ""
 
 prettyCaptures :: Set.Set XObj -> String
@@ -813,8 +817,12 @@ xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy
 xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
 xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
 xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
-xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _)
+xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : rest)) _) _ _)
   | isLower firstLetter = Just (VarTy s)
+  | firstLetter == '!' =
+      if (not (null rest))
+        then Just (ProtocolTy (SymPath [] rest) [])
+        else Nothing
   | otherwise = Just (StructTy (ConcreteNameTy spath) [])
 xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
   do
@@ -890,6 +898,13 @@ polymorphicSuffix signature actualType =
             else do
               put (a : visitedTypeVariables) -- now it's visited
               pure [tyToC b]
+        (p@(ProtocolTy _ _), t) -> do
+          visitedTypeVariables <- get
+          if p `elem` visitedTypeVariables
+            then pure []
+            else do
+              put (p : visitedTypeVariables) -- now it's visited
+              pure [tyToC t]
         (FuncTy argTysA retTyA _, FuncTy argTysB retTyB _) -> do
           visitedArgs <- fmap concat (zipWithM visit argTysA argTysB)
           visitedRets <- visit retTyA retTyB

src/Primitives.hs

@@ -11,7 +11,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Bifunctor
 import Data.Either (fromRight, rights)
 import Data.Functor ((<&>))
-import Data.List (foldl')
+import Data.List (foldl', find)
 import Data.Maybe (fromJust, fromMaybe)
 import Deftype
 import Emit
@@ -37,6 +37,8 @@ import TypePredicates
 import Types
 import Util
 import Web.Browser (openBrowser)
+import Protocol
+import Forms
 
 makeNullaryPrim :: SymPath -> NullaryPrimitiveCallback -> String -> String -> (String, Binder)
 makeNullaryPrim p = makePrim p . NullaryPrimitive
@@ -118,6 +120,32 @@ primitiveColumn x@(XObj _ i _) ctx args =
   where
     err = toEvalError ctx x (MissingInfo x)
 
+-- | Defines a new protocol.
+primitiveProtocol :: VariadicPrimitiveCallback
+primitiveProtocol x ctx (s@(XObj (Sym ppath@(SymPath [] _) _) i _):paths) =
+  let ty = (Just (ProtocolTy ppath []))
+      ps = (map getPath paths)
+      pro = XObj (Lst [XObj (Protocol ps []) i ty, s]) i ty
+      binder = toBinder pro
+   in if (any (not . isSym) paths)
+        -- TODO: Better error here.
+        then pure $ toEvalError ctx x (ArgumentTypeError "defprotocol" "symbols" "other" (fromJust (find (not . isSym) paths)))
+        else case insertTypeBinder ctx (markQualified ppath) binder of
+               Right ctx' -> pure (ctx', dynamicNil)
+               Left err -> pure $ throwErr err ctx (xobjInfo x)
+primitiveProtocol x ctx y = pure $ toEvalError ctx x (ArgumentTypeError "defprotocol" "an unqualified symbol" "first" (head y))
+
+-- | Make a type as an instance of a protocol.
+primitiveInstance :: BinaryPrimitiveCallback
+primitiveInstance x ctx (XObj (Sym protocol@(SymPath _ _) _) _ _) (XObj (Sym path _) _ _) =
+  case registerInstance ctx protocol path of
+    Left err -> pure $ throwErr err ctx (xobjInfo x)
+    Right ctx' -> pure (ctx', dynamicNil)
+primitiveInstance x ctx (XObj (Sym _ _) _ _) y =
+  pure $ toEvalError ctx x (ArgumentTypeError "instance" "a symbol" "second" y)
+primitiveInstance _ ctx x _ =
+  pure $ toEvalError ctx x (ArgumentTypeError "instance" "a symbol" "first" x)
+
 primitiveImplements :: BinaryPrimitiveCallback
 primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sym path _) _ _) =
   do
@@ -281,6 +309,7 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
         let found = lookupBinderInTypeEnv ctx path
         _ <- printIfFound found
         _ <- printInterfaceImplementationsOrAll found otherBindings
+        _ <- printProtocolInterfaces found
         either (const (notFound ctx target path)) (const ok) (found <> fmap head otherBindings)
       where
         otherBindings =
@@ -296,6 +325,10 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
   where
     ok :: IO (Context, Either EvalError XObj)
     ok = pure (ctx, dynamicNil)
+    printProtocolInterfaces :: Either ContextError Binder -> IO ()
+    printProtocolInterfaces (Right (Binder _ (ProtocolPat _ interfaces _))) =
+      putStrLn $ "  Required Definitions: " ++ joinWithComma (map show interfaces)
+    printProtocolInterfaces _ = pure ()
     printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO ()
     printInterfaceImplementationsOrAll interface impls =
       either
@@ -463,15 +496,16 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _
     invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
     validType t = either (const defInterface) updateInterface (lookupBinderInTypeEnv ctx path)
       where
-        defInterface =
-          let interface = defineInterface name t [] (xobjInfo nameXObj)
+        withProtocols = resolveProtocols ctx t
+        defInterface  =
+          let interface = defineInterface name withProtocols [] (xobjInfo nameXObj)
               binder = toBinder interface
               Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder
               Right newCtx = retroactivelyRegisterInInterface ctx' binder
            in (newCtx, dynamicNil)
         updateInterface binder = case binder of
           Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
-            if foundType == t
+            if protocolEq foundType withProtocols
               then (ctx, dynamicNil)
               else
                 evalError