Refactored the compiler result to plug in the code generator

Also some tweaks in error reporting.

5 files changed, 63 insertions, 44 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 5a16129..db970d9 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -71,8 +71,8 @@ compileFile filename onlyParse = do
     Left err -> hPutStrLn stderr (showParserError err) >> exitFailure
     Right ast -> do
       res <- return $ evalState (compileAll ast) startState
-      case res of
-        Right _ -> if onlyParse then exitSuccess else print ast
+      case crExit res of
+        Right out -> if onlyParse then exitSuccess else hPutStrLn stdout out
         Left errs -> hPutStr stderr (showErrorList errs) >> exitFailure
 
 main :: IO ()
diff --git a/src/Micro/Asm/Sdcc.hs b/src/Micro/Asm/Sdcc.hs
index 60a2caf..916fa3e 100644
--- a/src/Micro/Asm/Sdcc.hs
+++ b/src/Micro/Asm/Sdcc.hs
@@ -1 +1,7 @@
 module Micro.Asm.Sdcc where
+
+import qualified Micro.Ast as A
+import Micro.Env (SymMap)
+
+generate :: SymMap -> [A.Expr] -> String
+generate sym ast = "OUTPUT"
diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
index 90e710b..f7ae71f 100644
--- a/src/Micro/Compiler.hs
+++ b/src/Micro/Compiler.hs
@@ -1,8 +1,8 @@
 module Micro.Compiler where
 
 import Control.Monad.State
-import Data.Either (rights)
 import Data.Maybe (catMaybes, fromMaybe)
+import Micro.Asm.Sdcc (generate)
 import qualified Micro.Ast as A
 import Micro.Env
 import Micro.Error
@@ -10,7 +10,21 @@ import Text.Parsec (SourcePos)
 
 type CompState = (Env, [Error])
 
-type CompResult = Either [Error] (Maybe A.Type)
+data CompResult = CompResult
+  { -- last resolved type
+    crLast :: Maybe A.Type,
+    -- only in last call
+    crExit :: Either [Error] String
+  }
+
+typeResult :: Maybe A.Type -> CompResult
+typeResult t = CompResult {crLast = t, crExit = Left []}
+
+errorResult :: [Error] -> CompResult
+errorResult err = CompResult {crLast = Nothing, crExit = Left err}
+
+successResult :: String -> CompResult
+successResult out = CompResult {crLast = Nothing, crExit = Right out}
 
 startState :: CompState
 startState = (emptyEnv, [])
@@ -34,7 +48,7 @@ addError :: Error -> State CompState CompResult
 addError e = do
   (ev, errs) <- get
   put (ev, e : errs)
-  pure $ Right Nothing
+  pure $ typeResult Nothing
 
 -- | @typecheckCall args params@ resolves @args@ and compares it with @params@,
 -- returning a string describing an error or Nothing in case of type match.
@@ -44,7 +58,8 @@ typecheckCall args params
   | length params == 0 = pure Nothing
   | otherwise = do
       -- resolve all args types
-      targs <- fmap rights $ traverse compile args
+      rargs <- traverse compile args
+      let targs = map crLast rargs
       case sequence targs of
         Just t
           -- after resolution, we could have less "rights"
@@ -66,11 +81,10 @@ showMaybet (Just t) = show t
 typecheckVal :: A.Expr -> Maybe A.Type -> State CompState (Maybe String)
 typecheckVal value typ = do
   r <- compile value
-  case r of
-    Right r
-      | r == typ -> pure Nothing
-      | otherwise -> return $ Just $ "type mismatch\n     found: " ++ showMaybet r ++ "\n  expected: " ++ showMaybet typ
-    Left _ -> pure Nothing -- error resolving value
+  case crLast r of
+    rt
+      | rt == typ -> pure Nothing
+      | otherwise -> return $ Just $ "type mismatch\n     found: " ++ showMaybet rt ++ "\n  expected: " ++ showMaybet typ
 
 -- | @typecheckReturn value fret@ resolves @value@ and compares it with @fret@,
 -- returning a string decribing an error or Nothing in case of a type match.
@@ -84,13 +98,11 @@ typecheckReturn (Just value) fret = typecheckVal value fret
 typecheckBinOp :: A.Expr -> A.Expr -> SourcePos -> State CompState CompResult
 typecheckBinOp a b pos = do
   l <- compile a
-  case l of
-    Right tl -> do
-      tr <- typecheckVal b $ tl
-      case tr of
-        Just err -> addError $ Error TypeError err pos
-        Nothing -> return $ Right $ tl
-    _ -> return $ Right Nothing -- error resolving left
+  let tl = crLast l
+  tr <- typecheckVal b $ tl
+  case tr of
+    Just err -> addError $ Error TypeError err pos
+    Nothing -> return $ typeResult tl
 
 -- built-in types
 types :: [String]
@@ -105,9 +117,9 @@ verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error
 verifyFuncType ident params ret pos = do
   ( catMaybes $
       map
-        ( \(id, t, _, pos) ->
+        ( \(_, t, _, pos) ->
             if not (definedType t)
-              then Just $ Error UndefinedType ("undefined type in function declaration \"" ++ id ++ "\"") pos
+              then Just $ Error UndefinedType ("undefined type in declaration of \"" ++ ident ++ "\"") pos
               else Nothing
         )
         params
@@ -119,9 +131,9 @@ verifyFuncType ident params ret pos = do
 compile :: A.Expr -> State CompState CompResult
 compile x = do
   case x of
-    (A.Module _ _) -> return $ Right Nothing
-    (A.Num _ _) -> return $ Right $ Just $ A.Type "u8" -- TODO: placeholder
-    (A.Bool' _ _) -> return $ Right $ Just $ A.Type "bool"
+    (A.Module _ _) -> return $ typeResult Nothing
+    (A.Num _ _) -> return $ typeResult $ Just $ A.Type "u8" -- TODO: placeholder
+    (A.Bool' _ _) -> return $ typeResult $ Just $ A.Type "bool"
     (A.BinOp A.Assign pos a@(A.Variable _ _) b) ->
       typecheckBinOp a b pos
     (A.BinOp A.Assign pos _ _) ->
@@ -150,32 +162,31 @@ compile x = do
       (_, errs) <- get
       -- store updated errors and the env with the function
       put (ev, errs)
-      return $ Right $ Just ftype
+      return $ typeResult $ Just ftype
       where
         ftype = A.toFuncType params ret
     (A.Call ident args pos) -> do
       r <- compile ident
-      case r of
-        Right (Just (A.FuncType params rtyp)) -> do
+      case crLast r of
+        Just (A.FuncType params rtyp) -> do
           r <- typecheckCall args params
           case r of
             Just err -> addError $ Error TypeError err pos
-            Nothing -> return $ Right rtyp
-        Right _ -> addError $ Error NonCallable "non callable value in function call" pos
-        _ -> pure $ Right Nothing
+            Nothing -> return $ typeResult rtyp
+        _ -> addError $ Error NonCallable "non callable value in function call" pos
     (A.Var ident typ val priv pos) -> do
       (ev, errs) <- get
       (ev, errs) <- return $ foldlEither addSymUniq (ev, errs) [(ident, typ, priv, pos)]
       errs <-
         return $
           if not (definedType typ)
-            then Error UndefinedType ("undefined type in variable declaration \"" ++ ident ++ "\"") pos : errs
+            then Error UndefinedType ("undefined type in declaration \"" ++ ident ++ "\"") pos : errs
             else errs
       put (ev, errs)
       vt <- typecheckVal val $ Just typ
       case vt of
         Just err -> addError $ Error TypeError err pos
-        Nothing -> return $ Right $ Just typ
+        Nothing -> return $ typeResult $ Just typ
     (A.Return value pos) -> do
       (ev, _) <- get
       case getSyml ev "$fn$" of
@@ -183,20 +194,22 @@ compile x = do
           r <- typecheckReturn value rtyp
           case r of
             Just err -> addError $ Error TypeError err pos
-            Nothing -> return $ Right rtyp
+            Nothing -> return $ typeResult rtyp
         _ -> addError $ Error UnexpectedReturn "return without function call" pos
     (A.Variable ident pos) -> do
       (ev, _) <- get
       case getSym ev ident of
-        Just (_, t, _, _) -> return $ Right $ Just t
-        Nothing -> addError $ Error Undefined ("undefined variable \"" ++ ident ++ "\"") pos
+        Just (_, t, _, _) -> return $ typeResult $ Just t
+        Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos
 
 compileAll :: [A.Expr] -> State CompState CompResult
-compileAll (x : xs) = do
-  _ <- compile x
-  compileAll xs
-compileAll [] = do
-  (_, errs) <- get
-  case errs of
-    [] -> pure $ Right Nothing
-    _ -> return $ Left errs
+compileAll ast =
+  case ast of
+    (x : xs) -> do
+      _ <- compile x
+      compileAll xs
+    [] -> do
+      ((Env sym _), errs) <- get
+      case errs of
+        [] -> pure $ successResult $ generate sym ast
+        _ -> return $ errorResult errs
diff --git a/src/Micro/Env.hs b/src/Micro/Env.hs
index 4174158..7259deb 100644
--- a/src/Micro/Env.hs
+++ b/src/Micro/Env.hs
@@ -58,6 +58,6 @@ addEnv env = Env Map.empty $ Just env
 addSymUniq :: Env -> Sym -> Either Error Env
 addSymUniq ev (id, typ, priv, pos) = case getSyml ev id of
   Nothing -> Right $ addSym ev sym
-  Just (_, _, _, p) -> Left $ Error AlreadyDefined ("symbol \"" ++ id ++ "\" already defined in " ++ show p) pos
+  Just (_, _, _, p) -> Left $ Error AlreadyDefined ("\"" ++ id ++ "\" already defined in " ++ show p) pos
   where
     sym = (id, typ, priv, pos)
diff --git a/test/Language.hs b/test/Language.hs
index 6680178..9f47008 100644
--- a/test/Language.hs
+++ b/test/Language.hs
@@ -25,7 +25,7 @@ expectError input etyp = do
     Left e -> assertFailure $ show e
     Right ast -> do
       res <- return $ evalState (compileAll ast) startState
-      case res of
+      case crExit res 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)