commit decf912be7e74546fff17a022e31ac0cec318f40
parent 8c1243580f1f9d26f06ff10b1151755b88bd9709
Author: James Eversole <james@eversole.co>
Date: Fri, 27 Dec 2024 20:46:30 -0600
Update lambda handling; better default decode out
Diffstat:
5 files changed, 72 insertions(+), 66 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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 _ -> ""
