From acab64cc0f21c0ee9fc5b9b08b60e08997818222 Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Sat, 10 Sep 2022 22:10:01 +0100
Subject: Preparing constant folding

---
 src/Micro/Compiler.hs | 59 +++++++++++++++++++++++----------------------------
 1 file changed, 26 insertions(+), 33 deletions(-)

(limited to 'src/Micro/Compiler.hs')

diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
index b3ec8a1..629ea45 100644
--- a/src/Micro/Compiler.hs
+++ b/src/Micro/Compiler.hs
@@ -1,6 +1,5 @@
 module Micro.Compiler
   ( version,
-    Result (..),
     compile,
   )
 where
@@ -22,21 +21,14 @@ data CompState = CompState
   }
   deriving (Show)
 
-data Result = Result
+data CompResult = Result
   { -- last resolved type
     crType :: Maybe A.Type,
-    -- only in last call
-    crExit :: Either [Error] String
+    crExpr :: A.Expr
   }
 
-typeResult :: Maybe A.Type -> Result
-typeResult t = Result {crType = t, crExit = Left []}
-
-errorResult :: [Error] -> Result
-errorResult err = Result {crType = Nothing, crExit = Left err}
-
-successResult :: String -> Result
-successResult out = Result {crType = Nothing, crExit = Right out}
+typeResult :: Maybe A.Type -> A.Expr -> CompResult
+typeResult t e = Result t e
 
 startState :: CompState
 startState = CompState emptyEnv []
@@ -56,11 +48,11 @@ foldlEither fn init xs =
 
 -- | @addError error@ adds @error@ to the state and returns no type to allow
 -- the compilation to continue.
-addError :: Error -> State CompState Result
+addError :: Error -> State CompState CompResult
 addError e = do
   st <- get
   put st {stErr = e : stErr st}
-  pure $ typeResult Nothing
+  pure $ typeResult Nothing A.Nop
 
 -- | @typecheckCall args params@ resolves @args@ and compares it with @params@,
 -- returning a string describing an error or Nothing in case of type match.
@@ -107,14 +99,14 @@ typecheckReturn (Just value) fret = typecheckVal value fret
 
 -- | @typecheckBinOp a b pos@ resolves @a@ (left) and compares it to the type
 -- of @b@ via typecheckVal.
-typecheckBinOp :: A.Expr -> A.Expr -> SourcePos -> State CompState Result
-typecheckBinOp a b pos = do
+typecheckBinOp :: A.Expr -> A.Expr -> A.Expr -> SourcePos -> State CompState CompResult
+typecheckBinOp op a b pos = do
   l <- compileOne a
   let tl = crType l
   tr <- typecheckVal b $ tl
   case tr of
     Just err -> addError $ Error TypeError err pos
-    Nothing -> return $ typeResult tl
+    Nothing -> return $ typeResult tl op
 
 -- built-in types
 types :: [String]
@@ -140,19 +132,19 @@ verifyFuncType ident params ret pos = do
       then [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos]
       else []
 
-compileOne :: A.Expr -> State CompState Result
+compileOne :: A.Expr -> State CompState CompResult
 compileOne x = do
   case x of
-    (A.Module _ _) -> return $ typeResult Nothing
-    (A.Num _ _) -> return $ typeResult $ Just $ A.Type "u8" -- TODO: placeholder
-    (A.Bool' _ _) -> return $ typeResult $ Just $ A.Type "bool"
+    (A.Module _ _) -> return $ typeResult Nothing x
+    (A.Num _ _) -> return $ typeResult (Just $ A.Type "u8") x -- TODO: placeholder
+    (A.Bool' _ _) -> return $ typeResult (Just $ A.Type "bool") x
     (A.BinOp A.Assign pos a@(A.Variable _ _) b) ->
-      typecheckBinOp a b pos
+      typecheckBinOp x a b pos
     (A.BinOp A.Assign pos _ _) ->
       addError $ Error InvalidTarget "invalid assignment target" pos
     (A.BinOp _ pos a b) ->
       -- TODO: types and invalid operators
-      typecheckBinOp a b pos
+      typecheckBinOp x a b pos
     (A.Func ident params ret body priv anon pos) -> do
       -- current env
       st <- get
@@ -174,7 +166,7 @@ compileOne x = do
       st <- get
       -- store updated errors and the env with the function
       put st {stEnv = ev}
-      return $ typeResult $ Just ftype
+      return $ typeResult (Just ftype) x
       where
         ftype = A.toFuncType params ret
     (A.Call ident args pos) -> do
@@ -184,7 +176,7 @@ compileOne x = do
           r <- typecheckCall args params
           case r of
             Just err -> addError $ Error TypeError err pos
-            Nothing -> return $ typeResult rtyp
+            Nothing -> return $ typeResult rtyp x
         _ -> addError $ Error NonCallable "non callable value in function call" pos
     (A.Var ident typ val priv pos) -> do
       st <- get
@@ -198,7 +190,7 @@ compileOne x = do
       vt <- typecheckVal val $ Just typ
       case vt of
         Just err -> addError $ Error TypeError err pos
-        Nothing -> return $ typeResult $ Just typ
+        Nothing -> return $ typeResult (Just typ) x
     (A.Return value pos) -> do
       st <- get
       case getSyml (stEnv st) "$fn$" of
@@ -206,23 +198,24 @@ compileOne x = do
           r <- typecheckReturn value rtyp
           case r of
             Just err -> addError $ Error TypeError err pos
-            Nothing -> return $ typeResult rtyp
+            Nothing -> return $ typeResult rtyp x
         _ -> addError $ Error UnexpectedReturn "return without function call" pos
     (A.Variable ident pos) -> do
       st <- get
       case getSym (stEnv st) ident of
-        Just Sym {symType = t} -> return $ typeResult $ Just t
+        Just Sym {symType = t} -> return $ typeResult (Just t) x
         Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos
+    (A.Nop) -> return $ typeResult Nothing x
 
-compileAll :: [A.Expr] -> State CompState Result
+compileAll :: [A.Expr] -> State CompState (Either [Error] String)
 compileAll ast = do
-  _ <- traverse compileOne ast
+  result <- traverse compileOne ast
   st <- get
   let (Env sym _) = stEnv st
   let errs = stErr st
   case errs of
-    [] -> pure $ successResult $ generate version sym ast
-    _ -> return $ errorResult errs
+    [] -> pure $ Right $ generate version sym (map (\r -> crExpr r) result)
+    _ -> return $ Left errs
 
-compile :: [A.Expr] -> Result
+compile :: [A.Expr] -> Either [Error] String
 compile ast = evalState (compileAll ast) startState
-- 
cgit v1.2.3