diff options
| -rw-r--r-- | lang.cabal | 3 | ||||
| -rw-r--r-- | src/Builtins.hs | 3 | ||||
| -rw-r--r-- | src/Evaluator.hs | 153 | ||||
| -rw-r--r-- | src/Lib.hs | 277 | ||||
| -rw-r--r-- | src/Parser.hs | 67 | ||||
| -rw-r--r-- | src/Tokenizer.hs | 46 | ||||
| -rw-r--r-- | src/Utils.hs | 14 |
7 files changed, 297 insertions, 266 deletions
@@ -26,7 +26,10 @@ source-repository head library exposed-modules: Builtins + Evaluator Lib + Parser + Tokenizer Utils other-modules: Paths_lang diff --git a/src/Builtins.hs b/src/Builtins.hs index 37c9238..a4676b8 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -17,7 +17,8 @@ builtinEnv = M.fromList [ ] -- maybe make a builtinBinaryFunction? --- builtinAdd2 = builtinBinaryFunction (ASTInteger a) (ASTInteger b) (\a b -> a + b) +-- builtinBinaryFunction :: AST -> AST -> (AST -> AST -> AST) -> AST +-- builtinAdd2 = builtinBinaryFunction (ASTInteger a) (ASTInteger b) (\(ASTInteger a) (ASTInteger b) -> ASTInteger $ a + b) builtinAdd2 :: AST builtinAdd2 = let outer :: LFunction diff --git a/src/Evaluator.hs b/src/Evaluator.hs new file mode 100644 index 0000000..8954264 --- /dev/null +++ b/src/Evaluator.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE LambdaCase #-} +module Evaluator ( + evaluate, +) where + +import qualified Data.Map as M +import qualified Data.List as L +import Control.Monad.Except +import Utils + +_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) @@ -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) + diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 index 0000000..62eff14 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,67 @@ +module Parser ( + parse, +) where + +import qualified Data.Map as M +import qualified Data.List as L +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) + $ 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 + +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 []
\ No newline at end of file diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs new file mode 100644 index 0000000..f321502 --- /dev/null +++ b/src/Tokenizer.hs @@ -0,0 +1,46 @@ +module Tokenizer ( + tokenize, +) where + +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 + +tokenize :: String -> LContext [String] +tokenize src = do + tokens <- _tokenize [] "" src + return $ tokens + $> reverse + .> filter (\s -> length s > 0) + diff --git a/src/Utils.hs b/src/Utils.hs index fe0a9c2..e2c182b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -113,3 +113,17 @@ evenElems (_:xs) = oddElems xs throwL :: String -> LContext a throwL s = throwError $ LException s + +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" |