diff options
| author | Jan Tuomi <jans.tuomi@gmail.com> | 2022-09-27 15:10:00 +0300 |
|---|---|---|
| committer | Jan Tuomi <jans.tuomi@gmail.com> | 2022-12-05 14:21:53 +0200 |
| commit | 0a56af62ffa95360587728b82c947a2936743a4c (patch) | |
| tree | 1083bbc78dc961382d0062c44ad9d251b11b5fd7 /src | |
| parent | 2952ecc005466775c9ac70a702da1bbad17a28e5 (diff) | |
Add src position to data structures
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 165 | ||||
| -rw-r--r-- | src/Evaluator.hs | 93 | ||||
| -rw-r--r-- | src/Lib.hs | 8 | ||||
| -rw-r--r-- | src/Parser.hs | 51 | ||||
| -rw-r--r-- | src/Tokenizer.hs | 118 | ||||
| -rw-r--r-- | src/Utils.hs | 66 |
6 files changed, 305 insertions, 196 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index 2dac829..f8d1567 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -30,14 +30,14 @@ builtinEnv = M.fromList [ builtinConcat, -- special builtinPrint, - ("unit", ASTUnit), - ("_", ASTHole), - ("otherwise", ASTHole), + ("unit", makeNonsenseAST ASTUnit), + ("_", makeNonsenseAST ASTHole), + ("otherwise", makeNonsenseAST ASTHole), builtinFatal ] -argError1 :: Show a => String -> a -> String -argError1 fn arg = "invalid argument to " ++ fn ++ ": " ++ show arg +argError1 :: String -> AST -> String +argError1 fn arg = pos arg ++ ": invalid argument to " ++ fn ++ ": " ++ show arg argError2 :: (Show a1, Show a2) => String -> a1 -> a2 -> String argError2 fn arg1 arg2 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 @@ -48,100 +48,101 @@ argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 -- BUILTINS builtinAdd2 :: (String, AST) -builtinAdd2 = (name, ASTFunction fn1) where +builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "+" - fn1 _ ast1@(ASTInteger a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTInteger b) = - return $ ASTInteger $ a + b + fn1 _ ast1@AST { astNode = ASTInteger a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTInteger b } = + return $ makeNonsenseAST $ ASTInteger $ a + b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1@(ASTDouble a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTDouble b) = - return $ ASTDouble $ a + b + fn1 _ ast1@AST { astNode = ASTDouble a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTDouble b } = + return $ makeNonsenseAST $ ASTDouble $ a + b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinSubtract2 :: (String, AST) -builtinSubtract2 = (name, ASTFunction fn1) where +builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "-" - fn1 _ ast1@(ASTInteger a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTInteger b) = - return $ ASTInteger $ a - b + fn1 _ ast1@AST { astNode = ASTInteger a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTInteger b } = + return $ makeNonsenseAST $ ASTInteger $ a - b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1@(ASTDouble a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTDouble b) = - return $ ASTDouble $ a - b + fn1 _ ast1@AST { astNode = ASTDouble a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTDouble b } = + return $ makeNonsenseAST $ ASTDouble $ a - b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinMultiply2 :: (String, AST) -builtinMultiply2 = (name, ASTFunction fn1) where +builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "*" - fn1 _ ast1@(ASTInteger a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTInteger b) = - return $ ASTInteger $ a * b + fn1 _ ast1@AST { astNode = ASTInteger a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTInteger b } = + return $ makeNonsenseAST $ ASTInteger $ a * b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1@(ASTDouble a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTDouble b) = - return $ ASTDouble $ a * b + fn1 _ ast1@AST { astNode = ASTDouble a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTDouble b } = + return $ makeNonsenseAST $ ASTDouble $ a * b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinDivide2 :: (String, AST) -builtinDivide2 = (name, ASTFunction fn1) where +builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "/" - fn1 _ ast1@(ASTInteger a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTInteger b) = + fn1 _ ast1@AST { astNode = ASTInteger a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTInteger b } = do when (b == 0) $ throwL $ "division by zero" - return $ ASTInteger $ a `div` b + return $ makeNonsenseAST $ ASTInteger $ a `div` b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1@(ASTDouble a) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTDouble b) = + fn1 _ ast1@AST { astNode = ASTDouble a } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTDouble b } = do when (b == 0) $ throwL $ "division by zero" - return $ ASTDouble $ a / b + return $ makeNonsenseAST $ ASTDouble $ a / b fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinEq2 :: (String, AST) -builtinEq2 = (name, ASTFunction fn1) where +builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "eq?" fn1 _ ast1 = - return $ ASTFunction $ fn2 where - fn2 _ ast2 = return $ ASTBoolean $ ast1 == ast2 + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2 builtinLt2 :: (String, AST) -builtinLt2 = (name, ASTFunction fn1) where +builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "lt?" fn1 _ ast1 = - return $ ASTFunction $ fn2 where - fn2 _ ast2 = return $ ASTBoolean $ ast1 <= ast2 + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2 builtinFloor :: (String, AST) -builtinFloor = (name, ASTFunction fn1) where +builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where name = "floor" - fn1 _ (ASTDouble dbl) = return $ ASTInteger $ floor dbl + fn1 _ AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl fn1 _ ast = throwL $ argError1 name ast builtinToDouble :: (String, AST) -builtinToDouble = (name, ASTFunction fn1) where +builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where name = "to-double" - fn1 _ (ASTInteger int) = return $ ASTDouble $ fromIntegral int + fn1 _ AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int fn1 _ ast = throwL $ argError1 name ast builtinFmt :: (String, AST) -builtinFmt = (name, ASTFunction fn1) where +builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where name = "fmt" - fn1 _ ast1@(ASTString str) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTVector replacements) = - return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str) + fn1 _ ast1@AST { astNode = ASTString str } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTVector replacements } = + return $ makeNonsenseAST $ ASTString $ + T.unpack $ replaceAll (0 :: Int) replacements (T.pack str) fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 replaceAll _ [] text = text @@ -150,65 +151,65 @@ builtinFmt = (name, ASTFunction fn1) where in replaceAll (n + 1) xs text' builtinHead :: (String, AST) -builtinHead = (name, ASTFunction fn1) where +builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where name = "head" - fn1 _ (ASTVector vec) = + fn1 _ AST { astNode = ASTVector vec } = do when (length vec == 0) $ throwL $ name ++ " of empty vector" return $ head vec fn1 _ ast = throwL $ argError1 name ast builtinTail :: (String, AST) -builtinTail = (name, ASTFunction fn1) where +builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where name = "tail" - fn1 _ (ASTVector vec) = + fn1 _ AST { astNode = ASTVector vec } = do when (length vec == 0) $ throwL $ name ++ " of empty vector" - return $ ASTVector $ tail vec + return $ makeNonsenseAST $ ASTVector $ tail vec fn1 _ ast = throwL $ argError1 name ast builtinSubstr :: (String, AST) -builtinSubstr = (name, ASTFunction fn1) where +builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where name = "substr" - fn1 _ ast1@(ASTInteger at) = - return $ ASTFunction $ fn2 where - fn2 _ ast2@(ASTInteger len) = - return $ ASTFunction $ fn3 where - fn3 _ (ASTString str) = - return $ ASTString $ drop at .> take len $ str + fn1 _ ast1@AST { astNode = ASTInteger at } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ ast2@AST { astNode = ASTInteger len } = + return $ makeNonsenseAST $ ASTFunction $ fn3 where + fn3 _ AST { astNode = ASTString str } = + return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str fn3 _ ast3 = throwL $ argError3 name ast1 ast2 ast3 fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinPrepend :: (String, AST) -builtinPrepend = (name, ASTFunction fn1) where +builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where name = "prepend" fn1 _ ast1 = - return $ ASTFunction $ fn2 where - fn2 _ (ASTVector vec) = - return $ ASTVector $ ast1 : vec + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTVector vec } = + return $ makeNonsenseAST $ ASTVector $ ast1 : vec fn2 _ ast2 = throwL $ argError2 name ast1 ast2 builtinPrint :: (String, AST) -builtinPrint = (name, ASTFunction fn1) where +builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where name = "print!" - fn1 _ (ASTString str) = + fn1 _ AST { astNode = ASTString str } = do liftIO $ putStr $ str - return ASTUnit + return $ makeNonsenseAST ASTUnit fn1 _ ast = throwL $ argError1 name ast builtinConcat :: (String, AST) -builtinConcat = (name, ASTFunction fn1) where +builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where name = "concat" - fn1 _ ast1@(ASTString str1) = - return $ ASTFunction $ fn2 where - fn2 _ (ASTString str2) = - return $ ASTString $ str1 ++ str2 + fn1 _ ast1@AST { astNode = ASTString str1 } = + return $ makeNonsenseAST $ ASTFunction $ fn2 where + fn2 _ AST { astNode = ASTString str2 } = + return $ makeNonsenseAST $ ASTString $ str1 ++ str2 fn2 _ ast2 = throwL $ argError2 name ast1 ast2 fn1 _ ast1 = throwL $ argError1 name ast1 builtinFatal :: (String, AST) -builtinFatal = (name, ASTFunction fn1) where +builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where name = "fatal" - fn1 _ (ASTString str) = + fn1 _ AST { astNode = ASTString str } = throwL $ str fn1 _ ast = throwL $ argError1 name ast diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 009f108..754c0b1 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -12,31 +12,31 @@ import Utils -- import Debug.Trace _curryCall :: Env -> [AST] -> LFunction -> LContext AST -_curryCall _ [] f = return $ ASTFunction f +_curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f) _curryCall env (arg:[]) f = f env arg _curryCall env (arg:rest) f = do g <- _curryCall env rest f - case g of + case astNode g of ASTFunction f' -> f' env arg other -> throwL $ "cannot call value " ++ show other ++ " as a function" curryCall :: Env -> [AST] -> LFunction -> LContext AST -curryCall env [] f = f env ASTUnit +curryCall env [] f = f env (makeNonsenseAST ASTUnit) curryCall env args f = _curryCall env args f traverseAndReplace :: String -> AST -> AST -> AST -traverseAndReplace param arg ast@(ASTSymbol sym) +traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym } | sym == param = arg | otherwise = ast -traverseAndReplace param arg (ASTFunctionCall body) = - ASTFunctionCall $ (map (traverseAndReplace param arg) body) -traverseAndReplace param arg (ASTVector vec) = - ASTVector $ (map (traverseAndReplace param arg) vec) -traverseAndReplace param arg (ASTHashMap hmap) = - ASTHashMap $ M.assocs hmap +traverseAndReplace param arg ast@AST { astNode = ASTFunctionCall body } = + ast { astNode = ASTFunctionCall $ (map (traverseAndReplace param arg) body) } +traverseAndReplace param arg ast@AST { astNode = ASTVector vec } = + ast { astNode = ASTVector $ (map (traverseAndReplace param arg) vec) } +traverseAndReplace param arg ast@AST { astNode = ASTHashMap hmap } = + ast { astNode = ASTHashMap $ M.assocs hmap $> L.concatMap (\(a, b) -> [a, b]) .> map (traverseAndReplace param arg) - .> asPairs .> M.fromList + .> asPairs .> M.fromList } traverseAndReplace _ _ other = other foldSymValPairs :: [(String, AST)] -> AST -> AST @@ -50,21 +50,21 @@ foldSymValPairs ((sym, val):rest) body = letArgsToSymValPairs :: Env -> [AST] -> LContext (String, AST) letArgsToSymValPairs env args = case args of - [ASTSymbol symbol', value'] -> do + [AST { astNode = ASTSymbol symbol' }, value'] -> do (_, evaledValue) <- evaluate env value' return (symbol', evaledValue) - [ASTSymbol "lazy", ASTSymbol symbol', value'] -> do + [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do return (symbol', value') other -> throwL $ "let called with invalid args " ++ show other defineUserFunction :: AST -> [AST] -> LContext LFunction -defineUserFunction (ASTSymbol param) exprs = return fn where +defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where fn :: LFunction fn env arg = do let replacedExprs = map (traverseAndReplace param arg) exprs let letExprs = take (length exprs - 1) replacedExprs letSymValPairs <- letExprs - $> mapM (\case (ASTFunctionCall v) -> return $ drop 1 v + $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v _ -> throwL $ "unreachable: map letExprs") .> fmap (mapM $ letArgsToSymValPairs env) .> join let body = head $ drop (length exprs - 1) replacedExprs @@ -77,36 +77,43 @@ defineUserFunction param exprs = throwL $ "unreachable: defineUserFunction, para defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction defineUserFunctionWithLetExprs [] exprs = - defineUserFunction (ASTSymbol "unit") exprs + -- the position info is nonsensical, but it should never get read anyway + defineUserFunction (makeNonsenseAST $ ASTSymbol "unit") exprs defineUserFunctionWithLetExprs (param:[]) exprs = defineUserFunction param exprs -defineUserFunctionWithLetExprs ((ASTSymbol param):rest) exprs = return fn where +defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs = return fn where fn :: LFunction fn _ arg = do let newExprs = map (traverseAndReplace param arg) exprs ret <- defineUserFunctionWithLetExprs rest newExprs - return $ ASTFunction $ ret + -- the returned AST will not have the correct position info, but that's fine + -- because the info is overridden in evaluateFunctionDef anyway + return $ makeNonsenseAST $ ASTFunction $ ret defineUserFunctionWithLetExprs _ _ = throwL $ "unreachable: defineUserFunctionWithLetExprs" evaluateFunctionDef :: Env -> [AST] -> LContext (Env, AST) -evaluateFunctionDef env args = do +evaluateFunctionDef env asts = do + let defAst = head asts + args = tail asts (params'', exprs) <- case args of args' | length args' < 2 -> throwL $ "\\ called with " ++ show (length args) ++ " arguments" | otherwise -> return $ (head args', tail args') - (ASTVector params') <- assertIsASTVector params'' + AST { astNode = ASTVector params' } <- assertIsASTVector params'' params <- mapM assertIsASTSymbol params' let letExprs = take (length exprs - 1) exprs - unless (all (\case ASTFunctionCall (ASTSymbol "let":_) -> True; _ -> False) letExprs) + unless (all (\case ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) -> True; _ -> False) (map astNode letExprs)) $ throwL "non-let expression in function definition before body" fn <- defineUserFunctionWithLetExprs params exprs - return $ (env, ASTFunction fn) + return $ (env, defAst { astNode = ASTFunction fn }) evaluateMatch :: Env -> [AST] -> LContext (Env, AST) -evaluateMatch env args = do +evaluateMatch env asts = do + let matchAst = head asts + args = tail asts (actualExpr, rest) <- case args of [] -> throwL $ "match called with no arguments" (_:[]) -> throwL $ "empty match cases" @@ -119,7 +126,7 @@ evaluateMatch env args = do (_, evaledActual) <- evaluate env actualExpr ret <- matchPairs (actualExpr, evaledActual) pairs - return (env, ret) + return (env, matchAst { astNode = astNode ret }) where matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST matchPairs (actualExpr, evaledActual) [] = throwL $ "matching case not found when matching on expression: " ++ show actualExpr @@ -133,33 +140,37 @@ evaluateMatch env args = do else matchPairs (actualExpr, evaledActual) restPairs evaluateLet :: Env -> [AST] -> LContext (Env, AST) -evaluateLet env args = do +evaluateLet env asts = do + let letAst = head asts + args = tail asts (symbol, value) <- letArgsToSymValPairs env args when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol let newEnv = M.insert symbol value env - return $ (newEnv, ASTUnit) + return $ (newEnv, letAst { astNode = ASTUnit }) -evaluateEnv :: Env -> LContext (Env, AST) -evaluateEnv env = do +evaluateEnv :: Env -> [AST] -> LContext (Env, AST) +evaluateEnv env asts = do + let envAst = head asts let pairs = M.assocs env let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ') let rows = pairs $> map (\(k, v) -> pad k ++ show v) liftIO $ mapM_ putStrLn rows - return (env, ASTUnit) + return (env, envAst { astNode = ASTUnit }) evaluateUserFunction :: Env -> [AST] -> LContext (Env, AST) evaluateUserFunction env children = do - let fnName = head children - let args = tail children - (_, fnEvaled) <- evaluate env fnName - (ASTFunction fn) <- assertIsASTFunction fnEvaled + let fnAst = head children + args = tail children + (_, fnEvaled) <- evaluate env fnAst + AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled evaledArgs' <- mapM (evaluate env) args let evaledArgs = map snd evaledArgs' doubleEvaledArgs' <- mapM (evaluate env) evaledArgs let doubleEvaledArgs = map snd doubleEvaledArgs' result <- curryCall env (reverse doubleEvaledArgs) fn - return (env, result) + -- maybe remove double eval here? can't remember why it was added + return (env, fnAst { astNode = astNode result }) evaluateSymbol :: Env -> String -> LContext (Env, AST) evaluateSymbol env sym = do @@ -169,10 +180,10 @@ evaluateSymbol env sym = do Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment" evaluate :: Env -> AST -> LContext (Env, AST) -evaluate env fnc@(ASTFunctionCall (first:args)) = +evaluate env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = do config <- ask when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc - case first of + case astNode x of ASTSymbol "\\" -> evaluateFunctionDef env args ASTSymbol "match" -> @@ -180,14 +191,14 @@ evaluate env fnc@(ASTFunctionCall (first:args)) = ASTSymbol "let" -> evaluateLet env args ASTSymbol "env" -> - evaluateEnv env + evaluateEnv env args _ -> - evaluateUserFunction env (first:args) -evaluate env (ASTSymbol sym) = + evaluateUserFunction env args +evaluate env AST { astNode = (ASTSymbol sym) } = evaluateSymbol env sym -evaluate env (ASTVector vec) = +evaluate env ast@AST { astNode = (ASTVector vec) } = do rets <- mapM (evaluate env) vec let vec' = map snd rets - return $ (env, ASTVector vec') + return $ (env, ast { astNode = ASTVector vec' }) evaluate env other = return (env, other) @@ -15,11 +15,11 @@ import Evaluator ( evaluate ) runScriptFile :: Env -> String -> LContext (Env, [AST]) runScriptFile env fileName = do src <- liftIO $ readFile fileName - runInlineScript env src + runInlineScript fileName env src -runInlineScript :: Env -> String -> LContext (Env, [AST]) -runInlineScript env src = do - tokenized <- tokenize src +runInlineScript :: String -> Env -> String -> LContext (Env, [AST]) +runInlineScript fileName env src = do + tokenized <- tokenize fileName src config <- ask when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized parsed <- parse tokenized diff --git a/src/Parser.hs b/src/Parser.hs index 62eff14..b60fdc9 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -4,27 +4,30 @@ module Parser ( import qualified Data.Map as M import qualified Data.List as L +import qualified Data.Maybe as MB import Control.Monad.Except import Text.Regex.TDFA import Utils validateBalance :: [String] -> [AST] -> LContext [AST] validateBalance allowed asts = do - when (ASTSymbol "(" `elem` asts && "(" `notElem` allowed) + when (ASTSymbol "(" `elem` astNodes && "(" `notElem` allowed) $ throwL "unbalanced function call" - when (ASTSymbol "[" `elem` asts && "[" `notElem` allowed) + when (ASTSymbol "[" `elem` astNodes && "[" `notElem` allowed) $ throwL "unbalanced vector" - when (ASTSymbol "{" `elem` asts && "{" `notElem` allowed) + when (ASTSymbol "{" `elem` astNodes && "{" `notElem` allowed) $ throwL "unbalanced hash map" return asts + where + astNodes = map astNode asts -parseToken :: String -> AST -parseToken token - | isInteger token = ASTInteger (read token) - | isDouble token = ASTDouble (read token) - | isString token = ASTString $ removeQuotes token - | isBoolean token = ASTBoolean $ asBoolean token - | otherwise = ASTSymbol token +parseToken :: Token -> AST +parseToken (Token token tr tc tf) + | isInteger token = ast $ ASTInteger (read token) + | isDouble token = ast $ ASTDouble (read token) + | isString token = ast $ ASTString $ removeQuotes token + | isBoolean token = ast $ ASTBoolean $ asBoolean token + | otherwise = ast $ ASTSymbol token where integerRegex = "^-?[[:digit:]]+$" isInteger :: String -> Bool @@ -36,32 +39,36 @@ parseToken token removeQuotes s = drop 1 s $> take (length s - 2) isBoolean t = t `elem` ["true", "false"] asBoolean t = if t == "true" then True else False + ast astNode = AST { astNode = astNode, astRow = tr, astColumn = tc, astFileName = tf } -_parse :: [AST] -> [String] -> LContext [AST] +_parse :: [AST] -> [Token] -> LContext [AST] _parse acc' [] = do acc <- validateBalance [] acc' return $ reverse acc -_parse acc (")":rest) = do - let children' = takeWhile (/= ASTSymbol "(") acc +_parse acc (Token { tokenContent = ")" }:rest) = do + let children' = takeWhile (astNode .> (/= ASTSymbol "(")) acc children <- validateBalance ["("] children' - let fnCall = ASTFunctionCall (reverse children) + let openParen = MB.fromJust $ L.find (astNode .> (== ASTSymbol "(")) acc + let fnCall = openParen { astNode = ASTFunctionCall (reverse children) } let newAcc = fnCall : drop (length children + 1) acc _parse newAcc rest -_parse acc ("]":rest) = do - let children' = takeWhile (/= ASTSymbol "[") acc +_parse acc (Token { tokenContent = "]" }:rest) = do + let children' = takeWhile (astNode .> (/= ASTSymbol "[")) acc children <- validateBalance ["["] children' - let vec = ASTVector (reverse children) + let openBracket = MB.fromJust $ L.find (astNode .> (== ASTSymbol "[")) acc + let vec = openBracket { astNode = ASTVector (reverse children) } let newAcc = vec : drop (length children + 1) acc _parse newAcc rest -_parse acc ("}":rest) = do - let children' = takeWhile (/= ASTSymbol "{") acc +_parse acc (Token { tokenContent = "}" }:rest) = do + let children' = takeWhile (astNode .> (/= ASTSymbol "{")) acc children <- validateBalance ["{"] children' pairs <- asPairsM $ reverse children - let vec = ASTHashMap (M.fromList pairs) - let newAcc = vec : drop (length children + 1) acc + let openCurly = MB.fromJust $ L.find (astNode .> (== ASTSymbol "{")) acc + let hmap = openCurly { astNode = ASTHashMap (M.fromList pairs) } + let newAcc = hmap : drop (length children + 1) acc _parse newAcc rest _parse acc (token:rest) = _parse (parseToken token : acc) rest -parse :: [String] -> LContext [AST] +parse :: [Token] -> LContext [AST] parse = _parse []
\ No newline at end of file diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs index f321502..64ba638 100644 --- a/src/Tokenizer.hs +++ b/src/Tokenizer.hs @@ -6,41 +6,91 @@ import qualified Data.Bifunctor as B import Control.Monad.Except import Utils -_tokenize :: [String] -> String -> String -> LContext [String] -_tokenize acc current src = case src of - "" -> return $ reverse current : acc - (x:xs) - | x == ';' -> - let commentDropped = dropWhile (\c -> c /= '\n') xs - in _tokenize (reverse current : acc) "" commentDropped - | x == '"' -> - -- String length -1 signals an unbalanced error - let inc k n = if n == -1 then -1 else n + k - consume :: String -> (String, Int) - consume str = case str of - ('\\':'"':rest) -> B.bimap ('\"' :) (inc 2) (consume rest) - ('\\':'n':rest) -> B.bimap ('\n' :) (inc 2) (consume rest) - ('\\':'t':rest) -> B.bimap ('\t' :) (inc 2) (consume rest) - ('"':_) -> ("", 1) - (c:rest) -> B.bimap (c :) (inc 1) (consume rest) - [] -> ("", -1) - (string, stringLength) = consume xs - stringDropped = drop (stringLength) xs - withQuotes = "\"" ++ string ++ "\"" - in do - when (stringLength == -1) $ throwL "unbalanced string literal" - _tokenize (withQuotes : acc) "" stringDropped - | x `elem` [' ', '\n', '\t', '\r'] -> - _tokenize (reverse current : acc) "" xs - | x `elem` ['(', ')', '[', ']', '{', '}', '\\'] -> - _tokenize ([x] : reverse current : acc) "" xs - | otherwise -> - _tokenize acc (x : current) xs +data TChar = TChar { + tChar :: Char, + tRow :: Int, + tColumn :: Int +} -tokenize :: String -> LContext [String] -tokenize src = do - tokens <- _tokenize [] "" src +_tokenize :: String -> [Token] -> [TChar] -> [TChar] -> LContext [Token] +_tokenize fileName acc current [] = + let cur = reverse current + token = Token { + tokenContent = cur $> map tChar, + tokenRow = tRow $ head cur, + tokenColumn = tColumn $ head cur, + tokenFileName = fileName } + in return $ token : acc +_tokenize fileName acc current (x:xs) + | tChar x == ';' = + let commentDropped = dropWhile (\tc -> tChar tc /= '\n') xs + cur = reverse current + token = Token { + tokenContent = cur $> map tChar, + tokenRow = tRow $ head cur, + tokenColumn = tColumn $ head cur, + tokenFileName = fileName } + in _tokenize fileName (token : acc) [] commentDropped + | tChar x == '"' = + -- String length -1 signals an unbalanced error + let inc k n = if n == -1 then -1 else n + k + consume :: String -> (String, Int) + consume str = case str of + ('\\':'"':rest) -> B.bimap ('\"' :) (inc 2) (consume rest) + ('\\':'n':rest) -> B.bimap ('\n' :) (inc 2) (consume rest) + ('\\':'t':rest) -> B.bimap ('\t' :) (inc 2) (consume rest) + ('"':_) -> ("", 1) + (c:rest) -> B.bimap (c :) (inc 1) (consume rest) + [] -> ("", -1) + (string, stringLength) = consume (map tChar xs) + stringDropped = drop (stringLength) xs + withQuotes = "\"" ++ string ++ "\"" + token = Token { + tokenContent = withQuotes, + tokenRow = tRow $ x, + tokenColumn = tColumn $ x, + tokenFileName = fileName } + in do + when (stringLength == -1) $ throwL "unbalanced string literal" + _tokenize fileName (token : acc) [] stringDropped + | tChar x `elem` [' ', '\n', '\t', '\r'] = + let cur = reverse current + token = Token { + tokenContent = cur $> map tChar, + tokenRow = tRow $ head cur, + tokenColumn = tColumn $ head cur, + tokenFileName = fileName } + in _tokenize fileName (token : acc) [] xs + | tChar x `elem` ['(', ')', '[', ']', '{', '}', '\\'] = + let cur = reverse current + token1 = Token { + tokenContent = [tChar x], + tokenRow = tRow x, + tokenColumn = tColumn x, + tokenFileName = fileName + } + token2 = Token { + tokenContent = cur $> map tChar, + tokenRow = tRow $ head cur, + tokenColumn = tColumn $ head cur, + tokenFileName = fileName + } + in _tokenize fileName (token1 : token2 : acc) [] xs + | otherwise = _tokenize fileName acc (x : current) xs + +tokenize :: String -> String -> LContext [Token] +tokenize fileName src = do + let tChars = augment 0 0 src + tokens <- _tokenize fileName [] [] tChars return $ tokens $> reverse - .> filter (\s -> length s > 0) + .> filter (\t -> length (tokenContent t) > 0) + where + augment row col ('\r':'\n':rest) = + TChar '\n' row col : augment 0 (col + 1) rest + augment row col ('\n':rest) = + TChar '\n' row col : augment 0 (col + 1) rest + augment row col (c:rest) = + TChar c (row + 1) col : augment 0 (col + 1) rest + augment _ _ [] = [] diff --git a/src/Utils.hs b/src/Utils.hs index 2b0f271..ba459e8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,11 +23,24 @@ type LContext a = ReaderT Config (ExceptT LException IO) a runL :: Config -> LContext a -> IO (Either LException a) runL config lc = runExceptT $ runReaderT lc config +data Token = Token { + tokenContent :: String, + tokenRow :: Int, + tokenColumn :: Int, + tokenFileName :: String +} + +instance (Eq Token) where + Token { tokenContent = tc1 } == Token { tokenContent = tc2 } = tc1 == tc2 + +instance (Show Token) where + show token = show $ tokenContent token + type Env = M.Map String AST type LFunction = (Env -> AST -> LContext AST) -data AST +data ASTNode = ASTInteger Int | ASTDouble Double | ASTSymbol String @@ -40,7 +53,17 @@ data AST | ASTUnit | ASTHole +data AST = AST { + astNode :: ASTNode, + astRow :: Int, + astColumn :: Int, + astFileName :: String +} + instance (Show AST) where + show (AST { astNode = node }) = show node + +instance (Show ASTNode) where show (ASTInteger n) = show n show (ASTDouble n) = show n show (ASTSymbol s) = s @@ -56,6 +79,9 @@ instance (Show AST) where show ASTHole = "<hole>" instance (Eq AST) where + AST { astNode = node1 } == AST { astNode = node2 } = node1 == node2 + +instance (Eq ASTNode) where ASTInteger a == ASTInteger b = a == b ASTDouble a == ASTDouble b = a == b ASTSymbol a == ASTSymbol b = a == b @@ -70,6 +96,9 @@ instance (Eq AST) where _ == _ = False instance (Ord AST) where + AST { astNode = node1 } <= AST { astNode = node2 } = node1 <= node2 + +instance (Ord ASTNode) where ASTInteger a <= ASTInteger b = a <= b ASTDouble a <= ASTDouble b = a <= b ASTSymbol a <= ASTSymbol b = a <= b @@ -84,34 +113,34 @@ instance (Ord AST) where _ <= _ = False assertIsASTFunction :: AST -> LContext AST -assertIsASTFunction ast = case ast of +assertIsASTFunction ast@(AST { astNode = node }) = case node of (ASTFunction _) -> return ast - _ -> throwL $ show ast ++ " is not a function" + _ -> throwL $ show node ++ " is not a function" assertIsASTInteger :: AST -> LContext AST -assertIsASTInteger ast = case ast of +assertIsASTInteger ast@(AST { astNode = node }) = case node of (ASTInteger _) -> return ast - _ -> throwL $ show ast ++ " is not an integer" + _ -> throwL $ show node ++ " is not an integer" assertIsASTSymbol :: AST -> LContext AST -assertIsASTSymbol ast = case ast of +assertIsASTSymbol ast@(AST { astNode = node }) = case node of (ASTSymbol _) -> return ast - _ -> throwL $ show ast ++ " is not a symbol" + _ -> throwL $ show node ++ " is not a symbol" assertIsASTVector :: AST -> LContext AST -assertIsASTVector ast = case ast of +assertIsASTVector ast@(AST { astNode = node }) = case node of (ASTVector _) -> return ast - _ -> throwL $ show ast ++ " is not a vector" + _ -> throwL $ show node ++ " is not a vector" assertIsASTString :: AST -> LContext AST -assertIsASTString ast = case ast of +assertIsASTString ast@(AST { astNode = node }) = case node of (ASTString _) -> return ast - _ -> throwL $ show ast ++ " is not a string" + _ -> throwL $ show node ++ " is not a string" assertIsASTFunctionCall :: AST -> LContext AST -assertIsASTFunctionCall ast = case ast of +assertIsASTFunctionCall ast@(AST { astNode = node }) = case node of (ASTFunctionCall _) -> return ast - _ -> throwL $ show ast ++ " is not a function call or body" + _ -> throwL $ show node ++ " is not a function call or body" -- UTILS @@ -146,3 +175,14 @@ asPairs (a:b:rest) = let restPaired = asPairs rest in (a, b) : restPaired asPairs _ = error "odd number of elements to pair up" + +makeNonsenseToken :: String -> Token +makeNonsenseToken content = + Token { tokenContent = content, tokenRow = -1, tokenColumn = -1, tokenFileName = "nonsense" } + +makeNonsenseAST :: ASTNode -> AST +makeNonsenseAST node = + AST { astNode = node, astRow = -1, astColumn = -1, astFileName = "nonsense"} + +pos :: AST -> String +pos AST { astRow = r, astColumn = c, astFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c |
