Allow multiple print statements

README.md

@@ -10,13 +10,19 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
 
 - Install `ghcup` (for managing Haskell tools) and `nix` (for managing external dependencies).
 - Clone the repo.
-- Use `ghcup` to install `stack 2.9.3`, `HLS 2.2.0.0`, `GHC 9.2.8`, and `cabal 3.6.2.0`.
+- Use `ghcup` to install `stack 2.11.1`, `HLS 2.3.0.0`, and `cabal 3.8.1.0`.
 
 ## Run Instructions
 
 - Use `stack run <file>` to run the program (for example, `stack run example/1.hear`).
 - The LLVM will be generated as `a.out.ll`, and the executable will be generated as `a.out`.
 
+## Currently Supported functionality
+
+- Arithmetic
+- Parenthesis
+- print() statement
+
 ## To edit
 
 I recommend using VSCodium, which is preconfigured to have syntax highlighting and (currently broken) debugging features and will automatically suggest the Haskell extensions to install.
@@ -46,12 +52,13 @@ I recommend using VSCodium, which is preconfigured to have syntax highlighting a
 - https://danieljharvey.github.io/posts/2023-02-08-llvm-compiler-part-1.html (for help using llvm-hs-pure)
 - 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)
 
 ### Tools
 
 - Language: Haskell
-- Haskell tools: GHCup, Stack, Cabal, GHC 9.2
-- Libraries: megaparsec, parser-combinators, text, process, llvm-hs 15, llvm-hs-pure 15,
+- Haskell/management tools: GHCup, Stack, Cabal, GHC 9.2, Nix
+- Libraries: See `package.yaml`
 - Dependencies: llvm 15, clang 15
 - IDE: VSCodium
 - Git platform: Forgejo

example/1.hear

@@ -1 +1 @@
-(5*(3-2)+-4-4)
+print(5*(3-2)+-4-4);

example/2.hear

@@ -1 +1,2 @@
-6+8/3
+ print(6+8/3);
+ print(5000);

package.yaml

@@ -7,9 +7,14 @@ dependencies:
   - parser-combinators
   - text
   - process
+  - mtl
+  - containers
   - llvm-hs >= 15 && < 16
   - llvm-hs-pure >= 15 && < 16
   - bytestring
+  - string-conversions
+  - transformers
+  - optparse-applicative >= 0.17 && < 1
 tested-with: GHC == 9.2.8
 category: Compilers/Interpreters
 

really-bad-compiler-in-haskell.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.35.2.
 --
 -- see: https://github.com/sol/hpack
 
@@ -18,7 +18,7 @@ executable really-bad-compiler-in-haskell
   other-modules:
       Main.LLVMGen
       Main.Parser.Megaparsec
-      Main.Types.Expr
+      Main.Type
       Paths_really_bad_compiler_in_haskell
   hs-source-dirs:
       src
@@ -28,10 +28,15 @@ executable really-bad-compiler-in-haskell
   build-depends:
       base >=4.14.3 && <5
     , bytestring
+    , containers
     , llvm-hs ==15.*
     , llvm-hs-pure ==15.*
     , megaparsec >=9.0.1 && <10
+    , mtl
+    , optparse-applicative >=0.17 && <1
     , parser-combinators
     , process
+    , string-conversions
     , text
+    , transformers
   default-language: Haskell2010

src/Main.hs

@@ -7,17 +7,41 @@ import Data.ByteString.Char8 qualified as B
 import Data.Text.IO qualified as T
 import Main.LLVMGen
 import Main.Parser.Megaparsec
+import Options.Applicative
 import System.Environment
 import System.Process (callCommand)
 
-main :: IO ()
-main = do
-  fileName <- fmap head getArgs
+data Opt = Opt
+  { filePath :: String,
+    showLLVM :: Bool,
+    showDebug :: Bool
+  }
+
+run :: Opt -> IO ()
+run opts = do
+  let fileName = filePath opts
   contents <- T.readFile fileName
-  T.putStrLn "- Parsing file..."
-  let parsed = parse contents
   T.putStrLn "- Generating LLVM to './a.out.ll'..."
-  llvmGen parsed >>= B.writeFile "a.out.ll"
+  result <- (llvmGen . parse) contents
+  B.writeFile "a.out.ll" result
   T.putStrLn "- Compiling to executable './a.out'..."
   callCommand "clang a.out.ll"
   T.putStrLn "- Done."
+
+main :: IO ()
+main = execParser opts >>= run
+  where
+    parser =
+      Opt
+        <$> argument str (metavar "FILE_PATH")
+        <*> switch
+          ( short 'l'
+              <> long "showLLVM"
+              <> help "Create <file>.ll with LLVM used to compile the binary"
+          )
+        <*> switch
+          ( short 'd'
+              <> long "showDebug"
+              <> help "Show debug output"
+          )
+    opts = info parser mempty

src/Main/LLVMGen.hs

@@ -1,12 +1,19 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecursiveDo #-}
 
 -- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
+-- see https://blog.josephmorag.com/posts/mcc3/
 
 module Main.LLVMGen (llvmGen) where
 
+import Control.Monad.State
+import Control.Monad.Trans.Class (lift)
 import Data.ByteString (ByteString)
+import Data.Map qualified as M
+import Data.String.Conversions
+import Data.Text
 import LLVM (moduleLLVMAssembly, withModuleFromAST)
 import LLVM.AST hiding (function)
 import LLVM.AST.Type
@@ -15,27 +22,73 @@ import LLVM.IRBuilder.Constant
 import LLVM.IRBuilder.Instruction
 import LLVM.IRBuilder.Module
 import LLVM.IRBuilder.Monad
-import Main.Types.Expr as Expr
+import Main.Type as Expr
 
-getLLVM :: Expr -> Module
+data Env = Env
+  { operands :: M.Map Text Operand,
+    strings :: M.Map Text Operand
+  }
+  deriving (Eq, Show)
+
+registerOperand :: (MonadState Env m) => Text -> Operand -> m ()
+registerOperand name op =
+  modify $ \env -> env {operands = M.insert name op (operands env)}
+
+registerString :: (MonadState Env m) => Text -> Operand -> m ()
+registerString name op =
+  modify $ \env -> env {strings = M.insert name op (operands env)}
+
+getOperand :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
+getOperand name = do
+  env <- get
+  case M.lookup name (operands env) of
+    Just op -> return op
+    Nothing -> error $ "Unknown operand: " ++ show name
+
+getString :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
+getString str = do
+  env <- get
+  case M.lookup str (strings env) of
+    Just s -> return s
+    Nothing -> do
+      s <- globalStringPtr (unpack str) (mkName "str")
+      let operand = ConstantOperand s
+      modify $ \env -> env {strings = M.insert str operand (strings env)}
+      return operand
+
+getLLVM :: [Expr] -> Module
 getLLVM expr =
-  buildModule "program" $ mdo
-    -- TODO: better module name
-    printf <- externVarArgs "printf" [ptr] i32
-    function "main" [] i32 $ \_ -> mdo
-      numFormatStr <- globalStringPtr "%d\n" (mkName "str")
-      ourExpression <- exprToLLVM expr
-      _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
-      ret (int32 0)
+  flip evalState (Env {operands = M.empty, strings = M.empty}) $
+    buildModuleT "program" $ mdo
+      -- TODO: better module name
+      printf <- externVarArgs "printf" [ptr] i32
+      lift $ registerOperand "printf" printf
+      function "main" [] i32 $ \_ -> mdo
+        printNumStr <- globalStringPtr "%d\n" (mkName "str")
+        lift $ registerString "%d\n" $ ConstantOperand printNumStr
+        _ <- forM_ expr exprToLLVM
+        ret $ int32 0
+
+--
+-- ourExpression <- exprToLLVM expr
+-- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
+-- ret $ int32 0
 
 exprToLLVM ::
   ( MonadIRBuilder m,
-    MonadModuleBuilder m
+    MonadModuleBuilder m,
+    MonadState Env m
   ) =>
   Expr ->
   m Operand
 exprToLLVM (Lit prim) = pure $ primToLLVM prim
 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
 exprToLLVM (Expr.Add a b) = mdo
   lhs <- exprToLLVM a
   rhs <- exprToLLVM b
@@ -54,12 +107,9 @@ exprToLLVM (Expr.Div a b) = mdo
   sdiv lhs rhs
 
 primToLLVM :: Int -> Operand
-primToLLVM i = int32 (fromIntegral i)
+primToLLVM i = int32 $ fromIntegral i
 
-llvmGen :: Expr -> IO ByteString
+llvmGen :: [Expr] -> IO ByteString
 llvmGen expr = do
   let l = getLLVM expr
-  withContext
-    ( \c ->
-        withModuleFromAST c l moduleLLVMAssembly
-    )
+  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.Expr
+import Main.Type
 import Text.Megaparsec as MP hiding (parse)
 import Text.Megaparsec qualified as MP
 import Text.Megaparsec.Char qualified as C
@@ -50,13 +50,13 @@ table =
   ]
 
 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 <$ 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))
+methodOp name f = Prefix $ f <$ (string name <* C.space)
 
 -- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
 -- postfixOp name f = Postfix (f <$ symbol name)
@@ -64,11 +64,14 @@ methodOp name f = Prefix (f <$ (string name <* C.space))
 expr :: Parser Expr
 expr = makeExprParser term table
 
-parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr
-parseExpr = MP.parse (C.space *> expr <* eof) ""
+statement :: Parser Expr
+statement = expr <* symbol ";"
 
-parse :: Text -> Expr
-parse t = do
+parseExpr :: Text -> Either (ParseErrorBundle Text Void) [Expr]
+parseExpr = MP.parse (C.space *> many statement <* eof) ""
+
+parse :: Text -> [Expr]
+parse t =
   case parseExpr t of
     Right r -> r
 

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/Expr.hs

@@ -1,13 +0,0 @@
-module Main.Types.Expr (Expr (..)) where
-
-data Expr
-  = Lit Int
-  | Paren Expr
-  | Add Expr Expr
-  | Sub Expr Expr
-  | Mul Expr Expr
-  | Div Expr Expr
-  | Print Expr
-  deriving
-    ( Show
-    )

stack.yaml

@@ -1,4 +1,11 @@
 resolver: lts-20.26
+compiler: ghc-9.2.8
+# setup-info:
+#   ghc:
+#     aarch64:
+#       9.4.6:
+#         url: "https://downloads.haskell.org/~ghc/9.4.6/ghc-9.4.6-aarch64-deb10-linux.tar.xz"
+#         sha256: "05896fc4bc52c117d281eac9c621c6c3a0b14f9f9eed5e42cce5e1c4485c7623"
 
 packages:
   - .
@@ -12,4 +19,4 @@ nix:
   enable: true
   packages: [llvm_15, clang_15, libxml2]
 system-ghc: true
-install-ghc: true
+install-ghc: false