carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 08:27:45 +03:00
Code Issues Projects Releases Wiki Activity

Move interface registration functions into Interfaces.hs

Browse Source 
This PR moves interface handling code out of Primitives.hs and into its
own module. The actual primitives user's rely on to define and implement
interfaces still live in Primitives.hs, but now all the
registration/internal context mgmt code related to interfaces lives in
its own module.

Hopefully this will make it easier to modify and extend!
This commit is contained in:
scottolsen 2020-06-10 01:02:13 -04:00
parent 131dca342d
commit 5955df79c8
3 changed files with 88 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CarpHask.cabal
View File

@ -52,6 +52,7 @@ library
RenderDocs,
StructUtils,
Path,
Interfaces,
Primitives,
Validate

83
src/Interfaces.hs Normal file
View File

@ -0,0 +1,83 @@
-- | This module contains interface registration functions.
-- Interface registration involves associating some concrete form, e.g. a defn with an interface.
-- Registered forms may be used wherever the interface is called.
-- Registrations are stored w/ the interface in the context type environment.
module Interfaces (registerInInterfaceIfNeeded,
registerInInterface,
retroactivelyRegisterInInterface) where
import Data.Either (isRight)
import Obj
import Lookup
import Types
import Util
import Constraints
import Data.List (foldl')
import Debug.Trace
data InterfaceError = KindMismatch SymPath Ty Ty
| TypeMismatch SymPath Ty Ty
| NonInterface SymPath
instance Show InterfaceError where
show (KindMismatch path definitionSignature interfaceSignature) = "[INTERFACE ERROR] " ++ show path ++ ":" ++ " One or more types in the interface implementation " ++
show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++
show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)"
show (TypeMismatch path definitionSignature interfaceSignature) = "[INTERFACE ERROR] " ++ show path ++ " : " ++ show definitionSignature ++
" doesn't match the interface signature " ++ show interfaceSignature
show (NonInterface path) = "[INTERFACE ERROR] " ++ show path ++ "Cant' implement the non-interface `" ++ show path ++ "`"
-- 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 (return ctx) (typeCheck . snd) (lookupInEnv interface typeEnv)
where 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
-- N.B. the xobjs aren't important here--we only care about types,
-- thus we pass inter to all three xobj positions.
then 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
-- 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) ->
-- This is a function, does it belong to an interface?
registerInInterfaceIfNeeded ctx path interface t
XObj (Lst [XObj (Deftemplate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
-- Templates should also be registered.
registerInInterfaceIfNeeded ctx path interface t
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-- Global variables can also be part of an interface
registerInInterfaceIfNeeded ctx path interface t
-- So can externals!
XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path 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
_ -> return 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 _ inter) =
-- 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

55
src/Primitives.hs
View File

@ -22,6 +22,7 @@ import Template
import ToTemplate
import Info
import qualified Meta as Meta
import Interfaces
import Debug.Trace
@ -117,7 +118,7 @@ primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), i@(X
notFound = checkInterface >>
primitiveMetaSet xobj ctx [i, XObj (Str "implements") (Just dummyInfo) (Just StringTy), XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy)]
found (_, Binder meta defobj) = checkInterface >>
either registerError updateImpls (registerDefnOrDefInInterfaceIfNeeded ctx defobj interface)
either registerError updateImpls (registerInInterface ctx defobj interface)
where registerError e = do case contextExecMode ctx of
Check -> let fppl = projectFilePathPrintLength (contextProj ctx)
in putStrLn (machineReadableInfoFromXObj fppl defobj ++ " " ++ e)
@ -143,45 +144,6 @@ primitiveImplements x@(XObj _ i t) ctx args =
return $ evalError
ctx ("`implements` expected 2 arguments, but got " ++ show (length args)) (info x)
registerInInterfaceIfNeeded :: Context -> SymPath -> SymPath -> Ty -> Either String Context
registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature =
let typeEnv = getTypeEnv (contextTypeEnv ctx)
in case lookupInEnv interface typeEnv of
Just (_, Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t)) ->
if checkKinds interfaceSignature definitionSignature
-- N.B. the xobjs aren't important here--we only care about types,
-- thus we pass inter to all three xobj positions.
then 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 return $ ctx { contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface) }
else Left ("[INTERFACE ERROR] " ++ show path ++ " : " ++ show definitionSignature ++
" doesn't match the interface signature " ++ show interfaceSignature)
else Left ("[INTERFACE ERROR] " ++ show path ++ ":" ++ " One or more types in the interface implementation " ++ show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++ show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)")
Just (_, Binder _ x) ->
error ("Can't implement the non-interface '" ++ name ++ "' in the type environment: " ++ show x)
Nothing -> return ctx
-- | Given an XObj and an interface path, ensure that a 'def' / 'defn' is
-- registered with the interface.
registerDefnOrDefInInterfaceIfNeeded :: Context -> XObj -> SymPath -> Either String Context
registerDefnOrDefInInterfaceIfNeeded ctx xobj interface =
case xobj of
XObj (Lst [XObj (Defn _) _ _, XObj (Sym path _) _ _, _, _]) _ (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) ->
-- Templates should also be registered.
registerInInterfaceIfNeeded ctx path interface t
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-- Global variables can also be part of an interface
registerInInterfaceIfNeeded ctx path interface t
-- So can externals!
XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path 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
_ -> return ctx
define :: Bool -> Context -> XObj -> IO Context
define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
@ -213,7 +175,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
Nothing -> return ()
case Meta.get "implements" previousMeta of
Just (XObj (Lst interfaces) _ _) ->
do let result = foldM (\ctx (xobj, interface) -> registerDefnOrDefInInterfaceIfNeeded ctx xobj interface) ctx (zip (cycle [annXObj]) (map getPath 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
@ -434,15 +396,6 @@ primitiveMetaSet _ ctx [XObj (Sym _ _) _ _, key, _] =
primitiveMetaSet _ ctx [target, _, _] =
argumentErr ctx "meta-set!" "a symbol" "first" target
retroactivelyRegisterInterfaceFunctions :: Context -> SymPath -> Context
retroactivelyRegisterInterfaceFunctions ctx interface@(SymPath _ inter) =
-- 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 = registerDefnOrDefInInterfaceIfNeeded ok (binderXObj binder) interface
primitiveDefinterface :: Primitive
primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _), ty] =
@ -453,7 +406,7 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
validType t = maybe defInterface (updateInterface . snd) (lookupInEnv path typeEnv)
where defInterface = let interface = defineInterface name t [] (info nameXObj)
typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface))
newCtx = retroactivelyRegisterInterfaceFunctions (ctx { contextTypeEnv = typeEnv' }) path
newCtx = retroactivelyRegisterInInterface (ctx { contextTypeEnv = typeEnv' }) path
in (newCtx, dynamicNil)
updateInterface binder = case binder of
Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->