30 Commits

Author SHA1 Message Date
a3282b794f 0.5.0 release commit 2025-01-06 09:14:04 -06:00
7b9a62462c Level Order Traversal demo 2025-01-03 12:00:06 -06:00
3eb28a2c62 Drop parseVarWithoutAssignment
Additionally sorts gitignore and adds attempted decoding of lists back
to the REPL
2025-01-03 10:31:35 -06:00
8c33e5ce66 Fix critical list evaluation bug and REPL updates 2025-01-02 19:08:14 -06:00
76487b15f9 Use better default output form in evaluator 2025-01-01 19:40:12 -06:00
18ff2d2e04 Clarify CLI options 2025-01-01 19:32:41 -06:00
fff29199d1 Support evaluation across multiple source files 2025-01-01 19:27:04 -06:00
a2c459b148 Provide "library" via tricu file directly
Allows easier loading of other files and drops the list of Haskell
strings containing the basic tools included
2025-01-01 18:53:56 -06:00
39be66a4d1 Fixes identifier lexing; support REPL file loading 2025-01-01 18:05:21 -06:00
bf58c9afbd Normalize CLI options and help display 2025-01-01 08:34:17 -06:00
7d38d99dcd Rename "compiler" functionality to Evaluator
Allows for stdin input for evaluation when no input file is provided.
2025-01-01 08:23:53 -06:00
458d3c3b10 Latest --help in README 2024-12-31 10:09:36 -06:00
0048fed6b4 Merge pull request 'Add "SimpleT" t output form' (#9) from feat/new-outputs into main
Reviewed-on: #9
2024-12-31 16:05:38 +00:00
476c3912a4 Merge branch 'main' into feat/new-outputs 2024-12-31 16:04:32 +00:00
493ef51a6a Add "SimpleT" t output form
This new output form allows easy piping to the decode function of the
tricu executable. Includes a new test for roundtrip evaluation of map,
compilation to tree calculus terms, and decoding back to a human
readable string.
2024-12-31 10:00:52 -06:00
e22ff06bfe Merge pull request 'Expands CLI support with output forms and decoding' (#7) from feat/ternary-representation into main
Reviewed-on: #7
2024-12-30 20:24:27 +00:00
5e2a4dff50 Expands CLI support with output forms and decoding
Adds CLI options for compiling to a Tree Calculus, AST, Ternary, and
ASCII tree view. Adds CLI command for attempted decoding of a compiled
result to Number/String/List.
2024-12-30 14:22:37 -06:00
8622af9ad2 Initial ternary representation options
Both parsing and conversion from T to ternary representation supported
2024-12-30 08:30:40 -06:00
fe70aa72ac Merge pull request 'Adds "compiler" and CLI argument handling' (#3) from feature/compiler-CLI into main
Reviewed-on: #3
2024-12-30 03:51:59 +00:00
2abeab9c04 Adds "compiler" and CLI argument handling 2024-12-29 21:49:57 -06:00
467e11edb3 Updates to tests
Uncomments a test for comment parsing behavior and removes a test for
incomplete function definitions.
2024-12-29 21:09:02 -06:00
38509724b1 Merge pull request 'Resolves issue with parsing comments' (#2) from fix/comments-0001 into main
Reviewed-on: #2
2024-12-30 03:03:39 +00:00
a8f72290a2 Resolves issue with parsing comments 2024-12-29 21:02:38 -06:00
b86ff6e9b8 Additional tests 2024-12-29 12:22:24 -06:00
a7674d4635 README updates for run/build 2024-12-29 10:41:04 -06:00
14fdb741dc README clarifications 2024-12-29 10:37:37 -06:00
60a9e3c1ee Expansion of testing suite to cover incl. library
Expands the testing suite to verify behavior of provided library
functions. Updates the README further for clarification on important
concepts.
2024-12-29 10:28:32 -06:00
c30f17367f Rename from sapling to tricu 2024-12-29 08:29:25 -06:00
064bed26c5 Further README clarification 2024-12-28 22:20:43 -06:00
ff2952010f README updates 2024-12-28 21:58:52 -06:00
22 changed files with 780 additions and 444 deletions

17
.gitignore vendored
View File

@ -1,14 +1,11 @@
bin/
data/Purr.sqlite
data/encryptionKey
/result
/config.dhall
/Dockerfile
/docker-stack.yml
.stack-work/
*.swp
dist*
*.txt
*~
.env
.stack-work/
/Dockerfile
/config.dhall
/result
WD
*.hs.txt
bin/
dist*

View File

@ -1,54 +1,82 @@
# sapling
# tricu
## 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) .
tricu (pronounced like "tree-shoe" in English) is a purely functional interpreted language implemented in Haskell. [I'm](https://eversole.co) developing tricu to further research the possibilities offered by the various forms of [Tree Calculi](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf).
It offers a minimal amount of syntax sugar:
tricu offers minimal syntax sugar yet manages to provide a complete, intuitive, and familiar programming environment. There is great power in simplicity. tricu offers:
- `t` operator behaving by the rules of Tree Calculus
- Function ("variable") definitions
- Lambda abstractions
- List, Number, and String literals (WIP)
1. `t` operator behaving by the rules of Tree Calculus
1. Function definitions/assignments
1. Lambda abstractions eliminated to Tree Calculus forms
1. List, Number, and String literals
1. Parentheses for grouping function application
This is an active experimentation project by [someone who has no idea what they're doing](https://eversole.co).
These features move us cleanly out of the [turing tarpit](https://en.wikipedia.org/wiki/Turing_tarpit) territory that you may find yourself in if you try working only with the `t` operator.
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`. This project was named "sapling" until I discovered the name is already being used for other (completely unrelated) programming language development projects.
## 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")
tricu < -- Anything after `--` on a single line is a comment
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
tricu < head (map (\i : lconcat i " world!") [("Hello, ")])
tricu > "Hello, world!"
tricu < id (head (map (\i : lconcat i " world!") [("Hello, ")]))
tricu > "Hello, world!"
-- 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!"]
tricu < -- Intensionality! We can inspect the structure of a function.
tricu < triage = (\a b c : t (t a b) c)
tricu < test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
tricu < test t t
tricu > "Stem"
tricu < -- We can even write a function to convert a function to source code
tricu < toTString id
tricu > "t (t (t t)) t"
```
## How to use
## Installation and Use
For now, you can easily build and run this project using Nix:
You can easily build and/or run this project using [Nix](https://nixos.org/download/).
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`
- Quick Start (REPL):
- `nix run git+https://git.eversole.co/James/tricu`
- Build executable in `./result/bin`:
- `nix build git+https://git.eversole.co/James/tricu`
`./result/bin/tricu --help`
```
tricu Evaluator and REPL
tricu [COMMAND] ... [OPTIONS]
tricu: Exploring Tree Calculus
Common flags:
-? --help Display help message
-V --version Print version information
tricu [repl] [OPTIONS]
Start interactive REPL
tricu eval [OPTIONS]
Evaluate tricu and return the result of the final expression.
-f --file=FILE Input file path(s) for evaluation.
Defaults to stdin.
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii).
Defaults to tricu-compatible `t` tree form.
tricu decode [OPTIONS]
Decode a Tree Calculus value into a string representation.
-f --file=FILE Optional input file path to attempt decoding.
Defaults to stdin.
```
## 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.

View File

@ -0,0 +1,34 @@
-- Level Order Traversal of a labelled binary tree
-- Objective: Print each "level" of the tree on a separate line
--
-- NOTICE: This demo relies on tricu base library functions
--
-- We model labelled binary trees as sublists where values act as labels. We
-- require explicit notation of empty nodes. Empty nodes can be represented
-- with an empty list, `[]`, which is equivalent to a single node `t`.
--
-- Example tree inputs:
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
-- Graph:
-- 1
-- / \
-- 2 3
-- / / \
-- 4 5 6
--
isLeaf = (\node : lOr (emptyList node) (emptyList (tail node)))
getLabel = (\node : head node)
getLeft = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (head (tail node))))
getRight = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (if (emptyList (tail (tail node))) [] (head (tail (tail node))))))
processLevel = y (\self queue : if (emptyList queue) [] (pair (map getLabel queue) (self (filter (\node : not (emptyList node)) (lconcat (map getLeft queue) (map getRight queue))))))
levelOrderTraversal = (\a : processLevel (t a t))
toLineString = y (\self levels : if (emptyList levels) "" (lconcat (lconcat (map (\x : lconcat x " ") (head levels)) "") (if (emptyList (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
levelOrderToString = (\s : toLineString (levelOrderTraversal s))
flatten = foldl (\acc x : lconcat acc x) ""
flatLOT = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
exampleOne = flatLOT [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
exampleTwo = flatLOT [("1") [("2") [("4") [("8") t t] [("9") t t]] [("6") [("10") t t] [("12") t t]]] [("3") [("5") [("11") t t] t] [("7") t t]]]

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} =

41
lib/base.tri Normal file
View File

@ -0,0 +1,41 @@
false = t
_ = t
true = 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)
not = matchBool false true
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)
head = matchList t (\hd tl : hd)
tail = matchList t (\hd tl : tl)
lconcat = 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))))
hfilter = y (\self : matchList (\f : t) (\hd tl f : matchBool (t hd) i (f hd) (self tl f)))
filter = (\f l : hfilter l f)
hfoldl = y (\self f l x : matchList (\acc : acc) (\hd tl acc : self f tl (f acc hd)) l x)
foldl = (\f x l : hfoldl f l x)
hfoldr = y (\self x f l : matchList x (\hd tl : f (self x f tl) hd) l)
foldr = (\f x l : hfoldr x f l)

View File

@ -1,8 +0,0 @@
{ pkgs ? import <nixpkgs> {} }:
let x = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
in
pkgs.mkShell {
buildInputs = [ x ];
}

View File

@ -3,17 +3,17 @@ module Eval where
import Parser
import Research
import Data.Map (Map)
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 :: Map String T -> TricuAST -> Map String T
evalSingle env term = case term of
SFunc name [] body ->
let lineNoLambda = eliminateLambda body
result = evalAST env lineNoLambda
in Map.insert name result env
in Map.insert "__result" result (Map.insert name result env)
SLambda _ body ->
let result = evalAST env body
in Map.insert "__result" result env
@ -23,40 +23,43 @@ evalSingle env term = case term of
SVar name ->
case Map.lookup name env of
Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined"
Nothing -> errorWithoutStackTrace $ "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] =
evalTricu :: Map String T -> [TricuAST] -> Map String T
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
where
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
Nothing -> error $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf
TStem t -> Stem (evalAST env t)
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
SStr str -> ofString str
SInt num -> ofNumber num
SList elems -> ofList (map (evalAST Map.empty) elems)
SFunc name args body ->
error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle."
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
SVar name -> case Map.lookup name env of
Just value -> value
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf
TStem t -> Stem (evalAST env t)
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
SStr str -> ofString str
SInt num -> ofNumber num
SList elems -> ofList (map (evalAST env) elems)
SEmpty -> Leaf
SFunc name args body ->
errorWithoutStackTrace $ "Unexpected function definition " ++ name
SLambda {} -> errorWithoutStackTrace "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))
@ -66,10 +69,9 @@ eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
eliminateLambda (SList xs) = SList (map eliminateLambda xs)
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
-- Chapter 4: Lambda-Abstraction
lambdaToT :: String -> TricuAST -> TricuAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
@ -83,7 +85,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,26 +97,21 @@ 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 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
result r = case Map.lookup "__result" r of
Just a -> a
Nothing -> error "No __result field found in provided environment"
Just a -> a
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"

30
src/FileEval.hs Normal file
View File

@ -0,0 +1,30 @@
module FileEval where
import Eval
import Parser
import Research
import System.IO
import qualified Data.Map as Map
evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do
contents <- readFile filePath
let asts = parseTricu contents
let finalEnv = evalTricu Map.empty asts
case Map.lookup "__result" finalEnv of
Just finalResult -> return finalResult
Nothing -> errorWithoutStackTrace "No expressions to evaluate found"
evaluateFile :: FilePath -> IO Env
evaluateFile filePath = do
contents <- readFile filePath
let asts = parseTricu contents
pure $ evalTricu Map.empty asts
evaluateFileWithContext :: Env -> FilePath -> IO Env
evaluateFileWithContext env filePath = do
contents <- readFile filePath
let asts = parseTricu contents
pure $ evalTricu env asts

View File

@ -1,37 +1,25 @@
module Lexer where
import Research
import Text.Megaparsec
import Text.Megaparsec.Char
import Control.Monad (void)
import Control.Monad (void)
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char hiding (space)
import Text.Megaparsec.Char.Lexer
import qualified Data.Set as Set
type Lexer = Parsec Void String
data LToken
= LKeywordT
| LIdentifier String
| LIntegerLiteral Int
| LStringLiteral String
| LAssign
| LColon
| LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
| LCloseBracket
| LNewline
| LComment String
deriving (Show, Eq, Ord)
keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
identifier :: Lexer LToken
identifier = do
name <- some (letterChar <|> char '_' <|> char '-')
first <- letterChar <|> char '_'
rest <- many (letterChar <|> char '_' <|> char '-' <|> digitChar)
let name = first : rest
if (name == "t" || name == "__result")
then fail "Keywords (`t`, `__result`) cannot be used as an identifier"
else return (LIdentifier name)
@ -45,11 +33,8 @@ stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- many (noneOf ['"'])
if null content
then fail "Empty string literals are not allowed"
else do
char '"' --"
return (LStringLiteral content)
char '"' --"
return (LStringLiteral content)
assign :: Lexer LToken
assign = char '=' *> pure LAssign
@ -75,34 +60,35 @@ 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 (void (char ' ') <|> void (char '\t') <|> void comment)
sc = space space1 (skipLineComment "--") (skipBlockComment "|-" "-|")
saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice
[ try identifier
, try keywordT
, try integerLiteral
, try stringLiteral
, assign
, colon
, backslash
, openParen
, closeParen
, openBracket
, closeBracket
, lnewline
] <* sc) <* eof
tricuLexer :: Lexer [LToken]
tricuLexer = do
sc
tokens <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
pure tokens
where
tricuLexer' =
[ try identifier
, try keywordT
, try integerLiteral
, try stringLiteral
, assign
, colon
, backslash
, openParen
, closeParen
, openBracket
, closeBracket
]
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

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))))"
]

View File

@ -1,22 +1,84 @@
module Main where
import Eval
import Lexer
import Library
import Parser
import REPL (repl)
import Eval (evalTricu, result)
import FileEval
import Parser (parseTricu)
import REPL
import Research
import Control.Monad (foldM)
import Control.Monad.IO.Class (liftIO)
import Text.Megaparsec (runParser)
import System.Console.CmdArgs
import qualified Data.Map as Map
import Text.Megaparsec (runParser)
data TricuArgs
= Repl
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
| Decode { file :: [FilePath] }
deriving (Show, Data, Typeable)
replMode :: TricuArgs
replMode = Repl
&= help "Start interactive REPL"
&= auto
&= name "repl"
evaluateMode :: TricuArgs
evaluateMode = Evaluate
{ file = def &= help "Input file path(s) for evaluation.\n \
\ Defaults to stdin."
&= name "f" &= typ "FILE"
, form = TreeCalculus &= typ "FORM"
&= help "Optional output form: (tree|fsl|ast|ternary|ascii).\n \
\ Defaults to tricu-compatible `t` tree form."
&= name "t"
}
&= help "Evaluate tricu and return the result of the final expression."
&= explicit
&= name "eval"
decodeMode :: TricuArgs
decodeMode = Decode
{ file = def
&= help "Optional input file path to attempt decoding.\n \
\ Defaults to stdin."
&= name "f" &= typ "FILE"
}
&= help "Decode a Tree Calculus value into a string representation."
&= explicit
&= name "decode"
main :: IO ()
main = do
putStrLn "Welcome to the Sapling Interpreter"
putStrLn "You can exit at any time by typing and entering: "
putStrLn ":_exit"
repl library
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary "tricu Evaluator and REPL"
case args of
Repl -> do
putStrLn "Welcome to the tricu REPL"
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`"
library <- liftIO $ evaluateFile "./lib/base.tri"
repl $ Map.delete "__result" library
Evaluate { file = filePaths, form = form } -> do
result <- case filePaths of
[] -> do
t <- getContents
pure $ runTricu t
(filePath:restFilePaths) -> do
initialEnv <- evaluateFile filePath
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
pure $ result finalEnv
let fRes = formatResult form result
putStr fRes
Decode { file = filePaths } -> do
value <- case filePaths of
[] -> getContents
(filePath:_) -> readFile filePath
library <- liftIO $ evaluateFile "./lib/base.tri"
putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value
runSapling :: String -> T
runSapling s = result (evalSapling Map.empty $ parseSapling s)
runSaplingEnv env s = result (evalSapling env $ parseSapling s)
runTricu :: String -> T
runTricu = result . evalTricu Map.empty . parseTricu

View File

@ -1,45 +1,36 @@
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
import Data.Void
import Research hiding (toList)
import Data.List.NonEmpty (toList)
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
type Parser = Parsec Void [LToken]
import qualified Data.Set as Set
data SaplingAST
= SVar String
| SInt Int
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST
| TLeaf
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
deriving (Show, Eq, Ord)
type Parser = Parsec Void [LToken]
type AltParser = Parsec Void String
parseSapling :: String -> [SaplingAST]
parseSapling input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSingle nonEmptyLines
parseTricu :: String -> [TricuAST]
parseTricu input
| null tokens = []
| otherwise = map parseSingle tokens
where
tokens = case lexTricu input of
[] -> []
tokens -> lines input
parseSingle :: String -> SaplingAST
parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err
Right ast -> ast
parseSingle :: String -> TricuAST
parseSingle input = case lexTricu input of
[] -> SEmpty
tokens -> case runParser parseExpression "" tokens 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 +41,10 @@ parseExpression = choice
, parseLiteral
]
parseFunction :: Parser SaplingAST
scnParser :: Parser ()
scnParser = skipMany (satisfy isNewline)
parseFunction :: Parser TricuAST
parseFunction = do
LIdentifier name <- satisfy isIdentifier
args <- many (satisfy isIdentifier)
@ -58,20 +52,13 @@ parseFunction = do
body <- parseExpression
return (SFunc name (map getIdentifier args) body)
parseAtomicBase :: Parser SaplingAST
parseAtomicBase :: Parser TricuAST
parseAtomicBase = choice
[ try parseVarWithoutAssignment
, parseTreeLeaf
[ 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 TricuAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
param <- satisfy isIdentifier
@ -81,13 +68,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 +84,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 +120,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 +140,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 +190,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)
@ -235,6 +222,42 @@ isLiteral _ = False
isNewline (LNewline) = True
isNewline _ = False
-- Alternative parsers
altSC :: AltParser ()
altSC = skipMany (char ' ' <|> char '\t' <|> char '\n')
parseTernaryTerm :: AltParser TricuAST
parseTernaryTerm = do
altSC
term <- choice parseTernaryTerm'
altSC
pure term
where
parseTernaryTerm' =
[ try (between (char '(') (char ')') parseTernaryTerm)
, try parseTernaryLeaf
, try parseTernaryStem
, try parseTernaryFork
]
parseTernaryLeaf :: AltParser TricuAST
parseTernaryLeaf = char '0' *> pure TLeaf
parseTernaryStem :: AltParser TricuAST
parseTernaryStem = char '1' *> (TStem <$> parseTernaryTerm)
parseTernaryFork :: AltParser TricuAST
parseTernaryFork = do
char '2'
term1 <- parseTernaryTerm
term2 <- parseTernaryTerm
pure $ TFork term1 term2
parseTernary :: String -> Either String TricuAST
parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
Left err -> Left (errorBundlePretty err)
Right ast -> Right ast
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle =
@ -252,4 +275,3 @@ showError (FancyError offset fancy) =
showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of "
++ show (Set.toList expected)

View File

@ -1,36 +1,65 @@
module REPL where
import Eval
import FileEval
import Lexer
import Parser
import Research
import Data.List (intercalate)
import qualified Data.Map as Map
import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isSpace)
import Data.List (dropWhile, dropWhileEnd, intercalate)
import System.Console.Haskeline
import System.IO (hFlush, stdout)
repl :: Map.Map String T -> IO ()
import qualified Data.Map as Map
repl :: Env -> IO ()
repl env = runInputT defaultSettings (loop env)
where
loop :: Map.Map String T -> InputT IO ()
loop :: Env -> InputT IO ()
loop env = do
minput <- getInputLine "sapling < "
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Goodbye!"
Just ":_exit" -> outputStrLn "Goodbye!"
Just "" -> do
outputStrLn ""
loop env
Just input -> do
let clearEnv = Map.delete "__result" env
newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of
Just r -> do
outputStrLn $ "sapling > " ++ show r
outputStrLn $ "DECODE -: " ++ decodeResult r
Nothing -> return ()
loop newEnv
Nothing -> outputStrLn "Exiting tricu"
Just s -> case strip s of
"!exit" -> outputStrLn "Exiting tricu"
"!load" -> do
path <- getInputLine "File path to load < "
case path of
Nothing -> do
outputStrLn "No input received; stopping import."
loop env
Just path -> do
loadedEnv <- liftIO $ evaluateFileWithContext env (strip path)
loop $ Map.delete "__result" (Map.union loadedEnv env)
"" -> do
outputStrLn ""
loop env
input -> do
case (take 2 input) of
"--" -> loop env
_ -> do
newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
loop newEnv
processInput :: Env -> String -> IO Env
processInput env input = do
let asts = parseTricu input
newEnv = evalTricu env asts
case Map.lookup "__result" newEnv of
Just r -> do
putStrLn $ "tricu > " ++ decodeResult r
Nothing -> return ()
return newEnv
errorHandler :: Env -> SomeException -> IO (Env)
errorHandler env e = do
putStrLn $ "Error: " ++ show e
return env
strip :: String -> String
strip = dropWhileEnd isSpace . dropWhile isSpace
decodeResult :: T -> String
decodeResult tc = case toNumber tc of
@ -39,4 +68,4 @@ decodeResult tc = case toNumber tc of
Right str -> "\"" ++ str ++ "\""
Left _ -> case toList tc of
Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
Left _ -> ""
Left _ -> formatResult TreeCalculus tc

View File

@ -1,13 +1,57 @@
module Research where
import Data.List (intercalate)
import Control.Monad.State
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Text (Text, replace)
import System.Console.CmdArgs (Data, Typeable)
import qualified Data.Map as Map
import qualified Data.Text as T
-- Tree Calculus Types
data T = Leaf | Stem T | Fork T T
deriving (Show, Eq, Ord)
-- Abstract Syntax Tree for tricu
data TricuAST
= SVar String
| SInt Int
| SStr String
| SList [TricuAST]
| SFunc String [String] TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
| SEmpty
deriving (Show, Eq, Ord)
-- Tokens from Lexer
data LToken
= LKeywordT
| LIdentifier String
| LIntegerLiteral Int
| LStringLiteral String
| LAssign
| LColon
| LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
| LCloseBracket
| LNewline
deriving (Show, Eq, Ord)
-- Output formats
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii
deriving (Show, Data, Typeable)
-- Environment containing previously evaluated TC terms
type Env = Map.Map String T
-- Tree Calculus Reduction
apply :: T -> T -> T
apply Leaf b = Stem b
apply (Stem a) b = Fork a b
@ -17,16 +61,6 @@ apply (Fork (Fork a1 a2) a3) Leaf = a1
apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
reduce :: T -> T
reduce expr =
let next = step expr
in if next == expr then expr else reduce next
step :: T -> T
step (Fork left right) = reduce (apply (reduce left) (reduce right))
step (Stem inner) = Stem (reduce inner)
step t = t
-- SKI Combinators
_S :: T
_S = Fork (Stem (Fork Leaf Leaf)) Leaf
@ -36,7 +70,7 @@ _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)
-- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
_I :: T
_I = Fork (Stem (Stem Leaf)) Leaf
@ -87,7 +121,31 @@ toList (Fork x rest) = case toList rest of
Left err -> Left err
toList _ = Left "Invalid Tree Calculus list"
-- Utility
-- Outputs
formatResult :: EvaluatedForm -> T -> String
formatResult TreeCalculus = toSimpleT . show
formatResult FSL = show
formatResult AST = show . toAST
formatResult Ternary = toTernaryString
formatResult Ascii = toAscii
toSimpleT :: String -> String
toSimpleT s = T.unpack
$ replace "Fork" "t"
$ replace "Stem" "t"
$ replace "Leaf" "t"
$ (T.pack s)
toTernaryString :: T -> String
toTernaryString Leaf = "0"
toTernaryString (Stem t) = "1" ++ toTernaryString t
toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2
toAST :: T -> TricuAST
toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
toAscii :: T -> String
toAscii tree = go tree "" True
where
@ -102,41 +160,4 @@ toAscii tree = go tree "" True
++ go left (prefix ++ (if isLast then " " else "| ")) False
++ go right (prefix ++ (if isLast then " " else "| ")) True
rules :: IO ()
rules = putStr $ header
++ (unlines $ tcRules)
++ (unlines $ haskellRules)
++ footer
where
tcRules :: [String]
tcRules =
[ "| |"
, "| ┌--------- | Tree Calculus | ---------┐ |"
, "| | 1. t t a b -> a | |"
, "| | 2. t (t a) b c -> a c (b c)| |"
, "| | 3a. t (t a b) c t -> a | |"
, "| | 3b. t (t a b) c (t u) -> b u | |"
, "| | 3c. t (t a b) c (t u v) -> c u v | |"
, "| └-------------------------------------┘ |"
, "| |"
]
haskellRules :: [String]
haskellRules =
[ "| ┌------------------------------ | Haskell | --------------------------------┐ |"
, "| | | |"
, "| | data T = Leaf | Stem T | Fork TT | |"
, "| | | |"
, "| | apply :: T -> T -> T | |"
, "| | apply Leaf b = Stem b | |"
, "| | apply (Stem a) b = Fork a b | |"
, "| | apply (Fork Leaf a) _ = a | |"
, "| | apply (Fork (Stem a1) a2) b = apply (apply a1 b) (apply a2 b) | |"
, "| | apply (Fork (Fork a1 a2) a3) Leaf = a1 | |"
, "| | apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u | |"
, "| | apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v | |"
, "| └---------------------------------------------------------------------------┘ |"
]
header :: String
header = "┌-------------------- | Rules for evaluating Tree Calculus | -------------------┐\n"
footer :: String
footer = "└-------------------- | Rules for evaluating Tree Calculus | -------------------┘\n"
-- Utility

View File

@ -1,11 +1,14 @@
module Main where
import Eval
import FileEval
import Lexer
import Library
import Parser
import REPL
import Research
import Control.Exception (evaluate, try, SomeException)
import Control.Monad.IO.Class (liftIO)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
@ -17,16 +20,17 @@ 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
, evaluationTests
, lambdaEvalTests
, libraryTests
, fileEvaluationTests
, propertyTests
]
@ -35,45 +39,40 @@ 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
let input = "&invalid"
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"
]
parserTests :: TestTree
parserTests = testGroup "Parser Tests"
[ --testCase "Error when parsing incomplete definitions" $ do
-- let input = lexSapling "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"
[ testCase "Error when assigning a value to T" $ do
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,19 +141,19 @@ 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
]
integrationTests :: TestTree
integrationTests = testGroup "Integration Tests"
[ testCase "Combine lexer and parser" $ do
let input = "x = t t t"
expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
parseSingle input @?= expect
, testCase "Complex Tree Calculus expression" $ do
let input = "t (t t t) t"
expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
parseSingle input @?= expect
parseTricu input @?= expect
, testCase "Comments 1" $ do
let input = "(t) (t) -- (t)"
expect = [SApp TLeaf TLeaf]
parseTricu input @?= expect
, testCase "Comments 2" $ do
let input = "(t) -- (t) -- (t)"
expect = [TLeaf]
parseTricu input @?= expect
, testCase "Comments with no terms" $ do
let input = unlines ["-- (t)", "(t t)"]
expect = [SEmpty,SApp TLeaf TLeaf]
parseTricu input @?= expect
]
evaluationTests :: TestTree
@ -182,16 +181,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,108 +210,215 @@ 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
, 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)
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"
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)"
]
libraryTests :: TestTree
libraryTests = testGroup "Library Tests"
[ testCase "K combinator 1" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "K combinator 2" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "K combinator 3" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "S combinator" $ do
library <- evaluateFile "./lib/base.tri"
let input = "s (t) (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf (Stem Leaf)
, testCase "SKK == I (fully expanded)" $ do
library <- evaluateFile "./lib/base.tri"
let input = "s k k"
env = evalTricu library (parseTricu input)
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
, testCase "I combinator" $ do
library <- evaluateFile "./lib/base.tri"
let input = "i not"
env = evalTricu library (parseTricu input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork Leaf (Fork Leaf Leaf))
, testCase "Triage test Leaf" $ do
library <- evaluateFile "./lib/base.tri"
let input = "test t"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Leaf\""
, testCase "Triage test (Stem Leaf)" $ do
library <- evaluateFile "./lib/base.tri"
let input = "test (t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Stem\""
, testCase "Triage test (Fork Leaf Leaf)" $ do
library <- evaluateFile "./lib/base.tri"
let input = "test (t t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Fork\""
, testCase "Boolean NOT: true" $ do
library <- evaluateFile "./lib/base.tri"
let input = "not true"
env = result $ evalTricu library (parseTricu input)
env @?= Leaf
, testCase "Boolean NOT: false" $ do
library <- evaluateFile "./lib/base.tri"
let input = "not false"
env = result $ evalTricu library (parseTricu input)
env @?= Stem Leaf
, testCase "Boolean AND TF" $ do
library <- evaluateFile "./lib/base.tri"
let input = "and (t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FT" $ do
library <- evaluateFile "./lib/base.tri"
let input = "and (t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FF" $ do
library <- evaluateFile "./lib/base.tri"
let input = "and (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND TT" $ do
library <- evaluateFile "./lib/base.tri"
let input = "and (t t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "List head" $ do
library <- evaluateFile "./lib/base.tri"
let input = "head [(t) (t t) (t t t)]"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "List tail" $ do
library <- evaluateFile "./lib/base.tri"
let input = "head (tail (tail [(t) (t t) (t t t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "List map" $ do
library <- evaluateFile "./lib/base.tri"
let input = "head (tail (map (\\a : (t t t)) [(t) (t) (t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "Empty list check" $ do
library <- evaluateFile "./lib/base.tri"
let input = "emptyList []"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Non-empty list check" $ do
library <- evaluateFile "./lib/base.tri"
let input = "not (emptyList [(1) (2) (3)])"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Concatenate strings" $ do
library <- evaluateFile "./lib/base.tri"
let input = "lconcat \"Hello, \" \"world!\""
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Hello, world!\""
, testCase "Verifying Equality" $ do
library <- evaluateFile "./lib/base.tri"
let input = "equal (t t t) (t t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
]
fileEvaluationTests :: TestTree
fileEvaluationTests = testGroup "Evaluation tests"
[ testCase "Forks" $ do
res <- liftIO $ evaluateFileResult "./test/fork.tri"
res @?= Fork Leaf Leaf
, testCase "File ends with comment" $ do
res <- liftIO $ evaluateFileResult "./test/comments-1.tri"
res @?= Fork (Stem Leaf) Leaf
, testCase "Mapping and Equality" $ do
res <- liftIO $ evaluateFileResult "./test/map.tri"
res @?= Stem Leaf
, testCase "Eval and decoding string" $ do
library <- liftIO $ evaluateFile "./lib/base.tri"
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
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

1
test/ascii.tri Normal file
View File

@ -0,0 +1 @@
t (t (t (t (t t) (t t t)) t) t t) t

1
test/assignment.tri Normal file
View File

@ -0,0 +1 @@
x = t (t t) t

9
test/comments-1.tri Normal file
View File

@ -0,0 +1,9 @@
-- This is a tricu comment!
-- t (t t) (t (t t t))
-- t (t t t) (t t)
-- x = (\a : a)
t (t t) t -- Fork (Stem Leaf) Leaf
-- t t
-- x
-- x = (\a : a)
-- t

1
test/fork.tri Normal file
View File

@ -0,0 +1 @@
t t t

24
test/map.tri Normal file
View File

@ -0,0 +1,24 @@
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)
yi = (\i : b m (c b (i m)))
y = yi iC
triage = (\a b c : t (t a b) c)
pair = t
matchList = (\oe oc : triage oe _ oc)
lconcat = y (\self : matchList (\k : k) (\h r k : pair h (self r k)))
hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f)))
map = (\f l : hmap l f)
lAnd = triage (\x : false) (\_ x : x) (\_ _ x : x)
lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true)
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))))
x = map (\i : lconcat "Successfully concatenated " i) [("two strings!")]
equal x [("Successfully concatenated two strings!")]

1
test/string.tri Normal file
View File

@ -0,0 +1 @@
head (map (\i : lconcat "String " i) [("test!")])

View File

@ -1,7 +1,7 @@
cabal-version: 1.12
name: sapling
version: 0.4.0
name: tricu
version: 0.5.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
@ -12,41 +12,41 @@ build-type: Simple
extra-source-files:
README.md
executable sapling
executable tricu
main-is: Main.hs
hs-source-dirs:
src
default-extensions:
ConstraintKinds
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
DeriveDataTypeable
OverloadedStrings
ScopedTypeVariables
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
build-depends:
base >=4.7
, cmdargs
, containers
, haskeline
, megaparsec
, mtl
, text
other-modules:
Eval
FileEval
Lexer
Library
Parser
REPL
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
default-extensions:
DeriveDataTypeable
OverloadedStrings
build-depends:
base
, cmdargs
, containers
, haskeline
, megaparsec
@ -54,11 +54,12 @@ test-suite sapling-tests
, tasty
, tasty-hunit
, tasty-quickcheck
, text
default-language: Haskell2010
other-modules:
Eval
FileEval
Lexer
Library
Parser
REPL
Research