Compare commits
10 Commits
0.7.0
...
0.12.0-hot
Author | SHA1 | Date | |
---|---|---|---|
33c2119708 | |||
3b833ca75b | |||
203bc1898d | |||
87aed72ab2 | |||
f71f88dce3 | |||
918d929c09 | |||
a64b3f0829 | |||
e2621bc09d | |||
ea128929da | |||
2bd388c871 |
@ -55,15 +55,11 @@ jobs:
|
|||||||
chmod 755 ./tricu
|
chmod 755 ./tricu
|
||||||
nix develop --command upx ./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
|
- name: Release binary
|
||||||
uses: https://gitea.com/actions/release-action@main
|
uses: akkuman/gitea-release-action@v1
|
||||||
with:
|
with:
|
||||||
files: |-
|
files: |-
|
||||||
./tricu
|
./tricu
|
||||||
api_key: '${{ secrets.RELEASE_TOKEN }}'
|
token: '${{ secrets.RELEASE_TOKEN }}'
|
||||||
pre_release: true
|
body: '${{ gitea.event.head_commit.message }}'
|
||||||
|
prerelease: true
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
## Introduction
|
## Introduction
|
||||||
|
|
||||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
|
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool. tricu is under active development and you can expect breaking changes with nearly every commit.
|
||||||
|
|
||||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||||
|
|
||||||
@ -10,12 +10,13 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
|
|||||||
|
|
||||||
- Tree Calculus operator: `t`
|
- Tree Calculus operator: `t`
|
||||||
- Assignments: `x = t t`
|
- Assignments: `x = t t`
|
||||||
|
- Immutable definitions
|
||||||
- Lambda abstraction syntax: `id = (\a : a)`
|
- Lambda abstraction syntax: `id = (\a : a)`
|
||||||
- List, Number, and String literals: `[(2) ("Hello")]`
|
- List, Number, and String literals: `[(2) ("Hello")]`
|
||||||
- Function application: `not (not false)`
|
- Function application: `not (not false)`
|
||||||
- Higher order/first-class functions: `map (\a : lconcat a "!") [("Hello")]`
|
- Higher order/first-class functions: `map (\a : lconcat a "!") [("Hello")]`
|
||||||
- Intensionality blurs the distinction between functions and data (see REPL examples)
|
- Intensionality blurs the distinction between functions and data (see REPL examples)
|
||||||
- Immutability
|
- Simple module system for code organization
|
||||||
|
|
||||||
## REPL examples
|
## REPL examples
|
||||||
|
|
||||||
@ -44,7 +45,7 @@ tricu > 12
|
|||||||
|
|
||||||
[Releases are available for Linux.](https://git.eversole.co/James/tricu/releases)
|
[Releases are available for Linux.](https://git.eversole.co/James/tricu/releases)
|
||||||
|
|
||||||
Or you can easily build and/or run this project using [Nix](https://nixos.org/download/).
|
Or you can easily build and run this project using [Nix](https://nixos.org/download/).
|
||||||
|
|
||||||
- Quick Start (REPL):
|
- Quick Start (REPL):
|
||||||
- `nix run git+https://git.eversole.co/James/tricu`
|
- `nix run git+https://git.eversole.co/James/tricu`
|
||||||
@ -71,7 +72,7 @@ tricu eval [OPTIONS]
|
|||||||
|
|
||||||
-f --file=FILE Input file path(s) for evaluation.
|
-f --file=FILE Input file path(s) for evaluation.
|
||||||
Defaults to stdin.
|
Defaults to stdin.
|
||||||
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii).
|
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii|decode).
|
||||||
Defaults to tricu-compatible `t` tree form.
|
Defaults to tricu-compatible `t` tree form.
|
||||||
|
|
||||||
tricu decode [OPTIONS]
|
tricu decode [OPTIONS]
|
||||||
|
@ -1,19 +1,25 @@
|
|||||||
|
!module Equality
|
||||||
|
|
||||||
|
!import "lib/base.tri" Lib
|
||||||
|
|
||||||
|
main = lambdaEqualsTC
|
||||||
|
|
||||||
-- We represent `false` with a Leaf and `true` with a Stem Leaf
|
-- We represent `false` with a Leaf and `true` with a Stem Leaf
|
||||||
false = t
|
demo_false = t
|
||||||
true = t t
|
demo_true = t t
|
||||||
|
|
||||||
-- Tree Calculus representation of the Boolean `not` function
|
-- Tree Calculus representation of the Boolean `not` function
|
||||||
not_TC? = t (t (t t) (t t t)) (t t (t t t))
|
not_TC? = t (t (t t) (t t t)) (t t (t t t))
|
||||||
|
|
||||||
-- /demos/toSource.tri contains an explanation of `triage`
|
-- /demos/toSource.tri contains an explanation of `triage`
|
||||||
triage = (\a b c : t (t a b) c)
|
demo_triage = \a b c : t (t a b) c
|
||||||
matchBool = (\ot of : triage
|
demo_matchBool = (\ot of : demo_triage
|
||||||
of
|
of
|
||||||
(\_ : ot)
|
(\_ : ot)
|
||||||
(\_ _ : ot)
|
(\_ _ : ot)
|
||||||
)
|
)
|
||||||
-- Lambda representation of the Boolean `not` function
|
-- Lambda representation of the Boolean `not` function
|
||||||
not_Lambda? = matchBool false true
|
not_Lambda? = demo_matchBool demo_false demo_true
|
||||||
|
|
||||||
-- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many
|
-- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many
|
||||||
-- functions defined via Lambda terms are larger than the most efficient TC
|
-- functions defined via Lambda terms are larger than the most efficient TC
|
||||||
@ -22,14 +28,14 @@ not_Lambda? = matchBool false true
|
|||||||
-- to different tree representations even if they share extensional behavior.
|
-- to different tree representations even if they share extensional behavior.
|
||||||
|
|
||||||
-- Let's see if these are the same:
|
-- Let's see if these are the same:
|
||||||
lambdaEqualsTC = equal? not_TC? not_Lambda?
|
lambdaEqualsTC = Lib.equal? not_TC? not_Lambda?
|
||||||
|
|
||||||
-- Here are some checks to verify their extensional behavior is the same:
|
-- Here are some checks to verify their extensional behavior is the same:
|
||||||
true_TC? = not_TC? false
|
true_TC? = not_TC? demo_false
|
||||||
false_TC? = not_TC? true
|
false_TC? = not_TC? demo_true
|
||||||
|
|
||||||
true_Lambda? = not_Lambda? false
|
true_Lambda? = not_Lambda? demo_false
|
||||||
false_Lambda? = not_Lambda? true
|
false_Lambda? = not_Lambda? demo_true
|
||||||
|
|
||||||
bothTrueEqual? = equal? true_TC? true_Lambda?
|
bothTrueEqual? = Lib.equal? true_TC? true_Lambda?
|
||||||
bothFalseEqual? = equal? false_TC? false_Lambda?
|
bothFalseEqual? = Lib.equal? false_TC? false_Lambda?
|
||||||
|
@ -1,11 +1,14 @@
|
|||||||
|
!module LOT
|
||||||
|
|
||||||
|
!import "lib/base.tri" Lib
|
||||||
|
|
||||||
|
main = exampleTwo
|
||||||
-- Level Order Traversal of a labelled binary tree
|
-- Level Order Traversal of a labelled binary tree
|
||||||
-- Objective: Print each "level" of the tree on a separate line
|
-- 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 nested lists where values act as labels. We
|
||||||
--
|
|
||||||
-- We model labelled binary trees as sublists where values act as labels. We
|
|
||||||
-- require explicit notation of empty nodes. Empty nodes can be represented
|
-- require explicit notation of empty nodes. Empty nodes can be represented
|
||||||
-- with an empty list, `[]`, which is equivalent to a single node `t`.
|
-- with an empty list, `[]`, which evaluates to a single node `t`.
|
||||||
--
|
--
|
||||||
-- Example tree inputs:
|
-- Example tree inputs:
|
||||||
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
|
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
|
||||||
@ -15,43 +18,42 @@
|
|||||||
-- 2 3
|
-- 2 3
|
||||||
-- / / \
|
-- / / \
|
||||||
-- 4 5 6
|
-- 4 5 6
|
||||||
--
|
|
||||||
|
|
||||||
label = (\node : head node)
|
label = \node : Lib.head node
|
||||||
|
|
||||||
left = (\node : if (emptyList node)
|
left = (\node : Lib.if (Lib.emptyList? node)
|
||||||
[]
|
[]
|
||||||
(if (emptyList (tail node))
|
(Lib.if (Lib.emptyList? (Lib.tail node))
|
||||||
[]
|
[]
|
||||||
(head (tail node))))
|
(Lib.head (Lib.tail node))))
|
||||||
|
|
||||||
right = (\node : if (emptyList node)
|
right = (\node : Lib.if (Lib.emptyList? node)
|
||||||
[]
|
[]
|
||||||
(if (emptyList (tail node))
|
(Lib.if (Lib.emptyList? (Lib.tail node))
|
||||||
[]
|
[]
|
||||||
(if (emptyList (tail (tail node)))
|
(Lib.if (Lib.emptyList? (Lib.tail (Lib.tail node)))
|
||||||
[]
|
[]
|
||||||
(head (tail (tail node))))))
|
(Lib.head (Lib.tail (Lib.tail node))))))
|
||||||
|
|
||||||
processLevel = y (\self queue : if (emptyList queue)
|
processLevel = Lib.y (\self queue : Lib.if (Lib.emptyList? queue)
|
||||||
[]
|
[]
|
||||||
(pair (map label queue) (self (filter
|
(Lib.pair (Lib.map label queue) (self (Lib.filter
|
||||||
(\node : not (emptyList node))
|
(\node : Lib.not? (Lib.emptyList? node))
|
||||||
(lconcat (map left queue) (map right queue))))))
|
(Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
|
||||||
|
|
||||||
levelOrderTraversal_ = (\a : processLevel (t a t))
|
levelOrderTraversal_ = \a : processLevel (t a t)
|
||||||
|
|
||||||
toLineString = y (\self levels : if (emptyList levels)
|
toLineString = Lib.y (\self levels : Lib.if (Lib.emptyList? levels)
|
||||||
""
|
""
|
||||||
(lconcat
|
(Lib.lconcat
|
||||||
(lconcat (map (\x : lconcat x " ") (head levels)) "")
|
(Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "")
|
||||||
(if (emptyList (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
|
(Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels))))))
|
||||||
|
|
||||||
levelOrderToString = (\s : toLineString (levelOrderTraversal_ s))
|
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
|
||||||
|
|
||||||
flatten = foldl (\acc x : lconcat acc x) ""
|
flatten = Lib.foldl (\acc x : Lib.lconcat acc x) ""
|
||||||
|
|
||||||
levelOrderTraversal = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
|
levelOrderTraversal = \s : Lib.lconcat (t 10 t) (flatten (levelOrderToString s))
|
||||||
|
|
||||||
exampleOne = levelOrderTraversal [("1")
|
exampleOne = levelOrderTraversal [("1")
|
||||||
[("2") [("4") t t] t]
|
[("2") [("4") t t] t]
|
||||||
@ -61,5 +63,3 @@ exampleTwo = levelOrderTraversal [("1")
|
|||||||
[("2") [("4") [("8") t t] [("9") t t]]
|
[("2") [("4") [("8") t t] [("9") t t]]
|
||||||
[("6") [("10") t t] [("12") t t]]]
|
[("6") [("10") t t] [("12") t t]]]
|
||||||
[("3") [("5") [("11") t t] t] [("7") t t]]]
|
[("3") [("5") [("11") t t] t] [("7") t t]]]
|
||||||
|
|
||||||
exampleTwo
|
|
||||||
|
@ -1,18 +1,24 @@
|
|||||||
compose = (\f g x : f (g x))
|
!module Size
|
||||||
|
|
||||||
succ = y (\self :
|
!import "lib/base.tri" Lib
|
||||||
triage
|
|
||||||
|
main = size size
|
||||||
|
|
||||||
|
compose = \f g x : f (g x)
|
||||||
|
|
||||||
|
succ = Lib.y (\self :
|
||||||
|
Lib.triage
|
||||||
1
|
1
|
||||||
t
|
t
|
||||||
(triage
|
(Lib.triage
|
||||||
(t (t t))
|
(t (t t))
|
||||||
(\_ tail : t t (self tail))
|
(\_ Lib.tail : t t (self Lib.tail))
|
||||||
t))
|
t))
|
||||||
|
|
||||||
size = (\x :
|
size = (\x :
|
||||||
(y (\self x :
|
(Lib.y (\self x :
|
||||||
compose succ
|
compose succ
|
||||||
(triage
|
(Lib.triage
|
||||||
(\x : x)
|
(\x : x)
|
||||||
self
|
self
|
||||||
(\x y : compose (self x) (self y))
|
(\x y : compose (self x) (self y))
|
||||||
|
@ -1,3 +1,8 @@
|
|||||||
|
!module ToSource
|
||||||
|
|
||||||
|
!import "lib/base.tri" Lib
|
||||||
|
|
||||||
|
main = toSource Lib.not?
|
||||||
-- Thanks to intensionality, we can inspect the structure of a given value
|
-- 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
|
-- even if it's a function. This includes lambdas which are eliminated to
|
||||||
-- Tree Calculus (TC) terms during evaluation.
|
-- Tree Calculus (TC) terms during evaluation.
|
||||||
@ -8,39 +13,39 @@
|
|||||||
-- the Tree Calculus term, `triage` enables branching logic based on the term's
|
-- the Tree Calculus term, `triage` enables branching logic based on the term's
|
||||||
-- shape, making it possible to perform structure-specific operations such as
|
-- shape, making it possible to perform structure-specific operations such as
|
||||||
-- reconstructing the terms' source code representation.
|
-- reconstructing the terms' source code representation.
|
||||||
triage = (\leaf stem fork : t (t leaf stem) fork)
|
-- triage = (\leaf stem fork : t (t leaf stem) fork)
|
||||||
|
|
||||||
-- Base case of a single Leaf
|
-- Base case of a single Leaf
|
||||||
sourceLeaf = t (head "t")
|
sourceLeaf = t (Lib.head "t")
|
||||||
|
|
||||||
-- Stem case
|
-- Stem case
|
||||||
sourceStem = (\convert : (\a rest :
|
sourceStem = (\convert : (\a rest :
|
||||||
t (head "(") -- Start with a left parenthesis "(".
|
t (Lib.head "(") -- Start with a left parenthesis "(".
|
||||||
(t (head "t") -- Add a "t"
|
(t (Lib.head "t") -- Add a "t"
|
||||||
(t (head " ") -- Add a space.
|
(t (Lib.head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the argument.
|
(convert a -- Recursively convert the argument.
|
||||||
(t (head ")") rest)))))) -- Close with ")" and append the rest.
|
(t (Lib.head ")") rest)))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Fork case
|
-- Fork case
|
||||||
sourceFork = (\convert : (\a b rest :
|
sourceFork = (\convert : (\a b rest :
|
||||||
t (head "(") -- Start with a left parenthesis "(".
|
t (Lib.head "(") -- Start with a left parenthesis "(".
|
||||||
(t (head "t") -- Add a "t"
|
(t (Lib.head "t") -- Add a "t"
|
||||||
(t (head " ") -- Add a space.
|
(t (Lib.head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the first arg.
|
(convert a -- Recursively convert the first arg.
|
||||||
(t (head " ") -- Add another space.
|
(t (Lib.head " ") -- Add another space.
|
||||||
(convert b -- Recursively convert the second arg.
|
(convert b -- Recursively convert the second arg.
|
||||||
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
|
(t (Lib.head ")") rest)))))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Wrapper around triage
|
-- Wrapper around triage
|
||||||
toSource_ = y (\self arg :
|
toSource_ = Lib.y (\self arg :
|
||||||
triage
|
Lib.triage
|
||||||
sourceLeaf -- `triage` "a" case, Leaf
|
sourceLeaf -- `triage` "a" case, Leaf
|
||||||
(sourceStem self) -- `triage` "b" case, Stem
|
(sourceStem self) -- `triage` "b" case, Stem
|
||||||
(sourceFork self) -- `triage` "c" case, Fork
|
(sourceFork self) -- `triage` "c" case, Fork
|
||||||
arg) -- The term to be inspected
|
arg) -- The term to be inspected
|
||||||
|
|
||||||
-- toSource takes a single TC term and returns a String
|
-- toSource takes a single TC term and returns a String
|
||||||
toSource = (\v : toSource_ v "")
|
toSource = \v : toSource_ v ""
|
||||||
|
|
||||||
exampleOne = toSource true -- OUT: "(t t)"
|
exampleOne = toSource Lib.true -- OUT: "(t t)"
|
||||||
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||||
|
43
lib/base.tri
43
lib/base.tri
@ -7,18 +7,15 @@ s = t (t (k t)) t
|
|||||||
m = s i i
|
m = s i i
|
||||||
b = s (k s) k
|
b = s (k s) k
|
||||||
c = s (s (k s) (s (k k) s)) (k k)
|
c = s (s (k s) (s (k k) s)) (k k)
|
||||||
iC = (\a b c : s a (k c) b)
|
id = \a : a
|
||||||
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
|
pair = t
|
||||||
if = (\cond then else : t (t else (t t then)) t cond)
|
if = \cond then else : t (t else (t t then)) t cond
|
||||||
|
|
||||||
triage = (\leaf stem fork : t (t leaf stem) fork)
|
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
|
||||||
|
(\x : x x)
|
||||||
|
(\a0 a1 a2 : t (t a0) (t t a2) a1))
|
||||||
|
|
||||||
|
triage = \leaf stem fork : t (t leaf stem) fork
|
||||||
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
||||||
|
|
||||||
matchBool = (\ot of : triage
|
matchBool = (\ot of : triage
|
||||||
@ -27,17 +24,9 @@ matchBool = (\ot of : triage
|
|||||||
(\_ _ : ot)
|
(\_ _ : ot)
|
||||||
)
|
)
|
||||||
|
|
||||||
matchList = (\oe oc : triage
|
matchList = \a b : triage a _ b
|
||||||
oe
|
|
||||||
_
|
|
||||||
oc
|
|
||||||
)
|
|
||||||
|
|
||||||
matchPair = (\op : triage
|
matchPair = \a : triage _ _ a
|
||||||
_
|
|
||||||
_
|
|
||||||
op
|
|
||||||
)
|
|
||||||
|
|
||||||
not? = matchBool false true
|
not? = matchBool false true
|
||||||
and? = matchBool id (\_ : false)
|
and? = matchBool id (\_ : false)
|
||||||
@ -53,20 +42,18 @@ lconcat = y (\self : matchList
|
|||||||
lAnd = (triage
|
lAnd = (triage
|
||||||
(\_ : false)
|
(\_ : false)
|
||||||
(\_ x : x)
|
(\_ x : x)
|
||||||
(\_ _ x : x)
|
(\_ _ x : x))
|
||||||
)
|
|
||||||
|
|
||||||
lOr = (triage
|
lOr = (triage
|
||||||
(\x : x)
|
(\x : x)
|
||||||
(\_ _ : true)
|
(\_ _ : true)
|
||||||
(\_ _ _ : true)
|
(\_ _ _ : true))
|
||||||
)
|
|
||||||
|
|
||||||
map_ = y (\self :
|
map_ = y (\self :
|
||||||
matchList
|
matchList
|
||||||
(\_ : t)
|
(\_ : t)
|
||||||
(\head tail f : pair (f head) (self tail f)))
|
(\head tail f : pair (f head) (self tail f)))
|
||||||
map = (\f l : map_ l f)
|
map = \f l : map_ l f
|
||||||
|
|
||||||
equal? = y (\self : triage
|
equal? = y (\self : triage
|
||||||
(triage
|
(triage
|
||||||
@ -87,10 +74,10 @@ equal? = y (\self : triage
|
|||||||
filter_ = y (\self : matchList
|
filter_ = y (\self : matchList
|
||||||
(\_ : t)
|
(\_ : t)
|
||||||
(\head tail f : matchBool (t head) i (f head) (self tail f)))
|
(\head tail f : matchBool (t head) i (f head) (self tail f)))
|
||||||
filter = (\f l : filter_ l f)
|
filter = \f l : filter_ l f
|
||||||
|
|
||||||
foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) 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)
|
foldl = \f x l : foldl_ f l x
|
||||||
|
|
||||||
foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) 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)
|
foldr = \f x l : foldr_ x f l
|
||||||
|
148
src/Eval.hs
148
src/Eval.hs
@ -3,37 +3,42 @@ module Eval where
|
|||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
|
||||||
|
import Data.List (partition, (\\))
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
evalSingle :: Env -> TricuAST -> Env
|
evalSingle :: Env -> TricuAST -> Env
|
||||||
evalSingle env term
|
evalSingle env term
|
||||||
| SFunc name [] body <- term =
|
| SDef name [] body <- term
|
||||||
if
|
= case Map.lookup name env of
|
||||||
| Map.member name env ->
|
Just existingValue
|
||||||
errorWithoutStackTrace $
|
| existingValue == evalAST env body -> env
|
||||||
"Error: Identifier '" ++ name ++ "' is already defined."
|
| otherwise -> errorWithoutStackTrace $
|
||||||
| otherwise ->
|
"Unable to rebind immutable identifier: '" ++ name
|
||||||
|
Nothing ->
|
||||||
let res = evalAST env body
|
let res = evalAST env body
|
||||||
in Map.insert "__result" res (Map.insert name res env)
|
in Map.insert "!result" res (Map.insert name res env)
|
||||||
| SApp func arg <- term =
|
| SApp func arg <- term
|
||||||
let res = apply (evalAST env func) (evalAST env arg)
|
= let res = apply (evalAST env func) (evalAST env arg)
|
||||||
in Map.insert "__result" res env
|
in Map.insert "!result" res env
|
||||||
| SVar name <- term =
|
| SVar name <- term
|
||||||
case Map.lookup name env of
|
= case Map.lookup name env of
|
||||||
Just v -> Map.insert "__result" v env
|
Just v -> Map.insert "!result" v env
|
||||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
Nothing ->
|
||||||
| otherwise =
|
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
|
||||||
Map.insert "__result" (evalAST env term) env
|
\This error should never occur here. Please report this as an issue."
|
||||||
|
| otherwise
|
||||||
|
= Map.insert "!result" (evalAST env term) env
|
||||||
|
|
||||||
evalTricu :: Env -> [TricuAST] -> Env
|
evalTricu :: Env -> [TricuAST] -> Env
|
||||||
evalTricu env [] = env
|
evalTricu env x = go env (reorderDefs env x)
|
||||||
evalTricu env [x] =
|
where
|
||||||
|
go env [] = env
|
||||||
|
go env [x] =
|
||||||
let updatedEnv = evalSingle env x
|
let updatedEnv = evalSingle env x
|
||||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
in Map.insert "!result" (result updatedEnv) updatedEnv
|
||||||
evalTricu env (x:xs) =
|
go env (x:xs) =
|
||||||
evalTricu (evalSingle env x) xs
|
evalTricu (evalSingle env x) xs
|
||||||
|
|
||||||
evalAST :: Env -> TricuAST -> T
|
evalAST :: Env -> TricuAST -> T
|
||||||
@ -54,11 +59,24 @@ evalAST env term
|
|||||||
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
||||||
name env
|
name env
|
||||||
|
|
||||||
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
|
|
||||||
-- Chapter 4: Lambda-Abstraction
|
|
||||||
elimLambda :: TricuAST -> TricuAST
|
elimLambda :: TricuAST -> TricuAST
|
||||||
elimLambda = go
|
elimLambda = go
|
||||||
where
|
where
|
||||||
|
-- η-reduction
|
||||||
|
go (SLambda [v] (SApp f (SVar x)))
|
||||||
|
| v == x && not (isFree v f) = elimLambda f
|
||||||
|
-- Triage optimization
|
||||||
|
go (SLambda [a] (SLambda [b] (SLambda [c] body)))
|
||||||
|
| body == triageBody = _TRIAGE
|
||||||
|
where
|
||||||
|
triageBody =
|
||||||
|
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
|
||||||
|
-- Composition optimization
|
||||||
|
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
||||||
|
| body == composeBody = _COMPOSE
|
||||||
|
where
|
||||||
|
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
|
||||||
|
-- General elimination
|
||||||
go (SLambda (v:vs) body)
|
go (SLambda (v:vs) body)
|
||||||
| null vs = toSKI v (elimLambda body)
|
| null vs = toSKI v (elimLambda body)
|
||||||
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
|
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
|
||||||
@ -73,25 +91,101 @@ elimLambda = go
|
|||||||
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
||||||
toSKI x t
|
toSKI x t
|
||||||
| not (isFree x t) = SApp _K t
|
| not (isFree x t) = SApp _K t
|
||||||
| otherwise = SApp (SApp _S (toSKI x t)) TLeaf
|
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
|
||||||
|
|
||||||
_S = parseSingle "t (t (t t t)) t"
|
_S = parseSingle "t (t (t t t)) t"
|
||||||
_K = parseSingle "t t"
|
_K = parseSingle "t t"
|
||||||
_I = parseSingle "t (t (t t)) t"
|
_I = parseSingle "t (t (t t)) t"
|
||||||
|
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
|
||||||
|
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||||
|
|
||||||
|
isFree :: String -> TricuAST -> Bool
|
||||||
isFree x = Set.member x . freeVars
|
isFree x = Set.member x . freeVars
|
||||||
|
|
||||||
|
freeVars :: TricuAST -> Set.Set String
|
||||||
freeVars (SVar v ) = Set.singleton v
|
freeVars (SVar v ) = Set.singleton v
|
||||||
freeVars (SInt _ ) = Set.empty
|
freeVars (SInt _ ) = Set.empty
|
||||||
freeVars (SStr _ ) = Set.empty
|
freeVars (SStr _ ) = Set.empty
|
||||||
freeVars (SList s ) = foldMap freeVars s
|
freeVars (SList s ) = foldMap freeVars s
|
||||||
freeVars (SApp f a ) = freeVars f <> freeVars a
|
freeVars (SApp f a ) = freeVars f <> freeVars a
|
||||||
freeVars (TLeaf ) = Set.empty
|
freeVars (TLeaf ) = Set.empty
|
||||||
freeVars (SFunc _ _ b) = freeVars b
|
freeVars (SDef _ _ b) = freeVars b
|
||||||
freeVars (TStem t ) = freeVars t
|
freeVars (TStem t ) = freeVars t
|
||||||
freeVars (TFork l r ) = freeVars l <> freeVars r
|
freeVars (TFork l r ) = freeVars l <> freeVars r
|
||||||
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
|
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
|
||||||
|
freeVars _ = Set.empty
|
||||||
|
|
||||||
|
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||||
|
reorderDefs env defs
|
||||||
|
| not (null missingDeps) =
|
||||||
|
errorWithoutStackTrace $
|
||||||
|
"Missing dependencies detected: " ++ show missingDeps
|
||||||
|
| otherwise = orderedDefs ++ others
|
||||||
|
where
|
||||||
|
(defsOnly, others) = partition isDef defs
|
||||||
|
defNames = [ name | SDef name _ _ <- defsOnly ]
|
||||||
|
|
||||||
|
defsWithFreeVars = [(def, freeVars body) | def@(SDef _ _ body) <- defsOnly]
|
||||||
|
|
||||||
|
graph = buildDepGraph defsOnly
|
||||||
|
sortedDefs = sortDeps graph
|
||||||
|
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
||||||
|
orderedDefs = map (\name -> defMap Map.! name) sortedDefs
|
||||||
|
|
||||||
|
freeVarsDefs = foldMap snd defsWithFreeVars
|
||||||
|
freeVarsOthers = foldMap freeVars others
|
||||||
|
allFreeVars = freeVarsDefs <> freeVarsOthers
|
||||||
|
validNames = Set.fromList defNames `Set.union` Set.fromList (Map.keys env)
|
||||||
|
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||||
|
|
||||||
|
isDef (SDef _ _ _) = True
|
||||||
|
isDef _ = False
|
||||||
|
|
||||||
|
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||||
|
buildDepGraph topDefs
|
||||||
|
| not (null duplicateNames) =
|
||||||
|
errorWithoutStackTrace $
|
||||||
|
"Duplicate definitions detected: " ++ show duplicateNames
|
||||||
|
| otherwise =
|
||||||
|
Map.fromList
|
||||||
|
[ (name, depends topDefs (SDef name [] body))
|
||||||
|
| SDef name _ body <- topDefs]
|
||||||
|
where
|
||||||
|
names = [name | SDef name _ _ <- topDefs]
|
||||||
|
duplicateNames =
|
||||||
|
[ name | (name, count) <- Map.toList (countOccurrences names) , count > 1]
|
||||||
|
countOccurrences = foldr (\x -> Map.insertWith (+) x 1) Map.empty
|
||||||
|
|
||||||
|
sortDeps :: Map.Map String (Set.Set String) -> [String]
|
||||||
|
sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||||
|
where
|
||||||
|
go sorted sortedSet [] = sorted
|
||||||
|
go sorted sortedSet remaining =
|
||||||
|
let ready = [ name | name <- remaining
|
||||||
|
, let deps = Map.findWithDefault Set.empty name graph
|
||||||
|
, Set.isSubsetOf deps sortedSet ]
|
||||||
|
notReady = remaining \\ ready
|
||||||
|
in if null ready
|
||||||
|
then errorWithoutStackTrace
|
||||||
|
"ERROR: Cyclic dependency detected and prohibited.\n\
|
||||||
|
\RESOLVE: Use nested lambdas."
|
||||||
|
else go (sorted ++ ready)
|
||||||
|
(Set.union sortedSet (Set.fromList ready))
|
||||||
|
notReady
|
||||||
|
|
||||||
|
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||||
|
depends topDefs (SDef _ _ body) =
|
||||||
|
Set.intersection
|
||||||
|
(Set.fromList [n | SDef n _ _ <- topDefs])
|
||||||
|
(freeVars body)
|
||||||
|
depends _ _ = Set.empty
|
||||||
|
|
||||||
result :: Env -> T
|
result :: Env -> T
|
||||||
result r = case Map.lookup "__result" r of
|
result r = case Map.lookup "!result" r of
|
||||||
Just a -> a
|
Just a -> a
|
||||||
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|
Nothing -> errorWithoutStackTrace "No !result field found in provided env"
|
||||||
|
|
||||||
|
mainResult :: Env -> T
|
||||||
|
mainResult r = case Map.lookup "main" r of
|
||||||
|
Just a -> a
|
||||||
|
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
||||||
|
136
src/FileEval.hs
136
src/FileEval.hs
@ -1,30 +1,150 @@
|
|||||||
module FileEval where
|
module FileEval where
|
||||||
|
|
||||||
import Eval
|
import Eval
|
||||||
|
import Lexer
|
||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
|
||||||
|
import Data.List (partition)
|
||||||
|
import Control.Monad (foldM)
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
evaluateFileResult :: FilePath -> IO T
|
evaluateFileResult :: FilePath -> IO T
|
||||||
evaluateFileResult filePath = do
|
evaluateFileResult filePath = do
|
||||||
contents <- readFile filePath
|
contents <- readFile filePath
|
||||||
let asts = parseTricu contents
|
let tokens = lexTricu contents
|
||||||
let finalEnv = evalTricu Map.empty asts
|
let moduleName = case parseProgram tokens of
|
||||||
case Map.lookup "__result" finalEnv of
|
Right ((SModule name) : _) -> name
|
||||||
|
_ -> ""
|
||||||
|
case parseProgram tokens of
|
||||||
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
|
Right _ -> do
|
||||||
|
ast <- preprocessFile filePath
|
||||||
|
let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
|
||||||
|
case Map.lookup "main" finalEnv of
|
||||||
Just finalResult -> return finalResult
|
Just finalResult -> return finalResult
|
||||||
Nothing -> errorWithoutStackTrace "No expressions to evaluate found"
|
Nothing -> errorWithoutStackTrace "No `main` function detected"
|
||||||
|
|
||||||
evaluateFile :: FilePath -> IO Env
|
evaluateFile :: FilePath -> IO Env
|
||||||
evaluateFile filePath = do
|
evaluateFile filePath = do
|
||||||
contents <- readFile filePath
|
contents <- readFile filePath
|
||||||
let asts = parseTricu contents
|
let tokens = lexTricu contents
|
||||||
pure $ evalTricu Map.empty asts
|
let moduleName = case parseProgram tokens of
|
||||||
|
Right ((SModule name) : _) -> name
|
||||||
|
_ -> ""
|
||||||
|
case parseProgram tokens of
|
||||||
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
|
Right _ -> do
|
||||||
|
ast <- preprocessFile filePath
|
||||||
|
pure $ mainAlias moduleName $ evalTricu Map.empty ast
|
||||||
|
|
||||||
evaluateFileWithContext :: Env -> FilePath -> IO Env
|
evaluateFileWithContext :: Env -> FilePath -> IO Env
|
||||||
evaluateFileWithContext env filePath = do
|
evaluateFileWithContext env filePath = do
|
||||||
contents <- readFile filePath
|
contents <- readFile filePath
|
||||||
let asts = parseTricu contents
|
let tokens = lexTricu contents
|
||||||
pure $ evalTricu env asts
|
let moduleName = case parseProgram tokens of
|
||||||
|
Right ((SModule name) : _) -> name
|
||||||
|
_ -> ""
|
||||||
|
case parseProgram tokens of
|
||||||
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
|
Right _ -> do
|
||||||
|
ast <- preprocessFile filePath
|
||||||
|
pure $ mainAlias moduleName $ evalTricu env ast
|
||||||
|
|
||||||
|
mainAlias :: String -> Env -> Env
|
||||||
|
mainAlias "" env = env
|
||||||
|
mainAlias moduleName env =
|
||||||
|
case Map.lookup (moduleName ++ ".main") env of
|
||||||
|
Just value -> Map.insert "main" value env
|
||||||
|
Nothing -> env
|
||||||
|
|
||||||
|
preprocessFile :: FilePath -> IO [TricuAST]
|
||||||
|
preprocessFile filePath = preprocessFile' Set.empty filePath
|
||||||
|
|
||||||
|
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
|
||||||
|
preprocessFile' inProgress filePath
|
||||||
|
| filePath `Set.member` inProgress =
|
||||||
|
errorWithoutStackTrace $ "Encountered cyclic import: " ++ filePath
|
||||||
|
| otherwise = do
|
||||||
|
contents <- readFile filePath
|
||||||
|
let tokens = lexTricu contents
|
||||||
|
case parseProgram tokens of
|
||||||
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
|
Right asts -> do
|
||||||
|
let (moduleName, restAST) = extractModule asts
|
||||||
|
let (imports, nonImports) = partition isImport restAST
|
||||||
|
let newInProgress = Set.insert filePath inProgress
|
||||||
|
importedASTs <- concat <$> mapM (processImport newInProgress) imports
|
||||||
|
let namespacedAST = namespaceDefinitions moduleName nonImports
|
||||||
|
pure $ importedASTs ++ namespacedAST
|
||||||
|
where
|
||||||
|
extractModule :: [TricuAST] -> (String, [TricuAST])
|
||||||
|
extractModule ((SModule name) : xs) = (name, xs)
|
||||||
|
extractModule xs = ("", xs)
|
||||||
|
|
||||||
|
isImport :: TricuAST -> Bool
|
||||||
|
isImport (SImport _ _) = True
|
||||||
|
isImport _ = False
|
||||||
|
|
||||||
|
processImport :: Set.Set FilePath -> TricuAST -> IO [TricuAST]
|
||||||
|
processImport inProgress (SImport filePath moduleName) = do
|
||||||
|
importedAST <- preprocessFile' inProgress filePath
|
||||||
|
pure $ namespaceDefinitions moduleName importedAST
|
||||||
|
processImport _ _ = error "Unexpected non-import in processImport"
|
||||||
|
|
||||||
|
namespaceDefinitions :: String -> [TricuAST] -> [TricuAST]
|
||||||
|
namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
|
||||||
|
|
||||||
|
namespaceDefinition :: String -> TricuAST -> TricuAST
|
||||||
|
namespaceDefinition "" def = def
|
||||||
|
namespaceDefinition moduleName (SDef name args body)
|
||||||
|
| isPrefixed name = SDef name args (namespaceBody moduleName body)
|
||||||
|
| otherwise = SDef (namespaceVariable moduleName name)
|
||||||
|
args (namespaceBody moduleName body)
|
||||||
|
namespaceDefinition moduleName other =
|
||||||
|
namespaceBody moduleName other
|
||||||
|
|
||||||
|
namespaceBody :: String -> TricuAST -> TricuAST
|
||||||
|
namespaceBody moduleName (SVar name)
|
||||||
|
| isPrefixed name = SVar name
|
||||||
|
| otherwise = SVar (namespaceVariable moduleName name)
|
||||||
|
namespaceBody moduleName (SApp func arg) =
|
||||||
|
SApp (namespaceBody moduleName func) (namespaceBody moduleName arg)
|
||||||
|
namespaceBody moduleName (SLambda args body) =
|
||||||
|
SLambda args (namespaceBodyScoped moduleName args body)
|
||||||
|
namespaceBody moduleName (SList items) =
|
||||||
|
SList (map (namespaceBody moduleName) items)
|
||||||
|
namespaceBody moduleName (TFork left right) =
|
||||||
|
TFork (namespaceBody moduleName left) (namespaceBody moduleName right)
|
||||||
|
namespaceBody moduleName (TStem subtree) =
|
||||||
|
TStem (namespaceBody moduleName subtree)
|
||||||
|
namespaceBody moduleName (SDef name args body)
|
||||||
|
| isPrefixed name = SDef name args (namespaceBody moduleName body)
|
||||||
|
| otherwise = SDef (namespaceVariable moduleName name)
|
||||||
|
args (namespaceBody moduleName body)
|
||||||
|
namespaceBody _ other = other
|
||||||
|
|
||||||
|
namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||||
|
namespaceBodyScoped moduleName args body = case body of
|
||||||
|
SVar name ->
|
||||||
|
if name `elem` args
|
||||||
|
then SVar name
|
||||||
|
else namespaceBody moduleName (SVar name)
|
||||||
|
SApp func arg -> SApp (namespaceBodyScoped moduleName args func) (namespaceBodyScoped moduleName args arg)
|
||||||
|
SLambda innerArgs innerBody -> SLambda innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||||
|
SList items -> SList (map (namespaceBodyScoped moduleName args) items)
|
||||||
|
TFork left right -> TFork (namespaceBodyScoped moduleName args left) (namespaceBodyScoped moduleName args right)
|
||||||
|
TStem subtree -> TStem (namespaceBodyScoped moduleName args subtree)
|
||||||
|
SDef name innerArgs innerBody ->
|
||||||
|
SDef (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||||
|
other -> other
|
||||||
|
|
||||||
|
isPrefixed :: String -> Bool
|
||||||
|
isPrefixed name = '.' `elem` name
|
||||||
|
|
||||||
|
namespaceVariable :: String -> String -> String
|
||||||
|
namespaceVariable "" name = name
|
||||||
|
namespaceVariable moduleName name = moduleName ++ "." ++ name
|
||||||
|
32
src/Lexer.hs
32
src/Lexer.hs
@ -20,11 +20,11 @@ identifier = do
|
|||||||
first <- letterChar <|> char '_'
|
first <- letterChar <|> char '_'
|
||||||
rest <- many $ letterChar
|
rest <- many $ letterChar
|
||||||
<|> digitChar
|
<|> digitChar
|
||||||
<|> char '_' <|> char '-' <|> char '?' <|> char '!'
|
<|> char '_' <|> char '-' <|> char '?' <|> char '.'
|
||||||
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
|
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
|
||||||
let name = first : rest
|
let name = first : rest
|
||||||
if (name == "t" || name == "__result")
|
if (name == "t" || name == "!result")
|
||||||
then fail "Keywords (`t`, `__result`) cannot be used as an identifier"
|
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
|
||||||
else return (LIdentifier name)
|
else return (LIdentifier name)
|
||||||
|
|
||||||
integerLiteral :: Lexer LToken
|
integerLiteral :: Lexer LToken
|
||||||
@ -39,6 +39,22 @@ stringLiteral = do
|
|||||||
char '"' --"
|
char '"' --"
|
||||||
return (LStringLiteral content)
|
return (LStringLiteral content)
|
||||||
|
|
||||||
|
lModule :: Lexer LToken
|
||||||
|
lModule = do
|
||||||
|
_ <- string "!module"
|
||||||
|
space1
|
||||||
|
LIdentifier moduleName <- identifier
|
||||||
|
return (LModule moduleName)
|
||||||
|
|
||||||
|
lImport :: Lexer LToken
|
||||||
|
lImport = do
|
||||||
|
_ <- string "!import"
|
||||||
|
space1
|
||||||
|
LStringLiteral path <- stringLiteral
|
||||||
|
space1
|
||||||
|
LIdentifier name <- identifier
|
||||||
|
return (LImport path name)
|
||||||
|
|
||||||
assign :: Lexer LToken
|
assign :: Lexer LToken
|
||||||
assign = char '=' *> pure LAssign
|
assign = char '=' *> pure LAssign
|
||||||
|
|
||||||
@ -72,13 +88,21 @@ sc = space
|
|||||||
tricuLexer :: Lexer [LToken]
|
tricuLexer :: Lexer [LToken]
|
||||||
tricuLexer = do
|
tricuLexer = do
|
||||||
sc
|
sc
|
||||||
|
header <- many $ do
|
||||||
|
tok <- choice
|
||||||
|
[ try lModule
|
||||||
|
, try lImport
|
||||||
|
, lnewline
|
||||||
|
]
|
||||||
|
sc
|
||||||
|
pure tok
|
||||||
tokens <- many $ do
|
tokens <- many $ do
|
||||||
tok <- choice tricuLexer'
|
tok <- choice tricuLexer'
|
||||||
sc
|
sc
|
||||||
pure tok
|
pure tok
|
||||||
sc
|
sc
|
||||||
eof
|
eof
|
||||||
pure tokens
|
pure (header ++ tokens)
|
||||||
where
|
where
|
||||||
tricuLexer' =
|
tricuLexer' =
|
||||||
[ try lnewline
|
[ try lnewline
|
||||||
|
18
src/Main.hs
18
src/Main.hs
@ -1,6 +1,6 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Eval (evalTricu, result)
|
import Eval (evalTricu, mainResult, result)
|
||||||
import FileEval
|
import FileEval
|
||||||
import Parser (parseTricu)
|
import Parser (parseTricu)
|
||||||
import REPL
|
import REPL
|
||||||
@ -16,7 +16,7 @@ import qualified Data.Map as Map
|
|||||||
data TricuArgs
|
data TricuArgs
|
||||||
= Repl
|
= Repl
|
||||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||||
| Decode { file :: [FilePath] }
|
| TDecode { file :: [FilePath] }
|
||||||
deriving (Show, Data, Typeable)
|
deriving (Show, Data, Typeable)
|
||||||
|
|
||||||
replMode :: TricuArgs
|
replMode :: TricuArgs
|
||||||
@ -31,7 +31,7 @@ evaluateMode = Evaluate
|
|||||||
\ Defaults to stdin."
|
\ Defaults to stdin."
|
||||||
&= name "f" &= typ "FILE"
|
&= name "f" &= typ "FILE"
|
||||||
, form = TreeCalculus &= typ "FORM"
|
, form = TreeCalculus &= typ "FORM"
|
||||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii).\n \
|
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
|
||||||
\ Defaults to tricu-compatible `t` tree form."
|
\ Defaults to tricu-compatible `t` tree form."
|
||||||
&= name "t"
|
&= name "t"
|
||||||
}
|
}
|
||||||
@ -40,7 +40,7 @@ evaluateMode = Evaluate
|
|||||||
&= name "eval"
|
&= name "eval"
|
||||||
|
|
||||||
decodeMode :: TricuArgs
|
decodeMode :: TricuArgs
|
||||||
decodeMode = Decode
|
decodeMode = TDecode
|
||||||
{ file = def
|
{ file = def
|
||||||
&= help "Optional input file path to attempt decoding.\n \
|
&= help "Optional input file path to attempt decoding.\n \
|
||||||
\ Defaults to stdin."
|
\ Defaults to stdin."
|
||||||
@ -60,8 +60,7 @@ main = do
|
|||||||
Repl -> do
|
Repl -> do
|
||||||
putStrLn "Welcome to the tricu REPL"
|
putStrLn "Welcome to the tricu REPL"
|
||||||
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`"
|
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`"
|
||||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
repl Map.empty
|
||||||
repl $ Map.delete "__result" library
|
|
||||||
Evaluate { file = filePaths, form = form } -> do
|
Evaluate { file = filePaths, form = form } -> do
|
||||||
result <- case filePaths of
|
result <- case filePaths of
|
||||||
[] -> do
|
[] -> do
|
||||||
@ -70,15 +69,14 @@ main = do
|
|||||||
(filePath:restFilePaths) -> do
|
(filePath:restFilePaths) -> do
|
||||||
initialEnv <- evaluateFile filePath
|
initialEnv <- evaluateFile filePath
|
||||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||||
pure $ result finalEnv
|
pure $ mainResult finalEnv
|
||||||
let fRes = formatResult form result
|
let fRes = formatResult form result
|
||||||
putStr fRes
|
putStr fRes
|
||||||
Decode { file = filePaths } -> do
|
TDecode { file = filePaths } -> do
|
||||||
value <- case filePaths of
|
value <- case filePaths of
|
||||||
[] -> getContents
|
[] -> getContents
|
||||||
(filePath:_) -> readFile filePath
|
(filePath:_) -> readFile filePath
|
||||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
||||||
putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value
|
|
||||||
|
|
||||||
runTricu :: String -> T
|
runTricu :: String -> T
|
||||||
runTricu input =
|
runTricu input =
|
||||||
|
108
src/Parser.hs
108
src/Parser.hs
@ -74,9 +74,33 @@ parseSingle input =
|
|||||||
parseProgramM :: ParserM [TricuAST]
|
parseProgramM :: ParserM [TricuAST]
|
||||||
parseProgramM = do
|
parseProgramM = do
|
||||||
skipMany topLevelNewline
|
skipMany topLevelNewline
|
||||||
|
moduleNode <- optional parseModuleM
|
||||||
|
skipMany topLevelNewline
|
||||||
|
importNodes <- many (do
|
||||||
|
node <- parseImportM
|
||||||
|
skipMany topLevelNewline
|
||||||
|
return node)
|
||||||
|
skipMany topLevelNewline
|
||||||
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
||||||
skipMany topLevelNewline
|
skipMany topLevelNewline
|
||||||
return exprs
|
return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
|
||||||
|
|
||||||
|
|
||||||
|
parseModuleM :: ParserM TricuAST
|
||||||
|
parseModuleM = do
|
||||||
|
LModule moduleName <- satisfyM isModule
|
||||||
|
pure (SModule moduleName)
|
||||||
|
where
|
||||||
|
isModule (LModule _) = True
|
||||||
|
isModule _ = False
|
||||||
|
|
||||||
|
parseImportM :: ParserM TricuAST
|
||||||
|
parseImportM = do
|
||||||
|
LImport filePath moduleName <- satisfyM isImport
|
||||||
|
pure (SImport filePath moduleName)
|
||||||
|
where
|
||||||
|
isImport (LImport _ _) = True
|
||||||
|
isImport _ = False
|
||||||
|
|
||||||
parseOneExpression :: ParserM TricuAST
|
parseOneExpression :: ParserM TricuAST
|
||||||
parseOneExpression = scnParserM *> parseExpressionM
|
parseOneExpression = scnParserM *> parseExpressionM
|
||||||
@ -85,13 +109,10 @@ scnParserM :: ParserM ()
|
|||||||
scnParserM = skipMany $ do
|
scnParserM = skipMany $ do
|
||||||
t <- lookAhead anySingle
|
t <- lookAhead anySingle
|
||||||
st <- get
|
st <- get
|
||||||
if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
|
if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
|
||||||
LNewline -> True
|
void $ satisfyM (== LNewline)
|
||||||
_ -> False -> void $ satisfyM $ \case
|
| otherwise ->
|
||||||
LNewline -> True
|
fail "In nested context or no space token" <|> empty
|
||||||
_ -> False
|
|
||||||
| otherwise -> fail "In nested context or no space token" <|> empty
|
|
||||||
|
|
||||||
|
|
||||||
eofM :: ParserM ()
|
eofM :: ParserM ()
|
||||||
eofM = lift eof
|
eofM = lift eof
|
||||||
@ -109,32 +130,23 @@ parseExpressionM = choice
|
|||||||
|
|
||||||
parseFunctionM :: ParserM TricuAST
|
parseFunctionM :: ParserM TricuAST
|
||||||
parseFunctionM = do
|
parseFunctionM = do
|
||||||
LIdentifier name <- satisfyM $ \case
|
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||||
LIdentifier _ -> True
|
LIdentifier name <- satisfyM ident
|
||||||
_ -> False
|
args <- many $ satisfyM ident
|
||||||
args <- many $ satisfyM $ \case
|
|
||||||
LIdentifier _ -> True
|
|
||||||
_ -> False
|
|
||||||
_ <- satisfyM (== LAssign)
|
_ <- satisfyM (== LAssign)
|
||||||
scnParserM
|
scnParserM
|
||||||
body <- parseExpressionM
|
body <- parseExpressionM
|
||||||
pure (SFunc name (map getIdentifier args) body)
|
pure (SDef name (map getIdentifier args) body)
|
||||||
|
|
||||||
parseLambdaM :: ParserM TricuAST
|
parseLambdaM :: ParserM TricuAST
|
||||||
parseLambdaM =
|
parseLambdaM = do
|
||||||
between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
|
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||||
_ <- satisfyM (== LBackslash)
|
_ <- satisfyM (== LBackslash)
|
||||||
param <- satisfyM $ \case
|
params <- some (satisfyM ident)
|
||||||
LIdentifier _ -> True
|
|
||||||
_ -> False
|
|
||||||
rest <- many $ satisfyM $ \case
|
|
||||||
LIdentifier _ -> True
|
|
||||||
_ -> False
|
|
||||||
_ <- satisfyM (== LColon)
|
_ <- satisfyM (== LColon)
|
||||||
scnParserM
|
scnParserM
|
||||||
body <- parseLambdaExpressionM
|
body <- parseLambdaExpressionM
|
||||||
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
|
pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
|
||||||
pure (SLambda [getIdentifier param] nested)
|
|
||||||
|
|
||||||
parseLambdaExpressionM :: ParserM TricuAST
|
parseLambdaExpressionM :: ParserM TricuAST
|
||||||
parseLambdaExpressionM = choice
|
parseLambdaExpressionM = choice
|
||||||
@ -180,9 +192,8 @@ parseAtomicBaseM = choice
|
|||||||
|
|
||||||
parseTreeLeafM :: ParserM TricuAST
|
parseTreeLeafM :: ParserM TricuAST
|
||||||
parseTreeLeafM = do
|
parseTreeLeafM = do
|
||||||
_ <- satisfyM $ \case
|
let keyword = (\case LKeywordT -> True; _ -> False)
|
||||||
LKeywordT -> True
|
_ <- satisfyM keyword
|
||||||
_ -> False
|
|
||||||
notFollowedBy $ lift $ satisfy (== LAssign)
|
notFollowedBy $ lift $ satisfy (== LAssign)
|
||||||
pure TLeaf
|
pure TLeaf
|
||||||
|
|
||||||
@ -248,37 +259,38 @@ parseGroupedItemM = do
|
|||||||
|
|
||||||
parseSingleItemM :: ParserM TricuAST
|
parseSingleItemM :: ParserM TricuAST
|
||||||
parseSingleItemM = do
|
parseSingleItemM = do
|
||||||
token <- satisfyM $ \case
|
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||||
LIdentifier _ -> True
|
if | LIdentifier name <- token -> pure (SVar name)
|
||||||
LKeywordT -> True
|
| token == LKeywordT -> pure TLeaf
|
||||||
_ -> False
|
| otherwise -> fail "Unexpected token in list item"
|
||||||
case token of
|
|
||||||
LIdentifier name -> pure (SVar name)
|
|
||||||
LKeywordT -> pure TLeaf
|
|
||||||
_ -> fail "Unexpected token in list item"
|
|
||||||
|
|
||||||
parseVarM :: ParserM TricuAST
|
parseVarM :: ParserM TricuAST
|
||||||
parseVarM = do
|
parseVarM = do
|
||||||
LIdentifier name <- satisfyM $ \case
|
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
|
||||||
LIdentifier _ -> True
|
LIdentifier name
|
||||||
_ -> False
|
| name == "t" || name == "!result" ->
|
||||||
if name == "t" || name == "__result"
|
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||||
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
| otherwise ->
|
||||||
else pure (SVar name)
|
pure (SVar name)
|
||||||
|
_ -> fail "Unexpected token while parsing variable"
|
||||||
|
|
||||||
parseIntLiteralM :: ParserM TricuAST
|
parseIntLiteralM :: ParserM TricuAST
|
||||||
parseIntLiteralM = do
|
parseIntLiteralM = do
|
||||||
LIntegerLiteral value <- satisfyM $ \case
|
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
||||||
LIntegerLiteral _ -> True
|
token <- satisfyM intL
|
||||||
_ -> False
|
if | LIntegerLiteral value <- token ->
|
||||||
pure (SInt value)
|
pure (SInt value)
|
||||||
|
| otherwise ->
|
||||||
|
fail "Unexpected token while parsing integer literal"
|
||||||
|
|
||||||
parseStrLiteralM :: ParserM TricuAST
|
parseStrLiteralM :: ParserM TricuAST
|
||||||
parseStrLiteralM = do
|
parseStrLiteralM = do
|
||||||
LStringLiteral value <- satisfyM $ \case
|
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
||||||
LStringLiteral _ -> True
|
token <- satisfyM strL
|
||||||
_ -> False
|
if | LStringLiteral value <- token ->
|
||||||
pure (SStr value)
|
pure (SStr value)
|
||||||
|
| otherwise ->
|
||||||
|
fail "Unexpected token while parsing string literal"
|
||||||
|
|
||||||
getIdentifier :: LToken -> String
|
getIdentifier :: LToken -> String
|
||||||
getIdentifier (LIdentifier name) = name
|
getIdentifier (LIdentifier name) = name
|
||||||
|
13
src/REPL.hs
13
src/REPL.hs
@ -26,7 +26,7 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
| Just s <- minput, strip s == "" -> do
|
| Just s <- minput, strip s == "" -> do
|
||||||
outputStrLn ""
|
outputStrLn ""
|
||||||
loop env
|
loop env
|
||||||
| Just s <- minput, strip s == "!load" -> do
|
| Just s <- minput, strip s == "!import" -> do
|
||||||
path <- getInputLine "File path to load < "
|
path <- getInputLine "File path to load < "
|
||||||
if
|
if
|
||||||
| Nothing <- path -> do
|
| Nothing <- path -> do
|
||||||
@ -34,7 +34,7 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
loop env
|
loop env
|
||||||
| Just p <- path -> do
|
| Just p <- path -> do
|
||||||
loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
|
loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
|
||||||
loop $ Map.delete "__result" (Map.union loadedEnv env)
|
loop $ Map.delete "!result" (Map.union loadedEnv env)
|
||||||
| Just s <- minput -> do
|
| Just s <- minput -> do
|
||||||
if
|
if
|
||||||
| take 2 s == "--" -> loop env
|
| take 2 s == "--" -> loop env
|
||||||
@ -47,7 +47,7 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
let asts = parseTricu input
|
let asts = parseTricu input
|
||||||
newEnv = evalTricu env asts
|
newEnv = evalTricu env asts
|
||||||
if
|
if
|
||||||
| Just r <- Map.lookup "__result" newEnv -> do
|
| Just r <- Map.lookup "!result" newEnv -> do
|
||||||
putStrLn $ "tricu > " ++ decodeResult r
|
putStrLn $ "tricu > " ++ decodeResult r
|
||||||
| otherwise -> return ()
|
| otherwise -> return ()
|
||||||
return newEnv
|
return newEnv
|
||||||
@ -59,10 +59,3 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
|
|
||||||
strip :: String -> String
|
strip :: String -> String
|
||||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||||
|
|
||||||
decodeResult :: T -> String
|
|
||||||
decodeResult tc
|
|
||||||
| Right num <- toNumber tc = show num
|
|
||||||
| Right str <- toString tc = "\"" ++ str ++ "\""
|
|
||||||
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
|
||||||
| otherwise = formatResult TreeCalculus tc
|
|
||||||
|
@ -19,13 +19,15 @@ data TricuAST
|
|||||||
| SInt Int
|
| SInt Int
|
||||||
| SStr String
|
| SStr String
|
||||||
| SList [TricuAST]
|
| SList [TricuAST]
|
||||||
| SFunc String [String] TricuAST
|
| SDef String [String] TricuAST
|
||||||
| SApp TricuAST TricuAST
|
| SApp TricuAST TricuAST
|
||||||
| TLeaf
|
| TLeaf
|
||||||
| TStem TricuAST
|
| TStem TricuAST
|
||||||
| TFork TricuAST TricuAST
|
| TFork TricuAST TricuAST
|
||||||
| SLambda [String] TricuAST
|
| SLambda [String] TricuAST
|
||||||
| SEmpty
|
| SEmpty
|
||||||
|
| SModule String
|
||||||
|
| SImport String String
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- Lexer Tokens
|
-- Lexer Tokens
|
||||||
@ -42,10 +44,12 @@ data LToken
|
|||||||
| LOpenBracket
|
| LOpenBracket
|
||||||
| LCloseBracket
|
| LCloseBracket
|
||||||
| LNewline
|
| LNewline
|
||||||
|
| LModule String
|
||||||
|
| LImport String String
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- Output formats
|
-- Output formats
|
||||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii
|
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||||
deriving (Show, Data, Typeable)
|
deriving (Show, Data, Typeable)
|
||||||
|
|
||||||
-- Environment containing previously evaluated TC terms
|
-- Environment containing previously evaluated TC terms
|
||||||
@ -115,6 +119,7 @@ formatResult FSL = show
|
|||||||
formatResult AST = show . toAST
|
formatResult AST = show . toAST
|
||||||
formatResult Ternary = toTernaryString
|
formatResult Ternary = toTernaryString
|
||||||
formatResult Ascii = toAscii
|
formatResult Ascii = toAscii
|
||||||
|
formatResult Decode = decodeResult
|
||||||
|
|
||||||
toSimpleT :: String -> String
|
toSimpleT :: String -> String
|
||||||
toSimpleT s = T.unpack
|
toSimpleT s = T.unpack
|
||||||
@ -147,4 +152,9 @@ toAscii tree = go tree "" True
|
|||||||
++ go left (prefix ++ (if isLast then " " else "| ")) False
|
++ go left (prefix ++ (if isLast then " " else "| ")) False
|
||||||
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
||||||
|
|
||||||
-- Utility
|
decodeResult :: T -> String
|
||||||
|
decodeResult tc
|
||||||
|
| Right num <- toNumber tc = show num
|
||||||
|
| Right str <- toString tc = "\"" ++ str ++ "\""
|
||||||
|
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
||||||
|
| otherwise = formatResult TreeCalculus tc
|
||||||
|
112
test/Spec.hs
112
test/Spec.hs
@ -9,6 +9,7 @@ import Research
|
|||||||
|
|
||||||
import Control.Exception (evaluate, try, SomeException)
|
import Control.Exception (evaluate, try, SomeException)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Data.List (isInfixOf)
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
import Test.Tasty.QuickCheck
|
import Test.Tasty.QuickCheck
|
||||||
@ -25,16 +26,18 @@ runTricu s = show $ result (evalTricu Map.empty $ parseTricu s)
|
|||||||
|
|
||||||
tests :: TestTree
|
tests :: TestTree
|
||||||
tests = testGroup "Tricu Tests"
|
tests = testGroup "Tricu Tests"
|
||||||
[ lexerTests
|
[ lexer
|
||||||
, parserTests
|
, parser
|
||||||
, evaluationTests
|
, simpleEvaluation
|
||||||
, lambdaEvalTests
|
, lambdas
|
||||||
, libraryTests
|
, baseLibrary
|
||||||
, fileEvaluationTests
|
, fileEval
|
||||||
|
, modules
|
||||||
|
, demos
|
||||||
]
|
]
|
||||||
|
|
||||||
lexerTests :: TestTree
|
lexer :: TestTree
|
||||||
lexerTests = testGroup "Lexer Tests"
|
lexer = testGroup "Lexer Tests"
|
||||||
[ testCase "Lex simple identifiers" $ do
|
[ testCase "Lex simple identifiers" $ do
|
||||||
let input = "x a b = a"
|
let input = "x a b = a"
|
||||||
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
|
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
|
||||||
@ -69,13 +72,13 @@ lexerTests = testGroup "Lexer Tests"
|
|||||||
Right i -> i @?= expect
|
Right i -> i @?= expect
|
||||||
|
|
||||||
, testCase "Error when using invalid characters in identifiers" $ do
|
, testCase "Error when using invalid characters in identifiers" $ do
|
||||||
case (runParser tricuLexer "" "__result = 5") of
|
case (runParser tricuLexer "" "!result = 5") of
|
||||||
Left _ -> return ()
|
Left _ -> return ()
|
||||||
Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
|
Right _ -> assertFailure "Expected failure when trying to assign the value of !result"
|
||||||
]
|
]
|
||||||
|
|
||||||
parserTests :: TestTree
|
parser :: TestTree
|
||||||
parserTests = testGroup "Parser Tests"
|
parser = testGroup "Parser Tests"
|
||||||
[ testCase "Error when assigning a value to T" $ do
|
[ testCase "Error when assigning a value to T" $ do
|
||||||
let tokens = lexTricu "t = x"
|
let tokens = lexTricu "t = x"
|
||||||
case parseSingleExpr tokens of
|
case parseSingleExpr tokens of
|
||||||
@ -84,7 +87,7 @@ parserTests = testGroup "Parser Tests"
|
|||||||
|
|
||||||
, testCase "Parse function definitions" $ do
|
, testCase "Parse function definitions" $ do
|
||||||
let input = "x = (\\a b c : a)"
|
let input = "x = (\\a b c : a)"
|
||||||
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse nested Tree Calculus terms" $ do
|
, testCase "Parse nested Tree Calculus terms" $ do
|
||||||
@ -104,7 +107,7 @@ parserTests = testGroup "Parser Tests"
|
|||||||
|
|
||||||
, testCase "Parse function with applications" $ do
|
, testCase "Parse function with applications" $ do
|
||||||
let input = "f = (\\x : t x)"
|
let input = "f = (\\x : t x)"
|
||||||
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse nested lists" $ do
|
, testCase "Parse nested lists" $ do
|
||||||
@ -146,7 +149,7 @@ parserTests = testGroup "Parser Tests"
|
|||||||
|
|
||||||
, testCase "Parse nested parentheses in function body" $ do
|
, testCase "Parse nested parentheses in function body" $ do
|
||||||
let input = "f = (\\x : t (t (t t)))"
|
let input = "f = (\\x : t (t (t t)))"
|
||||||
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse lambda abstractions" $ do
|
, testCase "Parse lambda abstractions" $ do
|
||||||
@ -156,12 +159,12 @@ parserTests = testGroup "Parser Tests"
|
|||||||
|
|
||||||
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
||||||
let input = "x = (\\a b : a)"
|
let input = "x = (\\a b : a)"
|
||||||
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Grouping T terms with parentheses in function application" $ do
|
, testCase "Grouping T terms with parentheses in function application" $ do
|
||||||
let input = "x = (\\a : a)\nx (t)"
|
let input = "x = (\\a : a)\nx (t)"
|
||||||
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
|
expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
|
||||||
parseTricu input @?= expect
|
parseTricu input @?= expect
|
||||||
|
|
||||||
, testCase "Comments 1" $ do
|
, testCase "Comments 1" $ do
|
||||||
@ -175,8 +178,8 @@ parserTests = testGroup "Parser Tests"
|
|||||||
parseTricu input @?= expect
|
parseTricu input @?= expect
|
||||||
]
|
]
|
||||||
|
|
||||||
evaluationTests :: TestTree
|
simpleEvaluation :: TestTree
|
||||||
evaluationTests = testGroup "Evaluation Tests"
|
simpleEvaluation = testGroup "Evaluation Tests"
|
||||||
[ testCase "Evaluate single Leaf" $ do
|
[ testCase "Evaluate single Leaf" $ do
|
||||||
let input = "t"
|
let input = "t"
|
||||||
let ast = parseSingle input
|
let ast = parseSingle input
|
||||||
@ -244,7 +247,7 @@ evaluationTests = testGroup "Evaluation Tests"
|
|||||||
(result env) @?= (Stem (Stem Leaf))
|
(result env) @?= (Stem (Stem Leaf))
|
||||||
|
|
||||||
|
|
||||||
, testCase "Evaluate variable shadowing" $ do
|
, testCase "Immutable definitions" $ do
|
||||||
let input = "x = t t\nx = t\nx"
|
let input = "x = t t\nx = t\nx"
|
||||||
env = evalTricu Map.empty (parseTricu input)
|
env = evalTricu Map.empty (parseTricu input)
|
||||||
result <- try (evaluate (runTricu input)) :: IO (Either SomeException String)
|
result <- try (evaluate (runTricu input)) :: IO (Either SomeException String)
|
||||||
@ -260,8 +263,8 @@ evaluationTests = testGroup "Evaluation Tests"
|
|||||||
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
||||||
]
|
]
|
||||||
|
|
||||||
lambdaEvalTests :: TestTree
|
lambdas :: TestTree
|
||||||
lambdaEvalTests = testGroup "Lambda Evaluation Tests"
|
lambdas = testGroup "Lambda Evaluation Tests"
|
||||||
[ testCase "Lambda Identity Function" $ do
|
[ testCase "Lambda Identity Function" $ do
|
||||||
let input = "id = (\\x : x)\nid t"
|
let input = "id = (\\x : x)\nid t"
|
||||||
runTricu input @?= "Leaf"
|
runTricu input @?= "Leaf"
|
||||||
@ -340,8 +343,8 @@ lambdaEvalTests = testGroup "Lambda Evaluation Tests"
|
|||||||
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
|
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
|
||||||
]
|
]
|
||||||
|
|
||||||
libraryTests :: TestTree
|
baseLibrary :: TestTree
|
||||||
libraryTests = testGroup "Library Tests"
|
baseLibrary = testGroup "Library Tests"
|
||||||
[ testCase "K combinator 1" $ do
|
[ testCase "K combinator 1" $ do
|
||||||
library <- evaluateFile "./lib/base.tri"
|
library <- evaluateFile "./lib/base.tri"
|
||||||
let input = "k (t) (t t)"
|
let input = "k (t) (t t)"
|
||||||
@ -476,8 +479,8 @@ libraryTests = testGroup "Library Tests"
|
|||||||
result env @?= Stem Leaf
|
result env @?= Stem Leaf
|
||||||
]
|
]
|
||||||
|
|
||||||
fileEvaluationTests :: TestTree
|
fileEval :: TestTree
|
||||||
fileEvaluationTests = testGroup "Evaluation tests"
|
fileEval = testGroup "File evaluation tests"
|
||||||
[ testCase "Forks" $ do
|
[ testCase "Forks" $ do
|
||||||
res <- liftIO $ evaluateFileResult "./test/fork.tri"
|
res <- liftIO $ evaluateFileResult "./test/fork.tri"
|
||||||
res @?= Fork Leaf Leaf
|
res @?= Fork Leaf Leaf
|
||||||
@ -487,11 +490,64 @@ fileEvaluationTests = testGroup "Evaluation tests"
|
|||||||
res @?= Fork (Stem Leaf) Leaf
|
res @?= Fork (Stem Leaf) Leaf
|
||||||
|
|
||||||
, testCase "Mapping and Equality" $ do
|
, testCase "Mapping and Equality" $ do
|
||||||
res <- liftIO $ evaluateFileResult "./test/map.tri"
|
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||||
res @?= Stem Leaf
|
fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
|
||||||
|
(mainResult fEnv) @?= Stem Leaf
|
||||||
|
|
||||||
, testCase "Eval and decoding string" $ do
|
, testCase "Eval and decoding string" $ do
|
||||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||||
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
||||||
decodeResult (result res) @?= "\"String test!\""
|
decodeResult (result res) @?= "\"String test!\""
|
||||||
]
|
]
|
||||||
|
|
||||||
|
modules :: TestTree
|
||||||
|
modules = testGroup "Test modules"
|
||||||
|
[ testCase "Detect cyclic dependencies" $ do
|
||||||
|
result <- try (liftIO $ evaluateFileResult "./test/cycle-1.tri") :: IO (Either SomeException T)
|
||||||
|
case result of
|
||||||
|
Left e -> do
|
||||||
|
let errorMsg = show e
|
||||||
|
if "Encountered cyclic import" `isInfixOf` errorMsg
|
||||||
|
then return ()
|
||||||
|
else assertFailure $ "Unexpected error: " ++ errorMsg
|
||||||
|
Right _ -> assertFailure "Expected cyclic dependencies"
|
||||||
|
, testCase "Module imports and namespacing" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./test/namespace-A.tri"
|
||||||
|
res @?= Leaf
|
||||||
|
, testCase "Multiple imports" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./test/vars-A.tri"
|
||||||
|
res @?= Leaf
|
||||||
|
, testCase "Error on unresolved variable" $ do
|
||||||
|
result <- try (liftIO $ evaluateFileResult "./test/unresolved-A.tri") :: IO (Either SomeException T)
|
||||||
|
case result of
|
||||||
|
Left e -> do
|
||||||
|
let errorMsg = show e
|
||||||
|
if "undefinedVar" `isInfixOf` errorMsg
|
||||||
|
then return ()
|
||||||
|
else assertFailure $ "Unexpected error: " ++ errorMsg
|
||||||
|
Right _ -> assertFailure "Expected unresolved variable error"
|
||||||
|
, testCase "Multi-level imports" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./test/multi-level-A.tri"
|
||||||
|
res @?= Leaf
|
||||||
|
, testCase "Lambda expression namespaces" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
|
||||||
|
res @?= Leaf
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
-- All of our demo tests are also module tests
|
||||||
|
demos :: TestTree
|
||||||
|
demos = testGroup "Test provided demo functionality"
|
||||||
|
[ testCase "Structural equality demo" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./demos/equality.tri"
|
||||||
|
decodeResult res @?= "t t"
|
||||||
|
, testCase "Convert values back to source code demo" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./demos/toSource.tri"
|
||||||
|
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
|
||||||
|
, testCase "Determining the size of functions" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./demos/size.tri"
|
||||||
|
decodeResult res @?= "454"
|
||||||
|
, testCase "Level Order Traversal demo" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
|
||||||
|
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
|
||||||
|
]
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
-- t (t t) (t (t t t))
|
-- t (t t) (t (t t t))
|
||||||
-- t (t t t) (t t)
|
-- t (t t t) (t t)
|
||||||
-- x = (\a : a)
|
-- x = (\a : a)
|
||||||
t (t t) t -- Fork (Stem Leaf) Leaf
|
main = t (t t) t -- Fork (Stem Leaf) Leaf
|
||||||
-- t t
|
-- t t
|
||||||
-- x
|
-- x
|
||||||
-- x = (\a : a)
|
-- x = (\a : a)
|
||||||
|
5
test/cycle-1.tri
Normal file
5
test/cycle-1.tri
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
!module Cycle
|
||||||
|
|
||||||
|
!import "test/cycle-2.tri" Cycle2
|
||||||
|
|
||||||
|
cycle1 = t Cycle2.cycle2
|
5
test/cycle-2.tri
Normal file
5
test/cycle-2.tri
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
!module Cycle2
|
||||||
|
|
||||||
|
!import "test/cycle-1.tri" Cycle1
|
||||||
|
|
||||||
|
cycle2 = t Cycle1.cycle1
|
@ -1 +1 @@
|
|||||||
t t t
|
main = t t t
|
||||||
|
2
test/lambda-A.tri
Normal file
2
test/lambda-A.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module A
|
||||||
|
main = (\x : x) t
|
24
test/map.tri
24
test/map.tri
@ -1,24 +1,2 @@
|
|||||||
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!")]
|
x = map (\i : lconcat "Successfully concatenated " i) [("two strings!")]
|
||||||
equal x [("Successfully concatenated two strings!")]
|
main = equal? x [("Successfully concatenated two strings!")]
|
||||||
|
5
test/modules-1.tri
Normal file
5
test/modules-1.tri
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
!module Test
|
||||||
|
|
||||||
|
!import "lib/base.tri" Lib
|
||||||
|
|
||||||
|
main = Lib.not? t
|
1
test/modules-2.tri
Normal file
1
test/modules-2.tri
Normal file
@ -0,0 +1 @@
|
|||||||
|
n = t t t
|
3
test/multi-level-A.tri
Normal file
3
test/multi-level-A.tri
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
!module A
|
||||||
|
!import "./test/multi-level-B.tri" B
|
||||||
|
main = B.main
|
3
test/multi-level-B.tri
Normal file
3
test/multi-level-B.tri
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
!module B
|
||||||
|
!import "./test/multi-level-C.tri" C
|
||||||
|
main = C.val
|
2
test/multi-level-C.tri
Normal file
2
test/multi-level-C.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module C
|
||||||
|
val = t
|
3
test/namespace-A.tri
Normal file
3
test/namespace-A.tri
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
!module A
|
||||||
|
!import "./test/namespace-B.tri" B
|
||||||
|
main = B.x
|
2
test/namespace-B.tri
Normal file
2
test/namespace-B.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module B
|
||||||
|
x = t
|
21
test/size.tri
Normal file
21
test/size.tri
Normal file
@ -0,0 +1,21 @@
|
|||||||
|
compose = \f g x : f (g x)
|
||||||
|
|
||||||
|
succ = y (\self :
|
||||||
|
triage
|
||||||
|
1
|
||||||
|
t
|
||||||
|
(triage
|
||||||
|
(t (t t))
|
||||||
|
(\_ tail : t t (self tail))
|
||||||
|
t))
|
||||||
|
|
||||||
|
size = (\x :
|
||||||
|
(y (\self x :
|
||||||
|
compose succ
|
||||||
|
(triage
|
||||||
|
(\x : x)
|
||||||
|
self
|
||||||
|
(\x y : compose (self x) (self y))
|
||||||
|
x)) x 0))
|
||||||
|
|
||||||
|
size size
|
1
test/undefined.tri
Normal file
1
test/undefined.tri
Normal file
@ -0,0 +1 @@
|
|||||||
|
namedTerm = undefinedForTesting
|
2
test/unresolved-A.tri
Normal file
2
test/unresolved-A.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module A
|
||||||
|
main = undefinedVar
|
7
test/vars-A.tri
Normal file
7
test/vars-A.tri
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
!module A
|
||||||
|
|
||||||
|
!import "./test/vars-B.tri" B
|
||||||
|
|
||||||
|
!import "./test/vars-C.tri" C
|
||||||
|
|
||||||
|
main = B.y (C.z)
|
2
test/vars-B.tri
Normal file
2
test/vars-B.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module B
|
||||||
|
y = \x : x
|
2
test/vars-C.tri
Normal file
2
test/vars-C.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
!module C
|
||||||
|
z = t
|
@ -1,7 +1,7 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
name: tricu
|
name: tricu
|
||||||
version: 0.7.0
|
version: 0.12.0
|
||||||
description: A micro-language for exploring Tree Calculus
|
description: A micro-language for exploring Tree Calculus
|
||||||
author: James Eversole
|
author: James Eversole
|
||||||
maintainer: james@eversole.co
|
maintainer: james@eversole.co
|
||||||
|
Reference in New Issue
Block a user