README.md

@@ -1,5 +1 @@
 # crafting-interpreters-hs
-
-Usage: `lox [file]`
-
-Implemented up to control flow statements (chapter 9).

app/Main.hs

@@ -1,39 +1,12 @@
 import Lox.Scanner
 import Lox.Parser
 import Lox.Interpreter
-import System.IO
-import System.Environment
 
 run :: String -> IO ()
-run source = do 
+run source = print result
-    let tokensMaybe = scanTokensFromSource source
+    where result = eval expr
-    case tokensMaybe of
+          expr = parse tokens
-        Left (LexicalError s) -> putStrLn s
+          tokens = scanTokensFromSource source
-        Right tokens -> do
-            let stmtMaybe = parse tokens
-            case stmtMaybe of
-                Left (SyntaxError s) -> putStrLn s
-                Right statements -> runStatements statements
-
-runEval :: String -> IO ()
-runEval source = do 
-    let tokensMaybe = scanTokensFromSource source
-    object <- case tokensMaybe of
-        Left (LexicalError s) -> putStrLn s >> return NullObject
-        Right tokens -> do
-            let exprMaybe = parseExpression tokens
-            case exprMaybe of
-                Left (SyntaxError s) -> putStrLn s >> return NullObject
-                Right statements -> eval statements
-    print object
-
-repl :: IO ()
-repl = putStr ">> " >> hFlush stdout >> getLine >>= runEval
 
 main :: IO ()
-main = getArgs >>= fs
+main = getLine >>= run 
-
-fs :: [String] -> IO ()
-fs [] = repl
-fs [s] = readFile s >>= run
-fs _ = putStrLn "Usage: lox [file]"

crafting-interpreters-hs.cabal

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

examples/fibonacci.lox

@@ -1,9 +0,0 @@
-var a = 0;
-var temp;
-
-for (var b = 1; a < 10000; b = temp + b) {
-  print a;
-  temp = a;
-  a = b;
-}
-

examples/scope.lox

@@ -1,19 +0,0 @@
-var a = "global a";
-var b = "global b";
-var c = "global c";
-{
-  var a = "outer a";
-  var b = "outer b";
-  {
-    var a = "inner a";
-    print a;
-    print b;
-    print c;
-  }
-  print a;
-  print b;
-  print c;
-}
-print a;
-print b;
-print c;

src/Lox/Environment.hs

@@ -1,34 +0,0 @@
-module Lox.Environment (
-    Environment (..),
-    emptyEnvironment,
-    define,
-    get,
-    assign
-) where
-
-import Data.Map
-import Lox.Scanner
-
-data Environment = Environment {enclosing :: Maybe Environment, variables :: Map String Object}
-
-emptyEnvironment :: Environment
-emptyEnvironment = Environment {enclosing=Nothing, variables=empty}
-
-define :: String -> Object -> Environment -> Environment
-define key value env@Environment {variables=variables} = env {variables=insert key value variables}
-
-get :: String -> Environment -> Maybe Object
-get key Environment {enclosing=enclosing, variables=variables} = 
-    case variables !? key of
-        Just val -> Just val
-        Nothing -> case enclosing of
-            Just e -> get key e
-            Nothing -> Nothing
-
-assign :: String -> Object -> Environment -> (Bool, Environment)
-assign key value env@Environment {enclosing=enclosing, variables=variables} = 
-    if member key variables 
-        then (True, env {variables=insert key value variables}) 
-        else case enclosing of 
-            Just e -> let (success, newEnclosing) = assign key value e in (success, env {enclosing = Just newEnclosing})
-            Nothing -> (False, env)

src/Lox/Expr.hs

@@ -1,25 +1,12 @@
 module Lox.Expr (
-    Stmt (..),
     Expr (..)
 ) where
 
 import Lox.Scanner
 
-data Stmt =
-    BlockStmt [Stmt] |
-    ExpressionStmt Expr |
-    IfStmt Expr Stmt (Maybe Stmt) |
-    PrintStmt Expr |
-    VariableStmt Token Expr |
-    WhileStmt Expr Stmt
-    deriving Show
-
 data Expr = 
-    LiteralExpr Object | 
+    Literal Object | 
-    LogicalExpr Expr Token Expr |
+    Unary Token Expr | 
-    UnaryExpr Token Expr | 
+    Binary Expr Token Expr | 
-    BinaryExpr Expr Token Expr | 
+    Grouping Expr
-    GroupingExpr Expr |
-    VariableExpr Token |
-    AssignmentExpr Token Expr
     deriving Show

src/Lox/Interpreter.hs

@@ -1,86 +1,30 @@
 module Lox.Interpreter (
-    runStatements,
     eval   
 ) where
 
 import Lox.Expr
 import Lox.Scanner
-import Lox.Environment
 import Control.Monad.State
-import Control.Monad
 
-data InterpreterState = InterpreterState {io :: IO (), environment :: Environment}
+data InterpreterState = InterpreterState
 
-emptyInterpreter :: InterpreterState
+eval :: Expr -> Object
-emptyInterpreter = InterpreterState {io=return (), environment=emptyEnvironment}
+eval expr = evalState (interpret expr) InterpreterState
 
-runStatements :: [Stmt] -> IO ()
+interpret :: Expr -> State InterpreterState Object
-runStatements s = io
+interpret (Literal value) = return value
-    where InterpreterState {io=io} = execState (interpret s) emptyInterpreter
+interpret (Grouping expr) = interpret expr
-
+interpret (Unary op expr) = do 
-interpret :: [Stmt] -> State InterpreterState ()
+    right <- interpret expr
-interpret = foldr ((>>) . execute) (return ())
-
-execute :: Stmt -> State InterpreterState ()
-execute (BlockStmt statements) = executeBlock statements
-execute (ExpressionStmt value) = void $ evalFrom value
-execute (IfStmt condition thenBranch elseBranchMaybe) = do
-    condValue <- isTruthy <$> evalFrom condition
-    if condValue then execute thenBranch else forM_ elseBranchMaybe execute 
-execute (PrintStmt expr) = do
-    value <- evalFrom expr
-    modify (\s@(InterpreterState {io=io}) -> s {io=io >> print value})
-execute (VariableStmt name expr) = do
-    value <- evalFrom expr
-    modify (\s@(InterpreterState {environment=env}) -> s {environment=define (tokenLexeme name) value env})
-execute (WhileStmt condition body) = executeWhile condition body 
-
-executeBlock :: [Stmt] -> State InterpreterState ()
-executeBlock statements = do 
-    oldEnv <- gets environment
-    modify (\s@InterpreterState {environment=_} -> s {environment=emptyEnvironment {enclosing=Just oldEnv}})
-    interpret statements
-    modify (\s@InterpreterState {environment=Environment {enclosing=Just enclosing}} -> s {environment=enclosing})
-
-executeWhile :: Expr -> Stmt -> State InterpreterState ()
-executeWhile condition body = do
-    shouldContinue <- evalFrom condition
-    when (isTruthy shouldContinue) $ execute body >> executeWhile condition body
-
-eval :: Expr -> IO Object
-eval expr = return $ evalState (evalFrom expr) emptyInterpreter
-
-evalFrom :: Expr -> State InterpreterState Object
-evalFrom (LiteralExpr value) = return value
-evalFrom (VariableExpr name) = do
-    maybeObject <- gets (\(InterpreterState {environment=env}) -> Lox.Environment.get (tokenLexeme name) env)
-    case maybeObject of
-        Nothing -> error "Undefined variable"
-        Just object -> return object
-evalFrom (AssignmentExpr name expr) = do
-    value <- evalFrom expr
-    success <- state $ f value
-    if success then return value else error "Undefined variable"
-    where f value s@InterpreterState {environment=env} = let (success, newEnv) = assign (tokenLexeme name) value env in (success, s {environment=newEnv})
-
-evalFrom (GroupingExpr expr) = evalFrom expr
-evalFrom (UnaryExpr op expr) = do 
-    right <- evalFrom expr
     case (tokenType op, right) of
         (MINUS, NumberObject x) -> return $ NumberObject (-x)
-        (BANG, object) -> return $ BoolObject $ not $ isTruthy object
+        (BANG, NullObject) -> return $ BoolObject False
+        (BANG, BoolObject x) -> return $ BoolObject (not x)
+        (BANG, _) -> return $ BoolObject True
         _ -> error "Type error"
-evalFrom (LogicalExpr leftExpr op rightExpr) = do
+interpret (Binary leftExpr op rightExpr) = do
-    isLeftTruthy <- isTruthy <$> evalFrom leftExpr
+    left <- interpret leftExpr
-    case (tokenType op, isLeftTruthy) of
+    right <- interpret rightExpr
-        (OR, True) -> return $ BoolObject True
-        (OR, False) -> evalFrom rightExpr
-        (AND, True) -> evalFrom rightExpr
-        (AND, False) -> return $ BoolObject False
-        _ -> error "Unreachable"
-evalFrom (BinaryExpr leftExpr op rightExpr) = do
-    left <- evalFrom leftExpr
-    right <- evalFrom rightExpr
     case (tokenType op, left, right) of
         (PLUS, NumberObject x, NumberObject y) -> return $ NumberObject (x + y)
         (MINUS, NumberObject x, NumberObject y) -> return $ NumberObject (x - y)
@@ -98,7 +42,3 @@ evalFrom (BinaryExpr leftExpr op rightExpr) = do
         
         _ -> error "Type error"
 
-isTruthy :: Object -> Bool
-isTruthy NullObject = False
-isTruthy (BoolObject False) = False
-isTruthy _ = True

src/Lox/Parser.hs

@@ -1,49 +1,15 @@
 module Lox.Parser (
-    SyntaxError (..),
+    parse
-    parse,
-    parseExpression
 ) where
 
 import Control.Monad
 import Control.Monad.State
-import Data.Either
-import Data.Maybe
 import Lox.Scanner
 import Lox.Expr
-import Control.Monad.Extra (ifM)
 
 data ParserState = ParserState {tokens :: [Token]}
 
-data SyntaxError = SyntaxError String deriving Show
+-- expression     → equality ;
-
--- program        → declaration* EOF ;
---
--- declaration    → varDecl
---                | statement ;
---
--- statement      → exprStmt
---                | forStmt
---                | ifStmt
---                | printStmt 
---                | whileStmt
---                | block ;
---
--- exprStmt       → expression ";" ;
--- forStmt        → "for" "(" ( varDecl | exprStmt | ";" ) 
---                  expression? ";"
---                  expression? ") statement ;
--- ifStmt         → "if" "(" expression ")" statement 
---                ( "else" statement )? ;
--- printStmt      → "print" expression ";" ;
--- whileStmt      → "while" "(" expression ")" statement ;
--- varDecl        → "var" IDENTIFIER ( "=" expression )? ";" ;
--- block          → "{" declaration* "}" ;
---
--- expression     → assignment ;
--- assignment     → IDENTIFIER "=" assignment 
---                | logic_or;
--- logic_or       → logic_and ( "or" logic_and )* ;
--- logic_and      → equality ( "and" equality )* ;
 -- equality       → comparison ( ( "!=" | "==" ) comparison )* ;
 -- comparison     → term ( ( ">" | ">=" | "<" | "<=" ) term )* ;
 -- term           → factor ( ( "-" | "+" ) factor )* ;
@@ -51,249 +17,68 @@ data SyntaxError = SyntaxError String deriving Show
 -- unary          → ( "!" | "-" ) unary
 --                | primary ;
 -- primary        → NUMBER | STRING | "true" | "false" | "nil"
---                | "(" expression ")" | IDENTIFIER;
+--                | "(" expression ")" ;
 
-parse :: [Token] -> Either SyntaxError [Stmt]
+parse :: [Token] -> Expr
-parse tokens = evalState program (ParserState {tokens=tokens})
+parse tokens = evalState expression (ParserState {tokens=tokens})
 
-parseExpression :: [Token] -> Either SyntaxError Expr
+expression :: State ParserState Expr
-parseExpression tokens = evalState expression (ParserState {tokens=tokens})
+expression = equality
 
-program :: State ParserState (Either SyntaxError [Stmt])
+equality :: State ParserState Expr
-program = do
-    atEnd <- isAtEnd
-    if atEnd then return $ Right [] else do
-        headMaybe <- declaration
-        case headMaybe of
-            Left err -> return $ Left err
-            Right head -> do
-                tailMaybe <- program
-                case tailMaybe of
-                    Left err -> return $ Left err
-                    Right tail -> return $ Right $ head : tail
-declaration :: State ParserState (Either SyntaxError Stmt)
-declaration = do
-    varMaybe <- matchToken [VAR]
-    case varMaybe of
-        Just _ -> varDeclaration
-        _ -> statement
-
-varDeclaration :: State ParserState (Either SyntaxError Stmt)
-varDeclaration = do
-    maybeName <- consume IDENTIFIER $ SyntaxError "Expected variable name" 
-    case maybeName of
-        Left err -> return $ Left err
-        Right name -> do
-            hasInit <- isJust <$> matchToken [EQUAL]
-            initMaybe <- if hasInit then expression else return $ Right $ LiteralExpr NullObject
-            semicolonMaybe <- consume SEMICOLON $ SyntaxError "Expected semicolon" 
-            case (initMaybe, semicolonMaybe) of
-                (Left err, _) -> return $ Left err
-                (_, Left err) -> return $ Left err
-                (Right init, Right _) -> return $ Right $ VariableStmt name init
-
-
-statement :: State ParserState (Either SyntaxError Stmt)
-statement = do
-    tokenTypeMaybe <- fmap tokenType <$> matchToken [FOR, IF, PRINT, WHILE, LEFT_BRACE]
-    case tokenTypeMaybe of
-        Just FOR -> forStatement
-        Just IF -> ifStatement
-        Just PRINT -> printStatement
-        Just WHILE -> whileStatement
-        Just LEFT_BRACE -> do 
-            result <- fmap BlockStmt <$> block
-            braceMaybe <- consume RIGHT_BRACE $ SyntaxError "Expected '}' after block"
-            return $ braceMaybe >> result
-        _ -> expressionStatement
-
-block :: State ParserState (Either SyntaxError [Stmt])
-block = do
-    isRightBrace <- check RIGHT_BRACE
-    if isRightBrace then return $ Right [] else do
-        declMaybe <- declaration
-        tailMaybe <- block
-        case (declMaybe, tailMaybe) of
-            (Left err, _) -> return $ Left err
-            (_, Left err) -> return $ Left err
-            (Right decl, Right tail) -> return $ Right $ decl : tail
-
-forStatement :: State ParserState (Either SyntaxError Stmt)
-forStatement = do
-    leftParen <- consume LEFT_PAREN $ SyntaxError "Expected '(' after 'for'"
-    tokenTypeMaybe <- fmap tokenType <$> matchToken [SEMICOLON, VAR]
-    initializer <- case tokenTypeMaybe of
-        Just SEMICOLON -> return Nothing
-        Just VAR -> Just <$> varDeclaration
-        _ -> Just <$> expressionStatement
-    condition <- ifM (check SEMICOLON) (return Nothing) (Just <$> expression)
-    conditionSemicolon <- consume SEMICOLON $ SyntaxError "Expected ';' after loop condition"
-    increment <- ifM (check RIGHT_PAREN) (return Nothing) (Just <$> expression)
-    rightParen <- consume RIGHT_PAREN $ SyntaxError "Expected ')' after for clauses"
-    body <- statement
-    body1 <- case increment of
-        Just inc -> return $ BlockStmt <$> ((\x y -> [x, y]) <$> body <*> (ExpressionStmt <$> inc))
-        Nothing -> return body
-    cond1 <- case condition of
-        Just cond -> return cond
-        Nothing -> return $ Right $ LiteralExpr $ BoolObject True
-    let body2 = WhileStmt <$> cond1 <*> body1
-    body3 <- case initializer of
-        Just init -> return $ BlockStmt <$> ((\x y -> [x, y]) <$> init <*> body2)
-        Nothing -> return body2
-    return $ leftParen >> conditionSemicolon >> rightParen >> body3
-
-ifStatement :: State ParserState (Either SyntaxError Stmt)
-ifStatement = do
-    leftParenMaybe <- consume LEFT_PAREN $ SyntaxError "Expected '(' after 'if'"
-    conditionMaybe <- expression
-    rightParenMaybe <- consume RIGHT_PAREN $ SyntaxError "Expected ')' after if condition"
-    thenBranchMaybe <- statement
-    isElse <- isJust <$> matchToken [ELSE]
-    elseBranchMaybe <- if isElse then fmap Just <$> statement else return $ Right Nothing
-    return $ IfStmt <$> (leftParenMaybe >> conditionMaybe <* rightParenMaybe) <*> thenBranchMaybe <*> elseBranchMaybe
-
-printStatement :: State ParserState (Either SyntaxError Stmt)
-printStatement = do
-    valueMaybe <- expression
-    semicolonMaybe <- consume SEMICOLON $ SyntaxError "Expected ';'"
-    case (valueMaybe, semicolonMaybe) of
-        (Left err, _) -> return $ Left err
-        (_, Left err) -> return $ Left err
-        (Right value, Right _) -> return $ Right $ PrintStmt value
-
-expressionStatement :: State ParserState (Either SyntaxError Stmt)
-expressionStatement = do
-    valueMaybe <- expression
-    semicolonMaybe <- consume SEMICOLON $ SyntaxError "Expected ';'"
-    case (valueMaybe, semicolonMaybe) of
-        (Left err, _) -> return $ Left err
-        (_, Left err) -> return $ Left err
-        (Right value, Right _) -> return $ Right $ ExpressionStmt value
-    
-whileStatement :: State ParserState (Either SyntaxError Stmt)
-whileStatement = do
-    leftParenMaybe <- consume LEFT_PAREN $ SyntaxError "Expected '(' after 'if'"
-    conditionMaybe <- expression
-    rightParenMaybe <- consume RIGHT_PAREN $ SyntaxError "Expected ')' after if condition"
-    bodyMaybe <- statement
-    return $ WhileStmt <$> (leftParenMaybe >> conditionMaybe <* rightParenMaybe) <*> bodyMaybe
-
-expression :: State ParserState (Either SyntaxError Expr)
-expression = assignment
-
-assignment :: State ParserState (Either SyntaxError Expr)
-assignment = do
-    maybeExpr <- logicalOr
-    matchedEqual <- isJust <$> matchToken [EQUAL]
-    if matchedEqual then do
-        maybeValue <- assignment
-        case (maybeExpr, maybeValue) of
-            (Left err, _) -> return $ Left err
-            (_, Left err) -> return $ Left err
-            (Right (VariableExpr name), Right value) -> return $ Right $ AssignmentExpr name value
-            _ -> return $ Left $ SyntaxError "Invalid assignment target" 
-    else return maybeExpr
-
-logicalOr :: State ParserState (Either SyntaxError Expr)
-logicalOr = do
-    exprMaybe <- logicalAnd
-    case exprMaybe of
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionLogicalMaybe expr) <$> matchTailLogical [OR] logicalAnd
-
-logicalAnd :: State ParserState (Either SyntaxError Expr)
-logicalAnd = do
-    exprMaybe <- equality
-    case exprMaybe of
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionLogicalMaybe expr) <$> matchTailLogical [AND] logicalAnd
-
-equality :: State ParserState (Either SyntaxError Expr)
 equality = do
-    exprMaybe <- comparison
+    expr <- comparison
-    case exprMaybe of
+    mergeExpressionMaybe expr <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison
 
-comparison :: State ParserState (Either SyntaxError Expr)
+comparison :: State ParserState Expr
 comparison = do
-    exprMaybe <- term 
+    expr <- term
-    case exprMaybe of
+    mergeExpressionMaybe expr <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term
 
-term :: State ParserState (Either SyntaxError Expr)
+term :: State ParserState Expr
 term = do
-    exprMaybe <- factor
+    expr <- factor
-    case exprMaybe of
+    mergeExpressionMaybe expr <$> matchTail [MINUS, PLUS] factor
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [MINUS, PLUS] factor
 
-factor :: State ParserState (Either SyntaxError Expr)
+factor :: State ParserState Expr
 factor = do
-    exprMaybe <- unary
+    expr <- unary
-    case exprMaybe of
+    mergeExpressionMaybe expr <$> matchTail [SLASH, STAR] unary
-        Left err -> return $ Left err
-        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [SLASH, STAR] unary
 
-unary :: State ParserState (Either SyntaxError Expr)
+unary :: State ParserState Expr
 unary = do
     maybeOperator <- matchToken [BANG, MINUS]
     case maybeOperator of
         Nothing -> primary
-        Just op -> do
+        Just op -> Unary op <$> unary
-            exprMaybe <- unary
-            case exprMaybe of
-                Left err -> return $ Left err
-                Right expr -> return $ Right $ UnaryExpr op expr
 
-primary :: State ParserState (Either SyntaxError Expr)
+primary :: State ParserState Expr
 primary = do
     token <- advance
     case tokenType token of
-        FALSE -> return $ Right $ LiteralExpr $ BoolObject False
+        FALSE -> return $ Literal $ BoolObject False
-        TRUE -> return $ Right $ LiteralExpr $ BoolObject True
+        TRUE -> return $ Literal $ BoolObject True
-        NIL -> return $ Right $ LiteralExpr NullObject
+        NIL -> return $ Literal NullObject
-        NUMBER -> return $ Right $ LiteralExpr $ tokenObject token
+        NUMBER -> return $ Literal $ tokenObject token
-        STRING -> return $ Right $ LiteralExpr $ tokenObject token
+        STRING -> return $ Literal $ tokenObject token
         LEFT_PAREN -> do
-            exprMaybe <- expression
+            expr <- expression
-            case exprMaybe of
+            consume RIGHT_PAREN "Expected '(' after ')'"
-                Left err -> return $ Left err
+            return $ Grouping expr
-                Right expr -> do 
+        _ -> error "Expected expression"
-                    consume RIGHT_PAREN $ SyntaxError "Mismatched parentheses"
-                    return $ Right $ GroupingExpr expr
-        IDENTIFIER -> return $ Right $ VariableExpr token
-        _ -> return $ Left $ SyntaxError "Expected expression" 
 
-matchTail :: [TokenType] -> State ParserState (Either SyntaxError Expr) -> State ParserState (Either SyntaxError (Maybe (Token, Expr)))
+matchTail :: [TokenType] -> State ParserState Expr -> State ParserState (Maybe (Token, Expr))
-matchTail tokenTypes = matchTailWith tokenTypes mergeExpressionMaybe
+matchTail tokenTypes f = do
-
-matchTailLogical :: [TokenType] -> State ParserState (Either SyntaxError Expr) -> State ParserState (Either SyntaxError (Maybe (Token, Expr)))
-matchTailLogical tokenTypes = matchTailWith tokenTypes mergeExpressionLogicalMaybe
-
-matchTailWith :: [TokenType] -> (Expr -> Maybe (Token, Expr) -> Expr) -> State ParserState (Either SyntaxError Expr) -> State ParserState (Either SyntaxError (Maybe (Token, Expr)))
-matchTailWith tokenTypes m f = do
     maybeOperator <- matchToken tokenTypes
     case maybeOperator of
-        Nothing -> return $ Right Nothing
+        Nothing -> return Nothing
         Just op -> do
-            exprMaybe <- comparison
+            expr <- comparison
-            restMaybe <- matchTail tokenTypes f
+            rest <- matchTail tokenTypes f
-            case (exprMaybe, restMaybe) of
+            return $ Just (op, mergeExpressionMaybe expr rest)
-                (Left err, _) -> return $ Left err
-                (_, Left err) -> return $ Left err
-                (Right expr, Right rest) -> return $ Right $ Just (op, m expr rest)
-
-
 mergeExpressionMaybe :: Expr -> Maybe (Token, Expr) -> Expr
 mergeExpressionMaybe expr Nothing = expr
-mergeExpressionMaybe left (Just (op, right)) = BinaryExpr left op right
+mergeExpressionMaybe left (Just (op, right)) = Binary left op right
-
-mergeExpressionLogicalMaybe :: Expr -> Maybe (Token, Expr) -> Expr
-mergeExpressionLogicalMaybe expr Nothing = expr
-mergeExpressionLogicalMaybe left (Just (op, right)) = LogicalExpr left op right
 
 matchToken :: [TokenType] -> State ParserState (Maybe Token)
 matchToken [] = return Nothing
@@ -306,10 +91,10 @@ check t = do
     atEnd <- isAtEnd
     if atEnd then return False else (== t) . tokenType <$> peek
 
-consume :: TokenType -> SyntaxError -> State ParserState (Either SyntaxError Token)
+consume :: TokenType -> String -> State ParserState Token
-consume t err = do
+consume t msg = do
     isOk <- check t
-    if isOk then Right <$> advance else return $ Left err
+    if isOk then advance else error msg
 
 advance :: State ParserState Token
 advance = state (\s@ParserState {tokens=(t:ts)} -> (t, s {tokens = ts}))

src/Lox/Scanner.hs

@@ -2,7 +2,6 @@ module Lox.Scanner (
     TokenType (..),
     Object (..),
     Token (..),
-    LexicalError (..),
     scanTokensFromSource
 ) where
 
@@ -31,7 +30,7 @@ data Object = NullObject
 
 instance Show Object where
     show NullObject = "Nil"
-    show (StringObject s) = s
+    show (StringObject s) = show s
     show (NumberObject x) = show x
     show (BoolObject False) = "false"
     show (BoolObject True) = "true"
@@ -45,24 +44,21 @@ data Token = Token {
 
 data ScannerState = ScannerState {source :: String, current :: String, lineNumber :: Int}
 
-data LexicalError = LexicalError String
-
 emptyScannerState :: String -> ScannerState
 emptyScannerState source = 
     ScannerState {source=source, current="", lineNumber=1}
 
-scanTokensFromSource :: String -> Either LexicalError [Token]
+scanTokensFromSource :: String -> [Token]
 scanTokensFromSource source = evalState scanTokens (emptyScannerState source)
 
-scanTokens :: State ScannerState (Either LexicalError [Token])
+scanTokens :: State ScannerState [Token]
 scanTokens = do
     atEnd <- isAtEnd
-    if atEnd then return . return <$> addToken EOF else do
+    if atEnd then return <$> addToken EOF else do
         maybeToken <- scanToken
         case maybeToken of
-            Right Nothing -> scanTokens
+            Nothing -> scanTokens
-            Right (Just t) -> fmap (fmap (t :)) scanTokens
+            Just t -> (t :) <$> scanTokens
-            Left err -> return $ Left err
 
 isAtEnd :: State ScannerState Bool
 isAtEnd = gets scannerIsAtEnd
@@ -70,34 +66,32 @@ isAtEnd = gets scannerIsAtEnd
 scannerIsAtEnd :: ScannerState -> Bool
 scannerIsAtEnd ScannerState {source=source} = null source
 
-scanToken :: State ScannerState (Either LexicalError (Maybe Token))
+scanToken :: State ScannerState (Maybe Token)
 scanToken = do
     resetCurrent
     c <- advance
-    let ok = Right . Just
-    let nothing = Right Nothing
     case c of
-        '(' -> ok <$> addToken LEFT_PAREN
+        '(' -> Just <$> addToken LEFT_PAREN
-        ')' -> ok <$> addToken RIGHT_PAREN
+        ')' -> Just <$> addToken RIGHT_PAREN
-        '{' -> ok <$> addToken LEFT_BRACE
+        '{' -> Just <$> addToken LEFT_BRACE
-        '}' -> ok <$> addToken RIGHT_BRACE
+        '}' -> Just <$> addToken RIGHT_BRACE
-        ',' -> ok <$> addToken COMMA
+        ',' -> Just <$> addToken COMMA
-        '.' -> ok <$> addToken DOT
+        '.' -> Just <$> addToken DOT
-        '-' -> ok <$> addToken MINUS
+        '-' -> Just <$> addToken MINUS
-        '+' -> ok <$> addToken PLUS
+        '+' -> Just <$> addToken PLUS
-        ';' -> ok <$> addToken SEMICOLON
+        ';' -> Just <$> addToken SEMICOLON
-        '*' -> ok <$> addToken STAR
+        '*' -> Just <$> addToken STAR
-        '!' -> ok <$> ifM (match '=') (addToken BANG_EQUAL) (addToken BANG)
+        '!' -> Just <$> ifM (match '=') (addToken BANG_EQUAL) (addToken BANG)
-        '=' -> ok <$> ifM (match '=') (addToken EQUAL_EQUAL) (addToken EQUAL)
+        '=' -> Just <$> ifM (match '=') (addToken EQUAL_EQUAL) (addToken EQUAL)
-        '<' -> ok <$> ifM (match '=') (addToken LESS_EQUAL) (addToken LESS)
+        '<' -> Just <$> ifM (match '=') (addToken LESS_EQUAL) (addToken LESS)
-        '>' -> ok <$> ifM (match '=') (addToken GREATER_EQUAL) (addToken GREATER)
+        '>' -> Just <$> ifM (match '=') (addToken GREATER_EQUAL) (addToken GREATER)
-        '/' -> ifM (match '/') (advanceLine >> return nothing) (ok <$> addToken SLASH)
+        '/' -> ifM (match '/') (advanceLine >> return Nothing) (Just <$> addToken SLASH)
-        '"' -> ok <$> scanString
+        '"' -> Just <$> scanString
-        ' ' -> return nothing
+        ' ' -> return Nothing
-        '\r' -> return nothing
+        '\r' -> return Nothing
-        '\t' -> return nothing
+        '\t' -> return Nothing
-        '\n' -> modify (\s@(ScannerState {lineNumber=n}) -> s {lineNumber=n+1}) >> return nothing
+        '\n' -> return Nothing
-        c -> if isDigit c then ok <$> scanNumber else if isAlpha c then ok <$> scanIdentifier else return $ Left $ LexicalError "Unexpected character"
+        c -> if isDigit c then Just <$> scanNumber else if isAlpha c then Just <$> scanIdentifier else error "Unexpected character"
 
 scanString :: State ScannerState Token
 scanString = do