Chapter 6 finished

app/Main.hs

@@ -2,6 +2,7 @@
 
 module Main (main) where
 
+import AstPrinter qualified
 import CmdlineOptions qualified
 import Control.Monad
 import Control.Monad.IO.Class
@@ -11,6 +12,7 @@ import Data.ByteString.Char8 qualified as B
 import Data.Foldable (traverse_)
 import Data.IORef qualified as IORef
 import Error qualified
+import Parser (parse)
 import Scanner
 import System.Exit qualified
 
@@ -50,8 +52,16 @@ runPrompt = forever $ do
 
 run :: MonadIO m => ByteString -> ReaderT Global m ()
 run sourceBS = do
-  (tokens, err) <- liftIO $ scanTokens sourceBS
+  (tokens, err1) <- liftIO $ scanTokens sourceBS
   liftIO $ traverse_ print tokens
-  case err of
-    Error.NoError -> pure ()
+  (m, err2) <- liftIO $ parse tokens
+  case m of
+    Nothing -> do
+      -- lift . liftIO $ B.putStrLn "no parse success"
+      pure ()
+    Just r -> do
+      -- lift . liftIO $ B.putStrLn "parse success"
+      lift . liftIO $ B.putStrLn (AstPrinter.printAst r)
+  case err1 <> err2 of
     Error.Error -> ask >>= \ref -> liftIO $ IORef.writeIORef ref.unGlobal Error.Error
+    Error.NoError -> pure ()

src/AstPrinter.hs

@@ -18,9 +18,11 @@ printAst = BS.toStrict . BS.toLazyByteString . go
       EGrouping expr -> paren "group" [go expr]
       ELiteral litValue ->
         case litValue of
-          NoLit -> "nil"
+          NoLit -> ""
           LitStr str -> BS.byteString str
           LitNum num -> BS.stringUtf8 $ show num
+          LitBool b -> (if b then "true" else "false")
+          LitNil -> "nil"
       EUnary operator expr -> paren (BS.byteString operator.lexeme) [go expr]
       where
         paren :: BS.Builder -> [BS.Builder] -> BS.Builder

src/Error.hs

@@ -11,7 +11,7 @@ import TokenType (Token (..), TokenType (..))
 data ErrorPresent
   = NoError
   | Error
-  deriving (Show)
+  deriving (Show, Eq)
 
 -- Behaves like Data.Monoid.Any
 instance Semigroup ErrorPresent where

src/Parser.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-module Parser where
+{-# HLINT ignore "Move brackets to avoid $" #-}
+
+module Parser (parse) where
 
 import Control.Monad (when)
 import Control.Monad.Except
@@ -16,34 +19,30 @@ data Parser = Parser
   { current :: !Int
   , tokens :: ![Token]
   }
+  deriving (Show)
 
 expression :: ParserM r Expr
 expression = equality
 
 {- |
 Removing newtypes, @ParserM r a@ is equivalent to:
-  + @RWS r [Error] Parser (Either Error a)@
-  + @RWST r [Error] Parser Identity (Either Error a)@
-  + @r -> Parser -> Identity (Either Error a, Parser, [Error])@
+  + @RWS r ParseException Parser (Either Error.ErrorPresent a)@
+  + @RWST r ParseException Parser Identity (Either Error.ErrorPresent a)@
+  + @r -> Parser -> Identity (Either Error.ErrorPresent a, Parser, ParseException)@
 -}
 type ParserM r a =
   ExceptT ParseException (RWST r Error.ErrorPresent Parser IO) a
 
 -- type ParserM r a = RWST r [Error] Parser (Either Error) a
 
-data ParseException = ParseError
+data ParseException = ParseException
 
-{-# INLINE whileParse #-}
-whileParse :: ParserM r Expr -> [TokenType] -> Expr -> ParserM r Expr
-whileParse inner matchlist eAccum = do
-  m <- match matchlist
-  if m
-    then do
-      operator <- previous
-      right <- inner
-      whileParse inner matchlist $ EBinary eAccum operator right
-    else
-      pure eAccum
+parse :: [Token] -> IO (Maybe Expr, Error.ErrorPresent)
+parse tokens = do
+  (r, w) <- (evalRWST . runExceptT) expression () initialParserState
+  pure (either (const Nothing) Just r, w)
+  where
+    initialParserState = Parser {current = 0, tokens = tokens}
 
 equality :: ParserM r Expr
 equality = comparison >>= whileParse comparison [BANG_EQUAL, EQUAL_EQUAL]
@@ -67,24 +66,91 @@ unary = do
 
 primary :: ParserM r Expr
 primary = do
+  -- f <- match [FALSE]
+  -- if f
+  --   then pure $ ELiteral $ LitBool False
+  --   else do
+  --     t <- match [TRUE]
+  --     if t
+  --       then pure $ ELiteral $ LitBool True
+  --       else do
+  --         n <- match [NIL]
+  --         if n
+  --           then pure $ ELiteral LitNil
+  --           else do
+  --             ns <- match [NUMBER, STRING]
+  --             if ns
+  --               then previous <&> (ELiteral . (.literal))
+  --               else do
+  --                 lp <- match [LEFT_PAREN]
+  --                 if lp
+  --                   then do
+  --                     expr <- expression
+  --                     consume RIGHT_PAREN "Expect ')' after expression."
+  --                     pure $ EGrouping expr
+  --                   else do
+  --                     p <- peek
+  --                     getPError p "Expect expression." >>= throwError
+
   t <- safePeek
   case t of
-    Just (Token FALSE _ _ _) -> pure $ ELiteral $ LitBool False
-    Just (Token TRUE _ _ _) -> pure $ ELiteral $ LitBool True
-    Just (Token NIL _ _ _) -> pure $ ELiteral LitNil
-    Just (Token NUMBER _ lit _) -> pure $ ELiteral lit
-    Just (Token STRING _ lit _) -> pure $ ELiteral lit
-    Just (Token LEFT_PAREN _ _ _) -> do
-      expr <- expression
-      consume RIGHT_PAREN "Expect ')' after expression."
-      pure $ EGrouping expr
-    _ -> undefined
+    Just (Token FALSE _ _ _) -> advance >> pure (ELiteral $ LitBool False)
+    Just (Token TRUE _ _ _) -> advance >> pure (ELiteral $ LitBool True)
+    Just (Token NIL _ _ _) -> advance >> (pure $ ELiteral LitNil)
+    Just (Token NUMBER _ lit _) -> advance >> (pure $ ELiteral lit)
+    Just (Token STRING _ lit _) -> advance >> (pure $ ELiteral lit)
+    Just (Token LEFT_PAREN _ _ _) ->
+      advance >> do
+        expr <- expression
+        consume RIGHT_PAREN "Expect ')' after expression."
+        pure $ EGrouping expr
+    _ -> do
+      p <- peek
+      getPError p "Expect expression." >>= throwError
   where
     safePeek :: ParserM r (Maybe Token)
     safePeek = do
       c <- not <$> isAtEnd
       if c then Just <$> peek else pure Nothing
 
+{-# INLINE whileParse #-}
+whileParse :: ParserM r Expr -> [TokenType] -> Expr -> ParserM r Expr
+whileParse inner matchlist eAccum = do
+  m <- match matchlist
+  if m
+    then do
+      operator <- previous
+      right <- inner
+      whileParse inner matchlist $ EBinary eAccum operator right
+    else
+      pure eAccum
+
+synchronize :: ParserM r ()
+synchronize = do
+  advance
+  go
+  where
+    go :: ParserM r ()
+    go = do
+      e <- not <$> isAtEnd
+      if e
+        then pure ()
+        else do
+          t <- previous
+          p <- peek
+          if t.ttype == SEMICOLON
+            then pure ()
+            else case p.ttype of
+              CLASS -> pure ()
+              FUN -> pure ()
+              VAR -> pure ()
+              FOR -> pure ()
+              IF -> pure ()
+              WHILE -> pure ()
+              PRINT -> pure ()
+              RETURN -> pure ()
+              _ -> advance >> go
+
 consume :: TokenType -> ByteString -> ParserM r Token
 consume ttype message =
   check ttype >>= \c ->
@@ -96,7 +162,7 @@ consume ttype message =
 getPError :: Token -> ByteString -> ParserM r ParseException
 getPError token message = do
   Error.parseError token message
-  pure ParseError
+  pure ParseException
 
 match :: [TokenType] -> ParserM r Bool
 match = \case
@@ -114,7 +180,7 @@ check ttype =
       then pure False
       else do
         p <- peek
-        pure $ p.ttype == ttype
+        pure (p.ttype == ttype)
 
 advance :: ParserM r Token
 advance = do

src/Scanner.hs

@@ -48,7 +48,7 @@ scanTokens source = (\act -> evalRWST act () initialScanner) $ do
             : sc.tokens
       }
 
-  get <&> (.tokens)
+  get <&> (reverse . (.tokens))
   where
     initialScanner =
       Scanner

test/parsetest.lox

@@ -0,0 +1 @@
+(2 * 4)  -((2) +2  ) - 3