Stop using to/of conventions backwards

Uses # instead of text output. Adds several basic library functions.

README.md

@@ -1,16 +1,52 @@
 # sapling
 
+## Introduction
+
 sapling is a "micro-language" that I'm working on to investigate [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) .
 
 It offers a minimal amount of syntax sugar:
 
 - `t` operator behaving by the rules of Tree Calculus
-- Variable definitions
+- Function ("variable") definitions
 - Lambda abstractions
-- List, Integer, and String literals
+- List, Number, and String literals (WIP)
 
 This is an active experimentation project by [someone who has no idea what they're doing](https://eversole.co).
 
+## What does it look like?
+
+```
+false      = t
+_          = t
+true       = t t
+id         = (\a : a)
+triage     = (\a b c : t (t a b) c) 
+match_bool = (\ot of : triage of (\_ : ot) t)
+and        = match_bool id (\_ : false)
+if         = (\cond then else : t (t else (t t then)) t cond)
+triage     = (\a b c : t (t a b) c)
+test       = triage "leaf" (\_ : "stem") (\_ _ : "fork")
+
+-- The REPL outputs the tree form results by default; they are elided here.
+sapling < test t
+DECODE -: "leaf"
+sapling < test (t t)
+DECODE -: "stem"
+sapling < test (t t t)
+DECODE -: "fork"
+sapling < map (\i : listConcat i " is super cool!") [("He") ("She") ("Everybody")]
+DECODE -: ["He is super cool!", "She is super cool!", "Everybody is super cool!"]
+```
+
+## How to use
+
+For now, you can easily build and run this project using Nix:
+
+1. Clone the repository:
+    a. `git clone ssh://git.eversole.co/sapling.git`
+    b. `git clone https://git.eversole/sapling.git`
+1. Run the REPL: `nix run`
+
 ## Acknowledgements 
 
 Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). 

sapling.cabal

@@ -1,8 +1,8 @@
 cabal-version: 1.12
 
 name:           sapling
-version:        0.2.0
+version:        0.4.0
-description:    Tree Calculus experiment repository
+description:    A micro-language for exploring Tree Calculus
 author:         James Eversole
 maintainer:     james@eversole.co
 copyright:      James Eversole
@@ -29,11 +29,13 @@ executable sapling
   build-depends:
     base >=4.7
     , containers
+    , haskeline
     , megaparsec
     , mtl
   other-modules:
     Eval
     Lexer
+    Library
     Parser
     REPL
     Research
@@ -46,6 +48,7 @@ test-suite sapling-tests
   build-depends:       
     base
     , containers
+    , haskeline
     , megaparsec
     , mtl
     , tasty
@@ -55,6 +58,7 @@ test-suite sapling-tests
   other-modules:
     Eval
     Lexer
+    Library
     Parser
     REPL
     Research

src/Eval.hs

@@ -2,121 +2,95 @@ module Eval where
 
 import Parser
 import Research
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.List (foldl')
-import qualified Data.Map as Map
-import Data.Map (Map)
 
-evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List (foldl')
+import qualified Data.Set as Set
+
+evalSingle :: Map String T -> SaplingAST -> Map String T
 evalSingle env term = case term of
-    SFunc name [] body ->
+  SFunc name [] body ->
-        let result = evalAST env body
+    let lineNoLambda = eliminateLambda body
-        in Map.insert name result env
+        result = evalAST env lineNoLambda
-    SApp func arg ->
+    in Map.insert name result env
-        let result = apply (evalAST env func) (evalAST env arg)
+  SLambda _ body ->
-        in Map.insert "__result" result env
+    let result = evalAST env body
-    SVar name -> case Map.lookup name env of
+    in Map.insert "__result" result env
-        Just value -> Map.insert "__result" value env
+  SApp func arg ->
-        Nothing -> error $ "Variable " ++ name ++ " not defined"
+    let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg)
-    _ ->
+    in Map.insert "__result" result env
-        let result = evalAST env term
+  SVar name ->
-        in Map.insert "__result" result env
+    case Map.lookup name env of
+      Just value -> Map.insert "__result" value env
+      Nothing -> error $ "Variable " ++ name ++ " not defined"
+  _ ->
+    let result = evalAST env term
+    in Map.insert "__result" result env
 
 evalSapling :: Map String T -> [SaplingAST] -> Map String T
 evalSapling env [] = env
 evalSapling env [lastLine] =
-    let
+    let lastLineNoLambda = eliminateLambda lastLine
-        lastLineNoLambda = eliminateLambda lastLine
         updatedEnv = evalSingle env lastLineNoLambda
     in Map.insert "__result" (result updatedEnv) updatedEnv
 evalSapling env (line:rest) =
-    let
+    let lineNoLambda = eliminateLambda line
-        lineNoLambda = eliminateLambda line
         updatedEnv = evalSingle env lineNoLambda
     in evalSapling updatedEnv rest
 
 evalAST :: Map String T -> SaplingAST -> T
 evalAST env term = case term of
-    SVar name ->
+    SVar name -> case Map.lookup name env of
-        case Map.lookup name env of
+        Just value -> value
-            Just value -> value
+        Nothing -> error $ "Variable " ++ name ++ " not defined"
-            Nothing -> error $ "Variable " ++ name ++ " not defined"
     TLeaf -> Leaf
-    TStem t ->
+    TStem t -> Stem (evalAST env t)
-        Stem (evalAST env t)
+    TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
-    TFork t1 t2 ->
+    SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
-        Fork (evalAST env t1) (evalAST env t2)
+    SStr str -> ofString str
-    SApp t1 t2 ->
+    SInt num -> ofNumber num
-        apply (evalAST env t1) (evalAST env t2)
+    SList elems -> ofList (map (evalAST Map.empty) elems)
-    SStr str -> toString str
-    SInt num -> toNumber num
-    SList elems -> toList (map (evalAST Map.empty) elems)
     SFunc name args body ->
         error $ "Unexpected function definition " ++ name
         ++ " in evalAST; define via evalSingle."
-    SLambda {} ->
+    SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
-        error "Internal error: SLambda found in evalAST after elimination."
-
-result :: Map String T -> T
-result r = case Map.lookup "__result" r of
-    Just a -> a
-    Nothing -> error "No __result field found in provided environment"
-
 
 eliminateLambda :: SaplingAST -> SaplingAST
 eliminateLambda (SLambda (v:vs) body)
-    | null vs = lambdaToT v (eliminateLambda body)
+  | null vs = lambdaToT v (eliminateLambda body)
-    | otherwise =
+  | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
-        eliminateLambda (SLambda [v] (SLambda vs body))
+eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
-eliminateLambda (SApp f arg) =
+eliminateLambda (TStem t) = TStem (eliminateLambda t)
-    SApp (eliminateLambda f) (eliminateLambda arg)
+eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (TStem t) =
+eliminateLambda (SList xs) = SList (map eliminateLambda xs)
-    TStem (eliminateLambda t)
-eliminateLambda (TFork l r) =
-    TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (SList xs) =
-    SList (map eliminateLambda xs)
-eliminateLambda (SFunc n vs b) =
-    SFunc n vs (eliminateLambda b)
 eliminateLambda other = other
 
+-- This is my attempt to implement the lambda calculus elimination rules defined
+-- in "Typed Program Analysis without Encodings" by Barry Jay.
+-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
 lambdaToT :: String -> SaplingAST -> SaplingAST
 lambdaToT x (SVar y)
-    | x == y = tI
+  | x == y = tI
 lambdaToT x (SVar y)
-    | x /= y =
+  | x /= y = SApp tK (SVar y)
-        SApp tK (SVar y)
 lambdaToT x t
-    | not (isFree x t) =
+  | not (isFree x t) = SApp tK t
-        SApp tK t
 lambdaToT x (SApp n u)
-    | not (isFree x (SApp n u)) =
+  | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
-        SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
+lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
-lambdaToT x (SApp n u) =
-    SApp
-    (SApp tS (lambdaToT x (eliminateLambda n)))
-    (lambdaToT x (eliminateLambda u))
-lambdaToT x (SApp f args) = lambdaToT x f
 lambdaToT x body
-    | not (isFree x body) =
+  | not (isFree x body) = SApp tK body
-        SApp tK body
+  | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
-    | otherwise =
-        SApp
-        (SApp tS (lambdaToT x body))
-        tLeaf
 
-tLeaf :: SaplingAST
+freeVars :: SaplingAST -> Set.Set String
-tLeaf = TLeaf
-
-freeVars :: SaplingAST -> Set String
 freeVars (SVar v) = Set.singleton v
 freeVars (SInt _) = Set.empty
 freeVars (SStr _) = Set.empty
 freeVars (SList xs) = foldMap freeVars xs
-freeVars (SFunc _ _ b) = freeVars b
 freeVars (SApp f arg) = freeVars f <> freeVars arg
 freeVars TLeaf = Set.empty
+freeVars (SFunc _ _ b) = freeVars b
 freeVars (TStem t) = freeVars t
 freeVars (TFork l r) = freeVars l <> freeVars r
 freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
@@ -129,12 +103,18 @@ toAST Leaf = TLeaf
 toAST (Stem a) = TStem (toAST a)
 toAST (Fork a b) = TFork (toAST a) (toAST b)
 
+-- We need the SKI operators in an unevaluated SaplingAST tree form so that we
+-- can keep the evaluation functions straightforward
 tI :: SaplingAST
-tI = toAST _I
+tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
 
 tK :: SaplingAST
-tK = toAST _K
+tK = SApp TLeaf TLeaf
 
 tS :: SaplingAST
-tS = toAST _S
+tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
 
+result :: Map String T -> T
+result r = case Map.lookup "__result" r of
+    Just a -> a
+    Nothing -> error "No __result field found in provided environment"

src/Lexer.hs

@@ -3,10 +3,13 @@ module Lexer where
 import Research
 import Text.Megaparsec
 import Text.Megaparsec.Char
+
+import Control.Monad (void)
 import Data.Void
 import qualified Data.Set as Set
 
 type Lexer = Parsec Void String
+
 data LToken
   = LKeywordT
   | LIdentifier String
@@ -20,6 +23,7 @@ data LToken
   | LOpenBracket
   | LCloseBracket
   | LNewline
+  | LComment String
   deriving (Show, Eq, Ord)
 
 keywordT :: Lexer LToken
@@ -44,7 +48,7 @@ stringLiteral = do
   if null content
     then fail "Empty string literals are not allowed"
     else do
-      char '"' -- "
+      char '"' --"
       return (LStringLiteral content)
 
 assign :: Lexer LToken
@@ -71,8 +75,16 @@ closeBracket = char ']' *> pure LCloseBracket
 lnewline :: Lexer LToken
 lnewline = char '\n' *> pure LNewline
 
+comment :: Lexer LToken
+comment = do
+  string "--"
+  content <- many (satisfy (/= '\n'))
+  optional (char '\n')
+  pure (LComment content)
+
+
 sc :: Lexer ()
-sc = skipMany (char ' ' <|> char '\t')
+sc = skipMany (void (char ' ') <|> void (char '\t') <|> void comment)
 
 saplingLexer :: Lexer [LToken]
 saplingLexer = many (sc *> choice
@@ -92,5 +104,5 @@ saplingLexer = many (sc *> choice
 
 lexSapling :: String -> [LToken]
 lexSapling input = case runParser saplingLexer "" input of
-  Left err  -> error $ "Lexical error:\n" ++ errorBundlePretty err
+  Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
   Right tokens -> tokens

src/Library.hs

@@ -0,0 +1,47 @@
+module Library where
+
+import Eval
+import Parser
+import Research
+
+import qualified Data.Map as Map
+
+library :: Map.Map String T
+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))))" 
+  ]

src/Main.hs

@@ -2,6 +2,7 @@ module Main where
 
 import Eval
 import Lexer
+import Library
 import Parser
 import REPL (repl)
 import Research
@@ -10,4 +11,12 @@ import qualified Data.Map as Map
 import Text.Megaparsec (runParser)
 
 main :: IO ()
-main = repl Map.empty --(Map.fromList [("__result", Leaf)])
+main = do
+  putStrLn "Welcome to the Sapling Interpreter"
+  putStrLn "You can exit at any time by typing and entering: "
+  putStrLn ":_exit"
+  repl library
+
+runSapling :: String -> T
+runSapling s = result (evalSapling Map.empty $ parseSapling s)
+runSaplingEnv env s = result (evalSapling env $ parseSapling s)

src/Parser.hs

@@ -1,10 +1,8 @@
 module Parser where
 
 import Debug.Trace
-
 import Lexer
 import Research hiding (toList)
-
 import Control.Exception (throw)
 import Data.List.NonEmpty (toList)
 import qualified Data.Set as Set
@@ -14,17 +12,18 @@ import Text.Megaparsec.Char
 import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
 
 type Parser = Parsec Void [LToken]
+
 data SaplingAST
-  = SVar    String
+  = SVar String
-  | SInt    Int
+  | SInt Int
-  | SStr    String
+  | SStr String
-  | SList   [SaplingAST]
+  | SList [SaplingAST]
-  | SFunc   String       [String]     SaplingAST
+  | SFunc String [String] SaplingAST
-  | SApp    SaplingAST   SaplingAST
+  | SApp SaplingAST SaplingAST
   | TLeaf
-  | TStem   SaplingAST
+  | TStem SaplingAST
-  | TFork   SaplingAST   SaplingAST
+  | TFork SaplingAST SaplingAST
-  | SLambda [String]     SaplingAST
+  | SLambda [String] SaplingAST
   deriving (Show, Eq, Ord)
 
 parseSapling :: String -> [SaplingAST]
@@ -33,9 +32,8 @@ parseSapling input =
   in map parseSingle nonEmptyLines
 
 parseSingle :: String -> SaplingAST
-parseSingle "" = error "Empty input provided to parseSingle"
 parseSingle input = case runParser parseExpression "" (lexSapling input) of
-  Left  err -> error $ handleParseError err
+  Left err -> error $ handleParseError err
   Right ast -> ast
 
 scnParser :: Parser ()
@@ -45,6 +43,7 @@ parseExpression :: Parser SaplingAST
 parseExpression = choice
   [ try parseFunction
   , try parseLambda
+  , try parseLambdaExpression
   , try parseListLiteral
   , try parseApplication
   , try parseTreeTerm
@@ -59,13 +58,26 @@ parseFunction = do
   body <- parseExpression
   return (SFunc name (map getIdentifier args) body)
 
+parseAtomicBase :: Parser SaplingAST
+parseAtomicBase = choice
+    [ try parseVarWithoutAssignment
+    , parseTreeLeaf
+    , parseGrouped
+    ]
+parseVarWithoutAssignment :: Parser SaplingAST
+parseVarWithoutAssignment = do
+    LIdentifier name <- satisfy isIdentifier
+    if (name == "t" || name == "__result")
+    then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
+    else notFollowedBy (satisfy (== LAssign)) *> return (SVar name)
+
 parseLambda :: Parser SaplingAST
 parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
   satisfy (== LBackslash)
-  param <- satisfy isIdentifier
+  param    <- satisfy isIdentifier
-  rest <- many (satisfy isIdentifier)
+  rest     <- many (satisfy isIdentifier)
   satisfy (== LColon)
-  body <- parseLambdaExpression
+  body     <- parseLambdaExpression
   let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
   return (SLambda [getIdentifier param] nestedLambda)
 
@@ -81,6 +93,7 @@ parseAtomicLambda = choice
   , parseTreeLeaf
   , parseLiteral
   , parseListLiteral
+  , try parseLambda
   , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
   ]
 
@@ -92,22 +105,15 @@ parseApplication = do
 
 parseLambdaApplication :: Parser SaplingAST
 parseLambdaApplication = do
-    func <- parseAtomicLambda
+  func <- parseAtomicLambda
-    args <- many parseAtomicLambda
+  args <- many parseAtomicLambda
-    return $ foldl (\acc arg -> SApp acc arg) func args
+  return $ foldl (\acc arg -> SApp acc arg) func args
 
 isTreeTerm :: SaplingAST -> Bool
-isTreeTerm TLeaf       = True
+isTreeTerm TLeaf = True
-isTreeTerm (TStem _)   = True
+isTreeTerm (TStem _) = True
 isTreeTerm (TFork _ _) = True
-isTreeTerm _           = False
+isTreeTerm _ = False
-
-parseAtomicBase :: Parser SaplingAST
-parseAtomicBase = choice
-  [ parseVar
-  , parseTreeLeaf
-  , parseGrouped
-  ]
 
 parseTreeLeaf :: Parser SaplingAST
 parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
@@ -123,8 +129,8 @@ parseTreeTerm = do
   pure $ foldl combine base rest
   where
     combine acc next = case acc of
-      TLeaf     -> TStem next
+      TLeaf -> TStem next
-      TStem t   -> TFork t next
+      TStem t -> TFork t next
       TFork _ _ -> TFork acc next
 
 parseTreeLeafOrParenthesized :: Parser SaplingAST
@@ -147,7 +153,6 @@ parseAtomic = choice
   , parseLiteral
   ]
 
-
 parseGrouped :: Parser SaplingAST
 parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
 
@@ -190,8 +195,8 @@ parseSingleItem = do
   token <- satisfy isListItem
   case token of
     LIdentifier name -> return (SVar name)
-    LKeywordT        -> return TLeaf
+    LKeywordT -> return TLeaf
-    _                -> fail "Unexpected token in list item"
+    _ -> fail "Unexpected token in list item"
 
 isListItem :: LToken -> Bool
 isListItem (LIdentifier _) = True
@@ -216,24 +221,19 @@ parseStrLiteral = do
   return (SStr value)
 
 -- Boolean Helpers
-isKeywordT       (LKeywordT)         = True
+isKeywordT (LKeywordT) = True
-isKeywordT                        _  = False
+isKeywordT _ = False
-
+isIdentifier (LIdentifier _) = True
-isIdentifier     (LIdentifier     _) = True
+isIdentifier _ = False
-isIdentifier                      _  = False
-
 isIntegerLiteral (LIntegerLiteral _) = True
-isIntegerLiteral                  _  = False
+isIntegerLiteral _ = False
-
+isStringLiteral (LStringLiteral _) = True
-isStringLiteral  (LStringLiteral  _) = True
+isStringLiteral _ = False
-isStringLiteral                   _  = False
+isLiteral (LIntegerLiteral _) = True
-
+isLiteral (LStringLiteral _) = True
-isLiteral        (LIntegerLiteral _) = True
+isLiteral _ = False
-isLiteral        (LStringLiteral  _) = True
+isNewline (LNewline) = True
-isLiteral                         _  = False
+isNewline _ = False
-
-esNewline        (LNewline)          = True
-isNewline                         _  = False
 
 -- Error Handling
 handleParseError :: ParseErrorBundle [LToken] Void -> String
@@ -246,9 +246,10 @@ handleParseError bundle =
 showError :: ParseError [LToken] Void -> String
 showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
   "Parse error at offset " ++ show offset ++ ": unexpected token "
-    ++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
+  ++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
 showError (FancyError offset fancy) =
   "Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
 showError (TrivialError offset Nothing expected) =
   "Parse error at offset " ++ show offset ++ ": expected one of "
-    ++ show (Set.toList expected)
+  ++ show (Set.toList expected)
+

src/REPL.hs

@@ -5,21 +5,38 @@ import Lexer
 import Parser
 import Research
 
-import Control.Monad         (void)
+import Data.List                 (intercalate)
 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
+repl env = runInputT defaultSettings (loop env)
-  putStr "sapling > "
+  where
-  hFlush stdout
+    loop :: Map.Map String T -> InputT IO ()
-  input <- getLine
+    loop env = do
-  if input == "_:exit"
+      minput <- getInputLine "sapling < "
-    then putStrLn "Goodbye!"
+      case minput of
-    else do
+        Nothing -> outputStrLn "Goodbye!"
-      let clearEnv = Map.delete "__result" env
+        Just ":_exit" -> outputStrLn "Goodbye!"
-      let newEnv   = evalSingle clearEnv (parseSingle input)
+        Just "" -> do
-      case Map.lookup "__result" newEnv of
+          outputStrLn ""
-        Just r  -> putStrLn $ "sapling < " ++ show r
+          loop env
-        Nothing -> pure ()
+        Just input -> do
-      repl newEnv
+          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 toNumber tc of
+  Right num -> show num
+  Left _ -> case toString tc of
+    Right str -> "\"" ++ str ++ "\""
+    Left _ -> case toList tc of
+      Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
+      Left _ -> ""

src/Research.hs

@@ -34,8 +34,11 @@ _S = Fork (Stem (Fork Leaf Leaf)) Leaf
 _K :: T
 _K = Stem Leaf
 
+-- Identity
+-- We use the "point-free" style which drops a redundant node
+-- Full _I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
 _I :: T
-_I = apply (apply _S _K) _K -- Fork (Stem (Stem Leaf)) (Stem Leaf)
+_I = Fork (Stem (Stem Leaf)) Leaf 
 
 -- Booleans
 _false :: T
@@ -48,33 +51,41 @@ _not :: T
 _not = Fork (Fork _true (Fork Leaf _false)) Leaf
 
 -- Marshalling
-toString :: String -> T
+ofString :: String -> T
-toString str = toList (map toNumber (map fromEnum str))
+ofString str = ofList (map ofNumber (map fromEnum str))
 
-ofString :: T -> String
+ofNumber :: Int -> T
-ofString tc = map (toEnum . ofNumber) (ofList tc)
+ofNumber 0 = Leaf
-
+ofNumber n =
-toNumber :: Int -> T
-toNumber 0 = Leaf
-toNumber n =
   Fork
     (if odd n then Stem Leaf else Leaf)
-    (toNumber (n `div` 2))
+    (ofNumber (n `div` 2))
 
-ofNumber :: T -> Int
+ofList :: [T] -> T
-ofNumber Leaf = 0
+ofList [] = Leaf
-ofNumber (Fork Leaf rest) = 2 * ofNumber rest
+ofList (x:xs) = Fork x (ofList xs)
-ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
-ofNumber _ = error "Invalid Tree Calculus number"
 
-toList :: [T] -> T
+toNumber :: T -> Either String Int
-toList [] = Leaf
+toNumber Leaf = Right 0
-toList (x:xs) = Fork x (toList xs)
+toNumber (Fork Leaf rest) = case toNumber rest of
+  Right n -> Right (2 * n)
+  Left err -> Left err
+toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
+  Right n -> Right (1 + 2 * n)
+  Left err -> Left err
+toNumber _ = Left "Invalid Tree Calculus number"
 
-ofList :: T -> [T]
+toString :: T -> Either String String
-ofList Leaf = []
+toString tc = case toList tc of
-ofList (Fork x rest) = x : ofList rest
+  Right list -> traverse (fmap toEnum . toNumber) list
-ofList _ = error "Invalid Tree Calculus list"
+  Left err -> Left "Invalid Tree Calculus string"
+
+toList :: T -> Either String [T]
+toList Leaf = Right []
+toList (Fork x rest) = case toList rest of
+  Right xs -> Right (x : xs)
+  Left err -> Left err
+toList _ = Left "Invalid Tree Calculus list"
 
 -- Utility
 toAscii :: T -> String

test/Spec.hs

@@ -2,240 +2,319 @@ module Main where
 
 import Eval
 import Lexer
+import Library
 import Parser
 import Research
 import Control.Exception (evaluate, try, SomeException)
-import qualified Data.Map as Map
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import Text.Megaparsec (runParser)
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 main :: IO ()
 main = defaultMain tests
 
+runSapling :: String -> String
+runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
+
 tests :: TestTree
 tests = testGroup "Sapling Tests"
-    [ lexerTests
+  [ lexerTests
-    , parserTests
+  , parserTests
-    , integrationTests
+  , integrationTests
-    , evaluationTests
+  , evaluationTests
-    , propertyTests
+  , lambdaEvalTests
-    ]
+  , propertyTests
+  ]
 
 lexerTests :: TestTree
 lexerTests = testGroup "Lexer Tests"
-    [ testCase "Lex simple identifiers" $ do
+  [ testCase "Lex simple identifiers" $ do
-        let input = "x a b = a"
+      let input = "x a b = a"
-            expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
+          expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
-        runParser saplingLexer "" input @?= expect
+      runParser saplingLexer "" input @?= expect
-    , testCase "Lex Tree Calculus terms" $ do
+  , testCase "Lex Tree Calculus terms" $ do
-        let input = "t t t"
+      let input = "t t t"
-            expect = Right [LKeywordT, LKeywordT, LKeywordT]
+          expect = Right [LKeywordT, LKeywordT, LKeywordT]
-        runParser saplingLexer "" input @?= expect
+      runParser saplingLexer "" input @?= expect
-    , testCase "Lex escaped characters in strings" $ do
+  , testCase "Lex escaped characters in strings" $ do
-        let input = "\"hello\\nworld\""
+      let input = "\"hello\\nworld\""
-            expect = Right [LStringLiteral "hello\\nworld"]
+          expect = Right [LStringLiteral "hello\\nworld"]
-        runParser saplingLexer "" input @?= expect
+      runParser saplingLexer "" input @?= expect
-    , testCase "Lex mixed literals" $ do
+  , testCase "Lex mixed literals" $ do
-        let input = "t \"string\" 42"
+      let input = "t \"string\" 42"
-            expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
+          expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
-        runParser saplingLexer "" input @?= expect
+      runParser saplingLexer "" input @?= expect
-    , testCase "Lex invalid token" $ do
+  , testCase "Lex invalid token" $ do
-        let input = "$invalid"
+      let input = "$invalid"
-        case runParser saplingLexer "" input of
+      case runParser saplingLexer "" input of
-            Left _ -> return ()
+        Left _ -> return ()
-            Right _ -> assertFailure "Expected lexer to fail on invalid token"
+        Right _ -> assertFailure "Expected lexer to fail on invalid token"
-    , testCase "Drop trailing whitespace in definitions" $ do
+  , testCase "Drop trailing whitespace in definitions" $ do
-        let input = "x = 5 "
+      let input = "x = 5 "
-            expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
+          expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
-        case (runParser saplingLexer "" input) of
+      case (runParser saplingLexer "" input) of
-            Left _ -> assertFailure "Failed to lex input"
+        Left _ -> assertFailure "Failed to lex input"
-            Right i -> i @?= expect
+        Right i -> i @?= expect
-    , testCase "Error when using invalid characters in identifiers" $ do
+  , testCase "Error when using invalid characters in identifiers" $ do
         case (runParser saplingLexer "" "__result = 5") of
-            Left _ -> return ()
+          Left _ -> return ()
-            Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
+          Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
-    ]
+  ]
 
 parserTests :: TestTree
 parserTests = testGroup "Parser Tests"
-    [ testCase "Error when parsing incomplete definitions" $ do
+  [ --testCase "Error when parsing incomplete definitions" $ do
-        let input = lexSapling "x = "
+    --  let input = lexSapling "x = "
-        case (runParser parseExpression "" input) of
+    --  case (runParser parseExpression "" input) of
-            Left _ -> return ()
+    --    Left _ -> return ()
-            Right _ -> assertFailure "Expected failure on invalid input"
+    --    Right _ -> assertFailure "Expected failure on invalid input"
-    , testCase "Error when assigning a value to T" $ do
+  testCase "Error when assigning a value to T" $ do
-        let input = lexSapling "t = x"
+      let input = lexSapling "t = x"
-        case (runParser parseExpression "" input) of
+      case (runParser parseExpression "" input) of
-            Left _ -> return ()
+        Left _ -> return ()
-            Right _ -> assertFailure "Expected failure when trying to assign the value of T"
+        Right _ -> assertFailure "Expected failure when trying to assign the value of T"
-    , testCase "Error when parsing bodyless definitions with arguments" $ do
+  , testCase "Parse function definitions" $ do
-        let input = lexSapling "x a b = "
+      let input = "x = (\\a b c : a)"
-        case (runParser parseExpression "" input) of
+          expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
-            Left _ -> return ()
+      parseSingle input @?= expect
-            Right _ -> assertFailure "Expected failure on invalid input"
+  , testCase "Parse nested Tree Calculus terms" $ do
-    , testCase "Parse function definitions" $ do
+      let input = "t (t t) t"
-        let input = "x a b c = a"
+          expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
-        let expect = SFunc "x" ["a","b","c"] (SVar "a")
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse sequential Tree Calculus terms" $ do
-    , testCase "Parse nested Tree Calculus terms" $ do
+      let input = "t t t"
-        let input = "t (t t) t"
+          expect = SApp (SApp TLeaf TLeaf) TLeaf
-        let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse mixed list literals" $ do
-    , testCase "Parse sequential Tree Calculus terms" $ do
+      let input = "[t (\"hello\") t]"
-        let input = "t t t"
+          expect = SList [TLeaf, SStr "hello", TLeaf]
-        let expect = SApp (SApp TLeaf TLeaf) TLeaf
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse function with applications" $ do
-    , testCase "Parse mixed list literals" $ do
+      let input  = "f = (\\x : t x)"
-        let input = "[t (\"hello\") t]"
+          expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
-        let expect = SList [TLeaf, SStr "hello", TLeaf]
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse nested lists" $ do
-    , testCase "Parse function with applications" $ do
+      let input  = "[t [(t t)]]"
-        let input = "f x = t x"
+          expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
-        let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse complex parentheses" $ do
-     , testCase "Parse nested lists" $ do
+      let input  = "t (t t (t t))"
-        let input = "[t [(t t)]]"
+          expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
-        let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse empty list" $ do
-    , testCase "Parse complex parentheses" $ do
+      let input  = "[]"
-        let input = "t (t t (t t))"
+          expect = SList []
-        let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse multiple nested lists" $ do
-    , testCase "Parse empty list" $ do
+      let input  = "[[t t] [t (t t)]]"
-        let input = "[]"
+          expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
-        let expect = SList []
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse whitespace variance" $ do
-    , testCase "Parse multiple nested lists" $ do
+      let input1 = "[t t]"
-        let input = "[[t t] [t (t t)]]"
+      let input2 = "[ t t ]"
-        let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
+          expect = SList [TLeaf, TLeaf]
-        parseSingle input @?= expect
+      parseSingle input1 @?= expect
-    , testCase "Parse whitespace variance" $ do
+      parseSingle input2 @?= expect
-        let input1 = "[t t]"
+  , testCase "Parse string in list" $ do
-        let input2 = "[ t t ]"
+      let input  = "[(\"hello\")]"
-        let expect = SList [TLeaf, TLeaf]
+          expect = SList [SStr "hello"]
-        parseSingle input1 @?= expect
+      parseSingle input @?= expect
-        parseSingle input2 @?= expect
+  , testCase "Parse parentheses inside list" $ do
-    , testCase "Parse string in list" $ do
+      let input  = "[t (t t)]"
-        let input = "[(\"hello\")]"
+          expect = SList [TLeaf,SApp TLeaf TLeaf]
-        let expect = SList [SStr "hello"]
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse nested parentheses in function body" $ do
-    , testCase "Parse parentheses inside list" $ do
+      let input  = "f = (\\x : t (t (t t)))"
-        let input = "[t (t t)]"
+          expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
-        let expect = SList [TLeaf,SApp TLeaf TLeaf]
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse lambda abstractions" $ do
-    , testCase "Parse nested parentheses in function body" $ do
+      let input  = "(\\a : a)"
-        let input = "f = t (t (t t))"
+          expect = (SLambda ["a"] (SVar "a"))
-        let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Parse multiple arguments to lambda abstractions" $ do
-    , testCase "Parse lambda abstractions" $ do
+      let input  = "x = (\\a b : a)"
-        let input = "(\\a : a)"
+          expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
-        let expect = (SLambda ["a"] (SVar "a"))
+      parseSingle input @?= expect
-        parseSingle input @?= expect
+  , testCase "Grouping T terms with parentheses in function application" $ do
-    , testCase "Parse multiple arguments to lambda abstractions" $ do
+      let input  = "x = (\\a : a)\nx (t)"
-        let input = "x = (\\a b : a)"
+          expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
-        let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
+      parseSapling input @?= expect
-        parseSingle input @?= expect
+  ]
-     , testCase "Grouping T terms with parentheses in function application" $ do
-        let input  = "x = (\\a : a)\n" <> "x (t)"
-            expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
-        parseSapling input @?= expect
-    ]
 
 integrationTests :: TestTree
 integrationTests = testGroup "Integration Tests"
-    [ testCase "Combine lexer and parser" $ do
+  [ testCase "Combine lexer and parser" $ do
-        let input = "x = t t t"
+      let input = "x = t t t"
-        let expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
+          expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
-        parseSingle input @?= expect
+      parseSingle input @?= expect
-    , testCase "Complex Tree Calculus expression" $ do
+  , testCase "Complex Tree Calculus expression" $ do
-        let input = "t (t t t) t"
+      let input = "t (t t t) t"
-        let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
+          expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
-        parseSingle input @?= expect
+      parseSingle input @?= expect
-    ]
+  ]
 
 evaluationTests :: TestTree
 evaluationTests = testGroup "Evaluation Tests"
-    [ testCase "Evaluate single Leaf" $ do
+  [ testCase "Evaluate single Leaf" $ do
-        let input = "t"
+      let input = "t"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= Leaf
+      (result $ evalSingle Map.empty ast) @?= Leaf
-    , testCase "Evaluate single Stem" $ do
+  , testCase "Evaluate single Stem" $ do
-        let input = "t t"
+      let input = "t t"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= Stem Leaf
+      (result $ evalSingle Map.empty ast) @?= Stem Leaf
-    , testCase "Evaluate single Fork" $ do
+  , testCase "Evaluate single Fork" $ do
-        let input = "t t t"
+      let input = "t t t"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
+      (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
-    , testCase "Evaluate nested Fork and Stem" $ do
+  , testCase "Evaluate nested Fork and Stem" $ do
-        let input = "t (t t) t"
+      let input = "t (t t) t"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
+      (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
-    , testCase "Evaluate `not` function" $ do
+  , testCase "Evaluate `not` function" $ do
-        let input = "t (t (t t) (t t t)) t"
+      let input = "t (t (t t) (t t t)) t"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?=
+      (result $ evalSingle Map.empty ast) @?=
-            Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
+        Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
-    , testCase "Environment updates with definitions" $ do
+  , testCase "Environment updates with definitions" $ do
-        let input = "x = t\ny = x"
+      let input = "x = t\ny = x"
-        let env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        Map.lookup "x" env @?= Just Leaf
+      Map.lookup "x" env @?= Just Leaf
-        Map.lookup "y" env @?= Just Leaf
+      Map.lookup "y" env @?= Just Leaf
-    , testCase "Variable substitution" $ do
+  , testCase "Variable substitution" $ do
-        let input = "x = t t\ny = t x\ny"
+      let input = "x = t t\ny = t x\ny"
-        let env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        (result env) @?= Stem (Stem Leaf)
+      (result env) @?= Stem (Stem Leaf)
-     , testCase "Multiline input evaluation" $ do
+  , testCase "Multiline input evaluation" $ do
-        let input = "x = t\ny = t t\nx"
+      let input = "x = t\ny = t t\nx"
-        let env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        (result env) @?= Leaf
+      (result env) @?= Leaf
-     , testCase "Evaluate string literal" $ do
+  , testCase "Evaluate string literal" $ do
-        let input = "\"hello\""
+      let input = "\"hello\""
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= toString "hello"
+      (result $ evalSingle Map.empty ast) @?= ofString "hello"
-    , testCase "Evaluate list literal" $ do
+  , testCase "Evaluate list literal" $ do
-        let input = "[t (t t)]"
+      let input = "[t (t t)]"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
+      (result $ evalSingle Map.empty ast) @?= ofList [Leaf, Stem Leaf]
-    , testCase "Evaluate empty list" $ do
+  , testCase "Evaluate empty list" $ do
-        let input = "[]"
+      let input = "[]"
-        let ast = parseSingle input
+      let ast = parseSingle input
-        (result $ evalSingle Map.empty ast) @?= toList []
+      (result $ evalSingle Map.empty ast) @?= ofList []
-    , testCase "Evaluate variable dependency chain" $ do
+  , testCase "Evaluate variable dependency chain" $ do
-        let input = "x = t (t t)\n \
+      let input = "x = t (t t)\n \
-                    \ y = x\n \
+                  \ y = x\n \
-                    \ z = y\n \
+                  \ z = y\n \
-                    \ variablewithamuchlongername = z\n \
+                  \ variablewithamuchlongername = z\n \
-                    \ variablewithamuchlongername"
+                  \ variablewithamuchlongername"
-        let env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        (result env) @?= (Stem (Stem Leaf))
+      (result env) @?= (Stem (Stem Leaf))
-    , testCase "Evaluate variable shadowing" $ do
+  , testCase "Evaluate variable shadowing" $ do
-        let input = "x = t t\nx = t\nx"
+      let input = "x = t t\nx = t\nx"
-        let env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        (result env) @?= Leaf
+      (result env) @?= Leaf
-    , testCase "Lambda identity" $ do
-        let input = "(\\a : a)"
-            env = evalSapling Map.empty (parseSapling input)
-        result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
     , testCase "Apply identity to Boolean Not" $ do
-        let not = "(t (t (t t) (t t t)) t)"
+      let not = "(t (t (t t) (t t t)) t)"
-            input = "x = (\\a : a)\nx " ++ not
+      let input = "x = (\\a : a)\nx " ++ not
-            env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
+      result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
     , testCase "Constant function matches" $ do
-        let input = "k = (\\a b : a)\nk (t t) t"
+      let input = "k = (\\a b : a)\nk (t t) t"
-            env = evalSapling Map.empty (parseSapling input)
+          env = evalSapling Map.empty (parseSapling input)
-        result env @?= Stem Leaf
+      result env @?= Stem Leaf
-    ]
+   , testCase "Boolean AND_ TF" $ do
+      let input = "and (t t) (t)"
+          env = evalSapling library (parseSapling input)
+      result env @?= Leaf
+   , testCase "Boolean AND_ FT" $ do
+      let input = "and (t) (t t)"
+          env = evalSapling library (parseSapling input)
+      result env @?= Leaf
+   , testCase "Boolean AND_ FF" $ do
+      let input = "and (t) (t)"
+          env = evalSapling library (parseSapling input)
+      result env @?= Leaf
+    , testCase "Boolean AND_ TT" $ do
+      let input = "and (t t) (t t)"
+          env = evalSapling library (parseSapling input)
+      result env @?= Stem Leaf
+    , testCase "Verifying Equality" $ do
+      let input = "equal (t t t) (t t t)"
+          env = evalSapling library (parseSapling input)
+      result env @?= Stem Leaf
+  ]
+
+lambdaEvalTests :: TestTree
+lambdaEvalTests = testGroup "Lambda Evaluation Tests"
+  [ testCase "Lambda Identity Function" $ do
+      let input = "id = (\\x : x)\nid t"
+      runSapling input @?= "Leaf"
+  , testCase "Lambda Constant Function (K combinator)" $ do
+      let input = "k = (\\x y : x)\nk t (t t)"
+      runSapling input @?= "Leaf"
+  , testCase "Lambda Application with Variable" $ do
+      let input = "id = (\\x : x)\nval = t t\nid val"
+      runSapling input @?= "Stem Leaf"
+  , testCase "Lambda Application with Multiple Arguments" $ do
+      let input = "apply = (\\f x y : f x y)\nk = (\\a b : a)\napply k t (t t)"
+      runSapling input @?= "Leaf"
+   , testCase "Nested Lambda Application" $ do
+      let input = "apply = (\\f x y : f x y)\nid = (\\x : x)\napply (\\f x : f x) id t"
+      runSapling input @?= "Leaf"
+  , testCase "Lambda with a complex body" $ do
+      let input = "f = (\\x : t (t x))\nf t"
+      runSapling input @?= "Stem (Stem Leaf)"
+  , testCase "Lambda returning a function" $ do
+      let input = "f = (\\x : (\\y : x))\ng = f t\ng (t t)"
+      runSapling input @?= "Leaf"
+  , testCase "Lambda with Shadowing" $ do
+      let input = "f = (\\x : (\\x : x))\nf t (t t)"
+      runSapling input @?= "Stem Leaf"
+   , testCase "Lambda returning another lambda" $ do
+      let input = "k = (\\x : (\\y : x))\nk_app = k t\nk_app (t t)"
+      runSapling input @?= "Leaf"
+   , testCase "Lambda with free variables" $ do
+      let input = "y = t t\nf = (\\x : y)\nf t"
+      runSapling input @?= "Stem Leaf"
+   , testCase "SKI Composition" $ do
+      let input = "s = (\\x y z : x z (y z))\nk = (\\x y : x)\ni = (\\x : x)\ncomp = s k i\ncomp t (t t)"
+      runSapling input @?= "Stem (Stem Leaf)"
+   , testCase "Lambda with multiple parameters and application" $ do
+      let input = "f = (\\a b c : t a b c)\nf t (t t) (t t t)"
+      runSapling input @?= "Stem Leaf"
+   , testCase "Lambda with nested application in the body" $ do
+      let input = "f = (\\x : t (t (t x)))\nf t"
+      runSapling input @?= "Stem (Stem (Stem Leaf))"
+    , testCase "Lambda returning a function and applying it" $ do
+        let input = "f = (\\x : (\\y : t x y))\ng = f t\ng (t t)"
+        runSapling input @?= "Fork Leaf (Stem Leaf)"
+    , testCase "Lambda applying a variable" $ do
+        let input = "id = (\\x : x)\na = t t\nid a"
+        runSapling input @?= "Stem Leaf"
+    , testCase "Nested lambda abstractions in the same expression" $ do
+        let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
+        runSapling input @?= "Leaf"
+  , testCase "Lambda with a string literal" $ do
+        let input = "f = (\\x : x)\nf \"hello\""
+        runSapling input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) Leaf))))"
+   , testCase "Lambda with an integer literal" $ do
+        let input = "f = (\\x : x)\nf 42"
+        runSapling input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
+   , testCase "Lambda with a list literal" $ do
+        let input = "f = (\\x : x)\nf [t (t t)]"
+        runSapling input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
+  ]
 
 propertyTests :: TestTree
 propertyTests = testGroup "Property Tests"
-    [ testProperty "Lexing and parsing round-trip" $ \input ->
+  [ testProperty "Lexing and parsing round-trip" $ \input ->
-        case runParser saplingLexer "" input of
+      case runParser saplingLexer "" input of
-            Left _ -> property True
+        Left _ -> property True
-            Right tokens -> case runParser parseExpression "" tokens of
+        Right tokens -> case runParser parseExpression "" tokens of
-                Left _ -> property True
+          Left _ -> property True
-                Right ast -> parseSingle input === ast
+          Right ast -> parseSingle input === ast
-    ]
+  ]