Merge pull request 'feature/comparisons' (#29) from feature/comparisons into main

Reviewed-on: https://git.sudoer.ch/me/really-bad-compiler-in-haskell/pulls/29

README.md

@@ -35,7 +35,7 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a
 
 ## File structure
 
-- `app` - contains the compiler program
+- `src` - contains the compiler program
 - `example` - contains example programs that can be compiled
 
 ## Credits
@@ -53,6 +53,9 @@ 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 +1,13 @@
-print(5*(3-2)+-4-4);
+printInt(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.Type
+      Main.Types
       Paths_really_bad_compiler_in_haskell
   hs-source-dirs:
       src

src/Main.hs

@@ -22,11 +22,15 @@ run opts = do
   let fileName = filePath opts
   contents <- T.readFile fileName
   T.putStrLn "- Generating LLVM to './a.out.ll'..."
-  result <- (llvmGen . parse) contents
+  let parseResult = 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,13 +16,15 @@ 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.Type as Expr
+import Main.Types qualified as T
 
 data Env = Env
   { operands :: M.Map Text Operand,
@@ -56,8 +58,8 @@ getString str = do
       modify $ \env -> env {strings = M.insert str operand (strings env)}
       return operand
 
-getLLVM :: [Expr] -> Module
+getLLVM :: [T.Statement] -> Module
-getLLVM expr =
+getLLVM statement =
   flip evalState (Env {operands = M.empty, strings = M.empty}) $
     buildModuleT "program" $ mdo
       -- TODO: better module name
@@ -66,7 +68,7 @@ getLLVM expr =
       function "main" [] i32 $ \_ -> mdo
         printNumStr <- globalStringPtr "%d\n" (mkName "str")
         lift $ registerString "%d\n" $ ConstantOperand printNumStr
-        _ <- forM_ expr exprToLLVM
+        _ <- forM_ statement statementToLLVM
         ret $ int32 0
 
 --
@@ -74,42 +76,106 @@ getLLVM expr =
 -- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
 -- ret $ int32 0
 
-exprToLLVM ::
+statementToLLVM ::
   ( MonadIRBuilder m,
     MonadModuleBuilder m,
     MonadState Env m
   ) =>
-  Expr ->
+  T.Statement ->
   m Operand
-exprToLLVM (Lit prim) = pure $ primToLLVM prim
+statementToLLVM (T.PrintInt e) = mdo
-exprToLLVM (Paren e) = exprToLLVM e
+  val <- intExprToLLVM 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
-exprToLLVM (Expr.Add a b) = mdo
+statementToLLVM (T.PrintBool e) = mdo
-  lhs <- exprToLLVM a
+  val <- boolExprToLLVM e
-  rhs <- exprToLLVM b
+  val32 <- zext val i32
+  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
-exprToLLVM (Expr.Sub a b) = mdo
+intExprToLLVM (T.IntArith T.Sub a b) = mdo
-  lhs <- exprToLLVM a
+  lhs <- intExprToLLVM a
-  rhs <- exprToLLVM b
+  rhs <- intExprToLLVM b
   sub lhs rhs
-exprToLLVM (Expr.Mul a b) = mdo
+intExprToLLVM (T.IntArith T.Mul a b) = mdo
-  lhs <- exprToLLVM a
+  lhs <- intExprToLLVM a
-  rhs <- exprToLLVM b
+  rhs <- intExprToLLVM b
   mul lhs rhs
-exprToLLVM (Expr.Div a b) = mdo
+intExprToLLVM (T.IntArith T.Div a b) = mdo
-  lhs <- exprToLLVM a
+  lhs <- intExprToLLVM a
-  rhs <- exprToLLVM b
+  rhs <- intExprToLLVM b
   sdiv lhs rhs
 
-primToLLVM :: Int -> Operand
+boolExprToLLVM ::
-primToLLVM i = int32 $ fromIntegral i
+  ( MonadIRBuilder m,
+    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 :: [Expr] -> IO ByteString
+llvmGen :: [T.Statement] -> 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.Type
+import Main.Types qualified as M
 import Text.Megaparsec as MP hiding (parse)
 import Text.Megaparsec qualified as MP
 import Text.Megaparsec.Char qualified as C
@@ -31,48 +31,115 @@ string = C.string
 container :: Text -> Text -> Parser a -> Parser a
 container b e = between (symbol b) (symbol e)
 
-term :: Parser Expr
+parens :: Parser a -> Parser a
-term =
+parens = container "(" ")"
+
+intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int
+intExprTerm =
   choice
-    [ Lit <$> int,
+    [ M.Int <$> int,
-      container "(" ")" expr
+      parens intExpr
     ]
 
-table :: [[Operator Parser Expr]]
+intExprTable :: [[Operator Parser M.Int]]
-table =
+intExprTable =
-  [ [methodOp "print" Print],
+  [ [ binaryOp "*" (M.IntArith M.Mul),
-    [ binaryOp "*" Mul,
+      binaryOp "/" (M.IntArith M.Div)
-      binaryOp "/" Div
     ],
-    [ binaryOp "+" Add,
+    [ binaryOp "+" (M.IntArith M.Add),
-      binaryOp "-" Sub
+      binaryOp "-" (M.IntArith M.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),
+      parens boolExpr,
+      uncurry3 M.IntEq <$> intEqExpr,
+      M.Bool True <$ string "true" <* C.space,
+      M.Bool False <$ string "false" <* C.space
+    ]
+
+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 <$ symbol name
+binaryOp name f = InfixL $ f <$ string name <* C.space
 
--- 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
 
-methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+statement :: Parser M.Statement
-methodOp name f = Prefix $ f <$ (string name <* C.space)
+statement =
+  choice
+    [ string "printInt" *> (M.PrintInt <$> parens intExpr),
+      string "printBool" *> (M.PrintBool <$> parens boolExpr)
+    ]
+    <* symbol ";"
 
--- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
--- postfixOp name f = Postfix (f <$ symbol name)
+parseStatements = MP.parse (C.space *> many statement <* eof) ""
 
-expr :: Parser Expr
+parse :: Text -> Either String [M.Statement]
-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 parseExpr t of
+  case parseStatements t of
-    Right r -> r
+    Right r -> Right r
+    Left e -> Left (errorBundlePretty e)
 
 -- TODO: add error handling

src/Main/Type.hs

@@ -1,30 +0,0 @@
-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

@@ -0,0 +1,42 @@
+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)