diff options
| -rw-r--r-- | examples/maybe.lisp | 10 | ||||
| -rw-r--r-- | examples/test.lisp | 24 | ||||
| -rw-r--r-- | src/Builtins.hs | 197 | ||||
| -rw-r--r-- | src/Evaluator.hs | 60 | ||||
| -rw-r--r-- | src/Utils.hs | 6 | ||||
| -rw-r--r-- | todo.md | 6 |
6 files changed, 176 insertions, 127 deletions
diff --git a/examples/maybe.lisp b/examples/maybe.lisp index 0447139..fe0b418 100644 --- a/examples/maybe.lisp +++ b/examples/maybe.lisp @@ -9,10 +9,12 @@ (match seq [] (fatal "unsafe-at out of bounds") - (match n - 0 - (head seq) - (unsafe-at (- n 1) (tail seq)))))) + otherwise + (match n + 0 + (head seq) + otherwise + (unsafe-at (- n 1) (tail seq)))))) (let unpack-just (unsafe-at 2)) (let kind (unsafe-at 1)) diff --git a/examples/test.lisp b/examples/test.lisp index 27275a0..a6f7d60 100644 --- a/examples/test.lisp +++ b/examples/test.lisp @@ -21,16 +21,20 @@ ;; map :: (a -> b) -> [a] -> [b] (let map (\[f lst] (match lst - [] [] - (prepend (f (head lst)) (map f (tail lst)))))) + [] + [] + otherwise + (prepend (f (head lst)) (map f (tail lst)))))) (map (+ 1) [1 2 3]) ;; foldr :: (a -> b -> b) -> b -> [a] -> b (let foldr (\[f accumulator lst] (match lst - [] accumulator - (f (head lst) (foldr f accumulator (tail lst)))))) + [] + accumulator + otherwise + (f (head lst) (foldr f accumulator (tail lst)))))) (foldr + 0 [1 2 3]) @@ -38,9 +42,11 @@ (let filter (\[pred lst] (match lst [] [] - (match (pred (head lst)) - true (prepend (head lst) (filter pred (tail lst))) - false (filter pred (tail lst)))))) + otherwise (match (pred (head lst)) + true + (prepend (head lst) (filter pred (tail lst))) + false + (filter pred (tail lst)))))) (filter is-even [0 1 2 3 4 5]) @@ -50,7 +56,7 @@ (match n 0 0 1 1 - (+ fibo-1 fibo-2)))) + _ (+ fibo-1 fibo-2)))) (fibo 10) @@ -60,7 +66,7 @@ (let lazy xa (prepend x a)) (match v [] a - (reverse_ xs xa)))) + _ (reverse_ xs xa)))) (let reverse (\[v] (reverse_ v []))) 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 @@ -2,13 +2,9 @@ In order of priority -- Make builtin math functions support both number types (integer and double) - Write tests! -- Add builtins to convert from int to double and vice versa -- Add builtin to convert to string - Add builtins to compare numbers (eq?, lt?) - Add import function with support for qualified imports - Come up with a name for the language -- Add auto import for standard library (std) -- Add flag to disable auto import of standard library +- Add auto import for standard library (std) and a flag to disable auto import - Add effects system (see `examples/effects-concept.lisp`) |