Allow parsing signed integers

README.md

@@ -12,9 +12,17 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
 
 ## Run Instructions
 
-- Use `stack run <file>` to run the program (for example, `stack run example/1`).
+- Use `stack run <file>` to run the program (for example, `stack run example/1.fs`).
 - The LLVM will be generated as `a.out.ll`, and the executable will be generated as `a.out`.
 
+## Language
+
+It is planned to be similar to Forth, unless it turns out that Forth does not have the features I am looking for.
+
+Currently, it supports positive integers, `+`, `-`, `*`, `/`, and `.` (pops from stack and outputs to console).
+
+The supported syntax for this compiler aims to be compatible with Gforth.
+
 ## 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.

example/1

@@ -1 +0,0 @@
-5*3+2

example/1.fs

@@ -0,0 +1 @@
+5 3 * 2 + .

example/2

@@ -1 +0,0 @@
-6+8/3

example/2.fs

@@ -0,0 +1 @@
+6 8 3 / + .

main/Main.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main (main) where
-
--- import Compiler.ExeGen
-import Compiler.LLVMGen
-import Data.ByteString.Char8 qualified as B
-import Data.Text.Lazy.IO qualified as T
-import Parser.Expr
-import System.Environment
-import System.Process
-import Types.Expr
-
-getRight :: ParseResult -> Expr
-getRight (Right r) = r
-
-main :: IO ()
-main = do
-  fileName <- fmap head getArgs
-  contents <- readFile fileName
-  T.putStrLn "- Parsing file..."
-  let parsed = getRight (parseExpr contents)
-  T.putStrLn "- Generating LLVM to './a.out.ll'..."
-  llvmGen parsed >>= B.writeFile "a.out.ll"
-  T.putStrLn "- Compiling to executable './a.out'..."
-  callCommand "clang a.out.ll"
-  T.putStrLn "- Done."

package.yaml

@@ -19,7 +19,7 @@ ghc-options: -threaded -Wall -j8 +RTS -A64M -RTS -fllvm
 #   source-dirs: src
 
 executable:
-  source-dirs: main
+  source-dirs: src
   main: Main.hs
 # tests:
 #   testall:

really-bad-compiler-in-haskell.cabal

@@ -16,12 +16,12 @@ tested-with:
 executable really-bad-compiler-in-haskell
   main-is: Main.hs
   other-modules:
-      Compiler.LLVMGen
+      Forth.LLVMGen
-      Parser.Expr
+      Forth.Parser
-      Types.Expr
+      Forth.Types.Token
       Paths_really_bad_compiler_in_haskell
   hs-source-dirs:
-      main
+      src
   default-extensions:
       OverloadedStrings, LambdaCase
   ghc-options: -threaded -Wall -j8 +RTS -A64M -RTS -fllvm

src/Forth/LLVMGen.hs

@@ -4,13 +4,11 @@
 
 -- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
 
-module Compiler.LLVMGen (llvmGen) where
+module Forth.LLVMGen (llvmGen) where
-
--- import LLVM.Pretty
 
 import Data.ByteString (ByteString)
-import Debug.Trace
+import Forth.Types.Token as Token
-import LLVM (moduleLLVMAssembly, withModuleFromAST, writeLLVMAssemblyToFile)
+import LLVM (moduleLLVMAssembly, withModuleFromAST)
 import LLVM.AST hiding (function)
 import LLVM.AST.Type
 import LLVM.Context
@@ -18,9 +16,8 @@ import LLVM.IRBuilder.Constant
 import LLVM.IRBuilder.Instruction
 import LLVM.IRBuilder.Module
 import LLVM.IRBuilder.Monad
-import Types.Expr as Expr
 
-getLLVM :: Expr -> Module
+getLLVM :: Token -> Module
 getLLVM expr =
   buildModule "program" $ mdo
     -- TODO: better module name
@@ -35,22 +32,22 @@ exprToLLVM ::
   ( MonadIRBuilder m,
     MonadModuleBuilder m
   ) =>
-  Expr ->
+  Token ->
   m Operand
 exprToLLVM (Lit prim) = pure $ primToLLVM prim
-exprToLLVM (Expr.Add a b) = mdo
+exprToLLVM (Token.Add a b) = mdo
   lhs <- exprToLLVM a
   rhs <- exprToLLVM b
   add lhs rhs
-exprToLLVM (Expr.Sub a b) = mdo
+exprToLLVM (Token.Sub a b) = mdo
   lhs <- exprToLLVM a
   rhs <- exprToLLVM b
   sub lhs rhs
-exprToLLVM (Expr.Mul a b) = mdo
+exprToLLVM (Token.Mul a b) = mdo
   lhs <- exprToLLVM a
   rhs <- exprToLLVM b
   mul lhs rhs
-exprToLLVM (Expr.Div a b) = mdo
+exprToLLVM (Token.Div a b) = mdo
   lhs <- exprToLLVM a
   rhs <- exprToLLVM b
   sdiv lhs rhs
@@ -58,7 +55,7 @@ exprToLLVM (Expr.Div a b) = mdo
 primToLLVM :: Int -> Operand
 primToLLVM i = int32 (fromIntegral i)
 
-llvmGen :: Expr -> IO ByteString
+llvmGen :: Token -> IO ByteString
 llvmGen expr = do
   let l = getLLVM expr
   withContext

src/Forth/Parser.hs

@@ -0,0 +1,54 @@
+-- see https://markkarpov.com/tutorial/megaparsec.html
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forth.Parser (parse) where
+
+import Data.Text
+import Data.Void (Void)
+import Forth.Types.Token
+import Text.Megaparsec as MP hiding (Token, parse)
+import Text.Megaparsec qualified as MP
+import Text.Megaparsec.Char qualified as C
+import Text.Megaparsec.Char.Lexer qualified as L
+import Prelude hiding (div)
+
+type Parser = Parsec Void Text
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme C.space
+
+int :: Parser Int
+int = lexeme $ L.signed (return ()) L.decimal
+
+symbol :: Text -> Parser Text
+symbol = L.symbol C.space
+
+item :: Parser Token
+item =
+  try
+    ( Lit
+        <$> int
+    )
+    <|> Add
+    <$ symbol "+"
+      <|> Sub
+    <$ symbol "-"
+      <|> Mul
+    <$ symbol "*"
+      <|> Div
+    <$ symbol "/"
+      <|> Pop
+    <$ symbol "."
+
+items :: Parser [Token]
+items = many item
+
+parseItems :: Text -> Either (ParseErrorBundle Text Void) [Token]
+parseItems = MP.parse items ""
+
+parse :: Text -> [Token]
+parse t = do
+  case parseItems t of
+    Left err -> [] -- putStrLn $ errorBundlePretty err
+    Right tns -> tns

src/Forth/Parser.hs.old

@@ -1,22 +1,24 @@
 -- see https://markkarpov.com/tutorial/megaparsec.html
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
 
-module Parser.Expr (parseExpr, ParseResult) where
+module Forth.Parser (parseExpr, ParseResult) where
 
 import Control.Monad.Combinators.Expr
 import Data.Functor.Identity qualified
+import Data.Text.Lazy
 import Data.Void (Void)
+import Forth.Types.Expr
 import Text.Megaparsec as MP
 import Text.Megaparsec.Char as C
 import Text.Megaparsec.Char.Lexer as L
-import Types.Expr
 
-type Parser = Parsec Void String
+type Parser = Parsec Void Text
 
 lexemeParser :: Parser a -> Parser a
 lexemeParser = L.lexeme C.space
 
-symbolParser :: String -> Parser String
+symbolParser :: Text -> Parser Text
 symbolParser = L.symbol C.space
 
 intParser :: Parser Int
@@ -32,18 +34,25 @@ table =
     ],
     [ binaryOp "+" Add,
       binaryOp "-" Sub
+      -- binaryOp "." Pop
     ]
   ]
 
-binaryOp :: String -> (a -> a -> a) -> Operator (ParsecT Void String Data.Functor.Identity.Identity) a
+binaryOp :: Text -> (a -> a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
 binaryOp name f = InfixL (f <$ symbolParser name)
 
+-- prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+-- prefixOp name f = Prefix (f <$ symbolParser name)
+
+-- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+-- postfixOp name f = Postfix (f <$ symbolParser name)
+
 expr :: Parser Expr
 expr = makeExprParser term table
 
-type ParseResult = Either (ParseErrorBundle String Void) Expr
+type ParseResult = Either (ParseErrorBundle Text Void) Expr
 
-parseExpr :: String -> ParseResult
+parseExpr :: Text -> ParseResult
 parseExpr = MP.parse (C.space *> expr <* eof) ""
 
 -- parseE = parseExpr

src/Forth/Types/Expr.hs.old

@@ -1,4 +1,4 @@
-module Types.Expr (Expr (..)) where
+module Forth.Types.Expr (Expr (..)) where
 
 data Expr
   = Lit Int
@@ -6,6 +6,7 @@ data Expr
   | Sub Expr Expr
   | Mul Expr Expr
   | Div Expr Expr
+  | Pop Expr Expr
   deriving
     ( Show
     )

src/Forth/Types/Token.hs

@@ -0,0 +1,12 @@
+module Forth.Types.Token (Token (..)) where
+
+data Token
+  = Lit Int
+  | Add
+  | Sub
+  | Mul
+  | Div
+  | Pop
+  deriving
+    ( Show
+    )

src/Main.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Data.ByteString.Char8 qualified as B
+import Data.Text.IO qualified as T
+import Forth.LLVMGen
+import Forth.Parser
+import System.Environment
+import System.Process
+
+main :: IO ()
+main = do
+  fileName <- fmap head getArgs
+  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"
+  -- T.putStrLn "- Compiling to executable './a.out'..."
+  -- callCommand "clang a.out.ll"
+  T.putStrLn "- Done."