From d46521dc1da448ac9158f97f406dd84e7e52916f Mon Sep 17 00:00:00 2001 From: hellerve Date: Sun, 19 Nov 2017 17:27:21 +0100 Subject: [PATCH 1/2] compiler: applied hlint fixes --- src/ArrayTemplates.hs | 62 +++++++++++++++--------------- src/AssignTypes.hs | 6 +-- src/Commands.hs | 63 +++++++++++++++---------------- src/Concretize.hs | 67 +++++++++++++++++---------------- src/Constraints.hs | 2 +- src/Deftype.hs | 55 +++++++++++++-------------- src/Emit.hs | 72 +++++++++++++++++------------------ src/Eval.hs | 44 +++++++++++----------- src/GenerateConstraints.hs | 30 ++++++++------- src/InitialTypes.hs | 32 ++++++++-------- src/ManageMemory.hs | 52 +++++++++++++------------ src/Obj.hs | 77 ++++++++++++++++++-------------------- src/Parsing.hs | 46 ++++++++++------------- src/Template.hs | 2 +- src/TypeError.hs | 6 +-- src/Types.hs | 6 +-- src/Util.hs | 17 ++++----- src/Workbench.hs | 2 +- 18 files changed, 313 insertions(+), 328 deletions(-) diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index 77596f77..74361bf4 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -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] diff --git a/src/AssignTypes.hs b/src/AssignTypes.hs index fd49c51b..e5ce34f8 100644 --- a/src/AssignTypes.hs +++ b/src/AssignTypes.hs @@ -7,7 +7,7 @@ import TypeError -- | 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 +assignTypes mappings = visit where visit xobj = case obj xobj of @@ -32,7 +32,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 +40,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 diff --git a/src/Commands.hs b/src/Commands.hs index a5aabbe2..1233e035 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -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 diff --git a/src/Concretize.hs b/src/Concretize.hs index 58cf1884..5c5b0be6 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -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) diff --git a/src/Constraints.hs b/src/Constraints.hs index f32378e9..2fff7e36 100644 --- a/src/Constraints.hs +++ b/src/Constraints.hs @@ -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 diff --git a/src/Deftype.hs b/src/Deftype.hs index 00f0b09c..a34492e6 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -48,13 +48,12 @@ moduleForDeftype typeEnv env pathStrings typeName rest i = -- | Follow the pattern [ , , ...] -- | TODO: What a mess this function is, clean it up! validateMembers :: TypeEnv -> [XObj] -> Either String () -validateMembers typeEnv rest = - mapM_ validateOneCase rest +validateMembers typeEnv = mapM_ validateOneCase 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 +102,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 +114,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 +144,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 +171,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 +186,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 +201,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 +253,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 +261,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 +273,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 +294,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) diff --git a/src/Emit.hs b/src/Emit.hs index 01659621..552e5472 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -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 = diff --git a/src/Eval.hs b/src/Eval.hs index 89a7d4e6..4c2729b8 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -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 diff --git a/src/GenerateConstraints.hs b/src/GenerateConstraints.hs index c127d663..84e70d88 100644 --- a/src/GenerateConstraints.hs +++ b/src/GenerateConstraints.hs @@ -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 diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index 19bc9a76..07ba0153 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -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 -> diff --git a/src/ManageMemory.hs b/src/ManageMemory.hs index b89e5706..5b4cc97f 100644 --- a/src/ManageMemory.hs +++ b/src/ManageMemory.hs @@ -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 diff --git a/src/Obj.hs b/src/Obj.hs index c56de39d..e632ff0a 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -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 @@ -331,7 +331,7 @@ multiLookupALL = multiLookupInternal True -- | 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 +multiLookupInternal allowLookupInAllModules name = recursiveLookup where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder) lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse! @@ -341,10 +341,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 +391,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 @@ -426,7 +426,7 @@ envAddBinding env name binder = env { envBindings = Map.insert name binder (envB -- | 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 +addListOfBindings = foldl' (\e (n, b) -> envAddBinding e n b) -- | Get an inner environment. getEnv :: Env -> [String] -> Env @@ -439,34 +439,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 +476,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 +553,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 +561,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 +622,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 +671,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 diff --git a/src/Parsing.hs b/src/Parsing.hs index 22ac4f54..72f49caa 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -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,7 +88,7 @@ aChar = do i <- createInfo incColumn 2 return (XObj (Chr c) i Nothing) -validCharacters :: [Char] +validCharacters :: String validCharacters = "+-*/?!><=_:" symbolSegment :: Parsec.Parsec String ParseState String @@ -212,21 +204,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] @@ -251,12 +243,12 @@ balance text = Left err -> error (show err) Right ok -> ok - where parenSyntax :: Parsec.Parsec String [Char] Int + where parenSyntax :: Parsec.Parsec String String Int parenSyntax = do _ <- Parsec.many character parens <- Parsec.getState return (length parens) - character :: Parsec.Parsec String [Char] () + character :: Parsec.Parsec String String () character = do c <- Parsec.anyChar parens <- Parsec.getState case parens of diff --git a/src/Template.hs b/src/Template.hs index 6a5700d0..fd5d688a 100644 --- a/src/Template.hs +++ b/src/Template.hs @@ -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 []) diff --git a/src/TypeError.hs b/src/TypeError.hs index 30339d0a..8bc0c5c6 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs index 76f62364..70217fcf 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index dd84cbdd..fb5adabb 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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 = diff --git a/src/Workbench.hs b/src/Workbench.hs index 0605b3c4..69e6dd59 100644 --- a/src/Workbench.hs +++ b/src/Workbench.hs @@ -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) From 520c5d8c4aabf4635c430275aa06ba93ce5269bc Mon Sep 17 00:00:00 2001 From: hellerve Date: Mon, 20 Nov 2017 13:36:39 +0100 Subject: [PATCH 2/2] compiler: added hlint ignore flags as discussed in #100 --- src/AssignTypes.hs | 3 ++- src/Deftype.hs | 4 +++- src/Obj.hs | 6 ++++-- src/Parsing.hs | 9 ++++++--- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/src/AssignTypes.hs b/src/AssignTypes.hs index e5ce34f8..7dfb14d2 100644 --- a/src/AssignTypes.hs +++ b/src/AssignTypes.hs @@ -5,9 +5,10 @@ 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 = visit +assignTypes mappings root = visit root where visit xobj = case obj xobj of diff --git a/src/Deftype.hs b/src/Deftype.hs index a34492e6..794924dc 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -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,11 +45,12 @@ 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 [ , , ...] -- | TODO: What a mess this function is, clean it up! validateMembers :: TypeEnv -> [XObj] -> Either String () -validateMembers typeEnv = mapM_ validateOneCase +validateMembers typeEnv rest = mapM_ validateOneCase rest where validateOneCase :: XObj -> Either String () validateOneCase (XObj (Arr arr) _ _) = diff --git a/src/Obj.hs b/src/Obj.hs index e632ff0a..adfc5da4 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -329,9 +329,10 @@ 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 = recursiveLookup +multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder) lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse! @@ -424,9 +425,10 @@ 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 = foldl' (\e (n, b) -> envAddBinding e n b) +addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd -- | Get an inner environment. getEnv :: Env -> [String] -> Env diff --git a/src/Parsing.hs b/src/Parsing.hs index 72f49caa..97b5afe6 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -88,7 +88,8 @@ aChar = do i <- createInfo incColumn 2 return (XObj (Chr c) i Nothing) -validCharacters :: String +{-# ANN validCharacters "HLint: ignore Use String" #-} +validCharacters :: [Char] validCharacters = "+-*/?!><=_:" symbolSegment :: Parsec.Parsec String ParseState String @@ -236,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 = @@ -243,12 +245,13 @@ balance text = Left err -> error (show err) Right ok -> ok - where parenSyntax :: Parsec.Parsec String String Int + where + parenSyntax :: Parsec.Parsec String [Char] Int parenSyntax = do _ <- Parsec.many character parens <- Parsec.getState return (length parens) - character :: Parsec.Parsec String String () + character :: Parsec.Parsec String [Char] () character = do c <- Parsec.anyChar parens <- Parsec.getState case parens of