Refactor Lib.hs

1 files changed, 12 insertions, 265 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index f12915d..a653336 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -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)
+