11 Commits

Author SHA1 Message Date
2e246eb1c8 Remove Nix caching that can't work due to /nix/store permissions
All checks were successful
Test, Build, and Release / test (push) Successful in 1m13s
Test, Build, and Release / build (push) Successful in 1m23s
2025-01-23 17:59:47 -06:00
ba340ae56f Update README to reflect demo
Some checks failed
Test, Build, and Release / build (push) Has been cancelled
Test, Build, and Release / test (push) Has been cancelled
2025-01-23 17:36:39 -06:00
739851c864 Minify and mark as pre-release
Some checks failed
Test, Build, and Release / test (push) Successful in 1m59s
Test, Build, and Release / build (push) Failing after 2m12s
2025-01-23 17:23:02 -06:00
8995efce15 Release 0.6.0
All checks were successful
Test, Build, and Release / test (push) Successful in 1m38s
Test, Build, and Release / build (push) Successful in 1m40s
2025-01-23 16:44:14 -06:00
03e2f6b93e Some special characters in ids; new demos
All checks were successful
Test and Build / test (push) Successful in 4m39s
Test and Build / build (push) Successful in 1m44s
Adds support for several special characters in identifiers. Adds a demo
for converting values to source code and another for checking equality.
Updates the existing demo and tests to reflect new names for functions
returning booleans.
2025-01-23 15:46:40 -06:00
419d66b4d1 All paths for caching cabal included :)
All checks were successful
Test and Build / test (push) Successful in 4m36s
Test and Build / build (push) Successful in 1m41s
2025-01-21 17:00:20 -06:00
4b98afd803 Use runner 0.1.0
All checks were successful
Test and Build / test (push) Successful in 2m52s
Test and Build / build (push) Successful in 1m42s
2025-01-21 16:49:15 -06:00
0768e11a02 Update Cabal caching path
Some checks failed
Test and Build / build (push) Has been cancelled
Test and Build / test (push) Has been cancelled
2025-01-21 16:48:29 -06:00
42fce0ae43 Drop unreachable cases of updateDepth
All checks were successful
Test and Build / test (push) Successful in 2m27s
Test and Build / build (push) Successful in 1m39s
2025-01-21 16:16:04 -06:00
51b1eb070f Add more explicit error handling for mismatched groupings 2025-01-21 16:06:10 -06:00
c2e5a8985a Inline pattern matching in Parser 2025-01-21 14:21:47 -06:00
11 changed files with 289 additions and 220 deletions

View File

@ -1,86 +1,69 @@
name: Test and Build
name: Test, Build, and Release
on:
on:
push:
branches:
- main
pull_request:
types:
- opened
- synchronize
tags:
- '*'
jobs:
test:
container:
image: docker.matri.cx/nix-runner:latest
image: docker.matri.cx/nix-runner:v0.1.0
credentials:
username: ${{ secrets.REGISTRY_USERNAME }}
password: ${{ secrets.REGISTRY_PASSWORD }}
steps:
- name: Checkout code
uses: actions/checkout@v3
- uses: actions/checkout@v3
with:
fetch-depth: 0
- name: Set up cache for Cabal
uses: actions/cache@v4
with:
path: |
~/.cabal
~/.ghc
key: cabal-${{ runner.os }}-${{ hashFiles('tricu.cabal') }}
~/.cache/cabal
~/.config/cabal
~/.local/state/cabal
key: cabal-${{ hashFiles('tricu.cabal') }}
restore-keys: |
cabal-${{ runner.os }}-
- name: Set up cache for Nix
uses: actions/cache@v4
with:
path: |
/nix/store
/nix/var/nix/cache
key: nix-${{ runner.os }}-${{ hashFiles('flake.lock') }}
restore-keys: |
nix-${{ runner.os }}-
cabal-
- name: Initialize Cabal and update package list
run: |
nix develop --command cabal update
- name: Install dependencies and run tests
- name: Run test suite
run: |
nix develop --command cabal test
build:
needs: test
container:
image: docker.matri.cx/nix-runner:latest
image: docker.matri.cx/nix-runner:v0.1.0
credentials:
username: ${{ secrets.REGISTRY_USERNAME }}
password: ${{ secrets.REGISTRY_PASSWORD }}
steps:
- name: Checkout code
uses: actions/checkout@v3
- name: Set up cache for Cabal
uses: actions/cache@v4
- uses: actions/checkout@v3
with:
path: |
~/.cabal
~/.ghc
key: cabal-${{ runner.os }}-${{ hashFiles('tricu.cabal') }}
restore-keys: |
cabal-${{ runner.os }}-
fetch-depth: 0
- name: Set up cache for Nix
uses: actions/cache@v4
with:
path: |
/nix/store
/nix/var/nix/cache
key: nix-${{ runner.os }}-${{ hashFiles('flake.lock') }}
restore-keys: |
nix-${{ runner.os }}-
- name: Build binary
- name: Build and shrink binary
run: |
nix build
ls -alh ./result/bin/tricu
cp -L ./result/bin/tricu ./tricu
chmod 755 ./tricu
nix develop --command upx ./tricu
- name: Setup go for release action
uses: actions/setup-go@v5
with:
go-version: '>=1.20.1'
- name: Release binary
uses: https://gitea.com/actions/release-action@main
with:
files: |-
./tricu
api_key: '${{ secrets.RELEASE_TOKEN }}'
pre_release: true

View File

@ -16,7 +16,7 @@ These features move us cleanly out of the [turing tarpit](https://en.wikipedia.o
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?
## REPL examples
```
tricu < -- Anything after `--` on a single line is a comment
@ -29,11 +29,11 @@ tricu > "Hello, world!"
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 < 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"
tricu < -- We can even convert a term back to source code (/demos/toSource.tri)
tricu < toSource not?
tricu > "(t (t (t t) (t t t)) (t t (t t t)))"
```
## Installation and Use
@ -79,4 +79,4 @@ tricu decode [OPTIONS]
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 tricu 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 Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus.

24
demos/equality.tri Normal file
View File

@ -0,0 +1,24 @@
false = t
true = t t
triage = (\a b c : t (t a b) c)
matchBool = (\ot of : triage
of
(\_ : ot)
(\_ _ : ot)
)
not_TC? = t (t (t t) (t t t)) (t t (t t t))
not_Lambda? = matchBool false true
areEqual? = equal not_TC not_Lambda
true_TC? = not_TC false
false_TC? = not_TC true
true_Lambda? = not_Lambda false
false_Lambda? = not_Lambda true
areTrueEqual? = equal true_TC true_Lambda
areFalseEqual? = equal false_TC false_Lambda

View File

@ -17,20 +17,15 @@
-- 4 5 6
--
isLeaf = (\node :
lOr
(emptyList node)
(emptyList (tail node)))
label = (\node : head node)
getLabel = (\node : head node)
getLeft = (\node : if (emptyList node)
left = (\node : if (emptyList node)
[]
(if (emptyList (tail node))
[]
(head (tail node))))
getRight = (\node : if (emptyList node)
right = (\node : if (emptyList node)
[]
(if (emptyList (tail node))
[]
@ -40,11 +35,11 @@ getRight = (\node : if (emptyList node)
processLevel = y (\self queue : if (emptyList queue)
[]
(pair (map getLabel queue) (self (filter
(pair (map label queue) (self (filter
(\node : not (emptyList node))
(lconcat (map getLeft queue) (map getRight queue))))))
(lconcat (map left queue) (map right queue))))))
levelOrderTraversal = (\a : processLevel (t a t))
levelOrderTraversal_ = (\a : processLevel (t a t))
toLineString = y (\self levels : if (emptyList levels)
""
@ -52,12 +47,19 @@ toLineString = y (\self levels : if (emptyList levels)
(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))
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]]]
levelOrderTraversal = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
exampleOne
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]
[("3") [("5") t t] [("6") t t]]]
exampleTwo = levelOrderTraversal [("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]]]
exampleTwo

46
demos/toSource.tri Normal file
View File

@ -0,0 +1,46 @@
-- Thanks to intensionality, we can inspect the structure of a given value
-- even if it's a function. This includes lambdas which are eliminated to
-- Tree Calculus (TC) terms during evaluation.
-- Triage takes four arguments: the first three represent behaviors for each
-- structural case in Tree Calculus (Leaf, Stem, and Fork).
-- The fourth argument is the value whose structure is inspected. By evaluating
-- the Tree Calculus term, `triage` enables branching logic based on the term's
-- shape, making it possible to perform structure-specific operations such as
-- reconstructing the terms' source code representation.
triage = (\a b c : t (t a b) c)
-- Base case of a single Leaf
sourceLeaf = t (head "t")
-- Stem case
sourceStem = (\convert : (\a rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the argument.
(t (head ")") rest)))))) -- Close with ")" and append the rest.
-- Fork case
sourceFork = (\convert : (\a b rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the first arg.
(t (head " ") -- Add another space.
(convert b -- Recursively convert the second arg.
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
-- Wrapper around triage
toSource_ = y (\self arg :
triage
sourceLeaf -- Triage `a` case, Leaf
(sourceStem self) -- Triage `b` case, Stem
(sourceFork self) -- Triage `c` case, Fork
arg) -- The term to be inspected
-- toSource takes a single TC term and returns a String
toSource = (\v : toSource_ v "")
exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource not -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

View File

@ -32,10 +32,11 @@
defaultPackage = self.packages.${system}.default;
devShells.default = pkgs.mkShell {
buildInputs = with pkgs.haskellPackages; [
cabal-install
ghcid
buildInputs = with pkgs; [
haskellPackages.cabal-install
haskellPackages.ghcid
customGHC
upx
];
inputsFrom = builtins.attrValues self.packages.${system};
};

View File

@ -1,22 +1,25 @@
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)
_ = 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)
pair = t
if = (\cond then else : t (t else (t t then)) t cond)
triage = (\a b c : t (t a b) c)
pair = t
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
matchBool = (\ot of : triage
of
@ -36,58 +39,58 @@ 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")
not? = matchBool false true
and? = matchBool id (\_ : false)
emptyList? = matchList true (\_ _ : false)
emptyList = matchList true (\y z : false)
head = matchList t (\hd tl : hd)
tail = matchList t (\hd tl : tl)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
lconcat = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
lAnd = (triage
(\x : false)
(\_ x : x)
(\_ : false)
(\_ x : x)
(\_ _ x : x)
)
lOr = (triage
(\x : x)
(\_ _ : true)
(\_ _ x : true)
(\x : x)
(\_ _ : true)
(\_ _ _ : true)
)
hmap = y (\self :
map_ = y (\self :
matchList
(\f : t)
(\hd tl f : pair
(f hd)
(self tl f)))
map = (\f l : hmap l f)
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = (\f l : map_ l f)
equal = y (\self : triage
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))))
(\_ : false)
(\_ _ : false))
(\ax :
triage
false
(self ax)
(\_ _ : false))
(\ax ay :
triage
false
(\_ : 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)
filter_ = y (\self : matchList
(\_ : t)
(\head tail f : matchBool (t head) i (f head) (self tail f)))
filter = (\f l : filter_ 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)
foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
foldl = (\f x l : foldl_ 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)
foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
foldr = (\f x l : foldr_ x f l)

View File

@ -18,7 +18,10 @@ keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
identifier :: Lexer LToken
identifier = do
first <- letterChar <|> char '_'
rest <- many (letterChar <|> char '_' <|> char '-' <|> digitChar)
rest <- many $ letterChar
<|> digitChar
<|> char '_' <|> char '-' <|> char '?' <|> char '!'
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
let name = first : rest
if (name == "t" || name == "__result")
then fail "Keywords (`t`, `__result`) cannot be used as an identifier"

View File

@ -12,7 +12,8 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
import qualified Data.Set as Set
data PState = PState
{ depth :: Int
{ parenDepth :: Int
, bracketDepth :: Int
} deriving (Show)
type ParserM = StateT PState (Parsec Void [LToken])
@ -24,24 +25,33 @@ satisfyM f = do
return token
updateDepth :: LToken -> PState -> PState
updateDepth LOpenParen st = st { depth = depth st + 1 }
updateDepth LCloseParen st = st { depth = max 0 (depth st - 1) }
updateDepth _ st = st
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
updateDepth LOpenBracket st = st { bracketDepth = bracketDepth st + 1 }
updateDepth LCloseParen st = st { parenDepth = parenDepth st - 1 }
updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 }
updateDepth _ st = st
topLevelNewline :: ParserM ()
topLevelNewline = do
st <- get
if depth st == 0
if parenDepth st == 0 && bracketDepth st == 0
then void (satisfyM (== LNewline))
else fail "Top-level exit in paren context"
else fail "Top-level exit in nested context (paren or bracket)"
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
parseProgram tokens =
runParser (evalStateT parseProgramM (PState 0)) "" tokens
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
parseSingleExpr tokens =
runParser (evalStateT (scnParserM *> parseExpressionM <* eofM) (PState 0)) "" tokens
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
finalizeDepth :: ParserM ()
finalizeDepth = do
st <- get
case (parenDepth st, bracketDepth st) of
(0, 0) -> pure ()
(p, b) -> fail $ "Unmatched tokens: " ++ show (p, b)
parseTricu :: String -> [TricuAST]
parseTricu input =
@ -49,7 +59,7 @@ parseTricu input =
[] -> []
toks ->
case parseProgram toks of
Left err -> error (handleParseError err)
Left err -> errorWithoutStackTrace (handleParseError err)
Right asts -> asts
parseSingle :: String -> TricuAST
@ -58,7 +68,7 @@ parseSingle input =
[] -> SEmpty
toks ->
case parseSingleExpr toks of
Left err -> error (handleParseError err)
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> ast
parseProgramM :: ParserM [TricuAST]
@ -73,12 +83,15 @@ parseOneExpression = scnParserM *> parseExpressionM
scnParserM :: ParserM ()
scnParserM = skipMany $ do
t <- lookAhead anySingle
t <- lookAhead anySingle
st <- get
if depth st > 0 && isNewline t
then void (satisfyM isNewline)
else
fail "In paren context or no space token" <|> empty
if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
LNewline -> True
_ -> False -> void $ satisfyM $ \case
LNewline -> True
_ -> False
| otherwise -> fail "In nested context or no space token" <|> empty
eofM :: ParserM ()
eofM = lift eof
@ -96,23 +109,32 @@ parseExpressionM = choice
parseFunctionM :: ParserM TricuAST
parseFunctionM = do
LIdentifier name <- satisfyM isIdentifier
args <- many (satisfyM isIdentifier)
LIdentifier name <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
args <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
_ <- satisfyM (== LAssign)
scnParserM
body <- parseExpressionM
pure (SFunc name (map getIdentifier args) body)
parseLambdaM :: ParserM TricuAST
parseLambdaM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
_ <- satisfyM (== LBackslash)
param <- satisfyM isIdentifier
rest <- many (satisfyM isIdentifier)
_ <- satisfyM (== LColon)
scnParserM
body <- parseLambdaExpressionM
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
pure (SLambda [getIdentifier param] nested)
parseLambdaM =
between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
_ <- satisfyM (== LBackslash)
param <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
rest <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
_ <- satisfyM (== LColon)
scnParserM
body <- parseLambdaExpressionM
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
pure (SLambda [getIdentifier param] nested)
parseLambdaExpressionM :: ParserM TricuAST
parseLambdaExpressionM = choice
@ -158,8 +180,10 @@ parseAtomicBaseM = choice
parseTreeLeafM :: ParserM TricuAST
parseTreeLeafM = do
_ <- satisfyM isKeywordT
notFollowedBy (lift (satisfy (== LAssign)))
_ <- satisfyM $ \case
LKeywordT -> True
_ -> False
notFollowedBy $ lift $ satisfy (== LAssign)
pure TLeaf
parseTreeTermM :: ParserM TricuAST
@ -201,7 +225,10 @@ parseLiteralM = choice
parseListLiteralM :: ParserM TricuAST
parseListLiteralM = do
_ <- satisfyM (== LOpenBracket)
elements <- many parseListItemM
elements <- many $ do
scnParserM
parseListItemM
scnParserM
_ <- satisfyM (== LCloseBracket)
pure (SList elements)
@ -221,7 +248,10 @@ parseGroupedItemM = do
parseSingleItemM :: ParserM TricuAST
parseSingleItemM = do
token <- satisfyM isListItem
token <- satisfyM $ \case
LIdentifier _ -> True
LKeywordT -> True
_ -> False
case token of
LIdentifier name -> pure (SVar name)
LKeywordT -> pure TLeaf
@ -229,71 +259,46 @@ parseSingleItemM = do
parseVarM :: ParserM TricuAST
parseVarM = do
LIdentifier name <- satisfyM isIdentifier
LIdentifier name <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
if name == "t" || name == "__result"
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
else pure (SVar name)
parseIntLiteralM :: ParserM TricuAST
parseIntLiteralM = do
LIntegerLiteral value <- satisfyM isIntegerLiteral
LIntegerLiteral value <- satisfyM $ \case
LIntegerLiteral _ -> True
_ -> False
pure (SInt value)
parseStrLiteralM :: ParserM TricuAST
parseStrLiteralM = do
LStringLiteral value <- satisfyM isStringLiteral
LStringLiteral value <- satisfyM $ \case
LStringLiteral _ -> True
_ -> False
pure (SStr value)
isKeywordT :: LToken -> Bool
isKeywordT LKeywordT = True
isKeywordT _ = False
isIdentifier :: LToken -> Bool
isIdentifier (LIdentifier _) = True
isIdentifier _ = False
isIntegerLiteral :: LToken -> Bool
isIntegerLiteral (LIntegerLiteral _) = True
isIntegerLiteral _ = False
isStringLiteral :: LToken -> Bool
isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False
isLiteral :: LToken -> Bool
isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
isListItem LKeywordT = True
isListItem _ = False
isNewline :: LToken -> Bool
isNewline LNewline = True
isNewline _ = False
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name
getIdentifier _ = error "Expected identifier"
getIdentifier _ = errorWithoutStackTrace "Expected identifier"
handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle =
let errors = bundleErrors bundle
errorList = Data.List.NonEmpty.toList errors
formattedErrs = map showError errorList
in unlines ("Parse error(s) encountered:" : formattedErrs)
showError :: ParseError [LToken] Void -> String
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
"Parse error at offset " ++ show offset
++ ": unexpected token " ++ show tokenStream
++ ", expected one of " ++ show (Set.toList expected)
showError (FancyError offset fancy) =
"Parse error at offset " ++ show offset ++ ":\n "
++ unlines (map show (Set.toList fancy))
showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset
++ ": expected one of " ++ show (Set.toList expected)
let errors = bundleErrors bundle
formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
in unlines ("Parse error(s) encountered:" : formattedErrors)
formatError :: ParseError [LToken] Void -> String
formatError (TrivialError offset unexpected expected) =
let unexpectedMsg = case unexpected of
Just x -> "unexpected token " ++ show x
Nothing -> "unexpected end of input"
expectedMsg = if null expected
then ""
else "expected " ++ show (Set.toList expected)
in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
if null expectedMsg then "" else " " ++ expectedMsg
formatError (FancyError offset _) =
"Parse error at offset " ++ show offset ++ ": unexpected FancyError"

View File

@ -308,7 +308,7 @@ libraryTests = testGroup "Library Tests"
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
, testCase "I combinator" $ do
library <- evaluateFile "./lib/base.tri"
let input = "i not"
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
@ -328,32 +328,32 @@ libraryTests = testGroup "Library Tests"
env @?= "\"Fork\""
, testCase "Boolean NOT: true" $ do
library <- evaluateFile "./lib/base.tri"
let input = "not true"
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"
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)"
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)"
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)"
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)"
let input = "and? (t t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "List head" $ do
@ -373,12 +373,12 @@ libraryTests = testGroup "Library Tests"
result env @?= Fork Leaf Leaf
, testCase "Empty list check" $ do
library <- evaluateFile "./lib/base.tri"
let input = "emptyList []"
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)])"
let input = "not? (emptyList? [(1) (2) (3)])"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Concatenate strings" $ do
@ -388,7 +388,7 @@ libraryTests = testGroup "Library Tests"
env @?= "\"Hello, world!\""
, testCase "Verifying Equality" $ do
library <- evaluateFile "./lib/base.tri"
let input = "equal (t t t) (t t t)"
let input = "equal? (t t t) (t t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
]

View File

@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
version: 0.6.0
version: 0.7.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
@ -18,6 +18,7 @@ executable tricu
src
default-extensions:
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
@ -44,6 +45,7 @@ test-suite tricu-tests
hs-source-dirs: test, src
default-extensions:
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
build-depends: