diff options
Diffstat (limited to 'src/Lib.hs')
| -rw-r--r-- | src/Lib.hs | 277 |
1 files changed, 12 insertions, 265 deletions
@@ -4,280 +4,19 @@ module Lib ( runInlineScript, ) where -import qualified Data.Map as M -import qualified Data.Bifunctor as B import qualified Data.List as L import Control.Monad.Except import Control.Monad.Reader -import Text.Regex.TDFA 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 - -tokenize :: String -> LContext [String] -tokenize src = do - tokens <- _tokenize [] "" src - return $ tokens - $> reverse - .> filter (\s -> length s > 0) - -validateBalance :: [String] -> [AST] -> LContext [AST] -validateBalance allowed asts = do - when (ASTSymbol "(" `elem` asts && "(" `notElem` allowed) - $ throwL "unbalanced function call" - when (ASTSymbol "[" `elem` asts && "[" `notElem` allowed) - $ throwL "unbalanced vector" - when (ASTSymbol "{" `elem` asts && "{" `notElem` allowed) - $ throwL "unbalanced hash map" - return asts - -asPairsM :: [a] -> LContext [(a, a)] -asPairsM [] = return [] -asPairsM (a:b:rest) = do - restPaired <- asPairsM rest - return $ (a, b) : restPaired -asPairsM _ = throwL "odd number of elements to pair up" - -asPairs :: [a] -> [(a, a)] -asPairs [] = [] -asPairs (a:b:rest) = - let restPaired = asPairs rest - in (a, b) : restPaired -asPairs _ = error "odd number of elements to pair up" - -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 - where - integerRegex = "^-?[[:digit:]]+$" - isInteger :: String -> Bool - isInteger t = t =~ integerRegex - doubleRegex = "^-?[[:digit:]]+(\\.[[:digit:]]+)?$" - isDouble :: String -> Bool - isDouble t = t =~ doubleRegex - isString t = "\"" `L.isPrefixOf` t - removeQuotes s = drop 1 s $> take (length s - 2) - isBoolean t = t `elem` ["true", "false"] - asBoolean t = if t == "true" then True else False - -_parse :: [AST] -> [String] -> LContext [AST] -_parse acc' [] = do - acc <- validateBalance [] acc' - return $ reverse acc -_parse acc (")":rest) = do - let children' = takeWhile (/= ASTSymbol "(") acc - children <- validateBalance ["("] children' - let fnCall = ASTFunctionCall (reverse children) - let newAcc = fnCall : drop (length children + 1) acc - _parse newAcc rest -_parse acc ("]":rest) = do - let children' = takeWhile (/= ASTSymbol "[") acc - children <- validateBalance ["["] children' - let vec = ASTVector (reverse children) - let newAcc = vec : drop (length children + 1) acc - _parse newAcc rest -_parse acc ("}":rest) = do - let children' = takeWhile (/= ASTSymbol "{") acc - children <- validateBalance ["{"] children' - pairs <- asPairsM $ reverse children - let vec = ASTHashMap (M.fromList pairs) - let newAcc = vec : drop (length children + 1) acc - _parse newAcc rest -_parse acc (token:rest) = - _parse (parseToken token : acc) rest - -parse :: [String] -> LContext [AST] -parse = _parse [] - -_curryCall :: Env -> [AST] -> LFunction -> LContext AST -_curryCall _ [] f = return $ ASTFunction f -_curryCall env (arg:[]) f = f env arg -_curryCall env (arg:rest) f = do - g <- _curryCall env rest f - case 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 args f = _curryCall env args f - -traverseAndReplace :: String -> AST -> AST -> AST -traverseAndReplace param arg ast@(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 - $> L.concatMap (\(a, b) -> [a, b]) - .> map (traverseAndReplace param arg) - .> asPairs .> M.fromList -traverseAndReplace _ _ other = other - -evalLetExpr :: Env -> [AST] -> LContext (String, AST) -evalLetExpr env args = - case args of - [ASTSymbol symbol', value'] -> do - (_, evaledValue) <- evaluate env value' - return (symbol', evaledValue) - [ASTSymbol "lazy", ASTSymbol symbol', value'] -> do - return (symbol', value') - other -> throwL $ "let called with invalid args " ++ show other - -foldSymValPairs :: [(String, AST)] -> AST -> AST -foldSymValPairs [] body = body -foldSymValPairs ((sym, val):rest) body = - let replacedRestVals = map (snd .> traverseAndReplace sym val) rest - replacedRest = zip (map fst rest) (replacedRestVals) - replacedBody = traverseAndReplace sym val body - in foldSymValPairs replacedRest replacedBody - -makeUserDefFn :: AST -> [AST] -> LFunction -makeUserDefFn (ASTSymbol param) exprs = - let fn :: LFunction - fn env arg = do - let replacedExprs = map (traverseAndReplace param arg) exprs - let letExprs = take (length exprs - 1) replacedExprs - letSymValPairs <- letExprs - $> map (\case (ASTFunctionCall v) -> drop 1 v - _ -> error $ "unreachable: map letExprs") - .> mapM (evalLetExpr env) - let body = head $ drop (length exprs - 1) replacedExprs - let newBody = traverseAndReplace param arg body - $> foldSymValPairs letSymValPairs - (_, ret) <- evaluate env newBody - return ret - in fn -makeUserDefFn _ _ = error $ "unreachable: makeUserDefFn" - -curriedMakeUserDefFn :: [AST] -> [AST] -> LFunction -curriedMakeUserDefFn [] exprs = makeUserDefFn (ASTSymbol "_") exprs -curriedMakeUserDefFn (param:[]) exprs = makeUserDefFn param exprs -curriedMakeUserDefFn ((ASTSymbol param):rest) exprs = - let fn :: LFunction - fn _ arg = do - let newExprs = map (traverseAndReplace param arg) exprs - let ret = curriedMakeUserDefFn rest newExprs - return $ ASTFunction $ ret - in fn -curriedMakeUserDefFn _ _ = error $ "unreachable: curriedMakeUserDefFn" - -evaluate :: Env -> AST -> LContext (Env, AST) -evaluate env (ASTFunctionCall (first:args)) - | first == ASTSymbol "\\" = do - (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'' - params <- mapM assertIsASTSymbol params' - - let letExprs = take (length exprs - 1) exprs - when (any (\case ASTFunctionCall (ASTSymbol "let":_) -> False; _ -> True) letExprs) - $ throwL "non-let expression in function definition before body" - - let fn = curriedMakeUserDefFn params exprs - return $ (env, ASTFunction fn) - | first == ASTSymbol "match" = do - (cond, rest) <- case args of - [] -> throwL $ "match called with no arguments" - (_:[]) -> throwL $ "empty match cases" - (a:b) -> return (a, b) - if length rest `mod` 2 == 0 - then do - caseMatchers' <- oddElems rest $> mapM (evaluate env) - let caseMatchers = map snd caseMatchers' - let caseBranches = evenElems rest - let caseMap = M.fromList $ L.zip caseMatchers caseBranches - (_, evaledCond) <- evaluate env cond - case M.lookup evaledCond caseMap of - Just branch -> evaluate env branch - Nothing -> throwL $ "matching case not found when matching on value: " ++ show cond - else do - let (defaultBranch, revCases) = case reverse rest of - (a:b) -> (a, b) - _ -> error $ "unreachable: reverse rest" - caseMatchers' <- oddElems (reverse revCases) $> mapM (evaluate env) - let caseMatchers = map snd caseMatchers' - let caseBranches = evenElems (reverse revCases) - let caseMap = M.fromList $ L.zip caseMatchers caseBranches - (_, evaledCond) <- evaluate env cond - case M.lookup evaledCond caseMap of - Just branch -> evaluate env branch - Nothing -> evaluate env defaultBranch - | first == ASTSymbol "let" = do - (symbol, value) <- evalLetExpr env args - when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol - let newEnv = M.insert symbol value env - return $ (newEnv, ASTUnit) - | first == ASTSymbol "env" = do - liftIO $ putStrLn $ show env - return (env, ASTUnit) - | otherwise = do - (_, fnEvaled) <- evaluate env first - (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) -evaluate env (ASTSymbol sym) = do - let val = M.lookup sym env - case val of - Just ast -> return (env, ast) - Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment" -evaluate env ast = return (env, ast) +import Tokenizer ( tokenize ) +import Parser ( parse ) +import Evaluator ( evaluate ) runScriptFile :: Env -> String -> LContext Env runScriptFile env fileName = do src <- liftIO $ readFile fileName runInlineScript env src -evalParsed :: Env -> [AST] -> LContext (Env, [AST]) -evalParsed env [] = return (env, []) -evalParsed env (ast:rest) = do - (newEnv, newAst) <- evaluate env ast - (retEnv, restEvaled) <- evalParsed newEnv rest - return $ (retEnv, newAst : restEvaled) - runInlineScript :: Env -> String -> LContext Env runInlineScript env src = do tokenized <- tokenize src @@ -287,6 +26,14 @@ runInlineScript env src = do when (configVerboseMode config) $ do let output = "parsed:\t\t\t" ++ (map show parsed $> L.intercalate "\n\t\t\t") liftIO $ putStrLn output - (newEnv, evaluated) <- evalParsed env parsed + (newEnv, evaluated) <- foldEvaluate env parsed liftIO $ mapM_ putStrLn (map show evaluated) return newEnv + where + foldEvaluate :: Env -> [AST] -> LContext (Env, [AST]) + foldEvaluate accEnv [] = return (accEnv, []) + foldEvaluate accEnv (ast:rest) = do + (newAccEnv, newAst) <- evaluate accEnv ast + (retEnv, restEvaled) <- foldEvaluate newAccEnv rest + return $ (retEnv, newAst : restEvaled) + |