Compare commits
2 Commits
09eedfb609
...
0.13.1
Author | SHA1 | Date | |
---|---|---|---|
7d1b6a741d | |||
bf1000d174 |
10
README.md
10
README.md
@ -2,7 +2,9 @@
|
|||||||
|
|
||||||
## 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 is under active development and you can expect breaking changes with nearly every commit.
|
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 should expect breaking changes with 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)`.
|
||||||
|
|
||||||
@ -14,7 +16,7 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
|
|||||||
- 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 : append a "!") [("Hello")]`
|
||||||
- Intensionality blurs the distinction between functions and data (see REPL examples)
|
- Intensionality blurs the distinction between functions and data (see REPL examples)
|
||||||
- Simple module system for code organization
|
- Simple module system for code organization
|
||||||
|
|
||||||
@ -23,9 +25,9 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
|
|||||||
```
|
```
|
||||||
tricu < -- Anything after `--` on a single line is a comment
|
tricu < -- Anything after `--` on a single line is a comment
|
||||||
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
|
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
|
||||||
tricu < head (map (\i : lconcat i " world!") [("Hello, ")])
|
tricu < head (map (\i : append i " world!") [("Hello, ")])
|
||||||
tricu > "Hello, world!"
|
tricu > "Hello, world!"
|
||||||
tricu < id (head (map (\i : lconcat i " world!") [("Hello, ")]))
|
tricu < id (head (map (\i : append i " world!") [("Hello, ")]))
|
||||||
tricu > "Hello, world!"
|
tricu > "Hello, world!"
|
||||||
|
|
||||||
tricu < -- Intensionality! We can inspect the structure of a function or data.
|
tricu < -- Intensionality! We can inspect the structure of a function or data.
|
||||||
|
@ -1,6 +1,4 @@
|
|||||||
!module Equality
|
!import "lib/base.tri" !Local
|
||||||
|
|
||||||
!import "lib/base.tri" Lib
|
|
||||||
|
|
||||||
main = lambdaEqualsTC
|
main = lambdaEqualsTC
|
||||||
|
|
||||||
@ -28,7 +26,7 @@ not_Lambda? = demo_matchBool demo_false demo_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 = Lib.equal? not_TC? not_Lambda?
|
lambdaEqualsTC = 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? demo_false
|
true_TC? = not_TC? demo_false
|
||||||
@ -37,5 +35,5 @@ false_TC? = not_TC? demo_true
|
|||||||
true_Lambda? = not_Lambda? demo_false
|
true_Lambda? = not_Lambda? demo_false
|
||||||
false_Lambda? = not_Lambda? demo_true
|
false_Lambda? = not_Lambda? demo_true
|
||||||
|
|
||||||
bothTrueEqual? = Lib.equal? true_TC? true_Lambda?
|
bothTrueEqual? = equal? true_TC? true_Lambda?
|
||||||
bothFalseEqual? = Lib.equal? false_TC? false_Lambda?
|
bothFalseEqual? = equal? false_TC? false_Lambda?
|
||||||
|
@ -1,6 +1,4 @@
|
|||||||
!module LOT
|
!import "lib/base.tri" !Local
|
||||||
|
|
||||||
!import "lib/base.tri" Lib
|
|
||||||
|
|
||||||
main = exampleTwo
|
main = exampleTwo
|
||||||
-- Level Order Traversal of a labelled binary tree
|
-- Level Order Traversal of a labelled binary tree
|
||||||
@ -19,41 +17,41 @@ main = exampleTwo
|
|||||||
-- / / \
|
-- / / \
|
||||||
-- 4 5 6
|
-- 4 5 6
|
||||||
|
|
||||||
label = \node : Lib.head node
|
label = \node : head node
|
||||||
|
|
||||||
left = (\node : Lib.if (Lib.emptyList? node)
|
left = (\node : if (emptyList? node)
|
||||||
[]
|
[]
|
||||||
(Lib.if (Lib.emptyList? (Lib.tail node))
|
(if (emptyList? (tail node))
|
||||||
[]
|
[]
|
||||||
(Lib.head (Lib.tail node))))
|
(head (tail node))))
|
||||||
|
|
||||||
right = (\node : Lib.if (Lib.emptyList? node)
|
right = (\node : if (emptyList? node)
|
||||||
[]
|
[]
|
||||||
(Lib.if (Lib.emptyList? (Lib.tail node))
|
(if (emptyList? (tail node))
|
||||||
[]
|
[]
|
||||||
(Lib.if (Lib.emptyList? (Lib.tail (Lib.tail node)))
|
(if (emptyList? (tail (tail node)))
|
||||||
[]
|
[]
|
||||||
(Lib.head (Lib.tail (Lib.tail node))))))
|
(head (tail (tail node))))))
|
||||||
|
|
||||||
processLevel = Lib.y (\self queue : Lib.if (Lib.emptyList? queue)
|
processLevel = y (\self queue : if (emptyList? queue)
|
||||||
[]
|
[]
|
||||||
(Lib.pair (Lib.map label queue) (self (Lib.filter
|
(pair (map label queue) (self (filter
|
||||||
(\node : Lib.not? (Lib.emptyList? node))
|
(\node : not? (emptyList? node))
|
||||||
(Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
|
(append (map left queue) (map right queue))))))
|
||||||
|
|
||||||
levelOrderTraversal_ = \a : processLevel (t a t)
|
levelOrderTraversal_ = \a : processLevel (t a t)
|
||||||
|
|
||||||
toLineString = Lib.y (\self levels : Lib.if (Lib.emptyList? levels)
|
toLineString = y (\self levels : if (emptyList? levels)
|
||||||
""
|
""
|
||||||
(Lib.lconcat
|
(append
|
||||||
(Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "")
|
(append (map (\x : append x " ") (head levels)) "")
|
||||||
(Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels))))))
|
(if (emptyList? (tail levels)) "" (append (t (t 10 t) t) (self (tail levels))))))
|
||||||
|
|
||||||
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
|
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
|
||||||
|
|
||||||
flatten = Lib.foldl (\acc x : Lib.lconcat acc x) ""
|
flatten = foldl (\acc x : append acc x) ""
|
||||||
|
|
||||||
levelOrderTraversal = \s : Lib.lconcat (t 10 t) (flatten (levelOrderToString s))
|
levelOrderTraversal = \s : append (t 10 t) (flatten (levelOrderToString s))
|
||||||
|
|
||||||
exampleOne = levelOrderTraversal [("1")
|
exampleOne = levelOrderTraversal [("1")
|
||||||
[("2") [("4") t t] t]
|
[("2") [("4") t t] t]
|
||||||
|
@ -1,24 +1,11 @@
|
|||||||
!module Size
|
!import "lib/base.tri" !Local
|
||||||
|
|
||||||
!import "lib/base.tri" Lib
|
|
||||||
|
|
||||||
main = size size
|
main = size size
|
||||||
|
|
||||||
compose = \f g x : f (g x)
|
|
||||||
|
|
||||||
succ = Lib.y (\self :
|
|
||||||
Lib.triage
|
|
||||||
1
|
|
||||||
t
|
|
||||||
(Lib.triage
|
|
||||||
(t (t t))
|
|
||||||
(\_ Lib.tail : t t (self Lib.tail))
|
|
||||||
t))
|
|
||||||
|
|
||||||
size = (\x :
|
size = (\x :
|
||||||
(Lib.y (\self x :
|
(y (\self x :
|
||||||
compose succ
|
compose succ
|
||||||
(Lib.triage
|
(triage
|
||||||
(\x : x)
|
(\x : x)
|
||||||
self
|
self
|
||||||
(\x y : compose (self x) (self y))
|
(\x y : compose (self x) (self y))
|
||||||
|
@ -1,8 +1,6 @@
|
|||||||
!module ToSource
|
!import "lib/base.tri" !Local
|
||||||
|
|
||||||
!import "lib/base.tri" Lib
|
main = toSource not?
|
||||||
|
|
||||||
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.
|
||||||
@ -16,29 +14,29 @@ main = toSource Lib.not?
|
|||||||
-- 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 (Lib.head "t")
|
sourceLeaf = t (head "t")
|
||||||
|
|
||||||
-- Stem case
|
-- Stem case
|
||||||
sourceStem = (\convert : (\a rest :
|
sourceStem = (\convert : (\a rest :
|
||||||
t (Lib.head "(") -- Start with a left parenthesis "(".
|
t (head "(") -- Start with a left parenthesis "(".
|
||||||
(t (Lib.head "t") -- Add a "t"
|
(t (head "t") -- Add a "t"
|
||||||
(t (Lib.head " ") -- Add a space.
|
(t (head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the argument.
|
(convert a -- Recursively convert the argument.
|
||||||
(t (Lib.head ")") rest)))))) -- Close with ")" and append the rest.
|
(t (head ")") rest)))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Fork case
|
-- Fork case
|
||||||
sourceFork = (\convert : (\a b rest :
|
sourceFork = (\convert : (\a b rest :
|
||||||
t (Lib.head "(") -- Start with a left parenthesis "(".
|
t (head "(") -- Start with a left parenthesis "(".
|
||||||
(t (Lib.head "t") -- Add a "t"
|
(t (head "t") -- Add a "t"
|
||||||
(t (Lib.head " ") -- Add a space.
|
(t (head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the first arg.
|
(convert a -- Recursively convert the first arg.
|
||||||
(t (Lib.head " ") -- Add another space.
|
(t (head " ") -- Add another space.
|
||||||
(convert b -- Recursively convert the second arg.
|
(convert b -- Recursively convert the second arg.
|
||||||
(t (Lib.head ")") rest)))))))) -- Close with ")" and append the rest.
|
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Wrapper around triage
|
-- Wrapper around triage
|
||||||
toSource_ = Lib.y (\self arg :
|
toSource_ = y (\self arg :
|
||||||
Lib.triage
|
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
|
||||||
@ -47,5 +45,5 @@ toSource_ = Lib.y (\self arg :
|
|||||||
-- 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 Lib.true -- OUT: "(t t)"
|
exampleOne = toSource true -- OUT: "(t t)"
|
||||||
exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||||
|
69
lib/base.tri
69
lib/base.tri
@ -15,6 +15,8 @@ y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
|
|||||||
(\x : x x)
|
(\x : x x)
|
||||||
(\a0 a1 a2 : t (t a0) (t t a2) a1))
|
(\a0 a1 a2 : t (t a0) (t t a2) a1))
|
||||||
|
|
||||||
|
compose = \f g x : f (g x)
|
||||||
|
|
||||||
triage = \leaf stem fork : t (t leaf stem) fork
|
triage = \leaf stem fork : t (t leaf stem) fork
|
||||||
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
||||||
|
|
||||||
@ -35,7 +37,14 @@ emptyList? = matchList true (\_ _ : false)
|
|||||||
head = matchList t (\head _ : head)
|
head = matchList t (\head _ : head)
|
||||||
tail = matchList t (\_ tail : tail)
|
tail = matchList t (\_ tail : tail)
|
||||||
|
|
||||||
lconcat = y (\self : matchList
|
or? = (\x y :
|
||||||
|
matchBool
|
||||||
|
(matchBool (t t) (t t) y)
|
||||||
|
(matchBool (t t) 0 y)
|
||||||
|
x)
|
||||||
|
xor? = matchBool id not?
|
||||||
|
|
||||||
|
append = y (\self : matchList
|
||||||
(\k : k)
|
(\k : k)
|
||||||
(\h r k : pair h (self r k)))
|
(\h r k : pair h (self r k)))
|
||||||
|
|
||||||
@ -71,6 +80,10 @@ equal? = y (\self : triage
|
|||||||
(\_ : false)
|
(\_ : false)
|
||||||
(\bx by : lAnd (self ax bx) (self ay by))))
|
(\bx by : lAnd (self ax bx) (self ay by))))
|
||||||
|
|
||||||
|
lExist? = y (\self x : matchList
|
||||||
|
false
|
||||||
|
(\h z : or? (equal? x h) (self x z)))
|
||||||
|
|
||||||
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)))
|
||||||
@ -81,3 +94,57 @@ 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
|
||||||
|
|
||||||
|
succ = y (\self :
|
||||||
|
triage
|
||||||
|
1
|
||||||
|
t
|
||||||
|
(triage
|
||||||
|
(t (t t))
|
||||||
|
(\_ tail : t t (self tail))
|
||||||
|
t))
|
||||||
|
|
||||||
|
length = y (\self : matchList
|
||||||
|
0
|
||||||
|
(\_ tail : succ (self tail)))
|
||||||
|
|
||||||
|
reverse = y (\self : matchList
|
||||||
|
t
|
||||||
|
(\head tail : append (self tail) (pair head t)))
|
||||||
|
|
||||||
|
snoc = y (\self x : matchList
|
||||||
|
(pair x t)
|
||||||
|
(\h z : pair h (self x z)))
|
||||||
|
|
||||||
|
count = y (\self x : matchList
|
||||||
|
0
|
||||||
|
(\h z : matchBool
|
||||||
|
(succ (self x z))
|
||||||
|
(self x z)
|
||||||
|
(equal? x h)))
|
||||||
|
|
||||||
|
last = y (\self : matchList
|
||||||
|
t
|
||||||
|
(\hd tl : matchBool
|
||||||
|
hd
|
||||||
|
(self tl)
|
||||||
|
(emptyList? tl)))
|
||||||
|
|
||||||
|
all? = y (\self pred : matchList
|
||||||
|
true
|
||||||
|
(\h z : and? (pred h) (self pred z)))
|
||||||
|
|
||||||
|
any? = y (\self pred : matchList
|
||||||
|
false
|
||||||
|
(\h z : or? (pred h) (self pred z)))
|
||||||
|
|
||||||
|
unique_ = y (\self seen : matchList
|
||||||
|
t
|
||||||
|
(\head rest : matchBool
|
||||||
|
(self seen rest)
|
||||||
|
(pair head (self (pair head seen) rest))
|
||||||
|
(lExist? head seen)))
|
||||||
|
unique = \xs : unique_ t xs
|
||||||
|
|
||||||
|
intersect = \xs ys : filter (\x : lExist? x ys) xs
|
||||||
|
union = \xs ys : unique (append xs ys)
|
||||||
|
10
src/Eval.hs
10
src/Eval.hs
@ -70,12 +70,10 @@ elimLambda = go
|
|||||||
| body == triageBody = _TRIAGE
|
| body == triageBody = _TRIAGE
|
||||||
where
|
where
|
||||||
triageBody =
|
triageBody =
|
||||||
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
|
SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
|
||||||
-- Composition optimization
|
-- Composition optimization
|
||||||
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
||||||
| body == composeBody = _COMPOSE
|
| body == SApp (SVar f) (SApp (SVar g) (SVar x)) = _B
|
||||||
where
|
|
||||||
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
|
|
||||||
-- General elimination
|
-- General elimination
|
||||||
go (SLambda (v:vs) body)
|
go (SLambda (v:vs) body)
|
||||||
| null vs = toSKI v (elimLambda body)
|
| null vs = toSKI v (elimLambda body)
|
||||||
@ -96,8 +94,8 @@ elimLambda = go
|
|||||||
_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"
|
||||||
|
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||||
_TRIAGE = parseSingle "t (t (t t (t (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 :: String -> TricuAST -> Bool
|
||||||
isFree x = Set.member x . freeVars
|
isFree x = Set.member x . freeVars
|
||||||
@ -108,7 +106,7 @@ 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 (SDef _ _ 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
|
||||||
|
145
src/FileEval.hs
145
src/FileEval.hs
@ -16,14 +16,11 @@ evaluateFileResult :: FilePath -> IO T
|
|||||||
evaluateFileResult filePath = do
|
evaluateFileResult filePath = do
|
||||||
contents <- readFile filePath
|
contents <- readFile filePath
|
||||||
let tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
let moduleName = case parseProgram tokens of
|
|
||||||
Right ((SModule name) : _) -> name
|
|
||||||
_ -> ""
|
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right _ -> do
|
Right ast -> do
|
||||||
ast <- preprocessFile filePath
|
ast <- preprocessFile filePath
|
||||||
let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
|
let finalEnv = evalTricu Map.empty ast
|
||||||
case Map.lookup "main" finalEnv of
|
case Map.lookup "main" finalEnv of
|
||||||
Just finalResult -> return finalResult
|
Just finalResult -> return finalResult
|
||||||
Nothing -> errorWithoutStackTrace "No `main` function detected"
|
Nothing -> errorWithoutStackTrace "No `main` function detected"
|
||||||
@ -32,37 +29,24 @@ evaluateFile :: FilePath -> IO Env
|
|||||||
evaluateFile filePath = do
|
evaluateFile filePath = do
|
||||||
contents <- readFile filePath
|
contents <- readFile filePath
|
||||||
let tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
let moduleName = case parseProgram tokens of
|
|
||||||
Right ((SModule name) : _) -> name
|
|
||||||
_ -> ""
|
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right _ -> do
|
Right ast -> do
|
||||||
ast <- preprocessFile filePath
|
ast <- preprocessFile filePath
|
||||||
pure $ mainAlias moduleName $ evalTricu Map.empty ast
|
pure $ 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 tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
let moduleName = case parseProgram tokens of
|
|
||||||
Right ((SModule name) : _) -> name
|
|
||||||
_ -> ""
|
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right _ -> do
|
Right ast -> do
|
||||||
ast <- preprocessFile filePath
|
ast <- preprocessFile filePath
|
||||||
pure $ mainAlias moduleName $ evalTricu env ast
|
pure $ 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 -> IO [TricuAST]
|
||||||
preprocessFile filePath = preprocessFile' Set.empty filePath
|
preprocessFile = preprocessFile' Set.empty
|
||||||
|
|
||||||
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
|
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
|
||||||
preprocessFile' inProgress filePath
|
preprocessFile' inProgress filePath
|
||||||
@ -74,77 +58,84 @@ preprocessFile' inProgress filePath
|
|||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right asts -> do
|
Right asts -> do
|
||||||
let (moduleName, restAST) = extractModule asts
|
let (imports, nonImports) = partition isImport asts
|
||||||
let (imports, nonImports) = partition isImport restAST
|
|
||||||
let newInProgress = Set.insert filePath inProgress
|
let newInProgress = Set.insert filePath inProgress
|
||||||
importedASTs <- concat <$> mapM (processImport newInProgress) imports
|
importedASTs <- concat <$>
|
||||||
let namespacedAST = namespaceDefinitions moduleName nonImports
|
mapM (processImport newInProgress "") imports
|
||||||
pure $ importedASTs ++ namespacedAST
|
pure $ importedASTs ++ nonImports
|
||||||
where
|
where
|
||||||
extractModule :: [TricuAST] -> (String, [TricuAST])
|
|
||||||
extractModule ((SModule name) : xs) = (name, xs)
|
|
||||||
extractModule xs = ("", xs)
|
|
||||||
|
|
||||||
isImport :: TricuAST -> Bool
|
isImport :: TricuAST -> Bool
|
||||||
isImport (SImport _ _) = True
|
isImport (SImport _ _) = True
|
||||||
isImport _ = False
|
isImport _ = False
|
||||||
|
|
||||||
processImport :: Set.Set FilePath -> TricuAST -> IO [TricuAST]
|
processImport :: Set.Set FilePath -> String -> TricuAST -> IO [TricuAST]
|
||||||
processImport inProgress (SImport filePath moduleName) = do
|
processImport prog currentModule (SImport path "!Local") = do
|
||||||
importedAST <- preprocessFile' inProgress filePath
|
ast <- preprocessFile' prog path
|
||||||
pure $ namespaceDefinitions moduleName importedAST
|
let defs = filter (not . isImport) ast
|
||||||
processImport _ _ = error "Unexpected non-import in processImport"
|
pure $ map (nsDefinition currentModule) defs
|
||||||
|
processImport prog _ (SImport path name) = do
|
||||||
|
ast <- preprocessFile' prog path
|
||||||
|
let defs = filter (not . isImport) ast
|
||||||
|
pure $ map (nsDefinition name) defs
|
||||||
|
processImport _ _ _ = error "Unexpected non-import in processImport"
|
||||||
|
|
||||||
namespaceDefinitions :: String -> [TricuAST] -> [TricuAST]
|
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
|
||||||
namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
|
nsDefinitions moduleName = map (nsDefinition moduleName)
|
||||||
|
|
||||||
namespaceDefinition :: String -> TricuAST -> TricuAST
|
nsDefinition :: String -> TricuAST -> TricuAST
|
||||||
namespaceDefinition "" def = def
|
nsDefinition "" def = def
|
||||||
namespaceDefinition moduleName (SDef name args body)
|
nsDefinition moduleName (SDef name args body)
|
||||||
| isPrefixed name = SDef name args (namespaceBody moduleName body)
|
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||||
| otherwise = SDef (namespaceVariable moduleName name)
|
| otherwise = SDef (nsVariable moduleName name)
|
||||||
args (namespaceBody moduleName body)
|
args (nsBody moduleName body)
|
||||||
namespaceDefinition moduleName other =
|
nsDefinition moduleName other =
|
||||||
namespaceBody moduleName other
|
nsBody moduleName other
|
||||||
|
|
||||||
namespaceBody :: String -> TricuAST -> TricuAST
|
nsBody :: String -> TricuAST -> TricuAST
|
||||||
namespaceBody moduleName (SVar name)
|
nsBody moduleName (SVar name)
|
||||||
| isPrefixed name = SVar name
|
| isPrefixed name = SVar name
|
||||||
| otherwise = SVar (namespaceVariable moduleName name)
|
| otherwise = SVar (nsVariable moduleName name)
|
||||||
namespaceBody moduleName (SApp func arg) =
|
nsBody moduleName (SApp func arg) =
|
||||||
SApp (namespaceBody moduleName func) (namespaceBody moduleName arg)
|
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
||||||
namespaceBody moduleName (SLambda args body) =
|
nsBody moduleName (SLambda args body) =
|
||||||
SLambda args (namespaceBodyScoped moduleName args body)
|
SLambda args (nsBodyScoped moduleName args body)
|
||||||
namespaceBody moduleName (SList items) =
|
nsBody moduleName (SList items) =
|
||||||
SList (map (namespaceBody moduleName) items)
|
SList (map (nsBody moduleName) items)
|
||||||
namespaceBody moduleName (TFork left right) =
|
nsBody moduleName (TFork left right) =
|
||||||
TFork (namespaceBody moduleName left) (namespaceBody moduleName right)
|
TFork (nsBody moduleName left) (nsBody moduleName right)
|
||||||
namespaceBody moduleName (TStem subtree) =
|
nsBody moduleName (TStem subtree) =
|
||||||
TStem (namespaceBody moduleName subtree)
|
TStem (nsBody moduleName subtree)
|
||||||
namespaceBody moduleName (SDef name args body)
|
nsBody moduleName (SDef name args body)
|
||||||
| isPrefixed name = SDef name args (namespaceBody moduleName body)
|
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||||
| otherwise = SDef (namespaceVariable moduleName name)
|
| otherwise = SDef (nsVariable moduleName name)
|
||||||
args (namespaceBody moduleName body)
|
args (nsBody moduleName body)
|
||||||
namespaceBody _ other = other
|
nsBody _ other = other
|
||||||
|
|
||||||
namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||||
namespaceBodyScoped moduleName args body = case body of
|
nsBodyScoped moduleName args body = case body of
|
||||||
SVar name ->
|
SVar name ->
|
||||||
if name `elem` args
|
if name `elem` args
|
||||||
then SVar name
|
then SVar name
|
||||||
else namespaceBody moduleName (SVar name)
|
else nsBody moduleName (SVar name)
|
||||||
SApp func arg -> SApp (namespaceBodyScoped moduleName args func) (namespaceBodyScoped moduleName args arg)
|
SApp func arg ->
|
||||||
SLambda innerArgs innerBody -> SLambda innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
|
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
||||||
SList items -> SList (map (namespaceBodyScoped moduleName args) items)
|
SLambda innerArgs innerBody ->
|
||||||
TFork left right -> TFork (namespaceBodyScoped moduleName args left) (namespaceBodyScoped moduleName args right)
|
SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||||
TStem subtree -> TStem (namespaceBodyScoped moduleName args subtree)
|
SList items ->
|
||||||
|
SList (map (nsBodyScoped moduleName args) items)
|
||||||
|
TFork left right ->
|
||||||
|
TFork (nsBodyScoped moduleName args left)
|
||||||
|
(nsBodyScoped moduleName args right)
|
||||||
|
TStem subtree ->
|
||||||
|
TStem (nsBodyScoped moduleName args subtree)
|
||||||
SDef name innerArgs innerBody ->
|
SDef name innerArgs innerBody ->
|
||||||
SDef (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
|
SDef (nsVariable moduleName name) innerArgs
|
||||||
|
(nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||||
other -> other
|
other -> other
|
||||||
|
|
||||||
isPrefixed :: String -> Bool
|
isPrefixed :: String -> Bool
|
||||||
isPrefixed name = '.' `elem` name
|
isPrefixed name = '.' `elem` name
|
||||||
|
|
||||||
namespaceVariable :: String -> String -> String
|
nsVariable :: String -> String -> String
|
||||||
namespaceVariable "" name = name
|
nsVariable "" name = name
|
||||||
namespaceVariable moduleName name = moduleName ++ "." ++ name
|
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||||
|
122
src/Lexer.hs
122
src/Lexer.hs
@ -12,39 +12,71 @@ import qualified Data.Set as Set
|
|||||||
|
|
||||||
type Lexer = Parsec Void String
|
type Lexer = Parsec Void String
|
||||||
|
|
||||||
|
tricuLexer :: Lexer [LToken]
|
||||||
|
tricuLexer = do
|
||||||
|
sc
|
||||||
|
header <- many $ do
|
||||||
|
tok <- choice
|
||||||
|
[ try lImport
|
||||||
|
, lnewline
|
||||||
|
]
|
||||||
|
sc
|
||||||
|
pure tok
|
||||||
|
tokens <- many $ do
|
||||||
|
tok <- choice tricuLexer'
|
||||||
|
sc
|
||||||
|
pure tok
|
||||||
|
sc
|
||||||
|
eof
|
||||||
|
pure (header ++ tokens)
|
||||||
|
where
|
||||||
|
tricuLexer' =
|
||||||
|
[ try lnewline
|
||||||
|
, try namespace
|
||||||
|
, try dot
|
||||||
|
, try identifier
|
||||||
|
, try keywordT
|
||||||
|
, try integerLiteral
|
||||||
|
, try stringLiteral
|
||||||
|
, assign
|
||||||
|
, colon
|
||||||
|
, backslash
|
||||||
|
, openParen
|
||||||
|
, closeParen
|
||||||
|
, openBracket
|
||||||
|
, closeBracket
|
||||||
|
]
|
||||||
|
|
||||||
|
lexTricu :: String -> [LToken]
|
||||||
|
lexTricu input = case runParser tricuLexer "" input of
|
||||||
|
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
||||||
|
Right tokens -> tokens
|
||||||
|
|
||||||
|
|
||||||
keywordT :: Lexer LToken
|
keywordT :: Lexer LToken
|
||||||
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
||||||
|
|
||||||
identifier :: Lexer LToken
|
identifier :: Lexer LToken
|
||||||
identifier = do
|
identifier = do
|
||||||
first <- letterChar <|> char '_'
|
first <- lowerChar <|> char '_'
|
||||||
rest <- many $ letterChar
|
rest <- many $ letterChar
|
||||||
<|> digitChar
|
<|> digitChar <|> 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
|
namespace :: Lexer LToken
|
||||||
integerLiteral = do
|
namespace = do
|
||||||
num <- some digitChar
|
name <- try (string "!Local") <|> do
|
||||||
return (LIntegerLiteral (read num))
|
first <- upperChar
|
||||||
|
rest <- many (letterChar <|> digitChar)
|
||||||
|
return (first:rest)
|
||||||
|
return (LNamespace name)
|
||||||
|
|
||||||
stringLiteral :: Lexer LToken
|
dot :: Lexer LToken
|
||||||
stringLiteral = do
|
dot = char '.' *> pure LDot
|
||||||
char '"'
|
|
||||||
content <- many (noneOf ['"'])
|
|
||||||
char '"' --"
|
|
||||||
return (LStringLiteral content)
|
|
||||||
|
|
||||||
lModule :: Lexer LToken
|
|
||||||
lModule = do
|
|
||||||
_ <- string "!module"
|
|
||||||
space1
|
|
||||||
LIdentifier moduleName <- identifier
|
|
||||||
return (LModule moduleName)
|
|
||||||
|
|
||||||
lImport :: Lexer LToken
|
lImport :: Lexer LToken
|
||||||
lImport = do
|
lImport = do
|
||||||
@ -52,7 +84,7 @@ lImport = do
|
|||||||
space1
|
space1
|
||||||
LStringLiteral path <- stringLiteral
|
LStringLiteral path <- stringLiteral
|
||||||
space1
|
space1
|
||||||
LIdentifier name <- identifier
|
LNamespace name <- namespace
|
||||||
return (LImport path name)
|
return (LImport path name)
|
||||||
|
|
||||||
assign :: Lexer LToken
|
assign :: Lexer LToken
|
||||||
@ -85,41 +117,15 @@ sc = space
|
|||||||
(skipLineComment "--")
|
(skipLineComment "--")
|
||||||
(skipBlockComment "|-" "-|")
|
(skipBlockComment "|-" "-|")
|
||||||
|
|
||||||
tricuLexer :: Lexer [LToken]
|
integerLiteral :: Lexer LToken
|
||||||
tricuLexer = do
|
integerLiteral = do
|
||||||
sc
|
num <- some digitChar
|
||||||
header <- many $ do
|
return (LIntegerLiteral (read num))
|
||||||
tok <- choice
|
|
||||||
[ try lModule
|
stringLiteral :: Lexer LToken
|
||||||
, try lImport
|
stringLiteral = do
|
||||||
, lnewline
|
char '"'
|
||||||
]
|
content <- many (noneOf ['"'])
|
||||||
sc
|
char '"' --"
|
||||||
pure tok
|
return (LStringLiteral content)
|
||||||
tokens <- many $ do
|
|
||||||
tok <- choice tricuLexer'
|
|
||||||
sc
|
|
||||||
pure tok
|
|
||||||
sc
|
|
||||||
eof
|
|
||||||
pure (header ++ tokens)
|
|
||||||
where
|
|
||||||
tricuLexer' =
|
|
||||||
[ try lnewline
|
|
||||||
, try identifier
|
|
||||||
, try keywordT
|
|
||||||
, try integerLiteral
|
|
||||||
, try stringLiteral
|
|
||||||
, assign
|
|
||||||
, colon
|
|
||||||
, backslash
|
|
||||||
, openParen
|
|
||||||
, closeParen
|
|
||||||
, openBracket
|
|
||||||
, closeBracket
|
|
||||||
]
|
|
||||||
|
|
||||||
lexTricu :: String -> [LToken]
|
|
||||||
lexTricu input = case runParser tricuLexer "" input of
|
|
||||||
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
|
||||||
Right tokens -> tokens
|
|
||||||
|
@ -8,7 +8,9 @@ import Research
|
|||||||
|
|
||||||
import Control.Monad (foldM)
|
import Control.Monad (foldM)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Data.Version (showVersion)
|
||||||
import Text.Megaparsec (runParser)
|
import Text.Megaparsec (runParser)
|
||||||
|
import Paths_tricu (version)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
@ -52,10 +54,12 @@ decodeMode = TDecode
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
||||||
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
||||||
&= help "tricu: Exploring Tree Calculus"
|
&= help "tricu: Exploring Tree Calculus"
|
||||||
&= program "tricu"
|
&= program "tricu"
|
||||||
&= summary "tricu Evaluator and REPL"
|
&= summary versionStr
|
||||||
|
&= versionArg [explicit, name "version", summary versionStr]
|
||||||
case args of
|
case args of
|
||||||
Repl -> do
|
Repl -> do
|
||||||
putStrLn "Welcome to the tricu REPL"
|
putStrLn "Welcome to the tricu REPL"
|
||||||
|
@ -73,8 +73,6 @@ parseSingle input =
|
|||||||
|
|
||||||
parseProgramM :: ParserM [TricuAST]
|
parseProgramM :: ParserM [TricuAST]
|
||||||
parseProgramM = do
|
parseProgramM = do
|
||||||
skipMany topLevelNewline
|
|
||||||
moduleNode <- optional parseModuleM
|
|
||||||
skipMany topLevelNewline
|
skipMany topLevelNewline
|
||||||
importNodes <- many (do
|
importNodes <- many (do
|
||||||
node <- parseImportM
|
node <- parseImportM
|
||||||
@ -83,16 +81,7 @@ parseProgramM = do
|
|||||||
skipMany topLevelNewline
|
skipMany topLevelNewline
|
||||||
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
||||||
skipMany topLevelNewline
|
skipMany topLevelNewline
|
||||||
return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
|
return (importNodes ++ exprs)
|
||||||
|
|
||||||
|
|
||||||
parseModuleM :: ParserM TricuAST
|
|
||||||
parseModuleM = do
|
|
||||||
LModule moduleName <- satisfyM isModule
|
|
||||||
pure (SModule moduleName)
|
|
||||||
where
|
|
||||||
isModule (LModule _) = True
|
|
||||||
isModule _ = False
|
|
||||||
|
|
||||||
parseImportM :: ParserM TricuAST
|
parseImportM :: ParserM TricuAST
|
||||||
parseImportM = do
|
parseImportM = do
|
||||||
@ -266,12 +255,19 @@ parseSingleItemM = do
|
|||||||
|
|
||||||
parseVarM :: ParserM TricuAST
|
parseVarM :: ParserM TricuAST
|
||||||
parseVarM = do
|
parseVarM = do
|
||||||
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
|
token <- satisfyM (\case
|
||||||
|
LNamespace _ -> True
|
||||||
|
LIdentifier _ -> True
|
||||||
|
_ -> False)
|
||||||
|
case token of
|
||||||
|
LNamespace ns -> do
|
||||||
|
_ <- satisfyM (== LDot)
|
||||||
|
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
|
||||||
|
pure $ SVar (ns ++ "." ++ name)
|
||||||
LIdentifier name
|
LIdentifier name
|
||||||
| name == "t" || name == "!result" ->
|
| name == "t" || name == "!result" ->
|
||||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||||
| otherwise ->
|
| otherwise -> pure (SVar name)
|
||||||
pure (SVar name)
|
|
||||||
_ -> fail "Unexpected token while parsing variable"
|
_ -> fail "Unexpected token while parsing variable"
|
||||||
|
|
||||||
parseIntLiteralM :: ParserM TricuAST
|
parseIntLiteralM :: ParserM TricuAST
|
||||||
|
54
src/REPL.hs
54
src/REPL.hs
@ -10,51 +10,65 @@ import Control.Exception (SomeException, catch)
|
|||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad.Catch (handle, MonadCatch)
|
import Control.Monad.Catch (handle, MonadCatch)
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.List (dropWhile, dropWhileEnd, intercalate)
|
import Data.List ( dropWhile
|
||||||
|
, dropWhileEnd
|
||||||
|
, intercalate
|
||||||
|
, isPrefixOf)
|
||||||
import System.Console.Haskeline
|
import System.Console.Haskeline
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
repl :: Env -> IO ()
|
repl :: Env -> IO ()
|
||||||
repl env = runInputT defaultSettings (withInterrupt (loop env))
|
repl env = runInputT defaultSettings (withInterrupt (loop env True))
|
||||||
where
|
where
|
||||||
loop :: Env -> InputT IO ()
|
loop :: Env -> Bool -> InputT IO ()
|
||||||
loop env = handle (interruptHandler env) $ do
|
loop env decode = handle (interruptHandler env decode) $ do
|
||||||
minput <- getInputLine "tricu < "
|
minput <- getInputLine "tricu < "
|
||||||
case minput of
|
case minput of
|
||||||
Nothing -> outputStrLn "Exiting tricu"
|
Nothing -> outputStrLn "Exiting tricu"
|
||||||
Just s
|
Just s
|
||||||
|
| strip s == "" -> loop env decode
|
||||||
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
||||||
| strip s == "" -> loop env
|
| strip s == "!decode" -> do
|
||||||
| strip s == "!import" -> do
|
outputStrLn $ "Decoding " ++ (if decode then "disabled" else "enabled")
|
||||||
|
loop env (not decode)
|
||||||
|
| "!import" `isPrefixOf` strip s -> do
|
||||||
|
let afterImport = dropWhile (== ' ') $ drop (length ("!import" :: String)) (strip s)
|
||||||
|
if not (null afterImport)
|
||||||
|
then outputStrLn "Warning: REPL imports are interactive; \
|
||||||
|
\additional arguments are ignored."
|
||||||
|
else pure ()
|
||||||
path <- getInputLine "File path to load < "
|
path <- getInputLine "File path to load < "
|
||||||
case path of
|
case path of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
outputStrLn "No input received; stopping import."
|
outputStrLn "No input received; stopping import."
|
||||||
loop env
|
loop env decode
|
||||||
Just p -> do
|
Just p -> do
|
||||||
loadedEnv <- liftIO $ evaluateFileWithContext env
|
loadedEnv <- liftIO $ evaluateFileWithContext env
|
||||||
(strip p) `catch` \e -> errorHandler env e
|
(strip p) `catch` \e -> errorHandler env e
|
||||||
loop $ Map.delete "!result" (Map.union loadedEnv env)
|
loop (Map.delete "!result" (Map.union loadedEnv env)) decode
|
||||||
| take 2 s == "--" -> loop env
|
| take 2 s == "--" -> loop env decode
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
newEnv <- liftIO $ processInput env s `catch` errorHandler env
|
newEnv <- liftIO $ processInput env s decode `catch` errorHandler env
|
||||||
loop newEnv
|
loop newEnv decode
|
||||||
|
|
||||||
interruptHandler :: Env -> Interrupt -> InputT IO ()
|
interruptHandler :: Env -> Bool -> Interrupt -> InputT IO ()
|
||||||
interruptHandler env _ = do
|
interruptHandler env decode _ = do
|
||||||
outputStrLn "Interrupted with CTRL+C\n\
|
outputStrLn "Interrupted with CTRL+C\n\
|
||||||
\You can use the !exit command or CTRL+D to exit"
|
\You can use the !exit command or CTRL+D to exit"
|
||||||
loop env
|
loop env decode
|
||||||
|
|
||||||
processInput :: Env -> String -> IO Env
|
processInput :: Env -> String -> Bool -> IO Env
|
||||||
processInput env input = do
|
processInput env input decode = do
|
||||||
let asts = parseTricu input
|
let asts = parseTricu input
|
||||||
newEnv = evalTricu env asts
|
newEnv = evalTricu env asts
|
||||||
if
|
case Map.lookup "!result" newEnv of
|
||||||
| Just r <- Map.lookup "!result" newEnv -> do
|
Just r -> do
|
||||||
putStrLn $ "tricu > " ++ decodeResult r
|
putStrLn $ "tricu > " ++
|
||||||
| otherwise -> return ()
|
if decode
|
||||||
|
then decodeResult r
|
||||||
|
else show r
|
||||||
|
Nothing -> pure ()
|
||||||
return newEnv
|
return newEnv
|
||||||
|
|
||||||
errorHandler :: Env -> SomeException -> IO (Env)
|
errorHandler :: Env -> SomeException -> IO (Env)
|
||||||
|
@ -26,7 +26,6 @@ data TricuAST
|
|||||||
| TFork TricuAST TricuAST
|
| TFork TricuAST TricuAST
|
||||||
| SLambda [String] TricuAST
|
| SLambda [String] TricuAST
|
||||||
| SEmpty
|
| SEmpty
|
||||||
| SModule String
|
|
||||||
| SImport String String
|
| SImport String String
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
@ -34,17 +33,18 @@ data TricuAST
|
|||||||
data LToken
|
data LToken
|
||||||
= LKeywordT
|
= LKeywordT
|
||||||
| LIdentifier String
|
| LIdentifier String
|
||||||
|
| LNamespace String
|
||||||
| LIntegerLiteral Int
|
| LIntegerLiteral Int
|
||||||
| LStringLiteral String
|
| LStringLiteral String
|
||||||
| LAssign
|
| LAssign
|
||||||
| LColon
|
| LColon
|
||||||
|
| LDot
|
||||||
| LBackslash
|
| LBackslash
|
||||||
| LOpenParen
|
| LOpenParen
|
||||||
| LCloseParen
|
| LCloseParen
|
||||||
| LOpenBracket
|
| LOpenBracket
|
||||||
| LCloseBracket
|
| LCloseBracket
|
||||||
| LNewline
|
| LNewline
|
||||||
| LModule String
|
|
||||||
| LImport String String
|
| LImport String String
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
@ -468,7 +468,7 @@ baseLibrary = testGroup "Library Tests"
|
|||||||
|
|
||||||
, testCase "Concatenate strings" $ do
|
, testCase "Concatenate strings" $ do
|
||||||
library <- evaluateFile "./lib/base.tri"
|
library <- evaluateFile "./lib/base.tri"
|
||||||
let input = "lconcat \"Hello, \" \"world!\""
|
let input = "append \"Hello, \" \"world!\""
|
||||||
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
||||||
env @?= "\"Hello, world!\""
|
env @?= "\"Hello, world!\""
|
||||||
|
|
||||||
@ -532,6 +532,9 @@ modules = testGroup "Test modules"
|
|||||||
, testCase "Lambda expression namespaces" $ do
|
, testCase "Lambda expression namespaces" $ do
|
||||||
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
|
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
|
||||||
res @?= Leaf
|
res @?= Leaf
|
||||||
|
, testCase "Local namespace import chain" $ do
|
||||||
|
res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
|
||||||
|
res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
@ -1 +0,0 @@
|
|||||||
t (t (t (t (t t) (t t t)) t) t t) t
|
|
@ -1 +0,0 @@
|
|||||||
x = t (t t) t
|
|
@ -1,4 +1,3 @@
|
|||||||
!module Cycle
|
|
||||||
|
|
||||||
!import "test/cycle-2.tri" Cycle2
|
!import "test/cycle-2.tri" Cycle2
|
||||||
|
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
!module Cycle2
|
|
||||||
|
|
||||||
!import "test/cycle-1.tri" Cycle1
|
!import "test/cycle-1.tri" Cycle1
|
||||||
|
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module A
|
|
||||||
main = (\x : x) t
|
main = (\x : x) t
|
||||||
|
4
test/local-ns/1.tri
Normal file
4
test/local-ns/1.tri
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
|
||||||
|
!import "test/local-ns/2.tri" Two
|
||||||
|
|
||||||
|
main = Two.x
|
2
test/local-ns/2.tri
Normal file
2
test/local-ns/2.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
|
||||||
|
!import "test/local-ns/3.tri" !Local
|
2
test/local-ns/3.tri
Normal file
2
test/local-ns/3.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
|
||||||
|
x = 3
|
@ -1,2 +1,2 @@
|
|||||||
x = map (\i : lconcat "Successfully concatenated " i) [("two strings!")]
|
x = map (\i : append "Successfully concatenated " i) [("two strings!")]
|
||||||
main = equal? x [("Successfully concatenated two strings!")]
|
main = equal? x [("Successfully concatenated two strings!")]
|
||||||
|
@ -1,5 +0,0 @@
|
|||||||
!module Test
|
|
||||||
|
|
||||||
!import "lib/base.tri" Lib
|
|
||||||
|
|
||||||
main = Lib.not? t
|
|
@ -1 +0,0 @@
|
|||||||
n = t t t
|
|
@ -1,3 +1,2 @@
|
|||||||
!module A
|
|
||||||
!import "./test/multi-level-B.tri" B
|
!import "./test/multi-level-B.tri" B
|
||||||
main = B.main
|
main = B.main
|
||||||
|
@ -1,3 +1,2 @@
|
|||||||
!module B
|
|
||||||
!import "./test/multi-level-C.tri" C
|
!import "./test/multi-level-C.tri" C
|
||||||
main = C.val
|
main = C.val
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module C
|
|
||||||
val = t
|
val = t
|
||||||
|
7
test/named-imports/1.tri
Normal file
7
test/named-imports/1.tri
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
|
||||||
|
!import "lib/base.tri"
|
||||||
|
|
||||||
|
!import "test/named-imports/2.tri"
|
||||||
|
!import "test/named-imports/3.tri" ThreeRenamed
|
||||||
|
|
||||||
|
main = equal? (equal? Two.x 2) (equal? ThreeRenamed.x 3)
|
2
test/named-imports/2.tri
Normal file
2
test/named-imports/2.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
|
||||||
|
x = 2
|
2
test/named-imports/3.tri
Normal file
2
test/named-imports/3.tri
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
|
||||||
|
x = 3
|
@ -1,3 +1,2 @@
|
|||||||
!module A
|
|
||||||
!import "./test/namespace-B.tri" B
|
!import "./test/namespace-B.tri" B
|
||||||
main = B.x
|
main = B.x
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module B
|
|
||||||
x = t
|
x = t
|
||||||
|
@ -1 +1 @@
|
|||||||
head (map (\i : lconcat "String " i) [("test!")])
|
head (map (\i : append "String " i) [("test!")])
|
||||||
|
@ -1 +0,0 @@
|
|||||||
namedTerm = undefinedForTesting
|
|
@ -1,2 +1 @@
|
|||||||
!module A
|
|
||||||
main = undefinedVar
|
main = undefinedVar
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
!module A
|
|
||||||
|
|
||||||
!import "./test/vars-B.tri" B
|
!import "./test/vars-B.tri" B
|
||||||
|
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module B
|
|
||||||
y = \x : x
|
y = \x : x
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module C
|
|
||||||
z = t
|
z = t
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
name: tricu
|
name: tricu
|
||||||
version: 0.12.0
|
version: 0.13.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