simplify scanner error type

README.md

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

app/Main.hs

@@ -1,12 +1,39 @@
 import Lox.Scanner
 import Lox.Parser
 import Lox.Interpreter
+import System.IO
+import System.Environment
 
 run :: String -> IO ()
-run source = print result
-    where result = eval expr
-          expr = parse tokens
-          tokens = scanTokensFromSource source
+run source = do 
+    let tokensMaybe = scanTokensFromSource source
+    case tokensMaybe of
+        Left (LexicalError s) -> putStrLn s
+        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 = getLine >>= run 
+main = getArgs >>= fs
+
+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
-    build-depends:    base ^>=4.18.3.0, mtl, extra
+    exposed-modules:  Lox.Scanner, Lox.Expr, Lox.Parser, Lox.Interpreter, Lox.Environment
+    build-depends:    base ^>=4.18.3.0, mtl, extra, containers
     hs-source-dirs:   src
     default-language: Haskell2010
 

examples/fibonacci.lox

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

examples/scope.lox

@@ -0,0 +1,19 @@
+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

@@ -0,0 +1,34 @@
+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,12 +1,25 @@
 module Lox.Expr (
+    Stmt (..),
     Expr (..)
 ) where
 
 import Lox.Scanner
 
-data Expr = 
-    Literal Object | 
-    Unary Token Expr | 
-    Binary Expr Token Expr | 
-    Grouping Expr
+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 | 
+    LogicalExpr Expr Token Expr |
+    UnaryExpr Token Expr | 
+    BinaryExpr Expr Token Expr | 
+    GroupingExpr Expr |
+    VariableExpr Token |
+    AssignmentExpr Token Expr
     deriving Show

src/Lox/Interpreter.hs

@@ -1,30 +1,86 @@
 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
+data InterpreterState = InterpreterState {io :: IO (), environment :: Environment}
 
-eval :: Expr -> Object
-eval expr = evalState (interpret expr) InterpreterState
+emptyInterpreter :: InterpreterState
+emptyInterpreter = InterpreterState {io=return (), environment=emptyEnvironment}
 
-interpret :: Expr -> State InterpreterState Object
-interpret (Literal value) = return value
-interpret (Grouping expr) = interpret expr
-interpret (Unary op expr) = do 
-    right <- interpret expr
+runStatements :: [Stmt] -> IO ()
+runStatements s = io
+    where InterpreterState {io=io} = execState (interpret s) emptyInterpreter
+
+interpret :: [Stmt] -> State InterpreterState ()
+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, NullObject) -> return $ BoolObject False
-        (BANG, BoolObject x) -> return $ BoolObject (not x)
-        (BANG, _) -> return $ BoolObject True
+        (BANG, object) -> return $ BoolObject $ not $ isTruthy object
         _ -> error "Type error"
-interpret (Binary leftExpr op rightExpr) = do
-    left <- interpret leftExpr
-    right <- interpret rightExpr
+evalFrom (LogicalExpr leftExpr op rightExpr) = do
+    isLeftTruthy <- isTruthy <$> evalFrom leftExpr
+    case (tokenType op, isLeftTruthy) of
+        (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)
@@ -42,3 +98,7 @@ interpret (Binary leftExpr op rightExpr) = do
         
         _ -> error "Type error"
 
+isTruthy :: Object -> Bool
+isTruthy NullObject = False
+isTruthy (BoolObject False) = False
+isTruthy _ = True

src/Lox/Parser.hs

@@ -1,15 +1,49 @@
 module Lox.Parser (
-    parse
+    SyntaxError (..),
+    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]}
 
--- expression     → equality ;
+data SyntaxError = SyntaxError String deriving Show
+
+-- 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 )* ;
@@ -17,68 +51,249 @@ data ParserState = ParserState {tokens :: [Token]}
 -- unary          → ( "!" | "-" ) unary
 --                | primary ;
 -- primary        → NUMBER | STRING | "true" | "false" | "nil"
---                | "(" expression ")" ;
+--                | "(" expression ")" | IDENTIFIER;
 
-parse :: [Token] -> Expr
-parse tokens = evalState expression (ParserState {tokens=tokens})
+parse :: [Token] -> Either SyntaxError [Stmt]
+parse tokens = evalState program (ParserState {tokens=tokens})
 
-expression :: State ParserState Expr
-expression = equality
+parseExpression :: [Token] -> Either SyntaxError Expr
+parseExpression tokens = evalState expression (ParserState {tokens=tokens})
 
-equality :: State ParserState Expr
+program :: State ParserState (Either SyntaxError [Stmt])
+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
-    expr <- comparison
-    mergeExpressionMaybe expr <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison
+    exprMaybe <- comparison
+    case exprMaybe of
+        Left err -> return $ Left err
+        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison
 
-comparison :: State ParserState Expr
+comparison :: State ParserState (Either SyntaxError Expr)
 comparison = do
-    expr <- term
-    mergeExpressionMaybe expr <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term
+    exprMaybe <- term 
+    case exprMaybe of
+        Left err -> return $ Left err
+        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term
 
-term :: State ParserState Expr
+term :: State ParserState (Either SyntaxError Expr)
 term = do
-    expr <- factor
-    mergeExpressionMaybe expr <$> matchTail [MINUS, PLUS] factor
+    exprMaybe <- factor
+    case exprMaybe of
+        Left err -> return $ Left err
+        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [MINUS, PLUS] factor
 
-factor :: State ParserState Expr
+factor :: State ParserState (Either SyntaxError Expr)
 factor = do
-    expr <- unary
-    mergeExpressionMaybe expr <$> matchTail [SLASH, STAR] unary
+    exprMaybe <- unary
+    case exprMaybe of
+        Left err -> return $ Left err
+        Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [SLASH, STAR] unary
 
-unary :: State ParserState Expr
+unary :: State ParserState (Either SyntaxError Expr)
 unary = do
     maybeOperator <- matchToken [BANG, MINUS]
     case maybeOperator of
         Nothing -> primary
-        Just op -> Unary op <$> unary
+        Just op -> do
+            exprMaybe <- unary
+            case exprMaybe of
+                Left err -> return $ Left err
+                Right expr -> return $ Right $ UnaryExpr op expr
 
-primary :: State ParserState Expr
+primary :: State ParserState (Either SyntaxError Expr)
 primary = do
     token <- advance
     case tokenType token of
-        FALSE -> return $ Literal $ BoolObject False
-        TRUE -> return $ Literal $ BoolObject True
-        NIL -> return $ Literal NullObject
-        NUMBER -> return $ Literal $ tokenObject token
-        STRING -> return $ Literal $ tokenObject token
+        FALSE -> return $ Right $ LiteralExpr $ BoolObject False
+        TRUE -> return $ Right $ LiteralExpr $ BoolObject True
+        NIL -> return $ Right $ LiteralExpr NullObject
+        NUMBER -> return $ Right $ LiteralExpr $ tokenObject token
+        STRING -> return $ Right $ LiteralExpr $ tokenObject token
         LEFT_PAREN -> do
-            expr <- expression
-            consume RIGHT_PAREN "Expected '(' after ')'"
-            return $ Grouping expr
-        _ -> error "Expected expression"
+            exprMaybe <- expression
+            case exprMaybe of
+                Left err -> return $ Left err
+                Right expr -> do 
+                    consume RIGHT_PAREN $ SyntaxError "Mismatched parentheses"
+                    return $ Right $ GroupingExpr expr
+        IDENTIFIER -> return $ Right $ VariableExpr token
+        _ -> return $ Left $ SyntaxError "Expected expression" 
 
-matchTail :: [TokenType] -> State ParserState Expr -> State ParserState (Maybe (Token, Expr))
-matchTail tokenTypes f = do
+matchTail :: [TokenType] -> State ParserState (Either SyntaxError Expr) -> State ParserState (Either SyntaxError (Maybe (Token, Expr)))
+matchTail tokenTypes = matchTailWith tokenTypes mergeExpressionMaybe
+
+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 Nothing
+        Nothing -> return $ Right Nothing
         Just op -> do
-            expr <- comparison
-            rest <- matchTail tokenTypes f
-            return $ Just (op, mergeExpressionMaybe expr rest)
+            exprMaybe <- comparison
+            restMaybe <- matchTail tokenTypes f
+            case (exprMaybe, restMaybe) of
+                (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)) = Binary left op right
+mergeExpressionMaybe left (Just (op, right)) = BinaryExpr 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
@@ -91,10 +306,10 @@ check t = do
     atEnd <- isAtEnd
     if atEnd then return False else (== t) . tokenType <$> peek
 
-consume :: TokenType -> String -> State ParserState Token
-consume t msg = do
+consume :: TokenType -> SyntaxError -> State ParserState (Either SyntaxError Token)
+consume t err = do
     isOk <- check t
-    if isOk then advance else error msg
+    if isOk then Right <$> advance else return $ Left err
 
 advance :: State ParserState Token
 advance = state (\s@ParserState {tokens=(t:ts)} -> (t, s {tokens = ts}))

src/Lox/Scanner.hs

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