Initial import

5 files changed, 376 insertions, 0 deletions

diff --git a/src/Ast.hs b/src/Ast.hs
new file mode 100644
index 0000000..c43eed4
--- /dev/null
+++ b/src/Ast.hs
@@ -0,0 +1,27 @@
+module Ast where
+
+import Text.Parsec (SourcePos)
+
+type Ident = String
+
+data Type = Type String | FuncType [Type] (Maybe Type) deriving (Eq, Ord, Show)
+
+type FuncParam = (Ident, Type, SourcePos)
+
+data Expr
+  = Num Integer SourcePos
+  | BinOp Op Expr Expr
+  | Var Ident SourcePos
+  | -- fn [params] return body private pos
+    Func Ident [FuncParam] (Maybe Type) [Expr] Bool SourcePos
+  | Call Expr [Expr] SourcePos
+  | Return (Maybe Expr) SourcePos
+  | Module String SourcePos
+  deriving (Eq, Ord, Show)
+
+data Op
+  = Plus
+  | Minus
+  | Mul
+  | Div
+  deriving (Eq, Ord, Show)
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
diff --git a/src/Lexer.hs b/src/Lexer.hs
new file mode 100644
index 0000000..4938cfe
--- /dev/null
+++ b/src/Lexer.hs
@@ -0,0 +1,49 @@
+module Lexer where
+
+import Text.Parsec
+import Text.Parsec.Language (emptyDef)
+import Text.Parsec.String (Parser)
+import qualified Text.Parsec.Token as T
+
+scanner :: T.TokenParser ()
+scanner = T.makeTokenParser style
+  where
+    ops = ["+", "*", "-", ";"]
+    names = ["module", "private", "def", "return", "->"]
+    style =
+      emptyDef
+        { T.commentLine = "//",
+          T.reservedOpNames = ops,
+          T.reservedNames = names
+        }
+
+integer :: Parser Integer
+integer = T.integer scanner
+
+parens :: Parser a -> Parser a
+parens = T.parens scanner
+
+braces :: Parser a -> Parser a
+braces = T.braces scanner
+
+commaSep :: Parser a -> Parser [a]
+commaSep = T.commaSep scanner
+
+colonSep :: Parser String
+colonSep = T.colon scanner
+
+identifier :: Parser String
+identifier = T.identifier scanner
+
+reserved :: String -> Parser ()
+reserved = T.reserved scanner
+
+reservedOp :: String -> Parser ()
+reservedOp = T.reservedOp scanner
+
+scan :: Parser a -> Parser a
+scan p = do
+  T.whiteSpace scanner
+  r <- p
+  eof
+  return r
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..e428ba5
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import Compiler
+import Control.Monad.State (evalState)
+import qualified Data.Map as Map
+import Lexer (scan)
+import Parser (parse, parseFromFile)
+import System.Exit (exitFailure)
+import System.IO (hPutStrLn, stderr, stdout)
+
+main :: IO ()
+main = do
+  res <- parseFromFile (scan parse) "input"
+  case res of
+    Left err -> hPutStrLn stderr ("error: " ++ show err) >> exitFailure
+    Right ast -> do
+      res <- return $ evalState (compile ast) startState
+      case res of
+        Right _ -> print ast
+        Left errs -> hPutStrLn stderr $ showErrorList errs
diff --git a/src/Parser.hs b/src/Parser.hs
new file mode 100644
index 0000000..1c21700
--- /dev/null
+++ b/src/Parser.hs
@@ -0,0 +1,148 @@
+module Parser where
+
+import Ast
+import Data.Maybe (isJust)
+import Lexer
+import Text.Parsec
+import qualified Text.Parsec.Expr as E
+import Text.Parsec.String (Parser)
+
+binary s f assoc = E.Infix (reservedOp s >> return (BinOp f)) assoc
+
+opTable =
+  [ [ binary "*" Mul E.AssocLeft,
+      binary "/" Div E.AssocLeft
+    ],
+    [ binary "+" Plus E.AssocLeft,
+      binary "-" Minus E.AssocLeft
+    ]
+  ]
+
+expr :: Parser Expr
+expr = E.buildExpressionParser opTable factor
+
+number :: Parser Expr
+number = do
+  pos <- getPosition
+  n <- integer
+  return $ Num n pos
+
+variable :: Parser Expr
+variable = do
+  pos <- getPosition
+  var <- identifier
+  return $ Var var pos
+
+typ :: Parser Type
+typ = do
+  p <- identifier
+  return $ Type p
+
+typFn :: Parser Type
+typFn = do
+  p <- parens $ commaSep typ
+  r <- optionMaybe $ do
+    reserved "->"
+    typ
+  return $ FuncType p r
+
+type' :: Parser Type
+type' = do
+  try typFn
+    <|> typ <?> "type"
+
+arg :: Parser (String, Type, SourcePos)
+arg = do
+  pos <- getPosition
+  i <- identifier
+  _ <- colonSep <?> "\":\" before type"
+  t <- type' <?> "type"
+  return $ (i, t, pos)
+
+fdef :: Ident -> Bool -> SourcePos -> Parser Expr
+fdef ident priv pos = do
+  args <- parens $ commaSep arg
+  rtyp <-
+    optionMaybe
+      ( do
+          _ <- colonSep <?> "\":\" before type"
+          rtyp <- type' <?> "return type"
+          return $ rtyp
+      )
+  body <- braces $ many statement
+  return $ Func ident args rtyp body priv pos
+
+function :: Parser Expr
+function = do
+  pos <- getPosition
+  priv <- optionMaybe $ reserved "private"
+  reserved "def"
+  ident <- identifier
+  fdef ident (isJust priv) pos
+
+lambdaId :: SourcePos -> Ident
+lambdaId s =
+  "lambda" ++ "@" ++ show (sourceLine s) ++ "," ++ show (sourceColumn s)
+
+lambda :: Parser Expr
+lambda = do
+  pos <- getPosition
+  fdef (lambdaId pos) True pos
+
+return' :: Parser Expr
+return' = do
+  pos <- getPosition
+  reserved "return"
+  value <- optionMaybe expr
+  reservedOp ";"
+  return $ Return value pos
+
+call :: Parser Expr
+call = do
+  pos <- getPosition
+  ident <- try lambda <|> variable
+  args <- parens $ commaSep expr
+  return $ Call ident args pos
+
+factor :: Parser Expr
+factor =
+  try number
+    <|> try call
+    <|> try lambda
+    <|> try variable
+    <|> parens expr
+
+exprStmt :: Parser Expr
+exprStmt = do
+  e <- expr <|> factor
+  reservedOp ";"
+  return $ e
+
+statement :: Parser Expr
+statement = do
+  try exprStmt
+    <|> return'
+
+module' :: Parser Expr
+module' = do
+  pos <- getPosition
+  reserved "module"
+  ident <- identifier
+  return $ Module ident pos
+
+program :: Parser [Expr]
+program = do
+  m <- module'
+  n <-
+    many $ do
+      try function
+        -- TODO: variable decl
+        <|> statement <?> "statement"
+  return $ [m] ++ n
+
+parse :: Parser [Expr]
+parse = program
+
+parseFromFile p fname = do
+  input <- readFile fname
+  return (runParser p () fname input)