parser first version

crafting-interpreters-hs.cabal

@@ -54,7 +54,7 @@ common warnings
     ghc-options: -Wall
 
 library
-    exposed-modules:  Lox.Scanner
+    exposed-modules:  Lox.Scanner, Lox.Expr, Lox.Parser
     build-depends:    base ^>=4.18.3.0, mtl, extra
     hs-source-dirs:   src
     default-language: Haskell2010

src/Lox/Expr.hs

@@ -0,0 +1,12 @@
+module Lox.Expr (
+    Expr (..)
+) where
+
+import Lox.Scanner
+
+data Expr = 
+    Literal Object | 
+    Unary Token Expr | 
+    Binary Expr Token Expr | 
+    Grouping Expr
+

src/Lox/Parser.hs

@@ -0,0 +1,106 @@
+module Lox.Parser (
+    expression
+) where
+
+import Control.Monad
+import Control.Monad.State
+import Lox.Scanner
+import Lox.Expr
+
+data ParserState = ParserState {tokens :: [Token]}
+
+-- expression     → equality ;
+-- equality       → comparison ( ( "!=" | "==" ) comparison )* ;
+-- comparison     → term ( ( ">" | ">=" | "<" | "<=" ) term )* ;
+-- term           → factor ( ( "-" | "+" ) factor )* ;
+-- factor         → unary ( ( "/" | "*" ) unary )* ;
+-- unary          → ( "!" | "-" ) unary
+--                | primary ;
+-- primary        → NUMBER | STRING | "true" | "false" | "nil"
+--                | "(" expression ")" ;
+
+parse :: [Token] -> Expr
+parse tokens = evalState expression (ParserState {tokens=tokens})
+
+expression :: State ParserState Expr
+expression = equality
+
+equality :: State ParserState Expr
+equality = do
+    expr <- comparison
+    mergeExpressionMaybe expr <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison
+
+comparison :: State ParserState Expr
+comparison = do
+    expr <- term
+    mergeExpressionMaybe expr <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term
+
+term :: State ParserState Expr
+term = do
+    expr <- factor
+    mergeExpressionMaybe expr <$> matchTail [MINUS, PLUS] factor
+
+factor :: State ParserState Expr
+factor = do
+    expr <- unary
+    mergeExpressionMaybe expr <$> matchTail [SLASH, STAR] unary
+
+unary :: State ParserState Expr
+unary = do
+    maybeOperator <- matchToken [BANG, MINUS]
+    case maybeOperator of
+        Nothing -> primary
+        Just op -> Unary op <$> unary
+
+primary :: State ParserState Expr
+primary = do
+    token <- advance
+    case getType token of
+        FALSE -> return $ Literal $ BoolObject False
+        TRUE -> return $ Literal $ BoolObject True
+        NIL -> return $ Literal NullObject
+        NUMBER -> return $ Literal $ getObject token
+        STRING -> return $ Literal $ getObject token
+        LEFT_PAREN -> do
+            expr <- expression
+            consume RIGHT_PAREN "Expected '(' after ')'"
+            return $ Grouping expr
+        _ -> error "Expected expression"
+
+matchTail :: [TokenType] -> State ParserState Expr -> State ParserState (Maybe (Token, Expr))
+matchTail tokenTypes f = do
+    maybeOperator <- matchToken tokenTypes
+    case maybeOperator of
+        Nothing -> return Nothing
+        Just op -> do
+            expr <- comparison
+            rest <- matchTail tokenTypes f
+            return $ Just (op, mergeExpressionMaybe expr rest)
+mergeExpressionMaybe :: Expr -> Maybe (Token, Expr) -> Expr
+mergeExpressionMaybe expr Nothing = expr
+mergeExpressionMaybe left (Just (op, right)) = Binary left op right
+
+matchToken :: [TokenType] -> State ParserState (Maybe Token)
+matchToken [] = return Nothing
+matchToken (t:ts) = do
+    isMatch <- check t
+    if isMatch then Just <$> advance else matchToken ts
+
+check :: TokenType -> State ParserState Bool
+check t = do
+    atEnd <- isAtEnd
+    if atEnd then return False else (== t) . getType <$> peek
+
+consume :: TokenType -> String -> State ParserState Token
+consume t msg = do
+    isOk <- check t
+    if isOk then advance else error msg
+
+advance :: State ParserState Token
+advance = state (\s@ParserState {tokens=(t:ts)} -> (t, s {tokens = ts}))
+
+peek :: State ParserState Token
+peek = gets (head . tokens) 
+
+isAtEnd :: State ParserState Bool
+isAtEnd = (== EOF) . getType <$> peek

src/Lox/Scanner.hs

@@ -1,7 +1,7 @@
 module Lox.Scanner (
-    TokenType,
-    Object,
-    Token,
+    TokenType (..),
+    Object (..),
+    Token (getType, getLexeme, getObject),
     scanTokensFromSource
 ) where
 
@@ -20,9 +20,9 @@ data TokenType = LEFT_PAREN | RIGHT_PAREN | LEFT_BRACE | RIGHT_BRACE
                | AND | CLASS | ELSE | FALSE | FUN | FOR | IF | NIL | OR
                | PRINT | RETURN | SUPER | THIS | TRUE | VAR | WHILE
                | EOF
-    deriving Show
+    deriving (Show, Eq)
 
-data Object = NullObject | StringObject String | NumberObject Double deriving Show
+data Object = NullObject | StringObject String | NumberObject Double | BoolObject Bool deriving Show
 
 data Token = Token {
     getType :: TokenType,