Refactored the compiler result to plug in the code generator

Also some tweaks in error reporting.

1 files changed, 53 insertions, 40 deletions

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