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

Merge pull request #100 from hellerve/apply-hlint

Browse Source 
Apply hlint fixes
This commit is contained in:
Erik Svedäng 2017-11-20 15:24:35 +01:00 committed by GitHub
commit 72119d6db4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 316 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
src/ArrayTemplates.hs
View File

@ -13,7 +13,7 @@ import Debug.Trace
templateCopyingMap :: (String, Binder)
templateCopyingMap = defineTypeParameterizedTemplate templateCreator path t
where fTy = FuncTy [(RefTy (VarTy "a"))] (VarTy "b")
where fTy = FuncTy [RefTy (VarTy "a")] (VarTy "b")
aTy = RefTy (StructTy "Array" [VarTy "a"])
bTy = StructTy "Array" [VarTy "b"]
path = SymPath ["Array"] "copy-map"
@ -23,8 +23,8 @@ templateCopyingMap = defineTypeParameterizedTemplate templateCreator path t
Template
t
(const (toTemplate "Array $NAME($(Fn [(Ref a)] b) f, Array* a)"))
(\(FuncTy [(FuncTy [_] outputTy), _] _) ->
(toTemplate $ unlines $
(\(FuncTy [FuncTy [_] outputTy, _] _) ->
(toTemplate $ unlines
[ "$DECL { "
, " Array b;"
, " b.len = a->len;"
@ -37,7 +37,7 @@ templateCopyingMap = defineTypeParameterizedTemplate templateCreator path t
, " return b;"
, "}"
]))
(\(FuncTy [ft@(FuncTy [_] _), (RefTy arrayTypeA)] arrayTypeB) ->
(\(FuncTy [ft@(FuncTy [_] _), RefTy arrayTypeA] arrayTypeB) ->
[defineFunctionTypeAlias ft,
defineArrayTypeAlias arrayTypeA,
defineArrayTypeAlias arrayTypeB] ++
@ -69,16 +69,16 @@ templateEMap =
templateFilter :: (String, Binder)
templateFilter = defineTypeParameterizedTemplate templateCreator path t
where
fTy = FuncTy [(RefTy (VarTy "a"))] BoolTy
fTy = FuncTy [RefTy (VarTy "a")] BoolTy
aTy = StructTy "Array" [VarTy "a"]
path = SymPath ["Array"] "filter"
t = (FuncTy [fTy, aTy] aTy)
t = FuncTy [fTy, aTy] aTy
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME($(Fn [(Ref a)] Bool) predicate, Array a)"))
(\(FuncTy [(FuncTy [(RefTy insideTy)] BoolTy), _] _) ->
(\(FuncTy [FuncTy [RefTy insideTy] BoolTy, _] _) ->
(toTemplate $ unlines $
let deleter = insideArrayDeletion typeEnv env insideTy
in ["$DECL { "
@ -95,7 +95,7 @@ templateFilter = defineTypeParameterizedTemplate templateCreator path t
, " return a;"
, "}"
]))
(\(FuncTy [ft@(FuncTy [(RefTy insideType)] BoolTy), arrayType] _) ->
(\(FuncTy [ft@(FuncTy [RefTy insideType] BoolTy), arrayType] _) ->
[defineFunctionTypeAlias ft, defineArrayTypeAlias arrayType] ++
depsForDeleteFunc typeEnv env insideType)
@ -151,9 +151,9 @@ templatePushBack =
templatePopBack :: (String, Binder)
templatePopBack = defineTypeParameterizedTemplate templateCreator path t
where path = (SymPath ["Array"] "pop-back")
where path = SymPath ["Array"] "pop-back"
aTy = StructTy "Array" [VarTy "a"]
t = (FuncTy [aTy] aTy)
t = FuncTy [aTy] aTy
templateCreator = TemplateCreator $
\typeEnv env ->
Template
@ -161,7 +161,7 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t
(const (toTemplate "Array $NAME(Array a)"))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in (toTemplate (unlines
in toTemplate (unlines
["$DECL { "
," a.len--;"
," " ++ deleteElement "a.len"
@ -173,7 +173,7 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t
," CARP_FREE(pre);"
," return a;"
,"}"
])))
]))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _) ->
defineArrayTypeAlias arrayType :
depsForDeleteFunc typeEnv env arrayType ++
@ -245,7 +245,7 @@ templateElemCount =
templateReplicate :: (String, Binder)
templateReplicate = defineTypeParameterizedTemplate templateCreator path t
where path = SymPath ["Array"] "replicate"
t = FuncTy [IntTy, (RefTy (VarTy "t"))] (StructTy "Array" [VarTy "t"])
t = FuncTy [IntTy, RefTy (VarTy "t")] (StructTy "Array" [VarTy "t"])
templateCreator = TemplateCreator $
\typeEnv env ->
Template
@ -253,14 +253,14 @@ templateReplicate = defineTypeParameterizedTemplate templateCreator path t
(const (toTemplate "Array $NAME(int n, $t *elem)"))
(\(FuncTy [_, _] arrayType) ->
let StructTy _ [insideType] = arrayType
copierType = (FuncTy [(RefTy insideType)] insideType)
copierType = FuncTy [RefTy insideType] insideType
copierPath = if isManaged typeEnv insideType -- TODO: also check if it's an external function
then case nameOfPolymorphicFunction typeEnv env copierType "copy" of
Just p -> Just p
Nothing -> error ("Can't find copy function for array type: " ++ show insideType)
else Nothing
in
(toTemplate $ unlines [ "$DECL {"
toTemplate $ unlines [ "$DECL {"
, " Array a; a.len = n; a.data = CARP_MALLOC(sizeof($t) * n);"
, " for(int i = 0; i < n; ++i) {"
, " (($t*)a.data)[i] = " ++ case copierPath of
@ -268,7 +268,7 @@ templateReplicate = defineTypeParameterizedTemplate templateCreator path t
Nothing -> "*elem;"
, " }"
, " return a;"
, "}"]))
, "}"])
(\(FuncTy [_, _] arrayType) ->
let StructTy _ [insideType] = arrayType
in defineArrayTypeAlias arrayType :
@ -278,13 +278,13 @@ templateReplicate = defineTypeParameterizedTemplate templateCreator path t
templateRepeat :: (String, Binder)
templateRepeat = defineTypeParameterizedTemplate templateCreator path t
where path = SymPath ["Array"] "repeat"
t = (FuncTy [IntTy, (FuncTy [] (VarTy "t"))] (StructTy "Array" [VarTy "t"]))
t = FuncTy [IntTy, FuncTy [] (VarTy "t")] (StructTy "Array" [VarTy "t"])
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME(int n, $(Fn [] t) f)"))
(\_ ->
(const
(toTemplate $ unlines
[ "$DECL {"
, " Array a; a.len = n; a.data = CARP_MALLOC(sizeof($t) * n);"
@ -342,8 +342,8 @@ templateCount = defineTemplate
templateRange :: (String, Binder)
templateRange = defineTypeParameterizedTemplate templateCreator path t
where path = (SymPath ["Array"] "range")
t = (FuncTy [(VarTy "t"), (VarTy "t"), (VarTy "t")] (StructTy "Array" [(VarTy "t")]))
where path = SymPath ["Array"] "range"
t = FuncTy [VarTy "t", VarTy "t", VarTy "t"] (StructTy "Array" [VarTy "t"])
templateCreator = TemplateCreator $
\typeEnv env ->
Template
@ -374,12 +374,12 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t
(const (toTemplate "void $NAME (Array a)"))
(\(FuncTy [arrayType] UnitTy) ->
[TokDecl, TokC "{\n"] ++
(deleteTy typeEnv env arrayType) ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [arrayType@(StructTy "Array" [insideType])] UnitTy) ->
defineArrayTypeAlias arrayType : depsForDeleteFunc typeEnv env insideType)
path = SymPath ["Array"] "delete"
t = (FuncTy [(StructTy "Array" [VarTy "a"])] UnitTy)
t = FuncTy [StructTy "Array" [VarTy "a"]] UnitTy
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
deleteTy typeEnv env (StructTy "Array" [innerType]) =
@ -405,23 +405,23 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t
Template
t
(const (toTemplate "Array $NAME (Array* a)"))
(\(FuncTy [(RefTy arrayType)] _) ->
(\(FuncTy [RefTy arrayType] _) ->
[TokDecl, TokC "{\n"] ++
[TokC " Array copy;\n"] ++
[TokC " copy.len = a->len;\n"] ++
[TokC " copy.data = CARP_MALLOC(sizeof(", TokTy (VarTy "a"), TokC ") * a->len);\n"] ++
(copyTy typeEnv env arrayType) ++
copyTy typeEnv env arrayType ++
[TokC " return copy;\n"] ++
[TokC "}\n"])
(\case
(FuncTy [(RefTy arrayType@(StructTy "Array" [insideType]))] _) ->
(FuncTy [RefTy arrayType@(StructTy "Array" [insideType])] _) ->
defineArrayTypeAlias arrayType :
depsForCopyFunc typeEnv env insideType
err ->
error ("CAN'T MATCH: " ++ (show err))
error ("CAN'T MATCH: " ++ show err)
)
path = SymPath ["Array"] "copy"
t = (FuncTy [(RefTy (StructTy "Array" [VarTy "a"]))] (StructTy "Array" [VarTy "a"]))
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"])] (StructTy "Array" [VarTy "a"])
copyTy :: TypeEnv -> Env -> Ty -> [Token]
copyTy typeEnv env (StructTy "Array" [innerType]) =
@ -448,15 +448,15 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t
Template
t
(const (toTemplate "string $NAME (Array* a)"))
(\(FuncTy [(RefTy arrayType)] StringTy) ->
(\(FuncTy [RefTy arrayType] StringTy) ->
[TokDecl, TokC "{\n"] ++
(strTy typeEnv env arrayType) ++
strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [(RefTy arrayType@(StructTy "Array" [insideType]))] StringTy) ->
(\(FuncTy [RefTy arrayType@(StructTy "Array" [insideType])] StringTy) ->
let deps = depsForStrFunc typeEnv env insideType
in defineArrayTypeAlias arrayType : deps)
path = SymPath ["Array"] "str"
t = (FuncTy [(RefTy (StructTy "Array" [VarTy "a"]))] StringTy)
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"])] StringTy
-- | TODO: move this into the templateStrArray function?
strTy :: TypeEnv -> Env -> Ty -> [Token]

5
src/AssignTypes.hs
View File

@ -5,6 +5,7 @@ import Obj
import Util
import TypeError
{-# ANN assignTypes "HLint: ignore Eta reduce" #-}
-- | Walk the whole expression tree and replace all occurences of VarTy with their corresponding actual type.
assignTypes :: TypeMappings -> XObj -> Either TypeError XObj
assignTypes mappings root = visit root
@ -32,7 +33,7 @@ assignTypes mappings root = visit root
assignType :: XObj -> Either TypeError XObj
assignType xobj = case ty xobj of
Just startingType ->
let finalType = (replaceTyVars mappings startingType)
let finalType = replaceTyVars mappings startingType
in if isArrayTypeOK finalType
then Right (xobj { ty = Just finalType })
else Left (ArraysCannotContainRefs xobj)
@ -40,5 +41,5 @@ assignTypes mappings root = visit root
isArrayTypeOK :: Ty -> Bool
isArrayTypeOK (StructTy "Array" [(RefTy _)]) = False -- An array containing refs!
isArrayTypeOK (StructTy "Array" [RefTy _]) = False -- An array containing refs!
isArrayTypeOK _ = True

63
src/Commands.hs
View File

@ -84,41 +84,41 @@ objToCommand :: Context -> XObj -> ReplCommand
objToCommand ctx xobj =
case obj xobj of
Lst lst -> case lst of
XObj Defn _ _ : _ : _ : _ : [] -> Define xobj
XObj Def _ _ : _ : _ : [] -> Define xobj
[XObj Defn _ _, _, _, _] -> Define xobj
[XObj Def _ _, _, _] -> Define xobj
XObj (Sym (SymPath _ "module")) _ _ : XObj (Sym (SymPath _ name)) _ _ : innerExpressions ->
DefineModule name innerExpressions (info xobj)
XObj (Sym (SymPath _ "defmodule")) _ _ : XObj (Sym (SymPath _ name)) _ _ : innerExpressions ->
DefineModule name innerExpressions (info xobj)
XObj (Sym (SymPath _ "defmacro")) _ _ : XObj (Sym (SymPath _ name)) _ _ : params@(XObj (Arr _) _ _) : body : [] ->
[XObj (Sym (SymPath _ "defmacro")) _ _, XObj (Sym (SymPath _ name)) _ _, params@(XObj (Arr _) _ _), body] ->
DefineMacro name params body
XObj (Sym (SymPath _ "defdynamic")) _ _ : XObj (Sym (SymPath _ name)) _ _ : params@(XObj (Arr _) _ _) : body : [] ->
[XObj (Sym (SymPath _ "defdynamic")) _ _, XObj (Sym (SymPath _ name)) _ _, params@(XObj (Arr _) _ _), body] ->
DefineDynamic name params body
XObj (Sym (SymPath _ "deftype")) _ _ : name : rest -> DefineType name rest
XObj (Sym (SymPath _ "defalias")) _ _ : XObj (Sym (SymPath _ name)) _ _ : t : [] -> DefineAlias name t
XObj (Sym (SymPath _ "eval")) _ _ : form : [] -> Eval form
XObj (Sym (SymPath _ "expand")) _ _ : form : [] -> Expand form
XObj (Sym (SymPath _ "instantiate")) _ _ : name : signature : [] -> InstantiateTemplate name signature
XObj (Sym (SymPath _ "type")) _ _ : form : [] -> Type form
XObj (Sym (SymPath _ "info")) _ _ : form : [] -> GetInfo form
XObj (Sym (SymPath _ "help")) _ _ : XObj (Sym (SymPath _ chapter)) _ _ : [] -> Help chapter
XObj (Sym (SymPath _ "help")) _ _ : [] -> Help ""
XObj (Sym (SymPath _ "quit")) _ _ : [] -> Quit
XObj (Sym (SymPath _ "env")) _ _ : [] -> ListBindingsInEnv
XObj (Sym (SymPath _ "build")) _ _ : [] -> BuildExe
XObj (Sym (SymPath _ "run")) _ _ : [] -> RunExe
XObj (Sym (SymPath _ "cat")) _ _ : [] -> Cat
XObj (Sym (SymPath _ "use")) _ _ : XObj (Sym path) _ _ : [] -> Use path xobj
XObj (Sym (SymPath _ "project-set!")) _ _ : XObj (Sym (SymPath _ key)) _ _ : XObj (Str value) _ _ : [] -> ProjectSet key value
XObj (Sym (SymPath _ "register")) _ _ : XObj (Sym (SymPath _ name)) _ _ : t : [] -> Register name t
[XObj (Sym (SymPath _ "defalias")) _ _, XObj (Sym (SymPath _ name)) _ _, t] -> DefineAlias name t
[XObj (Sym (SymPath _ "eval")) _ _, form] -> Eval form
[XObj (Sym (SymPath _ "expand")) _ _, form] -> Expand form
[XObj (Sym (SymPath _ "instantiate")) _ _, name, signature] -> InstantiateTemplate name signature
[XObj (Sym (SymPath _ "type")) _ _, form] -> Type form
[XObj (Sym (SymPath _ "info")) _ _, form] -> GetInfo form
[XObj (Sym (SymPath _ "help")) _ _, XObj (Sym (SymPath _ chapter)) _ _] -> Help chapter
[XObj (Sym (SymPath _ "help")) _ _] -> Help ""
[XObj (Sym (SymPath _ "quit")) _ _] -> Quit
[XObj (Sym (SymPath _ "env")) _ _] -> ListBindingsInEnv
[XObj (Sym (SymPath _ "build")) _ _] -> BuildExe
[XObj (Sym (SymPath _ "run")) _ _] -> RunExe
[XObj (Sym (SymPath _ "cat")) _ _] -> Cat
[XObj (Sym (SymPath _ "use")) _ _, XObj (Sym path) _ _] -> Use path xobj
[XObj (Sym (SymPath _ "project-set!")) _ _, XObj (Sym (SymPath _ key)) _ _, XObj (Str value) _ _] -> ProjectSet key value
[XObj (Sym (SymPath _ "register")) _ _, XObj (Sym (SymPath _ name)) _ _, t] -> Register name t
XObj (Sym (SymPath _ "register-type")) _ _ : XObj (Sym (SymPath _ name)) _ _ : rest -> RegisterType name rest
XObj (Sym (SymPath _ "local-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (LocalInclude file)
XObj (Sym (SymPath _ "system-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (SystemInclude file)
XObj (Sym (SymPath _ "add-cflag")) _ _ : XObj (Str flag) _ _ : [] -> AddCFlag flag
XObj (Sym (SymPath _ "add-lib")) _ _ : XObj (Str flag) _ _ : [] -> AddLibraryFlag flag
XObj (Sym (SymPath _ "project")) _ _ : [] -> DisplayProject
XObj (Sym (SymPath _ "load")) _ _ : XObj (Str path) _ _ : [] -> Load path
XObj (Sym (SymPath _ "reload")) _ _ : [] -> Reload
[XObj (Sym (SymPath _ "local-include")) _ _, XObj (Str file) _ _] -> AddInclude (LocalInclude file)
[XObj (Sym (SymPath _ "system-include")) _ _, XObj (Str file) _ _] -> AddInclude (SystemInclude file)
[XObj (Sym (SymPath _ "add-cflag")) _ _, XObj (Str flag) _ _] -> AddCFlag flag
[XObj (Sym (SymPath _ "add-lib")) _ _, XObj (Str flag) _ _] -> AddLibraryFlag flag
[XObj (Sym (SymPath _ "project")) _ _] -> DisplayProject
[XObj (Sym (SymPath _ "load")) _ _, XObj (Str path) _ _] -> Load path
[XObj (Sym (SymPath _ "reload")) _ _] -> Reload
_ -> consumeExpr ctx xobj
Sym (SymPath [] (':' : text)) -> ListOfCommands (mapMaybe charToCommand text)
_ -> consumeExpr ctx xobj
@ -139,7 +139,7 @@ define ctx@(Context globalEnv typeEnv _ proj _) annXObj =
-- Sort different kinds of definitions into the globalEnv or the typeEnv:
case annXObj of
XObj (Lst (XObj (Defalias _) _ _ : _)) _ _ ->
do --putStrLnWithColor Yellow (show (getPath annXObj) ++ " : " ++ show annXObj)
--putStrLnWithColor Yellow (show (getPath annXObj) ++ " : " ++ show annXObj)
return (ctx { contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv typeEnv) (getPath annXObj) annXObj) })
_ ->
do --putStrLnWithColor Blue (show (getPath annXObj) ++ " : " ++ showMaybeTy (ty annXObj))
@ -196,8 +196,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
ctx' = (ctx { contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) typeModuleXObj
, contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) typeName typeDefinition)
})
in do ctx'' <- foldM define ctx' deps
return ctx''
in foldM define ctx' deps
Left errorMessage ->
do putStrLnWithColor Red ("Invalid type definition for '" ++ pretty nameXObj ++ "'. " ++ errorMessage)
return ctx
@ -403,7 +402,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
fullSearchPaths =
path :
("./" ++ path) : -- the path from the current directory
(map (++ "/" ++ path) (projectCarpSearchPaths proj)) ++ -- user defined search paths
map (++ "/" ++ path) (projectCarpSearchPaths proj) ++ -- user defined search paths
[carpDir ++ "/core/" ++ path]
-- putStrLn ("Full search paths = " ++ show fullSearchPaths)
existingPaths <- filterM doesPathExist fullSearchPaths
@ -412,7 +411,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
do putStrLnWithColor Red ("Invalid path " ++ path)
return ctx
firstPathFound : _ ->
do --putStrLn ("Will load '" ++ firstPathFound ++ "'")
--putStrLn ("Will load '" ++ firstPathFound ++ "'")
performLoad firstPathFound
where performLoad thePath =
do contents <- readFile thePath

67
src/Concretize.hs
View File

@ -31,8 +31,8 @@ concretizeXObj allowAmbiguity typeEnv rootEnv root =
return $ do okVisited <- visited
Right (XObj (Lst okVisited) i t)
visit env (XObj (Arr arr) i (Just t)) = do visited <- fmap sequence (mapM (visit env) arr)
modify ((depsForDeleteFunc typeEnv env t) ++ )
modify ((defineArrayTypeAlias t) : )
modify (depsForDeleteFunc typeEnv env t ++)
modify (defineArrayTypeAlias t : )
return $ do okVisited <- visited
Right (XObj (Arr okVisited) i (Just t))
visit _ x = return (Right x)
@ -40,17 +40,17 @@ concretizeXObj allowAmbiguity typeEnv rootEnv root =
visitList :: Env -> [XObj] -> State [XObj] (Either TypeError [XObj])
visitList _ [] = return (Right [])
visitList env (defn@(XObj Defn _ _) : nameSymbol@(XObj (Sym (SymPath [] "main")) _ _) : args@(XObj (Arr argsArr) _ _) : body : []) =
do if not (null argsArr)
then return $ Left (MainCannotHaveArguments (length argsArr))
else do visitedBody <- visit env body
return $ do okBody <- visitedBody
let t = fromMaybe UnitTy (ty okBody)
if t /= UnitTy && t /= IntTy
then Left (MainCanOnlyReturnUnitOrInt t)
else return [defn, nameSymbol, args, okBody]
visitList env [defn@(XObj Defn _ _), nameSymbol@(XObj (Sym (SymPath [] "main")) _ _), args@(XObj (Arr argsArr) _ _), body] =
if not (null argsArr)
then return $ Left (MainCannotHaveArguments (length argsArr))
else do visitedBody <- visit env body
return $ do okBody <- visitedBody
let t = fromMaybe UnitTy (ty okBody)
if t /= UnitTy && t /= IntTy
then Left (MainCanOnlyReturnUnitOrInt t)
else return [defn, nameSymbol, args, okBody]
visitList env (defn@(XObj Defn _ _) : nameSymbol : args@(XObj (Arr argsArr) _ _) : body : []) =
visitList env [defn@(XObj Defn _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body] =
do mapM_ checkForNeedOfTypedefs argsArr
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName)) _ _) ->
@ -60,14 +60,14 @@ concretizeXObj allowAmbiguity typeEnv rootEnv root =
return $ do okBody <- visitedBody
return [defn, nameSymbol, args, okBody]
visitList env (letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : []) =
visitList env [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] =
do visitedBindings <- fmap sequence (mapM (visit env) bindings)
visitedBody <- (visit env) body
visitedBody <- visit env body
return $ do okVisitedBindings <- visitedBindings
okVisitedBody <- visitedBody
return [letExpr, XObj (Arr okVisitedBindings) bindi bindt, okVisitedBody]
visitList env (theExpr@(XObj The _ _) : typeXObj : value : []) =
visitList env [theExpr@(XObj The _ _), typeXObj, value] =
do visitedValue <- visit env value
return $ do okVisitedValue <- visitedValue
return [theExpr, typeXObj, okVisitedValue]
@ -163,7 +163,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv definition concreteType =
newPath = SymPath pathStrings (name ++ suffix)
in
case definition of
XObj (Lst ((XObj Defn _ _) : _)) _ _ ->
XObj (Lst (XObj Defn _ _ : _)) _ _ ->
let withNewPath = setPath definition newPath
mappings = unifySignatures polyType concreteType
in case assignTypes mappings withNewPath of
@ -172,10 +172,10 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv definition concreteType =
managed <- manageMemory typeEnv globalEnv concrete
return (managed, deps)
Left e -> Left e
XObj (Lst ((XObj (Deftemplate (TemplateCreator templateCreator)) _ _) : _)) _ _ ->
XObj (Lst (XObj (Deftemplate (TemplateCreator templateCreator)) _ _ : _)) _ _ ->
let template = templateCreator typeEnv globalEnv
in Right (instantiateTemplate newPath concreteType template)
XObj (Lst ((XObj External _ _) : _ : [])) _ _ ->
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
@ -188,7 +188,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv definition concreteType =
allFunctionsWithNameAndSignature env functionName functionType =
filter (predicate . ty . binderXObj . snd) (multiLookupALL functionName env)
where
predicate = \(Just t) -> areUnifiable functionType t
predicate (Just t) = areUnifiable functionType t
-- | Find all the dependencies of a polymorphic function with a name and a desired concrete type.
depsOfPolymorphicFunction :: TypeEnv -> Env -> String -> Ty -> [XObj]
@ -197,12 +197,12 @@ depsOfPolymorphicFunction typeEnv env functionName functionType =
[] ->
(trace $ "No '" ++ functionName ++ "' function found with type " ++ show functionType ++ ".")
[]
[(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] ->
[(_, Binder (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _))] ->
[]
[(_, Binder single)] ->
case concretizeDefinition False typeEnv env single functionType of
Left err -> error (show err)
Right (ok, deps) -> (ok : deps)
Right (ok, deps) -> ok : deps
_ ->
(trace $ "Too many '" ++ functionName ++ "' functions found with type " ++ show functionType ++ ", can't figure out dependencies.")
[]
@ -218,22 +218,22 @@ depsForDeleteFunc typeEnv env t =
depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForCopyFunc typeEnv env t =
if isManaged typeEnv t
then depsOfPolymorphicFunction typeEnv env "copy" (FuncTy [(RefTy t)] t)
then depsOfPolymorphicFunction typeEnv env "copy" (FuncTy [RefTy t] t)
else []
-- | Helper for finding the 'str' function for a type.
depsForStrFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForStrFunc typeEnv env t =
if isManaged typeEnv t
then depsOfPolymorphicFunction typeEnv env "str" (FuncTy [(RefTy t)] StringTy)
then depsOfPolymorphicFunction typeEnv env "str" (FuncTy [RefTy t] StringTy)
else depsOfPolymorphicFunction typeEnv env "str" (FuncTy [t] StringTy)
-- | The type of a type's str function.
typesStrFunctionType :: TypeEnv -> Ty -> Ty
typesStrFunctionType typeEnv memberType =
if isManaged typeEnv memberType
then (FuncTy [(RefTy memberType)] StringTy)
else (FuncTy [memberType] StringTy)
then FuncTy [RefTy memberType] StringTy
else FuncTy [memberType] StringTy
-- | The various results when trying to find a function using 'findFunctionForMember'.
data FunctionFinderResult = FunctionFound String
@ -241,6 +241,13 @@ data FunctionFinderResult = FunctionFound String
| FunctionIgnored
deriving (Show)
getConcretizedPath :: XObj -> Ty -> SymPath
getConcretizedPath single functionType =
let Just t' = ty single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
in SymPath pathStrings (name ++ suffix)
-- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array).
findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
findFunctionForMember typeEnv env functionName functionType (memberName, memberType)
@ -249,10 +256,7 @@ findFunctionForMember typeEnv env functionName functionType (memberName, memberT
[] -> FunctionNotFound ("Can't find any '" ++ functionName ++ "' function for member '" ++
memberName ++ "' of type " ++ show functionType)
[(_, Binder single)] ->
let Just t' = ty single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix)
let concretizedPath = getConcretizedPath single functionType
in FunctionFound (pathToC concretizedPath)
_ -> FunctionNotFound ("Can't find a single '" ++ functionName ++ "' function for member '" ++
memberName ++ "' of type " ++ show functionType)
@ -265,10 +269,7 @@ findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (me
[] -> FunctionNotFound ("Can't find any '" ++ functionName ++ "' function for member '" ++
memberName ++ "' of type " ++ show functionType)
[(_, Binder single)] ->
let Just t' = ty single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix)
let concretizedPath = getConcretizedPath single functionType
in FunctionFound (pathToC concretizedPath)
_ -> FunctionNotFound ("Can't find a single '" ++ functionName ++ "' function for member '" ++
memberName ++ "' of type " ++ show functionType)

2
src/Constraints.hs
View File

@ -85,7 +85,7 @@ isTypeHole ('?' : _, _) = True
isTypeHole _ = False
solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
solveOne mappings constraint = solveOneInternal mappings constraint
solveOne = solveOneInternal
debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
debugSolveOne mappings constraint = let m' = solveOneInternal mappings constraint

57
src/Deftype.hs
View File

@ -14,6 +14,7 @@ import Polymorphism
data AllocationMode = StackAlloc | HeapAlloc
{-# ANN module "HLint: ignore Reduce duplication" #-}
-- | This function creates a "Type Module" with the same name as the type being defined.
-- A type module provides a namespace for all the functions that area automatically
-- generated by a deftype.
@ -44,17 +45,17 @@ moduleForDeftype typeEnv env pathStrings typeName rest i =
Just x -> Right x
Nothing -> Left "Something's wrong with the templates..." -- TODO: Better messages here, should come from the template functions!
{-# ANN validateMembers "HLint: ignore Eta reduce" #-}
-- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...]
-- | TODO: What a mess this function is, clean it up!
validateMembers :: TypeEnv -> [XObj] -> Either String ()
validateMembers typeEnv rest =
mapM_ validateOneCase rest
validateMembers typeEnv rest = mapM_ validateOneCase rest
where
validateOneCase :: XObj -> Either String ()
validateOneCase (XObj (Arr arr) _ _) =
if length arr `mod` 2 == 0
then do mapM_ okXObjForType (map snd (pairwise arr))
then mapM_ (okXObjForType . snd) (pairwise arr)
else Left "Uneven nr of members / types."
validateOneCase XObj {} =
Left "Type members must be defined using array syntax: [member1 type1 member2 type2 ...]"
@ -103,9 +104,9 @@ templateForNew _ _ _ = Nothing
-- | Helper function to create the binder for the 'str' template.
templateForStr :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe ((String, Binder), [XObj])
templateForStr typeEnv env insidePath typeName [XObj (Arr membersXObjs) _ _] =
Just $ (instanceBinderWithDeps (SymPath insidePath "str")
(FuncTy [(RefTy (StructTy typeName []))] StringTy)
(templateStr typeEnv env typeName (memberXObjsToPairs membersXObjs)))
Just (instanceBinderWithDeps (SymPath insidePath "str")
(FuncTy [RefTy (StructTy typeName [])] StringTy)
(templateStr typeEnv env typeName (memberXObjsToPairs membersXObjs)))
templateForStr _ _ _ _ _ = Nothing
-- | Generate a list of types from a deftype declaration.
@ -115,17 +116,17 @@ initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs)
-- | Helper function to create the binder for the 'delete' template.
templateForDelete :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe ((String, Binder), [XObj])
templateForDelete typeEnv env insidePath typeName [XObj (Arr membersXObjs) _ _] =
Just $ (instanceBinderWithDeps (SymPath insidePath "delete")
(FuncTy [(StructTy typeName [])] UnitTy)
(templateDelete typeEnv env (memberXObjsToPairs membersXObjs)))
Just (instanceBinderWithDeps (SymPath insidePath "delete")
(FuncTy [StructTy typeName []] UnitTy)
(templateDelete typeEnv env (memberXObjsToPairs membersXObjs)))
templateForDelete _ _ _ _ _ = Nothing
-- | Helper function to create the binder for the 'copy' template.
templateForCopy :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe ((String, Binder), [XObj])
templateForCopy typeEnv env insidePath typeName [XObj (Arr membersXObjs) _ _] =
Just $ (instanceBinderWithDeps (SymPath insidePath "copy")
(FuncTy [(RefTy (StructTy typeName []))] (StructTy typeName []))
(templateCopy typeEnv env (memberXObjsToPairs membersXObjs)))
Just (instanceBinderWithDeps (SymPath insidePath "copy")
(FuncTy [RefTy (StructTy typeName [])] (StructTy typeName []))
(templateCopy typeEnv env (memberXObjsToPairs membersXObjs)))
templateForCopy _ _ _ _ _ = Nothing
-- | Get a list of pairs from a deftype declaration.
@ -145,11 +146,11 @@ templatesForSingleMember typeEnv env insidePath typeName (nameXObj, typeXObj) =
let Just t = xobjToTy typeXObj
p = StructTy typeName []
memberName = getName nameXObj
fixedMemberTy = if isManaged typeEnv t then (RefTy t) else t
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [(RefTy p)] fixedMemberTy) (templateGetter (mangle memberName) fixedMemberTy)
fixedMemberTy = if isManaged typeEnv t then RefTy t else t
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p] fixedMemberTy) (templateGetter (mangle memberName) fixedMemberTy)
,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p) (templateSetter typeEnv env (mangle memberName) t)
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName))
(FuncTy [p, (FuncTy [t] t)] p)
(FuncTy [p, FuncTy [t] t] p)
(templateUpdater (mangle memberName))]
-- | The template for the 'init' and 'new' functions for a deftype.
@ -172,7 +173,7 @@ templateInit allocationMode typeName members =
templateStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Template
templateStr typeEnv env typeName members =
Template
(FuncTy [(RefTy (StructTy typeName []))] StringTy)
(FuncTy [RefTy (StructTy typeName [])] StringTy)
(const (toTemplate $ "string $NAME(" ++ typeName ++ " *p)"))
(const (toTemplate $ unlines [ "$DECL {"
, " // convert members to string here:"
@ -187,8 +188,8 @@ templateStr typeEnv env typeName members =
, " snprintf(bufferPtr, 1024, \")\");"
, " return buffer;"
, "}"]))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env "str" . (typesStrFunctionType typeEnv))
(filter (not . (isExternalType typeEnv)) (map snd members)))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env "str" . typesStrFunctionType typeEnv)
(filter (not . isExternalType typeEnv) (map snd members)))
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
memberStr :: TypeEnv -> Env -> (String, Ty) -> String
@ -202,10 +203,10 @@ memberStr typeEnv env (memberName, memberTy) =
]
else let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
maybeTakeAddress = if isManaged typeEnv memberTy then "&" else ""
strFuncType = (FuncTy [refOrNotRefType] StringTy)
strFuncType = FuncTy [refOrNotRefType] StringTy
in case nameOfPolymorphicFunction typeEnv env strFuncType "str" of
Just strFunctionPath ->
unlines [(" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");")
unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");"
, " snprintf(bufferPtr, 1024, \"%s \", temp);"
, " bufferPtr += strlen(temp) + 1;"
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
@ -254,7 +255,7 @@ templateSetter typeEnv env memberName memberTy =
," return p;"
,"}\n"])))
(\_ -> if isManaged typeEnv memberTy
then (depsOfPolymorphicFunction typeEnv env "delete" (typesDeleterFunctionType memberTy))
then depsOfPolymorphicFunction typeEnv env "delete" (typesDeleterFunctionType memberTy)
else [])
-- | The template for updater functions of a deftype
@ -262,7 +263,7 @@ templateSetter typeEnv env memberName memberTy =
templateUpdater :: String -> Template
templateUpdater member =
Template
(FuncTy [VarTy "p", (FuncTy [VarTy "t"] (VarTy "t"))] (VarTy "p"))
(FuncTy [VarTy "p", FuncTy [VarTy "t"] (VarTy "t")] (VarTy "p"))
(const (toTemplate "$p $NAME($p p, $(Fn [t] t) updater)"))
(const (toTemplate (unlines ["$DECL {"
," p." ++ member ++ " = updater(p." ++ member ++ ");"
@ -274,10 +275,10 @@ templateUpdater member =
templateDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
templateDelete typeEnv env members =
Template
(FuncTy [(VarTy "p")] UnitTy)
(const (toTemplate $ "void $NAME($p p)"))
(FuncTy [VarTy "p"] UnitTy)
(const (toTemplate "void $NAME($p p)"))
(const (toTemplate $ unlines [ "$DECL {"
, (joinWith "\n" (map (memberDeletion typeEnv env) members))
, joinWith "\n" (map (memberDeletion typeEnv env) members)
, "}"]))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (map snd members)))
@ -295,11 +296,11 @@ memberDeletion typeEnv env (memberName, memberType) =
templateCopy :: TypeEnv -> Env -> [(String, Ty)] -> Template
templateCopy typeEnv env members =
Template
(FuncTy [(RefTy (VarTy "p"))] (VarTy "p"))
(const (toTemplate $ "$p $NAME($p* pRef)"))
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
(const (toTemplate "$p $NAME($p* pRef)"))
(const (toTemplate $ unlines [ "$DECL {"
, " $p copy = *pRef;"
, (joinWith "\n" (map (memberCopy typeEnv env) members))
, joinWith "\n" (map (memberCopy typeEnv env) members)
, " return copy;"
, "}"]))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env "copy" . typesCopyFunctionType)

72
src/Emit.hs
View File

@ -54,14 +54,14 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
case obj xobj of
Lst _ -> visitList indent xobj
Arr _ -> visitArray indent xobj
Num IntTy num -> return (show ((round num) :: Int))
Num LongTy num -> return (show ((round num) :: Int) ++ "l")
Num IntTy num -> return (show (round num :: Int))
Num LongTy num -> return (show (round num :: Int) ++ "l")
Num FloatTy num -> return (show num ++ "f")
Num DoubleTy num -> return (show num)
Num _ _ -> error "Can't emit invalid number type."
Bol b -> return (if b then "true" else "false")
Str _ -> visitString indent xobj
Chr c -> return ('\'' : c : '\'' : [])
Chr c -> return ['\'', c, '\'']
Sym _ -> visitSymbol xobj
Defn -> error (show (DontVisitObj Defn))
Def -> error (show (DontVisitObj Def))
@ -92,7 +92,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
-- | This will use the statically allocated string in the C binary (can't be freed):
do let var = freshVar i
varRef = freshVar i ++ "_ref";
appendToSrc (addIndent indent ++ "string " ++ var ++ " = \"" ++ (escapeString str) ++ "\";\n")
appendToSrc (addIndent indent ++ "string " ++ var ++ " = \"" ++ escapeString str ++ "\";\n")
appendToSrc (addIndent indent ++ "string *" ++ varRef ++ " = &" ++ var ++ ";\n")
return varRef
visitString _ _ = error "Not a string."
@ -112,7 +112,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
visitList indent (XObj (Lst xobjs) (Just i) t) =
case xobjs of
-- Defn
XObj Defn _ _ : XObj (Sym path) _ _ : XObj (Arr argList) _ _ : body : [] ->
[XObj Defn _ _, XObj (Sym path) _ _, XObj (Arr argList) _ _, body] ->
do let innerIndent = indent + indentAmount
Just (FuncTy _ retTy) = t
defnDecl = defnToDeclaration path argList retTy
@ -125,14 +125,14 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return ""
-- Def
XObj Def _ _ : XObj (Sym path) _ _ : expr : [] ->
[XObj Def _ _, XObj (Sym path) _ _, expr] ->
do ret <- visit 0 expr
let Just t' = t
appendToSrc ("" ++ tyToC t' ++ " " ++ pathToC path ++ " = " ++ ret ++ ";\n")
return ""
-- Let
(XObj Let _ _) : (XObj (Arr bindings) _ _) : body : [] ->
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
let indent' = indent + indentAmount
in do let Just bodyTy = ty body
isNotVoid = bodyTy /= UnitTy
@ -146,7 +146,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
when (bindingTy /= UnitTy) $
appendToSrc (addIndent indent' ++ tyToC bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
letBindingToC _ _ = error "Invalid binding."
_ <- mapM (\(sym, expr) -> letBindingToC sym expr) (pairwise bindings)
_ <- mapM (uncurry letBindingToC) (pairwise bindings)
ret <- visit indent' body
when isNotVoid $
appendToSrc (addIndent indent' ++ letBodyRet ++ " = " ++ ret ++ ";\n")
@ -155,7 +155,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return letBodyRet
-- If
XObj If _ _ : expr : ifTrue : ifFalse : [] ->
[XObj If _ _, expr, ifTrue, ifFalse] ->
let indent' = indent + indentAmount
in do let isNotVoid = ty ifTrue /= Just UnitTy
ifRetVar = freshVar i
@ -179,7 +179,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return ifRetVar
-- While
XObj While _ _ : expr : body : [] ->
[XObj While _ _, expr, body] ->
let indent' = indent + indentAmount
Just exprTy = ty expr
conditionVar = freshVar i
@ -216,12 +216,12 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return retVar
-- Address
XObj Address _ _ : value : [] ->
[XObj Address _ _, value] ->
do valueVar <- visit indent value
return ("&" ++ valueVar)
-- Set!
XObj SetBang _ _ : variable : value : [] ->
[XObj SetBang _ _, variable, value] ->
do valueVar <- visit indent value
let properVariableName =
case variable of
@ -233,7 +233,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return ""
-- The
XObj The _ _ : _ : value : [] ->
[XObj The _ _, _, value] ->
do var <- visit indent value
let Just t' = t
fresh = mangle (freshVar i)
@ -241,7 +241,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return fresh
-- Ref
XObj Ref _ _ : value : [] ->
[XObj Ref _ _, value] ->
do var <- visit indent value
let Just t' = t
fresh = mangle (freshVar i)
@ -253,28 +253,28 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
return ""
-- Template
(XObj (Deftemplate _) _ _) : (XObj (Sym _) _ _) : [] ->
[XObj (Deftemplate _) _ _, XObj (Sym _) _ _] ->
return ""
(XObj (Instantiate template) _ _) : (XObj (Sym path) _ _) : [] ->
[XObj (Instantiate template) _ _, XObj (Sym path) _ _] ->
do let Just t' = t
appendToSrc (templateToC template path t')
return ""
-- Alias
(XObj (Defalias _) _ _) : _ ->
XObj (Defalias _) _ _ : _ ->
return ""
-- External
(XObj External _ _) : _ ->
XObj External _ _ : _ ->
return ""
-- Macro
(XObj Macro _ _) : _ ->
XObj Macro _ _ : _ ->
return ""
-- Dynamic
(XObj Dynamic _ _) : _ ->
XObj Dynamic _ _ : _ ->
return ""
-- Function application
@ -323,8 +323,8 @@ delete indent i = mapM_ deleterToC (infoDelete i)
where deleterToC :: Deleter -> State EmitterState ()
deleterToC FakeDeleter {} =
return ()
deleterToC deleter@(ProperDeleter {}) =
appendToSrc $ (addIndent indent) ++ "" ++ pathToC (deleterPath deleter) ++ "(" ++ mangle (deleterVariable deleter) ++ ");\n"
deleterToC deleter@ProperDeleter{} =
appendToSrc $ addIndent indent ++ "" ++ pathToC (deleterPath deleter) ++ "(" ++ mangle (deleterVariable deleter) ++ ");\n"
defnToDeclaration :: SymPath -> [XObj] -> Ty -> String
defnToDeclaration path@(SymPath _ name) argList retTy =
@ -337,8 +337,8 @@ defnToDeclaration path@(SymPath _ name) argList retTy =
templateToC :: Template -> SymPath -> Ty -> String
templateToC template path actualTy =
let mappings = unifySignatures (templateSignature template) actualTy
declaration = (templateDeclaration template) actualTy
definition = (templateDefinition template) actualTy
declaration = templateDeclaration template actualTy
definition = templateDefinition template actualTy
tokens = concatMap (concretizeTypesInToken mappings (pathToC path) declaration) definition
in concatMap show tokens ++ "\n"
@ -346,7 +346,7 @@ templateToDeclaration :: Template -> SymPath -> Ty -> String
templateToDeclaration template path actualTy =
let mappings = unifySignatures (templateSignature template) actualTy
e = error "Can't refer to declaration in declaration."
declaration = (templateDeclaration template) actualTy
declaration = templateDeclaration template actualTy
tokens = concatMap (concretizeTypesInToken mappings (pathToC path) e) declaration
in concatMap show tokens ++ ";\n"
@ -383,28 +383,28 @@ defaliasToDeclaration t path =
toDeclaration :: XObj -> String
toDeclaration xobj@(XObj (Lst xobjs) _ t) =
case xobjs of
(XObj Defn _ _) : (XObj (Sym path) _ _) : (XObj (Arr argList) _ _) : _ : [] ->
[XObj Defn _ _, XObj (Sym path) _ _, XObj (Arr argList) _ _, _] ->
let (Just (FuncTy _ retTy)) = t
in defnToDeclaration path argList retTy ++ ";\n"
(XObj Def _ _) : (XObj (Sym path) _ _) : _ : [] ->
[XObj Def _ _, XObj (Sym path) _ _, _] ->
let Just t' = t
in "" ++ tyToC t' ++ " " ++ pathToC path ++ ";\n"
(XObj Typ _ _) : (XObj (Sym path) _ _) : rest ->
XObj Typ _ _ : XObj (Sym path) _ _ : rest ->
deftypeToDeclaration path rest
(XObj (Deftemplate _) _ _) : _ ->
XObj (Deftemplate _) _ _ : _ ->
""
(XObj Macro _ _) : _ ->
XObj Macro _ _ : _ ->
""
(XObj Dynamic _ _) : _ ->
XObj Dynamic _ _ : _ ->
""
(XObj (Instantiate template) _ _) : (XObj (Sym path) _ _) : [] ->
[XObj (Instantiate template) _ _, XObj (Sym path) _ _] ->
let Just t' = t
in templateToDeclaration template path t'
(XObj (Defalias aliasTy) _ _) : (XObj (Sym path) _ _) : [] ->
[XObj (Defalias aliasTy) _ _, XObj (Sym path) _ _] ->
defaliasToDeclaration aliasTy path
(XObj External _ _) : _ ->
XObj External _ _ : _ ->
""
(XObj ExternalType _ _) : _ ->
XObj ExternalType _ _ : _ ->
""
_ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj)
toDeclaration _ = error "Missing case."
@ -466,7 +466,7 @@ sortDeclarationBinders typeEnv binders =
sortOn fst (map (scoreBinder typeEnv) binders)
checkForUnresolvedSymbols :: XObj -> Either ToCError ()
checkForUnresolvedSymbols root = visit root
checkForUnresolvedSymbols = visit
where
visit :: XObj -> Either ToCError ()
visit xobj =

44
src/Eval.hs
View File

@ -31,12 +31,12 @@ eval env xobj =
evalList (XObj (Lst xobjs) i t) =
case xobjs of
[] -> Right xobj
XObj (Sym (SymPath [] "quote")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "quote")) _ _, target] ->
return target
XObj (Sym (SymPath [] "list")) _ _ : rest ->
do evaledList <- mapM (eval env) rest
return (XObj (Lst evaledList) i t)
XObj (Sym (SymPath [] "list?")) _ _ : x : [] ->
[XObj (Sym (SymPath [] "list?")) _ _, x] ->
do evaled <- eval env x
case evaled of
XObj (Lst _) _ _ -> Right trueXObj
@ -44,80 +44,80 @@ eval env xobj =
XObj (Sym (SymPath [] "array")) _ _ : rest ->
do evaledArray <- mapM (eval env) rest
return (XObj (Arr evaledArray) i t)
XObj (Sym (SymPath [] "=")) _ _ : a : b : [] ->
[XObj (Sym (SymPath [] "=")) _ _, a, b] ->
do evaledA <- eval env a
evaledB <- eval env b
case (evaledA, evaledB) of
(XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) ->
if ((round aNum) :: Int) == ((round bNum) :: Int)
if (round aNum :: Int) == (round bNum :: Int)
then Right trueXObj else Right falseXObj
_ ->
--Right falseXObj
Left (EvalError ("Can't compare " ++ pretty evaledA ++ " with " ++ pretty evaledB))
XObj (Sym (SymPath [] "count")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "count")) _ _, target] ->
do evaled <- eval env target
case evaled of
XObj (Lst lst) _ _ -> return (XObj (Num IntTy (fromIntegral (length lst))) Nothing Nothing)
XObj (Arr arr) _ _ -> return (XObj (Num IntTy (fromIntegral (length arr))) Nothing Nothing)
_ -> Left (EvalError ("Applying 'count' to non-list: " ++ pretty evaled))
XObj (Sym (SymPath [] "car")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "car")) _ _, target] ->
do evaled <- eval env target
case evaled of
XObj (Lst (car : _)) _ _ -> return car
XObj (Arr (car : _)) _ _ -> return car
_ -> Left (EvalError ("Applying 'car' to non-list: " ++ pretty evaled))
XObj (Sym (SymPath [] "cdr")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "cdr")) _ _, target] ->
do evaled <- eval env target
case evaled of
XObj (Lst (_ : cdr)) _ _ -> return (XObj (Lst cdr) Nothing Nothing)
XObj (Arr (_ : cdr)) _ _ -> return (XObj (Arr cdr) Nothing Nothing)
_ -> Left (EvalError "Applying 'cdr' to non-list or empty list")
XObj (Sym (SymPath [] "last")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "last")) _ _, target] ->
do evaled <- eval env target
case evaled of
XObj (Lst lst) _ _ -> return (last lst)
XObj (Arr arr) _ _ -> return (last arr)
_ -> Left (EvalError "Applying 'last' to non-list or empty list")
XObj (Sym (SymPath [] "init")) _ _ : target : [] ->
[XObj (Sym (SymPath [] "init")) _ _, target] ->
do evaled <- eval env target
case evaled of
XObj (Lst lst) _ _ -> return (XObj (Lst (init lst)) Nothing Nothing)
XObj (Arr arr) _ _ -> return (XObj (Arr (init arr)) Nothing Nothing)
_ -> Left (EvalError "Applying 'init' to non-list or empty list")
XObj (Sym (SymPath [] "cons")) _ _ : x : xs : [] ->
[XObj (Sym (SymPath [] "cons")) _ _, x, xs] ->
do evaledX <- eval env x
evaledXS <- eval env xs
case evaledXS of
XObj (Lst lst) _ _ -> return (XObj (Lst (evaledX : lst)) i t) -- TODO: probably not correct to just copy 'i' and 't'?
_ -> Left (EvalError "Applying 'cons' to non-list or empty list")
XObj (Sym (SymPath [] "cons-last")) _ _ : x : xs : [] ->
[XObj (Sym (SymPath [] "cons-last")) _ _, x, xs] ->
do evaledX <- eval env x
evaledXS <- eval env xs
case evaledXS of
XObj (Lst lst) _ _ -> return (XObj (Lst (lst ++ [evaledX])) i t) -- TODO: should they get their own i:s and t:s
_ -> Left (EvalError "Applying 'cons-last' to non-list or empty list")
XObj (Sym (SymPath [] "append")) _ _ : xs : ys : [] ->
[XObj (Sym (SymPath [] "append")) _ _, xs, ys] ->
do evaledXS <- eval env xs
evaledYS <- eval env ys
case (evaledXS, evaledYS) of
(XObj (Lst lst1) _ _, XObj (Lst lst2) _ _) ->
return (XObj (Lst (lst1 ++ lst2)) i t) -- TODO: should they get their own i:s and t:s
_ -> Left (EvalError "Applying 'append' to non-list or empty list")
XObj If _ _ : condition : ifTrue : ifFalse : [] ->
[XObj If _ _, condition, ifTrue, ifFalse] ->
do evaledCondition <- eval env condition
case obj evaledCondition of
Bol b -> if b then eval env ifTrue else eval env ifFalse
_ -> Left (EvalError ("Non-boolean expression in if-statement: " ++ pretty evaledCondition))
defnExpr@(XObj Defn _ _) : name : args : body : [] ->
[defnExpr@(XObj Defn _ _), name, args, body] ->
do evaledBody <- eval env body
Right (XObj (Lst [defnExpr, name, args, evaledBody]) i t)
defExpr@(XObj Def _ _) : name : expr : [] ->
[defExpr@(XObj Def _ _), name, expr] ->
do evaledExpr <- expand env expr
Right (XObj (Lst [defExpr, name, evaledExpr]) i t)
theExpr@(XObj The _ _) : typeXObj : value : [] ->
[theExpr@(XObj The _ _), typeXObj, value] ->
do evaledValue <- expand env value
Right (XObj (Lst [theExpr, typeXObj, evaledValue]) i t)
letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] ->
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings)
then do bind <- mapM (\(n, x) -> do x' <- eval env x
return [n, x'])
@ -250,16 +250,16 @@ expand env xobj =
XObj (Instantiate _) _ _ : _ -> Right xobj
XObj (Deftemplate _) _ _ : _ -> Right xobj
XObj (Defalias _) _ _ : _ -> Right xobj
defnExpr@(XObj Defn _ _) : name : args : body : [] ->
[defnExpr@(XObj Defn _ _), name, args, body] ->
do expandedBody <- expand env body
Right (XObj (Lst [defnExpr, name, args, expandedBody]) i t)
defExpr@(XObj Def _ _) : name : expr : [] ->
[defExpr@(XObj Def _ _), name, expr] ->
do expandedExpr <- expand env expr
Right (XObj (Lst [defExpr, name, expandedExpr]) i t)
theExpr@(XObj The _ _) : typeXObj : value : [] ->
[theExpr@(XObj The _ _), typeXObj, value] ->
do expandedValue <- expand env value
Right (XObj (Lst [theExpr, typeXObj, expandedValue]) i t)
letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] ->
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings)
then do bind <- mapM (\(n, x) -> do x' <- expand env x
return [n, x'])
@ -271,7 +271,7 @@ expand env xobj =
doExpr@(XObj Do _ _) : expressions ->
do expandedExpressions <- mapM (expand env) expressions
Right (XObj (Lst (doExpr : expandedExpressions)) i t)
(XObj (Mod _) _ _) : _ ->
XObj Mod{} _ _ : _ ->
Left (EvalError "Can't eval module")
f:args -> do expandedF <- expand env f
expandedArgs <- mapM (expand env) args

30
src/GenerateConstraints.hs
View File

@ -1,22 +1,24 @@
module GenerateConstraints (genConstraints) where
import Data.List (foldl', sort)
import Control.Arrow
import Control.Monad.State
import Data.Maybe (mapMaybe)
import Types
import Obj
import Constraints
import Util
import TypeError
import Data.List (foldl', sort)
import Control.Monad.State
import Data.Maybe (mapMaybe)
-- | Will create a list of type constraints for a form.
genConstraints :: XObj -> Either TypeError [Constraint]
genConstraints root = fmap sort (gen root)
where gen xobj =
case obj xobj of
(Lst lst) -> case lst of
Lst lst -> case lst of
-- Defn
(XObj Defn _ _) : _ : (XObj (Arr args) _ _) : body : [] ->
[XObj Defn _ _, _, XObj (Arr args) _ _, body] ->
do insideBodyConstraints <- gen body
xobjType <- toEither (ty xobj) (DefnMissingType xobj)
bodyType <- toEither (ty body) (ExpressionMissingType xobj)
@ -26,7 +28,7 @@ genConstraints root = fmap sort (gen root)
return (bodyConstr : argConstrs ++ insideBodyConstraints)
-- Def
(XObj Def _ _) : _ : expr : [] ->
[XObj Def _ _, _, expr] ->
do insideExprConstraints <- gen expr
xobjType <- toEither (ty xobj) (DefMissingType xobj)
exprType <- toEither (ty expr) (ExpressionMissingType xobj)
@ -34,7 +36,7 @@ genConstraints root = fmap sort (gen root)
return (defConstraint : insideExprConstraints)
-- Let
XObj Let _ _ : XObj (Arr bindings) _ _ : body : [] ->
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
do insideBodyConstraints <- gen body
insideBindingsConstraints <- fmap join (mapM gen bindings)
bodyType <- toEither (ty body) (ExpressionMissingType body)
@ -42,13 +44,13 @@ genConstraints root = fmap sort (gen root)
wholeStatementConstraint = Constraint bodyType xobjTy body xobj OrdLetBody
bindingsConstraints = zipWith (\(symTy, exprTy) (symObj, exprObj) ->
Constraint symTy exprTy symObj exprObj OrdLetBind)
(map (\(a, b) -> (forceTy a, forceTy b)) (pairwise bindings))
(map (forceTy *** forceTy) (pairwise bindings))
(pairwise bindings)
return (wholeStatementConstraint : insideBodyConstraints ++
bindingsConstraints ++ insideBindingsConstraints)
-- If
XObj If _ _ : expr : ifTrue : ifFalse : [] ->
[XObj If _ _, expr, ifTrue, ifFalse] ->
do insideConditionConstraints <- gen expr
insideTrueConstraints <- gen ifTrue
insideFalseConstraints <- gen ifFalse
@ -65,7 +67,7 @@ genConstraints root = fmap sort (gen root)
insideTrueConstraints ++ insideFalseConstraints)
-- While
XObj While _ _ : expr : body : [] ->
[XObj While _ _, expr, body] ->
do insideConditionConstraints <- gen expr
insideBodyConstraints <- gen body
exprType <- toEither (ty expr) (ExpressionMissingType expr)
@ -93,11 +95,11 @@ genConstraints root = fmap sort (gen root)
return (retConstraint : insideExpressionsConstraints ++ expressionsShouldReturnUnit)
-- Address
XObj Address _ _ : value : [] ->
[XObj Address _ _, value] ->
gen value
-- Set!
XObj SetBang _ _ : variable : value : [] ->
[XObj SetBang _ _, variable, value] ->
do insideValueConstraints <- gen value
variableType <- toEither (ty variable) (ExpressionMissingType variable)
valueType <- toEither (ty value) (ExpressionMissingType value)
@ -105,7 +107,7 @@ genConstraints root = fmap sort (gen root)
return (sameTypeConstraint : insideValueConstraints)
-- The
XObj The _ _ : _ : value : [] ->
[XObj The _ _, _, value] ->
do insideValueConstraints <- gen value
xobjType <- toEither (ty xobj) (DefMissingType xobj)
valueType <- toEither (ty value) (DefMissingType value)
@ -113,7 +115,7 @@ genConstraints root = fmap sort (gen root)
return (theTheConstraint : insideValueConstraints)
-- Ref
XObj Ref _ _ : value : [] ->
[XObj Ref _ _, value] ->
gen value
-- Function application

32
src/InitialTypes.hs
View File

@ -124,7 +124,7 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
visitList env xobj@(XObj (Lst xobjs) i _) =
case xobjs of
-- Defn
defn@(XObj Defn _ _) : nameSymbol@(XObj (Sym (SymPath _ name)) _ _) : (XObj (Arr argList) argsi argst) : body : [] ->
[defn@(XObj Defn _ _), nameSymbol@(XObj (Sym (SymPath _ name)) _ _), XObj (Arr argList) argsi argst, body] ->
do argTypes <- genVarTys (length argList)
returnType <- genVarTy
funcScopeEnv <- extendEnvWithParamList env argList
@ -138,20 +138,20 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
okArgs <- sequence visitedArgs
return (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
XObj Defn _ _ : (XObj (Sym _) _ _) : (XObj (Arr _) _ _) : [] -> return (Left (NoFormsInBody xobj))
[XObj Defn _ _, XObj (Sym _) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj))
XObj Defn _ _ : _ -> return (Left (InvalidObj Defn xobj))
-- Def
def@(XObj Def _ _) : nameSymbol : expression : [] ->
[def@(XObj Def _ _), nameSymbol, expression]->
do definitionType <- genVarTy
visitedExpr <- visit env expression
return $ do okExpr <- visitedExpr
return (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType))
(XObj Def _ _) : _ -> return (Left (InvalidObj Def xobj))
XObj Def _ _ : _ -> return (Left (InvalidObj Def xobj))
-- Let binding
letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] ->
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
do wholeExprType <- genVarTy
letScopeEnv <- extendEnvWithLetBindings env bindings
case letScopeEnv of
@ -163,7 +163,7 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
return (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) i (Just wholeExprType))
Left err -> return (Left err)
XObj Let _ _ : XObj (Arr _) _ _ : [] ->
[XObj Let _ _, XObj (Arr _) _ _] ->
return (Left (NoFormsInBody xobj))
XObj Let _ _ : XObj (Arr _) _ _ : _ ->
return (Left (TooManyFormsInBody xobj))
@ -171,7 +171,7 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
return (Left (InvalidObj Let xobj))
-- If
ifExpr@(XObj If _ _) : expr : ifTrue : ifFalse : [] ->
[ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
do visitedExpr <- visit env expr
visitedTrue <- visit env ifTrue
visitedFalse <- visit env ifFalse
@ -184,14 +184,14 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
XObj If _ _ : _ -> return (Left (InvalidObj If xobj))
-- While (always return Unit)
whileExpr@(XObj While _ _) : expr : body : [] ->
[whileExpr@(XObj While _ _), expr, body] ->
do visitedExpr <- visit env expr
visitedBody <- visit env body
return $ do okExpr <- visitedExpr
okBody <- visitedBody
return (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy))
XObj While _ _ : _ : [] ->
[XObj While _ _, _] ->
return (Left (NoFormsInBody xobj))
XObj While _ _ : _ ->
return (Left (TooManyFormsInBody xobj))
@ -204,36 +204,36 @@ initialTypes rootEnv root = evalState (visit rootEnv root) 0
return (XObj (Lst (doExpr : okExpressions)) i (Just t))
-- Address
addressExpr@(XObj Address _ _) : value : [] ->
[addressExpr@(XObj Address _ _), value] ->
do visitedValue <- visit env value
return $ do okValue <- visitedValue
let Just t' = ty okValue
return (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t')))
-- Set!
setExpr@(XObj SetBang _ _) : variable : value : [] ->
[setExpr@(XObj SetBang _ _), variable, value] ->
do visitedVariable <- visit env variable
visitedValue <- visit env value
return $ do okVariable <- visitedVariable
okValue <- visitedValue
return (XObj (Lst (setExpr : okVariable : okValue : [])) i (Just UnitTy))
return (XObj (Lst [setExpr, okVariable, okValue]) i (Just UnitTy))
XObj SetBang _ _ : _ -> return (Left (InvalidObj SetBang xobj))
-- The
theExpr@(XObj The _ _) : typeXObj : value : [] ->
[theExpr@(XObj The _ _), typeXObj, value] ->
do visitedValue <- visit env value
return $ do okValue <- visitedValue
case xobjToTy typeXObj of
Just okType -> return (XObj (Lst [theExpr, typeXObj, okValue]) i (Just okType))
Nothing -> error ("Not a type: " ++ show typeXObj)
(XObj The _ _) : _ -> return (Left (InvalidObj The xobj))
XObj The _ _ : _ -> return (Left (InvalidObj The xobj))
-- Ref
refExpr@(XObj Ref _ _) : value : [] ->
[refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit env value
return $ do okValue <- visitedValue
let Just valueTy = ty okValue
return (XObj (Lst (refExpr : okValue : [])) i (Just (RefTy valueTy)))
return (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy)))
-- Function application
func : args ->

52
src/ManageMemory.hs
View File

@ -17,7 +17,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 { info = setDeletersOnInfo (info xobj) deleters }
-- | To keep track of the deleters when recursively walking the form.
type MemState = Set.Set Deleter
@ -41,7 +41,7 @@ manageMemory typeEnv globalEnv root =
Arr _ -> visitArray xobj
Str _ -> do manage xobj
return (Right xobj)
_ -> do return (Right xobj)
_ -> return (Right xobj)
visitArray :: XObj -> State MemState (Either TypeError XObj)
visitArray xobj@(XObj (Arr arr) _ _) =
@ -58,7 +58,7 @@ manageMemory typeEnv globalEnv root =
visitList :: XObj -> State MemState (Either TypeError XObj)
visitList xobj@(XObj (Lst lst) i t) =
case lst of
defn@(XObj Defn _ _) : nameSymbol@(XObj (Sym _) _ _) : args@(XObj (Arr argList) _ _) : body : [] ->
[defn@(XObj Defn _ _), nameSymbol@(XObj (Sym _) _ _), args@(XObj (Arr argList) _ _), body] ->
let Just funcTy@(FuncTy _ defnReturnType) = t
in case defnReturnType of
RefTy _ ->
@ -72,8 +72,8 @@ manageMemory typeEnv globalEnv root =
Left e -> Left e
Right _ ->
do okBody <- visitedBody
return (XObj (Lst (defn : nameSymbol : args : okBody : [])) i t)
letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] ->
return (XObj (Lst [defn, nameSymbol, args, okBody]) i t)
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
let Just letReturnType = t
in case letReturnType of
RefTy _ ->
@ -89,14 +89,14 @@ manageMemory typeEnv globalEnv root =
do postDeleters <- get
let diff = postDeleters Set.\\ preDeleters
newInfo = setDeletersOnInfo i diff
survivors = (postDeleters Set.\\ diff) -- Same as just pre deleters, right?!
survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?!
put survivors
--trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors)
manage xobj
return $ do okBody <- visitedBody
okBindings <- fmap (concatMap (\(n,x) -> [n, x])) (sequence visitedBindings)
return (XObj (Lst (letExpr : (XObj (Arr okBindings) bindi bindt) : okBody : [])) newInfo t)
setbangExpr@(XObj SetBang _ _) : variable : value : [] ->
return (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) newInfo t)
[setbangExpr@(XObj SetBang _ _), variable, value] ->
do visitedValue <- visit value
unmanage value
let varInfo = info variable
@ -109,19 +109,19 @@ manageMemory typeEnv globalEnv root =
newVarInfo = setDeletersOnInfo varInfo deleters
newVariable = variable { info = newVarInfo }
return $ do okValue <- visitedValue
return (XObj (Lst (setbangExpr : newVariable : okValue : [])) i t)
addressExpr@(XObj Address _ _) : value : [] ->
return (XObj (Lst [setbangExpr, newVariable, okValue]) i t)
[addressExpr@(XObj Address _ _), value] ->
do visitedValue <- visit value
return $ do okValue <- visitedValue
return (XObj (Lst (addressExpr : okValue : [])) i t)
theExpr@(XObj The _ _) : typeXObj : value : [] ->
return (XObj (Lst [addressExpr, okValue]) i t)
[theExpr@(XObj The _ _), typeXObj, value] ->
do visitedValue <- visit value
result <- transferOwnership value xobj
return $ case result of
Left e -> Left e
Right _ -> do okValue <- visitedValue
return (XObj (Lst (theExpr : typeXObj : okValue : [])) i t)
refExpr@(XObj Ref _ _) : value : [] ->
return (XObj (Lst [theExpr, typeXObj, okValue]) i t)
[refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit value
case visitedValue of
Left e -> return (Left e)
@ -129,7 +129,7 @@ manageMemory typeEnv globalEnv root =
do checkResult <- refCheck visitedValue
case checkResult of
Left e -> return (Left e)
Right () -> return $ Right (XObj (Lst (refExpr : visitedValue : [])) i t)
Right () -> return $ Right (XObj (Lst [refExpr, visitedValue]) i t)
doExpr@(XObj Do _ _) : expressions ->
do visitedExpressions <- mapM visit expressions
result <- transferOwnership (last expressions) xobj
@ -137,7 +137,7 @@ manageMemory typeEnv globalEnv root =
Left e -> Left e
Right _ -> do okExpressions <- sequence visitedExpressions
return (XObj (Lst (doExpr : okExpressions)) i t)
whileExpr@(XObj While _ _) : expr : body : [] ->
[whileExpr@(XObj While _ _), expr, body] ->
do preDeleters <- get
visitedExpr <- visit expr
visitedBody <- visit body
@ -153,9 +153,9 @@ manageMemory typeEnv globalEnv root =
okExpr2 <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
okBody2 <- visitedBody2 -- And this one too. Laziness FTW.
let newInfo = setDeletersOnInfo i diff
return (XObj (Lst (whileExpr : okExpr : okBody : [])) newInfo t)
return (XObj (Lst [whileExpr, okExpr, okBody]) newInfo t)
ifExpr@(XObj If _ _) : expr : ifTrue : ifFalse : [] ->
[ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
do visitedExpr <- visit expr
deleters <- get
@ -182,7 +182,7 @@ manageMemory typeEnv globalEnv root =
common = Set.intersection deletedInTrue deletedInFalse
delsTrue = deletedInFalse Set.\\ common
delsFalse = deletedInTrue Set.\\ common
stillAlive = deleters Set.\\ (Set.union deletedInTrue deletedInFalse)
stillAlive = deleters Set.\\ Set.union deletedInTrue deletedInFalse
put stillAlive
manage xobj
@ -190,14 +190,14 @@ manageMemory typeEnv globalEnv root =
return $ do okExpr <- visitedExpr
okTrue <- visitedTrue
okFalse <- visitedFalse
return (XObj (Lst (ifExpr : okExpr : (del okTrue delsTrue) : (del okFalse delsFalse) : [])) i t)
return (XObj (Lst [ifExpr, okExpr, del okTrue delsTrue, del okFalse delsFalse]) i t)
f : args ->
do visitedF <- visit f
visitedArgs <- fmap sequence $ mapM visitArg args
visitedArgs <- sequence <$> mapM visitArg args
manage xobj
return $ do okF <- visitedF
okArgs <- visitedArgs
(Right (XObj (Lst (okF : okArgs)) i t))
Right (XObj (Lst (okF : okArgs)) i t)
[] -> return (Right xobj)
visitList _ = error "Must visit list."
@ -218,11 +218,9 @@ manageMemory typeEnv globalEnv root =
result <- unmanage xobj
case result of
Left e -> return (Left e)
Right _ -> return $ do okXObj <- visitedXObj
return okXObj
else do --(trace ("Ignoring arg " ++ show xobj ++ " because it's not managed."))
(visit xobj)
visitArg xobj@(XObj _ _ _) =
Right _ -> return visitedXObj
else visit xobj
visitArg xobj@XObj{} =
visit xobj
createDeleter :: XObj -> Maybe Deleter

75
src/Obj.hs
View File

@ -59,7 +59,7 @@ data Info = Info { infoLine :: Int
} deriving (Show, Eq)
dummyInfo :: Info
dummyInfo = Info 0 0 "dummy-file" (Set.empty) (-1)
dummyInfo = Info 0 0 "dummy-file" Set.empty (-1)
data Deleter = ProperDeleter { deleterPath :: SymPath
, deleterVariable :: String
@ -119,14 +119,14 @@ getPath x = SymPath [] (pretty x)
setPath :: XObj -> SymPath -> XObj
setPath (XObj (Lst (defn@(XObj Defn _ _) : XObj (Sym _) si st : rest)) i t) newPath =
XObj (Lst (defn : XObj (Sym newPath) si st : rest)) i t
setPath (XObj (Lst (extr@(XObj External _ _) : XObj (Sym _) si st : [])) i t) newPath =
XObj (Lst (extr : XObj (Sym newPath) si st : [])) i t
setPath (XObj (Lst [extr@(XObj External _ _), XObj (Sym _) si st]) i t) newPath =
XObj (Lst [extr, XObj (Sym newPath) si st]) i t
setPath x _ =
compilerError ("Can't set path on " ++ show x)
-- | Convert an XObj to a pretty string representation.
pretty :: XObj -> String
pretty root = visit 0 root
pretty = visit 0
where visit :: Int -> XObj -> String
visit indent xobj =
case obj xobj of
@ -221,19 +221,19 @@ dependencyDepthOfTypedef typeEnv (XObj (Lst (_ : XObj (Sym (SymPath _ selfName))
xs -> maximum xs
where
expandCase :: XObj -> [Int]
expandCase (XObj (Arr arr) _ _) = map ((depthOfType typeEnv selfName) . xobjToTy . snd) (pairwise arr)
expandCase (XObj (Arr arr) _ _) = map (depthOfType typeEnv selfName . xobjToTy . snd) (pairwise arr)
expandCase _ = compilerError "Malformed case in typedef."
dependencyDepthOfTypedef _ xobj =
compilerError ("Can't get dependency depth from " ++ show xobj)
depthOfType :: TypeEnv -> String -> Maybe Ty -> Int
depthOfType typeEnv selfName ty = visitType ty
depthOfType typeEnv selfName = visitType
where
visitType :: Maybe Ty -> Int
visitType (Just (StructTy name _)) = depthOfStructType name
visitType (Just (FuncTy argTys retTy)) =
-- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
(maximum (visitType (Just retTy) : (map (visitType . Just) argTys))) + 1
maximum (visitType (Just retTy) : map (visitType . Just) argTys) + 1
visitType (Just (PointerTy p)) = visitType (Just p)
visitType (Just (RefTy r)) = visitType (Just r)
visitType (Just _) = 0
@ -288,10 +288,10 @@ prettyEnvironment = prettyEnvironmentIndented 0
prettyEnvironmentIndented :: Int -> Env -> String
prettyEnvironmentIndented indent env =
joinWith "\n" $ map (showBinderIndented indent) (Map.toList (envBindings env)) ++
let modules = (envUseModules env)
let modules = envUseModules env
in if null modules
then []
else ["\n" ++ replicate indent ' ' ++ "Used modules:"] ++ map (showImportIndented indent) modules
else ("\n" ++ replicate indent ' ' ++ "Used modules:") : map (showImportIndented indent) modules
showImportIndented :: Int -> SymPath -> String
showImportIndented indent path = replicate indent ' ' ++ " * " ++ show path
@ -329,6 +329,7 @@ multiLookup = multiLookupInternal False
multiLookupALL :: String -> Env -> [(Env, Binder)]
multiLookupALL = multiLookupInternal True
{-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-}
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
@ -341,10 +342,10 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
imports :: Env -> [Env]
imports env = if allowLookupInAllModules
then let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ (concatMap imports envs)
in envs ++ concatMap imports envs
-- Only lookup in imported modules:
else let envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
in envs ++ (concatMap imports envs)
in envs ++ concatMap imports envs
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder (XObj (Mod e) _ _)) = Just e
@ -391,7 +392,7 @@ multiLookupQualified path@(SymPath (p:ps) name) rootEnv =
Nothing -> []
fromUsedModules = let usedModules = envUseModules rootEnv
envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path rootEnv)) usedModules
in concatMap (\usedEnv -> multiLookupQualified path usedEnv) envs
in concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules
@ -424,6 +425,7 @@ envReplaceEnvAt env (p:ps) replacement =
envAddBinding :: Env -> String -> Binder -> Env
envAddBinding env name binder = env { envBindings = Map.insert name binder (envBindings env) }
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
-- | Add a list of bindings to an environment
addListOfBindings :: Env -> [(String, Binder)] -> Env
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
@ -439,34 +441,34 @@ getEnv env (p:ps) = case Map.lookup p (envBindings env) of
-- | Changes the symbol part of a defn (the name) to a new symbol path
-- | Example: (defn foo () 123) => (defn GreatModule.foo () 123)
setFullyQualifiedDefn :: XObj -> SymPath -> XObj
setFullyQualifiedDefn (XObj (Lst (defn : (XObj _ symi symt) : args : body : [])) i t) newPath =
XObj (Lst (defn : (XObj (Sym newPath) symi symt) : args : body : [])) i t
setFullyQualifiedDefn (XObj (Lst (def : (XObj _ symi symt) : expr : [])) i t) newPath =
XObj (Lst (def : (XObj (Sym newPath) symi symt) : expr : [])) i t
setFullyQualifiedDefn (XObj (Lst [defn, XObj _ symi symt, args, body]) i t) newPath =
XObj (Lst [defn, XObj (Sym newPath) symi symt, args, body]) i t
setFullyQualifiedDefn (XObj (Lst [def, XObj _ symi symt, expr]) i t) newPath =
XObj (Lst [def, XObj (Sym newPath) symi symt, expr]) i t
setFullyQualifiedDefn xobj _ = error ("Can't set new path on " ++ show xobj)
-- | Changes all symbols EXCEPT bound vars (defn names, variable names, etc) to their fully qualified paths.
-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment.
-- | This function does NOT go into function-body scope environments and the like.
setFullyQualifiedSymbols :: Env -> XObj -> XObj
setFullyQualifiedSymbols env (XObj (Lst (defn@(XObj Defn _ _) :
sym@(XObj (Sym (SymPath _ functionName)) _ _) :
args@(XObj (Arr argsArr) _ _) :
body : []))
setFullyQualifiedSymbols env (XObj (Lst [defn@(XObj Defn _ _),
sym@(XObj (Sym (SymPath _ functionName)) _ _),
args@(XObj (Arr argsArr) _ _),
body])
i t) =
-- For self-recursion, there must be a binding to the function in the inner env.
-- Note: This inner env is ephemeral since it is not stored in a module or global scope.
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv
envWithSelf = extendEnv functionEnv functionName sym
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName)) _ _) -> extendEnv e argSymName arg) envWithSelf argsArr
in (XObj (Lst [defn, sym, args, setFullyQualifiedSymbols envWithArgs body]) i t)
setFullyQualifiedSymbols env (XObj (Lst (the@(XObj The _ _) : typeXObj : value : [])) i t) =
in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols envWithArgs body]) i t
setFullyQualifiedSymbols env (XObj (Lst [the@(XObj The _ _), typeXObj, value]) i t) =
let value' = setFullyQualifiedSymbols env value
in (XObj (Lst [the, typeXObj, value']) i t)
setFullyQualifiedSymbols env (XObj (Lst (def@(XObj Def _ _) : sym : expr : [])) i t) =
in XObj (Lst [the, typeXObj, value']) i t
setFullyQualifiedSymbols env (XObj (Lst [def@(XObj Def _ _), sym, expr]) i t) =
let expr' = setFullyQualifiedSymbols env expr
in (XObj (Lst [def, sym, expr']) i t)
setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Arr bindings) bindi bindt) : body : [])) i t) =
in XObj (Lst [def, sym, expr']) i t
setFullyQualifiedSymbols env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t) =
if even (length bindings)
then let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv
envWithBindings = foldl' (\e (binderSym@(XObj (Sym (SymPath _ binderName)) _ _), _) ->
@ -476,8 +478,8 @@ setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Ar
newBinders = XObj (Arr (concatMap (\(s, o) -> [s, setFullyQualifiedSymbols envWithBindings o])
(pairwise bindings))) bindi bindt
newBody = setFullyQualifiedSymbols envWithBindings body
in (XObj (Lst [letExpr, newBinders, newBody]) i t)
else (XObj (Lst [letExpr, bind, body]) i t) -- Leave it untouched for the compiler to find the error.
in XObj (Lst [letExpr, newBinders, newBody]) i t
else XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
setFullyQualifiedSymbols env (XObj (Lst xobjs) i t) =
let xobjs' = map (setFullyQualifiedSymbols env) xobjs
in XObj (Lst xobjs') i t
@ -553,7 +555,7 @@ xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr")) _ _, innerTy]) _ _) =
do okInnerTy <- xobjToTy innerTy
return (PointerTy okInnerTy)
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ptr")) _ _ : _)) _ _) =
do Nothing
Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref")) _ _, innerTy]) _ _) =
do okInnerTy <- xobjToTy innerTy
return (RefTy okInnerTy)
@ -561,7 +563,7 @@ xobjToTy (XObj (Lst [XObj Ref i t, innerTy]) _ _) = -- This enables parsing of '
do okInnerTy <- xobjToTy innerTy
return (RefTy okInnerTy)
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ref")) _ _ : _)) _ _) =
do Nothing
Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath path "λ")) fi ft, XObj (Arr argTys) ai at, retTy]) i t) =
xobjToTy (XObj (Lst [XObj (Sym (SymPath path "Fn")) fi ft, XObj (Arr argTys) ai at, retTy]) i t)
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn")) _ _, XObj (Arr argTys) _ _, retTy]) _ _) =
@ -622,7 +624,7 @@ instance Show Template where
-- | Note: This is to make comparisons of Environments possible, otherwise
-- | they are always different when they contain Templates.
instance Eq Template where
a == b = (templateSignature a) == (templateSignature b)
a == b = templateSignature a == templateSignature b
-- | Tokens are used for emitting C code from templates.
data Token = TokTy Ty -- | Some kind of type, will be looked up if it's a type variable.
@ -671,19 +673,16 @@ isExternalType _ _ =
-- | Unsafe way of getting the type from an XObj
forceTy :: XObj -> Ty
forceTy xobj = case ty xobj of
Just t -> t
Nothing -> error ("No type in " ++ show xobj)
forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (ty xobj)
-- | Is this type managed - does it need to be freed?
isManaged :: TypeEnv -> Ty -> Bool
isManaged typeEnv (StructTy name _) =
if name == "Array"
then True
else case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
(name == "Array") || (
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder (XObj (Lst (XObj ExternalType _ _ : _)) _ _)) -> False
Just (_, Binder (XObj (Lst (XObj Typ _ _ : _)) _ _)) -> True
Just (_, Binder (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong)
Nothing -> error ("Can't find " ++ name ++ " in type env.")
Nothing -> error ("Can't find " ++ name ++ " in type env."))
isManaged _ StringTy = True
isManaged _ _ = False

45
src/Parsing.hs
View File

@ -19,12 +19,16 @@ createInfo = do i <- fmap parseInfo Parsec.getState
firstDigit :: Parsec.Parsec String ParseState Char
firstDigit = Parsec.choice [Parsec.digit, Parsec.char '-']
maybeSigned :: Parsec.Parsec String ParseState (Maybe Info, String)
maybeSigned = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
return (i, num)
double :: Parsec.Parsec String ParseState XObj
double = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
double = do (i, num) <- maybeSigned
_ <- Parsec.char '.'
decimals <- Parsec.many1 Parsec.digit
incColumn (length decimals)
@ -33,11 +37,7 @@ double = do i <- createInfo
else return (XObj (Num DoubleTy (read (num ++ "." ++ decimals))) i Nothing)
float :: Parsec.Parsec String ParseState XObj
float = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
float = do (i, num) <- maybeSigned
_ <- Parsec.char '.'
incColumn 1
decimals <- Parsec.many1 Parsec.digit
@ -49,21 +49,13 @@ float = do i <- createInfo
else return (XObj (Num FloatTy (read (num ++ "." ++ decimals))) i Nothing)
integer :: Parsec.Parsec String ParseState XObj
integer = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
integer = do (i, num) <- maybeSigned
if num == "-"
then return (XObj (Sym (SymPath [] "-")) i Nothing)
else return (XObj (Num IntTy (read num)) i Nothing)
long :: Parsec.Parsec String ParseState XObj
long = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
long = do (i, num) <- maybeSigned
_ <- Parsec.char 'l'
incColumn 1
if num == "-"
@ -79,7 +71,7 @@ number = Parsec.try float <|>
string :: Parsec.Parsec String ParseState XObj
string = do i <- createInfo
_ <- Parsec.char '"'
str <- Parsec.many ((Parsec.try escaped) <|> Parsec.noneOf ['"'])
str <- Parsec.many (Parsec.try escaped <|> Parsec.noneOf ['"'])
_ <- Parsec.char '"'
incColumn (length str + 2)
return (XObj (Str str) i Nothing)
@ -96,6 +88,7 @@ aChar = do i <- createInfo
incColumn 2
return (XObj (Chr c) i Nothing)
{-# ANN validCharacters "HLint: ignore Use String" #-}
validCharacters :: [Char]
validCharacters = "+-*/?!><=_:"
@ -212,21 +205,21 @@ ref :: Parsec.Parsec String ParseState XObj
ref = do i <- createInfo
_ <- Parsec.char '&'
expr <- sexpr
return (XObj (Lst [(XObj Ref Nothing Nothing), expr]) i Nothing)
return (XObj (Lst [XObj Ref Nothing Nothing, expr]) i Nothing)
copy :: Parsec.Parsec String ParseState XObj
copy = do i1 <- createInfo
i2 <- createInfo
_ <- Parsec.char '@'
expr <- sexpr
return (XObj (Lst [(XObj (Sym (SymPath [] "copy")) i1 Nothing), expr]) i2 Nothing)
return (XObj (Lst [XObj (Sym (SymPath [] "copy")) i1 Nothing, expr]) i2 Nothing)
quote :: Parsec.Parsec String ParseState XObj
quote = do i1 <- createInfo
i2 <- createInfo
_ <- Parsec.char '\''
expr <- sexpr
return (XObj (Lst [(XObj (Sym (SymPath [] "quote")) i1 Nothing), expr]) i2 Nothing)
return (XObj (Lst [XObj (Sym (SymPath [] "quote")) i1 Nothing, expr]) i2 Nothing)
sexpr :: Parsec.Parsec String ParseState XObj
sexpr = do x <- Parsec.choice [ref, copy, quote, list, array, atom]
@ -244,6 +237,7 @@ parse text fileName = let initState = ParseState (Info 1 0 fileName (Set.fromLis
{-# ANN balance "HLint: ignore Use String" #-}
-- | For detecting the parenthesis balance in a string, i.e. "((( ))" = 1
balance :: String -> Int
balance text =
@ -251,7 +245,8 @@ balance text =
Left err -> error (show err)
Right ok -> ok
where parenSyntax :: Parsec.Parsec String [Char] Int
where
parenSyntax :: Parsec.Parsec String [Char] Int
parenSyntax = do _ <- Parsec.many character
parens <- Parsec.getState
return (length parens)

2
src/Template.hs
View File

@ -139,7 +139,7 @@ toTokTy s =
templateNoop :: (String, Binder)
templateNoop = defineTemplate
(SymPath [] "noop")
(FuncTy [(PointerTy (VarTy "a"))] UnitTy)
(FuncTy [PointerTy (VarTy "a")] UnitTy)
(toTemplate "void $NAME ($a* a)")
(toTemplate "$DECL { }")
(const [])

6
src/TypeError.hs
View File

@ -1,5 +1,7 @@
module TypeError where
import Data.Maybe (fromMaybe)
import Types
import Obj
import Constraints
@ -103,9 +105,7 @@ instance Show TypeError where
recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of
(VarTy v) -> case recursiveLookup mappings v of
Just ok -> ok
Nothing -> t
(VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(RefTy r) -> RefTy (recursiveLookupTy mappings r)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)

6
src/Types.hs
View File

@ -190,10 +190,8 @@ replaceTyVars mappings t =
-- | The type of a type's copying function.
typesCopyFunctionType :: Ty -> Ty
typesCopyFunctionType memberType =
(FuncTy [(RefTy memberType)] memberType)
typesCopyFunctionType memberType = FuncTy [RefTy memberType] memberType
-- | The type of a type's deleter function.
typesDeleterFunctionType :: Ty -> Ty
typesDeleterFunctionType memberType =
(FuncTy [memberType] UnitTy)
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy

17
src/Util.hs
View File

@ -2,21 +2,22 @@ module Util where
import Data.List
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
joinWith :: String -> [String] -> String
joinWith s = concat . (intersperse s)
joinWith = intercalate
joinWithSpace :: [String] -> String
joinWithSpace = joinWith " "
joinWithSpace = unwords
joinWithComma :: [String] -> String
joinWithComma = joinWith ", "
joinWithComma = intercalate", "
joinWithUnderscore :: [String] -> String
joinWithUnderscore = joinWith "_"
joinWithUnderscore = intercalate"_"
joinWithPeriod :: [String] -> String
joinWithPeriod = joinWith "."
joinWithPeriod = intercalate"."
pairwise :: Show a => [a] -> [(a, a)]
pairwise [] = []
@ -33,10 +34,8 @@ toEither a b = case a of
Nothing -> Left b
replaceChars :: Map.Map Char String -> String -> String
replaceChars dict input = concat (map replacer input)
where replacer c = case Map.lookup c dict of
Just s -> s
Nothing -> [c]
replaceChars dict = concatMap replacer
where replacer c = fromMaybe [c] (Map.lookup c dict)
addIfNotPresent :: Eq a => a -> [a] -> [a]
addIfNotPresent x xs =

2
src/Workbench.hs
View File

@ -19,7 +19,7 @@ startingGlobalEnv :: Env
startingGlobalEnv = Env { envBindings = bs,
envParent = Nothing,
envModuleName = Nothing,
envUseModules = [(SymPath [] "String")],
envUseModules = [SymPath [] "String"],
envMode = ExternalEnv
}
where bs = Map.fromList [ register "and" (FuncTy [BoolTy, BoolTy] BoolTy)