diff options
| -rw-r--r-- | examples/effects-concept.lisp | 4 | ||||
| -rw-r--r-- | examples/maybe.lisp | 51 | ||||
| -rw-r--r-- | examples/test.lisp | 39 | ||||
| -rw-r--r-- | spec.md | 6 | ||||
| -rw-r--r-- | src/Builtins.hs | 13 | ||||
| -rw-r--r-- | src/Evaluator.hs | 103 | ||||
| -rw-r--r-- | src/Lib.hs | 2 | ||||
| -rw-r--r-- | test/Spec.hs | 4 |
8 files changed, 126 insertions, 96 deletions
diff --git a/examples/effects-concept.lisp b/examples/effects-concept.lisp index 0bde72f..5ea90d7 100644 --- a/examples/effects-concept.lisp +++ b/examples/effects-concept.lisp @@ -1,7 +1,7 @@ ; FUNCTIONS -(let prompt-input (\[] - (let p "> ") +(let! prompt-input (\[] + (let! p "> ") (do get-user-input "prompted" p))) ; SIGNAL HANDLERS diff --git a/examples/maybe.lisp b/examples/maybe.lisp index fe0b418..dab7bf8 100644 --- a/examples/maybe.lisp +++ b/examples/maybe.lisp @@ -1,14 +1,14 @@ ; LIB -(let just (\[a] +(let! just (\[a] ["maybe" "just" a])) -(let nothing (\[] +(let! nothing (\[] ["maybe" "nothing"])) -(let unsafe-at (\[n seq] +(let! unsafe-at (\[n seq] (match seq [] - (fatal "unsafe-at out of bounds") + (fatal! "unsafe-at out of bounds") otherwise (match n 0 @@ -16,36 +16,45 @@ otherwise (unsafe-at (- n 1) (tail seq)))))) -(let unpack-just (unsafe-at 2)) -(let kind (unsafe-at 1)) +(let! unpack-just (unsafe-at 2)) +(let! kind (unsafe-at 1)) -(let map (\[f m] +(let! map (\[f m] (match (kind m) "just" (just (f (unpack-just m))) "nothing" (nothing)))) -(let and-then (\[f m] +(let! and-then (\[f m] (match (kind m) "just" (f (unpack-just m)) "nothing" (nothing)))) ; TESTING -(let print-line! (\[s] +(let! print-line! (\[s] (print! (concat s "\n")))) -(let m (just 10)) -(match (kind m) - "just" +(let! a (just 10)) +(let! b (nothing)) + +(map (+ 5) a) +(map (+ 5) b) + +(and-then (\[n] (just (+ n 5))) a) +(and-then (\[n] (just (+ n 5))) b) + +(let! m (just 10)) +(match m + (just _) (print-line! (fmt "found just {0}!" [(unpack-just m)])) - "nothing" + (nothing) (print-line! "found nothing!")) -(let exports [ - just - nothing - unpack-just - kind - map - and-then -]) +;; (let! exports [ +;; just +;; nothing +;; unpack-just +;; kind +;; map +;; and-then +;; ]) diff --git a/examples/test.lisp b/examples/test.lisp index a6f7d60..fd8c379 100644 --- a/examples/test.lisp +++ b/examples/test.lisp @@ -1,25 +1,27 @@ -(let compose (\[f g] +(let! compose (\[f g] (\[x] (f (g x))))) ((compose (+ 1) (+ 2)) 3) -(let mod (\[n k] +(let! id (\[a] a)) + +(let! mod (\[n k] (- n (* k (/ n k))))) -(let not (\[b] +(let! not (\[b] (match b true false false true))) -(let is-even (\[n] +(let! is-even (\[n] (match (mod n 2) 0 true 1 false))) -(let is-odd (compose not is-even)) +(let! is-odd (compose not is-even)) ;; map :: (a -> b) -> [a] -> [b] -(let map (\[f lst] +(let! map (\[f lst] (match lst [] [] @@ -29,7 +31,7 @@ (map (+ 1) [1 2 3]) ;; foldr :: (a -> b -> b) -> b -> [a] -> b -(let foldr (\[f accumulator lst] +(let! foldr (\[f accumulator lst] (match lst [] accumulator @@ -39,7 +41,7 @@ (foldr + 0 [1 2 3]) ;; filter :: (a -> Bool) -> [a] -> [a] -(let filter (\[pred lst] +(let! filter (\[pred lst] (match lst [] [] otherwise (match (pred (head lst)) @@ -50,9 +52,9 @@ (filter is-even [0 1 2 3 4 5]) -(let fibo (\[n] - (let lazy fibo-1 (fibo (- n 1))) - (let lazy fibo-2 (fibo (- n 2))) +(let! fibo (\[n] + (let! lazy fibo-1 (fibo (- n 1))) + (let! lazy fibo-2 (fibo (- n 2))) (match n 0 0 1 1 @@ -60,15 +62,20 @@ (fibo 10) -(let reverse_ (\[v a] - (let lazy x (head v)) - (let lazy xs (tail v)) - (let lazy xa (prepend x a)) +(let! reverse_ (\[v a] + (let! lazy x (head v)) + (let! lazy xs (tail v)) + (let! lazy xa (prepend x a)) (match v [] a _ (reverse_ xs xa)))) -(let reverse (\[v] +(let! reverse (\[v] (reverse_ v []))) (reverse [1 2 3]) + +(let! flow (\[fs] (foldr compose id (reverse fs)))) +(let! pipe (\[x fs] ((flow fs) x))) + +(pipe 10 [(+ 1) (+ 2)]) @@ -29,8 +29,8 @@ Calling the builtin variadic function '\' constructs a new function. The first a Functions are automatically curried E.g. - (let f1 (\[x y] (+ x y))) - (let f2 (\[x] (\[y] (+ x y)))) + (let! f1 (\[x y] (+ x y))) + (let! f2 (\[x] (\[y] (+ x y)))) ; f1 equivalent to f2 ## Some builtin functions @@ -38,7 +38,7 @@ E.g. `let` Evaluates second argument and stores the resulting value in the environment. - (let sum2 (\[x y] (+ x y))) + (let! sum2 (\[x y] (+ x y))) `\` Defines a function. diff --git a/src/Builtins.hs b/src/Builtins.hs index ebaad42..f68cc78 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -33,7 +33,12 @@ builtinEnv = M.fromList [ ("unit", makeNonsenseAST ASTUnit), ("_", makeNonsenseAST ASTHole), ("otherwise", makeNonsenseAST ASTHole), - builtinFatal + builtinFatal, + -- reserved keywords + reservedKeyword "\\", + reservedKeyword "let!", + reservedKeyword "match", + reservedKeyword "env!" ] argError1 :: String -> AST -> String @@ -48,6 +53,10 @@ argError3 :: String -> AST -> AST -> AST -> String argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3 +reservedKeyword :: String -> (String, AST) +reservedKeyword name = (name, makeNonsenseAST $ ASTFunction fn1) where + fn1 _ ast1 = throwL (astPos ast1) $ "unreachable: " ++ name ++ " is a reserved word" + -- BUILTINS builtinAdd2 :: (String, AST) @@ -211,7 +220,7 @@ builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where builtinFatal :: (String, AST) builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where - name = "fatal" + name = "fatal!" fn1 _ ast1@AST { astNode = ASTString str } = throwL (astPos ast1) $ str fn1 _ ast1 = diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 4de5565..b7b792b 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -11,6 +11,8 @@ import Control.Monad.Except ( catchError ) import Utils -- import Debug.Trace +type Depth = Int + _curryCall :: Env -> [AST] -> LFunction -> LContext AST _curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f) _curryCall env (arg:[]) f = f env arg @@ -47,18 +49,18 @@ foldSymValPairs ((sym, val):rest) body = replacedBody = traverseAndReplace sym val body in foldSymValPairs replacedRest replacedBody -letArgsToSymValPairs :: Env -> [AST] -> LContext (String, AST) -letArgsToSymValPairs env args = +letArgsToSymValPairs :: Depth -> Env -> [AST] -> LContext (String, AST) +letArgsToSymValPairs d env args = case args of [AST { astNode = ASTSymbol symbol' }, value'] -> do - (_, evaledValue) <- evaluate env value' + (_, evaledValue) <- evaluate d env value' return (symbol', evaledValue) [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do return (symbol', value') - other -> throwL (astPos $ head other) $ "let called with invalid args " ++ show other + other -> throwL (astPos $ head other) $ "let! called with invalid args " ++ show other -defineUserFunction :: AST -> [AST] -> LContext LFunction -defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where +defineUserFunction :: Depth -> AST -> [AST] -> LContext LFunction +defineUserFunction d AST { astNode = ASTSymbol param } exprs = return fn where fn :: LFunction fn env arg = do let replacedExprs = map (traverseAndReplace param arg) exprs @@ -66,35 +68,35 @@ defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where letSymValPairs <- letExprs $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast) - .> fmap (mapM $ letArgsToSymValPairs env) .> join + .> fmap (mapM $ letArgsToSymValPairs d env) .> join let body = head $ drop (length exprs - 1) replacedExprs let newBody = traverseAndReplace param arg body $> foldSymValPairs letSymValPairs - (_, ret) <- evaluate env newBody + (_, ret) <- evaluate d env newBody return ret -defineUserFunction param exprs = throwL (astPos param) +defineUserFunction _ param exprs = throwL (astPos param) $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs -defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction -defineUserFunctionWithLetExprs [] exprs = +defineUserFunctionWithLetExprs :: Depth -> [AST] -> [AST] -> LContext LFunction +defineUserFunctionWithLetExprs d [] exprs = -- the position info is nonsensical, but it should never get read anyway - defineUserFunction (makeNonsenseAST $ ASTSymbol "unit") exprs -defineUserFunctionWithLetExprs (param:[]) exprs = - defineUserFunction param exprs -defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs = return fn where + defineUserFunction d (makeNonsenseAST $ ASTSymbol "unit") exprs +defineUserFunctionWithLetExprs d (param:[]) exprs = + defineUserFunction d param exprs +defineUserFunctionWithLetExprs d (AST { astNode = ASTSymbol param }:rest) exprs = return fn where fn :: LFunction fn _ arg = do let newExprs = map (traverseAndReplace param arg) exprs - ret <- defineUserFunctionWithLetExprs rest newExprs + ret <- defineUserFunctionWithLetExprs d rest newExprs -- the returned AST will not have the correct position info, but that's fine -- because the info is overridden in evaluateFunctionDef anyway return $ makeNonsenseAST $ ASTFunction $ ret -defineUserFunctionWithLetExprs (param:_) _ = throwL (astPos $ param) +defineUserFunctionWithLetExprs _ (param:_) _ = throwL (astPos $ param) $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param -evaluateFunctionDef :: Env -> [AST] -> LContext (Env, AST) -evaluateFunctionDef env asts = do +evaluateFunctionDef :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateFunctionDef d env asts = do let defAst = head asts args = tail asts (params'', exprs) <- case args of @@ -119,15 +121,15 @@ evaluateFunctionDef env asts = do $ "non-let expression in function definition before body: " ++ show nonLetExpr Nothing -> return () - fn <- defineUserFunctionWithLetExprs params exprs + fn <- defineUserFunctionWithLetExprs d params exprs return $ (env, defAst { astNode = ASTFunction fn }) where - isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) } = True + isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True isLetAST _ = False isParamNameShadowing name = M.member name env -evaluateMatch :: Env -> [AST] -> LContext (Env, AST) -evaluateMatch env asts = do +evaluateMatch :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateMatch d env asts = do let matchAst = head asts args = tail asts (actualExpr, rest) <- case args of @@ -140,7 +142,7 @@ evaluateMatch env asts = do ++ "- matching on expr: " ++ show actualExpr ++ "\n" ++ "- arguments: " ++ show rest) - (_, evaledActual) <- evaluate env actualExpr + (_, evaledActual) <- evaluate d env actualExpr ret <- matchPairs (actualExpr, evaledActual) pairs return (env, matchAst { astNode = astNode ret }) where @@ -149,25 +151,27 @@ evaluateMatch env asts = do $ "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 + (_, evaledMatcher) <- evaluate d env matcher if evaledActual == evaledMatcher then do - (_, ret) <- evaluate env branch + (_, ret) <- evaluate d env branch return ret else matchPairs (actualExpr, evaledActual) restPairs -evaluateLet :: Env -> [AST] -> LContext (Env, AST) -evaluateLet env asts = do +evaluateLet :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateLet d env asts = do let letAst = head asts args = tail asts - (symbol, value) <- letArgsToSymValPairs env args + when (d > 1) $ throwL (astPos letAst) $ "let! can only be called on the top level or in a function definition" + (symbol, value) <- letArgsToSymValPairs d env args when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol let newEnv = M.insert symbol value env return $ (newEnv, letAst { astNode = ASTUnit }) -evaluateEnv :: Env -> [AST] -> LContext (Env, AST) -evaluateEnv env asts = do +evaluateEnv :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateEnv d env asts = do let envAst = head asts + when (d > 1) $ throwL (astPos envAst) $ "env! can only be called on the top level or in a function definition" let pairs = M.assocs env let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ') @@ -175,15 +179,15 @@ evaluateEnv env asts = do liftIO $ mapM_ putStrLn rows return (env, envAst { astNode = ASTUnit }) -evaluateUserFunction :: Env -> [AST] -> LContext (Env, AST) -evaluateUserFunction env children = do +evaluateUserFunction :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateUserFunction d env children = do let fnAst = head children args = tail children - (_, fnEvaled) <- evaluate env fnAst + (_, fnEvaled) <- evaluate d env fnAst AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled - evaledArgs' <- mapM (evaluate env) args + evaledArgs' <- mapM (evaluate d env) args let evaledArgs = map snd evaledArgs' - doubleEvaledArgs' <- mapM (evaluate env) evaledArgs + doubleEvaledArgs' <- mapM (evaluate d env) evaledArgs let doubleEvaledArgs = map snd doubleEvaledArgs' result <- curryCall env (reverse doubleEvaledArgs) fn -- maybe remove double eval here? can't remember why it was added @@ -197,26 +201,27 @@ evaluateSymbol env ast@AST { astNode = ASTSymbol sym } = do Nothing -> throwL (astPos ast) $ "symbol " ++ sym ++ " not defined in environment" evaluateSymbol _ ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast -evaluate :: Env -> AST -> LContext (Env, AST) -evaluate env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = +evaluate :: Depth -> Env -> AST -> LContext (Env, AST) +evaluate d env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = do config <- ask when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc case astNode x of + -- remember to add these as reseved keywords in Builtins! ASTSymbol "\\" -> - evaluateFunctionDef env args + evaluateFunctionDef (d + 1) env args ASTSymbol "match" -> - evaluateMatch env args - ASTSymbol "let" -> - evaluateLet env args - ASTSymbol "env" -> - evaluateEnv env args + evaluateMatch (d + 1) env args + ASTSymbol "let!" -> + evaluateLet (d + 1) env args + ASTSymbol "env!" -> + evaluateEnv (d + 1) env args _ -> - evaluateUserFunction env args -evaluate env ast@AST { astNode = (ASTSymbol _) } = + evaluateUserFunction (d + 1) env args +evaluate _ env ast@AST { astNode = (ASTSymbol _) } = evaluateSymbol env ast -evaluate env ast@AST { astNode = (ASTVector vec) } = - do rets <- mapM (evaluate env) vec +evaluate d env ast@AST { astNode = (ASTVector vec) } = + do rets <- mapM (evaluate (d + 1) env) vec let vec' = map snd rets return $ (env, ast { astNode = ASTVector vec' }) -evaluate env other = +evaluate _ env other = return (env, other) @@ -38,6 +38,6 @@ runInlineScript fileName env src = do foldEvaluate :: Env -> [AST] -> LContext (Env, [AST]) foldEvaluate accEnv [] = return (accEnv, []) foldEvaluate accEnv (ast:rest) = do - (newAccEnv, newAst) <- evaluate accEnv ast + (newAccEnv, newAst) <- evaluate 0 accEnv ast (retEnv, restEvaled) <- foldEvaluate newAccEnv rest return $ (retEnv, newAst : restEvaled) diff --git a/test/Spec.hs b/test/Spec.hs index 3d1ad3a..1b712a8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -29,7 +29,7 @@ parseTests = testGroup "parse" [ evaluateTests = testGroup "evaluate" [ do let env = M.fromList [builtinAdd2] :: Env - (gotEnv, gotAST) <- expectSuccessL $ evaluate env (astFunctionCall + (gotEnv, gotAST) <- expectSuccessL $ evaluate 0 env (astFunctionCall [astSymbol "+", astInteger 1, astInteger 2]) let expectedAST = astInteger 3 assertEqual "" gotAST expectedAST @@ -38,7 +38,7 @@ evaluateTests = testGroup "evaluate" [ e2eTests = testGroup "e2e" [ do let env = M.fromList [builtinSubtract2] :: Env - let script1 = "(let sub2 (\\[a b] (- a b)))\n(sub2 3 2)" + let script1 = "(let! sub2 (\\[a b] (- a b)))\n(sub2 3 2)" (gotEnv, gotASTs) <- expectSuccessL $ runInlineScript "<test>" env script1 let expectedEnvKeys = ["-", "sub2"] assertEqual "" (M.keys gotEnv) expectedEnvKeys |