carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

chore: Fix hlint warnings (#1086)

Browse Source
This commit is contained in:
jacereda 2020-12-22 17:44:44 +01:00 committed by GitHub
parent e396863719
commit 32d7396174
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
27 changed files with 343 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
src/ArrayTemplates.hs
View File

@ -20,7 +20,7 @@ templateEMap =
documentation
where
templateType =
(FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy)
FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy
endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
documentation =
@ -30,7 +30,7 @@ templateEMap =
Template
templateType
(templateLiteral "Array $NAME(Lambda *f, Array a)")
( \(FuncTy [_, (StructTy (ConcreteNameTy "Array") [memberTy])] _ _) ->
( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) ->
handleUnits memberTy
)
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
@ -107,10 +107,10 @@ templatePushBack :: (String, Binder)
templatePushBack =
defineTypeParameterizedTemplate creator path t docs
where
path = (SymPath ["Array"] "push-back")
path = SymPath ["Array"] "push-back"
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
valTy = VarTy "a"
t = (FuncTy [aTy, valTy] aTy StaticLifetimeTy)
t = FuncTy [aTy, valTy] aTy StaticLifetimeTy
docs = "adds an element `value` to the end of an array `a`."
declaration :: String -> [Token]
declaration setter =
@ -145,10 +145,10 @@ templatePushBackBang :: (String, Binder)
templatePushBackBang =
defineTypeParameterizedTemplate creator path t docs
where
path = (SymPath ["Array"] "push-back!")
path = SymPath ["Array"] "push-back!"
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
valTy = VarTy "a"
t = (FuncTy [aTy, valTy] UnitTy StaticLifetimeTy)
t = FuncTy [aTy, valTy] UnitTy StaticLifetimeTy
docs = "adds an element `value` to the end of an array `a` in-place."
declaration :: String -> [Token]
declaration setter =
@ -190,7 +190,7 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
Template
t
(const (toTemplate "Array $NAME(Array a)"))
( \(FuncTy [(StructTy _ [insideTy])] _ _) ->
( \(FuncTy [StructTy _ [insideTy]] _ _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in toTemplate
( unlines
@ -213,9 +213,9 @@ templatePopBackBang :: (String, Binder)
templatePopBackBang =
defineTypeParameterizedTemplate creator path t docs
where
path = (SymPath ["Array"] "pop-back!")
path = SymPath ["Array"] "pop-back!"
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
t = (FuncTy [aTy] (VarTy "a") StaticLifetimeTy)
t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy
docs = "removes an element `value` from the end of an array `a` in-place and returns it."
creator =
TemplateCreator $
@ -352,16 +352,15 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
UnitTy -> unitSetterTemplate
_ ->
let deleter = insideArrayDeletion typeEnv env insideTy
in ( multilineTemplate
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
deleter "n",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
in multilineTemplate
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
deleter "n",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
( \(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
@ -388,15 +387,14 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator
case valueType of
UnitTy -> unitSetterTemplate
_ ->
( multilineTemplate
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
multilineTemplate
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
(const [])
@ -462,7 +460,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
++ deleteTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(FuncTy [(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType
)
@ -619,15 +617,15 @@ calculateStrSize :: TypeEnv -> Env -> Ty -> String
calculateStrSize typeEnv env t =
case t of
-- If the member type is Unit, don't access the element.
UnitTy -> makeTemplate (\functionName -> (functionName ++ "();"))
_ -> makeTemplate (\functionName -> (functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);"))
UnitTy -> makeTemplate (++ "();")
_ -> makeTemplate (++ "(" ++ strTakesRefOrNot typeEnv env t ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
where
makeTemplate :: (String -> String) -> String
makeTemplate strcall =
unlines
[ " int size = 3; // opening and closing brackets and terminator",
" for(int i = 0; i < a->len; i++) {",
(arrayMemberSizeCalc strcall) ++ " }",
arrayMemberSizeCalc strcall ++ " }",
""
]
-- Get the size of the member type's string representation
@ -649,8 +647,8 @@ calculateStrSize typeEnv env t =
insideArrayStr :: TypeEnv -> Env -> Ty -> String
insideArrayStr typeEnv env t =
case t of
UnitTy -> makeTemplate (\functionName -> functionName ++ "();")
_ -> makeTemplate (\functionName -> functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
UnitTy -> makeTemplate (++ "();")
_ -> makeTemplate (++ "(" ++ strTakesRefOrNot typeEnv env t ++ "((" ++ tyToC t ++ "*)a->data)[i]);")
where
makeTemplate :: (String -> String) -> String
makeTemplate strcall =

4
src/ColorText.hs
View File

@ -39,10 +39,10 @@ emitErrorWithLabel :: String -> String -> IO ()
emitErrorWithLabel label str = putStrLnWithColor Red (labelStr label str)
emitError :: String -> IO ()
emitError str = emitErrorWithLabel "ERROR" str
emitError = emitErrorWithLabel "ERROR"
emitErrorBare :: String -> IO ()
emitErrorBare str = putStrLnWithColor Red str
emitErrorBare = putStrLnWithColor Red
emitErrorAndExit :: String -> IO a
emitErrorAndExit str = do

114
src/Commands.hs
View File

@ -5,6 +5,7 @@ import Control.Exception
import Control.Monad (join, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits (finiteBitSize)
import Data.Functor ((<&>))
import Data.Hashable (hash)
import Data.List (elemIndex)
import Data.List.Split (splitOn)
@ -232,7 +233,7 @@ commandProjectGetConfig ctx xobj@(XObj (Str key) _ _) =
_ -> Left key
in pure $ case getVal ctx of
Right val -> (ctx, Right $ xstr val)
Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj))
Left k -> evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj)
commandProjectGetConfig ctx faultyKey =
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
@ -337,7 +338,8 @@ commandBuild shutUp ctx = do
in liftIO $ do
when echoCompilationCommand (putStrLn cmd)
callCommand cmd
when (execMode == Repl && not shutUp) $
when
(execMode == Repl && not shutUp)
(putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)")))
pure (setProjectCanExecute hasMain ctx, dynamicNil)
liftIO $ createDirectoryIfMissing False outDir
@ -377,12 +379,12 @@ commandProject ctx = do
-- | Command for getting the name of the operating system you're on.
commandHostOS :: NullaryCommandCallback
commandHostOS ctx =
pure (ctx, (Right (XObj (Str os) (Just dummyInfo) (Just StringTy))))
pure (ctx, Right (XObj (Str os) (Just dummyInfo) (Just StringTy)))
-- | Command for getting the native architecture.
commandHostArch :: NullaryCommandCallback
commandHostArch ctx =
pure (ctx, (Right (XObj (Str arch) (Just dummyInfo) (Just StringTy))))
pure (ctx, Right (XObj (Str arch) (Just dummyInfo) (Just StringTy)))
-- | Command for adding a header file include to the project.
commandAddInclude :: (String -> Includer) -> UnaryCommandCallback
@ -446,9 +448,9 @@ commandLength :: UnaryCommandCallback
commandLength ctx x =
pure $ case x of
XObj (Lst lst) _ _ ->
(ctx, (Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing)))
(ctx, Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing))
XObj (Arr arr) _ _ ->
(ctx, (Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing)))
(ctx, Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing))
_ -> evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (xobjInfo x)
commandCar :: UnaryCommandCallback
@ -532,22 +534,22 @@ commandEq ctx a b =
cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb
cmp (XObj (Sym sa _) _ _, XObj (Sym sb _) _ _) = Right $ sa == sb
cmp (XObj (Bol xa) _ _, XObj (Bol xb) _ _) = Right $ xa == xb
cmp (XObj Def _ _, XObj Def _ _) = Right $ True
cmp (XObj Do _ _, XObj Do _ _) = Right $ True
cmp (XObj Let _ _, XObj Let _ _) = Right $ True
cmp (XObj While _ _, XObj While _ _) = Right $ True
cmp (XObj Break _ _, XObj Break _ _) = Right $ True
cmp (XObj If _ _, XObj If _ _) = Right $ True
cmp (XObj With _ _, XObj With _ _) = Right $ True
cmp (XObj MetaStub _ _, XObj MetaStub _ _) = Right $ True
cmp (XObj Address _ _, XObj Address _ _) = Right $ True
cmp (XObj SetBang _ _, XObj SetBang _ _) = Right $ True
cmp (XObj Macro _ _, XObj Macro _ _) = Right $ True
cmp (XObj Dynamic _ _, XObj Dynamic _ _) = Right $ True
cmp (XObj DefDynamic _ _, XObj DefDynamic _ _) = Right $ True
cmp (XObj The _ _, XObj The _ _) = Right $ True
cmp (XObj Ref _ _, XObj Ref _ _) = Right $ True
cmp (XObj Deref _ _, XObj Deref _ _) = Right $ True
cmp (XObj Def _ _, XObj Def _ _) = Right True
cmp (XObj Do _ _, XObj Do _ _) = Right True
cmp (XObj Let _ _, XObj Let _ _) = Right True
cmp (XObj While _ _, XObj While _ _) = Right True
cmp (XObj Break _ _, XObj Break _ _) = Right True
cmp (XObj If _ _, XObj If _ _) = Right True
cmp (XObj With _ _, XObj With _ _) = Right True
cmp (XObj MetaStub _ _, XObj MetaStub _ _) = Right True
cmp (XObj Address _ _, XObj Address _ _) = Right True
cmp (XObj SetBang _ _, XObj SetBang _ _) = Right True
cmp (XObj Macro _ _, XObj Macro _ _) = Right True
cmp (XObj Dynamic _ _, XObj Dynamic _ _) = Right True
cmp (XObj DefDynamic _ _, XObj DefDynamic _ _) = Right True
cmp (XObj The _ _, XObj The _ _) = Right True
cmp (XObj Ref _ _, XObj Ref _ _) = Right True
cmp (XObj Deref _ _, XObj Deref _ _) = Right True
cmp (XObj (Lst []) _ _, XObj (Lst []) _ _) = Right True
cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) =
if length elemsA == length elemsB
@ -564,7 +566,7 @@ commandEq ctx a b =
cmp' elt (Right True) = cmp elt
commandComp :: (Number -> Number -> Bool) -> String -> BinaryCommandCallback
commandComp op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) | aTy == bTy = pure $ (ctx, Right (boolToXObj (op aNum bNum)))
commandComp op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) | aTy == bTy = pure (ctx, Right (boolToXObj (op aNum bNum)))
commandComp _ opname ctx a b = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (xobjInfo a)
commandLt :: BinaryCommandCallback
@ -616,7 +618,7 @@ commandStringConcat ctx a =
commandStringSplitOn :: BinaryCommandCallback
commandStringSplitOn ctx (XObj (Str sep) _ _) (XObj (Str s) _ _) =
pure $ (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing))
pure (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing))
where
xstr o = XObj (Str o) (Just dummyInfo) (Just StringTy)
commandStringSplitOn ctx sep s =
@ -633,7 +635,7 @@ commandSymConcat ctx a =
commandSymPrefix :: BinaryCommandCallback
commandSymPrefix ctx (XObj (Sym (SymPath [] prefix) _) _ _) (XObj (Sym (SymPath [] suffix) _) i t) =
pure $ (ctx, Right (XObj (Sym (SymPath [prefix] suffix) (LookupGlobal CarpLand AVariable)) i t))
pure (ctx, Right (XObj (Sym (SymPath [prefix] suffix) (LookupGlobal CarpLand AVariable)) i t))
commandSymPrefix ctx x (XObj (Sym (SymPath [] _) _) _ _) =
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (xobjInfo x)
commandSymPrefix ctx _ x =
@ -670,13 +672,13 @@ commandPathAbsolute ctx a =
case a of
XObj (Str s) _ _ -> do
abs <- makeAbsolute s
pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
pure (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
commandArith :: (Number -> Number -> Number) -> String -> BinaryCommandCallback
commandArith op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _)
| aTy == bTy =
pure $ (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
pure (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
commandArith _ opname ctx a b = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandPlus :: BinaryCommandCallback
@ -718,7 +720,7 @@ commandReadFile ctx filename =
exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String)))
pure $ case exceptional of
Right contents -> (ctx, Right (XObj (Str contents) (Just dummyInfo) (Just StringTy)))
Left _ -> (evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename))
Left _ -> evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename)
_ -> pure (evalError ctx ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (xobjInfo filename))
commandWriteFile :: BinaryCommandCallback
@ -769,7 +771,7 @@ saveDocs ctx pathsAndEnvBinders = do
pure (ctx, dynamicNil)
commandSexpression :: VariadicCommandCallback
commandSexpression ctx [xobj, (XObj (Bol b) _ _)] =
commandSexpression ctx [xobj, XObj (Bol b) _ _] =
commandSexpressionInternal ctx xobj b
commandSexpression ctx [xobj] =
commandSexpressionInternal ctx xobj False
@ -781,7 +783,7 @@ commandSexpressionInternal ctx xobj bol =
let tyEnv = getTypeEnv $ contextTypeEnv ctx
in case xobj of
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
(XObj (Lst forms) i t) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
mdl@(XObj (Mod e) _ _) ->
@ -796,21 +798,20 @@ commandSexpressionInternal ctx xobj bol =
getMod
where
getMod =
case (toSymbols mdl) of
case toSymbols mdl of
x@(XObj (Lst _) _ _) ->
bindingSyms e (ctx, Right x)
_ -> error "getmod"
where
bindingSyms env start =
( mapM (\x -> commandSexpression ctx [x]) $
map snd $
Map.toList $
Map.map binderXObj (envBindings env)
)
>>= pure . foldl combine start
combine (c, (Right (XObj (Lst xs) i t))) (_, (Right y@(XObj (Lst _) _ _))) =
mapM
(commandSexpression ctx . pure . snd)
( Map.toList $ Map.map binderXObj (envBindings env)
)
<&> foldl combine start
combine (c, Right (XObj (Lst xs) i t)) (_, Right y@(XObj (Lst _) _ _)) =
(c, Right (XObj (Lst (xs ++ [y])) i t))
combine _ (c, (Left err)) =
combine _ (c, Left err) =
(c, Left err)
combine (c, Left err) _ =
(c, Left err)
@ -820,24 +821,23 @@ commandSexpressionInternal ctx xobj bol =
toSymbols :: XObj -> XObj
toSymbols (XObj (Mod e) i t) =
( XObj
( Lst
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t
]
)
i
t
)
toSymbols (XObj (Defn _) i t) = (XObj (Sym (SymPath [] "defn") Symbol) i t)
toSymbols (XObj Def i t) = (XObj (Sym (SymPath [] "def") Symbol) i t)
toSymbols (XObj (Deftype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
toSymbols (XObj (DefSumtype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
toSymbols (XObj (Interface _ _) i t) = (XObj (Sym (SymPath [] "definterface") Symbol) i t)
toSymbols (XObj Macro i t) = (XObj (Sym (SymPath [] "defmacro") Symbol) i t)
toSymbols (XObj (Command _) i t) = (XObj (Sym (SymPath [] "command") Symbol) i t)
toSymbols (XObj (Primitive _) i t) = (XObj (Sym (SymPath [] "primitive") Symbol) i t)
toSymbols (XObj (External _) i t) = (XObj (Sym (SymPath [] "external") Symbol) i t)
XObj
( Lst
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t
]
)
i
t
toSymbols (XObj (Defn _) i t) = XObj (Sym (SymPath [] "defn") Symbol) i t
toSymbols (XObj Def i t) = XObj (Sym (SymPath [] "def") Symbol) i t
toSymbols (XObj (Deftype _) i t) = XObj (Sym (SymPath [] "deftype") Symbol) i t
toSymbols (XObj (DefSumtype _) i t) = XObj (Sym (SymPath [] "deftype") Symbol) i t
toSymbols (XObj (Interface _ _) i t) = XObj (Sym (SymPath [] "definterface") Symbol) i t
toSymbols (XObj Macro i t) = XObj (Sym (SymPath [] "defmacro") Symbol) i t
toSymbols (XObj (Command _) i t) = XObj (Sym (SymPath [] "command") Symbol) i t
toSymbols (XObj (Primitive _) i t) = XObj (Sym (SymPath [] "primitive") Symbol) i t
toSymbols (XObj (External _) i t) = XObj (Sym (SymPath [] "external") Symbol) i t
toSymbols x = x
commandHash :: UnaryCommandCallback

46
src/Concretize.hs
View File

@ -99,7 +99,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure $ do
okBody <- visitedBody
pure [defn, nameSymbol, args, okBody]
visitList _ Inside _ xobj@(XObj (Lst [(XObj (Defn _) _ _), _, (XObj (Arr _) _ _), _]) _ _) =
visitList _ Inside _ xobj@(XObj (Lst [XObj (Defn _) _ _, _, XObj (Arr _) _ _, _]) _ _) =
pure (Left (DefinitionsMustBeAtToplevel xobj))
visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) =
-- The basic idea of this function is to first visit the body of the lambda ("in place"),
@ -205,7 +205,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure $ do
okBody <- visitedBody
pure [def, nameSymbol, okBody]
visitList _ Inside _ xobj@(XObj (Lst [(XObj Def _ _), _, _]) _ _) =
visitList _ Inside _ xobj@(XObj (Lst [XObj Def _ _, _, _]) _ _) =
pure (Left (DefinitionsMustBeAtToplevel xobj))
visitList allowAmbig level env (XObj (Lst [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body]) _ _) =
do
@ -390,12 +390,12 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
let (bound, bindingsCaptured) =
foldl
( \(bound', captured) (XObj sym _ ty, expr) ->
let capt = filter (\x -> Set.notMember x bound') (visit expr)
let capt = filter (`Set.notMember` bound') (visit expr)
in (Set.insert (XObj sym (Just dummyInfo) ty) bound', capt ++ captured)
)
(Set.empty, [])
(pairwise bindings)
in let bodyCaptured = filter (\x -> Set.notMember x bound) (visit body)
in let bodyCaptured = filter (`Set.notMember` bound) (visit body)
in bindingsCaptured ++ bodyCaptured
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
@ -567,9 +567,7 @@ replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj
replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath _ name) _) _ _) =
let Just perhapsTyVar = xobjToTy xobj
in if isFullyGenericType perhapsTyVar
then case Map.lookup name mappings of
Just found -> reify found
Nothing -> xobj -- error ("Failed to concretize member '" ++ name ++ "' at " ++ prettyInfoFromXObj xobj ++ ", mappings: " ++ show mappings)
then maybe xobj reify (Map.lookup name mappings)
else xobj
replaceGenericTypeSymbols mappings (XObj (Lst lst) i t) =
XObj (Lst (map (replaceGenericTypeSymbols mappings) lst)) i t
@ -860,7 +858,7 @@ manageMemory typeEnv globalEnv root =
pure (Right xobj)
case r of
Right ok -> do
MemState _ _ _ <- get
MemState {} <- get
r' <- checkThatRefTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
addToLifetimesMappingsIfRef True ok -- (***)
pure r'
@ -897,7 +895,7 @@ manageMemory typeEnv globalEnv root =
MemState deleters deps lifetimes <- get
let newDeleters = Set.insert deleter deleters
newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
newState = (MemState newDeleters newDeps lifetimes)
newState = MemState newDeleters newDeps lifetimes
put newState --(trace (show newState) newState)
pure (Right xobj)
visitStaticArray _ = error "Must visit static array."
@ -905,7 +903,7 @@ manageMemory typeEnv globalEnv root =
visitList xobj@(XObj (Lst lst) i t) =
case lst of
[defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
let captures = fromMaybe [] (fmap Set.toList maybeCaptures)
let captures = maybe [] Set.toList maybeCaptures
in --case defnReturnType of
-- RefTy _ _ ->
-- pure (Left (FunctionsCantReturnRefTy xobj funcTy))
@ -915,13 +913,15 @@ manageMemory typeEnv globalEnv root =
-- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters
-- TODO: Use another kind of Deleter for this case since it's pretty special?
mapM_
( \cap ->
modify
( \memState ->
memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)}
)
( ( \cap ->
modify
( \memState ->
memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)}
)
)
. getName
)
(map getName captures)
captures
mapM_ (addToLifetimesMappingsIfRef False) argList
mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas
visitedBody <- visit body
@ -987,12 +987,12 @@ manageMemory typeEnv globalEnv root =
Right (okCorrectVariable, okMode) ->
do
MemState preDeleters _ _ <- get
ownsTheVarBefore <- pure $ case createDeleter okCorrectVariable of
Nothing -> Right ()
Just d ->
if Set.member d preDeleters || isLookupGlobal okMode
then (Right ())
else (Left (UsingUnownedValue variable))
let ownsTheVarBefore = case createDeleter okCorrectVariable of
Nothing -> Right ()
Just d ->
if Set.member d preDeleters || isLookupGlobal okMode
then Right ()
else Left (UsingUnownedValue variable)
visitedValue <- visit value
_ <- unmanage value -- The assigned value can't be used anymore
MemState managed _ _ <- get
@ -1245,7 +1245,7 @@ manageMemory typeEnv globalEnv root =
[] -> pure (Right xobj)
visitList _ = error "Must visit list."
visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj]))
visitMatchCase (lhs@(XObj _ _ _), rhs@XObj {}) =
visitMatchCase (lhs@XObj {}, rhs@XObj {}) =
do
MemState preDeleters _ _ <- get
_ <- visitCaseLhs lhs

24
src/Deftype.hs
View File

@ -122,7 +122,7 @@ templateGetter _ UnitTy =
(FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($(Ref p) p)"))
-- Execution of the action passed as an argument is handled in Emit.hs.
(const $ toTemplate ("$DECL { return; }\n"))
(const $ toTemplate "$DECL { return; }\n")
(const [])
templateGetter member memberTy =
Template
@ -187,8 +187,8 @@ templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typ
t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of
UnitTy -> (toTemplate "$p $NAME($p p)")
_ -> (toTemplate "$p $NAME($p p, $t newValue)")
UnitTy -> toTemplate "$p $NAME($p p)"
_ -> toTemplate "$p $NAME($p p, $t newValue)"
)
( \(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
@ -242,7 +242,7 @@ templateMutatingSetter typeEnv env memberName memberTy =
-- | The template for mutating setters of a generic deftype.
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), membTy] UnitTy StaticLifetimeTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs
where
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
@ -253,13 +253,13 @@ templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNa
t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of
UnitTy -> (toTemplate "void $NAME($p* pRef)")
_ -> (toTemplate "void $NAME($p* pRef, $t newValue)")
UnitTy -> toTemplate "void $NAME($p* pRef)"
_ -> toTemplate "void $NAME($p* pRef, $t newValue)"
)
( \(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in case memberTy of
UnitTy -> (toTemplate "$DECL { return; }\n")
UnitTy -> toTemplate "$DECL { return; }\n"
_ ->
toTemplate
( unlines
@ -327,7 +327,7 @@ binderForInit _ _ _ = error "binderforinit"
-- | Generate a list of types from a deftype declaration.
initArgListTypes :: [XObj] -> [Ty]
initArgListTypes xobjs =
(map (fromJust . xobjToTy . snd) (pairwise xobjs))
map (fromJust . xobjToTy . snd) (pairwise xobjs)
-- | The template for the 'init' and 'new' functions for a concrete deftype.
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
@ -343,7 +343,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers)
in tokensForInit allocationMode typeName correctedMembers
)
(\FuncTy {} -> [])
where
@ -371,7 +371,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers)
in tokensForInit allocationMode typeName correctedMembers
)
( \(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
@ -399,7 +399,7 @@ tokensForInit allocationMode typeName membersXObjs =
]
where
assignments [] = " instance.__dummy = 0;"
assignments _ = go $ unitless
assignments _ = go unitless
where
go [] = ""
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
@ -480,7 +480,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m
in concatMap
(depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env)
(remove isFullyGenericType (map snd memberPairs))
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)]
)
genericStr _ _ _ _ = error "genericstr"

28
src/Emit.hs
View File

@ -12,6 +12,7 @@ where
import Control.Monad.State
import Data.Char (ord)
import Data.Functor ((<&>))
import Data.List (intercalate, sortOn)
import Data.Maybe (fromJust, fromMaybe)
import Env
@ -314,7 +315,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
do
ret <- visit indent' expr
let Just bindingTy = xobjTy expr
when ((not . isUnit) bindingTy) $
unless (isUnit bindingTy) $
appendToSrc (addIndent indent' ++ tyToCLambdaFix bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
letBindingToC _ _ = error "Invalid binding."
mapM_ (uncurry letBindingToC) (pairwise bindings)
@ -360,8 +361,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- A better idea is to not specialise the names, which happens when calling 'concretize' on the lhs
-- This requires a bunch of extra machinery though, so this will do for now...
[var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)]
++ concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) unitless ([0 ..] :: [Int]))
(var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)) :
concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) unitless ([0 ..] :: [Int]))
where
unitless = remove (isUnit . forceTy) caseMatchers
tagCondition _ _ _ _ =
@ -679,7 +680,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
let argTypes = map forceTy args
unitless = remove isUnit argTypes
-- Run side effects
sideEffects = mapM (visit indent) (filter (isUnit . forceTy) args) >>= pure . intercalate ";\n"
sideEffects = mapM (visit indent) (filter (isUnit . forceTy) args) <&> intercalate ";\n"
unwrapped =
joinWithComma $
if unwrapLambdas
@ -722,13 +723,12 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
( case innerTy of
UnitTy -> "/* () */"
_ ->
( addIndent indent ++ "((" ++ tyToCLambdaFix innerTy ++ "*)" ++ arrayVar
++ ".data)["
++ show index
++ "] = "
++ visited
++ ";\n"
)
addIndent indent ++ "((" ++ tyToCLambdaFix innerTy ++ "*)" ++ arrayVar
++ ".data)["
++ show index
++ "] = "
++ visited
++ ";\n"
)
pure ()
visitStaticArray :: Int -> XObj -> State EmitterState String
@ -850,16 +850,16 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
emitSumtypeCase ind (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) =
do
appendToSrc (addIndent ind ++ "struct {\n")
let members = zipWith (\anonName tyXObj -> (anonName, tyXObj)) anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys)
let members = zip anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys)
mapM_ (memberToDecl (ind + indentAmount)) members
appendToSrc (addIndent ind ++ "} " ++ caseName ++ ";\n")
emitSumtypeCase ind (XObj (Sym (SymPath [] caseName) _) _ _) =
appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n")
emitSumtypeCase _ _ = error "emitsumtypecase"
emitSumtypeCaseTagDefinition :: (Int, XObj) -> State EmitterState ()
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _)) =
emitSumtypeCaseTagDefinition (tagIndex, XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _) =
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Sym (SymPath [] caseName) _) _ _)) =
emitSumtypeCaseTagDefinition (tagIndex, XObj (Sym (SymPath [] caseName) _) _ _) =
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
emitSumtypeCaseTagDefinition _ = error "emitsumtypecasetagdefinition"
in if isTypeGeneric sumTy

50
src/Eval.hs
View File

@ -85,13 +85,12 @@ eval ctx xobj@(XObj o info ty) preference resolver =
tryAllLookups =
( case preference of
PreferDynamic -> tryDynamicLookup
PreferGlobal -> (tryLookup spath <|> tryDynamicLookup)
PreferGlobal -> tryLookup spath <|> tryDynamicLookup
)
<|> (if null p then tryInternalLookup spath else tryLookup spath)
tryDynamicLookup =
( lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
)
lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
tryInternalLookup path =
( contextInternalEnv ctx
>>= lookupBinder path
@ -209,7 +208,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
)
(xobjInfo defn)
)
[(XObj Def _ _), name, _] ->
[XObj Def _ _, name, _] ->
if isUnqualifiedSym name
then specialCommandDefine ctx xobj
else
@ -287,7 +286,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
(newCtx, res) <- eval ctx' x preference ResolveLocal
case res of
Right okX -> do
let binder = Binder emptyMeta (XObj (Lst [(XObj LetDef Nothing Nothing), XObj (Sym (SymPath [] n) Symbol) Nothing Nothing, okX]) Nothing (xobjTy okX))
let binder = Binder emptyMeta (XObj (Lst [XObj LetDef Nothing Nothing, XObj (Sym (SymPath [] n) Symbol) Nothing Nothing, okX]) Nothing (xobjTy okX))
Just e = contextInternalEnv newCtx
pure $ Right (newCtx {contextInternalEnv = Just (envInsertAt e (SymPath [] n) binder)})
Left err -> pure $ Left err
@ -473,7 +472,7 @@ macroExpand ctx xobj =
(newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t)
pure (newCtx', res)
-- TODO: Determine a way to eval primitives generally and remove this special case.
Right p@(XObj (Lst [(XObj (Primitive prim) _ _), (XObj (Sym (SymPath _ "defmodule") _) _ _), _]) _ _) ->
Right p@(XObj (Lst [XObj (Primitive prim) _ _, XObj (Sym (SymPath _ "defmodule") _) _ _, _]) _ _) ->
getPrimitive prim p next args
_ -> do
(newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args
@ -594,9 +593,9 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj =
error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).")
-- The s-expression command is a special case that prefers global/static bindings over dynamic bindings
-- when given a naked binding (no path) as an argument; (s-expr inc)
(newCtx, result) <- if (xobjIsSexp xobj) then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
(newCtx, result) <- if xobjIsSexp xobj then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
case result of
Left e@(EvalError _ _ _ _) -> do
Left e@EvalError {} -> do
reportExecutionError newCtx (show e)
pure (xobj, newCtx)
-- special case: calling something static at the repl
@ -776,16 +775,16 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
>>= \(newCtx, result) ->
case result of
Left err -> pure (newCtx, Left err)
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = (join (fmap envParent (contextInternalEnv newCtx)))}), dynamicNil)
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil)
where
updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) =
let ctx' =
ctx
{ contextInternalEnv = Just innerEnv {envParent = i},
contextPath = ((contextPath ctx) ++ [moduleName])
contextPath = contextPath ctx ++ [moduleName]
}
in (pure (ctx', dynamicNil))
in pure (ctx', dynamicNil)
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
defineNewModule meta
updateExistingModule _ =
@ -800,7 +799,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
-- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
-- In theory this shouldn't be necessary; but for now it is.
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = ((contextPath ctx) ++ [moduleName])}
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]}
defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
defineModuleBindings (context, Left e) = pure (context, Left e)
@ -810,7 +809,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
step :: (Context, Either EvalError XObj) -> XObj -> IO (Context, Either EvalError XObj)
step (ctx', Left e) _ = pure (ctx', Left e)
step (ctx', Right _) expressions =
(macroExpand ctx' expressions)
macroExpand ctx' expressions
>>= \(ctx'', res) -> case res of
Left _ -> pure (ctx'', res)
Right r -> evalDynamic ResolveLocal ctx'' r
@ -882,14 +881,7 @@ loadInternal ctx xobj path i fileToLoad reloadMode = do
Just firstPathFound ->
do
canonicalPath <- liftIO (canonicalizePath firstPathFound)
fileThatLoads <-
liftIO
( canonicalizePath
( case i of
Just ii -> infoFile ii
Nothing -> ""
)
)
fileThatLoads <- liftIO (canonicalizePath $ maybe "" infoFile i)
if canonicalPath == fileThatLoads
then pure $ cantLoadSelf ctx path
else do
@ -900,7 +892,7 @@ loadInternal ctx xobj path i fileToLoad reloadMode = do
contents <- liftIO $ slurp canonicalPath
let files = projectFiles proj
files' =
if canonicalPath `elem` (map fst files)
if canonicalPath `elem` map fst files
then files
else files ++ [(canonicalPath, reloadMode)]
prevStack = projectLoadStack proj
@ -1023,7 +1015,7 @@ loadFilesOnce :: Context -> [FilePath] -> IO Context
loadFilesOnce = loadFilesExt commandLoadOnce
loadFilesExt :: VariadicCommandCallback -> Context -> [FilePath] -> IO Context
loadFilesExt loadCmd ctxStart filesToLoad = foldM load ctxStart filesToLoad
loadFilesExt loadCmd = foldM load
where
load :: Context -> FilePath -> IO Context
load ctx file = do
@ -1053,7 +1045,7 @@ commandReload ctx = do
-- | Command for expanding a form and its macros.
commandExpand :: UnaryCommandCallback
commandExpand ctx xobj = macroExpand ctx xobj
commandExpand = macroExpand
-- | This function will show the resulting C code from an expression.
-- | i.e. (Int.+ 2 3) => "_0 = 2 + 3"
@ -1138,7 +1130,7 @@ primitiveDefdynamic _ ctx [notName, _] =
primitiveDefdynamic _ _ _ = error "primitivedefdynamic"
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
specialCommandSet ctx [XObj (Sym path@(SymPath mod n) _) _ _, val] = do
(newCtx, result) <- evalDynamic ResolveLocal ctx val
case result of
Left err -> pure (newCtx, Left err)
@ -1175,7 +1167,7 @@ specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
specialCommandSet ctx [notName, _] =
pure (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (xobjInfo notName))
specialCommandSet ctx args =
pure (evalError ctx ("`set!` takes a name and a value, but got `" ++ intercalate " " (map pretty args)) (if null args then Nothing else xobjInfo (head args)))
pure (evalError ctx ("`set!` takes a name and a value, but got `" ++ unwords (map pretty args)) (if null args then Nothing else xobjInfo (head args)))
-- | Convenience method for signifying failure in a given context.
failure :: Context -> EvalError -> (Context, Either EvalError a)
@ -1183,14 +1175,14 @@ failure ctx err = (ctx, Left err)
-- | Given a context, value XObj and an existing binder, check whether or not
-- the given value has a type matching the binder's in the given context.
typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, (Either EvalError XObj))
typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, Either EvalError XObj)
typeCheckValueAgainstBinder ctx val binder = do
(ctx', typedValue) <- annotateWithinContext False ctx val
pure $ case typedValue of
Right (val', _) -> go ctx' binderTy val'
Left err -> (ctx', Left err)
where
path = (getPath (binderXObj binder))
path = getPath (binderXObj binder)
binderTy = xobjTy (binderXObj binder)
typeErr x = evalError ctx ("can't `set!` " ++ show path ++ " to a value of type " ++ show (fromJust (xobjTy x)) ++ ", " ++ show path ++ " has type " ++ show (fromJust binderTy)) (xobjInfo x)
go ctx'' (Just DynamicTy) x = (ctx'', Right x)

6
src/Expand.hs
View File

@ -138,7 +138,7 @@ expand eval ctx xobj =
do
okExpandedExpr <- expandedExpr
okExpandedPairs <- expandedPairs
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t)
Right (XObj (Lst (matchExpr : okExpandedExpr : concat okExpandedPairs)) i t)
)
| otherwise ->
pure
@ -165,7 +165,7 @@ expand eval ctx xobj =
okExpression <- expandedExpression
Right (XObj (Lst [withExpr, pathExpr, okExpression]) i t) -- Replace the with-expression with just the expression!
)
[(XObj With _ _), _, _] ->
[XObj With _ _, _, _] ->
pure
( evalError
ctx
@ -322,7 +322,7 @@ setNewIdentifiers root =
-- | Replaces the file, line and column info on an XObj an all its children.
replaceSourceInfo :: FilePath -> Int -> Int -> XObj -> XObj
replaceSourceInfo newFile newLine newColumn root = visit root
replaceSourceInfo newFile newLine newColumn = visit
where
visit :: XObj -> XObj
visit xobj =

5
src/GenerateConstraints.hs
View File

@ -4,7 +4,7 @@ import Constraints
import Control.Arrow hiding (arr)
import Control.Monad.State
import Data.List as List
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Info
import Obj
import qualified Set
@ -35,8 +35,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
captureList :: [XObj]
captureList = Set.toList captures
capturesConstrs =
mapMaybe
id
catMaybes
( zipWith
( \captureTy captureObj ->
case captureTy of

4
src/InitialTypes.hs
View File

@ -203,7 +203,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
okBody <- visitedBody
okArgs <- sequence visitedArgs
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
[(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
[XObj (Defn _) _ _, XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
XObj defn@(Defn _) _ _ : _ ->
pure (Left (InvalidObjExample defn xobj "(defn <name> [<arguments>] <body>)"))
-- Fn
@ -419,7 +419,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
let pairs = pairwise xobjs
emptyInnerEnv =
Env
{ envBindings = Map.fromList [],
{ envBindings = Map.empty,
envParent = Just env,
envModuleName = Nothing,
envUseModules = [],

8
src/Interfaces.hs
View File

@ -13,10 +13,10 @@ where
import ColorText
import Constraints
import Control.Monad (foldM)
import Data.Maybe (mapMaybe)
import Env
import Lookup
import Obj
import Data.Maybe (mapMaybe)
import Types
import Util
@ -64,7 +64,7 @@ registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
_ ->
Left (show $ NonInterface (getBinderPath interface))
where
implPath = (getBinderPath implementation)
implPath = getBinderPath implementation
typeEnv = getTypeEnv (contextTypeEnv ctx)
(SymPath _ name) = getBinderPath interface
@ -72,7 +72,7 @@ registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
-- registered with the interface.
registerInInterface :: Context -> Binder -> Binder -> Either String Context
registerInInterface ctx implementation interface =
case (binderXObj implementation) of
case binderXObj implementation of
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
-- This is a function, does it belong to an interface?
registerInInterfaceIfNeeded ctx implementation interface t
@ -95,7 +95,7 @@ registerInInterface ctx implementation interface =
retroactivelyRegisterInInterface :: Context -> Binder -> Context
retroactivelyRegisterInInterface ctx interface =
-- TODO: Don't use error here?
either (\e -> error e) id resultCtx
either error id resultCtx
where
env = contextGlobalEnv ctx
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env

4
src/Lookup.hs
View File

@ -32,13 +32,13 @@ lookupInEnv path@(SymPath (p : ps) name) env =
-- | Lookup a binder in a context's typeEnv.
lookupBinderInTypeEnv :: Context -> SymPath -> Maybe Binder
lookupBinderInTypeEnv ctx path =
let typeEnv = (getTypeEnv (contextTypeEnv ctx))
let typeEnv = getTypeEnv (contextTypeEnv ctx)
in lookupBinder path typeEnv
-- | Lookup a binder in a context's globalEnv.
lookupBinderInGlobalEnv :: Context -> SymPath -> Maybe Binder
lookupBinderInGlobalEnv ctx path =
let global = (contextGlobalEnv ctx)
let global = contextGlobalEnv ctx
in lookupBinder path global
-- | Lookup a binder in a context's contextEnv.

25
src/Meta.hs
View File

@ -22,18 +22,17 @@ import Types
-- (def foo 0)
stub :: SymPath -> Binder
stub path =
( Binder
emptyMeta
( XObj
( Lst
[ XObj MetaStub Nothing Nothing,
XObj (Sym path Symbol) Nothing Nothing
]
)
(Just dummyInfo)
(Just (VarTy "a"))
)
)
Binder
emptyMeta
( XObj
( Lst
[ XObj MetaStub Nothing Nothing,
XObj (Sym path Symbol) Nothing Nothing
]
)
(Just dummyInfo)
(Just (VarTy "a"))
)
get :: String -> MetaData -> Maybe XObj
get key meta = Map.lookup key $ getMeta meta
@ -42,7 +41,7 @@ set :: String -> XObj -> MetaData -> MetaData
set key value meta = MetaData $ Map.insert key value $ getMeta meta
fromBinder :: Binder -> MetaData
fromBinder binder = binderMeta binder
fromBinder = binderMeta
getBinderMetaValue :: String -> Binder -> Maybe XObj
getBinderMetaValue key binder =

23
src/Obj.hs
View File

@ -269,9 +269,7 @@ instance Eq TemplateCreator where
_ == _ = True
prettyInfoFromXObj :: XObj -> String
prettyInfoFromXObj xobj = case xobjInfo xobj of
Just i -> prettyInfo i
Nothing -> "no info"
prettyInfoFromXObj xobj = maybe "no info" prettyInfo (xobjInfo xobj)
machineReadableInfoFromXObj :: FilePathPrintLength -> XObj -> String
machineReadableInfoFromXObj fppl xobj =
@ -504,7 +502,7 @@ prettyUpTo lim xobj =
prettyCaptures :: Set.Set XObj -> String
prettyCaptures captures =
joinWithComma (map (\x -> getName x ++ " : " ++ fromMaybe "" (fmap show (xobjTy x))) (Set.toList captures))
joinWithComma (map (\x -> getName x ++ " : " ++ maybe "" show (xobjTy x)) (Set.toList captures))
data EvalError
= EvalError String [XObj] FilePathPrintLength (Maybe Info)
@ -512,7 +510,7 @@ data EvalError
deriving (Eq)
instance Show EvalError where
show (HasStaticCall xobj info) = "Expression " ++ (pretty xobj) ++ " has unexpected static call" ++ showInfo info
show (HasStaticCall xobj info) = "Expression " ++ pretty xobj ++ " has unexpected static call" ++ showInfo info
where
showInfo (Just i) = " at " ++ prettyInfo i ++ "."
showInfo Nothing = ""
@ -576,8 +574,7 @@ prettyTyped = visit 0
++ suffix
spaces :: Int -> String
spaces n =
join (take n (repeat " "))
spaces n = replicate n ' '
-- | Datatype for holding meta data about a binder, like type annotation or docstring.
newtype MetaData = MetaData {getMeta :: Map.Map String XObj} deriving (Eq, Show, Generic)
@ -619,7 +616,7 @@ showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths)
++ replicate indent ' '
++ "}"
showBinderIndented indent showHidden (name, Binder meta xobj) =
if (not showHidden) && metaIsTrue meta "hidden"
if not showHidden && metaIsTrue meta "hidden"
then ""
else
replicate indent ' ' ++ name
@ -693,10 +690,7 @@ safeEnvModuleName env =
Just name -> name ++ ", with parent " ++ parent
Nothing -> "???, with parent " ++ parent
where
parent =
case envParent env of
Just p -> safeEnvModuleName p
Nothing -> "Global"
parent = maybe "Global" safeEnvModuleName (envParent env)
-- | Used by the compiler command "(env)"
prettyEnvironment :: Env -> String
@ -740,10 +734,7 @@ pathToEnv rootEnv = reverse (visit rootEnv)
Just name -> name : parent
Nothing -> parent
where
parent =
case envParent env of
Just p -> visit p
Nothing -> []
parent = maybe [] visit (envParent env)
showImportIndented :: Int -> SymPath -> String
showImportIndented indent path = replicate indent ' ' ++ " * " ++ show path

40
src/Parsing.hs
View File

@ -33,7 +33,7 @@ maybeSigned = do
i <- createInfo
sign <- Parsec.optionMaybe (Parsec.char '-')
digits <- Parsec.many1 Parsec.digit
let num = maybe "" (\x -> [x]) sign ++ digits
let num = maybe "" pure sign ++ digits
incColumn (length num)
pure (i, num)
@ -385,26 +385,26 @@ symbol = do
Nothing
)
else pure $ case last segments of
"defn" -> (XObj (Defn Nothing) i Nothing)
"def" -> (XObj Def i Nothing)
"defn" -> XObj (Defn Nothing) i Nothing
"def" -> XObj Def i Nothing
-- TODO: What about the other def- forms?
"do" -> (XObj Do i Nothing)
"while" -> (XObj While i Nothing)
"fn" -> (XObj (Fn Nothing Set.empty) i Nothing)
"let" -> (XObj Let i Nothing)
"break" -> (XObj Break i Nothing)
"if" -> (XObj If i Nothing)
"match" -> (XObj (Match MatchValue) i Nothing)
"match-ref" -> (XObj (Match MatchRef) i Nothing)
"true" -> (XObj (Bol True) i Nothing)
"false" -> (XObj (Bol False) i Nothing)
"address" -> (XObj Address i Nothing)
"set!" -> (XObj SetBang i Nothing)
"the" -> (XObj The i Nothing)
"ref" -> (XObj Ref i Nothing)
"deref" -> (XObj Deref i Nothing)
"with" -> (XObj With i Nothing)
name -> (XObj (Sym (SymPath (init segments) name) Symbol) i Nothing)
"do" -> XObj Do i Nothing
"while" -> XObj While i Nothing
"fn" -> XObj (Fn Nothing Set.empty) i Nothing
"let" -> XObj Let i Nothing
"break" -> XObj Break i Nothing
"if" -> XObj If i Nothing
"match" -> XObj (Match MatchValue) i Nothing
"match-ref" -> XObj (Match MatchRef) i Nothing
"true" -> XObj (Bol True) i Nothing
"false" -> XObj (Bol False) i Nothing
"address" -> XObj Address i Nothing
"set!" -> XObj SetBang i Nothing
"the" -> XObj The i Nothing
"ref" -> XObj Ref i Nothing
"deref" -> XObj Deref i Nothing
"with" -> XObj With i Nothing
name -> XObj (Sym (SymPath (init segments) name) Symbol) i Nothing
atom :: Parsec.Parsec String ParseState XObj
atom = Parsec.choice [number, pat, rawString, string, aChar, symbol]

6
src/PrimitiveError.hs
View File

@ -23,15 +23,15 @@ instance Show PrimitiveError where
++ pretty actual
++ "`"
show (ArgumentArityError fun numberExpected args) =
"`" ++ (show (getPath fun)) ++ "`" ++ "expected " ++ numberExpected
"`" ++ show (getPath fun) ++ "`" ++ "expected " ++ numberExpected
++ " arguments "
++ ", but got "
++ show (length args)
show (MissingInfo x) =
"No information about object: " ++ pretty x
show (ForewardImplementsMeta) =
show ForewardImplementsMeta =
"Can't set the `implements` meta on a global definition before it is declared."
show (RegisterTypeError) =
show RegisterTypeError =
"I don't understand this usage of `register-type`.\n\n"
++ "Valid usages :\n"
++ " (register-type Name)\n"

168
src/Primitives.hs
View File

@ -1,3 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Primitives where
import ColorText
@ -7,6 +10,7 @@ import Control.Applicative
import Control.Monad (foldM, unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Either (rights)
import Data.Functor ((<&>))
import Data.List (union)
import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)
import Deftype
@ -16,9 +20,9 @@ import Infer
import Info
import Interfaces
import Lookup
import qualified Map as Map
import qualified Map
import Managed
import qualified Meta as Meta
import qualified Meta
import Obj
import PrimitiveError
import Project
@ -38,12 +42,10 @@ import Web.Browser (openBrowser)
-- pure (ctx, dynamicNil)
makePrim :: String -> Int -> String -> String -> Primitive -> (String, Binder)
makePrim name arity doc example callback =
makePrim' name (Just arity) doc example callback
makePrim name arity = makePrim' name (Just arity)
makeVarPrim :: String -> String -> String -> Primitive -> (String, Binder)
makeVarPrim name doc example callback =
makePrim' name Nothing doc example callback
makeVarPrim name = makePrim' name Nothing
argumentErr :: Context -> String -> String -> String -> XObj -> IO (Context, Either EvalError XObj)
argumentErr ctx fun ty number actual =
@ -90,9 +92,9 @@ makePrim' name maybeArity docString example callback =
unfoldArgs =
case maybeArity of
Just arity ->
let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing)
let tosym x = XObj (Sym (SymPath [] x) Symbol) Nothing Nothing
in XObj (Arr (map (tosym . intToArgName) [1 .. arity])) Nothing Nothing
Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
Nothing -> XObj (Arr [XObj (Sym (SymPath [] "") Symbol) Nothing Nothing]) Nothing Nothing
infoXObjOrError :: Context -> (Context, Either EvalError XObj) -> Maybe Info -> Maybe XObj -> (Context, Either EvalError XObj)
infoXObjOrError ctx err i = maybe err (\xobj -> (ctx, Right xobj {xobjInfo = i}))
@ -126,22 +128,22 @@ primitiveColumn x@(XObj _ i _) ctx args =
err = toEvalError ctx x (MissingInfo x)
primitiveImplements :: Primitive
primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) _ _)] =
primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), XObj (Sym (SymPath prefixes name) _) _ _] =
do
(maybeInterface, maybeImpl) <- pure ((lookupBinder interface tyEnv), (lookupBinder (SymPath modules name) global))
(maybeInterface, maybeImpl) <- pure (lookupBinder interface tyEnv, lookupBinder (SymPath modules name) global)
case (maybeInterface, maybeImpl) of
(_, Nothing) ->
if null modules
then pure (toEvalError ctx call ForewardImplementsMeta)
else updateMeta (Meta.stub (SymPath modules name)) ctx
(Nothing, Just implBinder) ->
(warn >> updateMeta implBinder ctx)
warn >> updateMeta implBinder ctx
(Just interfaceBinder, Just implBinder) ->
(addToInterface interfaceBinder implBinder)
addToInterface interfaceBinder implBinder
where
global = contextGlobalEnv ctx
tyEnv = getTypeEnv . contextTypeEnv $ ctx
(SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
warn :: IO ()
warn = emitWarning (show (NonExistentInterfaceWarning x))
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
@ -165,7 +167,7 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XOb
where
update =
( ( Meta.getBinderMetaValue "implements" binder
>>= pure . updateImplementations binder
<&> updateImplementations binder
)
<|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
)
@ -177,11 +179,11 @@ primitiveImplements call ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XOb
else Meta.updateBinderMeta implBinder "implements" (XObj (Lst (x : impls)) inf ty)
updateImplementations implBinder _ =
Meta.updateBinderMeta implBinder "implements" (XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy))
primitiveImplements x ctx [(XObj (Sym _ _) _ _), y] =
primitiveImplements x ctx [XObj (Sym _ _) _ _, y] =
pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "second" y)
primitiveImplements _ ctx [x, _] =
pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "first" x)
primitiveImplements x@(XObj _ _ _) ctx args =
primitiveImplements x@XObj {} ctx args =
pure $ toEvalError ctx x (ArgumentArityError x "2" args)
define :: Bool -> Context -> XObj -> IO Context
@ -192,13 +194,13 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
then defineInTypeEnv newBinder
else defineInGlobalEnv newBinder
where
freshBinder = (Binder emptyMeta annXObj)
freshBinder = Binder emptyMeta annXObj
defineInTypeEnv :: Binder -> IO Context
defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder)
defineInGlobalEnv :: Binder -> IO Context
defineInGlobalEnv fallbackBinder =
do
maybeExistingBinder <- pure (lookupBinder (getPath annXObj) globalEnv)
let maybeExistingBinder = lookupBinder (getPath annXObj) globalEnv
when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj)))
case maybeExistingBinder of
Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder)
@ -206,7 +208,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
redefineExistingBinder :: Binder -> IO Context
redefineExistingBinder old@(Binder meta _) =
do
updatedBinder <- pure (hideIt (Binder meta annXObj))
let updatedBinder = hideIt (Binder meta annXObj)
warnTypeChange old
updatedContext <- implementInterfaces updatedBinder
pure (insertInGlobalEnv updatedContext (getPath annXObj) updatedBinder)
@ -230,12 +232,12 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
>>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces)
)
>>= \maybeinterfaces ->
pure (mapMaybe ((flip lookupBinder) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))
pure (mapMaybe (`lookupBinder` getTypeEnv typeEnv) (fromMaybe [] maybeinterfaces))
>>= \interfaceBinders ->
pure (foldM (\ctx' interface -> registerInInterface ctx' binder interface) ctx interfaceBinders)
>>= \result -> case result of
Left e -> ((printError (contextExecMode ctx) e) >> pure ctx)
Right newCtx -> (pure newCtx)
pure (foldM (`registerInInterface` binder) ctx interfaceBinders)
>>= \case
Left e -> printError (contextExecMode ctx) e >> pure ctx
Right newCtx -> pure newCtx
printError :: ExecutionMode -> String -> IO ()
printError Check e =
let fppl = projectFilePathPrintLength (contextProj ctx)
@ -249,13 +251,13 @@ primitiveRegisterType _ ctx [x] =
pure (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (xobjInfo x))
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _, XObj (Str override) _ _] =
primitiveRegisterTypeWithoutFields ctx t (Just override)
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), (XObj (Str override) _ _), members] =
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), XObj (Str override) _ _, members] =
primitiveRegisterTypeWithFields ctx x t (Just override) members
primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
primitiveRegisterTypeWithFields ctx x t Nothing members
primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
primitiveRegisterTypeWithoutFields :: Context -> String -> (Maybe String) -> IO (Context, Either EvalError XObj)
primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
primitiveRegisterTypeWithoutFields ctx t override = do
let pathStrings = contextPath ctx
typeEnv = contextTypeEnv ctx
@ -263,7 +265,7 @@ primitiveRegisterTypeWithoutFields ctx t override = do
typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
pure (ctx {contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition)}, dynamicNil)
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> (Maybe String) -> XObj -> IO (Context, Either EvalError XObj)
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
primitiveRegisterTypeWithFields ctx x t override members =
either
handleErr
@ -297,15 +299,15 @@ primitiveInfo :: Primitive
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
case path of
SymPath [] _ ->
(printIfFound (lookupBinderInTypeEnv ctx path))
printIfFound (lookupBinderInTypeEnv ctx path)
>> maybe
(notFound ctx target path)
(\binders -> foldM (\_ binder -> printer binder) (ctx, dynamicNil) binders)
( (fmap (: []) (lookupBinderInContextEnv ctx path))
<|> (multiLookupBinderEverywhere ctx path)
(foldM (\_ binder -> printer binder) (ctx, dynamicNil))
( fmap (: []) (lookupBinderInContextEnv ctx path)
<|> multiLookupBinderEverywhere ctx path
)
_ ->
(printIfFound (lookupBinderInTypeEnv ctx path))
printIfFound (lookupBinderInTypeEnv ctx path)
>> ( case lookupBinderInContextEnv ctx path of
Nothing -> notFound ctx target path
Just found -> printer found
@ -315,18 +317,18 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
printIfFound :: Maybe Binder -> IO (Context, Either EvalError XObj)
printIfFound binder = maybe (pure (ctx, dynamicNil)) printer binder
printer (binder@(Binder metaData x@(XObj _ (Just i) _))) =
(putStrLnWithColor Blue (forceShowBinder binder))
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
putStrLnWithColor Blue (forceShowBinder binder)
>> putStrLn (" Defined at " ++ prettyInfo i)
>> printMeta metaData (contextProj ctx) x
>> pure (ctx, dynamicNil)
printer (binder@(Binder metaData x)) =
(print binder)
printer binder@(Binder metaData x) =
print binder
>> printMeta metaData (contextProj ctx) x
>> pure (ctx, dynamicNil)
printMeta :: MetaData -> Project -> XObj -> IO ()
printMeta metaData proj x =
(maybe (pure ()) (printMetaVal "Documentation" ((either (const "") id) . unwrapStringXObj)) (Meta.get "doc" metaData))
maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
>> maybe (pure ()) (printMetaVal "Implements" getName) (Meta.get "implements" metaData)
>> maybe (pure ()) (printMetaVal "Private" pretty) (Meta.get "private" metaData)
>> maybe (pure ()) (printMetaVal "Hidden" pretty) (Meta.get "hidden" metaData)
@ -334,7 +336,7 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ _) _) _ _)] = do
>> when (projectPrintTypedAST proj) (putStrLnWithColor Yellow (prettyTyped x))
printMetaVal :: String -> (XObj -> String) -> XObj -> IO ()
printMetaVal s f xobj = putStrLn (" " ++ s ++ ": " ++ (f xobj))
printMetaVal s f xobj = putStrLn (" " ++ s ++ ": " ++ f xobj)
primitiveInfo _ ctx [notName] =
argumentErr ctx "info" "a name" "first" notName
primitiveInfo x ctx xs = pure $ toEvalError ctx x (ArgumentArityError x "1" xs)
@ -414,41 +416,39 @@ primitiveMembers _ _ _ = error "primitivemembers"
-- | Set meta data for a Binder
primitiveMetaSet :: Primitive
primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj (Str key) _ _, value] =
pure $ maybe create (\newCtx -> (newCtx, dynamicNil)) lookupAndUpdate
pure $ maybe create (,dynamicNil) lookupAndUpdate
where
fullPath@(SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
dynamicPath = (consPath ["Dynamic"] fullPath)
fullPath@(SymPath modules _) = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
dynamicPath = consPath ["Dynamic"] fullPath
global = contextGlobalEnv ctx
types = (getTypeEnv (contextTypeEnv ctx))
types = getTypeEnv (contextTypeEnv ctx)
lookupAndUpdate :: Maybe Context
lookupAndUpdate =
( (lookupBinder dynamicPath global)
( lookupBinder dynamicPath global
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
pure (Meta.updateBinderMeta binder key value)
>>= \b ->
(pure (envInsertAt global dynamicPath b))
pure (envInsertAt global dynamicPath b)
>>= \env -> pure (ctx {contextGlobalEnv = env})
)
<|> ( (lookupBinder fullPath global)
<|> ( lookupBinder fullPath global
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
pure (Meta.updateBinderMeta binder key value)
>>= \b ->
(pure (envInsertAt global fullPath b))
pure (envInsertAt global fullPath b)
>>= \env -> pure (ctx {contextGlobalEnv = env})
)
-- This is a global name but it doesn't exist in the global env
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
<|> ( if (null modules)
then
( (lookupBinder fullPath types)
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
>>= \b ->
(pure (envInsertAt types fullPath b))
>>= \env -> pure (ctx {contextTypeEnv = (TypeEnv env)})
)
else Nothing
)
<|> if null modules
then
lookupBinder fullPath types
>>= \binder ->
pure (Meta.updateBinderMeta binder key value)
>>= \b ->
pure (envInsertAt types fullPath b)
>>= \env -> pure (ctx {contextTypeEnv = TypeEnv env})
else Nothing
create :: (Context, Either EvalError XObj)
create =
if null prefixes
@ -585,7 +585,7 @@ primitiveDeftype xobj ctx (name : rest) =
members (binding : val : xs) = do
xs' <- members xs
Just $ (binding, val) : xs'
members (_ : []) = Nothing
members [_] = Nothing
members [] = Just []
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
ensureUnqualified objs =
@ -617,7 +617,7 @@ primitiveDeftype xobj ctx (name : rest) =
deftype' nameXObj typeName typeVariableXObjs = do
let pathStrings = contextPath ctx
env = contextGlobalEnv ctx
innerEnv = (contextInternalEnv ctx)
innerEnv = contextInternalEnv ctx
typeEnv = contextTypeEnv ctx
typeVariables = mapM xobjToTy typeVariableXObjs
(preExistingModule, preExistingMeta) =
@ -647,18 +647,18 @@ primitiveDeftype xobj ctx (name : rest) =
i
(Just TypeTy)
holderEnv = \name' prev -> Env (Map.fromList []) (Just prev) (Just name') [] ExternalEnv 0
holderModule = \name'' prevEnv -> (Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy)))
folder = \(contx, prev) pathstring -> (contx {contextTypeEnv = TypeEnv $ envInsertAt (getTypeEnv typeEnv) (SymPath (maybeToList (envModuleName prev)) pathstring) (holderModule pathstring prev)}, (holderEnv pathstring prev))
wHolders = (fst (foldl folder (ctx, (getTypeEnv typeEnv)) pathStrings))
holderModule = \name'' prevEnv -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy))
folder = \(contx, prev) pathstring -> (contx {contextTypeEnv = TypeEnv $ envInsertAt (getTypeEnv typeEnv) (SymPath (maybeToList (envModuleName prev)) pathstring) (holderModule pathstring prev)}, holderEnv pathstring prev)
wHolders = fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings)
ctx' =
( (fst (foldl folder (ctx, (getTypeEnv typeEnv)) pathStrings))
( (fst (foldl folder (ctx, getTypeEnv typeEnv) pathStrings))
{ contextGlobalEnv = updatedGlobal,
contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv (contextTypeEnv wHolders)) (SymPath pathStrings tyName) (Binder emptyMeta typeDefinition))
}
)
in do
ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)))
let fakeImplBinder sympath t = Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t))
deleteSig = FuncTy [structTy] UnitTy StaticLifetimeTy
strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
@ -712,7 +712,7 @@ primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (
where
global = contextGlobalEnv ctx
types = getTypeEnv (contextTypeEnv ctx)
fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
fullPath = consPath (contextPath ctx `union` prefixes) (SymPath [] name)
lookup' :: Maybe Binder
lookup' = (lookupBinder fullPath global <|> lookupBinder fullPath types) >>= pure
foundBinder :: Binder -> (Context, Either EvalError XObj)
@ -726,9 +726,9 @@ primitiveMeta _ ctx [path, _] =
primitiveMeta _ _ _ = error "primitivemeta"
primitiveDefined :: Primitive
primitiveDefined _ ctx [XObj (Sym path _) _ _] = do
primitiveDefined _ ctx [XObj (Sym path _) _ _] =
let env = contextEnv ctx
pure $ maybe (ctx, Right falseXObj) (\_ -> (ctx, Right trueXObj)) (lookupInEnv path env)
in pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupInEnv path env)
primitiveDefined _ ctx [arg] =
argumentErr ctx "defined" "a symbol" "first" arg
primitiveDefined _ _ _ = error "primitivedefined"
@ -773,22 +773,24 @@ noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x)
primitiveType :: Primitive
-- A special case, the type of the type of types (type (type (type 1))) => ()
primitiveType _ ctx [(XObj _ _ (Just Universe))] =
primitiveType _ ctx [XObj _ _ (Just Universe)] =
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [XObj _ _ (Just TypeTy)] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
(maybe otherDefs go (lookupBinder path env))
maybe otherDefs go (lookupBinder path env)
where
env = contextGlobalEnv ctx
otherDefs = case multiLookupEverywhere name env of
[] ->
notFound ctx x path
binders ->
(sequence (map (go . snd) binders))
>>= pure . Lst . rights . map snd
>>= \obj -> pure (ctx, Right $ (XObj obj Nothing Nothing))
mapM (go . snd) binders
>>= (\obj -> pure (ctx, Right (XObj obj Nothing Nothing)))
. Lst
. rights
. map snd
go binder =
case (xobjTy (binderXObj binder)) of
case xobjTy (binderXObj binder) of
Nothing -> noTypeError ctx x
Just t -> pure (ctx, Right (reify t))
primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
@ -796,7 +798,7 @@ primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
where
env = contextGlobalEnv ctx
go binder =
case (xobjTy (binderXObj binder)) of
case xobjTy (binderXObj binder) of
Nothing -> noTypeError ctx x
Just t -> pure (ctx, Right $ reify t)
-- As a special case, we force evaluation on sequences such as (type (type 1))
@ -809,30 +811,30 @@ primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
-- (type '(Pair.init 1 1)) => (Pair Int Int)
-- Contrarily the behavior is far more consistent as a primitive if we simply add this case, and from a user perspective, it makes more sense
-- that this function would be one that *doesn't* evaluate its arguments.
primitiveType any' ctx [(XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _ : rest)) _ _)] =
primitiveType any' ctx [XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _ : rest)) _ _] =
primitiveType any' ctx rest
>>= \result -> case snd result of
Right xobj -> primitiveType any' (fst result) [xobj]
Left e -> pure (ctx, Left e)
primitiveType _ ctx [x@(XObj _ _ _)] =
primitiveType _ ctx [x@XObj {}] =
let tenv = contextTypeEnv ctx
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
in liftIO $ either fail' ok typed
where
fail' _ = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
ok ((XObj _ _ (Just t)), _) = pure (ctx, Right $ reify t)
ok (XObj _ _ (Just t), _) = pure (ctx, Right $ reify t)
ok (_, _) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
primitiveType _ _ _ = error "primitivetype"
primitiveKind :: Primitive
primitiveKind _ ctx [x@(XObj _ _ _)] =
primitiveKind _ ctx [x@XObj {}] =
let tenv = contextTypeEnv ctx
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
in pure (either fail' ok typed)
where
fail' _ = (evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x))
fail' _ = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
ok (XObj _ _ (Just t), _) = (ctx, Right $ reify (tyToKind t))
ok (_, _) = (evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x))
ok (_, _) = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
primitiveKind _ _ _ = error "primitivekind"
-- | Primitive for printing help.

7
src/Reify.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Module Reify provides a typeclass and instances for turning internal compiler types and data into
-- corresponding representations in the Carp language.
@ -44,13 +43,13 @@ instance Reifiable Ty where
reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
instance Reifiable String where
reify s = (XObj (Str s) Nothing (Just StringTy))
reify s = XObj (Str s) Nothing (Just StringTy)
instance Reifiable Int where
reify i = (XObj (Num IntTy (fromIntegral i)) Nothing (Just IntTy))
reify i = XObj (Num IntTy (fromIntegral i)) Nothing (Just IntTy)
getInfoAsXObj :: (Reifiable a) => (Info -> a) -> Maybe Info -> Maybe XObj
getInfoAsXObj f i = fmap (reify . f) i
getInfoAsXObj f = fmap (reify . f)
getFileAsXObj :: FilePathPrintLength -> Maybe Info -> Maybe XObj
getFileAsXObj FullPath = getInfoAsXObj infoFile

2
src/Repl.hs
View File

@ -124,7 +124,7 @@ treatSpecialInput arg = arg
repl :: String -> String -> InputT (StateT Context IO) ()
repl readSoFar prompt =
do
context <- lift $ get
context <- lift get
input <- getInputLine (strWithColor Yellow prompt)
case input of
Nothing -> do

10
src/Scoring.hs
View File

@ -26,7 +26,7 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
where
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
Just (Binder _ typedef) -> ((depthOfDeftype typeEnv Set.empty typedef varTys + 1), b)
Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
where
lookupPath = getPathFromStructName structName
@ -74,15 +74,15 @@ depthOfType typeEnv visited selfName theType =
depthOfStructType :: Ty -> [Ty] -> Int
depthOfStructType struct varTys =
1
+ case (getStructName struct) of
+ case getStructName struct of
"Array" -> depthOfVarTys
_
| (tyToC struct) == selfName -> 1
| tyToC struct == selfName -> 1
| otherwise ->
case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of
Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
where
moduleDepth = ((length lookupPath) * 1000) -- modules have score 1000
moduleDepth = length lookupPath * 1000 -- modules have score 1000
Nothing ->
--trace ("Unknown type: " ++ name) $
depthOfVarTys -- The problem here is that generic types don't generate
@ -110,7 +110,7 @@ scoreValueBinder _ _ binder =
(0, binder)
scoreBody :: Env -> Set.Set SymPath -> XObj -> Int
scoreBody globalEnv visited root = visit root
scoreBody globalEnv visited = visit
where
visit xobj =
case xobjObj xobj of

6
src/StartingEnv.hs
View File

@ -439,7 +439,7 @@ startingGlobalEnv noArray =
Map.fromList $
[ register "NULL" (PointerTy (VarTy "a"))
]
++ (if noArray then [] else [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing))])
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray]
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
@ -472,12 +472,12 @@ startingTypeEnv =
interfaceBinder
"str"
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
((SymPath ["Array"] "str") : (SymPath ["StaticArray"] "str") : registerFunctionFunctionsWithInterface "str")
(SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str")
builtInSymbolInfo,
interfaceBinder
"prn"
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
((SymPath ["StaticArray"] "str") : (registerFunctionFunctionsWithInterface "prn")) -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
(SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
builtInSymbolInfo
]
builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)

4
src/StaticArrayTemplates.hs
View File

@ -11,7 +11,7 @@ import Types
-- since there are some small differences here and there I'v decided to not
-- try to abstract over them and just duplicate the templates instead.
concreteArray :: Ty
concreteArray = (ConcreteNameTy "StaticArray")
concreteArray = ConcreteNameTy "StaticArray"
templateUnsafeNth :: (String, Binder)
templateUnsafeNth =
@ -67,7 +67,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
++ deleteTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
( \(FuncTy [StructTy _ [insideType]] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType
)

2
src/SumtypeCase.hs
View File

@ -12,7 +12,7 @@ data SumtypeCase = SumtypeCase
deriving (Show, Eq)
toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv typeVars xobjs = mapM (toCase typeEnv typeVars) xobjs
toCases typeEnv typeVars = mapM (toCase typeEnv typeVars)
toCase :: TypeEnv -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =

19
src/Sumtypes.hs
View File

@ -47,15 +47,14 @@ memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
replaceGenericTypesOnCases mappings cases =
map replaceOnCase cases
replaceGenericTypesOnCases mappings = map replaceOnCase
where
replaceOnCase theCase =
let newTys = (map (replaceTyVars mappings) (caseTys theCase))
let newTys = map (replaceTyVars mappings) (caseTys theCase)
in theCase {caseTys = newTys}
initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)]
initers insidePath structTy cases = mapM (binderForCaseInit insidePath structTy) cases
initers insidePath structTy = mapM (binderForCaseInit insidePath structTy)
binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder)
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
@ -143,7 +142,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _)
(FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
(\_ -> [])
(const [])
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
doc = "Gets the tag from a `" ++ typeName ++ "`."
binderForTag _ _ = error "binderfortag"
@ -202,7 +201,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
correctedCases = replaceGenericTypesOnCases mappings cases
tys = remove isFullyGenericType (concatMap caseTys correctedCases)
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) tys
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)]
)
genericStr _ _ _ _ = error "genericstr"
@ -227,7 +226,7 @@ tokensForStr typeEnv env _ cases concreteStructTy =
namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String)
namesFromCase theCase concreteStructTy =
let name = caseName theCase
in (name, caseTys theCase {caseTys = (remove isUnit (caseTys theCase))}, tagName concreteStructTy name)
in (name, caseTys theCase {caseTys = remove isUnit (caseTys theCase)}, tagName concreteStructTy name)
strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
@ -403,7 +402,11 @@ tokensForSumtypeCopy typeEnv env concreteStructTy cases =
unlines
[ "$DECL {",
" $p copy = *pRef;",
joinLines $ map (copyCase typeEnv env concreteStructTy) (zip cases (True : repeat False)),
joinLines $
zipWith
(curry (copyCase typeEnv env concreteStructTy))
cases
(True : repeat False),
" return copy;",
"}"
]

2
src/TypeError.hs
View File

@ -457,7 +457,7 @@ showTypeFromXObj mappings xobj =
Nothing -> "Type missing"
evalError :: Context -> String -> Maybe Info -> (Context, Either EvalError a)
evalError ctx msg i = makeEvalError ctx Nothing msg i
evalError ctx = makeEvalError ctx Nothing
-- | Print type errors correctly when running the compiler in 'Check' mode
makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info -> (Context, Either EvalError a)

28
src/Types.hs
View File

@ -80,7 +80,7 @@ data Kind
tyToKind :: Ty -> Kind
tyToKind (StructTy _ _) = Higher
tyToKind (FuncTy _ _ _) = Higher -- the type of functions, consider the (->) constructor in Haskell
tyToKind FuncTy {} = Higher -- the type of functions, consider the (->) constructor in Haskell
tyToKind (PointerTy _) = Higher
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
tyToKind _ = Base
@ -113,17 +113,17 @@ areKindsConsistent typeVars =
Just k ->
if k == kind
then assignKinds next arityMap
else (Left name)
else Left name
where
next = (vars ++ rest)
kind = (length vars)
next = vars ++ rest
kind = length vars
assignKinds ((VarTy v) : rest) arityMap =
case Map.lookup v arityMap of
Nothing -> assignKinds rest (Map.insert v kind arityMap)
Just k ->
if k == kind
then assignKinds rest arityMap
else (Left v)
else Left v
where
kind = 0
assignKinds (FuncTy args ret _ : rest) arityMap =
@ -175,8 +175,8 @@ instance Show Ty where
show ModuleTy = "Module"
show TypeTy = "Type"
show InterfaceTy = "Interface"
show (StructTy s []) = (show s)
show (StructTy s typeArgs) = "(" ++ (show s) ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
show (StructTy s []) = show s
show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
show (ConcreteNameTy name) = name
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
show (RefTy r lt) =
@ -212,8 +212,8 @@ doesTypeContainTyVarWithName _ _ = False
replaceConflicted :: String -> Ty -> Ty
replaceConflicted name (VarTy n) =
if n == name
then (VarTy (n ++ "conflicted"))
else (VarTy n)
then VarTy (n ++ "conflicted")
else VarTy n
replaceConflicted name (FuncTy argTys retTy lt) =
FuncTy
(map (replaceConflicted name) argTys)
@ -311,13 +311,13 @@ replaceTyVars mappings t =
(VarTy key) -> fromMaybe t (Map.lookup key mappings)
(FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
(StructTy name tyArgs) ->
case (replaceTyVars mappings name) of
case replaceTyVars mappings name of
-- special case, struct (f a b) mapped to (RefTy a lt)
-- We f in such a case to the full (Ref a lt) in constraints; we also still map
-- individual members a and b, as these need mappings since they may be
-- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
-- a would remain generic here.
(RefTy a lt) -> (replaceTyVars mappings (RefTy a lt))
(RefTy a lt) -> replaceTyVars mappings (RefTy a lt)
_ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs)
(PointerTy x) -> PointerTy (replaceTyVars mappings x)
(RefTy x lt) -> RefTy (replaceTyVars mappings x) (replaceTyVars mappings lt)
@ -336,7 +336,7 @@ lambdaEnvTy :: Ty
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
createStructName :: [String] -> String -> String
createStructName path name = (intercalate "." (path ++ [name]))
createStructName path name = intercalate "." (path ++ [name])
getStructName :: Ty -> String
getStructName (StructTy (ConcreteNameTy name) _) = name
@ -345,8 +345,8 @@ getStructName _ = ""
getPathFromStructName :: String -> [String]
getPathFromStructName structName =
let path = (map unpack (splitOn (pack ".") (pack structName)))
in if ((length path) > 1) then init path else []
let path = map unpack (splitOn (pack ".") (pack structName))
in if length path > 1 then init path else []
getNameFromStructName :: String -> String
getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))

1
src/Validate.hs
View File

@ -144,3 +144,4 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
isCaptured v@(VarTy _) (StructTy _ vars) = v `elem` vars
-- Not a variable.
isCaptured _ _ = True