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

Address name shadowing (#1032)

Browse Source 
* Rename ty to xobjTy.

* Rename info to xobjInfo.

* Rename obj to xobjObj.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Address name shadowing.

* Remove some primes.
This commit is contained in:
jacereda 2020-12-01 00:11:01 +01:00 committed by GitHub
parent a9c8109ace
commit 2a94f67db8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
26 changed files with 657 additions and 674 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CarpHask.cabal
View File

@ -14,7 +14,7 @@ extra-source-files: README.md
cabal-version: >=1.10
library
ghc-options: -Wall -Wno-name-shadowing -Wno-incomplete-patterns
ghc-options: -Wall -Wno-incomplete-patterns
hs-source-dirs: src
exposed-modules: Info,
Obj,

12
src/ArrayTemplates.hs
View File

@ -16,7 +16,7 @@ templateEMap =
let fTy = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
bTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
elem = "((($a*)a.data)[i])"
elt = "((($a*)a.data)[i])"
in defineTemplate
(SymPath ["Array"] "endo-map")
(FuncTy [RefTy fTy (VarTy "q"), aTy] bTy StaticLifetimeTy)
@ -25,7 +25,7 @@ templateEMap =
(toTemplate $ unlines
["$DECL { "
," for(int i = 0; i < a.len; ++i) {"
," (($a*)a.data)[i] = " ++ templateCodeForCallingLambda "(*f)" fTy [elem] ++ ";"
," (($a*)a.data)[i] = " ++ templateCodeForCallingLambda "(*f)" fTy [elt] ++ ";"
," }"
," return a;"
,"}"
@ -50,7 +50,7 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
path = SymPath ["Array"] "endo-filter"
t = FuncTy [RefTy fTy (VarTy "w"), aTy] aTy StaticLifetimeTy
docs = "filters array members using a function. This function takes ownership."
elem = "&((($a*)a.data)[i])"
elt = "&((($a*)a.data)[i])"
templateCreator = TemplateCreator $
\typeEnv env ->
Template
@ -62,7 +62,7 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
in ["$DECL { "
, " int insertIndex = 0;"
, " for(int i = 0; i < a.len; ++i) {"
, " if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elem] ++ ") {"
, " if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elt] ++ ") {"
, " ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];"
, " } else {"
, " " ++ deleter "i"
@ -381,7 +381,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
copyTy :: TypeEnv -> Env -> Ty -> [Token]
copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
if isManaged
if managed
then
[ TokC " for(int i = 0; i < a->len; i++) {\n"
, TokC $ " " ++ insideArrayCopying typeEnv env innerType
@ -389,7 +389,7 @@ copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
]
else
[TokC " memcpy(copy.data, a->data, sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->len);\n"]
where isManaged =
where managed =
case findFunctionForMember typeEnv env "delete"
(typesDeleterFunctionType innerType) ("Inside array.", innerType) of
FunctionFound _ -> True

8
src/AssignTypes.hs
View File

@ -12,7 +12,7 @@ assignTypes :: TypeMappings -> XObj -> Either TypeError XObj
assignTypes mappings root = visit root
where
visit xobj =
case obj xobj of
case xobjObj xobj of
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj
@ -40,11 +40,11 @@ assignTypes mappings root = visit root
visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them."
assignType :: XObj -> Either TypeError XObj
assignType xobj = case ty xobj of
assignType xobj = case xobjTy xobj of
Just startingType ->
let finalType = replaceTyVars mappings startingType
in if isArrayTypeOK finalType
then Right (xobj { ty = Just finalType })
then Right (xobj { xobjTy = Just finalType })
else Left (ArraysCannotContainRefs xobj)
Nothing -> pure xobj
@ -58,7 +58,7 @@ isArrayTypeOK _ = True
-- | TODO: Only change variables that are machine generated.
beautifyTypeVariables :: XObj -> Either TypeError XObj
beautifyTypeVariables root =
let Just t = ty root
let Just t = xobjTy root
tys = nub (typeVariablesInOrderOfAppearance t)
mappings = Map.fromList (zip (map (\(VarTy name) -> name) tys)
(map (VarTy . (:[])) ['a'..]))

113
src/Commands.hs
View File

@ -1,5 +1,6 @@
module Commands where
import Prelude hiding (abs)
import Control.Exception
import Control.Monad (join, when)
import Control.Monad.IO.Class (liftIO, MonadIO)
@ -137,11 +138,11 @@ commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do
pure (proj { projectDocsURL = url })
"docs-styling" -> do url <- unwrapStringXObj value
pure (proj { projectDocsStyling = url })
"file-path-print-length" -> do length <- unwrapStringXObj value
case length of
"file-path-print-length" -> do len <- unwrapStringXObj value
case len of
"short" -> pure (proj { projectFilePathPrintLength = ShortPath })
"full" -> pure (proj { projectFilePathPrintLength = ShortPath })
_ -> Left ("Project.config can't understand the value '" ++ length ++ "' for key 'file-path-print-length.")
_ -> Left ("Project.config can't understand the value '" ++ len ++ "' for key 'file-path-print-length.")
"generate-only" -> do generateOnly <- unwrapBoolXObj value
pure (proj { projectGenerateOnly = generateOnly })
"paren-balance-hints" ->
@ -161,7 +162,7 @@ commandProjectGetConfig :: CommandCallback
commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
let proj = contextProj ctx
xstr s = XObj s (Just dummyInfo) (Just StringTy)
getVal _ proj = case key of
getVal _ = case key of
"cflag" -> Right $ Str $ show $ projectCFlags proj
"libflag" -> Right $ Str $ show $ projectLibFlags proj
"pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
@ -185,9 +186,9 @@ commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
"generate-only" -> Right $ Bol $ projectGenerateOnly proj
"paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj
_ -> Left key
in pure $ case getVal ctx proj of
in pure $ case getVal ctx of
Right val -> (ctx, Right $ xstr val)
Left key -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ key)) (info 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)
@ -214,8 +215,8 @@ commandRunExe ctx _ = do
quoted x = "\"" ++ x ++ "\""
outExe = quoted $ outDir </> projectTitle (contextProj ctx)
if projectCanExecute proj
then liftIO $ do handle <- spawnCommand outExe
exitCode <- waitForProcess handle
then liftIO $ do hndl <- spawnCommand outExe
exitCode <- waitForProcess hndl
case exitCode of
ExitSuccess -> pure (ctx, Right (XObj (Num IntTy 0) (Just dummyInfo) (Just IntTy)))
ExitFailure i -> throw (ShellOutException ("'" ++ outExe ++ "' exited with return value " ++ show i ++ ".") i)
@ -323,7 +324,7 @@ commandAddInclude includerConstructor ctx [x] =
proj' = proj { projectIncludes = includers' }
pure (ctx { contextProj = proj' }, dynamicNil)
_ ->
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (info x))
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x))
commandAddSystemInclude :: CommandCallback
commandAddSystemInclude = commandAddInclude SystemInclude
@ -337,7 +338,7 @@ commandAddRelativeInclude ctx [x] =
XObj (Str $ takeDirectory compiledFile </> file) i t
]
_ ->
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (info x))
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x))
commandIsList :: CommandCallback
commandIsList ctx [x] =
@ -372,50 +373,50 @@ commandLength ctx [x] =
(ctx, (Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing)))
XObj (Arr arr) _ _ ->
(ctx, (Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing)))
_ -> evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (info x)
_ -> evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (xobjInfo x)
commandCar :: CommandCallback
commandCar ctx [x] =
pure $ case x of
XObj (Lst (car : _)) _ _ -> (ctx, Right car)
XObj (Arr (car : _)) _ _ -> (ctx, Right car)
_ -> evalError ctx ("Applying 'car' to non-list: " ++ pretty x) (info x)
_ -> evalError ctx ("Applying 'car' to non-list: " ++ pretty x) (xobjInfo x)
commandCdr :: CommandCallback
commandCdr ctx [x] =
pure $ case x of
XObj (Lst (_ : cdr)) i _ -> (ctx, Right (XObj (Lst cdr) i Nothing))
XObj (Arr (_ : cdr)) i _ -> (ctx, Right (XObj (Arr cdr) i Nothing))
_ -> evalError ctx "Applying 'cdr' to non-list or empty list" (info x)
_ -> evalError ctx "Applying 'cdr' to non-list or empty list" (xobjInfo x)
commandLast :: CommandCallback
commandLast ctx [x] =
pure $ case x of
XObj (Lst lst@(_:_)) _ _ -> (ctx, Right (last lst))
XObj (Arr arr@(_:_)) _ _ -> (ctx, Right (last arr))
_ -> evalError ctx "Applying 'last' to non-list or empty list." (info x)
_ -> evalError ctx "Applying 'last' to non-list or empty list." (xobjInfo x)
commandAllButLast :: CommandCallback
commandAllButLast ctx [x] =
pure $ case x of
XObj (Lst lst) i _ -> (ctx, Right (XObj (Lst (init lst)) i Nothing))
XObj (Arr arr) i _ -> (ctx, Right (XObj (Arr (init arr)) i Nothing))
_ -> evalError ctx "Applying 'all-but-last' to non-list or empty list." (info x)
_ -> evalError ctx "Applying 'all-but-last' to non-list or empty list." (xobjInfo x)
commandCons :: CommandCallback
commandCons ctx [x, xs] =
pure $ case xs of
XObj (Lst lst) _ _ ->
(ctx, Right (XObj (Lst (x : lst)) (info x) (ty x))) -- TODO: probably not correct to just copy 'i' and 't'?
XObj (Arr arr) _ _ -> (ctx, Right (XObj (Arr (x : arr)) (info x) (ty x)))
_ -> evalError ctx "Applying 'cons' to non-list or empty list." (info xs)
(ctx, Right (XObj (Lst (x : lst)) (xobjInfo x) (xobjTy x))) -- TODO: probably not correct to just copy 'i' and 't'?
XObj (Arr arr) _ _ -> (ctx, Right (XObj (Arr (x : arr)) (xobjInfo x) (xobjTy x)))
_ -> evalError ctx "Applying 'cons' to non-list or empty list." (xobjInfo xs)
commandConsLast :: CommandCallback
commandConsLast ctx [x, xs] =
pure $ case xs of
XObj (Lst lst) i t ->
(ctx, Right (XObj (Lst (lst ++ [x])) i t)) -- TODO: should they get their own i:s and t:s
_ -> evalError ctx "Applying 'cons-last' to non-list or empty list." (info xs)
_ -> evalError ctx "Applying 'cons-last' to non-list or empty list." (xobjInfo xs)
commandAppend :: CommandCallback
commandAppend ctx [xs, ys] =
@ -423,29 +424,29 @@ commandAppend ctx [xs, ys] =
(XObj (Lst lst1) i t, XObj (Lst lst2) _ _) ->
(ctx, Right (XObj (Lst (lst1 ++ lst2)) i t)) -- TODO: should they get their own i:s and t:s
(XObj (Arr arr1) i t, XObj (Arr arr2) _ _) -> (ctx, Right (XObj (Arr (arr1 ++ arr2)) i t))
_ -> evalError ctx "Applying 'append' to non-array/list or empty list." (info xs)
_ -> evalError ctx "Applying 'append' to non-array/list or empty list." (xobjInfo xs)
commandMacroError :: CommandCallback
commandMacroError ctx [msg] =
pure $ case msg of
XObj (Str smsg) _ _ -> evalError ctx smsg (info msg)
x -> evalError ctx (pretty x) (info msg)
XObj (Str smsg) _ _ -> evalError ctx smsg (xobjInfo msg)
x -> evalError ctx (pretty x) (xobjInfo msg)
commandMacroLog :: CommandCallback
commandMacroLog ctx msgs = do
liftIO (mapM_ (putStr . logify) msgs)
liftIO (putStr "\n")
pure (ctx, dynamicNil)
where logify msg =
case msg of
where logify m =
case m of
XObj (Str msg) _ _ -> msg
x -> pretty x
commandEq :: CommandCallback
commandEq ctx [a, b] =
pure $ case cmp (a, b) of
Left (a, b) -> evalError ctx ("Can't compare " ++ pretty a ++ " with " ++ pretty b) (info a)
Right b -> (ctx, Right (boolToXObj b))
Left (a', b') -> evalError ctx ("Can't compare " ++ pretty a' ++ " with " ++ pretty b') (xobjInfo a')
Right b' -> (ctx, Right (boolToXObj b'))
where
cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _) | aTy == bTy =
Right $ aNum == bNum
@ -482,11 +483,11 @@ commandEq ctx [a, b] =
cmp invalid = Left invalid
cmp' _ invalid@(Left _) = invalid
cmp' _ (Right False) = Right False
cmp' elem (Right True) = cmp elem
cmp' elt (Right True) = cmp elt
commandComp :: (Number -> Number -> Bool) -> String -> CommandCallback
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) (info a)
commandComp _ opname ctx [a, b] = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (xobjInfo a)
commandLt :: CommandCallback
@ -501,15 +502,15 @@ commandCharAt ctx [a, b] =
(XObj (Str s) _ _, XObj (Num IntTy (Integral i)) _ _) ->
if length s > i
then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy)))
else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (info a)
_ -> evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b) (info a)
else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (xobjInfo a)
_ -> evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandIndexOf :: CommandCallback
commandIndexOf ctx [a, b] =
pure $ case (a, b) of
(XObj (Str s) _ _, XObj (Chr c) _ _) ->
(ctx, Right (XObj (Num IntTy (Integral (getIdx c s))) (Just dummyInfo) (Just IntTy)))
_ -> evalError ctx ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b) (info a)
_ -> evalError ctx ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
where getIdx c s = fromMaybe (-1) $ elemIndex c s
commandSubstring :: CommandCallback
@ -517,47 +518,47 @@ commandSubstring ctx [a, b, c] =
pure $ case (a, b, c) of
(XObj (Str s) _ _, XObj (Num IntTy (Integral f)) _ _, XObj (Num IntTy (Integral t)) _ _) ->
(ctx, Right (XObj (Str (take t (drop f s))) (Just dummyInfo) (Just StringTy)))
_ -> evalError ctx ("Can't call substring with " ++ pretty a ++ ", " ++ pretty b ++ " and " ++ pretty c) (info a)
_ -> evalError ctx ("Can't call substring with " ++ pretty a ++ ", " ++ pretty b ++ " and " ++ pretty c) (xobjInfo a)
commandStringLength :: CommandCallback
commandStringLength ctx [a] =
pure $ case a of
XObj (Str s) _ _ ->
(ctx, Right (XObj (Num IntTy (Integral (length s))) (Just dummyInfo) (Just IntTy)))
_ -> evalError ctx ("Can't call length with " ++ pretty a) (info a)
_ -> evalError ctx ("Can't call length with " ++ pretty a) (xobjInfo a)
commandStringConcat :: CommandCallback
commandStringConcat ctx [a] =
pure $ case a of
XObj (Arr strings) _ _ ->
case mapM unwrapStringXObj strings of
Left err -> evalError ctx err (info a)
Left err -> evalError ctx err (xobjInfo a)
Right result -> (ctx, Right (XObj (Str (join result)) (Just dummyInfo) (Just StringTy)))
_ -> evalError ctx ("Can't call concat with " ++ pretty a) (info a)
_ -> evalError ctx ("Can't call concat with " ++ pretty a) (xobjInfo a)
commandStringSplitOn :: CommandCallback
commandStringSplitOn ctx [XObj (Str sep) _ _, XObj (Str s) _ _] =
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] =
pure $ evalError ctx ("Can't call split-on with " ++ pretty sep ++ ", " ++ pretty s) (info sep)
pure $ evalError ctx ("Can't call split-on with " ++ pretty sep ++ ", " ++ pretty s) (xobjInfo sep)
commandSymConcat :: CommandCallback
commandSymConcat ctx [a] =
pure $ case a of
XObj (Arr syms) _ _ ->
case mapM unwrapSymPathXObj syms of
Left err -> evalError ctx err (info a)
Left err -> evalError ctx err (xobjInfo a)
Right result -> (ctx, Right (XObj (Sym (SymPath [] (join (map show result))) (LookupGlobal CarpLand AVariable)) (Just dummyInfo) Nothing))
_ -> evalError ctx ("Can't call concat with " ++ pretty a) (info a)
_ -> evalError ctx ("Can't call concat with " ++ pretty a) (xobjInfo a)
commandSymPrefix :: CommandCallback
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))
commandSymPrefix ctx [x, XObj (Sym (SymPath [] _) _) _ _] =
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (info x)
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (xobjInfo x)
commandSymPrefix ctx [_, x] =
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (info x)
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (xobjInfo x)
commandSymFrom :: CommandCallback
commandSymFrom ctx [x@(XObj (Sym _ _) _ _)] = pure (ctx, Right x)
@ -567,13 +568,13 @@ commandSymFrom ctx [XObj (Chr c) i t] = pure (ctx, Right $ XObj (sFrom_ (show c)
commandSymFrom ctx [XObj (Num _ v) i t] = pure (ctx, Right $ XObj (sFrom_ (show v)) i t)
commandSymFrom ctx [XObj (Bol b) i t] = pure (ctx, Right $ XObj (sFrom_ (show b)) i t)
commandSymFrom ctx [x] =
pure $ evalError ctx ("Can’t call `from` with " ++ pretty x) (info x)
pure $ evalError ctx ("Can’t call `from` with " ++ pretty x) (xobjInfo x)
commandSymStr :: CommandCallback
commandSymStr ctx [XObj (Sym s _) i _] =
pure (ctx, Right $ XObj (Str (show s)) i (Just StringTy))
commandSymStr ctx [x] =
pure $ evalError ctx ("Can’t call `str` with " ++ pretty x) (info x)
pure $ evalError ctx ("Can’t call `str` with " ++ pretty x) (xobjInfo x)
sFrom_ :: String -> Obj
sFrom_ s = Sym (SymPath [] s) (LookupGlobal CarpLand AVariable)
@ -583,7 +584,7 @@ commandPathDirectory ctx [a] =
pure $ case a of
XObj (Str s) _ _ ->
(ctx, Right (XObj (Str (takeDirectory s)) (Just dummyInfo) (Just StringTy)))
_ -> evalError ctx ("Can't call `directory` with " ++ pretty a) (info a)
_ -> evalError ctx ("Can't call `directory` with " ++ pretty a) (xobjInfo a)
commandPathAbsolute :: CommandCallback
commandPathAbsolute ctx [a] =
@ -591,13 +592,13 @@ commandPathAbsolute ctx [a] =
XObj (Str s) _ _ -> do
abs <- makeAbsolute s
pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (info a)
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
commandArith :: (Number -> Number -> Number) -> String -> CommandCallback
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)))
commandArith _ opname ctx [a, b] = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (info a)
commandArith _ opname ctx [a, b] = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandPlus :: CommandCallback
commandPlus = commandArith (+) "+"
@ -628,7 +629,7 @@ commandNot :: CommandCallback
commandNot ctx [x] =
pure $ case x of
XObj (Bol ab) _ _ -> (ctx, Right (boolToXObj (not ab)))
_ -> evalError ctx ("Can't perform logical operation (not) on " ++ pretty x) (info x)
_ -> evalError ctx ("Can't perform logical operation (not) on " ++ pretty x) (xobjInfo x)
commandReadFile :: CommandCallback
commandReadFile ctx [filename] =
@ -637,8 +638,8 @@ 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") (info filename))
_ -> pure (evalError ctx ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (info 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 :: CommandCallback
commandWriteFile ctx [filename, contents] =
@ -649,9 +650,9 @@ commandWriteFile ctx [filename, contents] =
exceptional <- liftIO ((try $ writeFile fname s) :: (IO (Either IOException ())))
pure $ case exceptional of
Right () -> (ctx, dynamicNil)
Left _ -> evalError ctx ("Cannot write to argument to `" ++ fname ++ "`, an argument to `write-file`") (info filename)
_ -> pure (evalError ctx ("The second argument to `write-file` must be a string, I got `" ++ pretty contents ++ "`") (info contents))
_ -> pure (evalError ctx ("The first argument to `write-file` must be a string, I got `" ++ pretty filename ++ "`") (info filename))
Left _ -> evalError ctx ("Cannot write to argument to `" ++ fname ++ "`, an argument to `write-file`") (xobjInfo filename)
_ -> pure (evalError ctx ("The second argument to `write-file` must be a string, I got `" ++ pretty contents ++ "`") (xobjInfo contents))
_ -> pure (evalError ctx ("The first argument to `write-file` must be a string, I got `" ++ pretty filename ++ "`") (xobjInfo filename))
commandHostBitWidth :: CommandCallback
commandHostBitWidth ctx [] =
@ -664,13 +665,13 @@ commandSaveDocsInternal ctx [modulePath] = do
case modulePath of
XObj (Lst xobjs) _ _ ->
case mapM unwrapSymPathXObj xobjs of
Left err -> pure (evalError ctx err (info modulePath))
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okPaths ->
case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of
Left err -> pure (evalError ctx err (info modulePath))
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders)
x ->
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (info modulePath))
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (xobjInfo modulePath))
where getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation _ env path =
case lookupInEnv path env of
@ -702,7 +703,7 @@ commandSexpressionInternal ctx [xobj] bol =
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))
mod@(XObj (Mod e) _ _) ->
mdl@(XObj (Mod e) _ _) ->
if bol
then getMod
else
@ -714,7 +715,7 @@ commandSexpressionInternal ctx [xobj] bol =
Nothing ->
getMod
where getMod =
case (toSymbols mod) of
case (toSymbols mdl) of
x@(XObj (Lst _) _ _) ->
bindingSyms e (ctx, Right x)
where bindingSyms env start =

95
src/Concretize.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Concretize where
import Prelude hiding (lookup)
import Control.Monad.State
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
@ -68,7 +69,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
else do _ <- concretizeTypeOfXObj typeEnv body
visitedBody <- visit False Inside env body
pure $ do okBody <- visitedBody
let t = fromMaybe UnitTy (ty okBody)
let t = fromMaybe UnitTy (xobjTy okBody)
if not (isTypeGeneric t) && t /= UnitTy && t /= IntTy
then Left (MainCanOnlyReturnUnitOrInt nameSymbol t)
else return [defn, nameSymbol, args, okBody]
@ -98,7 +99,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
do mapM_ (concretizeTypeOfXObj typeEnv) argsArr
let Just ii = i
Just funcTy = t
argObjs = map obj argsArr
argObjs = map xobjObj argsArr
-- | TODO: This code is a copy of the one above in Defn, remove duplication:
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv (envFunctionNestingLevel env)
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
@ -110,13 +111,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
let -- Analyse the body of the lambda to find what variables it captures
capturedVarsRaw = collectCapturedVars okBody
-- and then remove the captures that are actually our arguments
capturedVars = filter (\xobj -> obj (toGeneralSymbol xobj) `notElem` argObjs) capturedVarsRaw
capturedVars = filter (\xobj -> xobjObj (toGeneralSymbol xobj) `notElem` argObjs) capturedVarsRaw
-- Create a new (top-level) function that will be used when the lambda is called.
-- Its name will contain the name of the (normal, non-lambda) function it's contained within,
-- plus the identifier of the particular s-expression that defines the lambda.
SymPath path name = rootDefinitionPath
lambdaPath = SymPath path ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii))
SymPath spath name = rootDefinitionPath
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii))
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
extendedArgs = if null capturedVars
then args
@ -228,7 +229,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
Just (foundEnv, binder)
| envIsExternal foundEnv ->
let theXObj = binderXObj binder
Just theType = ty theXObj
Just theType = xobjTy theXObj
typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t
in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
isTypeGeneric theType && not (isTypeGeneric typeOfVisited)
@ -327,23 +328,23 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
(Just dummyInfo) ty
visit xobj =
case obj xobj of
case xobjObj xobj of
-- don't peek inside lambdas, trust their capture lists:
(Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures
-- in the case of lets, we have to remove new bindings from the list of captured variables,
-- including the ones captured in later bindings
(Lst [XObj Let _ _, XObj (Arr bindings) _ _, body]) ->
let (bound, bindingsCaptured) = foldl
(\(bound, captured) (XObj sym _ ty, expr) ->
let capt = filter (\x -> Set.notMember x bound) (visit expr) in
(Set.insert (XObj sym (Just dummyInfo) ty) bound, capt++captured))
(\(bound', captured) (XObj sym _ ty, expr) ->
let capt = filter (\x -> Set.notMember x 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
bindingsCaptured++bodyCaptured
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
-- TODO: Static Arrays!
sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (ty xobj)]
sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (xobjTy xobj)]
_ -> []
visitList :: XObj -> [XObj]
@ -367,8 +368,8 @@ matchingSignature3 tA (tB, _, _) = areUnifiable tA tB
-- | Does the type of an XObj require additional concretization of generic types or some typedefs for function types, etc?
-- | If so, perform the concretization and append the results to the list of dependencies.
concretizeTypeOfXObj :: TypeEnv -> XObj -> State [XObj] (Either TypeError ())
concretizeTypeOfXObj typeEnv (XObj _ _ (Just t)) =
case concretizeType typeEnv t of
concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) =
case concretizeType typeEnv ty of
Right t -> do modify (t ++)
pure (Right ())
Left err -> pure (Left err)
@ -501,8 +502,8 @@ replaceGenericTypeSymbols mappings (XObj (Arr arr) i t) =
replaceGenericTypeSymbols _ xobj = xobj
replaceGenericTypeSymbolsOnCase :: Map.Map String Ty -> XObj -> XObj
replaceGenericTypeSymbolsOnCase mappings (XObj (Lst (caseName : caseMembers)) i t) =
XObj (Lst (caseName : map replacer caseMembers)) i t
replaceGenericTypeSymbolsOnCase mappings (XObj (Lst (caseNm : caseMembers)) i t) =
XObj (Lst (caseNm : map replacer caseMembers)) i t
where replacer memberXObj =
replaceGenericTypeSymbols mappings memberXObj
-- Handle cases like `(State a) Done (Value [a]))`
@ -553,7 +554,7 @@ modeFromPath env p =
concretizeDefinition :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Ty -> Either TypeError (XObj, [XObj])
concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definition concreteType =
let SymPath pathStrings name = getPath definition
Just polyType = ty definition
Just polyType = xobjTy definition
suffix = polymorphicSuffix polyType concreteType
newPath = SymPath pathStrings (name ++ suffix)
in
@ -576,14 +577,14 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
if name == "NULL"
then Right (definition, []) -- A hack to make all versions of NULL have the same name
else let withNewPath = setPath definition newPath
withNewType = withNewPath { ty = Just concreteType }
withNewType = withNewPath { xobjTy = Just concreteType }
in Right (withNewType, [])
-- TODO: This old form shouldn't be necessary, but somehow, some External xobjs are still registered without a ty xobj position.
XObj (Lst [XObj (External _) _ _, _]) _ _ ->
if name == "NULL"
then Right (definition, []) -- A hack to make all versions of NULL have the same name
else let withNewPath = setPath definition newPath
withNewType = withNewPath { ty = Just concreteType }
withNewType = withNewPath { xobjTy = Just concreteType }
in Right (withNewType, [])
XObj (Lst [XObj (Instantiate template) _ _, _]) _ _ ->
Right (instantiateTemplate newPath concreteType template)
@ -593,7 +594,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
-- | Find ALL functions with a certain name, matching a type signature.
allFunctionsWithNameAndSignature :: Env -> String -> Ty -> [(Env, Binder)]
allFunctionsWithNameAndSignature env functionName functionType =
filter (predicate . ty . binderXObj . snd) (multiLookupALL functionName env)
filter (predicate . xobjTy . binderXObj . snd) (multiLookupALL functionName env)
where
predicate (Just t) = --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
areUnifiable functionType t
@ -653,7 +654,7 @@ data FunctionFinderResult = FunctionFound String
-- | TODO: COMMENT THIS
getConcretizedPath :: XObj -> Ty -> SymPath
getConcretizedPath single functionType =
let Just t' = ty single
let Just t' = xobjTy single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
in SymPath pathStrings (name ++ suffix)
@ -694,7 +695,7 @@ setDeletersOnInfo i deleters = fmap (\i' -> i' { infoDelete = deleters }) i
-- | Helper function for setting the deleters for an XObj.
del :: XObj -> Set.Set Deleter -> XObj
del xobj deleters = xobj { info = setDeletersOnInfo (info xobj) deleters }
del xobj deleters = xobj { xobjInfo = setDeletersOnInfo (xobjInfo xobj) deleters }
-- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function
data LifetimeMode = LifetimeInsideFunction String
@ -724,17 +725,17 @@ manageMemory typeEnv globalEnv root =
in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $
case finalObj of
Left err -> Left err
Right ok -> let newInfo = fmap (\i -> i { infoDelete = deleteThese }) (info ok)
Right ok -> let newInfo = fmap (\i -> i { infoDelete = deleteThese }) (xobjInfo ok)
in -- This final check of lifetimes works on the lifetimes mappings after analyzing the function form, and
-- after all the local variables in it have been deleted. This is needed for values that are created
-- directly in body position, e.g. (defn f [] &[1 2 3])
case evalState (checkThatRefTargetIsAlive ok) (MemState (Set.fromList []) [] (memStateLifetimes finalState)) of
Left err -> Left err
Right _ -> Right (ok { info = newInfo }, deps)
Right _ -> Right (ok { xobjInfo = newInfo }, deps)
where visit :: XObj -> State MemState (Either TypeError XObj)
visit xobj =
do r <- case obj xobj of
do r <- case xobjObj xobj of
Lst _ -> visitList xobj
Arr _ -> visitArray xobj
StaticArr _ -> visitStaticArray xobj
@ -748,9 +749,9 @@ manageMemory typeEnv globalEnv root =
pure (Right xobj)
case r of
Right ok -> do MemState _ _ _ <- get
r <- checkThatRefTargetIsAlive ok -- $ trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
r' <- checkThatRefTargetIsAlive ok -- $ trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
addToLifetimesMappingsIfRef True ok -- (***)
pure r
pure r'
Left err -> pure (Left err)
visitArray :: XObj -> State MemState (Either TypeError XObj)
@ -774,7 +775,7 @@ manageMemory typeEnv globalEnv root =
Right _ ->
-- We know that we want to add a deleter for the static array here
do let var = varOfXObj xobj
Just (RefTy t@(StructTy (ConcreteNameTy "StaticArray") [_]) _) = ty xobj
Just (RefTy t@(StructTy (ConcreteNameTy "StaticArray") [_]) _) = xobjTy xobj
deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
Just pathOfDeleteFunc ->
ProperDeleter pathOfDeleteFunc var
@ -856,7 +857,7 @@ manageMemory typeEnv globalEnv root =
-- Set!
[setbangExpr@(XObj SetBang _ _), variable, value] ->
let varInfo = info variable
let varInfo = xobjInfo variable
correctVariableAndMode =
case variable of
-- DISABLE FOR NOW: (XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : symObj@(XObj (Sym _ _) _ _) : _)) _ _) -> Right symObj
@ -886,10 +887,10 @@ manageMemory typeEnv globalEnv root =
Symbol -> error "How to handle this?"
LookupLocal _ ->
if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive
then variable { info = setDeletersOnInfo varInfo deleters }
then variable { xobjInfo = setDeletersOnInfo varInfo deleters }
else variable -- don't add the new info = no deleter
LookupGlobal _ _ ->
variable { info = setDeletersOnInfo varInfo deleters }
variable { xobjInfo = setDeletersOnInfo varInfo deleters }
-- traceDeps = trace ("SET!-deleters for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++
-- "unmanaged " ++ pretty value ++ "\n" ++
@ -923,8 +924,8 @@ manageMemory typeEnv globalEnv root =
pure (XObj (Lst [theExpr, typeXObj, okValue]) i t)
[refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit value
case visitedValue of
do visited <- visit value
case visited of
Left e -> pure (Left e)
Right visitedValue ->
do checkResult <- refCheck visitedValue
@ -1071,8 +1072,8 @@ manageMemory typeEnv globalEnv root =
-- Putting the deleter info on the lhs,
-- because the right one can collide with
-- the other expressions, e.g. a 'let'
let newLhsInfo = setDeletersOnInfo (info lhs) finalSetOfDeleters
in [lhs { info = newLhsInfo }, rhs]
let newLhsInfo = setDeletersOnInfo (xobjInfo lhs) finalSetOfDeleters
in [lhs { xobjInfo = newLhsInfo }, rhs]
)
okVisitedCases
deletersForEachCase
@ -1084,9 +1085,9 @@ manageMemory typeEnv globalEnv root =
in (XObj (Lst ([matchExpr, okVisitedExpr] ++ concat okVisitedCasesWithAllDeleters)) i t
, deletersAfterTheMatch)
XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : args ->
XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : uargs ->
do -- Do not visit f in this case, we don't want to manage it's memory since it is a ref!
visitedArgs <- sequence <$> mapM visitArg args
visitedArgs <- sequence <$> mapM visitArg uargs
case visitedArgs of
Left err -> pure (Left err)
Right args ->
@ -1095,9 +1096,9 @@ manageMemory typeEnv globalEnv root =
pure $ do okArgs <- unmanagedArgs
Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t)
f : args ->
f : uargs ->
do visitedF <- visit f
visitedArgs <- sequence <$> mapM visitArg args
visitedArgs <- sequence <$> mapM visitArg uargs
case visitedArgs of
Left err -> pure (Left err)
Right args -> do unmanagedArgs <- sequence <$> mapM unmanageArg args
@ -1141,7 +1142,7 @@ manageMemory typeEnv globalEnv root =
addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState ()
addToLifetimesMappingsIfRef internal xobj =
case ty xobj of
case xobjTy xobj of
Just (RefTy _ (VarTy lt)) ->
do m@(MemState _ _ lifetimes) <- get
case Map.lookup lt lifetimes of
@ -1149,7 +1150,7 @@ manageMemory typeEnv globalEnv root =
--trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $
pure ()
Nothing ->
do let lifetimes' = Map.insert lt (makeLifetimeMode xobj) lifetimes
do let lifetimes' = Map.insert lt makeLifetimeMode lifetimes
put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $
m { memStateLifetimes = lifetimes' }
pure ()
@ -1159,7 +1160,7 @@ manageMemory typeEnv globalEnv root =
_ ->
--trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
pure ()
where makeLifetimeMode xobj =
where makeLifetimeMode =
if internal then
LifetimeInsideFunction $
case xobj of
@ -1171,7 +1172,7 @@ manageMemory typeEnv globalEnv root =
checkThatRefTargetIsAlive :: XObj -> State MemState (Either TypeError XObj)
checkThatRefTargetIsAlive xobj =
-- TODO: Replace this whole thing with a function that collects all lifetime variables in a type.
case ty xobj of
case xobjTy xobj of
Just (RefTy _ (VarTy lt)) ->
performCheck lt
Just (FuncTy _ _ (VarTy lt)) ->
@ -1249,7 +1250,7 @@ manageMemory typeEnv globalEnv root =
createDeleter :: XObj -> Maybe Deleter
createDeleter xobj =
case ty xobj of
case xobjTy xobj of
Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj))
Just t -> let var = varOfXObj xobj
in if isExternalType typeEnv t
@ -1270,7 +1271,7 @@ manageMemory typeEnv globalEnv root =
else case createDeleter xobj of
Just deleter -> do MemState deleters deps lifetimes <- get
let newDeleters = Set.insert deleter deleters
Just t = ty xobj
Just t = xobjTy xobj
newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
put (MemState newDeleters newDeps lifetimes)
Nothing -> pure ()
@ -1294,7 +1295,7 @@ manageMemory typeEnv globalEnv root =
unmanage :: XObj -> State MemState (Either TypeError ())
unmanage xobj =
let Just t = ty xobj
let Just t = xobjTy xobj
in if isManaged typeEnv t && not (isGlobalFunc xobj) && not (isExternalType typeEnv t)
then do MemState deleters deps lifetimes <- get
case deletersMatchingXObj xobj deleters of
@ -1310,7 +1311,7 @@ manageMemory typeEnv globalEnv root =
-- | Check that the value being referenced hasn't already been given away
refCheck :: XObj -> State MemState (Either TypeError ())
refCheck xobj =
let Just t = ty xobj
let Just t = xobjTy xobj
isGlobalVariable = case xobj of
XObj (Sym _ (LookupGlobal _ _)) _ _ -> True
_ -> False
@ -1334,7 +1335,7 @@ varOfXObj :: XObj -> String
varOfXObj xobj =
case xobj of
XObj (Sym path _) _ _ -> pathToC path
_ -> case info xobj of
_ -> case xobjInfo xobj of
Just i -> freshVar i
Nothing -> error ("Missing info on " ++ show xobj)

2
src/Constraints.hs
View File

@ -225,7 +225,7 @@ checkConflictInternal mappings constraint name otherTy =
RefTy otherInnerTy otherLifetimeTy ->
case solveOneInternal mappings (mkConstraint OrdRef xobj1 xobj2 ctx innerTy otherInnerTy) of
Left err -> Left err
Right ok -> solveOneInternal ok (mkConstraint OrdRef xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Right smappings -> solveOneInternal smappings (mkConstraint OrdRef xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just foundNonVar -> case otherTy of

8
src/Deftype.hs
View File

@ -153,8 +153,8 @@ templateSetter typeEnv env memberName memberTy =
-- | The template for setters of a generic deftype.
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) memberTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, memberTy] originalStructTy StaticLifetimeTy) docs
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName)
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
@ -202,8 +202,8 @@ 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) _) memberTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), memberTy] UnitTy StaticLifetimeTy) docs
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
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
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."

156
src/Emit.hs
View File

@ -46,22 +46,22 @@ data ToCError = InvalidParameter XObj
instance Show ToCError where
show (InvalidParameter xobj) =
"I encountered an invalid parameter `" ++ show (obj xobj) ++ "` at " ++
"I encountered an invalid parameter `" ++ show (xobjObj xobj) ++ "` at " ++
prettyInfoFromXObj xobj ++ "."
show (InvalidList xobj) =
"I encountered an invalid list `" ++ show (obj xobj) ++ "` at " ++
"I encountered an invalid list `" ++ show (xobjObj xobj) ++ "` at " ++
prettyInfoFromXObj xobj ++ "."
show (DontVisitObj xobj) =
"I can’t visit " ++ show (obj xobj) ++ " at " ++ prettyInfoFromXObj xobj ++
"I can’t visit " ++ show (xobjObj xobj) ++ " at " ++ prettyInfoFromXObj xobj ++
"."
show (CannotEmitUnit xobj) =
"I can't emit code for the unit type `()` at" ++ prettyInfoFromXObj xobj ++
"."
show (CannotEmitExternal xobj) =
"I can’t emit code for the external function/variable `" ++
show (obj xobj) ++ "` at " ++ prettyInfoFromXObj xobj ++ "."
show (xobjObj xobj) ++ "` at " ++ prettyInfoFromXObj xobj ++ "."
show (CannotEmitModKeyword xobj) =
"I can’t emit code for the module `" ++ show (obj xobj) ++ "` at " ++
"I can’t emit code for the module `" ++ show (xobjObj xobj) ++ "` at " ++
prettyInfoFromXObj xobj ++ "."
show (BinderIsMissingType b) =
"I encountered a binder `" ++ show b ++ "` that is missing its type."
@ -95,7 +95,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
All -> 0
visit :: Int -> XObj -> State EmitterState String
visit indent xobj =
case obj xobj of
case xobjObj xobj of
Lst _ -> visitList indent xobj
Arr _ -> visitArray indent xobj
StaticArr _ -> visitStaticArray indent xobj
@ -113,7 +113,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
'\n' -> "'\\n'"
'\\' -> "'\\\\'"
x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\'']
Closure elem _ -> visit indent elem
Closure elt _ -> visit indent elt
Sym _ _ -> visitSymbol indent xobj
(Defn _) -> error (show (DontVisitObj xobj))
Def -> error (show (DontVisitObj xobj))
@ -166,12 +166,12 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
visitSymbol :: Int -> XObj -> State EmitterState String
visitSymbol _ (XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ _) =
pure overrideWithName
visitSymbol indent xobj@(XObj sym@(Sym path lookupMode) (Just i) t) =
let Just t' = t
in if isTypeGeneric t'
visitSymbol indent xobj@(XObj sym@(Sym path lookupMode) (Just i) ty) =
let Just t = ty
in if isTypeGeneric t
then error ("Can't emit symbol of generic type: " ++
show path ++ " : " ++ show t' ++ " at " ++ prettyInfoFromXObj xobj)
else if isFunctionType t' && not (isLookupLocal lookupMode) && not (isGlobalVariableLookup lookupMode)
show path ++ " : " ++ show t ++ " at " ++ prettyInfoFromXObj xobj)
else if isFunctionType t && not (isLookupLocal lookupMode) && not (isGlobalVariableLookup lookupMode)
then do let var = freshVar i
appendToSrc (addIndent indent ++ "Lambda " ++ var ++ " = { .callback = (void*)" ++ pathToC path ++ ", .env = NULL, .delete = NULL, .copy = NULL }; //" ++ show sym ++ "\n")
pure var
@ -183,7 +183,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
visitSymbol _ _ = error "Not a symbol."
visitList :: Int -> XObj -> State EmitterState String
visitList indent (XObj (Lst xobjs) (Just i) t) =
visitList indent (XObj (Lst xobjs) (Just info) ty) =
case xobjs of
-- Defn
[XObj (Defn _) _ _, XObj (Sym path@(SymPath _ name) _) _ _, XObj (Arr argList) _ _, body] ->
@ -192,14 +192,14 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
pure ""
_ ->
do let innerIndent = indent + indentAmount
Just (FuncTy _ retTy _) = t
Just (FuncTy _ retTy _) = ty
defnDecl = defnToDeclaration meta path argList retTy
isMain = name == "main"
appendToSrc (defnDecl ++ " {\n")
when isMain $
appendToSrc (addIndent innerIndent ++ "carp_init_globals(argc, argv);\n")
ret <- visit innerIndent body
delete innerIndent i
delete innerIndent info
case retTy of
UnitTy -> when isMain $ appendToSrc (addIndent innerIndent ++ "return 0;\n")
_ -> appendToSrc (addIndent innerIndent ++ "return " ++ ret ++ ";\n")
@ -208,14 +208,14 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- Fn / λ
[XObj (Fn name set) _ _, XObj (Arr _) _ _, _] ->
do let retVar = freshVar i
do let retVar = freshVar info
capturedVars = Set.toList set
Just callback = name
callbackMangled = pathToC callback
needEnv = not (null capturedVars)
lambdaEnvTypeName = callbackMangled ++ "_env" -- The name of the struct is the callback name with suffix '_env'.
lambdaEnvType = StructTy (ConcreteNameTy lambdaEnvTypeName) []
lambdaEnvName = freshVar i ++ "_env"
lambdaEnvName = freshVar info ++ "_env"
appendToSrc (addIndent indent ++ "// This lambda captures " ++
show (length capturedVars) ++ " variables: " ++
joinWithComma (map getName capturedVars) ++ "\n")
@ -247,22 +247,22 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
let innerIndent = indent + indentAmount
ret <- visit innerIndent expr
appendToSrc (addIndent innerIndent ++ pathToC path ++ " = " ++ ret ++ ";\n")
delete innerIndent i
delete innerIndent info
appendToSrc (addIndent indent ++ "}\n")
pure ""
-- Let
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
let indent' = indent + indentAmount
in do let Just bodyTy = ty body
in do let Just bodyTy = xobjTy body
isNotVoid = bodyTy /= UnitTy
letBodyRet = freshVar i
letBodyRet = freshVar info
when isNotVoid $ -- Must be declared outside the scope
appendToSrc (addIndent indent ++ tyToCLambdaFix bodyTy ++ " " ++ letBodyRet ++ ";\n")
appendToSrc (addIndent indent ++ "/* let */ {\n")
let letBindingToC (XObj (Sym (SymPath _ symName) _) _ _) expr =
do ret <- visit indent' expr
let Just bindingTy = ty expr
let Just bindingTy = xobjTy expr
when (bindingTy /= UnitTy) $
appendToSrc (addIndent indent' ++ tyToCLambdaFix bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
letBindingToC _ _ = error "Invalid binding."
@ -270,28 +270,28 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
ret <- visit indent' body
when isNotVoid $
appendToSrc (addIndent indent' ++ letBodyRet ++ " = " ++ ret ++ ";\n")
delete indent' i
delete indent' info
appendToSrc (addIndent indent ++ "}\n")
pure letBodyRet
-- If
[XObj If _ _, expr, ifTrue, ifFalse] ->
let indent' = indent + indentAmount
in do let isNotVoid = ty ifTrue /= Just UnitTy
ifRetVar = freshVar i
in do let isNotVoid = xobjTy ifTrue /= Just UnitTy
ifRetVar = freshVar info
when isNotVoid $
let Just ifT = ty ifTrue
let Just ifT = xobjTy ifTrue
in appendToSrc (addIndent indent ++ tyToCLambdaFix ifT ++ " " ++ ifRetVar ++ ";\n")
exprVar <- visit indent expr
appendToSrc (addIndent indent ++ "if (" ++ exprVar ++ ") {\n")
trueVar <- visit indent' ifTrue
let Just ifTrueInfo = info ifTrue
let Just ifTrueInfo = xobjInfo ifTrue
delete indent' ifTrueInfo
when isNotVoid $
appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ trueVar ++ ";\n")
appendToSrc (addIndent indent ++ "} else {\n")
falseVar <- visit indent' ifFalse
let Just ifFalseInfo = info ifFalse
let Just ifFalseInfo = xobjInfo ifFalse
delete indent' ifFalseInfo
when isNotVoid $
appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ falseVar ++ ";\n")
@ -301,8 +301,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- Match
XObj (Match matchMode) _ _ : expr@(XObj _ (Just exprInfo) (Just exprTyNotFixed)) : rest ->
let indent' = indent + indentAmount
retVar = freshVar i
isNotVoid = t /= Just UnitTy
retVar = freshVar info
isNotVoid = ty /= Just UnitTy
exprTy = exprTyNotFixed
tagCondition :: String -> String -> Ty -> XObj -> [String]
@ -314,7 +314,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- TODO probably we want to filter Units from caseMatchers here
[var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)] ++
concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) caseMatchers ([0..] :: [Int]))
tagCondition _ _ _ x =
tagCondition _ _ _ _ =
[]
--error ("tagCondition fell through: " ++ show x)
@ -378,12 +378,12 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
in do exprVar <- visit indent expr
when isNotVoid $
let Just tt = t
in appendToSrc (addIndent indent ++ tyToCLambdaFix tt ++ " " ++ retVar ++ ";\n")
let Just t = ty
in appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ retVar ++ ";\n")
zipWithM_ (emitCase exprVar) (True : repeat False) (pairwise rest)
appendToSrc (addIndent indent ++ "else {\n")
appendToSrc (addIndent indent ++ " // This will not be needed with static exhaustiveness checking in 'match' expressions:\n")
appendToSrc (addIndent indent ++ " fprintf(stderr, \"Unhandled case in 'match' expression at " ++ quoteBackslashes (prettyInfo i) ++ "\\n\");\n")
appendToSrc (addIndent indent ++ " fprintf(stderr, \"Unhandled case in 'match' expression at " ++ quoteBackslashes (prettyInfo info) ++ "\\n\");\n")
appendToSrc (addIndent indent ++ " exit(1);\n")
appendToSrc (addIndent indent ++ "}\n")
pure retVar
@ -397,16 +397,16 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- While
[XObj While _ _, expr, body] ->
let indent' = indent + indentAmount
Just exprTy = ty expr
conditionVar = freshVar i
Just exprInfo = info expr
Just exprTy = xobjTy expr
conditionVar = freshVar info
Just exprInfo = xobjInfo expr
in do exprRetVar <- visitWhileExpression indent
appendToSrc (addIndent indent ++ tyToCLambdaFix exprTy ++ " " ++ conditionVar ++ " = " ++ exprRetVar ++ ";\n")
delete indent exprInfo
appendToSrc (addIndent indent ++ "while (" ++ conditionVar ++ ") {\n")
_ <- visit indent' body
exprRetVar' <- visitWhileExpression indent'
delete indent' i
delete indent' info
appendToSrc (addIndent indent' ++ conditionVar ++ " = " ++ exprRetVar' ++ ";\n")
appendToSrc (addIndent indent ++ "}\n")
pure ""
@ -423,9 +423,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- Do
XObj Do _ _ : expressions ->
do let lastExpr = last expressions
retVar = freshVar i
retVar = freshVar info
mapM_ (visit indent) (init expressions)
let (Just lastTy) = ty lastExpr
let (Just lastTy) = xobjTy lastExpr
if lastTy == UnitTy
then do _ <- visit indent lastExpr
pure ""
@ -446,35 +446,35 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
(XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : (XObj (Sym sym _) _ _) : _)) _ _) -> "*" ++ pathToC sym
(XObj (Sym sym _) _ _) -> pathToC sym
_ -> error (show (CannotSet variable))
Just varInfo = info variable
Just varInfo = xobjInfo variable
--appendToSrc (addIndent indent ++ "// " ++ show (length (infoDelete varInfo)) ++ " deleters for " ++ properVariableName ++ ":\n")
delete indent varInfo
appendToSrc (addIndent indent ++ properVariableName ++ " = " ++ valueVar ++ "; "
++ " // " ++ show (fromMaybe (VarTy "?") (ty variable)) ++ " = " ++ show (fromMaybe (VarTy "?") (ty value))
++ " // " ++ show (fromMaybe (VarTy "?") (xobjTy variable)) ++ " = " ++ show (fromMaybe (VarTy "?") (xobjTy value))
++ "\n")
pure ""
-- The
[XObj The _ _, _, value] ->
do var <- visit indent value
let Just t' = t
fresh = mangle (freshVar i)
appendToSrc (addIndent indent ++ tyToCLambdaFix t' ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n")
let Just t = ty
fresh = mangle (freshVar info)
appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n")
pure fresh
-- Ref
[XObj Ref _ _, value] ->
do var <- visit indent value
let Just t' = t
fresh = mangle (freshVar i)
case t' of
let Just t = ty
fresh = mangle (freshVar info)
case t of
(RefTy UnitTy _) -> appendToSrc ""
_ -> if isNumericLiteral value
then do let literal = freshVar i ++ "_lit";
Just literalTy = ty value
appendToSrc (addIndent indent ++ "static " ++ tyToCLambdaFix literalTy ++ " " ++ literal ++ " = " ++ var ++ ";\n")
appendToSrc (addIndent indent ++ tyToCLambdaFix t' ++ " " ++ fresh ++ " = &" ++ literal ++ "; // ref\n")
else appendToSrc (addIndent indent ++ tyToCLambdaFix t' ++ " " ++ fresh ++ " = &" ++ var ++ "; // ref\n")
then do let literal = freshVar info ++ "_lit"
Just literalTy = xobjTy value
appendToSrc (addIndent indent ++ "static " ++ tyToCLambdaFix literalTy ++ " " ++ literal ++ " = " ++ var ++ ";\n")
appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ literal ++ "; // ref\n")
else appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ var ++ "; // ref\n")
pure fresh
-- Deref
@ -499,8 +499,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
Globals ->
pure ""
_ ->
do let Just t' = t
appendToSrc (templateToC template path t')
do let Just t = ty
appendToSrc (templateToC template path t)
pure ""
-- Alias
@ -543,7 +543,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- Function application (functions with overridden names)
func@(XObj (Sym _ (LookupGlobalOverride overriddenName)) _ _) : args ->
do argListAsC <- createArgList indent True args -- The 'True' means "unwrap lambdas" which is always the case for functions with overriden names (they are external)
let funcTy = case ty func of
let funcTy = case xobjTy func of
Just actualType -> actualType
_ -> error ("No type on func " ++ show func)
FuncTy _ retTy _ = funcTy
@ -551,19 +551,19 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
if isUnit retTy
then do appendToSrc (addIndent indent ++ callFunction)
pure ""
else do let varName = freshVar i
else do let varName = freshVar info
appendToSrc (addIndent indent ++ tyToCLambdaFix retTy ++ " " ++ varName ++ " = " ++ callFunction)
pure varName
-- Function application (global symbols that are functions -- lambdas stored in def:s need to be called like locals, see below)
func@(XObj (Sym path (LookupGlobal mode AFunction)) _ _) : args ->
do argListAsC <- createArgList indent (mode == ExternalCode) args
let Just (FuncTy _ retTy _) = ty func
let Just (FuncTy _ retTy _) = xobjTy func
funcToCall = pathToC path
if isUnit retTy
then do appendToSrc (addIndent indent ++ funcToCall ++ "(" ++ argListAsC ++ ");\n")
pure ""
else do let varName = freshVar i
else do let varName = freshVar info
appendToSrc (addIndent indent ++ tyToCLambdaFix retTy ++ " " ++ varName ++ " = " ++ funcToCall ++ "(" ++ argListAsC ++ ");\n")
pure varName
@ -574,7 +574,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
XObj (Sym _ (LookupGlobal ExternalCode _)) _ _ -> True
_ -> False
argListAsC <- createArgList indent unwrapLambdas args
let funcTy = case ty func of
let funcTy = case xobjTy func of
Just actualType -> actualType
_ -> error ("No type on func " ++ show func)
FuncTy argTys retTy _ = funcTy
@ -591,7 +591,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
if isUnit retTy
then do appendToSrc (addIndent indent ++ callLambda)
pure ""
else do let varName = freshVar i
else do let varName = freshVar info
appendToSrc (addIndent indent ++ tyToCLambdaFix retTy ++ " " ++ varName ++ " = " ++ callLambda)
pure varName
@ -747,15 +747,15 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
mapM_ emitSumtypeCaseTagDefinition (zip [0..] rest)
emitSumtypeCase :: Int -> XObj -> State EmitterState ()
emitSumtypeCase indent (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr []) _ _]) _ _) =
appendToSrc (addIndent indent ++ "// " ++ caseName ++ "\n")
emitSumtypeCase indent (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) =
do appendToSrc (addIndent indent ++ "struct {\n")
emitSumtypeCase ind (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr []) _ _]) _ _) =
appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n")
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)
mapM_ (memberToDecl (indent + indentAmount)) members
appendToSrc (addIndent indent ++ "} " ++ caseName ++ ";\n")
emitSumtypeCase indent (XObj (Sym (SymPath [] caseName) _) _ _) =
appendToSrc (addIndent indent ++ "// " ++ caseName ++ "\n")
mapM_ (memberToDecl (ind + indentAmount)) members
appendToSrc (addIndent ind ++ "} " ++ caseName ++ ";\n")
emitSumtypeCase ind (XObj (Sym (SymPath [] caseName) _) _ _) =
appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n")
emitSumtypeCaseTagDefinition :: (Int, XObj) -> State EmitterState ()
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _)) =
@ -777,14 +777,14 @@ defaliasToDeclaration t path =
fixer x = tyToCLambdaFix x
toDeclaration :: Binder -> String
toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) =
toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
case xobjs of
[XObj (Defn _) _ _, XObj (Sym path _) _ _, XObj (Arr argList) _ _, _] ->
let (Just (FuncTy _ retTy _)) = t
let (Just (FuncTy _ retTy _)) = ty
in defnToDeclaration meta path argList retTy ++ ";\n"
[XObj Def _ _, XObj (Sym path _) _ _, _] ->
let Just t' = t
in "" ++ tyToCLambdaFix t' ++ " " ++ pathToC path ++ ";\n"
let Just t = ty
in "" ++ tyToCLambdaFix t ++ " " ++ pathToC path ++ ";\n"
XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest ->
defStructToDeclaration t path rest
XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest ->
@ -798,8 +798,8 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) =
XObj DefDynamic _ _ : _ ->
""
[XObj (Instantiate template) _ _, XObj (Sym path _) _ _] ->
let Just t' = t
in templateToDeclaration template path t'
let Just t = ty
in templateToDeclaration template path t
[XObj (Defalias aliasTy) _ _, XObj (Sym path _) _ _] ->
defaliasToDeclaration aliasTy path
[XObj (Interface _ _) _ _, _] ->
@ -839,7 +839,7 @@ binderToC toCMode binder =
XObj (ExternalType _) _ _ -> Right ""
XObj (Command _) _ _ -> Right ""
XObj (Mod env) _ _ -> envToC env toCMode
_ -> case ty xobj of
_ -> case xobjTy xobj of
Just t -> if isTypeGeneric t
then Right ""
else do checkForUnresolvedSymbols xobj
@ -851,7 +851,7 @@ binderToDeclaration typeEnv binder =
let xobj = binderXObj binder
in case xobj of
XObj (Mod env) _ _ -> envToDeclarations typeEnv env
_ -> case ty xobj of
_ -> case xobjTy xobj of
Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "")
Nothing -> Left (BinderIsMissingType binder)
@ -896,14 +896,14 @@ checkForUnresolvedSymbols = visit
where
visit :: XObj -> Either ToCError ()
visit xobj =
case ty xobj of
case xobjTy xobj of
Nothing -> visitXObj
Just t -> if isTypeGeneric t
then Left (UnresolvedGenericType xobj)
else visitXObj
where
visitXObj =
case obj xobj of
case xobjObj xobj of
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj

339
src/Eval.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Eval where
import Prelude hiding (mod, exp)
import Control.Applicative
import Control.Exception
import Control.Monad.State
@ -57,18 +58,18 @@ evalStatic ctx xobj = eval ctx xobj PreferGlobal
-- remnant of us using StateT, and might not be necessary anymore since we
-- switched to more explicit state-passing.)
eval :: Context -> XObj -> LookupPreference -> IO (Context, Either EvalError XObj)
eval ctx xobj@(XObj o i t) preference =
eval ctx xobj@(XObj o info ty) preference =
case o of
Lst body -> eval' body
Sym path@(SymPath p n) _ ->
Sym spath@(SymPath p n) _ ->
pure
$ fromMaybe (evalError ctx ("Can't find symbol '" ++ show n ++ "'") i) -- all else failed, error.
$ fromMaybe (evalError ctx ("Can't find symbol '" ++ show n ++ "'") info) -- all else failed, error.
-- Certain contexts prefer looking up bindings in the dynamic environment (e.g. defdyanmic) while others
-- prefer the static global environment.
((case preference of
PreferDynamic -> tryDynamicLookup
PreferGlobal -> (tryLookup path <|> tryDynamicLookup))
<|> (if null p then tryInternalLookup path else tryLookup path))
PreferGlobal -> (tryLookup spath <|> tryDynamicLookup))
<|> (if null p then tryInternalLookup spath else tryLookup spath))
where tryDynamicLookup =
(lookupInEnv (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found)))
@ -84,16 +85,16 @@ eval ctx xobj@(XObj o i t) preference =
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found)))
checkPrivate meta found =
pure $ if metaIsTrue meta "private"
then evalError ctx ("The binding: " ++ show (getPath found) ++ " is private; it may only be used within the module that defines it.") i
then evalError ctx ("The binding: " ++ show (getPath found) ++ " is private; it may only be used within the module that defines it.") info
else (ctx, Right (resolveDef found))
Arr objs -> do
(newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs
pure (newCtx, do ok <- evaled
Right (XObj (Arr ok) i t))
Right (XObj (Arr ok) info ty))
StaticArr objs -> do
(newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs
pure (newCtx, do ok <- evaled
Right (XObj (StaticArr ok) i t))
Right (XObj (StaticArr ok) info ty))
_ -> do (nctx, res) <- annotateWithinContext False ctx xobj
pure $ case res of
Left e -> (nctx, Left e)
@ -109,74 +110,73 @@ eval ctx xobj@(XObj o i t) preference =
(newCtx, evd) <- eval ctx mcond preference
case evd of
Right cond ->
case obj cond of
case xobjObj cond of
Bol b -> eval newCtx (if b then mtrue else mfalse) preference
_ ->
pure (evalError ctx
("This `if` condition contains the non-boolean value `" ++
pretty cond ++ "`") (info cond))
pretty cond ++ "`") (xobjInfo cond))
Left e -> pure (newCtx, Left e)
XObj If _ _:_ ->
pure (evalError ctx
("I didn’t understand this `if`.\n\n Got:\n```\n" ++ pretty xobj ++
"\n```\n\nExpected the form:\n```\n(if cond then else)\n```\n") (info xobj))
"\n```\n\nExpected the form:\n```\n(if cond then else)\n```\n") (xobjInfo xobj))
[XObj (Defn _) _ _, name, args@(XObj (Arr a) _ _), _] ->
case obj name of
case xobjObj name of
(Sym (SymPath [] _) _) ->
if all isUnqualifiedSym a
then specialCommandDefine ctx xobj
else pure (evalError ctx
("`defn` requires all arguments to be unqualified symbols, but it got `" ++
pretty args ++ "`") (info xobj))
pretty args ++ "`") (xobjInfo xobj))
_ -> pure (evalError ctx
("`defn` identifiers must be unqualified symbols, but it got `" ++
pretty name ++ "`") (info xobj))
pretty name ++ "`") (xobjInfo xobj))
[XObj (Defn _) _ _, _, invalidArgs, _] ->
pure (evalError ctx
("`defn` requires an array of symbols as argument list, but it got `" ++
pretty invalidArgs ++ "`") (info xobj))
pretty invalidArgs ++ "`") (xobjInfo xobj))
(defn@(XObj (Defn _) _ _) : _) ->
pure (evalError ctx
("I didn’t understand the `defn` at " ++ prettyInfoFromXObj xobj ++
":\n\n" ++ pretty xobj ++
"\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`.")
(info defn))
(xobjInfo defn))
[(XObj Def _ _), name, _] ->
if isUnqualifiedSym name
then specialCommandDefine ctx xobj
else pure (evalError ctx
("`def` identifiers must be unqualified symbols, but it got `" ++
pretty name ++ "`") (info xobj))
pretty name ++ "`") (xobjInfo xobj))
[the@(XObj The _ _), ty, value] ->
[the@(XObj The _ _), t, value] ->
do (newCtx, evaledValue) <- expandAll evalDynamic ctx value -- TODO: Why expand all here?
pure (newCtx, do okValue <- evaledValue
Right (XObj (Lst [the, ty, okValue]) i t))
Right (XObj (Lst [the, t, okValue]) info ty))
(XObj The _ _: _) ->
pure (evalError ctx
("I didn’t understand the `the` at " ++ prettyInfoFromXObj xobj ++
":\n\n" ++ pretty xobj ++
"\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.")
(info xobj))
(xobjInfo xobj))
[XObj Let _ _, XObj (Arr bindings) _ _, body]
| odd (length bindings) -> pure (evalError ctx
("Uneven number of forms in `let`: " ++ pretty xobj)
(info xobj)) -- Unreachable?
(xobjInfo xobj)) -- Unreachable?
| not (all isSym (evenIndices bindings)) -> pure (evalError ctx
("`let` identifiers must be symbols, but it got `" ++
joinWithSpace (map pretty bindings) ++ "`") (info xobj))
joinWithSpace (map pretty bindings) ++ "`") (xobjInfo xobj))
| otherwise ->
do let binds = unwrapVar (pairwise bindings) []
i = contextInternalEnv ctx
ni = Env Map.empty i Nothing [] InternalEnv 0
eitherCtx <- foldrM successiveEval (Right ctx{contextInternalEnv=Just ni}) binds
ni = Env Map.empty (contextInternalEnv ctx) Nothing [] InternalEnv 0
eitherCtx <- foldrM successiveEval' (Right ctx{contextInternalEnv=Just ni}) binds
case eitherCtx of
Left err -> pure (ctx, Left err)
Right newCtx -> do
@ -187,25 +187,25 @@ eval ctx xobj@(XObj o i t) preference =
Right okBody)
where unwrapVar [] acc = acc
unwrapVar ((XObj (Sym (SymPath [] x) _) _ _,y):xs) acc = unwrapVar xs ((x,y):acc)
successiveEval (n, x) =
successiveEval' (n, x) =
\case
err@(Left _) -> pure err
Right ctx -> do
(newCtx, res) <- eval ctx x preference
Right ctx' -> do
(newCtx, res) <- eval ctx' x preference
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 (ty okX))
Just e = contextInternalEnv ctx
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
l@[XObj Fn{} _ _, args@(XObj (Arr a) _ _), _] ->
pure $ if all isUnqualifiedSym a
then (ctx, Right (XObj (Closure (XObj (Lst l) i t) (CCtx ctx)) i t))
else evalError ctx ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info args)
then (ctx, Right (XObj (Closure (XObj (Lst l) info ty) (CCtx ctx)) info ty))
else evalError ctx ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (xobjInfo args)
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CCtx c)) _ _:args ->
case checkArity params args of
Left err -> pure (evalError ctx err (info xobj))
Left err -> pure (evalError ctx err (xobjInfo xobj))
Right () ->
do (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of
@ -232,7 +232,7 @@ eval ctx xobj@(XObj o i t) preference =
--let replacedBody = replaceSourceInfoOnXObj (info xobj) body
(ctx', res) <- apply ctx body params args
case res of
Right xobj -> macroExpand ctx' xobj
Right xobj' -> macroExpand ctx' xobj'
Left _ -> pure (ctx, res)
XObj (Lst [XObj (Command callback) _ _, _, _]) _ _:args ->
@ -243,13 +243,13 @@ eval ctx xobj@(XObj o i t) preference =
x@(XObj (Lst [XObj (Primitive prim) _ _, _, _]) _ _):args -> (getPrimitive prim) x ctx args
XObj (Lst (XObj (Defn _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Lst (XObj (Interface _ _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Lst (XObj (Instantiate _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Lst (XObj (Deftemplate _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Lst (XObj (External _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Match _) _ _:_ -> pure (ctx, Left (HasStaticCall xobj i))
[XObj Ref _ _, _] -> pure (ctx, Left (HasStaticCall xobj i))
XObj (Lst (XObj (Defn _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
XObj (Lst (XObj (Interface _ _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
XObj (Lst (XObj (Instantiate _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
XObj (Lst (XObj (Deftemplate _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
XObj (Lst (XObj (External _) _ _:_)) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
XObj (Match _) _ _:_ -> pure (ctx, Left (HasStaticCall xobj info))
[XObj Ref _ _, _] -> pure (ctx, Left (HasStaticCall xobj info))
l@(XObj (Lst _) i t):args -> do
(newCtx, f) <- eval ctx l preference
@ -263,29 +263,29 @@ eval ctx xobj@(XObj o i t) preference =
(newCtx, f) <- eval ctx x preference
case f of
Right fun -> do
(newCtx', res) <- eval (pushFrame ctx xobj) (XObj (Lst (fun:args)) i t) preference
(newCtx', res) <- eval (pushFrame ctx xobj) (XObj (Lst (fun:args)) i ty) preference
pure (popFrame newCtx', res)
Left err -> pure (newCtx, Left err)
XObj With _ _ : xobj@(XObj (Sym path _) _ _) : forms ->
specialCommandWith ctx xobj path forms
XObj With _ _ : xobj'@(XObj (Sym path _) _ _) : forms ->
specialCommandWith ctx xobj' path forms
XObj With _ _ : _ ->
pure (evalError ctx ("Invalid arguments to `with`: " ++ pretty xobj) (info xobj))
pure (evalError ctx ("Invalid arguments to `with`: " ++ pretty xobj) (xobjInfo xobj))
XObj SetBang _ _ :args -> specialCommandSet ctx args
[XObj Do _ _] ->
pure (evalError ctx "No forms in do" (info xobj))
XObj Do _ _ : rest -> foldlM successiveEval (ctx, dynamicNil) rest
where successiveEval (ctx, acc) x =
pure (evalError ctx "No forms in do" (xobjInfo xobj))
XObj Do _ _ : rest -> foldlM successiveEval' (ctx, dynamicNil) rest
where successiveEval' (ctx', acc) x =
case acc of
err@(Left _) -> pure (ctx, err)
Right _ -> eval ctx x preference
err@(Left _) -> pure (ctx', err)
Right _ -> eval ctx' x preference
[XObj While _ _, cond, body] ->
specialCommandWhile ctx cond body
[XObj Address _ _, value] ->
specialCommandAddress ctx value
[] -> pure (ctx, dynamicNil)
_ -> do
pure (evalError ctx ("I did not understand the form `" ++ pretty xobj ++ "`") (info xobj))
pure (evalError ctx ("I did not understand the form `" ++ pretty xobj ++ "`") (xobjInfo xobj))
checkArity params args =
let la = length args
withRest = any ((":rest" ==) . getName) params
@ -302,11 +302,11 @@ eval ctx xobj@(XObj o i t) preference =
show la ++ ".\n\nThe arguments " ++
intercalate ", " (map pretty (drop lp args)) ++
" are not needed.")
successiveEval (ctx, acc) x =
successiveEval (ctx', acc) x =
case acc of
Left _ -> pure (ctx, acc)
Left _ -> pure (ctx', acc)
Right l -> do
(newCtx, evald) <- eval ctx x preference
(newCtx, evald) <- eval ctx' x preference
pure $ case evald of
Right res -> (newCtx, Right (l ++ [res]))
Left err -> (newCtx, Left err)
@ -338,11 +338,11 @@ macroExpand ctx xobj =
pure (newCtx, do ok <- expanded
Right (XObj (Lst ok) i t))
_ -> pure (ctx, Right xobj)
where successiveExpand (ctx, acc) x =
where successiveExpand (ctx', acc) x =
case acc of
Left _ -> pure (ctx, acc)
Left _ -> pure (ctx', acc)
Right l -> do
(newCtx, expanded) <- macroExpand ctx x
(newCtx, expanded) <- macroExpand ctx' x
pure $ case expanded of
Right res -> (newCtx, Right (l ++ [res]))
Left err -> (newCtx, Left err)
@ -387,17 +387,17 @@ executeString doCatch printResult ctx input fileName =
_ <- liftIO $ treatErr ctx (replaceChars (Map.fromList [('\n', " ")]) (show parseError)) parseErrorXObj
pure ctx
Right xobjs -> do
(res, ctx) <- foldM interactiveFolder
(res, ctx') <- foldM interactiveFolder
(XObj (Lst []) (Just dummyInfo) (Just UnitTy), ctx)
xobjs
when (printResult && ty res /= Just UnitTy)
when (printResult && xobjTy res /= Just UnitTy)
(putStrLnWithColor Yellow ("=> " ++ pretty res))
pure ctx
pure ctx'
interactiveFolder (_, context) xobj =
executeCommand context xobj
treatErr ctx e xobj = do
let fppl = projectFilePathPrintLength (contextProj ctx)
case contextExecMode ctx of
treatErr ctx' e xobj = do
let fppl = projectFilePathPrintLength (contextProj ctx')
case contextExecMode ctx' of
Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ e)
_ -> emitErrorWithLabel "PARSE ERROR" e
throw CancelEvaluationException
@ -431,19 +431,19 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj =
Left (HasStaticCall _ _) ->
callFromRepl newCtx xobj
Right result -> pure (result, newCtx)
where callFromRepl newCtx xobj = do
(nc, r) <- annotateWithinContext False newCtx xobj
Right res -> pure (res, newCtx)
where callFromRepl newCtx xobj' = do
(nc, r) <- annotateWithinContext False newCtx xobj'
case r of
Right (ann, deps) -> do
ctxWithDeps <- liftIO $ foldM (define True) nc deps
executeCommand ctxWithDeps (withBuildAndRun (buildMainFunction ann))
Left err -> do
reportExecutionError nc (show err)
pure (xobj, nc)
withBuildAndRun xobj =
pure (xobj', nc)
withBuildAndRun xobj' =
XObj (Lst [ XObj Do (Just dummyInfo) Nothing
, xobj
, xobj'
, XObj (Lst [XObj (Sym (SymPath [] "build") Symbol) (Just dummyInfo) Nothing])
(Just dummyInfo) Nothing
, XObj (Lst [XObj (Sym (SymPath [] "run") Symbol) (Just dummyInfo) Nothing])
@ -464,20 +464,15 @@ reportExecutionError ctx errorMessage =
catcher :: Context -> CarpException -> IO Context
catcher ctx exception =
case exception of
(ShellOutException message returnCode) ->
do emitErrorWithLabel "RUNTIME ERROR" message
stop returnCode
CancelEvaluationException ->
stop 1
EvalException evalError ->
do emitError (show evalError)
stop 1
where stop returnCode =
(ShellOutException message rc) -> emitErrorWithLabel "RUNTIME ERROR" message >> stop rc
CancelEvaluationException -> stop 1
EvalException err -> emitError (show err) >> stop 1
where stop rc =
case contextExecMode ctx of
Repl -> pure ctx
Build -> exitWith (ExitFailure returnCode)
Install _ -> exitWith (ExitFailure returnCode)
BuildAndRun -> exitWith (ExitFailure returnCode)
Build -> exitWith (ExitFailure rc)
Install _ -> exitWith (ExitFailure rc)
BuildAndRun -> exitWith (ExitFailure rc)
Check -> exitSuccess
specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
@ -511,32 +506,32 @@ specialCommandAddress ctx xobj =
Right (annXObj, _) -> return (newCtx, Right annXObj)
Left err ->
return (ctx, Left err)
_ -> return (evalError ctx ("Can't get the address of non-symbol " ++ pretty xobj) (info xobj))
_ -> return (evalError ctx ("Can't get the address of non-symbol " ++ pretty xobj) (xobjInfo xobj))
specialCommandWhile :: Context -> XObj -> XObj -> IO (Context, Either EvalError XObj)
specialCommandWhile ctx cond body = do
(newCtx, evd) <- evalDynamic ctx cond
case evd of
Right c ->
case obj c of
case xobjObj c of
Bol b -> if b
then do
(newCtx, _) <- evalDynamic newCtx body
specialCommandWhile newCtx cond body
(newCtx', _) <- evalDynamic newCtx body
specialCommandWhile newCtx' cond body
else
pure (newCtx, dynamicNil)
_ ->
pure (evalError ctx ("This `while` condition contains the non-boolean value '" ++
pretty c ++ "`") (info c))
pretty c ++ "`") (xobjInfo c))
Left e -> pure (newCtx, Left e)
getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> (Either EvalError (Maybe (Ty, XObj)))
getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i t) =
getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i ty) =
let pathStrings = contextPath ctx
path = (getPath xobj)
fullPath = case path of
(SymPath [] _) -> consPath pathStrings path
(SymPath _ _) -> path
metaData = existingMeta globalEnv (XObj (Sym fullPath Symbol) i t)
metaData = existingMeta globalEnv (XObj (Sym fullPath Symbol) i ty)
in case Meta.get "sig" metaData of
Just foundSignature ->
case xobjToTy foundSignature of
@ -544,7 +539,7 @@ getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i t) =
nameToken = XObj (Sym (SymPath [] (getName xobj)) Symbol) Nothing Nothing
recreatedSigForm = XObj (Lst [sigToken, nameToken, foundSignature]) Nothing (Just MacroTy)
in Right (Just (t, recreatedSigForm))
Nothing -> Left (EvalError ("Can't use '" ++ pretty foundSignature ++ "' as a type signature") (contextHistory ctx) fppl (info xobj))
Nothing -> Left (EvalError ("Can't use '" ++ pretty foundSignature ++ "' as a type signature") (contextHistory ctx) fppl (xobjInfo xobj))
Nothing -> Right Nothing
annotateWithinContext :: Bool -> Context -> XObj -> IO (Context, Either EvalError (XObj, [XObj]))
@ -568,10 +563,9 @@ annotateWithinContext qualifyDefn ctx xobj = do
Left err ->
case contextExecMode ctx of
Check ->
let fppl = projectFilePathPrintLength (contextProj ctx)
in pure (evalError ctx (joinLines (machineReadableErrorStrings fppl err)) Nothing)
pure (evalError ctx (joinLines (machineReadableErrorStrings fppl err)) Nothing)
_ ->
pure (evalError ctx (show err) (info xobj))
pure (evalError ctx (show err) (xobjInfo xobj))
Right ok -> pure (ctx, Right ok)
primitiveDefmodule :: Primitive
@ -580,42 +574,42 @@ primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput ex
defineIt meta = do
let parentEnv = getEnv env pathStrings
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
newModule = XObj (Mod innerEnv) (info xobj) (Just ModuleTy)
newModule = XObj (Mod innerEnv) (xobjInfo xobj) (Just ModuleTy)
globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
ctx' = Context globalEnvWithModuleAdded (Just (innerEnv{envParent=i})) typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history
(ctxAfterModuleDef, res) <- liftIO $ foldM folder (ctx', dynamicNil) innerExpressions
(ctxAfterModuleDef, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleDef{contextInternalEnv=i}, res)
(newCtx, result) <-
case lookupInEnv (SymPath pathStrings moduleName) env of
Just (_, Binder _ (XObj (Mod innerEnv) _ _)) -> do
let ctx' = Context env (Just innerEnv{envParent=i}) typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history -- TODO: use { = } syntax instead
(ctxAfterModuleAdditions, res) <- liftIO $ foldM folder (ctx', dynamicNil) innerExpressions
(ctxAfterModuleAdditions, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleAdditions{contextInternalEnv=i}, res) -- TODO: propagate errors...
Just (_, Binder existingMeta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
defineIt existingMeta
Just (_, Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
defineIt meta
Just (_, Binder _ _) ->
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (info xobj))
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj))
Nothing ->
defineIt emptyMeta
pure $ case result of
Left err -> (newCtx, Left err)
Right _ -> (newCtx, dynamicNil)
where folder (ctx, r) x =
where step (ctx', r) x =
case r of
Left _ -> pure (ctx, r)
Left _ -> pure (ctx', r)
Right _ -> do
(newCtx, result) <- macroExpand ctx x
case result of
(newCtx, res) <- macroExpand ctx' x
case res of
Left err -> pure (newCtx, Left err)
Right e -> do
(newCtx, result) <- evalDynamic newCtx e
case result of
Left err -> pure (newCtx, Left err)
Right _ -> pure (newCtx, r)
(newCtx', res') <- evalDynamic newCtx e
case res' of
Left err -> pure (newCtx', Left err)
Right _ -> pure (newCtx', r)
primitiveDefmodule _ ctx (x:_) =
pure (evalError ctx ("`defmodule` expects a symbol, got '" ++ pretty x ++ "' instead.") (info x))
pure (evalError ctx ("`defmodule` expects a symbol, got '" ++ pretty x ++ "' instead.") (xobjInfo x))
primitiveDefmodule _ ctx [] =
pure (evalError ctx "`defmodule` requires at least a symbol, received none." (Just dummyInfo))
@ -626,13 +620,13 @@ commandLoad :: CommandCallback
commandLoad ctx [xobj@(XObj (Str path) i _)] =
loadInternal ctx xobj path i DoesReload
commandLoad ctx [x] =
pure $ evalError ctx ("Invalid args to `load`: " ++ pretty x) (info x)
pure $ evalError ctx ("Invalid args to `load`: " ++ pretty x) (xobjInfo x)
commandLoadOnce :: CommandCallback
commandLoadOnce ctx [xobj@(XObj (Str path) i _)] =
loadInternal ctx xobj path i Frozen
commandLoadOnce ctx [x] =
pure $ evalError ctx ("Invalid args to `load-once`: " ++ pretty x) (info x)
pure $ evalError ctx ("Invalid args to `load-once`: " ++ pretty x) (xobjInfo x)
loadInternal :: Context -> XObj -> String -> Maybe Info -> ReloadMode -> IO (Context, Either EvalError XObj)
loadInternal ctx xobj path i reloadMode = do
@ -696,47 +690,47 @@ loadInternal ctx xobj path i reloadMode = do
isFrozen Frozen = True
isFrozen _ = False
fppl ctx =
projectFilePathPrintLength (contextProj ctx)
invalidPath ctx path =
evalError ctx
((case contextExecMode ctx of
fppl ctx' =
projectFilePathPrintLength (contextProj ctx')
invalidPath ctx' path' =
evalError ctx'
((case contextExecMode ctx' of
Check ->
machineReadableInfoFromXObj (fppl ctx) xobj ++ " I can't find a file named: '" ++ path ++ "'"
_ -> "I can't find a file named: '" ++ path ++ "'") ++
"\n\nIf you tried loading an external package, try appending a version string (like `@master`)") (info xobj)
invalidPathWith ctx path stderr cleanup cleanupPath = do
machineReadableInfoFromXObj (fppl ctx') xobj ++ " I can't find a file named: '" ++ path' ++ "'"
_ -> "I can't find a file named: '" ++ path' ++ "'") ++
"\n\nIf you tried loading an external package, try appending a version string (like `@master`)") (xobjInfo xobj)
invalidPathWith ctx' path' stderr cleanup cleanupPath = do
_ <- liftIO $ when cleanup (removeDirectoryRecursive cleanupPath)
pure $ evalError ctx
((case contextExecMode ctx of
pure $ evalError ctx'
((case contextExecMode ctx' of
Check ->
machineReadableInfoFromXObj (fppl ctx) xobj ++ " I can't find a file named: '" ++ path ++ "'"
_ -> "I can't find a file named: '" ++ path ++ "'") ++
machineReadableInfoFromXObj (fppl ctx') xobj ++ " I can't find a file named: '" ++ path' ++ "'"
_ -> "I can't find a file named: '" ++ path' ++ "'") ++
"\n\nI tried interpreting the statement as a git import, but got: " ++ stderr)
(info xobj)
(xobjInfo xobj)
replaceC _ _ [] = []
replaceC c s (a:b) = if a == c then s ++ replaceC c s b else a : replaceC c s b
cantLoadSelf ctx path =
case contextExecMode ctx of
cantLoadSelf ctx' path' =
case contextExecMode ctx' of
Check ->
evalError ctx (machineReadableInfoFromXObj (fppl ctx) xobj ++ " A file can't load itself: '" ++ path ++ "'") (info xobj)
evalError ctx' (machineReadableInfoFromXObj (fppl ctx') xobj ++ " A file can't load itself: '" ++ path' ++ "'") (xobjInfo xobj)
_ ->
evalError ctx ("A file can't load itself: '" ++ path ++ "'") (info xobj)
tryInstall path =
let split = splitOn "@" path
evalError ctx' ("A file can't load itself: '" ++ path' ++ "'") (xobjInfo xobj)
tryInstall path' =
let split = splitOn "@" path'
in tryInstallWithCheckout (joinWith "@" (init split)) (last split)
fromURL url =
let split = splitOn "/" (replaceC ':' "_COLON_" url)
fst = head split
in if fst `elem` ["https_COLON_", "http_COLON_"]
first = head split
in if first `elem` ["https_COLON_", "http_COLON_"]
then joinWith "/" (tail (tail split))
else
if '@' `elem` fst
then joinWith "/" (joinWith "@" (tail (splitOn "@" fst)) : tail split)
if '@' `elem` first
then joinWith "/" (joinWith "@" (tail (splitOn "@" first)) : tail split)
else url
tryInstallWithCheckout path toCheckout = do
tryInstallWithCheckout path' toCheckout = do
let proj = contextProj ctx
fpath <- liftIO $ cachePath $ projectLibDir proj </> fromURL path </> toCheckout
fpath <- liftIO $ cachePath $ projectLibDir proj </> fromURL path' </> toCheckout
cur <- liftIO getCurrentDirectory
pathExists <- liftIO $ doesPathExist fpath
let cleanup = not pathExists
@ -746,23 +740,23 @@ loadInternal ctx xobj path i reloadMode = do
if txt == "HEAD\n"
then do
_ <- liftIO $ setCurrentDirectory cur
doGitLoad path fpath
doGitLoad path' fpath
else do
_ <- liftIO $ readProcessWithExitCode "git" ["init"] ""
_ <- liftIO $ readProcessWithExitCode "git" ["remote", "add", "origin", path] ""
_ <- liftIO $ readProcessWithExitCode "git" ["remote", "add", "origin", path'] ""
(x0, _, stderr0) <- liftIO $ readProcessWithExitCode "git" ["fetch", "--all", "--tags"] ""
case x0 of
ExitFailure _ -> do
_ <- liftIO $ setCurrentDirectory cur
invalidPathWith ctx path stderr0 cleanup fpath
invalidPathWith ctx path' stderr0 cleanup fpath
ExitSuccess -> do
(x1, _, stderr1) <- liftIO $ readProcessWithExitCode "git" ["checkout", toCheckout] ""
_ <- liftIO $ setCurrentDirectory cur
case x1 of
ExitSuccess -> doGitLoad path fpath
ExitFailure _ -> invalidPathWith ctx path stderr1 cleanup fpath
doGitLoad path fpath =
let fName = last (splitOn "/" path)
ExitSuccess -> doGitLoad path' fpath
ExitFailure _ -> invalidPathWith ctx path' stderr1 cleanup fpath
doGitLoad path' fpath =
let fName = last (splitOn "/" path')
realName' = if ".git" `isSuffixOf` fName
then take (length fName - 4) fName
else fName
@ -785,9 +779,9 @@ loadFilesOnce :: Context -> [FilePath] -> IO Context
loadFilesOnce = loadFilesExt commandLoadOnce
loadFilesExt :: CommandCallback -> Context -> [FilePath] -> IO Context
loadFilesExt loadCmd ctxStart filesToLoad = foldM folder ctxStart filesToLoad
where folder :: Context -> FilePath -> IO Context
folder ctx file = do
loadFilesExt loadCmd ctxStart filesToLoad = foldM load ctxStart filesToLoad
where load :: Context -> FilePath -> IO Context
load ctx file = do
(newCtx, ret) <- loadCmd ctx [XObj (Str file) Nothing Nothing]
case ret of
Left err -> throw (EvalException err)
@ -827,7 +821,7 @@ commandC ctx [xobj] = do
Left err -> pure (newCtx, Left err)
Right expanded ->
case annotate typeEnv globalEnv (setFullyQualifiedSymbols typeEnv globalEnv globalEnv expanded) Nothing of
Left err -> pure $ evalError newCtx (show err) (info xobj)
Left err -> pure $ evalError newCtx (show err) (xobjInfo xobj)
Right (annXObj, annDeps) ->
do let cXObj = printC annXObj
cDeps = concatMap printC annDeps
@ -850,7 +844,7 @@ buildMainFunction xobj =
, XObj (Sym (SymPath [] "main") Symbol) di Nothing
, XObj (Arr []) di Nothing
, XObj (Lst [ XObj Do di Nothing
, case ty xobj of
, case xobjTy xobj of
Just UnitTy -> xobj
Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing, xobj])
di (Just UnitTy)
@ -870,11 +864,11 @@ primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do
Right evaledBody ->
dynamicOrMacroWith newCtx (\path -> [XObj DefDynamic Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, evaledBody]) DynamicTy name value
primitiveDefdynamic _ ctx [notName, _] =
pure (evalError ctx ("`defndynamic` expected a name as first argument, but got " ++ pretty notName) (info notName))
pure (evalError ctx ("`defndynamic` expected a name as first argument, but got " ++ pretty notName) (xobjInfo notName))
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
(newCtx, result) <- evalDynamic ctx value
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
(newCtx, result) <- evalDynamic ctx val
case result of
Left err -> pure (newCtx, Left err)
Right evald -> do
@ -882,31 +876,31 @@ specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
case contextInternalEnv ctx of
Nothing -> setGlobal newCtx globalEnv evald
Just env -> setInternal newCtx env evald
where setGlobal ctx env value =
where setGlobal ctx' env value =
case lookupInEnv path env of
Just (_, binder) -> do
(ctx', typedVal) <- typeCheckValueAgainstBinder ctx value binder
pure $ either (failure ctx) (success ctx') typedVal
(ctx'', typedVal) <- typeCheckValueAgainstBinder ctx' value binder
pure $ either (failure ctx'') (success ctx'') typedVal
where success c xo = (c{contextGlobalEnv = setStaticOrDynamicVar path env binder xo}, dynamicNil)
Nothing -> pure (ctx, Right value)
setInternal ctx env value =
setInternal ctx' env value =
case lookupInEnv path env of
Just (_, binder) -> do
-- TODO: Type check local bindings.
-- At the moment, let bindings are not structured the same as global defs or dynamic defs.
-- This makes calls to the type check problematic, as we cannot work against a common binding form.
-- Once we better support let bindings, type check them.
(ctx', typedVal) <- typeCheckValueAgainstBinder ctx value binder
pure $ if contextPath ctx == mod
then either (failure ctx) (success ctx') typedVal
else (ctx', dynamicNil)
(ctx'', typedVal) <- typeCheckValueAgainstBinder ctx' value binder
pure $ if contextPath ctx'' == mod
then either (failure ctx'') (success ctx'') typedVal
else (ctx'', dynamicNil)
where success c xo = (c{contextInternalEnv = Just (setStaticOrDynamicVar (SymPath [] n) env binder xo)}, dynamicNil)
-- If the def isn't found in the internal environment, check the global environment.
Nothing -> setGlobal ctx (contextGlobalEnv ctx) value
Nothing -> setGlobal ctx' (contextGlobalEnv ctx') value
specialCommandSet ctx [notName, _] =
pure (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (info 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 info (head 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)))
-- | Convenience method for signifying failure in a given context.
failure :: Context -> EvalError -> (Context, Either EvalError a)
@ -921,10 +915,10 @@ typeCheckValueAgainstBinder ctx val binder = do
Right (val', _) -> go ctx' binderTy val'
Left err -> (ctx', Left err)
where path = (getPath (binderXObj binder))
binderTy = ty (binderXObj binder)
typeErr x = evalError ctx ("can't `set!` " ++ show path ++ " to a value of type " ++ show (fromJust (ty x)) ++ ", " ++ show path ++ " has type " ++ show (fromJust binderTy)) (info x)
go ctx (Just DynamicTy) x = (ctx, Right x)
go ctx t x@(XObj _ _ t') = if t == t' then (ctx, Right x) else typeErr x
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)
go ctx'' t x@(XObj _ _ t') = if t == t' then (ctx'', Right x) else typeErr x
-- | Sets a variable, checking whether or not it is static or dynamic, and
-- assigns an appropriate type to the variable.
@ -933,11 +927,11 @@ setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
setStaticOrDynamicVar path env binder value =
case binder of
(Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (info value) t)) env
envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)) env
(Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (info value) (Just DynamicTy))) env
envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))) env
(Binder meta (XObj (Lst (lett@(XObj LetDef _ _) : sym : _)) _ t)) ->
envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (info value) t)) env
envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)) env
-- shouldn't happen, errors are thrown at call sites.
-- TODO: Return an either here to propagate error.
_ -> env
@ -991,9 +985,9 @@ primitiveAnd _ ctx [a, b] = do
Left e -> (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->
(newCtx', Right (boolToXObj bb))
Right b -> evalError ctx ("Can’t call `or` on " ++ pretty b) (info b)
Right b' -> evalError ctx ("Can’t call `or` on " ++ pretty b') (xobjInfo b')
else pure (newCtx, Right falseXObj)
Right a -> pure (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a))
Right a' -> pure (evalError ctx ("Can’t call `or` on " ++ pretty a') (xobjInfo a'))
primitiveOr :: Primitive
primitiveOr _ ctx [a, b] = do
@ -1009,5 +1003,6 @@ primitiveOr _ ctx [a, b] = do
Left e -> (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->
(newCtx', Right (boolToXObj bb))
Right b -> evalError ctx ("Can’t call `or` on " ++ pretty b) (info b)
Right a -> pure (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a))
Right o -> err o
Right o -> pure (err o)
where err o = evalError ctx ("Can’t call `or` on " ++ pretty o) (xobjInfo o)

103
src/Expand.hs
View File

@ -17,20 +17,20 @@ type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj)
-- | Note: comparing environments is tricky! Make sure they *can* be equal, otherwise this won't work at all!
expandAll :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expandAll eval ctx root =
do (ctx, fullyExpanded) <- expandAllInternal root
pure (ctx, fmap setNewIdentifiers fullyExpanded)
do (ctx', fullyExpanded) <- expandAllInternal root
pure (ctx', fmap setNewIdentifiers fullyExpanded)
where expandAllInternal xobj =
do (newCtx, expansionResult) <- expand eval ctx xobj
case expansionResult of
Right expanded -> if expanded == xobj
then pure (ctx, Right expanded)
then pure (newCtx, Right expanded)
else expandAll eval newCtx expanded
err -> pure (newCtx, err)
-- | Macro expansion of a single form
expand :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expand eval ctx xobj =
case obj xobj of
case xobjObj xobj of
--case obj (trace ("Expand: " ++ pretty xobj) xobj) of
Lst _ -> expandList xobj
Arr _ -> expandArray xobj
@ -47,24 +47,24 @@ expand eval ctx xobj =
XObj (Deftemplate _) _ _ : _ -> pure (ctx, Right xobj)
XObj (Defalias _) _ _ : _ -> pure (ctx, Right xobj)
[defnExpr@(XObj (Defn _) _ _), name, args, body] ->
do (ctx, expandedBody) <- expand eval ctx body
pure (ctx, do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t))
do (ctx', expandedBody) <- expand eval ctx body
pure (ctx', do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t))
[defExpr@(XObj Def _ _), name, expr] ->
do (ctx, expandedExpr) <- expand eval ctx expr
pure (ctx, do okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t))
do (ctx', expandedExpr) <- expand eval ctx expr
pure (ctx', do okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t))
[theExpr@(XObj The _ _), typeXObj, value] ->
do (ctx, expandedValue) <- expand eval ctx value
pure (ctx, do okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t))
do (ctx', expandedValue) <- expand eval ctx value
pure (ctx', do okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t))
(XObj The _ _ : _) ->
pure (evalError ctx ("I didn’t understand the `the` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.") Nothing)
[ifExpr@(XObj If _ _), condition, trueBranch, falseBranch] ->
do (ctx, expandedCondition) <- expand eval ctx condition
(ctx, expandedTrueBranch) <- expand eval ctx trueBranch
(ctx, expandedFalseBranch) <- expand eval ctx falseBranch
pure (ctx, do okCondition <- expandedCondition
do (ctx', expandedCondition) <- expand eval ctx condition
(ctx'', expandedTrueBranch) <- expand eval ctx' trueBranch
(nct, expandedFalseBranch) <- expand eval ctx'' falseBranch
pure (nct, do okCondition <- expandedCondition
okTrueBranch <- expandedTrueBranch
okFalseBranch <- expandedFalseBranch
-- This is a HACK so that each branch of the if statement
@ -75,51 +75,35 @@ expand eval ctx xobj =
let wrappedTrue =
case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (info okTrueBranch) Nothing
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (xobjInfo okTrueBranch) Nothing
wrappedFalse =
case okFalseBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (info okFalseBranch) Nothing
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (xobjInfo okFalseBranch) Nothing
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t))
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings)
then do (ctx, bind) <- foldlM successiveExpand (ctx, Right []) (pairwise bindings)
(newCtx, expandedBody) <- expand eval ctx body
then do (ctx', bind) <- foldlM successiveExpandLR (ctx, Right []) (pairwise bindings)
(newCtx, expandedBody) <- expand eval ctx' body
pure (newCtx, do okBindings <- bind
okBody <- expandedBody
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t))
else pure (evalError ctx (
"I ecountered an odd number of forms inside a `let` (`" ++
pretty xobj ++ "`)") (info xobj))
where successiveExpand (ctx, acc) (n, x) =
case acc of
Left _ -> pure (ctx, acc)
Right l -> do
(newCtx, x') <- expand eval ctx x
case x' of
Left err -> pure (newCtx, Left err)
Right okX -> pure (newCtx, Right (l ++ [[n, okX]]))
pretty xobj ++ "`)") (xobjInfo xobj))
matchExpr@(XObj (Match _) _ _) : (expr : rest)
| null rest ->
pure (evalError ctx "I encountered a `match` without forms" (info xobj))
pure (evalError ctx "I encountered a `match` without forms" (xobjInfo xobj))
| even (length rest) ->
do (ctx, expandedExpr) <- expand eval ctx expr
(newCtx, expandedPairs) <- foldlM successiveExpand (ctx, Right []) (pairwise rest)
do (ctx', expandedExpr) <- expand eval ctx expr
(newCtx, expandedPairs) <- foldlM successiveExpandLR (ctx', Right []) (pairwise rest)
pure (newCtx, do okExpandedExpr <- expandedExpr
okExpandedPairs <- expandedPairs
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t))
| otherwise -> pure (evalError ctx
"I encountered an odd number of forms inside a `match`" (info xobj))
where successiveExpand (ctx, acc) (l, r) =
case acc of
Left _ -> pure (ctx, acc)
Right lst -> do
(newCtx, expandedR) <- expand eval ctx r
case expandedR of
Left err -> pure (newCtx, Left err)
Right v -> pure (newCtx, Right (lst ++ [[l, v]]))
"I encountered an odd number of forms inside a `match`" (xobjInfo xobj))
doExpr@(XObj Do _ _) : expressions ->
do (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions
@ -141,7 +125,7 @@ expand eval ctx xobj =
XObj (Mod modEnv) _ _ : args ->
let pathToModule = pathToEnv modEnv
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
in expand eval ctx (XObj (Lst (implicitInit : args)) (info xobj) (ty xobj))
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
f:args ->
do (_, expandedF) <- expand eval ctx f
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
@ -181,18 +165,27 @@ expand eval ctx xobj =
Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
where
isPrivate m x = pure $ if metaIsTrue m "private"
then evalError ctx ("The binding: " ++ pretty sym ++ " is private; it may only be used within the module that defines it.") (info sym)
then evalError ctx ("The binding: " ++ pretty sym ++ " is private; it may only be used within the module that defines it.") (xobjInfo sym)
else (ctx, Right x)
expandSymbol _ = pure (evalError ctx "Can't expand non-symbol in expandSymbol." Nothing)
successiveExpand (ctx, acc) e =
successiveExpand (ctx', acc) e =
case acc of
Left _ -> pure (ctx, acc)
Left _ -> pure (ctx', acc)
Right lst -> do
(newCtx, expanded) <- expand eval ctx e
(newCtx, expanded) <- expand eval ctx' e
pure $ case expanded of
Right e -> (newCtx, Right (lst ++ [e]))
Left err -> (ctx, Left err)
Right err -> (newCtx, Right (lst ++ [err]))
Left err -> (newCtx, Left err)
successiveExpandLR (ctx', acc) (l, r) =
case acc of
Left _ -> pure (ctx', acc)
Right lst -> do
(newCtx, expandedR) <- expand eval ctx' r
case expandedR of
Right v -> pure (newCtx, Right (lst ++ [[l, v]]))
Left err -> pure (newCtx, Left err)
-- | Replace all the infoIdentifier:s on all nested XObj:s
setNewIdentifiers :: XObj -> XObj
@ -202,7 +195,7 @@ setNewIdentifiers root = let final = evalState (visit root) 0
where
visit :: XObj -> State Int XObj
visit xobj =
case obj xobj of
case xobjObj xobj of
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj
@ -233,8 +226,8 @@ setNewIdentifiers root = let final = evalState (visit root) 0
bumpAndSet xobj =
do counter <- get
put (counter + 1)
pure $ case info xobj of
Just i -> (xobj { info = Just (i { infoIdentifier = counter })})
pure $ case xobjInfo xobj of
Just i -> (xobj { xobjInfo = Just (i { infoIdentifier = counter })})
Nothing -> xobj
-- | Replaces the file, line and column info on an XObj an all its children.
@ -243,7 +236,7 @@ replaceSourceInfo newFile newLine newColumn root = visit root
where
visit :: XObj -> XObj
visit xobj =
case obj xobj of
case xobjObj xobj of
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
_ -> setNewInfo xobj
@ -261,8 +254,8 @@ replaceSourceInfo newFile newLine newColumn root = visit root
setNewInfo :: XObj -> XObj
setNewInfo xobj =
case info xobj of
Just i -> (xobj { info = Just (i { infoFile = newFile
case xobjInfo xobj of
Just i -> (xobj { xobjInfo = Just (i { infoFile = newFile
, infoLine = newLine
, infoColumn = newColumn
})})

96
src/GenerateConstraints.hs
View File

@ -1,6 +1,6 @@
module GenerateConstraints (genConstraints) where
import Control.Arrow
import Control.Arrow hiding(arr)
import Control.Monad.State
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Set as Set
@ -18,8 +18,8 @@ genConstraints :: Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError [Constrain
genConstraints _ root rootSig = fmap sort (gen root)
where genF xobj args body captures =
do insideBodyConstraints <- gen body
xobjType <- toEither (ty xobj) (DefnMissingType xobj)
bodyType <- toEither (ty body) (ExpressionMissingType xobj)
xobjType <- toEither (xobjTy xobj) (DefnMissingType xobj)
bodyType <- toEither (xobjTy body) (ExpressionMissingType xobj)
let (FuncTy argTys retTy lifetimeTy) = xobjType
bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody
argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args
@ -45,7 +45,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
captureList)
pure (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs ++ sigConstr)
gen xobj =
case obj xobj of
case xobjObj xobj of
Lst lst -> case lst of
-- Defn
[XObj (Defn captures) _ _, _, XObj (Arr args) _ _, body] ->
@ -58,8 +58,8 @@ genConstraints _ root rootSig = fmap sort (gen root)
-- Def
[XObj Def _ _, _, expr] ->
do insideExprConstraints <- gen expr
xobjType <- toEither (ty xobj) (DefMissingType xobj)
exprType <- toEither (ty expr) (ExpressionMissingType xobj)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
exprType <- toEither (xobjTy expr) (ExpressionMissingType xobj)
let defConstraint = Constraint xobjType exprType xobj expr xobj OrdDefExpr
sigConstr = case rootSig of
Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation]
@ -70,9 +70,9 @@ genConstraints _ root rootSig = fmap sort (gen root)
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
do insideBodyConstraints <- gen body
insideBindingsConstraints <- fmap join (mapM gen bindings)
bodyType <- toEither (ty body) (ExpressionMissingType body)
let Just xobjTy = ty xobj
wholeStatementConstraint = Constraint bodyType xobjTy body xobj xobj OrdLetBody
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let Just xobjTy' = xobjTy xobj
wholeStatementConstraint = Constraint bodyType xobjTy' body xobj xobj OrdLetBody
bindingsConstraints = zipWith (\(symTy, exprTy) (symObj, exprObj) ->
Constraint symTy exprTy symObj exprObj xobj OrdLetBind)
(List.map (forceTy *** forceTy) (pairwise bindings))
@ -85,13 +85,13 @@ genConstraints _ root rootSig = fmap sort (gen root)
do insideConditionConstraints <- gen expr
insideTrueConstraints <- gen ifTrue
insideFalseConstraints <- gen ifFalse
exprType <- toEither (ty expr) (ExpressionMissingType expr)
trueType <- toEither (ty ifTrue) (ExpressionMissingType ifTrue)
falseType <- toEither (ty ifFalse) (ExpressionMissingType ifFalse)
let expected = XObj (Sym (SymPath [] "Condition in if value") Symbol) (info expr) (Just BoolTy)
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
trueType <- toEither (xobjTy ifTrue) (ExpressionMissingType ifTrue)
falseType <- toEither (xobjTy ifFalse) (ExpressionMissingType ifFalse)
let expected = XObj (Sym (SymPath [] "Condition in if value") Symbol) (xobjInfo expr) (Just BoolTy)
let conditionConstraint = Constraint exprType BoolTy expr expected xobj OrdIfCondition
sameReturnConstraint = Constraint trueType falseType ifTrue ifFalse xobj OrdIfReturn
Just t = ty xobj
Just t = xobjTy xobj
wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole
pure (conditionConstraint : sameReturnConstraint :
wholeStatementConstraint : insideConditionConstraints ++
@ -102,8 +102,8 @@ genConstraints _ root rootSig = fmap sort (gen root)
do insideExprConstraints <- gen expr
casesLhsConstraints <- fmap join (mapM (genConstraintsForCaseMatcher matchMode . fst) (pairwise cases))
casesRhsConstraints <- fmap join (mapM (gen . snd) (pairwise cases))
exprType <- toEither (ty expr) (ExpressionMissingType expr)
xobjType <- toEither (ty xobj) (DefMissingType xobj)
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
let
-- Each case rhs should have the same return type as the whole match form:
@ -145,10 +145,10 @@ genConstraints _ root rootSig = fmap sort (gen root)
[XObj While _ _, expr, body] ->
do insideConditionConstraints <- gen expr
insideBodyConstraints <- gen body
exprType <- toEither (ty expr) (ExpressionMissingType expr)
bodyType <- toEither (ty body) (ExpressionMissingType body)
let expectedCond = XObj (Sym (SymPath [] "Condition in while-expression") Symbol) (info expr) (Just BoolTy)
expectedBody = XObj (Sym (SymPath [] "Body in while-expression") Symbol) (info xobj) (Just UnitTy)
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let expectedCond = XObj (Sym (SymPath [] "Condition in while-expression") Symbol) (xobjInfo expr) (Just BoolTy)
expectedBody = XObj (Sym (SymPath [] "Body in while-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
conditionConstraint = Constraint exprType BoolTy expr expectedCond xobj OrdWhileCondition
wholeStatementConstraint = Constraint bodyType UnitTy body expectedBody xobj OrdWhileBody
pure (conditionConstraint : wholeStatementConstraint :
@ -160,10 +160,10 @@ genConstraints _ root rootSig = fmap sort (gen root)
[] -> Left (NoStatementsInDo xobj)
_ -> let lastExpr = last expressions
in do insideExpressionsConstraints <- fmap join (mapM gen expressions)
xobjType <- toEither (ty xobj) (DefMissingType xobj)
lastExprType <- toEither (ty lastExpr) (ExpressionMissingType xobj)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
lastExprType <- toEither (xobjTy lastExpr) (ExpressionMissingType xobj)
let retConstraint = Constraint xobjType lastExprType xobj lastExpr xobj OrdDoReturn
must = XObj (Sym (SymPath [] "Statement in do-expression") Symbol) (info xobj) (Just UnitTy)
must = XObj (Sym (SymPath [] "Statement in do-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
mkConstr x@(XObj _ _ (Just t)) = Just (Constraint t UnitTy x must xobj OrdDoStatement)
mkConstr _ = Nothing
expressionsShouldReturnUnit = mapMaybe mkConstr (init expressions)
@ -177,16 +177,16 @@ genConstraints _ root rootSig = fmap sort (gen root)
[XObj SetBang _ _, variable, value] ->
do insideValueConstraints <- gen value
insideVariableConstraints <- gen variable
variableType <- toEither (ty variable) (ExpressionMissingType variable)
valueType <- toEither (ty value) (ExpressionMissingType value)
variableType <- toEither (xobjTy variable) (ExpressionMissingType variable)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let sameTypeConstraint = Constraint variableType valueType variable value xobj OrdSetBang
pure (sameTypeConstraint : insideValueConstraints ++ insideVariableConstraints)
-- The
[XObj The _ _, _, value] ->
do insideValueConstraints <- gen value
xobjType <- toEither (ty xobj) (DefMissingType xobj)
valueType <- toEither (ty value) (DefMissingType value)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
valueType <- toEither (xobjTy value) (DefMissingType value)
let theTheConstraint = Constraint xobjType valueType xobj value xobj OrdThe
pure (theTheConstraint : insideValueConstraints)
@ -197,9 +197,9 @@ genConstraints _ root rootSig = fmap sort (gen root)
-- Deref
[XObj Deref _ _, value] ->
do insideValueConstraints <- gen value
xobjType <- toEither (ty xobj) (ExpressionMissingType xobj)
valueType <- toEither (ty value) (ExpressionMissingType value)
let lt = VarTy (makeTypeVariableNameFromInfo (info xobj))
xobjType <- toEither (xobjTy xobj) (ExpressionMissingType xobj)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let lt = VarTy (makeTypeVariableNameFromInfo (xobjInfo xobj))
let theTheConstraint = Constraint (RefTy xobjType lt) valueType xobj value xobj OrdDeref
pure (theTheConstraint : insideValueConstraints)
@ -211,7 +211,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
func : args ->
do funcConstraints <- gen func
variablesConstraints <- fmap join (mapM gen args)
funcTy <- toEither (ty func) (ExpressionMissingType func)
funcTy <- toEither (xobjTy func) (ExpressionMissingType func)
case funcTy of
(FuncTy argTys retTy _) ->
if length args /= length argTys then
@ -219,18 +219,18 @@ genConstraints _ root rootSig = fmap sort (gen root)
else
let expected t n =
XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName func ++ "'")) Symbol)
(info func) (Just t)
(xobjInfo func) (Just t)
argConstraints = zipWith4 (\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy args)
argTys
args
[0..]
Just xobjTy = ty xobj
retConstraint = Constraint xobjTy retTy xobj func xobj OrdFuncAppRet
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj func xobj OrdFuncAppRet
in pure (retConstraint : funcConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy args) (forceTy xobj) (VarTy "what?!")
expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (info func) Nothing
expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (xobjInfo func) Nothing
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType func expected xobj OrdFuncAppVarTy
in pure (wholeTypeConstraint : funcConstraints ++ variablesConstraints)
_ -> Left (NotAFunction func)
@ -242,12 +242,12 @@ genConstraints _ root rootSig = fmap sort (gen root)
case arr of
[] -> Right []
x:xs -> do insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = ty x
let Just headTy = xobjTy x
genObj o n = XObj (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(info o) (ty o)
(xobjInfo o) (xobjTy o)
headObj = XObj (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
(info x) (Just headTy)
Just (StructTy (ConcreteNameTy "Array") [t]) = ty xobj
(xobjInfo x) (Just headTy)
Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
@ -257,12 +257,12 @@ genConstraints _ root rootSig = fmap sort (gen root)
case arr of
[] -> Right []
x:xs -> do insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = ty x
let Just headTy = xobjTy x
genObj o n = XObj (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(info o) (ty o)
(xobjInfo o) (xobjTy o)
headObj = XObj (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
(info x) (Just headTy)
Just (RefTy(StructTy (ConcreteNameTy "StaticArray") [t]) _) = ty xobj
(xobjInfo x) (Just headTy)
Just (RefTy(StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
@ -279,24 +279,24 @@ genConstraintsForCaseMatcher matchMode = gen
gen xobj@(XObj (Lst (caseName : variables)) _ _) =
do caseNameConstraints <- gen caseName
variablesConstraints <- fmap join (mapM gen variables)
caseNameTy <- toEither (ty caseName) (ExpressionMissingType caseName)
caseNameTy <- toEither (xobjTy caseName) (ExpressionMissingType caseName)
case caseNameTy of
(FuncTy argTys retTy _) ->
if length variables /= length argTys then
Left (WrongArgCount caseName (length argTys) (length variables)) -- | TODO: This could be another error since this isn't an actual function call.
else
let expected t n = XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName caseName ++ "'")) Symbol) (info caseName) (Just t)
let expected t n = XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) (Just t)
argConstraints = zipWith4 (\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy variables)
(zipWith refWrapper variables argTys)
variables
[0..]
Just xobjTy = ty xobj
retConstraint = Constraint xobjTy retTy xobj caseName xobj OrdFuncAppRet
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj caseName xobj OrdFuncAppRet
in pure (retConstraint : caseNameConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy variables) (forceTy xobj) (VarTy "what?!") -- | TODO: Fix
expected = XObj (Sym (SymPath [] ("Matchin on '" ++ getName caseName ++ "'")) Symbol) (info caseName) Nothing
expected = XObj (Sym (SymPath [] ("Matchin on '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) Nothing
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType caseName expected xobj OrdFuncAppVarTy
in pure (wholeTypeConstraint : caseNameConstraints ++ variablesConstraints)
_ -> Left (NotAFunction caseName) -- | TODO: This error could be more specific too, since it's not an actual function call.

46
src/InitialTypes.hs
View File

@ -65,16 +65,16 @@ initialTypes :: TypeEnv -> Env -> XObj -> Either TypeError XObj
initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
where
visit :: Env -> XObj -> State Integer (Either TypeError XObj)
visit env xobj = case obj xobj of
(Num t _) -> pure (Right (xobj { ty = Just t }))
(Bol _) -> pure (Right (xobj { ty = Just BoolTy }))
visit env xobj = case xobjObj xobj of
(Num t _) -> pure (Right (xobj { xobjTy = Just t }))
(Bol _) -> pure (Right (xobj { xobjTy = Just BoolTy }))
(Str _) -> do lt <- genVarTy
pure (Right (xobj { ty = Just (RefTy StringTy lt) }))
pure (Right (xobj { xobjTy = Just (RefTy StringTy lt) }))
(Pattern _) -> do lt <- genVarTy
pure (Right (xobj { ty = Just (RefTy PatternTy lt) }))
(Chr _) -> pure (Right (xobj { ty = Just CharTy }))
Break -> pure (Right (xobj { ty = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Command _) -> pure (Right (xobj { ty = Just DynamicTy }))
pure (Right (xobj { xobjTy = Just (RefTy PatternTy lt) }))
(Chr _) -> pure (Right (xobj { xobjTy = Just CharTy }))
Break -> pure (Right (xobj { xobjTy = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Command _) -> pure (Right (xobj { xobjTy = Just DynamicTy }))
(Lst _) -> visitList env xobj
(Arr _) -> visitArray env xobj
(StaticArr _) -> visitStaticArray env xobj
@ -112,27 +112,27 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
visitSymbol _ xobj@(XObj (Sym _ LookupRecursive) _ _) _ =
-- Recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to)
do freshTy <- genVarTy
pure (Right xobj { ty = Just freshTy })
pure (Right xobj { xobjTy = Just freshTy })
visitSymbol env xobj symPath =
case symPath of
-- Symbols with leading ? are 'holes'.
SymPath _ name@('?' : _) -> pure (Right (xobj { ty = Just (VarTy name) }))
SymPath _ name@('?' : _) -> pure (Right (xobj { xobjTy = Just (VarTy name) }))
SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
_ ->
case lookupInEnv symPath env of
Just (foundEnv, binder) ->
case ty (binderXObj binder) of
case xobjTy (binderXObj binder) of
-- Don't rename internal symbols like parameters etc!
Just theType | envIsExternal foundEnv -> do renamed <- renameVarTys theType
pure (Right (xobj { ty = Just renamed }))
| otherwise -> pure (Right (xobj { ty = Just theType }))
pure (Right (xobj { xobjTy = Just renamed }))
| otherwise -> pure (Right (xobj { xobjTy = Just theType }))
Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
do freshTy <- genVarTy
pure (Right xobj { ty = Just freshTy })
pure (Right xobj { xobjTy = Just freshTy })
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
@ -140,7 +140,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
Just (_, Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
Nothing -> genVarTy
pure (Right xobj { ty = Just freshTy })
pure (Right xobj { xobjTy = Just freshTy })
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
visitArray env (XObj (Arr xobjs) i _) =
@ -183,7 +183,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
[defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
typedNameSymbol = nameSymbol { ty = funcTy }
typedNameSymbol = nameSymbol { xobjTy = funcTy }
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
visitedBody <- visit envWithSelf body
@ -312,7 +312,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
[addressExpr@(XObj Address _ _), value] ->
do visitedValue <- visit env value
pure $ do okValue <- visitedValue
let Just t' = ty okValue
let Just t' = xobjTy okValue
pure (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t')))
-- Set!
@ -341,7 +341,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
_ | isLiteral value -> pure StaticLifetimeTy
| otherwise -> genVarTy
pure $ do okValue <- visitedValue
let Just valueTy = ty okValue
let Just valueTy = xobjTy okValue
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
-- Deref (error!)
@ -369,7 +369,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
pure (XObj (Lst (okFunc : okArgs)) i (Just t))
-- Empty list
[] -> pure (Right xobj { ty = Just UnitTy })
[] -> pure (Right xobj { xobjTy = Just UnitTy })
visitList _ _ = error "Must match on list!"
@ -391,7 +391,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
case envOrErr of
Left err -> pure (Left err)
Right env' ->
case obj sym of
case xobjObj sym of
(Sym (SymPath _ name) _) ->
do visited <- visit env' expr
pure (envAddBinding env' name . Binder emptyMeta <$> visited)
@ -410,10 +410,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
where
createBinderForParam :: XObj -> State Integer (String, Binder)
createBinderForParam xobj =
case obj xobj of
case xobjObj xobj of
(Sym (SymPath _ name) _) ->
do t <- genVarTy
let xobjWithTy = xobj { ty = Just t }
let xobjWithTy = xobj { xobjTy = Just t }
pure (name, Binder emptyMeta xobjWithTy)
_ -> error "Can't create binder for non-symbol parameter."
@ -442,7 +442,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
if isVarName name
-- A variable that will bind to something:
then do freshTy <- genVarTy
pure [(name, Binder emptyMeta xobj { ty = Just freshTy })]
pure [(name, Binder emptyMeta xobj { xobjTy = Just freshTy })]
-- Tags for the sumtypes won't bind to anything:
else pure []

4
src/Interfaces.hs
View File

@ -84,5 +84,5 @@ retroactivelyRegisterInInterface ctx interface@(SymPath _ _) =
where env = contextGlobalEnv ctx
impls = recursiveLookupAll interface lookupImplementations env
resultCtx = foldl' folder (Right ctx) impls
folder ctx' binder = either Left register ctx'
where register ok = registerInInterface ok (binderXObj binder) interface
folder ctx' binder = either Left register' ctx'
where register' ok = registerInInterface ok (binderXObj binder) interface

10
src/Lookup.hs
View File

@ -74,10 +74,6 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
importsNormal env =
mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e
binderToEnv _ = Nothing
importsLookup :: Env -> [(Env, Binder)]
importsLookup env =
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env
@ -167,7 +163,7 @@ multiLookupQualified path@(SymPath (p:_) _) rootEnv =
Just parent -> multiLookupQualified path parent
Nothing -> []
fromUsedModules = let usedModules = envUseModules rootEnv
envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path rootEnv)) usedModules
envs = mapMaybe (\path' -> fmap getEnvFromBinder (lookupInEnv path' rootEnv)) usedModules
in concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules
@ -182,8 +178,8 @@ envInsertAt env (SymPath [] name) binder =
envAddBinding env name binder
envInsertAt env (SymPath (p:ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder existingMeta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder existingMeta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
Just (Binder meta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
in env { envBindings = Map.insert p newInnerEnv (envBindings env) }
Just _ -> error ("Can't insert into non-module: " ++ p)
Nothing -> error ("Can't insert into non-existing module: " ++ p)

50
src/Obj.hs
View File

@ -212,20 +212,20 @@ instance Eq TemplateCreator where
_ == _ = True
prettyInfoFromXObj :: XObj -> String
prettyInfoFromXObj xobj = case info xobj of
prettyInfoFromXObj xobj = case xobjInfo xobj of
Just i -> prettyInfo i
Nothing -> "no info"
machineReadableInfoFromXObj :: FilePathPrintLength -> XObj -> String
machineReadableInfoFromXObj fppl xobj =
case info xobj of
case xobjInfo xobj of
Just i -> machineReadableInfo fppl i
Nothing -> ""
-- | Obj with eXtra information.
data XObj = XObj { obj :: Obj
, info :: Maybe Info
, ty :: Maybe Ty
data XObj = XObj { xobjObj :: Obj
, xobjInfo :: Maybe Info
, xobjTy :: Maybe Ty
} deriving (Show, Eq, Ord)
getBinderDescription :: XObj -> String
@ -304,7 +304,7 @@ pretty :: XObj -> String
pretty = visit 0
where visit :: Int -> XObj -> String
visit indent xobj =
case obj xobj of
case xobjObj xobj of
Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")"
Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
StaticArr arr -> "$[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
@ -327,7 +327,7 @@ pretty = visit 0
Nothing -> ""
Def -> "def"
Fn _ captures -> "fn" ++ " <" ++ prettyCaptures captures ++ ">"
Closure elem _ -> "closure<" ++ pretty elem ++ ">"
Closure elt _ -> "closure<" ++ pretty elt ++ ">"
If -> "if"
Match MatchValue -> "match"
Match MatchRef -> "match-ref"
@ -360,14 +360,14 @@ pretty = visit 0
With -> "with"
prettyUpTo :: Int -> XObj -> String
prettyUpTo max xobj =
prettyUpTo lim xobj =
let prettied = pretty xobj
in if length prettied > max
then take max prettied ++ "..." ++ end
in if length prettied > lim
then take lim prettied ++ "..." ++ end
else prettied
where end =
-- we match all of them explicitly to get errors if we forget one
case obj xobj of
case xobjObj xobj of
Lst _ -> ")"
Arr _ -> "]"
Dict _ -> "}"
@ -424,41 +424,41 @@ prettyUpTo max xobj =
prettyCaptures :: Set.Set XObj -> String
prettyCaptures captures =
joinWithComma (map (\x -> getName x ++ " : " ++ fromMaybe "" (fmap show (ty x))) (Set.toList captures))
joinWithComma (map (\x -> getName x ++ " : " ++ fromMaybe "" (fmap show (xobjTy x))) (Set.toList captures))
data EvalError = EvalError String [XObj] FilePathPrintLength (Maybe Info)
| HasStaticCall XObj (Maybe Info)
deriving (Eq)
instance Show EvalError where
show (HasStaticCall xobj info) = "Expression " ++ (pretty xobj) ++ " has unexpected static call"++ getInfo info
where getInfo (Just i) = " at " ++ prettyInfo i ++ "."
getInfo Nothing = ""
show (EvalError msg t fppl i) = msg ++ getInfo i ++ getTrace
where getInfo (Just i) = " at " ++ machineReadableInfo fppl i ++ "."
getInfo Nothing = ""
show (HasStaticCall xobj info) = "Expression " ++ (pretty xobj) ++ " has unexpected static call"++ showInfo info
where showInfo (Just i) = " at " ++ prettyInfo i ++ "."
showInfo Nothing = ""
show (EvalError msg t fppl info) = msg ++ showInfo info ++ getTrace
where showInfo (Just i) = " at " ++ machineReadableInfo fppl i ++ "."
showInfo Nothing = ""
getTrace =
if null t
then ""
else
"\n\nTraceback:\n" ++
unlines (map (\x -> prettyUpTo 60 x ++ getInfo (info x)) t)
unlines (map (\x -> prettyUpTo 60 x ++ showInfo (xobjInfo x)) t)
-- | Get the type of an XObj as a string.
typeStr :: XObj -> String
typeStr xobj = case ty xobj of
typeStr xobj = case xobjTy xobj of
Nothing -> "" --" : _"
Just t -> " : " ++ show t
-- | Get the identifier of an XObj as a string.
identifierStr :: XObj -> String
identifierStr xobj = case info xobj of
identifierStr xobj = case xobjInfo xobj of
Just i -> "#" ++ show (infoIdentifier i)
Nothing -> "#?"
-- | Get the deleters of an XObj as a string.
deletersStr :: XObj -> String
deletersStr xobj = case info xobj of
deletersStr xobj = case xobjInfo xobj of
Just i -> joinWithComma (map show (Set.toList (infoDelete i)))
Nothing -> ""
@ -471,7 +471,7 @@ prettyTyped = visit 0
identifierStr xobj ++ " " ++
deletersStr xobj ++ " " ++
"\n"
in case obj xobj of
in case xobjObj xobj of
Lst lst ->
listPrinter "(" ")" lst suffix indent
Arr arr ->
@ -526,7 +526,7 @@ showBinderIndented indent (name, Binder meta xobj) =
then ""
else replicate indent ' ' ++ name ++
-- " (" ++ show (getPath xobj) ++ ")" ++
" : " ++ showMaybeTy (ty xobj)
" : " ++ showMaybeTy (xobjTy xobj)
-- ++ " <" ++ getBinderDescription xobj ++ ">"
-- | Get a list of pairs from a deftype declaration.
@ -773,7 +773,7 @@ defineInterface name t paths info =
-- | Unsafe way of getting the type from an XObj
forceTy :: XObj -> Ty
forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (ty xobj)
forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (xobjTy xobj)
-- | How should the compiler be run? Interactively or just build / build & run and then quit?
data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check deriving (Show, Eq)

2
src/Parsing.hs
View File

@ -134,7 +134,7 @@ string = do i <- createInfo
countLinebreaks :: String -> Int
countLinebreaks =
foldr (\x sum -> if x == '\n' then sum+1 else sum) 0
foldr (\x acc -> if x == '\n' then acc+1 else acc) 0
parseInternalPattern :: Parsec.Parsec String ParseState String
parseInternalPattern = do maybeAnchor <- Parsec.optionMaybe (Parsec.char '^')

4
src/Polymorphism.hs
View File

@ -15,12 +15,12 @@ import Lookup
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName =
let foundBinders = multiLookupALL functionName env
in case filter ((\(Just t') -> areUnifiable functionType t') . ty . binderXObj . snd) foundBinders of
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
Just (SymPath [] name)
[(_, Binder _ single)] ->
let Just t' = ty single
let Just t' = xobjTy single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix)

178
src/Primitives.hs
View File

@ -46,7 +46,7 @@ argumentErr :: Context -> String -> String -> String -> XObj -> IO (Context, Eit
argumentErr ctx fun ty number actual =
pure (evalError ctx (
"`" ++ fun ++ "` expected " ++ ty ++ " as its " ++ number ++
" argument, but got `" ++ pretty actual ++ "`") (info actual))
" argument, but got `" ++ pretty actual ++ "`") (xobjInfo actual))
makePrim' :: String -> Maybe Int -> String -> String -> Primitive -> (String, Binder)
makePrim' name maybeArity docString example callback =
@ -69,7 +69,7 @@ makePrim' name maybeArity docString example callback =
err x ctx a l =
pure (evalError ctx (
"The primitive `" ++ name ++ "` expected " ++ show a ++
" arguments, but got " ++ show l ++ ".\n\n" ++ exampleUsage) (info x))
" arguments, but got " ++ show l ++ ".\n\n" ++ exampleUsage) (xobjInfo x))
doc = docString ++ "\n\n" ++ exampleUsage
exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
unfoldArgs =
@ -86,8 +86,8 @@ primitiveFile x@(XObj _ i t) ctx args =
[XObj _ mi _] -> go mi
_ -> evalError ctx
("`file` expected 0 or 1 arguments, but got " ++ show (length args))
(info x)
where err = evalError ctx ("No information about object " ++ pretty x) (info x)
(xobjInfo x)
where err = evalError ctx ("No information about object " ++ pretty x) (xobjInfo x)
go = maybe err (\info ->
let fppl = projectFilePathPrintLength (contextProj ctx)
file = infoFile info
@ -103,8 +103,8 @@ primitiveLine x@(XObj _ i t) ctx args =
[XObj _ mi _] -> go mi
_ -> evalError ctx
("`line` expected 0 or 1 arguments, but got " ++ show (length args))
(info x)
where err = evalError ctx ("No information about object " ++ pretty x) (info x)
(xobjInfo x)
where err = evalError ctx ("No information about object " ++ pretty x) (xobjInfo x)
go = maybe err (\info -> (ctx, Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t)))
primitiveColumn :: Primitive
@ -114,15 +114,15 @@ primitiveColumn x@(XObj _ i t) ctx args =
[XObj _ mi _] -> go mi
_ -> evalError ctx
("`column` expected 0 or 1 arguments, but got " ++ show (length args))
(info x)
where err = evalError ctx ("No information about object " ++ pretty x) (info x)
(xobjInfo x)
where err = evalError ctx ("No information about object " ++ pretty x) (xobjInfo x)
go = maybe err (\info -> (ctx, Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t)))
primitiveImplements :: Primitive
primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inner@(XObj (Sym impl@(SymPath prefixes name) _) inf _)] =
primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inner@(XObj (Sym impl@(SymPath prefixes name) _) info _)] =
let global = contextGlobalEnv ctx
def = lookupInEnv impl global
in maybe notFound found def
in maybe notFound' found def
where (SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
checkInterface = let warn = do emitWarning ("The interface " ++ show interface ++ " implemented by " ++ show impl ++
" at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++
@ -135,17 +135,17 @@ primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inne
--
-- This is only allowed for qualified bindings. Allowing forward declarations on global bindings would cause a loop in
-- primitiveMetaSet's lookup which is generic.
notFound = if null modules
then pure $ evalError ctx "Can't set the `implements` meta on a global definition before it is declared." inf
else (checkInterface >>
primitiveMetaSet xobj ctx [inner, XObj (Str "implements") (Just dummyInfo) (Just StringTy), XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy)])
notFound' = if null modules
then pure $ evalError ctx "Can't set the `implements` meta on a global definition before it is declared." info
else (checkInterface >>
primitiveMetaSet xobj ctx [inner, XObj (Str "implements") (Just dummyInfo) (Just StringTy), XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy)])
found (_, Binder meta defobj) = checkInterface >>
either registerError updateImpls (registerInInterface ctx defobj interface)
where registerError e = do case contextExecMode ctx of
Check -> let fppl = projectFilePathPrintLength (contextProj ctx)
in putStrLn (machineReadableInfoFromXObj fppl defobj ++ " " ++ e)
_ -> putStrLnWithColor Red e
pure $ evalError ctx e (info x)
pure $ evalError ctx e (xobjInfo x)
updateImpls ctx' = do currentImplementations <- primitiveMeta xobj ctx [inner, XObj (Str "implements") (Just dummyInfo) (Just StringTy)]
pure $ either metaError existingImpls (snd currentImplementations)
where metaError e = (ctx, Left e)
@ -161,17 +161,17 @@ primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inne
in (ctx' {contextGlobalEnv = envInsertAt global (getPath defobj) (Binder newMeta defobj)}, dynamicNil)
global = contextGlobalEnv ctx
primitiveImplements _ ctx [x, _] =
pure $ evalError ctx ("`implements` expects symbol arguments.") (info x)
pure $ evalError ctx ("`implements` expects symbol arguments.") (xobjInfo x)
primitiveImplements x@(XObj _ _ _) ctx args =
pure $ evalError
ctx ("`implements` expected 2 arguments, but got " ++ show (length args)) (info x)
ctx ("`implements` expected 2 arguments, but got " ++ show (length args)) (xobjInfo x)
define :: Bool -> Context -> XObj -> IO Context
define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
let previousType =
case lookupInEnv (getPath annXObj) globalEnv of
Just (_, Binder _ found) -> ty found
Just (_, Binder _ found) -> xobjTy found
Nothing -> Nothing
previousMeta = existingMeta globalEnv annXObj
adjustedMeta = if hidden
@ -195,7 +195,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
Nothing -> pure ()
case Meta.get "implements" previousMeta of
Just (XObj (Lst interfaces) _ _) ->
do let result = foldM (\ctx (xobj, interface) -> registerInInterface ctx xobj interface) ctx (zip (cycle [annXObj]) (map getPath interfaces))
do let result = foldM (\ctx' (xobj, interface) -> registerInInterface ctx' xobj interface) ctx (zip (cycle [annXObj]) (map getPath interfaces))
case result of
Left err ->
do case contextExecMode ctx of
@ -211,7 +211,7 @@ primitiveRegisterType :: Primitive
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] =
primitiveRegisterTypeWithoutFields ctx t Nothing
primitiveRegisterType _ ctx [x] =
pure (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (info 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] =
@ -240,7 +240,7 @@ primitiveRegisterTypeWithFields :: Context -> XObj -> String -> (Maybe String) -
primitiveRegisterTypeWithFields ctx x t override members =
either handleErr updateContext
(bindingsForRegisteredType typeEnv globalEnv pathStrings t [members] Nothing preExistingModule)
where handleErr e = pure $ makeEvalError ctx (Just e) (show e) (info x)
where handleErr e = pure $ makeEvalError ctx (Just e) (show e) (xobjInfo x)
updateContext (typeModuleName, typeModuleXObj, deps) =
do let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
ctx' = (ctx { contextGlobalEnv = envInsertAt globalEnv (SymPath pathStrings typeModuleName) (Binder emptyMeta typeModuleXObj)
@ -258,7 +258,7 @@ primitiveRegisterTypeWithFields ctx x t override members =
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
notFound ctx x path =
pure (evalError ctx ("I can’t find the symbol `" ++ show path ++ "`") (info x))
pure (evalError ctx ("I can’t find the symbol `" ++ show path ++ "`") (xobjInfo x))
primitiveInfo :: Primitive
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
@ -322,15 +322,14 @@ dynamicOrMacroWith ctx producer ty name body = do
let pathStrings = contextPath ctx
globalEnv = contextGlobalEnv ctx
path = SymPath pathStrings name
elem = XObj (Lst (producer path)) (info body) (Just ty)
meta = existingMeta globalEnv elem
pure (ctx { contextGlobalEnv = envInsertAt globalEnv path (Binder meta elem) }, dynamicNil)
elt = XObj (Lst (producer path)) (xobjInfo body) (Just ty)
meta = existingMeta globalEnv elt
pure (ctx { contextGlobalEnv = envInsertAt globalEnv path (Binder meta elt) }, dynamicNil)
primitiveMembers :: Primitive
primitiveMembers _ ctx [target] = do
let env = contextEnv ctx
typeEnv = contextTypeEnv ctx
case bottomedTarget env target of
let typeEnv = contextTypeEnv ctx
case bottomedTarget of
XObj (Sym path@(SymPath _ name) _) _ _ ->
case lookupInEnv path (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [
@ -353,9 +352,10 @@ primitiveMembers _ ctx [target] = do
getMembersFromCase (XObj x _ _) =
error ("Can't handle case " ++ show x)
_ ->
pure (evalError ctx ("Can't find a struct type named '" ++ name ++ "' in type environment") (info target))
_ -> pure (evalError ctx ("Can't get the members of non-symbol: " ++ pretty target) (info target))
where bottomedTarget env target =
pure (evalError ctx ("Can't find a struct type named '" ++ name ++ "' in type environment") (xobjInfo target))
_ -> pure (evalError ctx ("Can't get the members of non-symbol: " ++ pretty target) (xobjInfo target))
where env = contextEnv ctx
bottomedTarget =
case target of
XObj (Sym targetPath _) _ _ ->
case lookupInEnv targetPath env of
@ -364,7 +364,7 @@ primitiveMembers _ ctx [target] = do
-- module
Just (_, Binder _ (XObj (Mod _) _ _)) -> target
-- if we’re recursing into a non-sym, we’ll stop one level down
Just (_, Binder _ x) -> bottomedTarget env x
Just (_, Binder _ _) -> bottomedTarget
_ -> target
_ -> target
@ -402,7 +402,7 @@ primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj
then let updated = Meta.updateBinderMeta (Meta.stub fullPath) key value
newEnv = envInsertAt global fullPath updated
in (ctx {contextGlobalEnv = newEnv}, dynamicNil)
else evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ pretty target ++ "`") (info target)
else evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ pretty target ++ "`") (xobjInfo target)
primitiveMetaSet _ ctx [XObj (Sym _ _) _ _, key, _] =
argumentErr ctx "meta-set!" "a string" "second" key
primitiveMetaSet _ ctx [target, _, _] =
@ -413,9 +413,9 @@ primitiveDefinterface :: Primitive
primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _), ty] =
pure $ maybe invalidType validType (xobjToTy ty)
where typeEnv = getTypeEnv (contextTypeEnv ctx)
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (info ty)
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
validType t = maybe defInterface (updateInterface . snd) (lookupInEnv path typeEnv)
where defInterface = let interface = defineInterface name t [] (info nameXObj)
where defInterface = let interface = defineInterface name t [] (xobjInfo nameXObj)
typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface))
newCtx = retroactivelyRegisterInInterface (ctx { contextTypeEnv = typeEnv' }) path
in (newCtx, dynamicNil)
@ -425,9 +425,9 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
then (ctx, dynamicNil)
else evalError ctx ("Tried to change the type of interface `" ++
show path ++ "` from `" ++ show foundType ++
"` to `" ++ show t ++ "`") (info xobj)
"` to `" ++ show t ++ "`") (xobjInfo xobj)
primitiveDefinterface _ ctx [name, _] =
pure (evalError ctx ("`definterface` expects a name as first argument, but got `" ++ pretty name ++ "`") (info name))
pure (evalError ctx ("`definterface` expects a name as first argument, but got `" ++ pretty name ++ "`") (xobjInfo name))
registerInternal :: Context -> String -> XObj -> Maybe String -> IO (Context, Either EvalError XObj)
registerInternal ctx name ty override =
@ -436,13 +436,13 @@ registerInternal ctx name ty override =
globalEnv = contextGlobalEnv ctx
invalidType = evalError ctx
("Can't understand type when registering '" ++ name ++
"'") (info ty)
"'") (xobjInfo ty)
-- TODO: Retroactively register in interface if implements metadata is present.
validType t = let path = SymPath pathStrings name
registration = XObj (Lst [XObj (External override) Nothing Nothing
,XObj (Sym path Symbol) Nothing Nothing
,ty
]) (info ty) (Just t)
]) (xobjInfo ty) (Just t)
meta = existingMeta globalEnv registration
env' = envInsertAt globalEnv path (Binder meta registration)
in (ctx { contextGlobalEnv = env' }, dynamicNil)
@ -453,22 +453,22 @@ primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty] =
primitiveRegister _ ctx [name, _] =
pure (evalError ctx
("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
(info name))
(xobjInfo name))
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty, XObj (Str override) _ _] =
registerInternal ctx name ty (Just override)
primitiveRegister _ ctx [XObj (Sym (SymPath _ _) _) _ _, _, override] =
pure (evalError ctx
("`register` expects a string as third argument, but got `" ++ pretty override ++ "`")
(info override))
(xobjInfo override))
primitiveRegister _ ctx [name, _, _] =
pure (evalError ctx
("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
(info name))
(xobjInfo name))
primitiveRegister x ctx _ =
pure (evalError ctx
("I didn’t understand the form `" ++ pretty x ++
"`.\n\nIs it valid? Every `register` needs to follow the form `(register name <signature> <optional: override>)`.")
(info x))
(xobjInfo x))
@ -485,9 +485,9 @@ primitiveDeftype xobj ctx (name:rest) =
("All fields must have a name and a type." ++
"Example:\n" ++
"```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n")
(info xobj)
Just a ->
ensureUnqualified $ map fst a
(xobjInfo xobj)
Just ms ->
ensureUnqualified $ map fst ms
where members :: [XObj] -> Maybe [(XObj, XObj)]
members (binding:val:xs) = do
xs' <- members xs
@ -505,15 +505,15 @@ primitiveDeftype xobj ctx (name:rest) =
Nothing
("Type members must be unqualified symbols, but got `" ++
concatMap pretty rest ++ "`")
(info xobj)
(xobjInfo xobj)
_ -> deftype name
where deftype name@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' name ty []
deftype (XObj (Lst (name@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
deftype' name ty tyvars
deftype name =
where deftype nm@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' nm ty []
deftype (XObj (Lst (nm@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
deftype' nm ty tyvars
deftype nm =
pure (evalError ctx
("Invalid name for type definition: " ++ pretty name)
(info name))
("Invalid name for type definition: " ++ pretty nm)
(xobjInfo nm))
deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj)
deftype' nameXObj typeName typeVariableXObjs = do
let pathStrings = contextPath ctx
@ -521,28 +521,28 @@ primitiveDeftype xobj ctx (name:rest) =
innerEnv = fromMaybe env (contextInternalEnv ctx)
typeEnv = contextTypeEnv ctx
typeVariables = mapM xobjToTy typeVariableXObjs
(preExistingModule, existingMeta) =
(preExistingModule, preExistingMeta) =
case lookupInEnv (SymPath pathStrings typeName) env of
Just (_, Binder existingMeta (XObj (Mod found) _ _)) -> (Just found, existingMeta)
Just (_, Binder existingMeta _) -> (Nothing, existingMeta)
Just (_, Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
Just (_, Binder meta _) -> (Nothing, meta)
_ -> (Nothing, emptyMeta)
(creatorFunction, typeConstructor) =
if length rest == 1 && isArray (head rest)
then (moduleForDeftype, Deftype)
else (moduleForSumtype, DefSumtype)
case (nameXObj, typeVariables) of
(XObj (Sym (SymPath _ typeName) _) i _, Just okTypeVariables) ->
case creatorFunction innerEnv typeEnv env pathStrings typeName okTypeVariables rest i preExistingModule of
(XObj (Sym (SymPath _ tyName) _) i _, Just okTypeVariables) ->
case creatorFunction innerEnv typeEnv env pathStrings tyName okTypeVariables rest i preExistingModule of
Right (typeModuleName, typeModuleXObj, deps) ->
let structTy = StructTy (ConcreteNameTy typeName) okTypeVariables
let structTy = StructTy (ConcreteNameTy tyName) okTypeVariables
typeDefinition =
-- NOTE: The type binding is needed to emit the type definition and all the member functions of the type.
XObj (Lst (XObj (typeConstructor structTy) Nothing Nothing :
XObj (Sym (SymPath pathStrings typeName) Symbol) Nothing Nothing :
XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing :
rest)
) i (Just TypeTy)
ctx' = (ctx { contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) (Binder existingMeta typeModuleXObj)
, contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) typeName typeDefinition)
ctx' = (ctx { contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) (Binder preExistingMeta typeModuleXObj)
, contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) tyName typeDefinition)
})
in do ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
let ctxWithInterfaceRegistrations =
@ -558,7 +558,7 @@ primitiveDeftype xobj ctx (name:rest) =
Left err ->
pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
(_, Nothing) ->
pure (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (info nameXObj))
pure (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (xobjInfo nameXObj))
primitiveUse :: Primitive
primitiveUse xobj ctx [XObj (Sym path _) _ _] =
@ -569,7 +569,7 @@ primitiveUse xobj ctx [XObj (Sym path _) _ _] =
useThese = envUseModules e
e' = if path `elem` useThese then e else e { envUseModules = path : useThese }
lookupInGlobal = maybe missing useModule (lookupInEnv path env)
where missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (info xobj)
where missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj)
useModule _ = (ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' }, dynamicNil)
primitiveUse _ ctx [x] =
argumentErr ctx "use" "a symbol" "first" x
@ -577,24 +577,20 @@ primitiveUse _ ctx [x] =
-- | Get meta data for a Binder
primitiveMeta :: Primitive
primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (Str key) _ _] = do
pure $ maybe notFound foundBinder lookup
pure $ maybe errNotFound foundBinder lookup'
where global = contextGlobalEnv ctx
types = getTypeEnv (contextTypeEnv ctx)
fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
lookup :: Maybe Binder
lookup = ((lookupInEnv fullPath global)
>>= pure . snd)
<|>
((lookupInEnv fullPath types)
>>= pure . snd)
lookup' :: Maybe Binder
lookup' = (lookupInEnv fullPath global <|> lookupInEnv fullPath types) >>= pure . snd
foundBinder :: Binder -> (Context, Either EvalError XObj)
foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
notFound :: (Context, Either EvalError XObj)
notFound = evalError ctx ("`meta` failed, I can’t find `" ++ show fullPath ++ "`") i
errNotFound :: (Context, Either EvalError XObj)
errNotFound = evalError ctx ("`meta` failed, I can’t find `" ++ show fullPath ++ "`") i
primitiveMeta _ ctx [XObj (Sym _ _) _ _, key] =
argumentErr ctx "meta" "a string" "second" key
primitiveMeta _ ctx [path, _] =
@ -615,7 +611,7 @@ primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty, XObj (Str de
typeEnv = contextTypeEnv ctx
globalEnv = contextGlobalEnv ctx
p = SymPath pathStrings name
invalidType = evalError ctx ("I do not understand the type form in " ++ pretty ty) (info ty)
invalidType = evalError ctx ("I do not understand the type form in " ++ pretty ty) (xobjInfo ty)
validType t = case defineTemplate p t "" (toTemplate declTempl) (toTemplate defTempl) (const []) of
(_, b@(Binder _ (XObj (Lst (XObj (Deftemplate template) _ _ : _)) _ _))) ->
if isTypeGeneric t
@ -640,7 +636,7 @@ primitiveDeftemplate _ ctx [x, _, _, _] =
argumentErr ctx "deftemplate" "a symbol" "first" x
noTypeError :: Context -> XObj -> IO (Context, Either EvalError XObj)
noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x) (info x)
noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x)
primitiveType :: Primitive
-- A special case, the type of the type of types (type (type (type 1))) => ()
@ -648,24 +644,24 @@ 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 [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
(maybe otherDefs (go ctx . snd) (lookupInEnv path env))
(maybe otherDefs (go . snd) (lookupInEnv path env))
where env = contextGlobalEnv ctx
otherDefs = case multiLookupALL name env of
[] ->
notFound ctx x path
binders ->
(sequence (map (go ctx . snd) binders))
(sequence (map (go . snd) binders))
>>= pure . Lst . rights . map snd
>>= \obj -> pure (ctx, Right $ (XObj obj Nothing Nothing))
go ctx binder =
case (ty (binderXObj binder))of
go binder =
case (xobjTy (binderXObj binder))of
Nothing -> noTypeError ctx x
Just t -> pure (ctx, Right (reify t))
primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
maybe (notFound ctx x qualifiedPath) (go ctx . snd) (lookupInEnv qualifiedPath env)
maybe (notFound ctx x qualifiedPath) (go . snd) (lookupInEnv qualifiedPath env)
where env = contextGlobalEnv ctx
go ctx binder =
case (ty (binderXObj binder)) of
go binder =
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))
@ -678,27 +674,27 @@ 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 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]
Right xobj -> primitiveType any' (fst result) [xobj]
Left e -> pure (ctx, Left e)
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) (info x))
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 (_,_) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
ok (_,_) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
primitiveKind :: Primitive
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) (info x))
in pure (either fail' ok typed)
where 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) (info x))
ok (_, _) = (evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x))
-- | Primitive for printing help.
primitiveHelp :: Primitive

8
src/Qualify.hs
View File

@ -181,14 +181,14 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
removeThoseShadowedByRecursiveSymbol :: [(Env, Binder)] -> [(Env, Binder)]
removeThoseShadowedByRecursiveSymbol allBinders = visit allBinders allBinders
where visit bs result =
where visit bs res =
foldl
(\result b ->
case b of
(Env { envMode = RecursionEnv }, Binder _ xobj) ->
remove (\(_, Binder _ x) -> xobj /= x && getName xobj == getName x) result
(Env { envMode = RecursionEnv }, Binder _ xobj') ->
remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result
_ -> result)
result
res
bs

41
src/RenderDocs.hs
View File

@ -4,8 +4,9 @@ module RenderDocs where
import CMark
import Control.Monad (when)
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
import Data.Maybe (fromMaybe)
import Data.Text as Text
@ -51,9 +52,9 @@ projectIndexPage ctx moduleNames =
let logo = projectDocsLogo ctx
url = projectDocsURL ctx
css = projectDocsStyling ctx
htmlHeader = toHtml $ projectTitle ctx
htmlHeader = H.toHtml $ projectTitle ctx
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack $ projectDocsPrelude ctx
html = renderHtml $ docTypeHtml $
html = renderHtml $ H.docTypeHtml $
do headOfPage css
H.body $
H.div ! A.class_ "content" $
@ -63,7 +64,7 @@ projectIndexPage ctx moduleNames =
moduleIndex moduleNames
H.div $
do H.h1 htmlHeader
preEscapedToHtml htmlDoc
H.preEscapedToHtml htmlDoc
in html
headOfPage :: String -> H.Html
@ -77,11 +78,11 @@ getModuleName :: Env -> String
getModuleName env = fromMaybe "Global" (envModuleName env)
saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO ()
saveDocsForEnvBinder ctx moduleNames (pathToEnv, envBinder) =
do let SymPath _ moduleName = pathToEnv
saveDocsForEnvBinder ctx moduleNames (envPath, envBinder) =
do let SymPath _ moduleName = envPath
dir = projectDocsDir ctx
fullPath = dir </> moduleName ++ ".html"
string = renderHtml (envBinderToHtml envBinder ctx (show pathToEnv) moduleNames)
string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames)
createDirectoryIfMissing False dir
writeFile fullPath string
@ -104,10 +105,10 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
do H.a ! A.href (H.stringValue url) $
H.img ! A.src (H.stringValue logo)
--span_ "CARP DOCS FOR"
H.div ! A.class_ "title" $ toHtml title
H.div ! A.class_ "title" $ H.toHtml title
moduleIndex moduleNames
H.h1 (toHtml moduleName)
H.div ! A.class_ "module-description" $ preEscapedToHtml moduleDescriptionHtml
H.h1 (H.toHtml moduleName)
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
shouldEmitDocsForBinder :: (String, Binder) -> Bool
@ -121,7 +122,7 @@ moduleIndex moduleNames =
moduleLink :: String -> H.Html
moduleLink name =
H.li $ H.a ! A.href (stringValue (name ++ ".html")) $ toHtml name
H.li $ H.a ! A.href (H.stringValue (name ++ ".html")) $ H.toHtml name
binderToHtml :: Binder -> H.Html
@ -129,7 +130,7 @@ binderToHtml (Binder meta xobj) =
let name = getSimpleName xobj
maybeNameAndArgs = getSimpleNameWithArgs xobj
description = getBinderDescription xobj
typeSignature = case ty xobj of
typeSignature = case xobjTy xobj of
Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables!
Nothing -> ""
docString = case Meta.get "doc" meta of
@ -138,12 +139,12 @@ binderToHtml (Binder meta xobj) =
Nothing -> ""
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack docString
in H.div ! A.class_ "binder" $
do H.a ! A.class_ "anchor" ! A.href (stringValue ("#" ++ name)) $
H.h3 ! A.id (stringValue name) $ toHtml name
H.div ! A.class_ "description" $ toHtml description
H.p ! A.class_ "sig" $ toHtml typeSignature
do H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name)) $
H.h3 ! A.id (H.stringValue name) $ H.toHtml name
H.div ! A.class_ "description" $ H.toHtml description
H.p ! A.class_ "sig" $ H.toHtml typeSignature
case maybeNameAndArgs of
Just nameAndArgs -> H.pre ! A.class_ "args" $ toHtml nameAndArgs
Nothing -> H.span $ toHtml (""::String)
H.p ! A.class_ "doc" $ preEscapedToHtml htmlDoc
Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs
Nothing -> H.span $ H.toHtml (""::String)
H.p ! A.class_ "doc" $ H.preEscapedToHtml htmlDoc
--p_ (toHtml (description))

10
src/Repl.hs
View File

@ -72,13 +72,13 @@ completeKeywordsAnd context word =
readlineSettings :: String -> Settings (StateT Context IO)
readlineSettings historyFile =
readlineSettings historyPath =
Settings {
complete = completeWordWithPrev Nothing ['(', ')', '[', ']', ' ', '\t', '\n']
(\_ w -> do
ctx <- get
pure (completeKeywordsAnd ctx w)),
historyFile = Just historyFile,
historyFile = Just historyPath,
autoAddHistory = True
}
@ -146,6 +146,6 @@ resetAlreadyLoadedFiles context =
runRepl :: Context -> IO ((), Context)
runRepl context = do
historyFile <- configPath "history"
createDirectoryIfMissing True (takeDirectory historyFile)
runStateT (runInputT (readlineSettings historyFile) (repl "" (projectPrompt (contextProj context)))) context
historyPath <- configPath "history"
createDirectoryIfMissing True (takeDirectory historyPath)
runStateT (runInputT (readlineSettings historyPath) (repl "" (projectPrompt (contextProj context)))) context

2
src/Scoring.hs
View File

@ -108,7 +108,7 @@ scoreBody :: Env -> Set.Set SymPath -> XObj -> Int
scoreBody globalEnv visited root = visit root
where
visit xobj =
case obj xobj of
case xobjObj xobj of
(Lst _) ->
visitList xobj
(Arr _) ->

6
src/Sumtypes.hs
View File

@ -111,8 +111,8 @@ tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) su
unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase)
caseMemberAssignment :: AllocationMode -> String -> String -> String
caseMemberAssignment allocationMode caseName memberName =
" instance" ++ sep ++ caseName ++ "." ++ memberName ++ " = " ++ memberName ++ ";"
caseMemberAssignment allocationMode caseNm memberName =
" instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";"
where sep = case allocationMode of
StackAlloc -> ".u."
HeapAlloc -> "->u."
@ -173,7 +173,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
tys = filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys correctedCases)
tys = filter (\t' -> (not . isExternalType typeEnv) t' && (not . isFullyGenericType) t') (concatMap caseTys correctedCases)
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) tys
++
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))

2
src/TypeError.hs
View File

@ -392,7 +392,7 @@ recursiveLookupTy mappings t = case t of
showTypeFromXObj :: TypeMappings -> XObj -> String
showTypeFromXObj mappings xobj =
case ty xobj of
case xobjTy xobj of
Just t -> show (recursiveLookupTy mappings t)
Nothing -> "Type missing"

4
src/Types.hs
View File

@ -169,13 +169,13 @@ type TypeMappings = Map.Map String Ty
-- | From two types, one with type variables and one without (e.g. (Fn ["t0"] "t1") and (Fn [Int] Bool))
-- create mappings that translate from the type variables to concrete types, e.g. "t0" => Int, "t1" => Bool
unifySignatures :: Ty -> Ty -> TypeMappings
unifySignatures v t = Map.fromList (unify v t)
unifySignatures at ct = Map.fromList (unify at ct)
where unify :: Ty -> Ty -> [(String, Ty)]
unify (VarTy _) (VarTy _) = [] -- if a == b then [] else error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (VarTy a) value = [(a, value)]
unify (StructTy v@(VarTy _) aArgs) (StructTy n bArgs) = unify v n ++ concat (zipWith unify aArgs bArgs)
unify (StructTy v'@(VarTy _) aArgs) (StructTy n bArgs) = unify v' n ++ concat (zipWith unify aArgs bArgs)
unify (StructTy a@(ConcreteNameTy _) aArgs) (StructTy b bArgs)
| a == b = concat (zipWith unify aArgs bArgs)
| otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b)

30
src/Validate.hs
View File

@ -29,7 +29,7 @@ validateMembers typeEnv typeVariables membersXObjs =
else Left (UnevenMembers membersXObjs)
pairs = pairwise membersXObjs
fields = fst <$> pairs
uniqueFields = nubBy ((==) `on` obj) fields
uniqueFields = nubBy ((==) `on` xobjObj) fields
dups = fields \\ uniqueFields
checkDuplicateMembers =
if length fields == length uniqueFields
@ -49,8 +49,8 @@ okXObjForType typeEnv typeVariables xobj =
-- | Can this type be used as a member for a deftype?
canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeEnv typeVariables t xobj =
case t of
canBeUsedAsMemberType typeEnv typeVariables ty xobj =
case ty of
UnitTy -> pure ()
IntTy -> pure ()
FloatTy -> pure ()
@ -75,7 +75,7 @@ canBeUsedAsMemberType typeEnv typeVariables t xobj =
do _ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of
Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes t xobj)
Nothing -> Left (NotAmongRegisteredTypes ty xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)]))
(VarTy _) -> pure ()
s@(StructTy name tyvar) ->
@ -84,26 +84,26 @@ canBeUsedAsMemberType typeEnv typeVariables t xobj =
else case name of
(ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t') _ _ : _))_ _))) ->
checkInhabitants t'
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t') _ _ : _))_ _))) ->
checkInhabitants t'
_ -> Left (InvalidMemberType t xobj)
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _))_ _))) ->
checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _))_ _))) ->
checkInhabitants t
_ -> Left (InvalidMemberType ty xobj)
-- Make sure any struct types have arguments before they can be used as members.
where checkInhabitants ty =
case ty of
where checkInhabitants t =
case t of
(StructTy _ vars) ->
if length vars == length tyvar
then pure ()
else Left (UninhabitedConstructor ty xobj (length tyvar) (length vars))
_ -> Left (InvalidMemberType ty xobj)
_ -> Left (InvalidMemberType t xobj)
VarTy _ -> if foldr (||) False (map (isCaptured t) typeVariables)
_ -> Left (InvalidMemberType ty xobj)
VarTy _ -> if foldr (||) False (map (isCaptured ty) typeVariables)
then pure ()
else Left (InvalidMemberType t xobj)
else Left (InvalidMemberType ty xobj)
where
-- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)`
-- `a` may be used as a member, sans `f`.
isCaptured t v@(VarTy _) = t == v
isCaptured t (StructTy (VarTy _) vars) = any (== t) vars
_ -> Left (InvalidMemberType t xobj)
_ -> Left (InvalidMemberType ty xobj)