diff --git a/README.md b/README.md index 928141b..f83a52c 100644 --- a/README.md +++ b/README.md @@ -1 +1,5 @@ # crafting-interpreters-hs + +Usage: `lox [file]` + +Implemented up to control flow statements (chapter 9). diff --git a/app/Main.hs b/app/Main.hs index 6966ae6..832d0ba 100644 --- a/app/Main.hs +++ b/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]" diff --git a/crafting-interpreters-hs.cabal b/crafting-interpreters-hs.cabal index 260e578..9c148c7 100644 --- a/crafting-interpreters-hs.cabal +++ b/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 diff --git a/examples/fibonacci.lox b/examples/fibonacci.lox new file mode 100644 index 0000000..aa85ecf --- /dev/null +++ b/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; +} + diff --git a/examples/scope.lox b/examples/scope.lox new file mode 100644 index 0000000..d563807 --- /dev/null +++ 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; diff --git a/src/Lox/Environment.hs b/src/Lox/Environment.hs new file mode 100644 index 0000000..60ccd45 --- /dev/null +++ b/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) diff --git a/src/Lox/Expr.hs b/src/Lox/Expr.hs index 7a6c174..a5007ea 100644 --- a/src/Lox/Expr.hs +++ b/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 diff --git a/src/Lox/Interpreter.hs b/src/Lox/Interpreter.hs index 29476bd..00fc96a 100644 --- a/src/Lox/Interpreter.hs +++ b/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 diff --git a/src/Lox/Parser.hs b/src/Lox/Parser.hs index d149c8c..cc44a96 100644 --- a/src/Lox/Parser.hs +++ b/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})) diff --git a/src/Lox/Scanner.hs b/src/Lox/Scanner.hs index 91dfbda..120ac6d 100644 --- a/src/Lox/Scanner.hs +++ b/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