Parse expr tokens to list

really-bad-compiler-in-haskell.cabal

@@ -19,6 +19,7 @@ executable really-bad-compiler-in-haskell
       Forth.LLVMGen
       Forth.Parser
       Forth.Types.Expr
+      Forth.Types.Token
       Paths_really_bad_compiler_in_haskell
   hs-source-dirs:
       src

src/Forth/Parser.hs

@@ -2,57 +2,51 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Forth.Parser (parseExpr, ParseResult) where
+module Forth.Parser (parse) where
 
-import Control.Monad.Combinators.Expr
+import Data.Text
-import Data.Functor.Identity qualified
-import Data.Text.Lazy
 import Data.Void (Void)
-import Forth.Types.Expr
+import Forth.Types.Token
-import Text.Megaparsec as MP
+import Text.Megaparsec as MP hiding (Token, parse)
-import Text.Megaparsec.Char as C
+import Text.Megaparsec qualified as MP
-import Text.Megaparsec.Char.Lexer as L
+import Text.Megaparsec.Char qualified as C
+import Text.Megaparsec.Char.Lexer qualified as L
+import Prelude hiding (div)
 
 type Parser = Parsec Void Text
 
-lexemeParser :: Parser a -> Parser a
+lexeme :: Parser a -> Parser a
-lexemeParser = L.lexeme C.space
+lexeme = L.lexeme C.space
 
-symbolParser :: Text -> Parser Text
+int :: Parser Int
-symbolParser = L.symbol C.space
+int = lexeme L.decimal
 
-intParser :: Parser Int
+symbol :: Text -> Parser Text
-intParser = lexemeParser L.decimal
+symbol = L.symbol C.space
 
-term :: Parser Expr
+item :: Parser Token
-term = Lit <$> intParser
+item =
+  Lit
+    <$> int
+      <|> Add
+    <$ symbol "+"
+      <|> Sub
+    <$ symbol "-"
+      <|> Mul
+    <$ symbol "*"
+      <|> Div
+    <$ symbol "/"
+      <|> Pop
+    <$ symbol "."
 
-table :: [[Operator Parser Expr]]
+items :: Parser [Token]
-table =
+items = many item
-  [ [ binaryOp "*" Mul,
-      binaryOp "/" Div
-    ],
-    [ binaryOp "+" Add,
-      binaryOp "-" Sub
-      -- binaryOp "." Pop
-    ]
-  ]
 
-binaryOp :: Text -> (a -> a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+parseItems :: Text -> Either (ParseErrorBundle Text Void) [Token]
-binaryOp name f = InfixL (f <$ symbolParser name)
+parseItems = MP.parse items ""
 
--- prefixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+parse :: Text -> [Token]
--- prefixOp name f = Prefix (f <$ symbolParser name)
+parse t = do
-
+  case parseItems t of
--- postfixOp :: Text -> (a -> a) -> Operator (ParsecT Void Text Data.Functor.Identity.Identity) a
+    Left err -> [] -- putStrLn $ errorBundlePretty err
--- postfixOp name f = Postfix (f <$ symbolParser name)
+    Right tns -> tns
-
-expr :: Parser Expr
-expr = makeExprParser term table
-
-type ParseResult = Either (ParseErrorBundle Text Void) Expr
-
-parseExpr :: Text -> ParseResult
-parseExpr = MP.parse (C.space *> expr <* eof) ""
-
--- parseE = parseExpr

src/Forth/Parser.hs.old

@@ -0,0 +1,58 @@
+-- see https://markkarpov.com/tutorial/megaparsec.html
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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
+
+type Parser = Parsec Void Text
+
+lexemeParser :: Parser a -> Parser a
+lexemeParser = L.lexeme C.space
+
+symbolParser :: Text -> Parser Text
+symbolParser = L.symbol C.space
+
+intParser :: Parser Int
+intParser = lexemeParser L.decimal
+
+term :: Parser Expr
+term = Lit <$> intParser
+
+table :: [[Operator Parser Expr]]
+table =
+  [ [ binaryOp "*" Mul,
+      binaryOp "/" Div
+    ],
+    [ binaryOp "+" Add,
+      binaryOp "-" Sub
+      -- binaryOp "." Pop
+    ]
+  ]
+
+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 Text Void) Expr
+
+parseExpr :: Text -> ParseResult
+parseExpr = MP.parse (C.space *> expr <* eof) ""
+
+-- parseE = parseExpr

src/Forth/Types/Expr.hs

@@ -6,7 +6,7 @@ data Expr
   | Sub Expr Expr
   | Mul Expr Expr
   | Div Expr Expr
+  | Pop Expr Expr
   deriving
-    ( -- | Pop Expr Expr
+    ( Show
-      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

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