From d804a114bb88b5f24898f507dd1b5a2b61acacb8 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Fri, 27 Dec 2024 20:46:30 -0600 Subject: [PATCH] Update lambda handling; better default decode out --- sapling.cabal | 2 ++ src/Eval.hs | 2 +- src/Library.hs | 75 +++++++++++++++++++++++++------------------------- src/Main.hs | 6 ++-- src/REPL.hs | 53 ++++++++++++++++++----------------- 5 files changed, 72 insertions(+), 66 deletions(-) diff --git a/sapling.cabal b/sapling.cabal index 7119379..c3da8e7 100644 --- a/sapling.cabal +++ b/sapling.cabal @@ -29,6 +29,7 @@ executable sapling build-depends: base >=4.7 , containers + , haskeline , megaparsec , mtl other-modules: @@ -47,6 +48,7 @@ test-suite sapling-tests build-depends: base , containers + , haskeline , megaparsec , mtl , tasty diff --git a/src/Eval.hs b/src/Eval.hs index c29954f..a76e5c0 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -18,7 +18,7 @@ evalSingle env term = case term of let result = evalAST env body in Map.insert "__result" result env SApp func arg -> - let result = apply (evalAST env func) (evalAST env arg) + let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg) in Map.insert "__result" result env SVar name -> case Map.lookup name env of diff --git a/src/Library.hs b/src/Library.hs index 093d4b9..b2af155 100644 --- a/src/Library.hs +++ b/src/Library.hs @@ -7,40 +7,41 @@ import Research import qualified Data.Map as Map library :: Map.Map String T -library = evalSapling Map.empty $ parseSapling - "false = t\n \ - \ true = t t\n \ - \ _ = t\n \ - \ k = t t\n \ - \ i = t (t k) t\n \ - \ s = t (t (k t)) t\n \ - \ m = s i i\n \ - \ b = s (k s) k\n \ - \ c = s (s (k s) (s (k k) s)) (k k)\n \ - \ iC = (\\a b c : s a (k c) b)\n \ - \ iD = b (b iC) iC\n \ - \ iE = b (b iD) iC\n \ - \ yi = (\\i : b m (c b (i m)))\n \ - \ y = yi iC\n \ - \ yC = yi iD\n \ - \ yD = yi iE\n \ - \ id = (\\a : a)\n \ - \ triage = (\\a b c : t (t a b) c)\n \ - \ pair = t\n \ - \ matchBool = (\\ot of : triage of (\\_ : ot) (\\_ _ : ot))\n \ - \ matchList = (\\oe oc : triage oe _ oc)\n \ - \ matchPair = (\\op : triage _ _ op)\n \ - \ and = matchBool id (\\z : false)\n \ - \ if = (\\cond then else : t (t else (t t then)) t cond)\n \ - \ test = triage \"leaf\" (\\z : \"stem\") (\\a b : \"fork\")\n \ - \ emptyList = matchList true (\\y z : false)\n \ - \ nonEmptyList = matchList false (\\y z : true)\n \ - \ head = matchList t (\\hd tl : hd)\n \ - \ tail = matchList t (\\hd tl : tl)\n \ - \ isLeaf = (\\_ : triage true false false)\n \ - \ listConcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))\n \ - \ lAnd = triage (\\x : false) (\\_ x : x) (\\_ _ x : x)\n \ - \ lOr = triage (\\x : x) (\\_ _ : true) (\\_ _ x : true)\n \ - \ hmap = y (\\self : matchList (\\f : t) (\\hd tl f : pair (f hd) (self tl f)))\n \ - \ map = (\\f l : hmap l f) \n \ - \ equal = y (\\self : triage (triage true (\\z : false) (\\y z : false)) (\\ax : triage false (self ax) (\\y z : false)) (\\ax ay : triage false (\\z : false) (\\bx by : lAnd (self ax bx) (self ay by))))" +library = evalSapling Map.empty $ parseSapling $ unlines + [ "false = t" + , "true = t t" + , "_ = t" + , "k = t t" + , "i = t (t k) t" + , "s = t (t (k t)) t" + , "m = s i i" + , "b = s (k s) k" + , "c = s (s (k s) (s (k k) s)) (k k)" + , "iC = (\\a b c : s a (k c) b)" + , "iD = b (b iC) iC" + , "iE = b (b iD) iC" + , "yi = (\\i : b m (c b (i m)))" + , "y = yi iC" + , "yC = yi iD" + , "yD = yi iE" + , "id = (\\a : a)" + , "triage = (\\a b c : t (t a b) c)" + , "pair = t" + , "matchBool = (\\ot of : triage of (\\_ : ot) (\\_ _ : ot))" + , "matchList = (\\oe oc : triage oe _ oc)" + , "matchPair = (\\op : triage _ _ op)" + , "and = matchBool id (\\z : false)" + , "if = (\\cond then else : t (t else (t t then)) t cond)" + , "test = triage \"leaf\" (\\z : \"stem\") (\\a b : \"fork\")" + , "emptyList = matchList true (\\y z : false)" + , "nonEmptyList = matchList false (\\y z : true)" + , "head = matchList t (\\hd tl : hd)" + , "tail = matchList t (\\hd tl : tl)" + , "isLeaf = (\\_ : triage true false false)" + , "listConcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))" + , "lAnd = triage (\\x : false) (\\_ x : x) (\\_ _ x : x)" + , "lOr = triage (\\x : x) (\\_ _ : true) (\\_ _ x : true)" + , "hmap = y (\\self : matchList (\\f : t) (\\hd tl f : pair (f hd) (self tl f)))" + , "map = (\\f l : hmap l f)" + , "equal = y (\\self : triage (triage true (\\z : false) (\\y z : false)) (\\ax : triage false (self ax) (\\y z : false)) (\\ax ay : triage false (\\z : false) (\\bx by : lAnd (self ax bx) (self ay by))))" + ] diff --git a/src/Main.hs b/src/Main.hs index 54df9f7..e65da0c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,6 @@ main = do putStrLn ":_exit" repl library -runSapling :: String -> String -runSapling s = show $ result (evalSapling Map.empty $ parseSapling s) -runSaplingEnv env s = show $ result (evalSapling env $ parseSapling s) +runSapling :: String -> T +runSapling s = result (evalSapling Map.empty $ parseSapling s) +runSaplingEnv env s = result (evalSapling env $ parseSapling s) diff --git a/src/REPL.hs b/src/REPL.hs index 480ff63..4f6f0bb 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -5,35 +5,38 @@ import Lexer import Parser import Research -import Control.Monad (void) +import Control.Monad (void) import qualified Data.Map as Map -import System.IO (hFlush, stdout) +import System.Console.Haskeline +import System.IO (hFlush, stdout) repl :: Map.Map String T -> IO () -repl env = do - putStr "sapling < " - hFlush stdout - input <- getLine - case input of - ":_exit" -> - putStrLn "Goodbye!" - "" -> do - putStrLn "" - repl env - _ -> do - let clearEnv = Map.delete "__result" env - newEnv = evalSingle clearEnv (parseSingle input) - case Map.lookup "__result" newEnv of - Just r -> do - putStrLn $ "sapling > " ++ show r - putStrLn $ "DECODE -: " ++ (decodeResult r) - Nothing -> pure () - repl newEnv +repl env = runInputT defaultSettings (loop env) + where + loop :: Map.Map String T -> InputT IO () + loop env = do + minput <- getInputLine "sapling < " + case minput of + Nothing -> outputStrLn "Goodbye!" + Just ":_exit" -> outputStrLn "Goodbye!" + Just "" -> do + outputStrLn "" + loop env + Just input -> do + let clearEnv = Map.delete "__result" env + newEnv = evalSingle clearEnv (parseSingle input) + case Map.lookup "__result" newEnv of + Just r -> do + outputStrLn $ "sapling > " ++ show r + outputStrLn $ "DECODE -: " ++ decodeResult r + Nothing -> return () + loop newEnv decodeResult :: T -> String -decodeResult tc = - case ofString tc of +decodeResult tc = case ofNumber tc of + Right num -> show num + Left _ -> case ofString tc of Right str -> "\"" ++ str ++ "\"" - Left _ -> case ofNumber tc of - Right num -> "# " ++ show num + Left _ -> case ofList tc of + Right list -> "[" ++ unlines (map decodeResult list) ++ "]" Left _ -> ""