diff --git a/README.md b/README.md index f83a52c..928141b 100644 --- a/README.md +++ b/README.md @@ -1,5 +1 @@ # 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 832d0ba..6966ae6 100644 --- a/app/Main.hs +++ b/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 - 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 +run source = print result + where result = eval expr + expr = parse tokens + tokens = scanTokensFromSource source main :: IO () -main = getArgs >>= fs - -fs :: [String] -> IO () -fs [] = repl -fs [s] = readFile s >>= run -fs _ = putStrLn "Usage: lox [file]" +main = getLine >>= run diff --git a/crafting-interpreters-hs.cabal b/crafting-interpreters-hs.cabal index 9c148c7..260e578 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, Lox.Environment - build-depends: base ^>=4.18.3.0, mtl, extra, containers + exposed-modules: Lox.Scanner, Lox.Expr, Lox.Parser, Lox.Interpreter + build-depends: base ^>=4.18.3.0, mtl, extra hs-source-dirs: src default-language: Haskell2010 diff --git a/examples/fibonacci.lox b/examples/fibonacci.lox deleted file mode 100644 index aa85ecf..0000000 --- a/examples/fibonacci.lox +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index d563807..0000000 --- a/examples/scope.lox +++ /dev/null @@ -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; diff --git a/src/Lox/Environment.hs b/src/Lox/Environment.hs deleted file mode 100644 index 60ccd45..0000000 --- a/src/Lox/Environment.hs +++ /dev/null @@ -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) diff --git a/src/Lox/Expr.hs b/src/Lox/Expr.hs index a5007ea..7a6c174 100644 --- a/src/Lox/Expr.hs +++ b/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 | - LogicalExpr Expr Token Expr | - UnaryExpr Token Expr | - BinaryExpr Expr Token Expr | - GroupingExpr Expr | - VariableExpr Token | - AssignmentExpr Token Expr + Literal Object | + Unary Token Expr | + Binary Expr Token Expr | + Grouping Expr deriving Show diff --git a/src/Lox/Interpreter.hs b/src/Lox/Interpreter.hs index 00fc96a..29476bd 100644 --- a/src/Lox/Interpreter.hs +++ b/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 -emptyInterpreter = InterpreterState {io=return (), environment=emptyEnvironment} +eval :: Expr -> Object +eval expr = evalState (interpret expr) InterpreterState -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 +interpret :: Expr -> State InterpreterState Object +interpret (Literal value) = return value +interpret (Grouping expr) = interpret expr +interpret (Unary op expr) = do + right <- interpret 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 - 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 +interpret (Binary leftExpr op rightExpr) = do + left <- interpret leftExpr + right <- interpret 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 diff --git a/src/Lox/Parser.hs b/src/Lox/Parser.hs index cc44a96..d149c8c 100644 --- a/src/Lox/Parser.hs +++ b/src/Lox/Parser.hs @@ -1,49 +1,15 @@ module Lox.Parser ( - SyntaxError (..), - parse, - parseExpression + parse ) 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 - --- 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 )* ; +-- expression → 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 tokens = evalState program (ParserState {tokens=tokens}) +parse :: [Token] -> Expr +parse tokens = evalState expression (ParserState {tokens=tokens}) -parseExpression :: [Token] -> Either SyntaxError Expr -parseExpression tokens = evalState expression (ParserState {tokens=tokens}) +expression :: State ParserState Expr +expression = equality -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 :: State ParserState Expr equality = do - exprMaybe <- comparison - case exprMaybe of - Left err -> return $ Left err - Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison + expr <- comparison + mergeExpressionMaybe expr <$> matchTail [BANG_EQUAL, EQUAL_EQUAL] comparison -comparison :: State ParserState (Either SyntaxError Expr) +comparison :: State ParserState Expr comparison = do - exprMaybe <- term - case exprMaybe of - Left err -> return $ Left err - Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term + expr <- term + mergeExpressionMaybe expr <$> matchTail [GREATER, GREATER_EQUAL, LESS, LESS_EQUAL] term -term :: State ParserState (Either SyntaxError Expr) +term :: State ParserState Expr term = do - exprMaybe <- factor - case exprMaybe of - Left err -> return $ Left err - Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [MINUS, PLUS] factor + expr <- factor + mergeExpressionMaybe expr <$> matchTail [MINUS, PLUS] factor -factor :: State ParserState (Either SyntaxError Expr) +factor :: State ParserState Expr factor = do - exprMaybe <- unary - case exprMaybe of - Left err -> return $ Left err - Right expr -> fmap (mergeExpressionMaybe expr) <$> matchTail [SLASH, STAR] unary + expr <- unary + 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 - exprMaybe <- unary - case exprMaybe of - Left err -> return $ Left err - Right expr -> return $ Right $ UnaryExpr op expr + Just op -> Unary op <$> unary -primary :: State ParserState (Either SyntaxError Expr) +primary :: State ParserState Expr primary = do token <- advance case tokenType token of - 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 + FALSE -> return $ Literal $ BoolObject False + TRUE -> return $ Literal $ BoolObject True + NIL -> return $ Literal NullObject + NUMBER -> return $ Literal $ tokenObject token + STRING -> return $ Literal $ tokenObject token LEFT_PAREN -> do - 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" + expr <- expression + consume RIGHT_PAREN "Expected '(' after ')'" + return $ Grouping expr + _ -> error "Expected expression" -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 +matchTail :: [TokenType] -> State ParserState Expr -> State ParserState (Maybe (Token, Expr)) +matchTail tokenTypes f = do maybeOperator <- matchToken tokenTypes case maybeOperator of - Nothing -> return $ Right Nothing + Nothing -> return Nothing Just op -> do - 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) - - + 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)) = BinaryExpr left op right - -mergeExpressionLogicalMaybe :: Expr -> Maybe (Token, Expr) -> Expr -mergeExpressionLogicalMaybe expr Nothing = expr -mergeExpressionLogicalMaybe left (Just (op, right)) = LogicalExpr left op right +mergeExpressionMaybe left (Just (op, right)) = Binary 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 t err = do +consume :: TokenType -> String -> State ParserState Token +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})) diff --git a/src/Lox/Scanner.hs b/src/Lox/Scanner.hs index 120ac6d..91dfbda 100644 --- a/src/Lox/Scanner.hs +++ b/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 - Right (Just t) -> fmap (fmap (t :)) scanTokens - Left err -> return $ Left err + Nothing -> scanTokens + Just t -> (t :) <$> scanTokens 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 - ')' -> 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" + '(' -> 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" scanString :: State ScannerState Token scanString = do