Constant folding fixes

2 files changed, 28 insertions, 33 deletions

diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
index 901a1e3..01456d2 100644
--- a/src/Micro/Compiler.hs
+++ b/src/Micro/Compiler.hs
@@ -63,6 +63,7 @@ typecheckCall args params
   | length params == 0 = pure Nothing
   | otherwise = do
       -- resolve all args types
+      -- FIXME: this break constant folding
       rargs <- traverse compileOne args
       let targs = map crType rargs
       case sequence targs of
@@ -81,33 +82,20 @@ showMaybet :: Maybe A.Type -> String
 showMaybet Nothing = "()"
 showMaybet (Just t) = show t
 
--- | @typecheckVal value typ@ resolves @value@ and compares it to @typ@ type,
--- returning a string describing an error or Nothing in case of type match.
-typecheckVal :: A.Expr -> Maybe A.Type -> State CompState (Maybe String)
-typecheckVal value typ = do
-  r <- compileOne value
-  case crType r of
-    rt
-      | rt == typ -> pure Nothing
-      | otherwise -> return $ Just $ "type mismatch\n     found: " ++ showMaybet rt ++ "\n  expected: " ++ showMaybet typ
+typecheck :: Maybe A.Type -> Maybe A.Type -> Maybe String
+typecheck expected found
+  | expected == found = Nothing
+  | otherwise = Just $ "type mismatch\n     found: " ++ showMaybet found ++ "\n  expected: " ++ showMaybet expected
 
 -- | @typecheckReturn value fret@ resolves @value@ and compares it with @fret@,
 -- returning a string decribing an error or Nothing in case of a type match.
 typecheckReturn :: Maybe A.Expr -> Maybe A.Type -> State CompState (Maybe String)
 typecheckReturn Nothing Nothing = return $ Nothing
 typecheckReturn Nothing fret = return $ Just $ "invalid return value\n     found: ()\n  expected: " ++ showMaybet fret
-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 -> 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 op
+typecheckReturn (Just value) fret = do
+  -- FIXME: this break constant folding
+  r <- compileOne value
+  return $ typecheck (crType r) fret
 
 -- built-in types
 types :: [String]
@@ -139,16 +127,23 @@ compileOne x = do
     (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 x a b pos
-    (A.BinOp A.Assign pos _ _) ->
-      addError $ Error InvalidTarget "invalid assignment target" pos
     (A.BinOp A.Plus pos (A.Num a _) (A.Num b _)) ->
-      -- TODO: overflow check, actual type
+      -- TODO: overflow check
       return $ typeResult (Just $ A.Type "u8") (A.Num (a + b) pos)
-    (A.BinOp _ pos a b) ->
-      -- TODO: types and invalid operators
-      typecheckBinOp x a b pos
+    (A.BinOp op pos a b) -> do
+      ra <- compileOne a
+      let (ta, ea) = (crType ra, crExpr ra)
+      rb <- compileOne b
+      let (tb, eb) = (crType rb, crExpr rb)
+      case op of
+        A.Assign -> case a of
+          (A.Variable _ _) -> case typecheck ta tb of
+            Nothing -> return $ typeResult ta (A.BinOp A.Assign pos ea eb)
+            Just err -> addError $ Error TypeError err pos
+          _ -> addError $ Error InvalidTarget "invalid assignment target" pos
+        _ -> case typecheck ta tb of
+          Nothing -> compileOne (A.BinOp op pos ea eb)
+          Just err -> addError $ Error TypeError err pos
     (A.Func ident params ret body priv anon pos) -> do
       -- current env
       st <- get
@@ -191,8 +186,8 @@ compileOne x = do
             then Error UndefinedType ("undefined type in declaration \"" ++ ident ++ "\"") pos : errs
             else errs
       put st {stEnv = ev, stErr = errs}
-      vt <- typecheckVal val $ Just typ
-      case vt of
+      r <- compileOne val
+      case typecheck (Just typ) (crType r) of
         Just err -> addError $ Error TypeError err pos
         Nothing -> return $ typeResult (Just typ) x
     (A.Return value pos) -> do
diff --git a/test/Language.hs b/test/Language.hs
index 604b06b..9d81733 100644
--- a/test/Language.hs
+++ b/test/Language.hs
@@ -254,9 +254,9 @@ testCase18 =
     TestCase $
       assertCompileAst
         "module main\n\
-        \1 + 2;"
+        \1 + 2 + 3 + (5 + 5);"
         [ A.Module "main" $ newPos "-" 1 1,
-          A.Num 3 $ newPos "-" 2 5
+          A.Num 16 $ newPos "-" 2 13
         ]
 
 -- test errors