From 87692f1c8c7a4dc48a7bd319a0a0e15070d8e852 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Wed, 21 Dec 2022 22:11:13 +0000 Subject: Tidy up --- src/Micro/Compiler.hs | 51 ++++++------- test/Language.hs | 198 +++++++++++++++++++++++++------------------------- 2 files changed, 122 insertions(+), 127 deletions(-) diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs index bd01b12..70ce82c 100644 --- a/src/Micro/Compiler.hs +++ b/src/Micro/Compiler.hs @@ -7,7 +7,8 @@ where import Control.Arrow (ArrowChoice (left)) import Control.Monad.State -import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Foldable (traverse_) +import Data.Maybe (isNothing, mapMaybe) import Micro.Asm.Sdcc (generate) import qualified Micro.Ast as A import Micro.Env @@ -30,38 +31,36 @@ startState = CompState emptyEnv [] -- returns either, returning accumulated right and the collected lefts as a -- list. foldlEither :: (accr -> b -> Either accl accr) -> (accr, [accl]) -> [b] -> (accr, [accl]) -foldlEither fn init xs = +foldlEither fn = foldl ( \(r, l) x -> case fn r x of Left e -> (r, e : l) Right x -> (x, l) ) - init - xs -- | @addError error@ adds @error@ to the state and returns no type to allow -- the compilation to continue. addError :: Error -> State CompState (Maybe A.Type) addError e = do modify $ \st -> st {stErr = e : stErr st} - pure $ Nothing + pure Nothing -- | @typecheckCall args params@ resolves @args@ and compares it with @params@, -- returning a string describing an error or Nothing in case of type match. typecheckCall :: [A.Expr] -> [A.Type] -> State CompState (Maybe String) typecheckCall args params | length args /= length params = return $ Just "invalid number of arguments in function call" - | length params == 0 = pure Nothing + | null params = pure Nothing | otherwise = do -- resolve all args types targs <- traverse compileOne args case sequence targs of Just t -- after resolution, we could have less "rights" - | length t /= length params -> return $ Nothing + | length t /= length params -> pure Nothing -- compare types - | all (\(a, b) -> a == b) $ zip t params -> - return $ Nothing -- all good! + | all (uncurry (==)) $ zip t params -> + pure Nothing -- all good! | otherwise -> return $ Just ("type mismatch in function call\n found: " ++ A.showList t ++ "\n expected: " ++ A.showList params) Nothing -> -- there was an error in on argument @@ -85,22 +84,18 @@ types = ["bool", "u8", "s8", "u16", "s16"] definedType :: A.Type -> Bool definedType (A.Type t) = t `elem` types definedType (A.FuncType ts r) = - all definedType ts && fromMaybe False (fmap definedType r) + all definedType ts && maybe False definedType r verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error] verifyFuncType ident params ret pos = do - ( catMaybes $ - map - ( \(_, t, _, pos) -> - if not (definedType t) - then Just $ Error UndefinedType ("undefined type in declaration of \"" ++ ident ++ "\"") pos - else Nothing - ) - params + mapMaybe + ( \(_, t, _, pos) -> + if not (definedType t) + then Just $ Error UndefinedType ("undefined type in declaration of \"" ++ ident ++ "\"") pos + else Nothing ) - ++ if not (fromMaybe True (fmap definedType ret)) - then [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos] - else [] + params + ++ [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos | not (maybe True definedType ret)] compileOne :: A.Expr -> State CompState (Maybe A.Type) compileOne x = do @@ -123,14 +118,14 @@ compileOne x = do -- current env st <- get -- check for undefined types - (ev, errs) <- return (stEnv st, (verifyFuncType ident params ret pos) ++ stErr st) + (ev, errs) <- return (stEnv st, verifyFuncType ident params ret pos ++ stErr st) -- updated with the function (ev, errs) <- return $ case addSymUniq ev (Sym ident ftype priv False pos) of Left err -> (ev, err : errs) Right ev -> (ev, errs) -- lambdas can only access local variables (closures aren't supported) - fev <- return $ if anon then emptyEnv else ev + let fev = if anon then emptyEnv else ev -- with parameters (nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) $ map (toSym True) params -- helper for return @@ -169,7 +164,7 @@ compileOne x = do case value of Nothing -> if isNothing rtyp - then pure $ Nothing + then pure Nothing else addError $ Error TypeError ("invalid return value\n found: ()\n expected: " ++ showMaybeType rtyp) pos Just v -> do r <- compileOne v @@ -196,7 +191,7 @@ foldConstant x = fa <- foldConstant a fb <- foldConstant b let newOp = A.BinOp op pos fa fb - if newOp /= x then foldConstant newOp else Right $ newOp + if newOp /= x then foldConstant newOp else Right newOp (A.Func ident params ret body priv anon pos) -> do fbody <- traverse foldConstant body Right $ A.Func ident params ret fbody priv anon pos @@ -214,7 +209,7 @@ foldConstant x = compileAll :: [A.Expr] -> State CompState (Either [Error] SymMap) compileAll ast = do - _ <- traverse compileOne ast + traverse_ compileOne ast st <- get let (Env sym _) = stEnv st let errs = stErr st @@ -225,10 +220,10 @@ compileAll ast = do compileToAst :: [A.Expr] -> Either [Error] [A.Expr] compileToAst ast = do _ <- evalState (compileAll ast) startState - left (\e -> [e]) $ traverse foldConstant ast + left (: []) $ traverse foldConstant ast compile :: [A.Expr] -> Either [Error] String compile ast = do _ <- evalState (compileAll ast) startState - fast <- left (\e -> [e]) $ traverse foldConstant ast + fast <- left (: []) $ traverse foldConstant ast return $ generate version fast diff --git a/test/Language.hs b/test/Language.hs index 3e6a898..351e244 100644 --- a/test/Language.hs +++ b/test/Language.hs @@ -11,31 +11,31 @@ import Text.Parsec.Pos (newPos) assertCompileAst :: String -> [A.Expr] -> Assertion assertCompileAst input expected = do - r <- return $ parseFromString input + let r = parseFromString input case r of Left e -> assertFailure $ show e Right ast -> do - res <- return $ compileToAst ast + let res = compileToAst ast case res of Left e -> assertFailure $ show e Right ast -> assertEqual "" expected ast assertAst :: String -> [A.Expr] -> Assertion assertAst input expected = do - r <- return $ parseFromString input + let r = parseFromString input case r of Left e -> assertFailure $ show e Right ast -> assertEqual "" expected ast expectError :: String -> E.ErrorType -> Assertion expectError input etyp = do - r <- return $ parseFromString input + let r = parseFromString input case r of Left e -> assertFailure $ show e Right ast -> do - res <- return $ compile ast + let res = compile ast case res of - Left e -> case (find (\(E.Error t _ _) -> t == etyp) e) of + Left e -> case find (\(E.Error t _ _) -> t == etyp) e of Just _ -> return () Nothing -> assertFailure $ "expected " ++ show etyp ++ " didn't happen, got instead:\n" ++ unlines (map (\(E.Error t _ _) -> show t) e) Right _ -> assertFailure "expected error, didn't happen" @@ -53,115 +53,115 @@ testCases = ], TestLabel "parse a function" - $ TestCase $ - assertAst - "module main\n\ - \def fn() { }" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [] Nothing [] False False $ newPos "-" 2 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn() { }" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [] Nothing [] False False $ newPos "-" 2 1 + ], TestLabel "parse a function with parameters" - $ TestCase $ - assertAst - "module main\n\ - \def fn(a: u8) { }" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [("a", A.Type "u8", True, newPos "-" 2 8)] Nothing [] False False $ newPos "-" 2 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn(a: u8) { }" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [("a", A.Type "u8", True, newPos "-" 2 8)] Nothing [] False False $ newPos "-" 2 1 + ], TestLabel "parse a function with return value" - $ TestCase $ - assertAst - "module main\n\ - \def fn(): u8 {\n\ - \return 1; }" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [] (Just $ A.Type "u8") [A.Return (Just $ A.Num 1 $ newPos "-" 3 8) $ newPos "-" 3 1] False False $ newPos "-" 2 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn(): u8 {\n\ + \return 1; }" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [] (Just $ A.Type "u8") [A.Return (Just $ A.Num 1 $ newPos "-" 3 8) $ newPos "-" 3 1] False False $ newPos "-" 2 1 + ], TestLabel "parse a function call" - $ TestCase $ - assertAst - "module main\n\ - \def fn() { }\n\ - \fn();" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [] Nothing [] False False $ newPos "-" 2 1, - A.Call (A.Variable "fn" $ newPos "-" 3 1) [] $ newPos "-" 3 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn() { }\n\ + \fn();" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [] Nothing [] False False $ newPos "-" 2 1, + A.Call (A.Variable "fn" $ newPos "-" 3 1) [] $ newPos "-" 3 1 + ], TestLabel "parse a function call with arguments" - $ TestCase $ - assertAst - "module main\n\ - \def fn(a: u8) { }\n\ - \fn(10);" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [("a", A.Type "u8", True, newPos "-" 2 8)] Nothing [] False False $ newPos "-" 2 1, - A.Call (A.Variable "fn" $ newPos "-" 3 1) [A.Num 10 $ newPos "-" 3 4] $ newPos "-" 3 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn(a: u8) { }\n\ + \fn(10);" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [("a", A.Type "u8", True, newPos "-" 2 8)] Nothing [] False False $ newPos "-" 2 1, + A.Call (A.Variable "fn" $ newPos "-" 3 1) [A.Num 10 $ newPos "-" 3 4] $ newPos "-" 3 1 + ], TestLabel "parse empty return on a function" - $ TestCase $ - assertAst - "module main\n\ - \def fn() {\n\ - \return; }" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [] Nothing [A.Return Nothing $ newPos "-" 3 1] False False $ newPos "-" 2 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn() {\n\ + \return; }" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [] Nothing [A.Return Nothing $ newPos "-" 3 1] False False $ newPos "-" 2 1 + ], TestLabel "parse a recursive function" - $ TestCase $ - assertAst - "module main\n\ - \def fn() {\n\ - \fn(); }" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn" [] Nothing [A.Call (A.Variable "fn" $ newPos "-" 3 1) [] $ newPos "-" 3 1] False False $ newPos "-" 2 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn() {\n\ + \fn(); }" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn" [] Nothing [A.Call (A.Variable "fn" $ newPos "-" 3 1) [] $ newPos "-" 3 1] False False $ newPos "-" 2 1 + ], TestLabel "parse a function with a function parameter" - $ TestCase $ - assertAst - "module main\n\ - \def fn1() { }\n\ - \def fn2(f: ()) {\n\ - \f(); }\n\ - \fn2(fn1);" - [ A.Module "main" $ newPos "-" 1 1, - A.Func "fn1" [] Nothing [] False False $ newPos "-" 2 1, - A.Func - "fn2" - [("f", A.FuncType [] Nothing, True, newPos "-" 3 9)] - Nothing - [ A.Call (A.Variable "f" $ newPos "-" 4 1) [] $ newPos "-" 4 1 - ] - False - False - $ newPos "-" 3 1, - A.Call (A.Variable "fn2" $ newPos "-" 5 1) [A.Variable "fn1" $ newPos "-" 5 5] $ newPos "-" 5 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn1() { }\n\ + \def fn2(f: ()) {\n\ + \f(); }\n\ + \fn2(fn1);" + [ A.Module "main" $ newPos "-" 1 1, + A.Func "fn1" [] Nothing [] False False $ newPos "-" 2 1, + A.Func + "fn2" + [("f", A.FuncType [] Nothing, True, newPos "-" 3 9)] + Nothing + [ A.Call (A.Variable "f" $ newPos "-" 4 1) [] $ newPos "-" 4 1 + ] + False + False + $ newPos "-" 3 1, + A.Call (A.Variable "fn2" $ newPos "-" 5 1) [A.Variable "fn1" $ newPos "-" 5 5] $ newPos "-" 5 1 + ], TestLabel "parse a function with a function parameter (lambda)" - $ TestCase $ - assertAst - "module main\n\ - \def fn(f: ()) {\n\ - \f(); }\n\ - \fn(() { });" - [ A.Module "main" $ newPos "-" 1 1, - A.Func - "fn" - [("f", A.FuncType [] Nothing, True, newPos "-" 2 8)] - Nothing - [A.Call (A.Variable "f" $ newPos "-" 3 1) [] $ newPos "-" 3 1] - False - False - $ newPos "-" 2 1, - A.Call (A.Variable "fn" $ newPos "-" 4 1) [A.Func "lambda@4,4" [] Nothing [] True True $ newPos "-" 4 4] $ newPos "-" 4 1 - ], + $ TestCase + $ assertAst + "module main\n\ + \def fn(f: ()) {\n\ + \f(); }\n\ + \fn(() { });" + [ A.Module "main" $ newPos "-" 1 1, + A.Func + "fn" + [("f", A.FuncType [] Nothing, True, newPos "-" 2 8)] + Nothing + [A.Call (A.Variable "f" $ newPos "-" 3 1) [] $ newPos "-" 3 1] + False + False + $ newPos "-" 2 1, + A.Call (A.Variable "fn" $ newPos "-" 4 1) [A.Func "lambda@4,4" [] Nothing [] True True $ newPos "-" 4 4] $ newPos "-" 4 1 + ], TestLabel "parse a call to lambda" $ TestCase $ assertAst -- cgit v1.2.3