Better project layout, removed warnings

1 files changed, 202 insertions, 0 deletions

diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
new file mode 100644
index 0000000..90e710b
--- /dev/null
+++ b/src/Micro/Compiler.hs
@@ -0,0 +1,202 @@
+module Micro.Compiler where
+
+import Control.Monad.State
+import Data.Either (rights)
+import Data.Maybe (catMaybes, fromMaybe)
+import qualified Micro.Ast as A
+import Micro.Env
+import Micro.Error
+import Text.Parsec (SourcePos)
+
+type CompState = (Env, [Error])
+
+type CompResult = Either [Error] (Maybe A.Type)
+
+startState :: CompState
+startState = (emptyEnv, [])
+
+-- | @foldlEither fn init xs@ folds left @xs@ applying a function @fn@ that
+-- 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 =
+  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 CompResult
+addError e = do
+  (ev, errs) <- get
+  put (ev, e : errs)
+  pure $ Right 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
+  | otherwise = do
+      -- resolve all args types
+      targs <- fmap rights $ traverse compile args
+      case sequence targs of
+        Just t
+          -- after resolution, we could have less "rights"
+          | length t /= length params -> return $ Nothing
+          -- compare types
+          | all (\(a, b) -> a == b) $ zip t params ->
+              return $ 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
+          pure Nothing
+
+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 <- 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
+
+-- | @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 -> 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
+
+-- built-in types
+types :: [String]
+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)
+
+verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error]
+verifyFuncType ident params ret pos = do
+  ( catMaybes $
+      map
+        ( \(id, t, _, pos) ->
+            if not (definedType t)
+              then Just $ Error UndefinedType ("undefined type in function declaration \"" ++ id ++ "\"") pos
+              else Nothing
+        )
+        params
+    )
+    ++ if not (fromMaybe True (fmap definedType ret))
+      then [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos]
+      else []
+
+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.BinOp A.Assign pos a@(A.Variable _ _) b) ->
+      typecheckBinOp 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
+    (A.Func ident params ret body priv anon pos) -> do
+      -- current env
+      (ev, errs) <- get
+      -- check for undefined types
+      (ev, errs) <- return $ (ev, (verifyFuncType ident params ret pos) ++ errs)
+      -- updated with the function
+      (ev, errs) <-
+        return $ case addSymUniq ev (ident, ftype, priv, 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
+      -- with parameters
+      (nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) params
+      -- helper for return
+      nev <- return $ addSym nev ("$fn$", ftype, True, pos)
+      put (nev, errs)
+      _ <- compileAll body
+      (_, errs) <- get
+      -- store updated errors and the env with the function
+      put (ev, errs)
+      return $ Right $ 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
+          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
+    (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
+            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
+    (A.Return value pos) -> do
+      (ev, _) <- get
+      case getSyml ev "$fn$" of
+        Just (_, A.FuncType _ rtyp, _, _) -> do
+          r <- typecheckReturn value rtyp
+          case r of
+            Just err -> addError $ Error TypeError err pos
+            Nothing -> return $ Right 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
+
+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