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
2023-10-23 17:31:28 +00:00 · 2023-10-23 17:31:28 +00:00 · 6953e77467
parent 2f790d6e55 1fbacda21b
commit 6953e77467
8 changed files with 258 additions and 94 deletions
--- a/README.md
+++ b/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

--- a/example/1.hear
+++ b/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));
--- a/really-bad-compiler-in-haskell.cabal
+++ b/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
--- a/src/Main.hs
+++ b/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
--- a/src/Main/LLVMGen.hs
+++ b/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 expr =
+getLLVM :: [T.Statement] -> Module
+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
-exprToLLVM (Paren e) = exprToLLVM e
-exprToLLVM (Print e) = mdo
-  val <- exprToLLVM e
+statementToLLVM (T.PrintInt e) = mdo
+  val <- intExprToLLVM e
  printf <- getOperand "printf"
  formatStr <- getString "%d\n"
  _ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])]
  pure val
-exprToLLVM (Expr.Add a b) = mdo
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
+statementToLLVM (T.PrintBool e) = mdo
+  val <- boolExprToLLVM e
+  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
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
+intExprToLLVM (T.IntArith T.Sub a b) = mdo
+  lhs <- intExprToLLVM a
+  rhs <- intExprToLLVM b
  sub lhs rhs
-exprToLLVM (Expr.Mul a b) = mdo
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
+intExprToLLVM (T.IntArith T.Mul a b) = mdo
+  lhs <- intExprToLLVM a
+  rhs <- intExprToLLVM b
  mul lhs rhs
-exprToLLVM (Expr.Div a b) = mdo
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
+intExprToLLVM (T.IntArith T.Div a b) = mdo
+  lhs <- intExprToLLVM a
+  rhs <- intExprToLLVM b
  sdiv lhs rhs

-primToLLVM :: Int -> Operand
-primToLLVM i = int32 $ fromIntegral i
+boolExprToLLVM ::
+  ( 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
--- a/src/Main/Parser/Megaparsec.hs
+++ b/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
-term =
+parens :: Parser a -> Parser a
+parens = container "(" ")"
+
+intExprTerm :: ParsecT Void Text Data.Functor.Identity.Identity M.Int
+intExprTerm =
  choice
-    [ Lit <$> int,
-      container "(" ")" expr
+    [ M.Int <$> int,
+      parens intExpr
    ]

-table :: [[Operator Parser Expr]]
-table =
-  [ [methodOp "print" Print],
-    [ binaryOp "*" Mul,
-      binaryOp "/" Div
+intExprTable :: [[Operator Parser M.Int]]
+intExprTable =
+  [ [ binaryOp "*" (M.IntArith M.Mul),
+      binaryOp "/" (M.IntArith M.Div)
    ],
-    [ binaryOp "+" Add,
-      binaryOp "-" Sub
+    [ binaryOp "+" (M.IntArith M.Add),
+      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 name f = Prefix (f <$ symbol name)
+prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+prefixOp name f = Prefix $ f <$ symbol name

-methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-methodOp name f = Prefix $ f <$ (string name <* C.space)
+statement :: Parser M.Statement
+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
-- postfixOp name f = Postfix (f <$ symbol name)
+parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
+parseStatements = MP.parse (C.space *> many statement <* eof) ""

-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 :: Text -> Either String [M.Statement]
 parse t =
-  case parseExpr t of
-    Right r -> r
+  case parseStatements t of
+    Right r -> Right r
+    Left e -> Left (errorBundlePretty e)

 -- TODO: add error handling
--- a/src/Main/Type.hs
+++ b/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
--       }
--- a/src/Main/Types.hs
+++ b/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)