From 77968899b90cd9afe2ed2668b290b66cb553ced2 Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Tue, 4 Oct 2022 20:25:22 +0300 Subject: Implement naive export system --- app/Main.hs | 16 +++++++--- examples/import.lisp | 5 ++- examples/maybe.lisp | 60 ------------------------------------ src/Interpreter.hs | 32 ++++++++++++++++--- src/Utils.hs | 3 +- stdlib/common.lisp | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++ stdlib/maybe.lisp | 60 ++++++++++++++++++++++++++++++++++++ 7 files changed, 189 insertions(+), 73 deletions(-) delete mode 100644 examples/maybe.lisp create mode 100644 stdlib/common.lisp create mode 100644 stdlib/maybe.lisp diff --git a/app/Main.hs b/app/Main.hs index c71fd2f..45540aa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,6 +19,8 @@ parseArgs config args = config { configPrintEvaled = True } rest ("-s":rest) -> parseArgs config { configPrintCallStack = True } rest + ("-r":rest) -> parseArgs + config { configUseREPL = True } rest _ -> config repl :: Config -> Env -> InputT IO () @@ -47,7 +49,8 @@ main = do configVerboseMode = False, configShowHelp = False, configPrintEvaled = False, - configPrintCallStack = False + configPrintCallStack = False, + configUseREPL = False } let config = parseArgs initialConfig args @@ -58,10 +61,15 @@ main = do putStrLn $ " " ++ progName ++ " -h # to show this help" putStrLn $ " " ++ progName ++ " -e # to automatically print results of evaluated expressions to stdout" putStrLn $ " " ++ progName ++ " -s # to automatically print call stack of evaluated expressions to stdout" + putStrLn $ " " ++ progName ++ " -r # to open REPL, even after script file execution" else do when (configVerboseMode config) $ do putStrLn $ "configScriptFileName:\t" ++ (show $ configScriptFileName config) putStrLn $ "configVerboseMode:\t" ++ (show $ configVerboseMode config) + putStrLn $ "configShowHelp:\t" ++ (show $ configShowHelp config) + putStrLn $ "configPrintEvaled:\t" ++ (show $ configPrintEvaled config) + putStrLn $ "configPrintCallStack:\t" ++ (show $ configPrintCallStack config) + putStrLn $ "configUseREPL:\t" ++ (show $ configUseREPL config) case (configScriptFileName config) of Just scriptFileName -> do @@ -70,10 +78,10 @@ main = do Left (LException mp ex) -> case mp of Just p -> putStrLn $ p ++ " error: " ++ ex Nothing -> putStrLn $ "error: " ++ ex - Right _ -> return () + Right (evaledEnv, _) -> do + when (configUseREPL config) $ + runInputT defaultSettings (repl config evaledEnv) Nothing -> do putStrLn $ "Lang REPL" putStrLn $ "Use CTRL+D to exit" runInputT defaultSettings (repl config builtinEnv) - - return () diff --git a/examples/import.lisp b/examples/import.lisp index d302562..1a2f6f1 100644 --- a/examples/import.lisp +++ b/examples/import.lisp @@ -1,3 +1,2 @@ -(import! M "examples/maybe.lisp") - -(print! (fmt "{0}\n" [(M:just 666)])) +(import! "stdlib/common.lisp") +(import! M "stdlib/maybe.lisp") diff --git a/examples/maybe.lisp b/examples/maybe.lisp deleted file mode 100644 index 7cabfea..0000000 --- a/examples/maybe.lisp +++ /dev/null @@ -1,60 +0,0 @@ -; LIB - -(let! just (\[a] - ["maybe" "just" a])) -(let! nothing (\[] - ["maybe" "nothing"])) - -(let! unsafe-at (\[n seq] - (match seq - [] - (fatal! "unsafe-at out of bounds") - otherwise - (match n - 0 - (head seq) - otherwise - (unsafe-at (- n 1) (tail seq)))))) - -(let! unpack-just (unsafe-at 2)) -(let! kind (unsafe-at 1)) - -(let! map (\[f m] - (match (kind m) - "just" (just (f (unpack-just m))) - "nothing" (nothing)))) - -(let! and-then (\[f m] - (match (kind m) - "just" (f (unpack-just m)) - "nothing" (nothing)))) - -; TESTING - -;; (let! print-line! (\[s] -;; (print! (concat s "\n")))) - -;; (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) -;; (print-line! "found nothing!")) - -(let! exports [ - just - nothing - unpack-just - kind - map - and-then -]) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 33e36ea..37996f4 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -191,12 +191,34 @@ evaluateImport d env asts = do case args of [AST { astNode = ASTSymbol qualifier }, AST { astNode = ASTString path }] -> do - (importedEnv, _) <- runScriptFile builtinEnv path - let nameMangled = M.mapKeys (\k -> qualifier ++ ":" ++ k) importedEnv - return (M.union env nameMangled, importAst { astNode = ASTUnit }) + (evaledRawEnv, _) <- runScriptFile builtinEnv path + let exportsVecASTM = M.lookup "exports" evaledRawEnv + exportedEnv <- case exportsVecASTM of + Just (AST { astNode = ASTVector exportsVec }) -> do + exportSyms <- exportsVec $> + mapM (\case AST { astNode = ASTSymbol sym } -> return sym + ast -> throwL (astPos ast) $ "non-symbol value in exports vector: " ++ show ast) + let resultEnv = M.filterWithKey (\k _ -> L.elem k exportSyms) evaledRawEnv + return resultEnv + Just ast -> throwL (astPos ast) $ "exports symbol set to non-symbol value: " ++ show ast + Nothing -> throwL (astPos importAst) $ "no exports vector defined in file: " ++ path + + let nameMangled = M.mapKeys (\k -> qualifier ++ ":" ++ k) exportedEnv + return $ (M.union env nameMangled, importAst { astNode = ASTUnit }) [AST { astNode = ASTString path }] -> do - (importedEnv, _) <- runScriptFile builtinEnv path - return (M.union env importedEnv, importAst { astNode = ASTUnit }) + (evaledRawEnv, _) <- runScriptFile builtinEnv path + let exportsVecASTM = M.lookup "exports" evaledRawEnv + exportedEnv <- case exportsVecASTM of + Just (AST { astNode = ASTVector exportsVec }) -> do + exportSyms <- exportsVec $> + mapM (\case AST { astNode = ASTSymbol sym } -> return sym + ast -> throwL (astPos ast) $ "non-symbol value in exports vector: " ++ show ast) + let resultEnv = M.filterWithKey (\k _ -> L.elem k exportSyms) evaledRawEnv + return resultEnv + Just ast -> throwL (astPos ast) $ "exports symbol set to non-symbol value: " ++ show ast + Nothing -> throwL (astPos importAst) $ "no exports vector defined in file: " ++ path + + return $ (M.union env exportedEnv, importAst { astNode = ASTUnit }) _ -> throwL (astPos importAst) $ "invalid arguments passed to import!: " ++ show args evaluateUserFunction :: Depth -> Env -> [AST] -> LContext (Env, AST) diff --git a/src/Utils.hs b/src/Utils.hs index 2a2f607..1e9afc5 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -18,7 +18,8 @@ data Config = Config { configVerboseMode :: Bool, configShowHelp :: Bool, configPrintEvaled :: Bool, - configPrintCallStack :: Bool + configPrintCallStack :: Bool, + configUseREPL :: Bool } type LContext a = ReaderT Config (ExceptT LException IO) a diff --git a/stdlib/common.lisp b/stdlib/common.lisp new file mode 100644 index 0000000..2db5d62 --- /dev/null +++ b/stdlib/common.lisp @@ -0,0 +1,86 @@ +(let! compose (\[f g] + (\[x] (f (g x))))) + +(let! id (\[a] a)) + +(let! mod (\[n k] + (- n (* k (/ n k))))) + +(let! not (\[b] + (match b + true false + false true))) + +(let! is-even (\[n] + (match (mod n 2) + 0 true + 1 false))) + +(let! is-odd (compose not is-even)) + +;; map :: (a -> b) -> [a] -> [b] +(let! map (\[f lst] + (match 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 + otherwise + (f (head lst) (foldr f accumulator (tail lst)))))) + +;; filter :: (a -> Bool) -> [a] -> [a] +(let! filter (\[pred lst] + (match lst + [] [] + otherwise (match (pred (head lst)) + true + (prepend (head lst) (filter pred (tail lst))) + false + (filter pred (tail lst)))))) + +(let! fibo (\[n] + (let! lazy fibo-1 (fibo (- n 1))) + (let! lazy fibo-2 (fibo (- n 2))) + (match n + 0 0 + 1 1 + _ (+ fibo-1 fibo-2)))) + +(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] + (reverse_ v []))) + +(let! flow (\[fs] (foldr compose id (reverse fs)))) +(let! pipe (\[x fs] ((flow fs) x))) + +(let! lazy exports [ + compose + id + mod + not + is-even + is-odd + map + foldr + filter + fibo + reverse_ + reverse + flow + pipe +]) diff --git a/stdlib/maybe.lisp b/stdlib/maybe.lisp new file mode 100644 index 0000000..0bc7ac4 --- /dev/null +++ b/stdlib/maybe.lisp @@ -0,0 +1,60 @@ +; LIB + +(let! just (\[a] + ["maybe" "just" a])) +(let! nothing (\[] + ["maybe" "nothing"])) + +(let! unsafe-at (\[n seq] + (match seq + [] + (fatal! "unsafe-at out of bounds") + otherwise + (match n + 0 + (head seq) + otherwise + (unsafe-at (- n 1) (tail seq)))))) + +(let! unpack-just (unsafe-at 2)) +(let! kind (unsafe-at 1)) + +(let! map (\[f m] + (match (kind m) + "just" (just (f (unpack-just m))) + "nothing" (nothing)))) + +(let! and-then (\[f m] + (match (kind m) + "just" (f (unpack-just m)) + "nothing" (nothing)))) + +; TESTING + +;; (let! print-line! (\[s] +;; (print! (concat s "\n")))) + +;; (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) +;; (print-line! "found nothing!")) + +(let! lazy exports [ + just + nothing + unpack-just + kind + map + and-then +]) -- cgit v1.3