From 279f04cb63e45ceb9a9df82540d5362565b8b37b Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Fri, 12 Aug 2022 22:53:06 +0100
Subject: Initial import

---
 src/Compiler.hs | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 132 insertions(+)
 create mode 100644 src/Compiler.hs

(limited to 'src/Compiler.hs')

diff --git a/src/Compiler.hs b/src/Compiler.hs
new file mode 100644
index 0000000..32dd1ee
--- /dev/null
+++ b/src/Compiler.hs
@@ -0,0 +1,132 @@
+module Compiler where
+
+import qualified Ast as A
+import Control.Monad.State
+import Data.List (sort)
+import qualified Data.Map as Map
+import Data.Maybe (isJust)
+import System.Environment (getEnv, getEnvironment)
+import Text.Parsec (ParseError, SourcePos)
+import Text.Read (Lexeme (String))
+
+data Error = Error String SourcePos deriving (Eq)
+
+instance Show Error where
+  show (Error message pos) =
+    "error: " ++ show pos ++ ":\n" ++ message
+
+instance Ord Error where
+  compare (Error _ pos1) (Error _ pos2) = compare pos1 pos2
+
+showErrorList :: [Error] -> String
+showErrorList errs = unlines $ map show (sort errs)
+
+type Sym = (A.Ident, A.Type, SourcePos)
+
+type SymMap = Map.Map A.Ident Sym
+
+data Env = Env SymMap (Maybe Env) deriving (Show)
+
+-- first parameter tells if we look on the local environment
+-- or if we should check also in the parent(s)
+getSymB :: Bool -> Env -> A.Ident -> Maybe Sym
+getSymB local (Env m parent) id =
+  case (local, Map.lookup id m) of
+    (False, Nothing) -> do
+      p <- parent
+      getSym p id
+    (_, s) -> s
+
+-- get symbol
+getSym :: Env -> A.Ident -> Maybe Sym
+getSym = getSymB False
+
+-- get symbol local
+getSyml :: Env -> A.Ident -> Maybe Sym
+getSyml = getSymB True
+
+-- if a symbol exists
+existsSym :: Env -> A.Ident -> Bool
+existsSym env sym = isJust $ getSym env sym
+
+-- if a local symbol exists
+existsSyml :: Env -> A.Ident -> Bool
+existsSyml env sym = isJust $ getSyml env sym
+
+-- add symbol
+addSym :: Env -> Sym -> Env
+addSym (Env m parent) (id, typ, pos) = case getSym env id of
+  Nothing -> Env (Map.insert id sym m) parent
+  Just s -> Env (Map.singleton id sym) $ Just env
+  where
+    env = (Env m parent)
+    sym = (id, typ, pos)
+
+-- adds a new local environment
+addEnv :: Env -> Env
+addEnv env = Env Map.empty $ Just env
+
+-- add a local symbol if it doesn't exist
+addSymUniq :: Env -> Sym -> Either Error Env
+addSymUniq ev (id, typ, pos) = case getSyml ev id of
+  Nothing -> Right $ addSym ev sym
+  Just (_, _, p) -> Left $ Error ("\"" ++ id ++ "\" already defined in " ++ show p) pos
+  where
+    sym = (id, typ, pos)
+
+toFuncType :: [A.FuncParam] -> Maybe A.Type -> A.Type
+toFuncType params rtyp =
+  A.FuncType (map (\(_, t, _) -> t) params) rtyp
+
+type CompState = (Env, [Error])
+
+type CompResult = Either [Error] ()
+
+startState :: CompState
+startState = (Env Map.empty Nothing, [])
+
+compile :: [A.Expr] -> State CompState CompResult
+compile (x : xs) = do
+  case x of
+    (A.Module name pos) -> return $ Right ()
+    (A.BinOp _ a b) -> compile [a, b]
+    (A.Func ident params ret body priv pos) -> do
+      -- current env
+      (ev, errs) <- get
+      -- with function and parameters
+      (nev, nerrs) <-
+        return $ case addSymUniq ev (ident, toFuncType params ret, pos) of
+          Left e -> (ev, e : errs)
+          Right fev ->
+            foldl
+              ( \(ev, errs) (id, typ, pos) -> case addSymUniq ev (id, typ, pos) of
+                  Right ev -> (ev, errs)
+                  Left nerr -> (ev, nerr : errs)
+              )
+              (addEnv fev, errs)
+              params
+      put (nev, nerrs)
+      r <- compile body
+      (_, errs) <- get
+      put (ev, errs)
+      return r
+    (A.Call ident args pos) -> do
+      id <- compile [ident]
+      return $ Right ()
+    (A.Return value pos) -> case value of
+      Nothing -> return $ Right ()
+      Just v -> compile [v]
+    (A.Var ident pos) -> do
+      (ev, errs) <- get
+      if existsSym ev ident
+        then return $ Right ()
+        else do
+          put (ev, Error ("undefined variable \"" ++ ident ++ "\"") pos : errs)
+          return $ Right ()
+    _ -> compile []
+  compile xs
+compile [] = do
+  (_, errs) <- get
+  case errs of
+    [] -> return $ Right ()
+    _ -> return $ Left errs
-- 
cgit v1.2.3