README.md

@@ -35,7 +35,7 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a
 
 ## File structure
 
-- `src` - contains the compiler program
+- `app` - contains the compiler program
 - `example` - contains example programs that can be compiled
 
 ## Credits
@@ -53,9 +53,6 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a
 - https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs (source code for above resource)
 - https://9to5tutorial.com/homebrew-compiler-made-with-haskell-llvm-configuration (for help using llvm-hs-pure)
 - https://blog.ocharles.org.uk/blog/posts/2012-12-17-24-days-of-hackage-optparse-applicative.html (for help parsing command line arguments with optparse-applicative)
-- http://learnyouahaskell.com/making-our-own-types-and-typeclasses (for help defining types)
-- https://llvm.org/docs/LangRef.html (LLVM documentation)
-- https://hackage.haskell.org/package/llvm-hs-pure-9.0.0/docs/ (llvm-hs documentation)
 
 ### Tools
 

example/1.hear

@@ -1,13 +1 @@
-printInt(5*(3-2)+-4-4);
+print(5*(3-2)+-4-4);
-printBool(true);
-printBool(false);
-printBool(5 * 3 >= 5 + 9);
-printBool(5*(3-2)+-4-4 < -3);
-printBool(5 == 5);
-printBool(5 == 6);
-printBool(5 != 5);
-printBool(true == true);
-printBool(true && true);
-printBool(true && false);
-printBool(!true);
-printBool(!(5 == 5));

really-bad-compiler-in-haskell.cabal

@@ -18,7 +18,7 @@ executable really-bad-compiler-in-haskell
   other-modules:
       Main.LLVMGen
       Main.Parser.Megaparsec
-      Main.Types
+      Main.Type
       Paths_really_bad_compiler_in_haskell
   hs-source-dirs:
       src

src/Main.hs

@@ -22,15 +22,11 @@ run opts = do
   let fileName = filePath opts
   contents <- T.readFile fileName
   T.putStrLn "- Generating LLVM to './a.out.ll'..."
-  let parseResult = parse contents
+  result <- (llvmGen . parse) contents
-  case parseResult of
-    Right r -> do
-      result <- llvmGen r
   B.writeFile "a.out.ll" result
   T.putStrLn "- Compiling to executable './a.out'..."
   callCommand "clang a.out.ll"
   T.putStrLn "- Done."
-    Left l -> putStrLn l
 
 main :: IO ()
 main = execParser opts >>= run

src/Main/LLVMGen.hs

@@ -16,15 +16,13 @@ import Data.String.Conversions
 import Data.Text
 import LLVM (moduleLLVMAssembly, withModuleFromAST)
 import LLVM.AST hiding (function)
-import LLVM.AST.IntegerPredicate
 import LLVM.AST.Type
-import LLVM.AST.Type qualified as AST
 import LLVM.Context
 import LLVM.IRBuilder.Constant
 import LLVM.IRBuilder.Instruction
 import LLVM.IRBuilder.Module
 import LLVM.IRBuilder.Monad
-import Main.Types qualified as T
+import Main.Type as Expr
 
 data Env = Env
   { operands :: M.Map Text Operand,
@@ -58,8 +56,8 @@ getString str = do
       modify $ \env -> env {strings = M.insert str operand (strings env)}
       return operand
 
-getLLVM :: [T.Statement] -> Module
+getLLVM :: [Expr] -> Module
-getLLVM statement =
+getLLVM expr =
   flip evalState (Env {operands = M.empty, strings = M.empty}) $
     buildModuleT "program" $ mdo
       -- TODO: better module name
@@ -68,7 +66,7 @@ getLLVM statement =
       function "main" [] i32 $ \_ -> mdo
         printNumStr <- globalStringPtr "%d\n" (mkName "str")
         lift $ registerString "%d\n" $ ConstantOperand printNumStr
-        _ <- forM_ statement statementToLLVM
+        _ <- forM_ expr exprToLLVM
         ret $ int32 0
 
 --
@@ -76,106 +74,42 @@ getLLVM statement =
 -- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
 -- ret $ int32 0
 
-statementToLLVM ::
+exprToLLVM ::
   ( MonadIRBuilder m,
     MonadModuleBuilder m,
     MonadState Env m
   ) =>
-  T.Statement ->
+  Expr ->
   m Operand
-statementToLLVM (T.PrintInt e) = mdo
+exprToLLVM (Lit prim) = pure $ primToLLVM prim
-  val <- intExprToLLVM e
+exprToLLVM (Paren e) = exprToLLVM e
+exprToLLVM (Print e) = mdo
+  val <- exprToLLVM e
   printf <- getOperand "printf"
   formatStr <- getString "%d\n"
   _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])]
   pure val
-statementToLLVM (T.PrintBool e) = mdo
+exprToLLVM (Expr.Add a b) = mdo
-  val <- boolExprToLLVM e
+  lhs <- exprToLLVM a
-  val32 <- zext val i32
+  rhs <- exprToLLVM b
-  printf <- getOperand "printf"
-  formatStr <- getString "%d\n"
-  _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val32, [])]
-  pure val
-
-intExprToLLVM ::
-  ( MonadIRBuilder m,
-    MonadModuleBuilder m,
-    MonadState Env m
-  ) =>
-  T.Int ->
-  m Operand
-intExprToLLVM (T.Int prim) = pure $ int32 $ fromIntegral prim
-intExprToLLVM (T.IntArith T.Add a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
   add lhs rhs
-intExprToLLVM (T.IntArith T.Sub a b) = mdo
+exprToLLVM (Expr.Sub a b) = mdo
-  lhs <- intExprToLLVM a
+  lhs <- exprToLLVM a
-  rhs <- intExprToLLVM b
+  rhs <- exprToLLVM b
   sub lhs rhs
-intExprToLLVM (T.IntArith T.Mul a b) = mdo
+exprToLLVM (Expr.Mul a b) = mdo
-  lhs <- intExprToLLVM a
+  lhs <- exprToLLVM a
-  rhs <- intExprToLLVM b
+  rhs <- exprToLLVM b
   mul lhs rhs
-intExprToLLVM (T.IntArith T.Div a b) = mdo
+exprToLLVM (Expr.Div a b) = mdo
-  lhs <- intExprToLLVM a
+  lhs <- exprToLLVM a
-  rhs <- intExprToLLVM b
+  rhs <- exprToLLVM b
   sdiv lhs rhs
 
-boolExprToLLVM ::
+primToLLVM :: Int -> Operand
-  ( MonadIRBuilder m,
+primToLLVM i = int32 $ fromIntegral i
-    MonadModuleBuilder m,
-    MonadState Env m
-  ) =>
-  T.Bool ->
-  m Operand
-boolExprToLLVM (T.Bool prim) =
-  if prim then pure $ bit 1 else pure $ bit 0
-boolExprToLLVM (T.IntOrdCmp T.GT a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp SGT lhs rhs
-boolExprToLLVM (T.IntOrdCmp T.GTE a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp SGE lhs rhs
-boolExprToLLVM (T.IntOrdCmp T.LT a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp SLT lhs rhs
-boolExprToLLVM (T.IntOrdCmp T.LTE a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp SLE lhs rhs
-boolExprToLLVM (T.IntEq T.EQ a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp LLVM.AST.IntegerPredicate.EQ lhs rhs
-boolExprToLLVM (T.IntEq T.NE a b) = mdo
-  lhs <- intExprToLLVM a
-  rhs <- intExprToLLVM b
-  icmp LLVM.AST.IntegerPredicate.NE lhs rhs
-boolExprToLLVM (T.BoolEq T.EQ a b) = mdo
-  lhs <- boolExprToLLVM a
-  rhs <- boolExprToLLVM b
-  icmp LLVM.AST.IntegerPredicate.EQ lhs rhs
-boolExprToLLVM (T.BoolEq T.NE a b) = mdo
-  lhs <- boolExprToLLVM a
-  rhs <- boolExprToLLVM b
-  icmp LLVM.AST.IntegerPredicate.NE lhs rhs
-boolExprToLLVM (T.BoolLogic T.AND a b) = mdo
-  lhs <- boolExprToLLVM a
-  rhs <- boolExprToLLVM b
-  LLVM.IRBuilder.Instruction.and lhs rhs
-boolExprToLLVM (T.BoolLogic T.OR a b) = mdo
-  lhs <- boolExprToLLVM a
-  rhs <- boolExprToLLVM b
-  LLVM.IRBuilder.Instruction.or lhs rhs
-boolExprToLLVM (T.BoolNeg a) = mdo
-  l <- boolExprToLLVM a
-  LLVM.IRBuilder.Instruction.xor l $ bit 1
 
-llvmGen :: [T.Statement] -> IO ByteString
+llvmGen :: [Expr] -> IO ByteString
 llvmGen expr = do
   let l = getLLVM expr
   withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly

src/Main/Parser/Megaparsec.hs

@@ -8,7 +8,7 @@ import Control.Monad.Combinators.Expr
 import Data.Functor.Identity qualified
 import Data.Text
 import Data.Void (Void)
-import Main.Types qualified as M
+import Main.Type
 import Text.Megaparsec as MP hiding (parse)
 import Text.Megaparsec qualified as MP
 import Text.Megaparsec.Char qualified as C
@@ -31,115 +31,48 @@ string = C.string
 container :: Text -> Text -> Parser a -> Parser a
 container b e = between (symbol b) (symbol e)
 
-parens :: Parser a -> Parser a
+term :: Parser Expr
-parens = container "(" ")"
+term =
-
-intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int
-intExprTerm =
   choice
-    [ M.Int <$> int,
+    [ Lit <$> int,
-      parens intExpr
+      container "(" ")" expr
     ]
 
-intExprTable :: [[Operator Parser M.Int]]
+table :: [[Operator Parser Expr]]
-intExprTable =
+table =
-  [ [ binaryOp "*" (M.IntArith M.Mul),
+  [ [methodOp "print" Print],
-      binaryOp "/" (M.IntArith M.Div)
+    [ binaryOp "*" Mul,
+      binaryOp "/" Div
     ],
-    [ binaryOp "+" (M.IntArith M.Add),
+    [ binaryOp "+" Add,
-      binaryOp "-" (M.IntArith M.Sub)
+      binaryOp "-" Sub
     ]
   ]
 
-intExpr :: Parser M.Int
-intExpr = makeExprParser intExprTerm intExprTable
-
-intOrdCmpExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.OrdCmpOp, M.Int, M.Int)
-intOrdCmpExpr = do
-  b <- intExpr
-  a <-
-    choice
-      [ M.GTE <$ string ">=" <* C.space,
-        M.LTE <$ string "<=" <* C.space,
-        M.GT <$ string ">" <* C.space,
-        M.LT <$ string "<" <* C.space
-      ]
-  c <- intExpr
-  return (a, b, c)
-
-intEqExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.EqOp, M.Int, M.Int)
-intEqExpr = do
-  b <- intExpr
-  a <-
-    choice
-      [ M.EQ <$ string "==" <* C.space,
-        M.NE <$ string "!=" <* C.space
-      ]
-  c <- intExpr
-  return (a, b, c)
-
-boolExprTable :: [[Operator Parser M.Bool]]
-boolExprTable =
-  [ [ binaryOp "==" (M.BoolEq M.EQ),
-      binaryOp "!=" (M.BoolEq M.NE)
-    ],
-    [prefixOp "!" M.BoolNeg],
-    [binaryOp "&&" (M.BoolLogic M.AND)],
-    [binaryOp "||" (M.BoolLogic M.OR)]
-  ]
-
--- boolEqExpr :: ParsecT Void Text Data.Functor.Identity.Identity (M.EqOp, M.Bool, M.Bool)
--- boolEqExpr = do
---   b <-
---       choice
---       [
-
---       ]
---   a <-
---     choice
---       [ M.EQ <$ string "==" <* C.space,
---         M.NE <$ string "!=" <* C.space
---       ]
---   c <- intExpr
---   return (a, b, c)
-
-uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
-uncurry3 f (x, y, z) = f x y z
-
-boolExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Bool
-boolExprTerm =
-  choice
-    [ try (uncurry3 M.IntOrdCmp <$> intOrdCmpExpr),
-      uncurry3 M.IntEq <$> intEqExpr,
-      M.Bool True <$ string "true" <* C.space,
-      M.Bool False <$ string "false" <* C.space,
-      parens boolExpr
-    ]
-
-boolExpr :: ParsecT Void Text Data.Functor.Identity.Identity M.Bool
-boolExpr = makeExprParser boolExprTerm boolExprTable
-
 binaryOp :: Text -> (a -> a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-binaryOp name f = InfixL $ f <$ string name <* C.space
+binaryOp name f = InfixL $ f <$ symbol name
 
-prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+-- prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-prefixOp name f = Prefix $ f <$ symbol name
+-- prefixOp name f = Prefix (f <$ symbol name)
 
-statement :: Parser M.Statement
+methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-statement =
+methodOp name f = Prefix $ f <$ (string name <* C.space)
-  choice
-    [ string "printInt" *> (M.PrintInt <$> parens intExpr),
-      string "printBool" *> (M.PrintBool <$> parens boolExpr)
-    ]
-    <* symbol ";"
 
-parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
+-- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-parseStatements = MP.parse (C.space *> many statement <* eof) ""
+-- postfixOp name f = Postfix (f <$ symbol name)
 
-parse :: Text -> Either String [M.Statement]
+expr :: Parser Expr
+expr = makeExprParser term table
+
+statement :: Parser Expr
+statement = expr <* symbol ";"
+
+parseExpr :: Text -> Either (ParseErrorBundle Text Void) [Expr]
+parseExpr = MP.parse (C.space *> many statement <* eof) ""
+
+parse :: Text -> [Expr]
 parse t =
-  case parseStatements t of
+  case parseExpr t of
-    Right r -> Right r
+    Right r -> r
-    Left e -> Left (errorBundlePretty e)
 
 -- TODO: add error handling

src/Main/Type.hs

@@ -0,0 +1,30 @@
+module Main.Type
+  ( Expr (..),
+  -- AST (..)
+  )
+where
+
+import Data.Graph (Tree (Node))
+
+data Expr
+  = Lit Int
+  | Paren Expr
+  | Add Expr Expr
+  | Sub Expr Expr
+  | Mul Expr Expr
+  | Div Expr Expr
+  | Print Expr
+  deriving
+    ( Show
+    )
+
+-- data AST = AST Node
+
+-- data Node
+--   = Reg
+--       { cur :: Expr,
+--         next :: Node
+--       }
+--   | End
+--       { cur :: Expr
+--       }

src/Main/Types.hs

@@ -1,42 +0,0 @@
-module Main.Types
-  ( ArithOp (..),
-    EqOp (..),
-    OrdCmpOp (..),
-    LogicOp (..),
-    -- BinExpr (..),
-    Int (..),
-    Bool (..),
-    Statement (..),
-  )
-where
-
-import qualified Prelude as P
-
-data ArithOp = Add | Sub | Mul | Div deriving (P.Show)
-
-data EqOp = EQ | NE deriving (P.Show)
-
-data OrdCmpOp = GT | GTE | LT | LTE deriving (P.Show)
-
-data LogicOp = AND | OR deriving (P.Show)
-
--- newtype BinExpr op i o = BinExpr (op -> i -> i -> o)
-
-data Int
-  = Int P.Int
-  | IntArith ArithOp Int Int -- (BinExpr ArithOp Int Int)
-  deriving (P.Show)
-
-data Bool
-  = Bool P.Bool
-  | BoolNeg Bool
-  | IntEq EqOp Int Int -- (BinExpr EqOp Int Bool)
-  | IntOrdCmp OrdCmpOp Int Int -- (BinExpr OrdCmpOp Int Bool)
-  | BoolEq EqOp Bool Bool -- (BinExpr EqOp Bool Bool)
-  | BoolLogic LogicOp Bool Bool
-  deriving (P.Show)
-
-data Statement
-  = PrintInt Int
-  | PrintBool Bool
-  deriving (P.Show)