From a7547dd670d2c03d1bae49de150cbeca7941a67d Mon Sep 17 00:00:00 2001
From: sudoer777 <git@sudoer.ch>
Date: Sat, 7 Oct 2023 22:46:37 -0500
Subject: [PATCH] Parse expressions into different types

---
 README.md                            |  1 +
 really-bad-compiler-in-haskell.cabal |  2 +-
 src/Main/LLVMGen.hs                  | 53 ++++++++++++++++------------
 src/Main/Parser/Megaparsec.hs        | 53 ++++++++++++----------------
 src/Main/Type.hs                     | 30 ----------------
 src/Main/Types.hs                    | 33 +++++++++++++++++
 6 files changed, 88 insertions(+), 84 deletions(-)
 delete mode 100644 src/Main/Type.hs
 create mode 100644 src/Main/Types.hs

diff --git a/README.md b/README.md
index 3f59fd2..17ef438 100644
--- a/README.md
+++ b/README.md
@@ -53,6 +53,7 @@ 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)
 
 ### Tools
 
diff --git a/really-bad-compiler-in-haskell.cabal b/really-bad-compiler-in-haskell.cabal
index 0b1bace..18fcdd1 100644
--- 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
diff --git a/src/Main/LLVMGen.hs b/src/Main/LLVMGen.hs
index 620e168..57b8ed8 100644
--- a/src/Main/LLVMGen.hs
+++ b/src/Main/LLVMGen.hs
@@ -22,7 +22,7 @@ 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 +56,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 +66,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 +74,49 @@ 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.Print 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
+
+intExprToLLVM ::
+  ( MonadIRBuilder m,
+    MonadModuleBuilder m,
+    MonadState Env m
+  ) =>
+  T.Int ->
+  m Operand
+intExprToLLVM (T.Int prim) = pure $ primToLLVM 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
 
-llvmGen :: [Expr] -> IO ByteString
+llvmGen :: [T.Statement] -> IO ByteString
 llvmGen expr = do
   let l = getLLVM expr
   withContext $ \c -> withModuleFromAST c l moduleLLVMAssembly
\ No newline at end of file
diff --git a/src/Main/Parser/Megaparsec.hs b/src/Main/Parser/Megaparsec.hs
index aa1ea72..ec90c9f 100644
--- 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,41 @@ 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
+
 binaryOp :: Text -> (a -> a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
 binaryOp name f = InfixL $ f <$ symbol name
 
--- prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
--- prefixOp name f = Prefix (f <$ symbol name)
+statement :: Parser M.Statement
+statement = string "print" *> (M.Print <$> parens intExpr) <* symbol ";"
 
-methodOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
-methodOp name f = Prefix $ f <$ (string name <* C.space)
+parseStatements :: Text -> Either (ParseErrorBundle Text Void) [M.Statement]
+parseStatements = MP.parse (C.space *> many statement <* eof) ""
 
--- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
--- postfixOp name f = Postfix (f <$ symbol name)
-
-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 -> [M.Statement]
 parse t =
-  case parseExpr t of
+  case parseStatements t of
     Right r -> r
 
 -- TODO: add error handling
\ No newline at end of file
diff --git a/src/Main/Type.hs b/src/Main/Type.hs
deleted file mode 100644
index 23178b8..0000000
--- a/src/Main/Type.hs
+++ /dev/null
@@ -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
---       }
\ No newline at end of file
diff --git a/src/Main/Types.hs b/src/Main/Types.hs
new file mode 100644
index 0000000..81a33d4
--- /dev/null
+++ b/src/Main/Types.hs
@@ -0,0 +1,33 @@
+module Main.Types
+  ( ArithOp (..),
+    EqOp (..),
+    OrdCmpOp (..),
+    -- BinExpr (..),
+    Int (..),
+    Bool (..),
+    Statement (..),
+  )
+where
+
+import qualified Prelude as P
+
+data ArithOp = Add | Sub | Mul | Div
+
+data EqOp = Eq | Neq
+
+data OrdCmpOp = GT | GTE | LT | LTE
+
+-- newtype BinExpr op i o = BinExpr (op -> i -> i -> o)
+
+data Int
+  = Int P.Int
+  | IntArith ArithOp Int Int -- (BinExpr ArithOp Int Int)
+
+data Bool
+  = Bool P.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)
+
+data Statement
+  = Print Int
\ No newline at end of file