James/tricu
1
1
Fork 0
Code Issues 3 Pull Requests Actions Packages Projects Releases 1 Wiki Activity

Compare commits

base: James:e376d13a93cdf7cc32ca27d0f9b94736b292ea65
Branches Tags
James:main
James:feat/new-outputs
James:feat/ternary-representation
James:feature/compiler-CLI
James:fix/comments-0001
James:0.5.0
..
compare: James:7fca4d38e8dc50cff988d0da1729ac9838de5f94
Branches Tags
James:main
James:feat/new-outputs
James:feat/ternary-representation
James:feature/compiler-CLI
James:fix/comments-0001
James:0.5.0

No commits in common. "e376d13a93cdf7cc32ca27d0f9b94736b292ea65" and "7fca4d38e8dc50cff988d0da1729ac9838de5f94" have entirely different histories.
e376d13a93 ... 7fca4d38e8

10 changed files with 385 additions and 581 deletions
Show Stats Expand all files Collapse all files

40
README.md
View File

@ -1,52 +1,16 @@
# sapling # 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) . 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: It offers a minimal amount of syntax sugar:
- `t` operator behaving by the rules of Tree Calculus - `t` operator behaving by the rules of Tree Calculus
- Function ("variable") definitions - Variable definitions
- Lambda abstractions - Lambda abstractions
- List, Number, and String literals (WIP) - List, Integer, and String literals
This is an active experimentation project by [someone who has no idea what they're doing](https://eversole.co). 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 ## Acknowledgements
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).

8
sapling.cabal
View File

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

142
src/Eval.hs
View File

@ -2,95 +2,121 @@ module Eval where
import Parser import Parser
import Research import Research
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (foldl')
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Map (Map)
evalSingle :: Map String T -> SaplingAST -> Map String T evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
evalSingle env term = case term of evalSingle env term = case term of
SFunc name [] body -> SFunc name [] body ->
let lineNoLambda = eliminateLambda body let result = evalAST env body
result = evalAST env lineNoLambda in Map.insert name result env
in Map.insert name result env SApp func arg ->
SLambda _ body -> let result = apply (evalAST env func) (evalAST env arg)
let result = evalAST env body in Map.insert "__result" result env
in Map.insert "__result" result env SVar name -> case Map.lookup name env of
SApp func arg -> Just value -> Map.insert "__result" value env
let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg) Nothing -> error $ "Variable " ++ name ++ " not defined"
in Map.insert "__result" result env _ ->
SVar name -> let result = evalAST env term
case Map.lookup name env of in Map.insert "__result" result env
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 :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env evalSapling env [] = env
evalSapling env [lastLine] = evalSapling env [lastLine] =
let lastLineNoLambda = eliminateLambda lastLine let
lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) = evalSapling env (line:rest) =
let lineNoLambda = eliminateLambda line let
lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest in evalSapling updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T evalAST :: Map String T -> SaplingAST -> T
evalAST env term = case term of evalAST env term = case term of
SVar name -> case Map.lookup name env of SVar name ->
Just value -> value case Map.lookup name env of
Nothing -> error $ "Variable " ++ name ++ " not defined" Just value -> value
Nothing -> error $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf TLeaf -> Leaf
TStem t -> Stem (evalAST env t) TStem t ->
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2) Stem (evalAST env t)
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2) TFork t1 t2 ->
SStr str -> ofString str Fork (evalAST env t1) (evalAST env t2)
SInt num -> ofNumber num SApp t1 t2 ->
SList elems -> ofList (map (evalAST Map.empty) elems) apply (evalAST env t1) (evalAST env t2)
SStr str -> toString str
SInt num -> toNumber num
SList elems -> toList (map (evalAST Map.empty) elems)
SFunc name args body -> SFunc name args body ->
error $ "Unexpected function definition " ++ name error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle." ++ " in evalAST; define via evalSingle."
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination." SLambda {} ->
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 :: SaplingAST -> SaplingAST
eliminateLambda (SLambda (v:vs) body) eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body) | null vs = lambdaToT v (eliminateLambda body)
| otherwise = eliminateLambda (SLambda [v] (SLambda vs body)) | otherwise =
eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg) eliminateLambda (SLambda [v] (SLambda vs body))
eliminateLambda (TStem t) = TStem (eliminateLambda t) eliminateLambda (SApp f arg) =
eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r) SApp (eliminateLambda f) (eliminateLambda arg)
eliminateLambda (SList xs) = SList (map eliminateLambda xs) eliminateLambda (TStem t) =
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 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 :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x == y = tI | x == y = tI
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x /= y = SApp tK (SVar y) | x /= y =
SApp tK (SVar y)
lambdaToT x t lambdaToT x t
| not (isFree x t) = SApp tK t | not (isFree x t) =
SApp tK t
lambdaToT x (SApp n u) lambdaToT x (SApp n u)
| not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u)) | not (isFree x (SApp n u)) =
lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (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 f args) = lambdaToT x f
lambdaToT x body lambdaToT x body
| not (isFree x body) = SApp tK body | not (isFree x body) =
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf SApp tK body
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
freeVars :: SaplingAST -> Set.Set String tLeaf :: SaplingAST
tLeaf = TLeaf
freeVars :: SaplingAST -> Set String
freeVars (SVar v) = Set.singleton v freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs freeVars (SList xs) = foldMap freeVars xs
freeVars (SFunc _ _ b) = freeVars b
freeVars (SApp f arg) = freeVars f <> freeVars arg freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty freeVars TLeaf = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
@ -103,18 +129,12 @@ toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a) toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b) 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 :: SaplingAST
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf tI = toAST _I
tK :: SaplingAST tK :: SaplingAST
tK = SApp TLeaf TLeaf tK = toAST _K
tS :: SaplingAST tS :: SaplingAST
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf tS = toAST _S
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"

18
src/Lexer.hs
View File

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

47
src/Library.hs
View File

@ -1,47 +0,0 @@
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))))"
]

11
src/Main.hs
View File

@ -2,7 +2,6 @@ module Main where
import Eval import Eval
import Lexer import Lexer
import Library
import Parser import Parser
import REPL (repl) import REPL (repl)
import Research import Research
@ -11,12 +10,4 @@ import qualified Data.Map as Map
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
main :: IO () main :: IO ()
main = do main = repl Map.empty --(Map.fromList [("__result", Leaf)])
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)

107
src/Parser.hs
View File

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

47
src/REPL.hs
View File

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

55
src/Research.hs
View File

@ -34,11 +34,8 @@ _S = Fork (Stem (Fork Leaf Leaf)) Leaf
_K :: T _K :: T
_K = Stem Leaf _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 :: T
_I = Fork (Stem (Stem Leaf)) Leaf _I = apply (apply _S _K) _K -- Fork (Stem (Stem Leaf)) (Stem Leaf)
-- Booleans -- Booleans
_false :: T _false :: T
@ -51,41 +48,33 @@ _not :: T
_not = Fork (Fork _true (Fork Leaf _false)) Leaf _not = Fork (Fork _true (Fork Leaf _false)) Leaf
-- Marshalling -- Marshalling
ofString :: String -> T toString :: String -> T
ofString str = ofList (map ofNumber (map fromEnum str)) toString str = toList (map toNumber (map fromEnum str))
ofNumber :: Int -> T ofString :: T -> String
ofNumber 0 = Leaf ofString tc = map (toEnum . ofNumber) (ofList tc)
ofNumber n =
toNumber :: Int -> T
toNumber 0 = Leaf
toNumber n =
Fork Fork
(if odd n then Stem Leaf else Leaf) (if odd n then Stem Leaf else Leaf)
(ofNumber (n `div` 2)) (toNumber (n `div` 2))
ofList :: [T] -> T ofNumber :: T -> Int
ofList [] = Leaf ofNumber Leaf = 0
ofList (x:xs) = Fork x (ofList xs) ofNumber (Fork Leaf rest) = 2 * ofNumber rest
ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
ofNumber _ = error "Invalid Tree Calculus number"
toNumber :: T -> Either String Int toList :: [T] -> T
toNumber Leaf = Right 0 toList [] = Leaf
toNumber (Fork Leaf rest) = case toNumber rest of toList (x:xs) = Fork x (toList xs)
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"
toString :: T -> Either String String ofList :: T -> [T]
toString tc = case toList tc of ofList Leaf = []
Right list -> traverse (fmap toEnum . toNumber) list ofList (Fork x rest) = x : ofList rest
Left err -> Left "Invalid Tree Calculus string" ofList _ = error "Invalid Tree Calculus list"
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 -- Utility
toAscii :: T -> String toAscii :: T -> String

491
test/Spec.hs
View File

@ -2,319 +2,240 @@ module Main where
import Eval import Eval
import Lexer import Lexer
import Library
import Parser import Parser
import Research import Research
import Control.Exception (evaluate, try, SomeException) import Control.Exception (evaluate, try, SomeException)
import qualified Data.Map as Map
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.QuickCheck import Test.Tasty.QuickCheck
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
import qualified Data.Map as Map
import qualified Data.Set as Set
main :: IO () main :: IO ()
main = defaultMain tests main = defaultMain tests
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
tests :: TestTree tests :: TestTree
tests = testGroup "Sapling Tests" tests = testGroup "Sapling Tests"
[ lexerTests [ lexerTests
, parserTests , parserTests
, integrationTests , integrationTests
, evaluationTests , evaluationTests
, lambdaEvalTests , propertyTests
, propertyTests ]
]
lexerTests :: TestTree lexerTests :: TestTree
lexerTests = testGroup "Lexer Tests" 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 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 :: TestTree
parserTests = testGroup "Parser Tests" 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 "Parse function definitions" $ do , testCase "Error when parsing bodyless definitions with arguments" $ do
let input = "x = (\\a b c : a)" let input = lexSapling "x a b = "
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a")))) case (runParser parseExpression "" input) of
parseSingle input @?= expect Left _ -> return ()
, testCase "Parse nested Tree Calculus terms" $ do Right _ -> assertFailure "Expected failure on invalid input"
let input = "t (t t) t" , testCase "Parse function definitions" $ do
expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf let input = "x a b c = a"
parseSingle input @?= expect let expect = SFunc "x" ["a","b","c"] (SVar "a")
, testCase "Parse sequential Tree Calculus terms" $ do parseSingle input @?= expect
let input = "t t t" , testCase "Parse nested Tree Calculus terms" $ do
expect = SApp (SApp TLeaf TLeaf) TLeaf let input = "t (t t) t"
parseSingle input @?= expect let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
, testCase "Parse mixed list literals" $ do parseSingle input @?= expect
let input = "[t (\"hello\") t]" , testCase "Parse sequential Tree Calculus terms" $ do
expect = SList [TLeaf, SStr "hello", TLeaf] let input = "t t t"
parseSingle input @?= expect let expect = SApp (SApp TLeaf TLeaf) TLeaf
, testCase "Parse function with applications" $ do parseSingle input @?= expect
let input = "f = (\\x : t x)" , testCase "Parse mixed list literals" $ do
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x"))) let input = "[t (\"hello\") t]"
parseSingle input @?= expect let expect = SList [TLeaf, SStr "hello", TLeaf]
, testCase "Parse nested lists" $ do parseSingle input @?= expect
let input = "[t [(t t)]]" , testCase "Parse function with applications" $ do
expect = SList [TLeaf,SList [SApp TLeaf TLeaf]] let input = "f x = t x"
parseSingle input @?= expect let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
, testCase "Parse complex parentheses" $ do parseSingle input @?= expect
let input = "t (t t (t t))" , testCase "Parse nested lists" $ do
expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf)) let input = "[t [(t t)]]"
parseSingle input @?= expect let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
, testCase "Parse empty list" $ do parseSingle input @?= expect
let input = "[]" , testCase "Parse complex parentheses" $ do
expect = SList [] let input = "t (t t (t t))"
parseSingle input @?= expect let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
, testCase "Parse multiple nested lists" $ do parseSingle input @?= expect
let input = "[[t t] [t (t t)]]" , testCase "Parse empty list" $ do
expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]] let input = "[]"
parseSingle input @?= expect let expect = SList []
, testCase "Parse whitespace variance" $ do parseSingle input @?= expect
let input1 = "[t t]" , testCase "Parse multiple nested lists" $ do
let input2 = "[ t t ]" let input = "[[t t] [t (t t)]]"
expect = SList [TLeaf, TLeaf] let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
parseSingle input1 @?= expect parseSingle input @?= expect
parseSingle input2 @?= expect , testCase "Parse whitespace variance" $ do
, testCase "Parse string in list" $ do let input1 = "[t t]"
let input = "[(\"hello\")]" let input2 = "[ t t ]"
expect = SList [SStr "hello"] let expect = SList [TLeaf, TLeaf]
parseSingle input @?= expect parseSingle input1 @?= expect
, testCase "Parse parentheses inside list" $ do parseSingle input2 @?= expect
let input = "[t (t t)]" , testCase "Parse string in list" $ do
expect = SList [TLeaf,SApp TLeaf TLeaf] let input = "[(\"hello\")]"
parseSingle input @?= expect let expect = SList [SStr "hello"]
, testCase "Parse nested parentheses in function body" $ do parseSingle input @?= expect
let input = "f = (\\x : t (t (t t)))" , testCase "Parse parentheses inside list" $ do
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))) let input = "[t (t t)]"
parseSingle input @?= expect let expect = SList [TLeaf,SApp TLeaf TLeaf]
, testCase "Parse lambda abstractions" $ do parseSingle input @?= expect
let input = "(\\a : a)" , testCase "Parse nested parentheses in function body" $ do
expect = (SLambda ["a"] (SVar "a")) let input = "f = t (t (t t))"
parseSingle input @?= expect let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
, testCase "Parse multiple arguments to lambda abstractions" $ do parseSingle input @?= expect
let input = "x = (\\a b : a)" , testCase "Parse lambda abstractions" $ do
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a"))) let input = "(\\a : a)"
parseSingle input @?= expect let expect = (SLambda ["a"] (SVar "a"))
, testCase "Grouping T terms with parentheses in function application" $ do parseSingle input @?= expect
let input = "x = (\\a : a)\nx (t)" , testCase "Parse multiple arguments to lambda abstractions" $ do
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf] let input = "x = (\\a b : a)"
parseSapling input @?= expect let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
] 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 :: TestTree
integrationTests = testGroup "Integration Tests" 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"
expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf) let 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"
expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
parseSingle input @?= expect parseSingle input @?= expect
] ]
evaluationTests :: TestTree evaluationTests :: TestTree
evaluationTests = testGroup "Evaluation Tests" 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"
env = evalSapling Map.empty (parseSapling input) let 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"
env = evalSapling Map.empty (parseSapling input) let 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"
env = evalSapling Map.empty (parseSapling input) let 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) @?= ofString "hello" (result $ evalSingle Map.empty ast) @?= toString "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) @?= ofList [Leaf, Stem Leaf] (result $ evalSingle Map.empty ast) @?= toList [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) @?= ofList [] (result $ evalSingle Map.empty ast) @?= toList []
, 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"
env = evalSapling Map.empty (parseSapling input) let 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"
env = evalSapling Map.empty (parseSapling input) let 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 , 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)"
let input = "x = (\\a : a)\nx " ++ not 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 , 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 :: TestTree
propertyTests = testGroup "Property Tests" 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
] ]