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

Rename from sapling to tricu

Browse Source
This commit is contained in:
James Eversole 2024-12-29 08:29:25 -06:00
parent 064bed26c5
commit c30f17367f
10 changed files with 136 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
README.md
View File

@ -1,10 +1,12 @@
# sapling
# tricu
## Introduction
sapling is a "micro-language" that [I'm](https://eversole.co) working on to investigate [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) .
tricu (pronounced like "tree-shoe") is a "micro-language" that [I'm](https://eversole.co) 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 yet provides a complete and intuitive programming environment. Sapling offers:
tricu [means tree in Lojban](https://en.wiktionary.org/wiki/Appendix:Lojban/tricu). This project was named "sapling" until I discovered the name was already being used for other projects in programming language development.
tricu offers a minimal amount of syntax sugar yet provides a complete and intuitive programming environment. tricu offers:
- `t` operator behaving by the rules of Tree Calculus
- Function ("variable") definitions
@ -21,36 +23,35 @@ _ = t
true = t t
-- We can define functions as lambda expressions that are eliminated to tree
-- calculus terms.
id = (\a : a) -- t (t (t t)) t
id = (\a : a) -- `id` evaluates to the TC form of: t (t (t t)) t
triage = (\a b c : t (t a b) c)
triage = (\a b c : t (t a b) c)
-- Intensionality !!!
-- Intensionality! We can inspect program structure, not just inputs/outputs:
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
-- REPL
-- `sapling <` is the input prompt
-- `sapling >` is the Tree Calculus form output. Most are elided below.
-- `DECODE -:` is an attempt to interpret the TC output as strings/numbers.
sapling < test t
sapling > Fork (Fork Leaf (Fork ...) ... )
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!"]
-- `tricu <` is the input prompt
-- `tricu >` is the Tree Calculus form output. Most are elided below.
-- `READ -:` is an attempt to interpret the TC output as strings/numbers.
tricu < test t
tricu > Fork (Fork Leaf (Fork ...) ... )
READ -: "Leaf"
tricu < test (t t)
READ -: "Stem"
tricu < test (t t t)
READ -: "Fork"
tricu < map (\i : listConcat i " is super cool!") [("Tree Calculus") ("Intensionality") ("tricu")]
READ -: ["Tree Calculus is super cool!", "Intensionality is super cool!", "tricu is super cool!"]
```
## Installation
You can easily build and/or run this project using [Nix](https://nixos.org/download/).
- Build REPL binary: `nix build git+https://git.eversole.co/James/sapling`
- Run REPL: `nix run git+https://git.eversole.co/James/sapling`
- Build REPL binary: `nix build git+https://git.eversole.co/James/tricu`
- Run REPL: `nix run git+https://git.eversole.co/James/tricu`
## Acknowledgements
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. If sapling sounds interesting but compiling this repo sounds like a hassle, you should check out his site.
[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. If tricu sounds interesting but compiling this repo sounds like a hassle, you should check out his site.

6
flake.nix
View File

@ -1,5 +1,5 @@
{
description = "sapling";
description = "tricu";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs";
@ -10,7 +10,7 @@
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages.${system};
packageName = "sapling";
packageName = "tricu";
containerPackageName = "${packageName}-container";
customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
@ -22,7 +22,7 @@
enableSharedExecutables = false;
enableSharedLibraries = false;
sapling = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
tricu = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
in {
packages.${packageName} =

32
src/Eval.hs
View File

@ -8,7 +8,7 @@ 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 :: Map String T -> TricuAST -> Map String T
evalSingle env term = case term of
SFunc name [] body ->
let lineNoLambda = eliminateLambda body
@ -28,18 +28,18 @@ evalSingle env term = case term of
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] =
evalTricu :: Map String T -> [TricuAST] -> Map String T
evalTricu env [] = env
evalTricu env [lastLine] =
let lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
evalTricu env (line:rest) =
let lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
in evalTricu updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T
evalAST :: Map String T -> TricuAST -> T
evalAST env term = case term of
SVar name -> case Map.lookup name env of
Just value -> value
@ -56,7 +56,7 @@ evalAST env term = case term of
++ " in evalAST; define via evalSingle."
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda :: TricuAST -> TricuAST
eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body)
| otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
@ -69,7 +69,7 @@ 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 -> TricuAST -> TricuAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
@ -83,7 +83,7 @@ lambdaToT x body
| not (isFree x body) = SApp tK body
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
freeVars :: SaplingAST -> Set.Set String
freeVars :: TricuAST -> Set.Set String
freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty
@ -95,23 +95,23 @@ freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
isFree :: String -> SaplingAST -> Bool
isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
toAST :: T -> SaplingAST
toAST :: T -> TricuAST
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
-- We need the SKI operators in an unevaluated TricuAST tree form so that we
-- can keep the evaluation functions straightforward
tI :: SaplingAST
tI :: TricuAST
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: SaplingAST
tK :: TricuAST
tK = SApp TLeaf TLeaf
tS :: SaplingAST
tS :: TricuAST
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
result :: Map String T -> T

8
src/Lexer.hs
View File

@ -86,8 +86,8 @@ comment = do
sc :: Lexer ()
sc = skipMany (void (char ' ') <|> void (char '\t') <|> void comment)
saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice
tricuLexer :: Lexer [LToken]
tricuLexer = many (sc *> choice
[ try identifier
, try keywordT
, try integerLiteral
@ -102,7 +102,7 @@ saplingLexer = many (sc *> choice
, lnewline
] <* sc) <* eof
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

2
src/Library.hs
View File

@ -7,7 +7,7 @@ import Research
import qualified Data.Map as Map
library :: Map.Map String T
library = evalSapling Map.empty $ parseSapling $ unlines
library = evalTricu Map.empty $ parseTricu $ unlines
[ "false = t"
, "true = t t"
, "_ = t"

8
src/Main.hs
View File

@ -12,11 +12,11 @@ import Text.Megaparsec (runParser)
main :: IO ()
main = do
putStrLn "Welcome to the Sapling Interpreter"
putStrLn "Welcome to the Tricu 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)
runTricu :: String -> T
runTricu s = result (evalTricu Map.empty $ parseTricu s)
runTricuEnv env s = result (evalTricu env $ parseTricu s)

72
src/Parser.hs
View File

@ -13,33 +13,33 @@ import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken]
data SaplingAST
data TricuAST
= SVar String
| SInt Int
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST
| SList [TricuAST]
| SFunc String [String] TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
| TStem TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
parseSapling input =
parseTricu :: String -> [TricuAST]
parseTricu input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSingle nonEmptyLines
parseSingle :: String -> SaplingAST
parseSingle input = case runParser parseExpression "" (lexSapling input) of
parseSingle :: String -> TricuAST
parseSingle input = case runParser parseExpression "" (lexTricu input) of
Left err -> error $ handleParseError err
Right ast -> ast
scnParser :: Parser ()
scnParser = skipMany (satisfy isNewline)
parseExpression :: Parser SaplingAST
parseExpression :: Parser TricuAST
parseExpression = choice
[ try parseFunction
, try parseLambda
@ -50,7 +50,7 @@ parseExpression = choice
, parseLiteral
]
parseFunction :: Parser SaplingAST
parseFunction :: Parser TricuAST
parseFunction = do
LIdentifier name <- satisfy isIdentifier
args <- many (satisfy isIdentifier)
@ -58,20 +58,20 @@ parseFunction = do
body <- parseExpression
return (SFunc name (map getIdentifier args) body)
parseAtomicBase :: Parser SaplingAST
parseAtomicBase :: Parser TricuAST
parseAtomicBase = choice
[ try parseVarWithoutAssignment
, parseTreeLeaf
, parseGrouped
]
parseVarWithoutAssignment :: Parser SaplingAST
parseVarWithoutAssignment :: Parser TricuAST
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 TricuAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
param <- satisfy isIdentifier
@ -81,13 +81,13 @@ parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
return (SLambda [getIdentifier param] nestedLambda)
parseLambdaExpression :: Parser SaplingAST
parseLambdaExpression :: Parser TricuAST
parseLambdaExpression = choice
[ try parseLambdaApplication
, parseAtomicLambda
]
parseAtomicLambda :: Parser SaplingAST
parseAtomicLambda :: Parser TricuAST
parseAtomicLambda = choice
[ parseVar
, parseTreeLeaf
@ -97,32 +97,32 @@ parseAtomicLambda = choice
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
parseApplication :: Parser SaplingAST
parseApplication :: Parser TricuAST
parseApplication = do
func <- parseAtomicBase
args <- many parseAtomic
return $ foldl (\acc arg -> SApp acc arg) func args
parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication :: Parser TricuAST
parseLambdaApplication = do
func <- parseAtomicLambda
args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool
isTreeTerm :: TricuAST -> Bool
isTreeTerm TLeaf = True
isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True
isTreeTerm _ = False
parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf :: Parser TricuAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name
getIdentifier _ = error "Expected identifier"
parseTreeTerm :: Parser SaplingAST
parseTreeTerm :: Parser TricuAST
parseTreeTerm = do
base <- parseTreeLeafOrParenthesized
rest <- many parseTreeLeafOrParenthesized
@ -133,18 +133,18 @@ parseTreeTerm = do
TStem t -> TFork t next
TFork _ _ -> TFork acc next
parseTreeLeafOrParenthesized :: Parser SaplingAST
parseTreeLeafOrParenthesized :: Parser TricuAST
parseTreeLeafOrParenthesized = choice
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
, parseTreeLeaf
]
foldTree :: [SaplingAST] -> SaplingAST
foldTree :: [TricuAST] -> TricuAST
foldTree [] = TLeaf
foldTree [x] = x
foldTree (x:y:rest) = TFork x (foldTree (y:rest))
parseAtomic :: Parser SaplingAST
parseAtomic :: Parser TricuAST
parseAtomic = choice
[ parseVar
, parseTreeLeaf
@ -153,44 +153,44 @@ parseAtomic = choice
, parseLiteral
]
parseGrouped :: Parser SaplingAST
parseGrouped :: Parser TricuAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
parseLiteral :: Parser SaplingAST
parseLiteral :: Parser TricuAST
parseLiteral = choice
[ parseIntLiteral
, parseStrLiteral
]
parens :: Parser SaplingAST -> Parser SaplingAST
parens :: Parser TricuAST -> Parser TricuAST
parens p = do
satisfy (== LOpenParen)
result <- p
satisfy (== LCloseParen)
return result
parseListLiteral :: Parser SaplingAST
parseListLiteral :: Parser TricuAST
parseListLiteral = do
satisfy (== LOpenBracket)
elements <- many parseListItem
satisfy (== LCloseBracket)
return (SList elements)
parseListItem :: Parser SaplingAST
parseListItem :: Parser TricuAST
parseListItem = choice
[ parseGroupedItem
, parseListLiteral
, parseSingleItem
]
parseGroupedItem :: Parser SaplingAST
parseGroupedItem :: Parser TricuAST
parseGroupedItem = do
satisfy (== LOpenParen)
inner <- parseExpression
satisfy (== LCloseParen)
return inner
parseSingleItem :: Parser SaplingAST
parseSingleItem :: Parser TricuAST
parseSingleItem = do
token <- satisfy isListItem
case token of
@ -203,19 +203,19 @@ isListItem (LIdentifier _) = True
isListItem LKeywordT = True
isListItem _ = False
parseVar :: Parser SaplingAST
parseVar :: Parser TricuAST
parseVar = do
LIdentifier name <- satisfy isIdentifier
if (name == "t" || name == "__result")
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
else return (SVar name)
parseIntLiteral :: Parser SaplingAST
parseIntLiteral :: Parser TricuAST
parseIntLiteral = do
LIntegerLiteral value <- satisfy isIntegerLiteral
return (SInt value)
parseStrLiteral :: Parser SaplingAST
parseStrLiteral :: Parser TricuAST
parseStrLiteral = do
LStringLiteral value <- satisfy isStringLiteral
return (SStr value)

4
src/REPL.hs
View File

@ -15,7 +15,7 @@ repl env = runInputT defaultSettings (loop env)
where
loop :: Map.Map String T -> InputT IO ()
loop env = do
minput <- getInputLine "sapling < "
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Goodbye!"
Just ":_exit" -> outputStrLn "Goodbye!"
@ -27,7 +27,7 @@ repl env = runInputT defaultSettings (loop env)
newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of
Just r -> do
outputStrLn $ "sapling > " ++ show r
outputStrLn $ "tricu > " ++ show r
outputStrLn $ "DECODE -: " ++ decodeResult r
Nothing -> return ()
loop newEnv

90
test/Spec.hs
View File

@ -17,11 +17,11 @@ import qualified Data.Set as Set
main :: IO ()
main = defaultMain tests
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
runTricu :: String -> String
runTricu s = show $ result (evalTricu Map.empty $ parseTricu s)
tests :: TestTree
tests = testGroup "Sapling Tests"
tests = testGroup "Tricu Tests"
[ lexerTests
, parserTests
, integrationTests
@ -35,32 +35,32 @@ lexerTests = testGroup "Lexer Tests"
[ testCase "Lex simple identifiers" $ do
let input = "x a b = a"
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
runParser saplingLexer "" input @?= expect
runParser tricuLexer "" input @?= expect
, testCase "Lex Tree Calculus terms" $ do
let input = "t t t"
expect = Right [LKeywordT, LKeywordT, LKeywordT]
runParser saplingLexer "" input @?= expect
runParser tricuLexer "" input @?= expect
, testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\""
expect = Right [LStringLiteral "hello\\nworld"]
runParser saplingLexer "" input @?= expect
runParser tricuLexer "" input @?= expect
, testCase "Lex mixed literals" $ do
let input = "t \"string\" 42"
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
runParser saplingLexer "" input @?= expect
runParser tricuLexer "" input @?= expect
, testCase "Lex invalid token" $ do
let input = "$invalid"
case runParser saplingLexer "" input of
case runParser tricuLexer "" input of
Left _ -> return ()
Right _ -> assertFailure "Expected lexer to fail on invalid token"
, testCase "Drop trailing whitespace in definitions" $ do
let input = "x = 5 "
expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
case (runParser saplingLexer "" input) of
case (runParser tricuLexer "" input) of
Left _ -> assertFailure "Failed to lex input"
Right i -> i @?= expect
, testCase "Error when using invalid characters in identifiers" $ do
case (runParser saplingLexer "" "__result = 5") of
case (runParser tricuLexer "" "__result = 5") of
Left _ -> return ()
Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
]
@ -68,12 +68,12 @@ lexerTests = testGroup "Lexer Tests"
parserTests :: TestTree
parserTests = testGroup "Parser Tests"
[ --testCase "Error when parsing incomplete definitions" $ do
-- let input = lexSapling "x = "
-- let input = lexTricu "x = "
-- case (runParser parseExpression "" input) of
-- Left _ -> return ()
-- Right _ -> assertFailure "Expected failure on invalid input"
testCase "Error when assigning a value to T" $ do
let input = lexSapling "t = x"
let input = lexTricu "t = x"
case (runParser parseExpression "" input) of
Left _ -> return ()
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
@ -142,7 +142,7 @@ parserTests = testGroup "Parser Tests"
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\nx (t)"
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
parseSapling input @?= expect
parseTricu input @?= expect
]
integrationTests :: TestTree
@ -182,16 +182,16 @@ evaluationTests = testGroup "Evaluation Tests"
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Environment updates with definitions" $ do
let input = "x = t\ny = x"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
Map.lookup "x" env @?= Just Leaf
Map.lookup "y" env @?= Just Leaf
, testCase "Variable substitution" $ do
let input = "x = t t\ny = t x\ny"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
(result env) @?= Stem (Stem Leaf)
, testCase "Multiline input evaluation" $ do
let input = "x = t\ny = t t\nx"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
(result env) @?= Leaf
, testCase "Evaluate string literal" $ do
let input = "\"hello\""
@ -211,40 +211,40 @@ evaluationTests = testGroup "Evaluation Tests"
\ z = y\n \
\ variablewithamuchlongername = z\n \
\ variablewithamuchlongername"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
(result env) @?= (Stem (Stem Leaf))
, testCase "Evaluate variable shadowing" $ do
let input = "x = t t\nx = t\nx"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
(result env) @?= Leaf
, testCase "Apply identity to Boolean Not" $ do
let not = "(t (t (t t) (t t t)) t)"
let input = "x = (\\a : a)\nx " ++ not
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
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"
env = evalSapling Map.empty (parseSapling input)
env = evalTricu Map.empty (parseTricu input)
result env @?= Stem Leaf
, testCase "Boolean AND_ TF" $ do
let input = "and (t t) (t)"
env = evalSapling library (parseSapling input)
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND_ FT" $ do
let input = "and (t) (t t)"
env = evalSapling library (parseSapling input)
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND_ FF" $ do
let input = "and (t) (t)"
env = evalSapling library (parseSapling input)
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND_ TT" $ do
let input = "and (t t) (t t)"
env = evalSapling library (parseSapling input)
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Verifying Equality" $ do
let input = "equal (t t t) (t t t)"
env = evalSapling library (parseSapling input)
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
]
@ -252,67 +252,67 @@ lambdaEvalTests :: TestTree
lambdaEvalTests = testGroup "Lambda Evaluation Tests"
[ testCase "Lambda Identity Function" $ do
let input = "id = (\\x : x)\nid t"
runSapling input @?= "Leaf"
runTricu input @?= "Leaf"
, testCase "Lambda Constant Function (K combinator)" $ do
let input = "k = (\\x y : x)\nk t (t t)"
runSapling input @?= "Leaf"
runTricu input @?= "Leaf"
, testCase "Lambda Application with Variable" $ do
let input = "id = (\\x : x)\nval = t t\nid val"
runSapling input @?= "Stem Leaf"
runTricu 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"
runTricu 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"
runTricu input @?= "Leaf"
, testCase "Lambda with a complex body" $ do
let input = "f = (\\x : t (t x))\nf t"
runSapling input @?= "Stem (Stem Leaf)"
runTricu 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"
runTricu input @?= "Leaf"
, testCase "Lambda with Shadowing" $ do
let input = "f = (\\x : (\\x : x))\nf t (t t)"
runSapling input @?= "Stem Leaf"
runTricu 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"
runTricu input @?= "Leaf"
, testCase "Lambda with free variables" $ do
let input = "y = t t\nf = (\\x : y)\nf t"
runSapling input @?= "Stem Leaf"
runTricu 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)"
runTricu 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"
runTricu 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))"
runTricu 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)"
runTricu 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"
runTricu 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"
runTricu 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))))"
runTricu 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)))))"
runTricu 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)"
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
]
propertyTests :: TestTree
propertyTests = testGroup "Property Tests"
[ testProperty "Lexing and parsing round-trip" $ \input ->
case runParser saplingLexer "" input of
case runParser tricuLexer "" input of
Left _ -> property True
Right tokens -> case runParser parseExpression "" tokens of
Left _ -> property True

6
sapling.cabal → tricu.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
name: sapling
name: tricu
version: 0.4.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
@ -12,7 +12,7 @@ build-type: Simple
extra-source-files:
README.md
executable sapling
executable tricu
main-is: Main.hs
hs-source-dirs:
src
@ -41,7 +41,7 @@ executable sapling
Research
default-language: Haskell2010
test-suite sapling-tests
test-suite tricu-tests
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test, src