mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 16:38:14 +03:00
chore: Fix hlint warnings (#1086)
This commit is contained in:
parent
e396863719
commit
32d7396174
@ -20,7 +20,7 @@ templateEMap =
|
||||
documentation
|
||||
where
|
||||
templateType =
|
||||
(FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy)
|
||||
FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy
|
||||
endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
|
||||
arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
||||
documentation =
|
||||
@ -30,7 +30,7 @@ templateEMap =
|
||||
Template
|
||||
templateType
|
||||
(templateLiteral "Array $NAME(Lambda *f, Array a)")
|
||||
( \(FuncTy [_, (StructTy (ConcreteNameTy "Array") [memberTy])] _ _) ->
|
||||
( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) ->
|
||||
handleUnits memberTy
|
||||
)
|
||||
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
|
||||
@ -107,10 +107,10 @@ templatePushBack :: (String, Binder)
|
||||
templatePushBack =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = (SymPath ["Array"] "push-back")
|
||||
path = SymPath ["Array"] "push-back"
|
||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
||||
valTy = VarTy "a"
|
||||
t = (FuncTy [aTy, valTy] aTy StaticLifetimeTy)
|
||||
t = FuncTy [aTy, valTy] aTy StaticLifetimeTy
|
||||
docs = "adds an element `value` to the end of an array `a`."
|
||||
declaration :: String -> [Token]
|
||||
declaration setter =
|
||||
@ -145,10 +145,10 @@ templatePushBackBang :: (String, Binder)
|
||||
templatePushBackBang =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = (SymPath ["Array"] "push-back!")
|
||||
path = SymPath ["Array"] "push-back!"
|
||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
||||
valTy = VarTy "a"
|
||||
t = (FuncTy [aTy, valTy] UnitTy StaticLifetimeTy)
|
||||
t = FuncTy [aTy, valTy] UnitTy StaticLifetimeTy
|
||||
docs = "adds an element `value` to the end of an array `a` in-place."
|
||||
declaration :: String -> [Token]
|
||||
declaration setter =
|
||||
@ -190,7 +190,7 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "Array $NAME(Array a)"))
|
||||
( \(FuncTy [(StructTy _ [insideTy])] _ _) ->
|
||||
( \(FuncTy [StructTy _ [insideTy]] _ _) ->
|
||||
let deleteElement = insideArrayDeletion typeEnv env insideTy
|
||||
in toTemplate
|
||||
( unlines
|
||||
@ -213,9 +213,9 @@ templatePopBackBang :: (String, Binder)
|
||||
templatePopBackBang =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = (SymPath ["Array"] "pop-back!")
|
||||
path = SymPath ["Array"] "pop-back!"
|
||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
||||
t = (FuncTy [aTy] (VarTy "a") StaticLifetimeTy)
|
||||
t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy
|
||||
docs = "removes an element `value` from the end of an array `a` in-place and returns it."
|
||||
creator =
|
||||
TemplateCreator $
|
||||
@ -352,7 +352,7 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
UnitTy -> unitSetterTemplate
|
||||
_ ->
|
||||
let deleter = insideArrayDeletion typeEnv env insideTy
|
||||
in ( multilineTemplate
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
" Array a = *aRef;",
|
||||
" assert(n >= 0);",
|
||||
@ -362,7 +362,6 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
"}"
|
||||
]
|
||||
)
|
||||
)
|
||||
( \(FuncTy [RefTy arrayType _, _, _] _ _) ->
|
||||
depsForDeleteFunc typeEnv env arrayType
|
||||
)
|
||||
@ -388,7 +387,7 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator
|
||||
case valueType of
|
||||
UnitTy -> unitSetterTemplate
|
||||
_ ->
|
||||
( multilineTemplate
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
" Array a = *aRef;",
|
||||
" assert(n >= 0);",
|
||||
@ -397,7 +396,6 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator
|
||||
"}"
|
||||
]
|
||||
)
|
||||
)
|
||||
(const [])
|
||||
|
||||
templateLength :: (String, Binder)
|
||||
@ -462,7 +460,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
|
||||
++ deleteTy typeEnv env arrayType
|
||||
++ [TokC "}\n"]
|
||||
)
|
||||
( \(FuncTy [(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
|
||||
( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) ->
|
||||
depsForDeleteFunc typeEnv env insideType
|
||||
)
|
||||
|
||||
@ -619,15 +617,15 @@ calculateStrSize :: TypeEnv -> Env -> Ty -> String
|
||||
calculateStrSize typeEnv env t =
|
||||
case t of
|
||||
-- If the member type is Unit, don't access the element.
|
||||
UnitTy -> makeTemplate (\functionName -> (functionName ++ "();"))
|
||||
_ -> makeTemplate (\functionName -> (functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);"))
|
||||
UnitTy -> makeTemplate (++ "();")
|
||||
_ -> makeTemplate (++ "(" ++ strTakesRefOrNot typeEnv env t ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
|
||||
where
|
||||
makeTemplate :: (String -> String) -> String
|
||||
makeTemplate strcall =
|
||||
unlines
|
||||
[ " int size = 3; // opening and closing brackets and terminator",
|
||||
" for(int i = 0; i < a->len; i++) {",
|
||||
(arrayMemberSizeCalc strcall) ++ " }",
|
||||
arrayMemberSizeCalc strcall ++ " }",
|
||||
""
|
||||
]
|
||||
-- Get the size of the member type's string representation
|
||||
@ -649,8 +647,8 @@ calculateStrSize typeEnv env t =
|
||||
insideArrayStr :: TypeEnv -> Env -> Ty -> String
|
||||
insideArrayStr typeEnv env t =
|
||||
case t of
|
||||
UnitTy -> makeTemplate (\functionName -> functionName ++ "();")
|
||||
_ -> makeTemplate (\functionName -> functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
|
||||
UnitTy -> makeTemplate (++ "();")
|
||||
_ -> makeTemplate (++ "(" ++ strTakesRefOrNot typeEnv env t ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
|
||||
where
|
||||
makeTemplate :: (String -> String) -> String
|
||||
makeTemplate strcall =
|
||||
|
@ -39,10 +39,10 @@ emitErrorWithLabel :: String -> String -> IO ()
|
||||
emitErrorWithLabel label str = putStrLnWithColor Red (labelStr label str)
|
||||
|
||||
emitError :: String -> IO ()
|
||||
emitError str = emitErrorWithLabel "ERROR" str
|
||||
emitError = emitErrorWithLabel "ERROR"
|
||||
|
||||
emitErrorBare :: String -> IO ()
|
||||
emitErrorBare str = putStrLnWithColor Red str
|
||||
emitErrorBare = putStrLnWithColor Red
|
||||
|
||||
emitErrorAndExit :: String -> IO a
|
||||
emitErrorAndExit str = do
|
||||
|
@ -5,6 +5,7 @@ import Control.Exception
|
||||
import Control.Monad (join, when)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Bits (finiteBitSize)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Hashable (hash)
|
||||
import Data.List (elemIndex)
|
||||
import Data.List.Split (splitOn)
|
||||
@ -232,7 +233,7 @@ commandProjectGetConfig ctx xobj@(XObj (Str key) _ _) =
|
||||
_ -> Left key
|
||||
in pure $ case getVal ctx of
|
||||
Right val -> (ctx, Right $ xstr val)
|
||||
Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj))
|
||||
Left k -> evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj)
|
||||
commandProjectGetConfig ctx faultyKey =
|
||||
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
|
||||
|
||||
@ -337,7 +338,8 @@ commandBuild shutUp ctx = do
|
||||
in liftIO $ do
|
||||
when echoCompilationCommand (putStrLn cmd)
|
||||
callCommand cmd
|
||||
when (execMode == Repl && not shutUp) $
|
||||
when
|
||||
(execMode == Repl && not shutUp)
|
||||
(putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)")))
|
||||
pure (setProjectCanExecute hasMain ctx, dynamicNil)
|
||||
liftIO $ createDirectoryIfMissing False outDir
|
||||
@ -377,12 +379,12 @@ commandProject ctx = do
|
||||
-- | Command for getting the name of the operating system you're on.
|
||||
commandHostOS :: NullaryCommandCallback
|
||||
commandHostOS ctx =
|
||||
pure (ctx, (Right (XObj (Str os) (Just dummyInfo) (Just StringTy))))
|
||||
pure (ctx, Right (XObj (Str os) (Just dummyInfo) (Just StringTy)))
|
||||
|
||||
-- | Command for getting the native architecture.
|
||||
commandHostArch :: NullaryCommandCallback
|
||||
commandHostArch ctx =
|
||||
pure (ctx, (Right (XObj (Str arch) (Just dummyInfo) (Just StringTy))))
|
||||
pure (ctx, Right (XObj (Str arch) (Just dummyInfo) (Just StringTy)))
|
||||
|
||||
-- | Command for adding a header file include to the project.
|
||||
commandAddInclude :: (String -> Includer) -> UnaryCommandCallback
|
||||
@ -446,9 +448,9 @@ commandLength :: UnaryCommandCallback
|
||||
commandLength ctx x =
|
||||
pure $ case x of
|
||||
XObj (Lst lst) _ _ ->
|
||||
(ctx, (Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing)))
|
||||
(ctx, Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing))
|
||||
XObj (Arr arr) _ _ ->
|
||||
(ctx, (Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing)))
|
||||
(ctx, Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing))
|
||||
_ -> evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (xobjInfo x)
|
||||
|
||||
commandCar :: UnaryCommandCallback
|
||||
@ -532,22 +534,22 @@ commandEq ctx a b =
|
||||
cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb
|
||||
cmp (XObj (Sym sa _) _ _, XObj (Sym sb _) _ _) = Right $ sa == sb
|
||||
cmp (XObj (Bol xa) _ _, XObj (Bol xb) _ _) = Right $ xa == xb
|
||||
cmp (XObj Def _ _, XObj Def _ _) = Right $ True
|
||||
cmp (XObj Do _ _, XObj Do _ _) = Right $ True
|
||||
cmp (XObj Let _ _, XObj Let _ _) = Right $ True
|
||||
cmp (XObj While _ _, XObj While _ _) = Right $ True
|
||||
cmp (XObj Break _ _, XObj Break _ _) = Right $ True
|
||||
cmp (XObj If _ _, XObj If _ _) = Right $ True
|
||||
cmp (XObj With _ _, XObj With _ _) = Right $ True
|
||||
cmp (XObj MetaStub _ _, XObj MetaStub _ _) = Right $ True
|
||||
cmp (XObj Address _ _, XObj Address _ _) = Right $ True
|
||||
cmp (XObj SetBang _ _, XObj SetBang _ _) = Right $ True
|
||||
cmp (XObj Macro _ _, XObj Macro _ _) = Right $ True
|
||||
cmp (XObj Dynamic _ _, XObj Dynamic _ _) = Right $ True
|
||||
cmp (XObj DefDynamic _ _, XObj DefDynamic _ _) = Right $ True
|
||||
cmp (XObj The _ _, XObj The _ _) = Right $ True
|
||||
cmp (XObj Ref _ _, XObj Ref _ _) = Right $ True
|
||||
cmp (XObj Deref _ _, XObj Deref _ _) = Right $ True
|
||||
cmp (XObj Def _ _, XObj Def _ _) = Right True
|
||||
cmp (XObj Do _ _, XObj Do _ _) = Right True
|
||||
cmp (XObj Let _ _, XObj Let _ _) = Right True
|
||||
cmp (XObj While _ _, XObj While _ _) = Right True
|
||||
cmp (XObj Break _ _, XObj Break _ _) = Right True
|
||||
cmp (XObj If _ _, XObj If _ _) = Right True
|
||||
cmp (XObj With _ _, XObj With _ _) = Right True
|
||||
cmp (XObj MetaStub _ _, XObj MetaStub _ _) = Right True
|
||||
cmp (XObj Address _ _, XObj Address _ _) = Right True
|
||||
cmp (XObj SetBang _ _, XObj SetBang _ _) = Right True
|
||||
cmp (XObj Macro _ _, XObj Macro _ _) = Right True
|
||||
cmp (XObj Dynamic _ _, XObj Dynamic _ _) = Right True
|
||||
cmp (XObj DefDynamic _ _, XObj DefDynamic _ _) = Right True
|
||||
cmp (XObj The _ _, XObj The _ _) = Right True
|
||||
cmp (XObj Ref _ _, XObj Ref _ _) = Right True
|
||||
cmp (XObj Deref _ _, XObj Deref _ _) = Right True
|
||||
cmp (XObj (Lst []) _ _, XObj (Lst []) _ _) = Right True
|
||||
cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) =
|
||||
if length elemsA == length elemsB
|
||||
@ -564,7 +566,7 @@ commandEq ctx a b =
|
||||
cmp' elt (Right True) = cmp elt
|
||||
|
||||
commandComp :: (Number -> Number -> Bool) -> String -> BinaryCommandCallback
|
||||
commandComp op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) | aTy == bTy = pure $ (ctx, Right (boolToXObj (op aNum bNum)))
|
||||
commandComp op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) | aTy == bTy = pure (ctx, Right (boolToXObj (op aNum bNum)))
|
||||
commandComp _ opname ctx a b = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (xobjInfo a)
|
||||
|
||||
commandLt :: BinaryCommandCallback
|
||||
@ -616,7 +618,7 @@ commandStringConcat ctx a =
|
||||
|
||||
commandStringSplitOn :: BinaryCommandCallback
|
||||
commandStringSplitOn ctx (XObj (Str sep) _ _) (XObj (Str s) _ _) =
|
||||
pure $ (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing))
|
||||
pure (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing))
|
||||
where
|
||||
xstr o = XObj (Str o) (Just dummyInfo) (Just StringTy)
|
||||
commandStringSplitOn ctx sep s =
|
||||
@ -633,7 +635,7 @@ commandSymConcat ctx a =
|
||||
|
||||
commandSymPrefix :: BinaryCommandCallback
|
||||
commandSymPrefix ctx (XObj (Sym (SymPath [] prefix) _) _ _) (XObj (Sym (SymPath [] suffix) _) i t) =
|
||||
pure $ (ctx, Right (XObj (Sym (SymPath [prefix] suffix) (LookupGlobal CarpLand AVariable)) i t))
|
||||
pure (ctx, Right (XObj (Sym (SymPath [prefix] suffix) (LookupGlobal CarpLand AVariable)) i t))
|
||||
commandSymPrefix ctx x (XObj (Sym (SymPath [] _) _) _ _) =
|
||||
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (xobjInfo x)
|
||||
commandSymPrefix ctx _ x =
|
||||
@ -670,13 +672,13 @@ commandPathAbsolute ctx a =
|
||||
case a of
|
||||
XObj (Str s) _ _ -> do
|
||||
abs <- makeAbsolute s
|
||||
pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
|
||||
pure (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
|
||||
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
|
||||
|
||||
commandArith :: (Number -> Number -> Number) -> String -> BinaryCommandCallback
|
||||
commandArith op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _)
|
||||
| aTy == bTy =
|
||||
pure $ (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
|
||||
pure (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
|
||||
commandArith _ opname ctx a b = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
|
||||
|
||||
commandPlus :: BinaryCommandCallback
|
||||
@ -718,7 +720,7 @@ commandReadFile ctx filename =
|
||||
exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String)))
|
||||
pure $ case exceptional of
|
||||
Right contents -> (ctx, Right (XObj (Str contents) (Just dummyInfo) (Just StringTy)))
|
||||
Left _ -> (evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename))
|
||||
Left _ -> evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename)
|
||||
_ -> pure (evalError ctx ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (xobjInfo filename))
|
||||
|
||||
commandWriteFile :: BinaryCommandCallback
|
||||
@ -769,7 +771,7 @@ saveDocs ctx pathsAndEnvBinders = do
|
||||
pure (ctx, dynamicNil)
|
||||
|
||||
commandSexpression :: VariadicCommandCallback
|
||||
commandSexpression ctx [xobj, (XObj (Bol b) _ _)] =
|
||||
commandSexpression ctx [xobj, XObj (Bol b) _ _] =
|
||||
commandSexpressionInternal ctx xobj b
|
||||
commandSexpression ctx [xobj] =
|
||||
commandSexpressionInternal ctx xobj False
|
||||
@ -781,7 +783,7 @@ commandSexpressionInternal ctx xobj bol =
|
||||
let tyEnv = getTypeEnv $ contextTypeEnv ctx
|
||||
in case xobj of
|
||||
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
|
||||
pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
|
||||
pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
|
||||
(XObj (Lst forms) i t) ->
|
||||
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
||||
mdl@(XObj (Mod e) _ _) ->
|
||||
@ -796,21 +798,20 @@ commandSexpressionInternal ctx xobj bol =
|
||||
getMod
|
||||
where
|
||||
getMod =
|
||||
case (toSymbols mdl) of
|
||||
case toSymbols mdl of
|
||||
x@(XObj (Lst _) _ _) ->
|
||||
bindingSyms e (ctx, Right x)
|
||||
_ -> error "getmod"
|
||||
where
|
||||
bindingSyms env start =
|
||||
( mapM (\x -> commandSexpression ctx [x]) $
|
||||
map snd $
|
||||
Map.toList $
|
||||
Map.map binderXObj (envBindings env)
|
||||
mapM
|
||||
(commandSexpression ctx . pure . snd)
|
||||
( Map.toList $ Map.map binderXObj (envBindings env)
|
||||
)
|
||||
>>= pure . foldl combine start
|
||||
combine (c, (Right (XObj (Lst xs) i t))) (_, (Right y@(XObj (Lst _) _ _))) =
|
||||
<&> foldl combine start
|
||||
combine (c, Right (XObj (Lst xs) i t)) (_, Right y@(XObj (Lst _) _ _)) =
|
||||
(c, Right (XObj (Lst (xs ++ [y])) i t))
|
||||
combine _ (c, (Left err)) =
|
||||
combine _ (c, Left err) =
|
||||
(c, Left err)
|
||||
combine (c, Left err) _ =
|
||||
(c, Left err)
|
||||
@ -820,7 +821,7 @@ commandSexpressionInternal ctx xobj bol =
|
||||
|
||||
toSymbols :: XObj -> XObj
|
||||
toSymbols (XObj (Mod e) i t) =
|
||||
( XObj
|
||||
XObj
|
||||
( Lst
|
||||
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
|
||||
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t
|
||||
@ -828,16 +829,15 @@ toSymbols (XObj (Mod e) i t) =
|
||||
)
|
||||
i
|
||||
t
|
||||
)
|
||||
toSymbols (XObj (Defn _) i t) = (XObj (Sym (SymPath [] "defn") Symbol) i t)
|
||||
toSymbols (XObj Def i t) = (XObj (Sym (SymPath [] "def") Symbol) i t)
|
||||
toSymbols (XObj (Deftype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
|
||||
toSymbols (XObj (DefSumtype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
|
||||
toSymbols (XObj (Interface _ _) i t) = (XObj (Sym (SymPath [] "definterface") Symbol) i t)
|
||||
toSymbols (XObj Macro i t) = (XObj (Sym (SymPath [] "defmacro") Symbol) i t)
|
||||
toSymbols (XObj (Command _) i t) = (XObj (Sym (SymPath [] "command") Symbol) i t)
|
||||
toSymbols (XObj (Primitive _) i t) = (XObj (Sym (SymPath [] "primitive") Symbol) i t)
|
||||
toSymbols (XObj (External _) i t) = (XObj (Sym (SymPath [] "external") Symbol) i t)
|
||||
toSymbols (XObj (Defn _) i t) = XObj (Sym (SymPath [] "defn") Symbol) i t
|
||||
toSymbols (XObj Def i t) = XObj (Sym (SymPath [] "def") Symbol) i t
|
||||
toSymbols (XObj (Deftype _) i t) = XObj (Sym (SymPath [] "deftype") Symbol) i t
|
||||
toSymbols (XObj (DefSumtype _) i t) = XObj (Sym (SymPath [] "deftype") Symbol) i t
|
||||
toSymbols (XObj (Interface _ _) i t) = XObj (Sym (SymPath [] "definterface") Symbol) i t
|
||||
toSymbols (XObj Macro i t) = XObj (Sym (SymPath [] "defmacro") Symbol) i t
|
||||
toSymbols (XObj (Command _) i t) = XObj (Sym (SymPath [] "command") Symbol) i t
|
||||
toSymbols (XObj (Primitive _) i t) = XObj (Sym (SymPath [] "primitive") Symbol) i t
|
||||
toSymbols (XObj (External _) i t) = XObj (Sym (SymPath [] "external") Symbol) i t
|
||||
toSymbols x = x
|
||||
|
||||
commandHash :: UnaryCommandCallback
|
||||
|
@ -99,7 +99,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
pure $ do
|
||||
okBody <- visitedBody
|
||||
pure [defn, nameSymbol, args, okBody]
|
||||
visitList _ Inside _ xobj@(XObj (Lst [(XObj (Defn _) _ _), _, (XObj (Arr _) _ _), _]) _ _) =
|
||||
visitList _ Inside _ xobj@(XObj (Lst [XObj (Defn _) _ _, _, XObj (Arr _) _ _, _]) _ _) =
|
||||
pure (Left (DefinitionsMustBeAtToplevel xobj))
|
||||
visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) =
|
||||
-- The basic idea of this function is to first visit the body of the lambda ("in place"),
|
||||
@ -205,7 +205,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
pure $ do
|
||||
okBody <- visitedBody
|
||||
pure [def, nameSymbol, okBody]
|
||||
visitList _ Inside _ xobj@(XObj (Lst [(XObj Def _ _), _, _]) _ _) =
|
||||
visitList _ Inside _ xobj@(XObj (Lst [XObj Def _ _, _, _]) _ _) =
|
||||
pure (Left (DefinitionsMustBeAtToplevel xobj))
|
||||
visitList allowAmbig level env (XObj (Lst [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body]) _ _) =
|
||||
do
|
||||
@ -390,12 +390,12 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
|
||||
let (bound, bindingsCaptured) =
|
||||
foldl
|
||||
( \(bound', captured) (XObj sym _ ty, expr) ->
|
||||
let capt = filter (\x -> Set.notMember x bound') (visit expr)
|
||||
let capt = filter (`Set.notMember` bound') (visit expr)
|
||||
in (Set.insert (XObj sym (Just dummyInfo) ty) bound', capt ++ captured)
|
||||
)
|
||||
(Set.empty, [])
|
||||
(pairwise bindings)
|
||||
in let bodyCaptured = filter (\x -> Set.notMember x bound) (visit body)
|
||||
in let bodyCaptured = filter (`Set.notMember` bound) (visit body)
|
||||
in bindingsCaptured ++ bodyCaptured
|
||||
(Lst _) -> visitList xobj
|
||||
(Arr _) -> visitArray xobj
|
||||
@ -567,9 +567,7 @@ replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj
|
||||
replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath _ name) _) _ _) =
|
||||
let Just perhapsTyVar = xobjToTy xobj
|
||||
in if isFullyGenericType perhapsTyVar
|
||||
then case Map.lookup name mappings of
|
||||
Just found -> reify found
|
||||
Nothing -> xobj -- error ("Failed to concretize member '" ++ name ++ "' at " ++ prettyInfoFromXObj xobj ++ ", mappings: " ++ show mappings)
|
||||
then maybe xobj reify (Map.lookup name mappings)
|
||||
else xobj
|
||||
replaceGenericTypeSymbols mappings (XObj (Lst lst) i t) =
|
||||
XObj (Lst (map (replaceGenericTypeSymbols mappings) lst)) i t
|
||||
@ -860,7 +858,7 @@ manageMemory typeEnv globalEnv root =
|
||||
pure (Right xobj)
|
||||
case r of
|
||||
Right ok -> do
|
||||
MemState _ _ _ <- get
|
||||
MemState {} <- get
|
||||
r' <- checkThatRefTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
|
||||
addToLifetimesMappingsIfRef True ok -- (***)
|
||||
pure r'
|
||||
@ -897,7 +895,7 @@ manageMemory typeEnv globalEnv root =
|
||||
MemState deleters deps lifetimes <- get
|
||||
let newDeleters = Set.insert deleter deleters
|
||||
newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
|
||||
newState = (MemState newDeleters newDeps lifetimes)
|
||||
newState = MemState newDeleters newDeps lifetimes
|
||||
put newState --(trace (show newState) newState)
|
||||
pure (Right xobj)
|
||||
visitStaticArray _ = error "Must visit static array."
|
||||
@ -905,7 +903,7 @@ manageMemory typeEnv globalEnv root =
|
||||
visitList xobj@(XObj (Lst lst) i t) =
|
||||
case lst of
|
||||
[defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
|
||||
let captures = fromMaybe [] (fmap Set.toList maybeCaptures)
|
||||
let captures = maybe [] Set.toList maybeCaptures
|
||||
in --case defnReturnType of
|
||||
-- RefTy _ _ ->
|
||||
-- pure (Left (FunctionsCantReturnRefTy xobj funcTy))
|
||||
@ -915,13 +913,15 @@ manageMemory typeEnv globalEnv root =
|
||||
-- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters
|
||||
-- TODO: Use another kind of Deleter for this case since it's pretty special?
|
||||
mapM_
|
||||
( \cap ->
|
||||
( ( \cap ->
|
||||
modify
|
||||
( \memState ->
|
||||
memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)}
|
||||
)
|
||||
)
|
||||
(map getName captures)
|
||||
. getName
|
||||
)
|
||||
captures
|
||||
mapM_ (addToLifetimesMappingsIfRef False) argList
|
||||
mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas
|
||||
visitedBody <- visit body
|
||||
@ -987,12 +987,12 @@ manageMemory typeEnv globalEnv root =
|
||||
Right (okCorrectVariable, okMode) ->
|
||||
do
|
||||
MemState preDeleters _ _ <- get
|
||||
ownsTheVarBefore <- pure $ case createDeleter okCorrectVariable of
|
||||
let ownsTheVarBefore = case createDeleter okCorrectVariable of
|
||||
Nothing -> Right ()
|
||||
Just d ->
|
||||
if Set.member d preDeleters || isLookupGlobal okMode
|
||||
then (Right ())
|
||||
else (Left (UsingUnownedValue variable))
|
||||
then Right ()
|
||||
else Left (UsingUnownedValue variable)
|
||||
visitedValue <- visit value
|
||||
_ <- unmanage value -- The assigned value can't be used anymore
|
||||
MemState managed _ _ <- get
|
||||
@ -1245,7 +1245,7 @@ manageMemory typeEnv globalEnv root =
|
||||
[] -> pure (Right xobj)
|
||||
visitList _ = error "Must visit list."
|
||||
visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj]))
|
||||
visitMatchCase (lhs@(XObj _ _ _), rhs@XObj {}) =
|
||||
visitMatchCase (lhs@XObj {}, rhs@XObj {}) =
|
||||
do
|
||||
MemState preDeleters _ _ <- get
|
||||
_ <- visitCaseLhs lhs
|
||||
|
@ -122,7 +122,7 @@ templateGetter _ UnitTy =
|
||||
(FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy)
|
||||
(const (toTemplate "void $NAME($(Ref p) p)"))
|
||||
-- Execution of the action passed as an argument is handled in Emit.hs.
|
||||
(const $ toTemplate ("$DECL { return; }\n"))
|
||||
(const $ toTemplate "$DECL { return; }\n")
|
||||
(const [])
|
||||
templateGetter member memberTy =
|
||||
Template
|
||||
@ -187,8 +187,8 @@ templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typ
|
||||
t
|
||||
( \(FuncTy [_, memberTy] _ _) ->
|
||||
case memberTy of
|
||||
UnitTy -> (toTemplate "$p $NAME($p p)")
|
||||
_ -> (toTemplate "$p $NAME($p p, $t newValue)")
|
||||
UnitTy -> toTemplate "$p $NAME($p p)"
|
||||
_ -> toTemplate "$p $NAME($p p, $t newValue)"
|
||||
)
|
||||
( \(FuncTy [_, memberTy] _ _) ->
|
||||
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
|
||||
@ -242,7 +242,7 @@ templateMutatingSetter typeEnv env memberName memberTy =
|
||||
-- | The template for mutating setters of a generic deftype.
|
||||
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
||||
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), membTy] UnitTy StaticLifetimeTy) docs
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs
|
||||
where
|
||||
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
|
||||
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
|
||||
@ -253,13 +253,13 @@ templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNa
|
||||
t
|
||||
( \(FuncTy [_, memberTy] _ _) ->
|
||||
case memberTy of
|
||||
UnitTy -> (toTemplate "void $NAME($p* pRef)")
|
||||
_ -> (toTemplate "void $NAME($p* pRef, $t newValue)")
|
||||
UnitTy -> toTemplate "void $NAME($p* pRef)"
|
||||
_ -> toTemplate "void $NAME($p* pRef, $t newValue)"
|
||||
)
|
||||
( \(FuncTy [_, memberTy] _ _) ->
|
||||
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
|
||||
in case memberTy of
|
||||
UnitTy -> (toTemplate "$DECL { return; }\n")
|
||||
UnitTy -> toTemplate "$DECL { return; }\n"
|
||||
_ ->
|
||||
toTemplate
|
||||
( unlines
|
||||
@ -327,7 +327,7 @@ binderForInit _ _ _ = error "binderforinit"
|
||||
-- | Generate a list of types from a deftype declaration.
|
||||
initArgListTypes :: [XObj] -> [Ty]
|
||||
initArgListTypes xobjs =
|
||||
(map (fromJust . xobjToTy . snd) (pairwise xobjs))
|
||||
map (fromJust . xobjToTy . snd) (pairwise xobjs)
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a concrete deftype.
|
||||
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
||||
@ -343,7 +343,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
in (tokensForInit allocationMode typeName correctedMembers)
|
||||
in tokensForInit allocationMode typeName correctedMembers
|
||||
)
|
||||
(\FuncTy {} -> [])
|
||||
where
|
||||
@ -371,7 +371,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
in (tokensForInit allocationMode typeName correctedMembers)
|
||||
in tokensForInit allocationMode typeName correctedMembers
|
||||
)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
@ -399,7 +399,7 @@ tokensForInit allocationMode typeName membersXObjs =
|
||||
]
|
||||
where
|
||||
assignments [] = " instance.__dummy = 0;"
|
||||
assignments _ = go $ unitless
|
||||
assignments _ = go unitless
|
||||
where
|
||||
go [] = ""
|
||||
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
|
||||
@ -480,7 +480,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env)
|
||||
(remove isFullyGenericType (map snd memberPairs))
|
||||
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
|
||||
++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)]
|
||||
)
|
||||
genericStr _ _ _ _ = error "genericstr"
|
||||
|
||||
|
18
src/Emit.hs
18
src/Emit.hs
@ -12,6 +12,7 @@ where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Char (ord)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List (intercalate, sortOn)
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Env
|
||||
@ -314,7 +315,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
do
|
||||
ret <- visit indent' expr
|
||||
let Just bindingTy = xobjTy expr
|
||||
when ((not . isUnit) bindingTy) $
|
||||
unless (isUnit bindingTy) $
|
||||
appendToSrc (addIndent indent' ++ tyToCLambdaFix bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
|
||||
letBindingToC _ _ = error "Invalid binding."
|
||||
mapM_ (uncurry letBindingToC) (pairwise bindings)
|
||||
@ -360,8 +361,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
-- A better idea is to not specialise the names, which happens when calling 'concretize' on the lhs
|
||||
-- This requires a bunch of extra machinery though, so this will do for now...
|
||||
|
||||
[var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)]
|
||||
++ concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) unitless ([0 ..] :: [Int]))
|
||||
(var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)) :
|
||||
concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) unitless ([0 ..] :: [Int]))
|
||||
where
|
||||
unitless = remove (isUnit . forceTy) caseMatchers
|
||||
tagCondition _ _ _ _ =
|
||||
@ -679,7 +680,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
let argTypes = map forceTy args
|
||||
unitless = remove isUnit argTypes
|
||||
-- Run side effects
|
||||
sideEffects = mapM (visit indent) (filter (isUnit . forceTy) args) >>= pure . intercalate ";\n"
|
||||
sideEffects = mapM (visit indent) (filter (isUnit . forceTy) args) <&> intercalate ";\n"
|
||||
unwrapped =
|
||||
joinWithComma $
|
||||
if unwrapLambdas
|
||||
@ -722,14 +723,13 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
( case innerTy of
|
||||
UnitTy -> "/* () */"
|
||||
_ ->
|
||||
( addIndent indent ++ "((" ++ tyToCLambdaFix innerTy ++ "*)" ++ arrayVar
|
||||
addIndent indent ++ "((" ++ tyToCLambdaFix innerTy ++ "*)" ++ arrayVar
|
||||
++ ".data)["
|
||||
++ show index
|
||||
++ "] = "
|
||||
++ visited
|
||||
++ ";\n"
|
||||
)
|
||||
)
|
||||
pure ()
|
||||
visitStaticArray :: Int -> XObj -> State EmitterState String
|
||||
visitStaticArray indent (XObj (StaticArr xobjs) (Just i) t) =
|
||||
@ -850,16 +850,16 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
|
||||
emitSumtypeCase ind (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) =
|
||||
do
|
||||
appendToSrc (addIndent ind ++ "struct {\n")
|
||||
let members = zipWith (\anonName tyXObj -> (anonName, tyXObj)) anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys)
|
||||
let members = zip anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys)
|
||||
mapM_ (memberToDecl (ind + indentAmount)) members
|
||||
appendToSrc (addIndent ind ++ "} " ++ caseName ++ ";\n")
|
||||
emitSumtypeCase ind (XObj (Sym (SymPath [] caseName) _) _ _) =
|
||||
appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n")
|
||||
emitSumtypeCase _ _ = error "emitsumtypecase"
|
||||
emitSumtypeCaseTagDefinition :: (Int, XObj) -> State EmitterState ()
|
||||
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _)) =
|
||||
emitSumtypeCaseTagDefinition (tagIndex, XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _) =
|
||||
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
|
||||
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Sym (SymPath [] caseName) _) _ _)) =
|
||||
emitSumtypeCaseTagDefinition (tagIndex, XObj (Sym (SymPath [] caseName) _) _ _) =
|
||||
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
|
||||
emitSumtypeCaseTagDefinition _ = error "emitsumtypecasetagdefinition"
|
||||
in if isTypeGeneric sumTy
|
||||
|
48
src/Eval.hs
48
src/Eval.hs
@ -85,13 +85,12 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
tryAllLookups =
|
||||
( case preference of
|
||||
PreferDynamic -> tryDynamicLookup
|
||||
PreferGlobal -> (tryLookup spath <|> tryDynamicLookup)
|
||||
PreferGlobal -> tryLookup spath <|> tryDynamicLookup
|
||||
)
|
||||
<|> (if null p then tryInternalLookup spath else tryLookup spath)
|
||||
tryDynamicLookup =
|
||||
( lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
|
||||
lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
|
||||
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
||||
)
|
||||
tryInternalLookup path =
|
||||
( contextInternalEnv ctx
|
||||
>>= lookupBinder path
|
||||
@ -209,7 +208,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
)
|
||||
(xobjInfo defn)
|
||||
)
|
||||
[(XObj Def _ _), name, _] ->
|
||||
[XObj Def _ _, name, _] ->
|
||||
if isUnqualifiedSym name
|
||||
then specialCommandDefine ctx xobj
|
||||
else
|
||||
@ -287,7 +286,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
(newCtx, res) <- eval ctx' x preference ResolveLocal
|
||||
case res of
|
||||
Right okX -> do
|
||||
let binder = Binder emptyMeta (XObj (Lst [(XObj LetDef Nothing Nothing), XObj (Sym (SymPath [] n) Symbol) Nothing Nothing, okX]) Nothing (xobjTy okX))
|
||||
let binder = Binder emptyMeta (XObj (Lst [XObj LetDef Nothing Nothing, XObj (Sym (SymPath [] n) Symbol) Nothing Nothing, okX]) Nothing (xobjTy okX))
|
||||
Just e = contextInternalEnv newCtx
|
||||
pure $ Right (newCtx {contextInternalEnv = Just (envInsertAt e (SymPath [] n) binder)})
|
||||
Left err -> pure $ Left err
|
||||
@ -473,7 +472,7 @@ macroExpand ctx xobj =
|
||||
(newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t)
|
||||
pure (newCtx', res)
|
||||
-- TODO: Determine a way to eval primitives generally and remove this special case.
|
||||
Right p@(XObj (Lst [(XObj (Primitive prim) _ _), (XObj (Sym (SymPath _ "defmodule") _) _ _), _]) _ _) ->
|
||||
Right p@(XObj (Lst [XObj (Primitive prim) _ _, XObj (Sym (SymPath _ "defmodule") _) _ _, _]) _ _) ->
|
||||
getPrimitive prim p next args
|
||||
_ -> do
|
||||
(newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args
|
||||
@ -594,9 +593,9 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj =
|
||||
error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).")
|
||||
-- The s-expression command is a special case that prefers global/static bindings over dynamic bindings
|
||||
-- when given a naked binding (no path) as an argument; (s-expr inc)
|
||||
(newCtx, result) <- if (xobjIsSexp xobj) then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
|
||||
(newCtx, result) <- if xobjIsSexp xobj then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
|
||||
case result of
|
||||
Left e@(EvalError _ _ _ _) -> do
|
||||
Left e@EvalError {} -> do
|
||||
reportExecutionError newCtx (show e)
|
||||
pure (xobj, newCtx)
|
||||
-- special case: calling something static at the repl
|
||||
@ -776,16 +775,16 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
|
||||
>>= \(newCtx, result) ->
|
||||
case result of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = (join (fmap envParent (contextInternalEnv newCtx)))}), dynamicNil)
|
||||
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil)
|
||||
where
|
||||
updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
|
||||
updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) =
|
||||
let ctx' =
|
||||
ctx
|
||||
{ contextInternalEnv = Just innerEnv {envParent = i},
|
||||
contextPath = ((contextPath ctx) ++ [moduleName])
|
||||
contextPath = contextPath ctx ++ [moduleName]
|
||||
}
|
||||
in (pure (ctx', dynamicNil))
|
||||
in pure (ctx', dynamicNil)
|
||||
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
|
||||
defineNewModule meta
|
||||
updateExistingModule _ =
|
||||
@ -800,7 +799,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
|
||||
updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
|
||||
-- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
|
||||
-- In theory this shouldn't be necessary; but for now it is.
|
||||
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = ((contextPath ctx) ++ [moduleName])}
|
||||
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]}
|
||||
|
||||
defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
|
||||
defineModuleBindings (context, Left e) = pure (context, Left e)
|
||||
@ -810,7 +809,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
|
||||
step :: (Context, Either EvalError XObj) -> XObj -> IO (Context, Either EvalError XObj)
|
||||
step (ctx', Left e) _ = pure (ctx', Left e)
|
||||
step (ctx', Right _) expressions =
|
||||
(macroExpand ctx' expressions)
|
||||
macroExpand ctx' expressions
|
||||
>>= \(ctx'', res) -> case res of
|
||||
Left _ -> pure (ctx'', res)
|
||||
Right r -> evalDynamic ResolveLocal ctx'' r
|
||||
@ -882,14 +881,7 @@ loadInternal ctx xobj path i fileToLoad reloadMode = do
|
||||
Just firstPathFound ->
|
||||
do
|
||||
canonicalPath <- liftIO (canonicalizePath firstPathFound)
|
||||
fileThatLoads <-
|
||||
liftIO
|
||||
( canonicalizePath
|
||||
( case i of
|
||||
Just ii -> infoFile ii
|
||||
Nothing -> ""
|
||||
)
|
||||
)
|
||||
fileThatLoads <- liftIO (canonicalizePath $ maybe "" infoFile i)
|
||||
if canonicalPath == fileThatLoads
|
||||
then pure $ cantLoadSelf ctx path
|
||||
else do
|
||||
@ -900,7 +892,7 @@ loadInternal ctx xobj path i fileToLoad reloadMode = do
|
||||
contents <- liftIO $ slurp canonicalPath
|
||||
let files = projectFiles proj
|
||||
files' =
|
||||
if canonicalPath `elem` (map fst files)
|
||||
if canonicalPath `elem` map fst files
|
||||
then files
|
||||
else files ++ [(canonicalPath, reloadMode)]
|
||||
prevStack = projectLoadStack proj
|
||||
@ -1023,7 +1015,7 @@ loadFilesOnce :: Context -> [FilePath] -> IO Context
|
||||
loadFilesOnce = loadFilesExt commandLoadOnce
|
||||
|
||||
loadFilesExt :: VariadicCommandCallback -> Context -> [FilePath] -> IO Context
|
||||
loadFilesExt loadCmd ctxStart filesToLoad = foldM load ctxStart filesToLoad
|
||||
loadFilesExt loadCmd = foldM load
|
||||
where
|
||||
load :: Context -> FilePath -> IO Context
|
||||
load ctx file = do
|
||||
@ -1053,7 +1045,7 @@ commandReload ctx = do
|
||||
|
||||
-- | Command for expanding a form and its macros.
|
||||
commandExpand :: UnaryCommandCallback
|
||||
commandExpand ctx xobj = macroExpand ctx xobj
|
||||
commandExpand = macroExpand
|
||||
|
||||
-- | This function will show the resulting C code from an expression.
|
||||
-- | i.e. (Int.+ 2 3) => "_0 = 2 + 3"
|
||||
@ -1138,7 +1130,7 @@ primitiveDefdynamic _ ctx [notName, _] =
|
||||
primitiveDefdynamic _ _ _ = error "primitivedefdynamic"
|
||||
|
||||
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
|
||||
specialCommandSet ctx [XObj (Sym path@(SymPath mod n) _) _ _, val] = do
|
||||
(newCtx, result) <- evalDynamic ResolveLocal ctx val
|
||||
case result of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
@ -1175,7 +1167,7 @@ specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
|
||||
specialCommandSet ctx [notName, _] =
|
||||
pure (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (xobjInfo notName))
|
||||
specialCommandSet ctx args =
|
||||
pure (evalError ctx ("`set!` takes a name and a value, but got `" ++ intercalate " " (map pretty args)) (if null args then Nothing else xobjInfo (head args)))
|
||||
pure (evalError ctx ("`set!` takes a name and a value, but got `" ++ unwords (map pretty args)) (if null args then Nothing else xobjInfo (head args)))
|
||||
|
||||
-- | Convenience method for signifying failure in a given context.
|
||||
failure :: Context -> EvalError -> (Context, Either EvalError a)
|
||||
@ -1183,14 +1175,14 @@ failure ctx err = (ctx, Left err)
|
||||
|
||||
-- | Given a context, value XObj and an existing binder, check whether or not
|
||||
-- the given value has a type matching the binder's in the given context.
|
||||
typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, (Either EvalError XObj))
|
||||
typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, Either EvalError XObj)
|
||||
typeCheckValueAgainstBinder ctx val binder = do
|
||||
(ctx', typedValue) <- annotateWithinContext False ctx val
|
||||
pure $ case typedValue of
|
||||
Right (val', _) -> go ctx' binderTy val'
|
||||
Left err -> (ctx', Left err)
|
||||
where
|
||||
path = (getPath (binderXObj binder))
|
||||
path = getPath (binderXObj binder)
|
||||
binderTy = xobjTy (binderXObj binder)
|
||||
typeErr x = evalError ctx ("can't `set!` " ++ show path ++ " to a value of type " ++ show (fromJust (xobjTy x)) ++ ", " ++ show path ++ " has type " ++ show (fromJust binderTy)) (xobjInfo x)
|
||||
go ctx'' (Just DynamicTy) x = (ctx'', Right x)
|
||||
|
@ -138,7 +138,7 @@ expand eval ctx xobj =
|
||||
do
|
||||
okExpandedExpr <- expandedExpr
|
||||
okExpandedPairs <- expandedPairs
|
||||
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t)
|
||||
Right (XObj (Lst (matchExpr : okExpandedExpr : concat okExpandedPairs)) i t)
|
||||
)
|
||||
| otherwise ->
|
||||
pure
|
||||
@ -165,7 +165,7 @@ expand eval ctx xobj =
|
||||
okExpression <- expandedExpression
|
||||
Right (XObj (Lst [withExpr, pathExpr, okExpression]) i t) -- Replace the with-expression with just the expression!
|
||||
)
|
||||
[(XObj With _ _), _, _] ->
|
||||
[XObj With _ _, _, _] ->
|
||||
pure
|
||||
( evalError
|
||||
ctx
|
||||
@ -322,7 +322,7 @@ setNewIdentifiers root =
|
||||
|
||||
-- | Replaces the file, line and column info on an XObj an all its children.
|
||||
replaceSourceInfo :: FilePath -> Int -> Int -> XObj -> XObj
|
||||
replaceSourceInfo newFile newLine newColumn root = visit root
|
||||
replaceSourceInfo newFile newLine newColumn = visit
|
||||
where
|
||||
visit :: XObj -> XObj
|
||||
visit xobj =
|
||||
|
@ -4,7 +4,7 @@ import Constraints
|
||||
import Control.Arrow hiding (arr)
|
||||
import Control.Monad.State
|
||||
import Data.List as List
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
|
||||
import Info
|
||||
import Obj
|
||||
import qualified Set
|
||||
@ -35,8 +35,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
||||
captureList :: [XObj]
|
||||
captureList = Set.toList captures
|
||||
capturesConstrs =
|
||||
mapMaybe
|
||||
id
|
||||
catMaybes
|
||||
( zipWith
|
||||
( \captureTy captureObj ->
|
||||
case captureTy of
|
||||
|
@ -203,7 +203,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
okBody <- visitedBody
|
||||
okArgs <- sequence visitedArgs
|
||||
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
|
||||
[(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
|
||||
[XObj (Defn _) _ _, XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
|
||||
XObj defn@(Defn _) _ _ : _ ->
|
||||
pure (Left (InvalidObjExample defn xobj "(defn <name> [<arguments>] <body>)"))
|
||||
-- Fn
|
||||
@ -419,7 +419,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
let pairs = pairwise xobjs
|
||||
emptyInnerEnv =
|
||||
Env
|
||||
{ envBindings = Map.fromList [],
|
||||
{ envBindings = Map.empty,
|
||||
envParent = Just env,
|
||||
envModuleName = Nothing,
|
||||
envUseModules = [],
|
||||
|
@ -13,10 +13,10 @@ where
|
||||
import ColorText
|
||||
import Constraints
|
||||
import Control.Monad (foldM)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Env
|
||||
import Lookup
|
||||
import Obj
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Types
|
||||
import Util
|
||||
|
||||
@ -64,7 +64,7 @@ registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
||||
_ ->
|
||||
Left (show $ NonInterface (getBinderPath interface))
|
||||
where
|
||||
implPath = (getBinderPath implementation)
|
||||
implPath = getBinderPath implementation
|
||||
typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
(SymPath _ name) = getBinderPath interface
|
||||
|
||||
@ -72,7 +72,7 @@ registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
||||
-- registered with the interface.
|
||||
registerInInterface :: Context -> Binder -> Binder -> Either String Context
|
||||
registerInInterface ctx implementation interface =
|
||||
case (binderXObj implementation) of
|
||||
case binderXObj implementation of
|
||||
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
||||
-- This is a function, does it belong to an interface?
|
||||
registerInInterfaceIfNeeded ctx implementation interface t
|
||||
@ -95,7 +95,7 @@ registerInInterface ctx implementation interface =
|
||||
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
||||
retroactivelyRegisterInInterface ctx interface =
|
||||
-- TODO: Don't use error here?
|
||||
either (\e -> error e) id resultCtx
|
||||
either error id resultCtx
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
|
||||
|
@ -32,13 +32,13 @@ lookupInEnv path@(SymPath (p : ps) name) env =
|
||||
-- | Lookup a binder in a context's typeEnv.
|
||||
lookupBinderInTypeEnv :: Context -> SymPath -> Maybe Binder
|
||||
lookupBinderInTypeEnv ctx path =
|
||||
let typeEnv = (getTypeEnv (contextTypeEnv ctx))
|
||||
let typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
in lookupBinder path typeEnv
|
||||
|
||||
-- | Lookup a binder in a context's globalEnv.
|
||||
lookupBinderInGlobalEnv :: Context -> SymPath -> Maybe Binder
|
||||
lookupBinderInGlobalEnv ctx path =
|
||||
let global = (contextGlobalEnv ctx)
|
||||
let global = contextGlobalEnv ctx
|
||||
in lookupBinder path global
|
||||
|
||||
-- | Lookup a binder in a context's contextEnv.
|
||||
|
@ -22,7 +22,7 @@ import Types
|
||||
-- (def foo 0)
|
||||
stub :: SymPath -> Binder
|
||||
stub path =
|
||||
( Binder
|
||||
Binder
|
||||
emptyMeta
|
||||
( XObj
|
||||
( Lst
|
||||
@ -33,7 +33,6 @@ stub path =
|
||||
(Just dummyInfo)
|
||||
(Just (VarTy "a"))
|
||||
)
|
||||
)
|
||||
|
||||
get :: String -> MetaData -> Maybe XObj
|
||||
get key meta = Map.lookup key $ getMeta meta
|
||||
@ -42,7 +41,7 @@ set :: String -> XObj -> MetaData -> MetaData
|
||||
set key value meta = MetaData $ Map.insert key value $ getMeta meta
|
||||
|
||||
fromBinder :: Binder -> MetaData
|
||||
fromBinder binder = binderMeta binder
|
||||
fromBinder = binderMeta
|
||||
|
||||
getBinderMetaValue :: String -> Binder -> Maybe XObj
|
||||
getBinderMetaValue key binder =
|
||||
|
23
src/Obj.hs
23
src/Obj.hs
@ -269,9 +269,7 @@ instance Eq TemplateCreator where
|
||||
_ == _ = True
|
||||
|
||||
prettyInfoFromXObj :: XObj -> String
|
||||
prettyInfoFromXObj xobj = case xobjInfo xobj of
|
||||
Just i -> prettyInfo i
|
||||
Nothing -> "no info"
|
||||
prettyInfoFromXObj xobj = maybe "no info" prettyInfo (xobjInfo xobj)
|
||||
|
||||
machineReadableInfoFromXObj :: FilePathPrintLength -> XObj -> String
|
||||
machineReadableInfoFromXObj fppl xobj =
|
||||
@ -504,7 +502,7 @@ prettyUpTo lim xobj =
|
||||
|
||||
prettyCaptures :: Set.Set XObj -> String
|
||||
prettyCaptures captures =
|
||||
joinWithComma (map (\x -> getName x ++ " : " ++ fromMaybe "" (fmap show (xobjTy x))) (Set.toList captures))
|
||||
joinWithComma (map (\x -> getName x ++ " : " ++ maybe "" show (xobjTy x)) (Set.toList captures))
|
||||
|
||||
data EvalError
|
||||
= EvalError String [XObj] FilePathPrintLength (Maybe Info)
|
||||
@ -512,7 +510,7 @@ data EvalError
|
||||
deriving (Eq)
|
||||
|
||||
instance Show EvalError where
|
||||
show (HasStaticCall xobj info) = "Expression " ++ (pretty xobj) ++ " has unexpected static call" ++ showInfo info
|
||||
show (HasStaticCall xobj info) = "Expression " ++ pretty xobj ++ " has unexpected static call" ++ showInfo info
|
||||
where
|
||||
showInfo (Just i) = " at " ++ prettyInfo i ++ "."
|
||||
showInfo Nothing = ""
|
||||
@ -576,8 +574,7 @@ prettyTyped = visit 0
|
||||
++ suffix
|
||||
|
||||
spaces :: Int -> String
|
||||
spaces n =
|
||||
join (take n (repeat " "))
|
||||
spaces n = replicate n ' '
|
||||
|
||||
-- | Datatype for holding meta data about a binder, like type annotation or docstring.
|
||||
newtype MetaData = MetaData {getMeta :: Map.Map String XObj} deriving (Eq, Show, Generic)
|
||||
@ -619,7 +616,7 @@ showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths)
|
||||
++ replicate indent ' '
|
||||
++ "}"
|
||||
showBinderIndented indent showHidden (name, Binder meta xobj) =
|
||||
if (not showHidden) && metaIsTrue meta "hidden"
|
||||
if not showHidden && metaIsTrue meta "hidden"
|
||||
then ""
|
||||
else
|
||||
replicate indent ' ' ++ name
|
||||
@ -693,10 +690,7 @@ safeEnvModuleName env =
|
||||
Just name -> name ++ ", with parent " ++ parent
|
||||
Nothing -> "???, with parent " ++ parent
|
||||
where
|
||||
parent =
|
||||
case envParent env of
|
||||
Just p -> safeEnvModuleName p
|
||||
Nothing -> "Global"
|
||||
parent = maybe "Global" safeEnvModuleName (envParent env)
|
||||
|
||||
-- | Used by the compiler command "(env)"
|
||||
prettyEnvironment :: Env -> String
|
||||
@ -740,10 +734,7 @@ pathToEnv rootEnv = reverse (visit rootEnv)
|
||||
Just name -> name : parent
|
||||
Nothing -> parent
|
||||
where
|
||||
parent =
|
||||
case envParent env of
|
||||
Just p -> visit p
|
||||
Nothing -> []
|
||||
parent = maybe [] visit (envParent env)
|
||||
|
||||
showImportIndented :: Int -> SymPath -> String
|
||||
showImportIndented indent path = replicate indent ' ' ++ " * " ++ show path
|
||||
|
@ -33,7 +33,7 @@ maybeSigned = do
|
||||
i <- createInfo
|
||||
sign <- Parsec.optionMaybe (Parsec.char '-')
|
||||
digits <- Parsec.many1 Parsec.digit
|
||||
let num = maybe "" (\x -> [x]) sign ++ digits
|
||||
let num = maybe "" pure sign ++ digits
|
||||
incColumn (length num)
|
||||
pure (i, num)
|
||||
|
||||
@ -385,26 +385,26 @@ symbol = do
|
||||
Nothing
|
||||
)
|
||||
else pure $ case last segments of
|
||||
"defn" -> (XObj (Defn Nothing) i Nothing)
|
||||
"def" -> (XObj Def i Nothing)
|
||||
"defn" -> XObj (Defn Nothing) i Nothing
|
||||
"def" -> XObj Def i Nothing
|
||||
-- TODO: What about the other def- forms?
|
||||
"do" -> (XObj Do i Nothing)
|
||||
"while" -> (XObj While i Nothing)
|
||||
"fn" -> (XObj (Fn Nothing Set.empty) i Nothing)
|
||||
"let" -> (XObj Let i Nothing)
|
||||
"break" -> (XObj Break i Nothing)
|
||||
"if" -> (XObj If i Nothing)
|
||||
"match" -> (XObj (Match MatchValue) i Nothing)
|
||||
"match-ref" -> (XObj (Match MatchRef) i Nothing)
|
||||
"true" -> (XObj (Bol True) i Nothing)
|
||||
"false" -> (XObj (Bol False) i Nothing)
|
||||
"address" -> (XObj Address i Nothing)
|
||||
"set!" -> (XObj SetBang i Nothing)
|
||||
"the" -> (XObj The i Nothing)
|
||||
"ref" -> (XObj Ref i Nothing)
|
||||
"deref" -> (XObj Deref i Nothing)
|
||||
"with" -> (XObj With i Nothing)
|
||||
name -> (XObj (Sym (SymPath (init segments) name) Symbol) i Nothing)
|
||||
"do" -> XObj Do i Nothing
|
||||
"while" -> XObj While i Nothing
|
||||
"fn" -> XObj (Fn Nothing Set.empty) i Nothing
|
||||
"let" -> XObj Let i Nothing
|
||||
"break" -> XObj Break i Nothing
|
||||
"if" -> XObj If i Nothing
|
||||
"match" -> XObj (Match MatchValue) i Nothing
|
||||
"match-ref" -> XObj (Match MatchRef) i Nothing
|
||||
"true" -> XObj (Bol True) i Nothing
|
||||
"false" -> XObj (Bol False) i Nothing
|
||||
"address" -> XObj Address i Nothing
|
||||
"set!" -> XObj SetBang i Nothing
|
||||
"the" -> XObj The i Nothing
|
||||
"ref" -> XObj Ref i Nothing
|
||||
"deref" -> XObj Deref i Nothing
|
||||
"with" -> XObj With i Nothing
|
||||
name -> XObj (Sym (SymPath (init segments) name) Symbol) i Nothing
|
||||
|
||||
atom :: Parsec.Parsec String ParseState XObj
|
||||
atom = Parsec.choice [number, pat, rawString, string, aChar, symbol]
|
||||
|
@ -23,15 +23,15 @@ instance Show PrimitiveError where
|
||||
++ pretty actual
|
||||
++ "`"
|
||||
show (ArgumentArityError fun numberExpected args) =
|
||||
"`" ++ (show (getPath fun)) ++ "`" ++ "expected " ++ numberExpected
|
||||
"`" ++ show (getPath fun) ++ "`" ++ "expected " ++ numberExpected
|
||||
++ " arguments "
|
||||
++ ", but got "
|
||||
++ show (length args)
|
||||
show (MissingInfo x) =
|
||||
"No information about object: " ++ pretty x
|
||||
show (ForewardImplementsMeta) =
|
||||
show ForewardImplementsMeta =
|
||||
"Can't set the `implements` meta on a global definition before it is declared."
|
||||
show (RegisterTypeError) =
|
||||
show RegisterTypeError =
|
||||
"I don't understand this usage of `register-type`.\n\n"
|
||||
++ "Valid usages :\n"
|
||||
++ " (register-type Name)\n"
|
||||
|
@ -1,3 +1,6 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Primitives where
|
||||
|
||||
import ColorText
|
||||
@ -7,6 +10,7 @@ import Control.Applicative
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Either (rights)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List (union)
|
||||
import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)
|
||||
import Deftype
|
||||
@ -16,9 +20,9 @@ import Infer
|
||||
import Info
|
||||
import Interfaces
|
||||
import Lookup
|
||||
import qualified Map as Map
|
||||
import qualified Map
|
||||
import Managed
|
||||
import qualified Meta as Meta
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import PrimitiveError
|
||||
import Project
|
||||
@ -38,12 +42,10 @@ import Web.Browser (openBrowser)
|
||||
-- pure (ctx, dynamicNil)
|
||||
|
||||
makePrim :: String -> Int -> String -> String -> Primitive -> (String, Binder)
|
||||
makePrim name arity doc example callback =
|
||||
makePrim' name (Just arity) doc example callback
|
||||
makePrim name arity = makePrim' name (Just arity)
|
||||
|
||||
makeVarPrim :: String -> String -> String -> Primitive -> (String, Binder)
|
||||
makeVarPrim name doc example callback =
|
||||
makePrim' name Nothing doc example callback
|
||||
makeVarPrim name = makePrim' name Nothing
|
||||
|
||||
argumentErr :: Context -> String -> String -> String -> XObj -> IO (Context, Either EvalError XObj)
|
||||
argumentErr ctx fun ty number actual =
|
||||
@ -90,9 +92,9 @@ makePrim' name maybeArity docString example callback =
|
||||
unfoldArgs =
|
||||
case maybeArity of
|
||||
Just arity ->
|
||||
let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing)
|
||||
let tosym x = XObj (Sym (SymPath [] x) Symbol) Nothing Nothing
|
||||
in XObj (Arr (map (tosym . intToArgName) [1 .. arity])) Nothing Nothing
|
||||
Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
|
||||
Nothing -> XObj (Arr [XObj (Sym (SymPath [] "") Symbol) Nothing Nothing]) Nothing Nothing
|
||||
|
||||
infoXObjOrError :: Context -> (Context, Either EvalError XObj) -> Maybe Info -> Maybe XObj -> (Context, Either EvalError XObj)
|
||||
infoXObjOrError ctx err i = maybe err (\xobj -> (ctx, Right xobj {xobjInfo = i}))
|
||||
@ -126,22 +128,22 @@ primitiveColumn x@(XObj _ i _) ctx args =
|
||||
err = toEvalError ctx x (MissingInfo x)
|
||||
|
||||
primitiveImplements :: Primitive
|
||||
primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) _ _)] =
|
||||
primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), XObj (Sym (SymPath prefixes name) _) _ _] =
|
||||
do
|
||||
(maybeInterface, maybeImpl) <- pure ((lookupBinder interface tyEnv), (lookupBinder (SymPath modules name) global))
|
||||
(maybeInterface, maybeImpl) <- pure (lookupBinder interface tyEnv, lookupBinder (SymPath modules name) global)
|
||||
case (maybeInterface, maybeImpl) of
|
||||
(_, Nothing) ->
|
||||
if null modules
|
||||
then pure (toEvalError ctx call ForewardImplementsMeta)
|
||||
else updateMeta (Meta.stub (SymPath modules name)) ctx
|
||||
(Nothing, Just implBinder) ->
|
||||
(warn >> updateMeta implBinder ctx)
|
||||
warn >> updateMeta implBinder ctx
|
||||
(Just interfaceBinder, Just implBinder) ->
|
||||
(addToInterface interfaceBinder implBinder)
|
||||
addToInterface interfaceBinder implBinder
|
||||
where
|
||||
global = contextGlobalEnv ctx
|
||||
tyEnv = getTypeEnv . contextTypeEnv $ ctx
|
||||
(SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
|
||||
SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
||||
warn :: IO ()
|
||||
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
||||
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
||||
@ -165,7 +167,7 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XOb
|
||||
where
|
||||
update =
|
||||
( ( Meta.getBinderMetaValue "implements" binder
|
||||
>>= pure . updateImplementations binder
|
||||
<&> updateImplementations binder
|
||||
)
|
||||
<|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
|
||||
)
|
||||
@ -177,11 +179,11 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XOb
|
||||
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 x ctx [(XObj (Sym _ _) _ _), y] =
|
||||
primitiveImplements x ctx [XObj (Sym _ _) _ _, y] =
|
||||
pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "second" y)
|
||||
primitiveImplements _ ctx [x, _] =
|
||||
pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "first" x)
|
||||
primitiveImplements x@(XObj _ _ _) ctx args =
|
||||
primitiveImplements x@XObj {} ctx args =
|
||||
pure $ toEvalError ctx x (ArgumentArityError x "2" args)
|
||||
|
||||
define :: Bool -> Context -> XObj -> IO Context
|
||||
@ -192,13 +194,13 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
|
||||
then defineInTypeEnv newBinder
|
||||
else defineInGlobalEnv newBinder
|
||||
where
|
||||
freshBinder = (Binder emptyMeta annXObj)
|
||||
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 (lookupBinder (getPath annXObj) globalEnv)
|
||||
let maybeExistingBinder = lookupBinder (getPath annXObj) globalEnv
|
||||
when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj)))
|
||||
case maybeExistingBinder of
|
||||
Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder)
|
||||
@ -206,7 +208,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
|
||||
redefineExistingBinder :: Binder -> IO Context
|
||||
redefineExistingBinder old@(Binder meta _) =
|
||||
do
|
||||
updatedBinder <- pure (hideIt (Binder meta annXObj))
|
||||
let updatedBinder = hideIt (Binder meta annXObj)
|
||||
warnTypeChange old
|
||||
updatedContext <- implementInterfaces updatedBinder
|
||||
pure (insertInGlobalEnv updatedContext (getPath annXObj) updatedBinder)
|
||||
@ -230,12 +232,12 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
|
||||
>>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces)
|
||||
)
|
||||
>>= \maybeinterfaces ->
|
||||
pure (mapMaybe ((flip lookupBinder) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))
|
||||
pure (mapMaybe (`lookupBinder` 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)
|
||||
pure (foldM (`registerInInterface` binder) ctx interfaceBinders)
|
||||
>>= \case
|
||||
Left e -> printError (contextExecMode ctx) e >> pure ctx
|
||||
Right newCtx -> pure newCtx
|
||||
printError :: ExecutionMode -> String -> IO ()
|
||||
printError Check e =
|
||||
let fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
@ -249,13 +251,13 @@ primitiveRegisterType _ ctx [x] =
|
||||
pure (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (xobjInfo x))
|
||||
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _, XObj (Str override) _ _] =
|
||||
primitiveRegisterTypeWithoutFields ctx t (Just override)
|
||||
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), (XObj (Str override) _ _), members] =
|
||||
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), XObj (Str override) _ _, members] =
|
||||
primitiveRegisterTypeWithFields ctx x t (Just override) members
|
||||
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
|
||||
primitiveRegisterTypeWithFields ctx x t Nothing members
|
||||
primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
|
||||
|
||||
primitiveRegisterTypeWithoutFields :: Context -> String -> (Maybe String) -> IO (Context, Either EvalError XObj)
|
||||
primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
|
||||
primitiveRegisterTypeWithoutFields ctx t override = do
|
||||
let pathStrings = contextPath ctx
|
||||
typeEnv = contextTypeEnv ctx
|
||||
@ -263,7 +265,7 @@ primitiveRegisterTypeWithoutFields ctx t override = do
|
||||
typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
||||
pure (ctx {contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition)}, dynamicNil)
|
||||
|
||||
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> (Maybe String) -> XObj -> IO (Context, Either EvalError XObj)
|
||||
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
|
||||
primitiveRegisterTypeWithFields ctx x t override members =
|
||||
either
|
||||
handleErr
|
||||
@ -297,15 +299,15 @@ primitiveInfo :: Primitive
|
||||
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
|
||||
case path of
|
||||
SymPath [] _ ->
|
||||
(printIfFound (lookupBinderInTypeEnv ctx path))
|
||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
||||
>> maybe
|
||||
(notFound ctx target path)
|
||||
(\binders -> foldM (\_ binder -> printer binder) (ctx, dynamicNil) binders)
|
||||
( (fmap (: []) (lookupBinderInContextEnv ctx path))
|
||||
<|> (multiLookupBinderEverywhere ctx path)
|
||||
(foldM (\_ binder -> printer binder) (ctx, dynamicNil))
|
||||
( fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||
<|> multiLookupBinderEverywhere ctx path
|
||||
)
|
||||
_ ->
|
||||
(printIfFound (lookupBinderInTypeEnv ctx path))
|
||||
printIfFound (lookupBinderInTypeEnv ctx path)
|
||||
>> ( case lookupBinderInContextEnv ctx path of
|
||||
Nothing -> notFound ctx target path
|
||||
Just found -> printer found
|
||||
@ -315,18 +317,18 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
|
||||
printIfFound :: Maybe Binder -> IO (Context, Either EvalError XObj)
|
||||
printIfFound binder = maybe (pure (ctx, dynamicNil)) printer binder
|
||||
|
||||
printer (binder@(Binder metaData x@(XObj _ (Just i) _))) =
|
||||
(putStrLnWithColor Blue (forceShowBinder binder))
|
||||
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)
|
||||
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))
|
||||
maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
|
||||
>> maybe (pure ()) (printMetaVal "Implements" getName) (Meta.get "implements" metaData)
|
||||
>> maybe (pure ()) (printMetaVal "Private" pretty) (Meta.get "private" metaData)
|
||||
>> maybe (pure ()) (printMetaVal "Hidden" pretty) (Meta.get "hidden" metaData)
|
||||
@ -334,7 +336,7 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
|
||||
>> when (projectPrintTypedAST proj) (putStrLnWithColor Yellow (prettyTyped x))
|
||||
|
||||
printMetaVal :: String -> (XObj -> String) -> XObj -> IO ()
|
||||
printMetaVal s f xobj = putStrLn (" " ++ s ++ ": " ++ (f xobj))
|
||||
printMetaVal s f xobj = putStrLn (" " ++ s ++ ": " ++ f xobj)
|
||||
primitiveInfo _ ctx [notName] =
|
||||
argumentErr ctx "info" "a name" "first" notName
|
||||
primitiveInfo x ctx xs = pure $ toEvalError ctx x (ArgumentArityError x "1" xs)
|
||||
@ -414,41 +416,39 @@ primitiveMembers _ _ _ = error "primitivemembers"
|
||||
-- | Set meta data for a Binder
|
||||
primitiveMetaSet :: Primitive
|
||||
primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj (Str key) _ _, value] =
|
||||
pure $ maybe create (\newCtx -> (newCtx, dynamicNil)) lookupAndUpdate
|
||||
pure $ maybe create (,dynamicNil) lookupAndUpdate
|
||||
where
|
||||
fullPath@(SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
|
||||
dynamicPath = (consPath ["Dynamic"] fullPath)
|
||||
fullPath@(SymPath modules _) = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
||||
dynamicPath = consPath ["Dynamic"] fullPath
|
||||
global = contextGlobalEnv ctx
|
||||
types = (getTypeEnv (contextTypeEnv ctx))
|
||||
types = getTypeEnv (contextTypeEnv ctx)
|
||||
lookupAndUpdate :: Maybe Context
|
||||
lookupAndUpdate =
|
||||
( (lookupBinder dynamicPath global)
|
||||
( lookupBinder dynamicPath global
|
||||
>>= \binder ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= \b ->
|
||||
(pure (envInsertAt global dynamicPath b))
|
||||
pure (envInsertAt global dynamicPath b)
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
)
|
||||
<|> ( (lookupBinder fullPath global)
|
||||
<|> ( lookupBinder fullPath global
|
||||
>>= \binder ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= \b ->
|
||||
(pure (envInsertAt global fullPath b))
|
||||
pure (envInsertAt global fullPath b)
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
)
|
||||
-- This is a global name but it doesn't exist in the global env
|
||||
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
|
||||
<|> ( if (null modules)
|
||||
<|> if null modules
|
||||
then
|
||||
( (lookupBinder fullPath types)
|
||||
lookupBinder fullPath types
|
||||
>>= \binder ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= \b ->
|
||||
(pure (envInsertAt types fullPath b))
|
||||
>>= \env -> pure (ctx {contextTypeEnv = (TypeEnv env)})
|
||||
)
|
||||
pure (envInsertAt types fullPath b)
|
||||
>>= \env -> pure (ctx {contextTypeEnv = TypeEnv env})
|
||||
else Nothing
|
||||
)
|
||||
create :: (Context, Either EvalError XObj)
|
||||
create =
|
||||
if null prefixes
|
||||
@ -585,7 +585,7 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
members (binding : val : xs) = do
|
||||
xs' <- members xs
|
||||
Just $ (binding, val) : xs'
|
||||
members (_ : []) = Nothing
|
||||
members [_] = Nothing
|
||||
members [] = Just []
|
||||
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
|
||||
ensureUnqualified objs =
|
||||
@ -617,7 +617,7 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
deftype' nameXObj typeName typeVariableXObjs = do
|
||||
let pathStrings = contextPath ctx
|
||||
env = contextGlobalEnv ctx
|
||||
innerEnv = (contextInternalEnv ctx)
|
||||
innerEnv = contextInternalEnv ctx
|
||||
typeEnv = contextTypeEnv ctx
|
||||
typeVariables = mapM xobjToTy typeVariableXObjs
|
||||
(preExistingModule, preExistingMeta) =
|
||||
@ -647,18 +647,18 @@ 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))
|
||||
wHolders = (fst (foldl folder (ctx, (getTypeEnv typeEnv)) pathStrings))
|
||||
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))
|
||||
( (fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings))
|
||||
{ contextGlobalEnv = updatedGlobal,
|
||||
contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv (contextTypeEnv wHolders)) (SymPath pathStrings tyName) (Binder emptyMeta typeDefinition))
|
||||
}
|
||||
)
|
||||
in do
|
||||
ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
|
||||
let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)))
|
||||
let fakeImplBinder sympath t = Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t))
|
||||
deleteSig = FuncTy [structTy] UnitTy StaticLifetimeTy
|
||||
strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
|
||||
copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
|
||||
@ -712,7 +712,7 @@ primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (
|
||||
where
|
||||
global = contextGlobalEnv ctx
|
||||
types = getTypeEnv (contextTypeEnv ctx)
|
||||
fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
|
||||
fullPath = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
|
||||
lookup' :: Maybe Binder
|
||||
lookup' = (lookupBinder fullPath global <|> lookupBinder fullPath types) >>= pure
|
||||
foundBinder :: Binder -> (Context, Either EvalError XObj)
|
||||
@ -726,9 +726,9 @@ primitiveMeta _ ctx [path, _] =
|
||||
primitiveMeta _ _ _ = error "primitivemeta"
|
||||
|
||||
primitiveDefined :: Primitive
|
||||
primitiveDefined _ ctx [XObj (Sym path _) _ _] = do
|
||||
primitiveDefined _ ctx [XObj (Sym path _) _ _] =
|
||||
let env = contextEnv ctx
|
||||
pure $ maybe (ctx, Right falseXObj) (\_ -> (ctx, Right trueXObj)) (lookupInEnv path env)
|
||||
in pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupInEnv path env)
|
||||
primitiveDefined _ ctx [arg] =
|
||||
argumentErr ctx "defined" "a symbol" "first" arg
|
||||
primitiveDefined _ _ _ = error "primitivedefined"
|
||||
@ -773,22 +773,24 @@ noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x)
|
||||
|
||||
primitiveType :: Primitive
|
||||
-- A special case, the type of the type of types (type (type (type 1))) => ()
|
||||
primitiveType _ ctx [(XObj _ _ (Just Universe))] =
|
||||
primitiveType _ ctx [XObj _ _ (Just Universe)] =
|
||||
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
|
||||
primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
|
||||
primitiveType _ ctx [XObj _ _ (Just TypeTy)] = liftIO $ pure (ctx, Right $ reify TypeTy)
|
||||
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
|
||||
(maybe otherDefs go (lookupBinder path env))
|
||||
maybe otherDefs go (lookupBinder path env)
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
otherDefs = case multiLookupEverywhere name env of
|
||||
[] ->
|
||||
notFound ctx x path
|
||||
binders ->
|
||||
(sequence (map (go . snd) binders))
|
||||
>>= pure . Lst . rights . map snd
|
||||
>>= \obj -> pure (ctx, Right $ (XObj obj Nothing Nothing))
|
||||
mapM (go . snd) binders
|
||||
>>= (\obj -> pure (ctx, Right (XObj obj Nothing Nothing)))
|
||||
. Lst
|
||||
. rights
|
||||
. map snd
|
||||
go binder =
|
||||
case (xobjTy (binderXObj binder)) of
|
||||
case xobjTy (binderXObj binder) of
|
||||
Nothing -> noTypeError ctx x
|
||||
Just t -> pure (ctx, Right (reify t))
|
||||
primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
|
||||
@ -796,7 +798,7 @@ primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
go binder =
|
||||
case (xobjTy (binderXObj binder)) of
|
||||
case xobjTy (binderXObj binder) of
|
||||
Nothing -> noTypeError ctx x
|
||||
Just t -> pure (ctx, Right $ reify t)
|
||||
-- As a special case, we force evaluation on sequences such as (type (type 1))
|
||||
@ -809,30 +811,30 @@ primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
|
||||
-- (type '(Pair.init 1 1)) => (Pair Int Int)
|
||||
-- Contrarily the behavior is far more consistent as a primitive if we simply add this case, and from a user perspective, it makes more sense
|
||||
-- that this function would be one that *doesn't* evaluate its arguments.
|
||||
primitiveType any' ctx [(XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _ : rest)) _ _)] =
|
||||
primitiveType any' ctx [XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _ : rest)) _ _] =
|
||||
primitiveType any' ctx rest
|
||||
>>= \result -> case snd result of
|
||||
Right xobj -> primitiveType any' (fst result) [xobj]
|
||||
Left e -> pure (ctx, Left e)
|
||||
primitiveType _ ctx [x@(XObj _ _ _)] =
|
||||
primitiveType _ ctx [x@XObj {}] =
|
||||
let tenv = contextTypeEnv ctx
|
||||
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
|
||||
in liftIO $ either fail' ok typed
|
||||
where
|
||||
fail' _ = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
|
||||
ok ((XObj _ _ (Just t)), _) = pure (ctx, Right $ reify t)
|
||||
ok (XObj _ _ (Just t), _) = pure (ctx, Right $ reify t)
|
||||
ok (_, _) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
|
||||
primitiveType _ _ _ = error "primitivetype"
|
||||
|
||||
primitiveKind :: Primitive
|
||||
primitiveKind _ ctx [x@(XObj _ _ _)] =
|
||||
primitiveKind _ ctx [x@XObj {}] =
|
||||
let tenv = contextTypeEnv ctx
|
||||
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
|
||||
in pure (either fail' ok typed)
|
||||
where
|
||||
fail' _ = (evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x))
|
||||
fail' _ = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
|
||||
ok (XObj _ _ (Just t), _) = (ctx, Right $ reify (tyToKind t))
|
||||
ok (_, _) = (evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x))
|
||||
ok (_, _) = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
|
||||
primitiveKind _ _ _ = error "primitivekind"
|
||||
|
||||
-- | Primitive for printing help.
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
-- | Module Reify provides a typeclass and instances for turning internal compiler types and data into
|
||||
-- corresponding representations in the Carp language.
|
||||
@ -44,13 +43,13 @@ instance Reifiable Ty where
|
||||
reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
|
||||
|
||||
instance Reifiable String where
|
||||
reify s = (XObj (Str s) Nothing (Just StringTy))
|
||||
reify s = XObj (Str s) Nothing (Just StringTy)
|
||||
|
||||
instance Reifiable Int where
|
||||
reify i = (XObj (Num IntTy (fromIntegral i)) Nothing (Just IntTy))
|
||||
reify i = XObj (Num IntTy (fromIntegral i)) Nothing (Just IntTy)
|
||||
|
||||
getInfoAsXObj :: (Reifiable a) => (Info -> a) -> Maybe Info -> Maybe XObj
|
||||
getInfoAsXObj f i = fmap (reify . f) i
|
||||
getInfoAsXObj f = fmap (reify . f)
|
||||
|
||||
getFileAsXObj :: FilePathPrintLength -> Maybe Info -> Maybe XObj
|
||||
getFileAsXObj FullPath = getInfoAsXObj infoFile
|
||||
|
@ -124,7 +124,7 @@ treatSpecialInput arg = arg
|
||||
repl :: String -> String -> InputT (StateT Context IO) ()
|
||||
repl readSoFar prompt =
|
||||
do
|
||||
context <- lift $ get
|
||||
context <- lift get
|
||||
input <- getInputLine (strWithColor Yellow prompt)
|
||||
case input of
|
||||
Nothing -> do
|
||||
|
@ -26,7 +26,7 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
|
||||
where
|
||||
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
|
||||
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ typedef) -> ((depthOfDeftype typeEnv Set.empty typedef varTys + 1), b)
|
||||
Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
||||
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
|
||||
where
|
||||
lookupPath = getPathFromStructName structName
|
||||
@ -74,15 +74,15 @@ depthOfType typeEnv visited selfName theType =
|
||||
depthOfStructType :: Ty -> [Ty] -> Int
|
||||
depthOfStructType struct varTys =
|
||||
1
|
||||
+ case (getStructName struct) of
|
||||
+ case getStructName struct of
|
||||
"Array" -> depthOfVarTys
|
||||
_
|
||||
| (tyToC struct) == selfName -> 1
|
||||
| tyToC struct == selfName -> 1
|
||||
| otherwise ->
|
||||
case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||
where
|
||||
moduleDepth = ((length lookupPath) * 1000) -- modules have score 1000
|
||||
moduleDepth = length lookupPath * 1000 -- modules have score 1000
|
||||
Nothing ->
|
||||
--trace ("Unknown type: " ++ name) $
|
||||
depthOfVarTys -- The problem here is that generic types don't generate
|
||||
@ -110,7 +110,7 @@ scoreValueBinder _ _ binder =
|
||||
(0, binder)
|
||||
|
||||
scoreBody :: Env -> Set.Set SymPath -> XObj -> Int
|
||||
scoreBody globalEnv visited root = visit root
|
||||
scoreBody globalEnv visited = visit
|
||||
where
|
||||
visit xobj =
|
||||
case xobjObj xobj of
|
||||
|
@ -439,7 +439,7 @@ startingGlobalEnv noArray =
|
||||
Map.fromList $
|
||||
[ register "NULL" (PointerTy (VarTy "a"))
|
||||
]
|
||||
++ (if noArray then [] else [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing))])
|
||||
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray]
|
||||
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
|
||||
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
|
||||
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
|
||||
@ -472,12 +472,12 @@ startingTypeEnv =
|
||||
interfaceBinder
|
||||
"str"
|
||||
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
|
||||
((SymPath ["Array"] "str") : (SymPath ["StaticArray"] "str") : registerFunctionFunctionsWithInterface "str")
|
||||
(SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str")
|
||||
builtInSymbolInfo,
|
||||
interfaceBinder
|
||||
"prn"
|
||||
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
|
||||
((SymPath ["StaticArray"] "str") : (registerFunctionFunctionsWithInterface "prn")) -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
|
||||
(SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
|
||||
builtInSymbolInfo
|
||||
]
|
||||
builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)
|
||||
|
@ -11,7 +11,7 @@ import Types
|
||||
-- since there are some small differences here and there I'v decided to not
|
||||
-- try to abstract over them and just duplicate the templates instead.
|
||||
concreteArray :: Ty
|
||||
concreteArray = (ConcreteNameTy "StaticArray")
|
||||
concreteArray = ConcreteNameTy "StaticArray"
|
||||
|
||||
templateUnsafeNth :: (String, Binder)
|
||||
templateUnsafeNth =
|
||||
@ -67,7 +67,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
|
||||
++ deleteTy typeEnv env arrayType
|
||||
++ [TokC "}\n"]
|
||||
)
|
||||
( \(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
|
||||
( \(FuncTy [StructTy _ [insideType]] UnitTy _) ->
|
||||
depsForDeleteFunc typeEnv env insideType
|
||||
)
|
||||
|
||||
|
@ -12,7 +12,7 @@ data SumtypeCase = SumtypeCase
|
||||
deriving (Show, Eq)
|
||||
|
||||
toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
|
||||
toCases typeEnv typeVars xobjs = mapM (toCase typeEnv typeVars) xobjs
|
||||
toCases typeEnv typeVars = mapM (toCase typeEnv typeVars)
|
||||
|
||||
toCase :: TypeEnv -> [Ty] -> XObj -> Either TypeError SumtypeCase
|
||||
toCase typeEnv typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
|
||||
|
@ -47,15 +47,14 @@ memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
|
||||
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
|
||||
|
||||
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
|
||||
replaceGenericTypesOnCases mappings cases =
|
||||
map replaceOnCase cases
|
||||
replaceGenericTypesOnCases mappings = map replaceOnCase
|
||||
where
|
||||
replaceOnCase theCase =
|
||||
let newTys = (map (replaceTyVars mappings) (caseTys theCase))
|
||||
let newTys = map (replaceTyVars mappings) (caseTys theCase)
|
||||
in theCase {caseTys = newTys}
|
||||
|
||||
initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)]
|
||||
initers insidePath structTy cases = mapM (binderForCaseInit insidePath structTy) cases
|
||||
initers insidePath structTy = mapM (binderForCaseInit insidePath structTy)
|
||||
|
||||
binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder)
|
||||
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
|
||||
@ -143,7 +142,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _)
|
||||
(FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy)
|
||||
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy)
|
||||
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
|
||||
(\_ -> [])
|
||||
(const [])
|
||||
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
|
||||
doc = "Gets the tag from a `" ++ typeName ++ "`."
|
||||
binderForTag _ _ = error "binderfortag"
|
||||
@ -202,7 +201,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
|
||||
correctedCases = replaceGenericTypesOnCases mappings cases
|
||||
tys = remove isFullyGenericType (concatMap caseTys correctedCases)
|
||||
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) tys
|
||||
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
|
||||
++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)]
|
||||
)
|
||||
genericStr _ _ _ _ = error "genericstr"
|
||||
|
||||
@ -227,7 +226,7 @@ tokensForStr typeEnv env _ cases concreteStructTy =
|
||||
namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String)
|
||||
namesFromCase theCase concreteStructTy =
|
||||
let name = caseName theCase
|
||||
in (name, caseTys theCase {caseTys = (remove isUnit (caseTys theCase))}, tagName concreteStructTy name)
|
||||
in (name, caseTys theCase {caseTys = remove isUnit (caseTys theCase)}, tagName concreteStructTy name)
|
||||
|
||||
strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
|
||||
strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
|
||||
@ -403,7 +402,11 @@ tokensForSumtypeCopy typeEnv env concreteStructTy cases =
|
||||
unlines
|
||||
[ "$DECL {",
|
||||
" $p copy = *pRef;",
|
||||
joinLines $ map (copyCase typeEnv env concreteStructTy) (zip cases (True : repeat False)),
|
||||
joinLines $
|
||||
zipWith
|
||||
(curry (copyCase typeEnv env concreteStructTy))
|
||||
cases
|
||||
(True : repeat False),
|
||||
" return copy;",
|
||||
"}"
|
||||
]
|
||||
|
@ -457,7 +457,7 @@ showTypeFromXObj mappings xobj =
|
||||
Nothing -> "Type missing"
|
||||
|
||||
evalError :: Context -> String -> Maybe Info -> (Context, Either EvalError a)
|
||||
evalError ctx msg i = makeEvalError ctx Nothing msg i
|
||||
evalError ctx = makeEvalError ctx Nothing
|
||||
|
||||
-- | Print type errors correctly when running the compiler in 'Check' mode
|
||||
makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info -> (Context, Either EvalError a)
|
||||
|
28
src/Types.hs
28
src/Types.hs
@ -80,7 +80,7 @@ data Kind
|
||||
|
||||
tyToKind :: Ty -> Kind
|
||||
tyToKind (StructTy _ _) = Higher
|
||||
tyToKind (FuncTy _ _ _) = Higher -- the type of functions, consider the (->) constructor in Haskell
|
||||
tyToKind FuncTy {} = Higher -- the type of functions, consider the (->) constructor in Haskell
|
||||
tyToKind (PointerTy _) = Higher
|
||||
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
|
||||
tyToKind _ = Base
|
||||
@ -113,17 +113,17 @@ areKindsConsistent typeVars =
|
||||
Just k ->
|
||||
if k == kind
|
||||
then assignKinds next arityMap
|
||||
else (Left name)
|
||||
else Left name
|
||||
where
|
||||
next = (vars ++ rest)
|
||||
kind = (length vars)
|
||||
next = vars ++ rest
|
||||
kind = length vars
|
||||
assignKinds ((VarTy v) : rest) arityMap =
|
||||
case Map.lookup v arityMap of
|
||||
Nothing -> assignKinds rest (Map.insert v kind arityMap)
|
||||
Just k ->
|
||||
if k == kind
|
||||
then assignKinds rest arityMap
|
||||
else (Left v)
|
||||
else Left v
|
||||
where
|
||||
kind = 0
|
||||
assignKinds (FuncTy args ret _ : rest) arityMap =
|
||||
@ -175,8 +175,8 @@ instance Show Ty where
|
||||
show ModuleTy = "Module"
|
||||
show TypeTy = "Type"
|
||||
show InterfaceTy = "Interface"
|
||||
show (StructTy s []) = (show s)
|
||||
show (StructTy s typeArgs) = "(" ++ (show s) ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
|
||||
show (StructTy s []) = show s
|
||||
show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
|
||||
show (ConcreteNameTy name) = name
|
||||
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
|
||||
show (RefTy r lt) =
|
||||
@ -212,8 +212,8 @@ doesTypeContainTyVarWithName _ _ = False
|
||||
replaceConflicted :: String -> Ty -> Ty
|
||||
replaceConflicted name (VarTy n) =
|
||||
if n == name
|
||||
then (VarTy (n ++ "conflicted"))
|
||||
else (VarTy n)
|
||||
then VarTy (n ++ "conflicted")
|
||||
else VarTy n
|
||||
replaceConflicted name (FuncTy argTys retTy lt) =
|
||||
FuncTy
|
||||
(map (replaceConflicted name) argTys)
|
||||
@ -311,13 +311,13 @@ replaceTyVars mappings t =
|
||||
(VarTy key) -> fromMaybe t (Map.lookup key mappings)
|
||||
(FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
|
||||
(StructTy name tyArgs) ->
|
||||
case (replaceTyVars mappings name) of
|
||||
case replaceTyVars mappings name of
|
||||
-- special case, struct (f a b) mapped to (RefTy a lt)
|
||||
-- We f in such a case to the full (Ref a lt) in constraints; we also still map
|
||||
-- individual members a and b, as these need mappings since they may be
|
||||
-- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
|
||||
-- a would remain generic here.
|
||||
(RefTy a lt) -> (replaceTyVars mappings (RefTy a lt))
|
||||
(RefTy a lt) -> replaceTyVars mappings (RefTy a lt)
|
||||
_ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs)
|
||||
(PointerTy x) -> PointerTy (replaceTyVars mappings x)
|
||||
(RefTy x lt) -> RefTy (replaceTyVars mappings x) (replaceTyVars mappings lt)
|
||||
@ -336,7 +336,7 @@ lambdaEnvTy :: Ty
|
||||
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
|
||||
|
||||
createStructName :: [String] -> String -> String
|
||||
createStructName path name = (intercalate "." (path ++ [name]))
|
||||
createStructName path name = intercalate "." (path ++ [name])
|
||||
|
||||
getStructName :: Ty -> String
|
||||
getStructName (StructTy (ConcreteNameTy name) _) = name
|
||||
@ -345,8 +345,8 @@ getStructName _ = ""
|
||||
|
||||
getPathFromStructName :: String -> [String]
|
||||
getPathFromStructName structName =
|
||||
let path = (map unpack (splitOn (pack ".") (pack structName)))
|
||||
in if ((length path) > 1) then init path else []
|
||||
let path = map unpack (splitOn (pack ".") (pack structName))
|
||||
in if length path > 1 then init path else []
|
||||
|
||||
getNameFromStructName :: String -> String
|
||||
getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
|
||||
|
@ -144,3 +144,4 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
|
||||
isCaptured v@(VarTy _) (StructTy _ vars) = v `elem` vars
|
||||
-- Not a variable.
|
||||
isCaptured _ _ = True
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user