aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Builtins.hs197
-rw-r--r--src/Evaluator.hs60
-rw-r--r--src/Utils.hs6
3 files changed, 154 insertions, 109 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs
index d35ce17..0ddf89f 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -8,17 +8,28 @@ import Utils
builtinEnv :: Env
builtinEnv = M.fromList [
+ -- arithmetic
builtinAdd2,
builtinSubtract2,
builtinMultiply2,
builtinDivide2,
+ -- conversions
+ builtinFmt,
+ builtinFloor,
+ builtinToDouble,
+ -- vector operations
builtinHead,
builtinTail,
builtinPrepend,
- builtinPrint,
+ -- string operations
+ builtinSubstr,
+ -- vector & string operations
builtinConcat,
- builtinFmt,
+ -- special
+ builtinPrint,
("unit", ASTUnit),
+ ("_", ASTHole),
+ ("otherwise", ASTHole),
builtinFatal
]
@@ -28,131 +39,159 @@ argError1 fn 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
+argError3 :: (Show a1, Show a2, Show a3) => String -> a1 -> a2 -> a3 -> String
+argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3
+
-- BUILTINS
builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, ASTFunction outer) where
+builtinAdd2 = (name, ASTFunction fn1) where
name = "+"
- outer _ ast1@(ASTInteger a) =
- return $ ASTFunction $ inner where
- inner _ (ASTInteger b) =
+ fn1 _ ast1@(ASTInteger a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTInteger b) =
return $ ASTInteger $ a + b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1@(ASTDouble a) =
- return $ ASTFunction $ inner where
- inner _ (ASTDouble b) =
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1@(ASTDouble a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTDouble b) =
return $ ASTDouble $ a + b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, ASTFunction outer) where
+builtinSubtract2 = (name, ASTFunction fn1) where
name = "-"
- outer _ ast1@(ASTInteger a) =
- return $ ASTFunction $ inner where
- inner _ (ASTInteger b) =
+ fn1 _ ast1@(ASTInteger a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTInteger b) =
return $ ASTInteger $ a - b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1@(ASTDouble a) =
- return $ ASTFunction $ inner where
- inner _ (ASTDouble b) =
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1@(ASTDouble a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTDouble b) =
return $ ASTDouble $ a - b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, ASTFunction outer) where
+builtinMultiply2 = (name, ASTFunction fn1) where
name = "*"
- outer _ ast1@(ASTInteger a) =
- return $ ASTFunction $ inner where
- inner _ (ASTInteger b) =
+ fn1 _ ast1@(ASTInteger a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTInteger b) =
return $ ASTInteger $ a * b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1@(ASTDouble a) =
- return $ ASTFunction $ inner where
- inner _ (ASTDouble b) =
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1@(ASTDouble a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTDouble b) =
return $ ASTDouble $ a * b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, ASTFunction outer) where
+builtinDivide2 = (name, ASTFunction fn1) where
name = "/"
- outer _ ast1@(ASTInteger a) =
- return $ ASTFunction $ inner where
- inner _ (ASTInteger b) =
+ fn1 _ ast1@(ASTInteger a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTInteger b) =
do when (b == 0) $ throwL $ "division by zero"
return $ ASTInteger $ a `div` b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1@(ASTDouble a) =
- return $ ASTFunction $ inner where
- inner _ (ASTDouble b) =
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1@(ASTDouble a) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTDouble b) =
do when (b == 0) $ throwL $ "division by zero"
return $ ASTDouble $ a / b
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
+
+builtinFloor :: (String, AST)
+builtinFloor = (name, ASTFunction fn1) where
+ name = "floor"
+ fn1 _ (ASTDouble dbl) = return $ ASTInteger $ floor dbl
+ fn1 _ ast = throwL $ argError1 name ast
+
+builtinToDouble :: (String, AST)
+builtinToDouble = (name, ASTFunction fn1) where
+ name = "to-double"
+ fn1 _ (ASTInteger int) = return $ ASTDouble $ fromIntegral int
+ fn1 _ ast = throwL $ argError1 name ast
+
+builtinFmt :: (String, AST)
+builtinFmt = (name, 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)
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
+ replaceAll _ [] text = text
+ replaceAll n (x:xs) text =
+ let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
+ in replaceAll (n + 1) xs text'
builtinHead :: (String, AST)
-builtinHead = (name, ASTFunction outer) where
+builtinHead = (name, ASTFunction fn1) where
name = "head"
- outer _ (ASTVector vec) =
+ fn1 _ (ASTVector vec) =
do when (length vec == 0) $ throwL $ name ++ " of empty vector"
return $ head vec
- outer _ ast = throwL $ argError1 name ast
+ fn1 _ ast = throwL $ argError1 name ast
builtinTail :: (String, AST)
-builtinTail = (name, ASTFunction outer) where
+builtinTail = (name, ASTFunction fn1) where
name = "tail"
- outer _ (ASTVector vec) =
+ fn1 _ (ASTVector vec) =
do when (length vec == 0) $ throwL $ name ++ " of empty vector"
return $ ASTVector $ tail vec
- outer _ ast = throwL $ argError1 name ast
+ fn1 _ ast = throwL $ argError1 name ast
+
+builtinSubstr :: (String, AST)
+builtinSubstr = (name, 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
+ 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 outer) where
+builtinPrepend = (name, ASTFunction fn1) where
name = "prepend"
- outer _ ast1 =
- return $ ASTFunction $ inner where
- inner _ (ASTVector vec) =
+ fn1 _ ast1 =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTVector vec) =
return $ ASTVector $ ast1 : vec
- inner _ ast2 = throwL $ argError2 name ast1 ast2
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
builtinPrint :: (String, AST)
-builtinPrint = (name, ASTFunction outer) where
+builtinPrint = (name, ASTFunction fn1) where
name = "print!"
- outer _ (ASTString str) =
+ fn1 _ (ASTString str) =
do liftIO $ putStr $ str
return ASTUnit
- outer _ ast = throwL $ argError1 name ast
+ fn1 _ ast = throwL $ argError1 name ast
builtinConcat :: (String, AST)
-builtinConcat = (name, ASTFunction outer) where
+builtinConcat = (name, ASTFunction fn1) where
name = "concat"
- outer _ ast1@(ASTString str1) =
- return $ ASTFunction $ inner where
- inner _ (ASTString str2) =
+ fn1 _ ast1@(ASTString str1) =
+ return $ ASTFunction $ fn2 where
+ fn2 _ (ASTString str2) =
return $ ASTString $ str1 ++ str2
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
-
-builtinFmt :: (String, AST)
-builtinFmt = (name, ASTFunction outer) where
- name = "fmt"
- outer _ ast1@(ASTString str) =
- return $ ASTFunction $ inner where
- inner _ (ASTVector replacements) =
- return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
- inner _ ast2 = throwL $ argError2 name ast1 ast2
- outer _ ast1 = throwL $ argError1 name ast1
- replaceAll _ [] text = text
- replaceAll n (x:xs) text =
- let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
- in replaceAll (n + 1) xs text'
+ fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+ fn1 _ ast1 = throwL $ argError1 name ast1
builtinFatal :: (String, AST)
-builtinFatal = (name, ASTFunction outer) where
+builtinFatal = (name, ASTFunction fn1) where
name = "fatal"
- outer _ (ASTString str) =
+ fn1 _ (ASTString str) =
throwL $ str
- outer _ ast =
+ fn1 _ ast =
throwL $ argError1 name ast
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index 32f287a..a0c6151 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -7,7 +7,9 @@ import qualified Data.Map as M
import qualified Data.List as L
import Data.Function ( on )
import Control.Monad.Reader
+import Control.Monad.Except ( catchError )
import Utils
+-- import Debug.Trace
_curryCall :: Env -> [AST] -> LFunction -> LContext AST
_curryCall _ [] f = return $ ASTFunction f
@@ -71,11 +73,11 @@ defineUserFunction (ASTSymbol param) exprs = return fn where
(_, ret) <- evaluate env newBody
return ret
-defineUserFunction _ _ = throwL $ "unreachable: defineUserFunction"
+defineUserFunction param exprs = throwL $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs
defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction
defineUserFunctionWithLetExprs [] exprs =
- defineUserFunction (ASTSymbol "_") exprs
+ defineUserFunction (ASTSymbol "unit") exprs
defineUserFunctionWithLetExprs (param:[]) exprs =
defineUserFunction param exprs
defineUserFunctionWithLetExprs ((ASTSymbol param):rest) exprs = return fn where
@@ -97,7 +99,7 @@ evaluateFunctionDef env args = do
params <- mapM assertIsASTSymbol params'
let letExprs = take (length exprs - 1) exprs
- when (any (\case ASTFunctionCall (ASTSymbol "let":_) -> False; _ -> True) letExprs)
+ unless (all (\case ASTFunctionCall (ASTSymbol "let":_) -> True; _ -> False) letExprs)
$ throwL "non-let expression in function definition before body"
fn <- defineUserFunctionWithLetExprs params exprs
@@ -105,33 +107,31 @@ evaluateFunctionDef env args = do
evaluateMatch :: Env -> [AST] -> LContext (Env, AST)
evaluateMatch env args = do
- (actual, 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
- (_, evaledActual) <- evaluate env actual
- case M.lookup evaledActual caseMap of
- Just branch -> evaluate env branch
- Nothing -> throwL $ "matching case not found when matching on expression: " ++ show actual
- ++ " (actual value: " ++ show evaledActual ++ ")"
- 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
- (_, evaledActual) <- evaluate env actual
- case M.lookup evaledActual caseMap of
- Just branch -> evaluate env branch
- Nothing -> evaluate env defaultBranch
+ (actualExpr, rest) <- case args of
+ [] -> throwL $ "match called with no arguments"
+ (_:[]) -> throwL $ "empty match cases"
+ (a:b) -> return (a, b)
+
+ pairs <- (asPairsM rest) `catchError`
+ (\_ -> throwL $ "invalid number of arguments passed to match\n"
+ ++ "- matching on expr: " ++ show actualExpr ++ "\n"
+ ++ "- arguments: " ++ show rest)
+
+
+ (_, evaledActual) <- evaluate env actualExpr
+ ret <- matchPairs (actualExpr, evaledActual) pairs
+ return (env, ret)
+ where
+ matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST
+ matchPairs (actualExpr, evaledActual) [] = throwL $ "matching case not found when matching on expression: " ++ show actualExpr
+ ++ " (actual value: " ++ show evaledActual ++ ")"
+ matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do
+ (_, evaledMatcher) <- evaluate env matcher
+ if evaledActual == evaledMatcher
+ then do
+ (_, ret) <- evaluate env branch
+ return ret
+ else matchPairs (actualExpr, evaledActual) restPairs
evaluateLet :: Env -> [AST] -> LContext (Env, AST)
evaluateLet env args = do
diff --git a/src/Utils.hs b/src/Utils.hs
index 56fd1a2..2b0f271 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -38,6 +38,7 @@ data AST
| ASTHashMap (M.Map AST AST)
| ASTFunction LFunction
| ASTUnit
+ | ASTHole
instance (Show AST) where
show (ASTInteger n) = show n
@@ -52,6 +53,7 @@ instance (Show AST) where
in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}"
show (ASTFunction _) = "<fn>"
show ASTUnit = "<unit>"
+ show ASTHole = "<hole>"
instance (Eq AST) where
ASTInteger a == ASTInteger b = a == b
@@ -63,6 +65,8 @@ instance (Eq AST) where
ASTFunctionCall a == ASTFunctionCall b = a == b
ASTHashMap a == ASTHashMap b = a == b
ASTUnit == ASTUnit = True
+ ASTHole == _ = True
+ _ == ASTHole = True
_ == _ = False
instance (Ord AST) where
@@ -75,6 +79,8 @@ instance (Ord AST) where
ASTFunctionCall a <= ASTFunctionCall b = a <= b
ASTHashMap a <= ASTHashMap b = a <= b
ASTUnit <= ASTUnit = True
+ ASTHole <= _ = True
+ _ <= ASTHole = True
_ <= _ = False
assertIsASTFunction :: AST -> LContext AST

Want to contribute? Host your changes somewhere and send me the link: jan (at) sydanviita.fi. Also, check out my website.


forge.jan.systems — powered by cgit