diff options
| -rw-r--r-- | app/Main.hs | 2 | ||||
| -rw-r--r-- | lang.cabal | 1 | ||||
| -rw-r--r-- | src/Builtins.hs | 18 | ||||
| -rw-r--r-- | src/Lib.hs | 29 | ||||
| -rw-r--r-- | src/Types.hs | 94 | ||||
| -rw-r--r-- | src/Utils.hs | 101 |
6 files changed, 124 insertions, 121 deletions
diff --git a/app/Main.hs b/app/Main.hs index 84e95d2..06ddb62 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,7 +3,7 @@ import System.Environment import Control.Monad.Except import Control.Monad.Reader import System.Console.Haskeline -import Types +import Utils import Builtins import Lib @@ -27,7 +27,6 @@ library exposed-modules: Builtins Lib - Types Utils other-modules: Paths_lang diff --git a/src/Builtins.hs b/src/Builtins.hs index 1ac532a..37c9238 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -2,8 +2,8 @@ module Builtins where import qualified Data.Map as M -import Control.Monad.Except ( when, MonadError(throwError) ) -import Types +import Control.Monad.Except +import Utils builtinEnv :: Env builtinEnv = M.fromList [ @@ -25,15 +25,15 @@ builtinAdd2 = let inner :: LFunction inner _ (ASTInteger b) = return $ ASTInteger $ a + b - inner _ other = throwError $ LException $ "invalid argument to integer add: " ++ show other + inner _ other = throwL $ "invalid argument to integer add: " ++ show other return $ ASTFunction $ inner outer _ (ASTDouble a) = do let inner :: LFunction inner _ (ASTDouble b) = return $ ASTDouble $ a + b - inner _ other = throwError $ LException $ "invalid argument to double add: " ++ show other + inner _ other = throwL $ "invalid argument to double add: " ++ show other return $ ASTFunction $ inner - outer _ other = throwError $ LException $ "non-numeric argument to add: " ++ show other + outer _ other = throwL $ "non-numeric argument to add: " ++ show other in ASTFunction outer @@ -63,7 +63,7 @@ builtinDivide2 = (ASTInteger a) <- assertIsASTInteger ast1 let inner _ ast2 = do (ASTInteger b) <- assertIsASTInteger ast2 - when (b == 0) $ throwError $ LException $ "division by zero" + when (b == 0) $ throwL $ "division by zero" return $ ASTInteger $ a `div` b return $ ASTFunction $ inner in ASTFunction outer @@ -72,7 +72,7 @@ builtinHead :: AST builtinHead = let outer _ ast = do (ASTVector vec) <- assertIsASTVector ast - when (length vec == 0) $ throwError $ LException $ "head of empty vector" + when (length vec == 0) $ throwL $ "head of empty vector" return $ head vec in ASTFunction outer @@ -80,7 +80,7 @@ builtinTail :: AST builtinTail = let outer _ ast = do (ASTVector vec) <- assertIsASTVector ast - when (length vec == 0) $ throwError $ LException $ "tail of empty vector" + when (length vec == 0) $ throwL $ "tail of empty vector" return $ ASTVector $ tail vec in ASTFunction outer @@ -91,4 +91,4 @@ builtinPrepend = (ASTVector vec) <- assertIsASTVector ast2 return $ ASTVector $ ast1 : vec return $ ASTFunction $ inner - in ASTFunction outer
\ No newline at end of file + in ASTFunction outer @@ -10,7 +10,6 @@ import qualified Data.List as L import Control.Monad.Except import Control.Monad.Reader import Text.Regex.TDFA -import Types import Utils _tokenize :: [String] -> String -> String -> LContext [String] @@ -35,7 +34,7 @@ _tokenize acc current src = case src of stringDropped = drop (stringLength) xs withQuotes = "\"" ++ string ++ "\"" in do - when (stringLength == -1) $ throwError (LException "unbalanced string literal") + when (stringLength == -1) $ throwL "unbalanced string literal" _tokenize (withQuotes : acc) "" stringDropped | x `elem` [' ', '\n', '\t', '\r'] -> _tokenize (reverse current : acc) "" xs @@ -54,11 +53,11 @@ tokenize src = do validateBalance :: [String] -> [AST] -> LContext [AST] validateBalance allowed asts = do when (ASTSymbol "(" `elem` asts && "(" `notElem` allowed) - $ throwError $ LException "unbalanced function call" + $ throwL "unbalanced function call" when (ASTSymbol "[" `elem` asts && "[" `notElem` allowed) - $ throwError $ LException "unbalanced vector" + $ throwL "unbalanced vector" when (ASTSymbol "{" `elem` asts && "{" `notElem` allowed) - $ throwError $ LException "unbalanced hash map" + $ throwL "unbalanced hash map" return asts asPairsM :: [a] -> LContext [(a, a)] @@ -66,7 +65,7 @@ asPairsM [] = return [] asPairsM (a:b:rest) = do restPaired <- asPairsM rest return $ (a, b) : restPaired -asPairsM _ = throwError $ LException "odd number of elements to pair up" +asPairsM _ = throwL "odd number of elements to pair up" asPairs :: [a] -> [(a, a)] asPairs [] = [] @@ -130,7 +129,7 @@ _curryCall env (arg:rest) f = do g <- _curryCall env rest f case g of ASTFunction f' -> f' env arg - other -> throwError $ LException $ "cannot call value " ++ show other ++ " as a function" + other -> throwL $ "cannot call value " ++ show other ++ " as a function" curryCall :: Env -> [AST] -> LFunction -> LContext AST curryCall env [] f = f env ASTUnit @@ -159,7 +158,7 @@ evalLetExpr env args = return (symbol', evaledValue) [ASTSymbol "lazy", ASTSymbol symbol', value'] -> do return (symbol', value') - other -> throwError $ LException $ "let called with invalid args " ++ show other + other -> throwL $ "let called with invalid args " ++ show other foldSymValPairs :: [(String, AST)] -> AST -> AST foldSymValPairs [] body = body @@ -205,21 +204,21 @@ evaluate env (ASTFunctionCall (first:args)) (params'', exprs) <- case args of args' | length args' < 2 -> - throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments" + 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) - $ throwError $ LException "non-let expression in function definition before body" + $ 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 - [] -> throwError $ LException $ "match called with no arguments" - (_:[]) -> throwError $ LException $ "empty match cases" + [] -> throwL $ "match called with no arguments" + (_:[]) -> throwL $ "empty match cases" (a:b) -> return (a, b) if length rest `mod` 2 == 0 then do @@ -230,7 +229,7 @@ evaluate env (ASTFunctionCall (first:args)) (_, evaledCond) <- evaluate env cond case M.lookup evaledCond caseMap of Just branch -> evaluate env branch - Nothing -> throwError $ LException $ "matching case not found when matching on value" ++ show cond + 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) @@ -245,7 +244,7 @@ evaluate env (ASTFunctionCall (first:args)) Nothing -> evaluate env defaultBranch | first == ASTSymbol "let" = do (symbol, value) <- evalLetExpr env args - when (M.member symbol env) $ throwError $ LException $ "symbol already defined: " ++ symbol + when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol let newEnv = M.insert symbol value env return $ (newEnv, ASTUnit) | first == ASTSymbol "env" = do @@ -264,7 +263,7 @@ evaluate env (ASTSymbol sym) = do let val = M.lookup sym env case val of Just ast -> return (env, ast) - Nothing -> throwError $ LException $ "symbol " ++ sym ++ " not defined in environment" + Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment" evaluate env ast = return (env, ast) runScriptFile :: Env -> String -> LContext Env diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 index 21a1ceb..0000000 --- a/src/Types.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-export-lists #-} -module Types where - -import Control.Monad.Except -import Control.Monad.Reader -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Char as C -import Utils - -newtype LException = LException String -data Config = Config { - configScriptFileName :: Maybe String, - configVerboseMode :: Bool, - configShowHelp :: Bool -} - -type LContext a = ReaderT Config (ExceptT LException IO) a - -type Env = M.Map String AST - -type LFunction = (Env -> AST -> LContext AST) - -data AST - = ASTInteger Int - | ASTDouble Double - | ASTSymbol String - | ASTBoolean Bool - | ASTString String - | ASTVector [AST] - | ASTFunctionCall [AST] - | ASTHashMap (M.Map AST AST) - | ASTFunction LFunction - | ASTUnit - -instance (Show AST) where - show (ASTInteger n) = show n - show (ASTDouble n) = show n - show (ASTSymbol s) = s - show (ASTBoolean b) = show b $> map C.toLower - show (ASTString s) = show s - show (ASTVector v) = "[" ++ L.intercalate " " (map show v) ++ "]" - show (ASTFunctionCall v) = "(" ++ L.intercalate " " (map show v) ++ ")" - show (ASTHashMap m) = - let flattenMap = M.assocs .> L.concatMap (\(k, v) -> [k, v]) - in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}" - show (ASTFunction _) = "<fn>" - show ASTUnit = "<unit>" - -instance (Eq AST) where - ASTInteger a == ASTInteger b = a == b - ASTDouble a == ASTDouble b = a == b - ASTSymbol a == ASTSymbol b = a == b - ASTBoolean a == ASTBoolean b = a == b - ASTString a == ASTString b = a == b - ASTVector a == ASTVector b = a == b - ASTHashMap a == ASTHashMap b = a == b - ASTUnit == ASTUnit = True - _ == _ = False - -instance (Ord AST) where - ASTInteger a <= ASTInteger b = a <= b - ASTDouble a <= ASTDouble b = a <= b - ASTSymbol a <= ASTSymbol b = a <= b - ASTBoolean a <= ASTBoolean b = a <= b - ASTString a <= ASTString b = a <= b - ASTVector a <= ASTVector b = a <= b - ASTHashMap a <= ASTHashMap b = a <= b - _ <= _ = False - -assertIsASTFunction :: AST -> LContext AST -assertIsASTFunction ast = case ast of - (ASTFunction _) -> return ast - _ -> throwError $ LException $ show ast ++ " is not a function" - -assertIsASTInteger :: AST -> LContext AST -assertIsASTInteger ast = case ast of - (ASTInteger _) -> return ast - _ -> throwError $ LException $ show ast ++ " is not an integer" - -assertIsASTSymbol :: AST -> LContext AST -assertIsASTSymbol ast = case ast of - (ASTSymbol _) -> return ast - _ -> throwError $ LException $ show ast ++ " is not a symbol" - -assertIsASTVector :: AST -> LContext AST -assertIsASTVector ast = case ast of - (ASTVector _) -> return ast - _ -> throwError $ LException $ show ast ++ " is not a vector" - -assertIsASTFunctionCall :: AST -> LContext AST -assertIsASTFunctionCall ast = case ast of - (ASTFunctionCall _) -> return ast - _ -> throwError $ LException $ show ast ++ " is not a function call or body" diff --git a/src/Utils.hs b/src/Utils.hs index d2068d4..fe0a9c2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,8 +1,104 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} module Utils where +import Control.Monad.Except +import Control.Monad.Reader +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Char as C + +-- TYPES + +newtype LException = LException String +data Config = Config { + configScriptFileName :: Maybe String, + configVerboseMode :: Bool, + configShowHelp :: Bool +} + +type LContext a = ReaderT Config (ExceptT LException IO) a + +type Env = M.Map String AST + +type LFunction = (Env -> AST -> LContext AST) + +data AST + = ASTInteger Int + | ASTDouble Double + | ASTSymbol String + | ASTBoolean Bool + | ASTString String + | ASTVector [AST] + | ASTFunctionCall [AST] + | ASTHashMap (M.Map AST AST) + | ASTFunction LFunction + | ASTUnit + +instance (Show AST) where + show (ASTInteger n) = show n + show (ASTDouble n) = show n + show (ASTSymbol s) = s + show (ASTBoolean b) = show b $> map C.toLower + show (ASTString s) = show s + show (ASTVector v) = "[" ++ L.intercalate " " (map show v) ++ "]" + show (ASTFunctionCall v) = "(" ++ L.intercalate " " (map show v) ++ ")" + show (ASTHashMap m) = + let flattenMap = M.assocs .> L.concatMap (\(k, v) -> [k, v]) + in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}" + show (ASTFunction _) = "<fn>" + show ASTUnit = "<unit>" + +instance (Eq AST) where + ASTInteger a == ASTInteger b = a == b + ASTDouble a == ASTDouble b = a == b + ASTSymbol a == ASTSymbol b = a == b + ASTBoolean a == ASTBoolean b = a == b + ASTString a == ASTString b = a == b + ASTVector a == ASTVector b = a == b + ASTHashMap a == ASTHashMap b = a == b + ASTUnit == ASTUnit = True + _ == _ = False + +instance (Ord AST) where + ASTInteger a <= ASTInteger b = a <= b + ASTDouble a <= ASTDouble b = a <= b + ASTSymbol a <= ASTSymbol b = a <= b + ASTBoolean a <= ASTBoolean b = a <= b + ASTString a <= ASTString b = a <= b + ASTVector a <= ASTVector b = a <= b + ASTHashMap a <= ASTHashMap b = a <= b + _ <= _ = False + +assertIsASTFunction :: AST -> LContext AST +assertIsASTFunction ast = case ast of + (ASTFunction _) -> return ast + _ -> throwL $ show ast ++ " is not a function" + +assertIsASTInteger :: AST -> LContext AST +assertIsASTInteger ast = case ast of + (ASTInteger _) -> return ast + _ -> throwL $ show ast ++ " is not an integer" + +assertIsASTSymbol :: AST -> LContext AST +assertIsASTSymbol ast = case ast of + (ASTSymbol _) -> return ast + _ -> throwL $ show ast ++ " is not a symbol" + +assertIsASTVector :: AST -> LContext AST +assertIsASTVector ast = case ast of + (ASTVector _) -> return ast + _ -> throwL $ show ast ++ " is not a vector" + +assertIsASTFunctionCall :: AST -> LContext AST +assertIsASTFunctionCall ast = case ast of + (ASTFunctionCall _) -> return ast + _ -> throwL $ show ast ++ " is not a function call or body" + +-- UTILS + +(.>) :: (a -> b) -> (b -> c) -> a -> c (.>) = flip (.) +($>) :: b -> (b -> c) -> c ($>) = flip ($) infixr 6 $> @@ -14,3 +110,6 @@ oddElems (x:xs) = x:evenElems xs evenElems :: [a] -> [a] evenElems [] = [] evenElems (_:xs) = oddElems xs + +throwL :: String -> LContext a +throwL s = throwError $ LException s |