4 Commits

Author SHA1 Message Date
1a9a4494e0 Caller-relative imports; smart deduping in imports
All checks were successful
Test, Build, and Release / test (push) Successful in 1m35s
Test, Build, and Release / build (push) Successful in 1m13s
2025-01-30 17:56:46 -06:00
a16a24a808 Replace placeholder xor? library function 2025-01-30 17:17:07 -06:00
7d1b6a741d REPL import warning; version info in CLI
All checks were successful
Test, Build, and Release / test (push) Successful in 1m18s
Test, Build, and Release / build (push) Successful in 1m13s
Adds the ability to toggle result decoding in REPL. Adds several more
useful functions to the base library.
2025-01-30 16:33:36 -06:00
bf1000d174 Rework module system
All checks were successful
Test, Build, and Release / test (push) Successful in 1m37s
Test, Build, and Release / build (push) Successful in 1m14s
Don't require/allow naming a module, instead require that the importer
names it. Allow importing into the local scope with the name !Local.
Simplify namespacing logic. Updates all tests to reflect these changes.
2025-01-30 13:56:09 -06:00
41 changed files with 441 additions and 398 deletions

View File

@ -2,7 +2,9 @@
## 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)`.
@ -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)`
- List, Number, and String literals: `[(2) ("Hello")]`
- 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)
- 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 < 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 < id (head (map (\i : lconcat i " world!") [("Hello, ")]))
tricu < id (head (map (\i : append i " world!") [("Hello, ")]))
tricu > "Hello, world!"
tricu < -- Intensionality! We can inspect the structure of a function or data.

View File

@ -1,6 +1,5 @@
!module Equality
!import "lib/base.tri" Lib
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
main = lambdaEqualsTC
@ -28,7 +27,7 @@ not_Lambda? = demo_matchBool demo_false demo_true
-- to different tree representations even if they share extensional behavior.
-- 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:
true_TC? = not_TC? demo_false
@ -37,5 +36,5 @@ false_TC? = not_TC? demo_true
true_Lambda? = not_Lambda? demo_false
false_Lambda? = not_Lambda? demo_true
bothTrueEqual? = Lib.equal? true_TC? true_Lambda?
bothFalseEqual? = Lib.equal? false_TC? false_Lambda?
bothTrueEqual? = equal? true_TC? true_Lambda?
bothFalseEqual? = equal? false_TC? false_Lambda?

View File

@ -1,6 +1,5 @@
!module LOT
!import "lib/base.tri" Lib
!import "../lib/base.tri" Lib
!import "../lib/list.tri" !Local
main = exampleTwo
-- Level Order Traversal of a labelled binary tree
@ -19,41 +18,41 @@ main = exampleTwo
-- / / \
-- 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
(\node : Lib.not? (Lib.emptyList? node))
(Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
(pair (map label queue) (self (filter
(\node : not? (emptyList? node))
(append (map left queue) (map right queue))))))
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
(Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "")
(Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels))))))
(append
(append (map (\x : append x " ") (head levels)) "")
(if (emptyList? (tail levels)) "" (append (t (t 10 t) t) (self (tail levels))))))
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")
[("2") [("4") t t] t]

View File

@ -1,24 +1,12 @@
!module Size
!import "lib/base.tri" Lib
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
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 :
(Lib.y (\self x :
(y (\self x :
compose succ
(Lib.triage
(triage
(\x : x)
self
(\x y : compose (self x) (self y))

View File

@ -1,8 +1,7 @@
!module ToSource
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
!import "lib/base.tri" Lib
main = toSource Lib.not?
main = toSource not?
-- Thanks to intensionality, we can inspect the structure of a given value
-- even if it's a function. This includes lambdas which are eliminated to
-- Tree Calculus (TC) terms during evaluation.
@ -16,29 +15,29 @@ main = toSource Lib.not?
-- triage = (\leaf stem fork : t (t leaf stem) fork)
-- Base case of a single Leaf
sourceLeaf = t (Lib.head "t")
sourceLeaf = t (head "t")
-- Stem case
sourceStem = (\convert : (\a rest :
t (Lib.head "(") -- Start with a left parenthesis "(".
(t (Lib.head "t") -- Add a "t"
(t (Lib.head " ") -- Add a space.
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the argument.
(t (Lib.head ")") rest)))))) -- Close with ")" and append the rest.
(t (head ")") rest)))))) -- Close with ")" and append the rest.
-- Fork case
sourceFork = (\convert : (\a b rest :
t (Lib.head "(") -- Start with a left parenthesis "(".
(t (Lib.head "t") -- Add a "t"
(t (Lib.head " ") -- Add a space.
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the first arg.
(t (Lib.head " ") -- Add another space.
(t (head " ") -- Add another space.
(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
toSource_ = Lib.y (\self arg :
Lib.triage
toSource_ = y (\self arg :
triage
sourceLeaf -- `triage` "a" case, Leaf
(sourceStem self) -- `triage` "b" case, Stem
(sourceFork self) -- `triage` "c" case, Fork
@ -47,5 +46,5 @@ toSource_ = Lib.y (\self arg :
-- toSource takes a single TC term and returns a String
toSource = \v : toSource_ v ""
exampleOne = toSource Lib.true -- OUT: "(t t)"
exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

View File

@ -1,13 +1,8 @@
false = t
_ = t
true = t t
k = t t
i = t (t k) t
s = t (t (k t)) t
m = s i i
b = s (k s) k
c = s (s (k s) (s (k k) s)) (k k)
id = \a : a
const = \a b : a
pair = t
if = \cond then else : t (t else (t t then)) t cond
@ -15,6 +10,8 @@ y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
(\x : x x)
(\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
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
@ -24,21 +21,6 @@ matchBool = (\ot of : triage
(\_ _ : ot)
)
matchList = \a b : triage a _ b
matchPair = \a : triage _ _ a
not? = matchBool false true
and? = matchBool id (\_ : false)
emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
lconcat = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
lAnd = (triage
(\_ : false)
(\_ x : x)
@ -49,11 +31,22 @@ lOr = (triage
(\_ _ : true)
(\_ _ _ : true))
map_ = y (\self :
matchList
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = \f l : map_ l f
matchPair = \a : triage _ _ a
not? = matchBool false true
and? = matchBool id (\_ : false)
or? = (\x z :
matchBool
(matchBool true true z)
(matchBool true false z)
x)
xor? = (\x z :
matchBool
(matchBool false true z)
(matchBool true false z)
x)
equal? = y (\self : triage
(triage
@ -71,13 +64,11 @@ equal? = y (\self : triage
(\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
filter_ = y (\self : matchList
(\_ : t)
(\head tail f : matchBool (t head) i (f head) (self tail 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 = \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 = \f x l : foldr_ x f l
succ = y (\self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
t))

77
lib/list.tri Normal file
View File

@ -0,0 +1,77 @@
!import "base.tri" !Local
matchList = \a b : triage a _ b
emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
append = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
lExist? = y (\self x : matchList
false
(\h z : or? (equal? x h) (self x z)))
map_ = y (\self :
matchList
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = \f l : map_ l f
filter_ = y (\self : matchList
(\_ : t)
(\head tail f : matchBool (t head) id (f head) (self tail 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 = \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 = \f x l : foldr_ x f l
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)

View File

@ -70,12 +70,10 @@ elimLambda = go
| body == triageBody = _TRIAGE
where
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
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
| body == composeBody = _COMPOSE
where
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
| body == SApp (SVar f) (SApp (SVar g) (SVar x)) = _B
-- General elimination
go (SLambda (v:vs) body)
| null vs = toSKI v (elimLambda body)
@ -96,8 +94,8 @@ elimLambda = go
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "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"
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
@ -108,7 +106,7 @@ freeVars (SInt _ ) = Set.empty
freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty
freeVars TLeaf = Set.empty
freeVars (SDef _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
@ -143,18 +141,23 @@ reorderDefs env defs
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
buildDepGraph topDefs
| not (null duplicateNames) =
| not (null conflictingDefs) =
errorWithoutStackTrace $
"Duplicate definitions detected: " ++ show duplicateNames
"Conflicting definitions detected: " ++ show conflictingDefs
| 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
defsMap = Map.fromListWith (++)
[(name, [(name, body)]) | SDef name _ body <- topDefs]
conflictingDefs =
[ name
| (name, defs) <- Map.toList defsMap
, let bodies = map snd defs
, not $ all (== head bodies) (tail bodies)
]
sortDeps :: Map.Map String (Set.Set String) -> [String]
sortDeps graph = go [] Set.empty (Map.keys graph)

View File

@ -8,6 +8,7 @@ import Research
import Data.List (partition)
import Control.Monad (foldM)
import System.IO
import System.FilePath (takeDirectory, normalise, (</>))
import qualified Data.Map as Map
import qualified Data.Set as Set
@ -16,14 +17,11 @@ evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do
Right ast -> do
ast <- preprocessFile filePath
let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
let finalEnv = evalTricu Map.empty ast
case Map.lookup "main" finalEnv of
Just finalResult -> return finalResult
Nothing -> errorWithoutStackTrace "No `main` function detected"
@ -32,119 +30,120 @@ evaluateFile :: FilePath -> IO Env
evaluateFile filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do
Right ast -> do
ast <- preprocessFile filePath
pure $ mainAlias moduleName $ evalTricu Map.empty ast
pure $ evalTricu Map.empty ast
evaluateFileWithContext :: Env -> FilePath -> IO Env
evaluateFileWithContext env filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do
Right ast -> 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
pure $ evalTricu env ast
preprocessFile :: FilePath -> IO [TricuAST]
preprocessFile filePath = preprocessFile' Set.empty filePath
preprocessFile p = preprocessFile' Set.empty p p
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
preprocessFile' inProgress filePath
| filePath `Set.member` inProgress =
errorWithoutStackTrace $ "Encountered cyclic import: " ++ filePath
preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
preprocessFile' s b p
| p `Set.member` s =
errorWithoutStackTrace $ "Encountered cyclic import: " ++ p
| 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
c <- readFile p
let t = lexTricu c
case parseProgram t of
Left e -> errorWithoutStackTrace (handleParseError e)
Right a -> do
let (i, n) = partition isImp a
let s' = Set.insert p s
r <- concat <$>
mapM (procImp s' "" p) i
pure $ r ++ n
where
extractModule :: [TricuAST] -> (String, [TricuAST])
extractModule ((SModule name) : xs) = (name, xs)
extractModule xs = ("", xs)
isImp :: TricuAST -> Bool
isImp (SImport _ _) = True
isImp _ = False
isImport :: TricuAST -> Bool
isImport (SImport _ _) = True
isImport _ = False
procImp :: Set.Set FilePath -> String -> FilePath -> TricuAST -> IO [TricuAST]
procImp s m f (SImport p "!Local") = do
let ip = makeRelativeTo f p
a <- preprocessFile' s b ip
let d = filter (not . isImp) a
pure $ map (nsDefinition m) d
procImp s _ f (SImport p n) = do
let ip = makeRelativeTo f p
a <- preprocessFile' s b ip
let d = filter (not . isImp) a
pure $ map (nsDefinition n) d
procImp _ _ _ _ = error "Unexpected non-import in processImport"
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"
makeRelativeTo :: FilePath -> FilePath -> FilePath
makeRelativeTo f i =
let d = takeDirectory f
in normalise $ d </> i
namespaceDefinitions :: String -> [TricuAST] -> [TricuAST]
namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
nsDefinitions moduleName = map (nsDefinition 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
nsDefinition :: String -> TricuAST -> TricuAST
nsDefinition "" def = def
nsDefinition moduleName (SDef name args body)
| isPrefixed name = SDef name args (nsBody moduleName body)
| otherwise = SDef (nsVariable moduleName name)
args (nsBody moduleName body)
nsDefinition moduleName other =
nsBody moduleName other
namespaceBody :: String -> TricuAST -> TricuAST
namespaceBody moduleName (SVar name)
nsBody :: String -> TricuAST -> TricuAST
nsBody 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
| otherwise = SVar (nsVariable moduleName name)
nsBody moduleName (SApp func arg) =
SApp (nsBody moduleName func) (nsBody moduleName arg)
nsBody moduleName (SLambda args body) =
SLambda args (nsBodyScoped moduleName args body)
nsBody moduleName (SList items) =
SList (map (nsBody moduleName) items)
nsBody moduleName (TFork left right) =
TFork (nsBody moduleName left) (nsBody moduleName right)
nsBody moduleName (TStem subtree) =
TStem (nsBody moduleName subtree)
nsBody moduleName (SDef name args body)
| isPrefixed name = SDef name args (nsBody moduleName body)
| otherwise = SDef (nsVariable moduleName name)
args (nsBody moduleName body)
nsBody _ other = other
namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
namespaceBodyScoped moduleName args body = case body of
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
nsBodyScoped 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)
else nsBody moduleName (SVar name)
SApp func arg ->
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
SLambda innerArgs innerBody ->
SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
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 (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
SDef (nsVariable moduleName name) innerArgs
(nsBodyScoped 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
nsVariable :: String -> String -> String
nsVariable "" name = name
nsVariable moduleName name = moduleName ++ "." ++ name

View File

@ -12,39 +12,71 @@ import qualified Data.Set as Set
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 = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
identifier :: Lexer LToken
identifier = do
first <- letterChar <|> char '_'
first <- lowerChar <|> char '_'
rest <- many $ letterChar
<|> digitChar
<|> char '_' <|> char '-' <|> char '?' <|> char '.'
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
let name = first : rest
if (name == "t" || name == "!result")
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
else return (LIdentifier name)
integerLiteral :: Lexer LToken
integerLiteral = do
num <- some digitChar
return (LIntegerLiteral (read num))
namespace :: Lexer LToken
namespace = do
name <- try (string "!Local") <|> do
first <- upperChar
rest <- many (letterChar <|> digitChar)
return (first:rest)
return (LNamespace name)
stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- many (noneOf ['"'])
char '"' --"
return (LStringLiteral content)
lModule :: Lexer LToken
lModule = do
_ <- string "!module"
space1
LIdentifier moduleName <- identifier
return (LModule moduleName)
dot :: Lexer LToken
dot = char '.' *> pure LDot
lImport :: Lexer LToken
lImport = do
@ -52,7 +84,7 @@ lImport = do
space1
LStringLiteral path <- stringLiteral
space1
LIdentifier name <- identifier
LNamespace name <- namespace
return (LImport path name)
assign :: Lexer LToken
@ -85,41 +117,15 @@ sc = space
(skipLineComment "--")
(skipBlockComment "|-" "-|")
tricuLexer :: Lexer [LToken]
tricuLexer = do
sc
header <- many $ do
tok <- choice
[ try lModule
, 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 identifier
, try keywordT
, try integerLiteral
, try stringLiteral
, assign
, colon
, backslash
, openParen
, closeParen
, openBracket
, closeBracket
]
integerLiteral :: Lexer LToken
integerLiteral = do
num <- some digitChar
return (LIntegerLiteral (read num))
stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- many (noneOf ['"'])
char '"' --"
return (LStringLiteral content)
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

View File

@ -8,7 +8,9 @@ import Research
import Control.Monad (foldM)
import Control.Monad.IO.Class (liftIO)
import Data.Version (showVersion)
import Text.Megaparsec (runParser)
import Paths_tricu (version)
import System.Console.CmdArgs
import qualified Data.Map as Map
@ -52,10 +54,12 @@ decodeMode = TDecode
main :: IO ()
main = do
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary "tricu Evaluator and REPL"
&= summary versionStr
&= versionArg [explicit, name "version", summary versionStr]
case args of
Repl -> do
putStrLn "Welcome to the tricu REPL"

View File

@ -73,8 +73,6 @@ parseSingle input =
parseProgramM :: ParserM [TricuAST]
parseProgramM = do
skipMany topLevelNewline
moduleNode <- optional parseModuleM
skipMany topLevelNewline
importNodes <- many (do
node <- parseImportM
@ -83,16 +81,7 @@ parseProgramM = do
skipMany topLevelNewline
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
skipMany topLevelNewline
return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
parseModuleM :: ParserM TricuAST
parseModuleM = do
LModule moduleName <- satisfyM isModule
pure (SModule moduleName)
where
isModule (LModule _) = True
isModule _ = False
return (importNodes ++ exprs)
parseImportM :: ParserM TricuAST
parseImportM = do
@ -266,12 +255,19 @@ parseSingleItemM = do
parseVarM :: ParserM TricuAST
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
| name == "t" || name == "!result" ->
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
| otherwise ->
pure (SVar name)
| otherwise -> pure (SVar name)
_ -> fail "Unexpected token while parsing variable"
parseIntLiteralM :: ParserM TricuAST

View File

@ -10,51 +10,65 @@ import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Catch (handle, MonadCatch)
import Data.Char (isSpace)
import Data.List (dropWhile, dropWhileEnd, intercalate)
import Data.List ( dropWhile
, dropWhileEnd
, intercalate
, isPrefixOf)
import System.Console.Haskeline
import qualified Data.Map as Map
repl :: Env -> IO ()
repl env = runInputT defaultSettings (withInterrupt (loop env))
repl env = runInputT defaultSettings (withInterrupt (loop env True))
where
loop :: Env -> InputT IO ()
loop env = handle (interruptHandler env) $ do
loop :: Env -> Bool -> InputT IO ()
loop env decode = handle (interruptHandler env decode) $ do
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Exiting tricu"
Just s
| strip s == "" -> loop env decode
| strip s == "!exit" -> outputStrLn "Exiting tricu"
| strip s == "" -> loop env
| strip s == "!import" -> do
| strip s == "!decode" -> 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 < "
case path of
Nothing -> do
outputStrLn "No input received; stopping import."
loop env
loop env decode
Just p -> do
loadedEnv <- liftIO $ evaluateFileWithContext env
(strip p) `catch` \e -> errorHandler env e
loop $ Map.delete "!result" (Map.union loadedEnv env)
| take 2 s == "--" -> loop env
loop (Map.delete "!result" (Map.union loadedEnv env)) decode
| take 2 s == "--" -> loop env decode
| otherwise -> do
newEnv <- liftIO $ processInput env s `catch` errorHandler env
loop newEnv
newEnv <- liftIO $ processInput env s decode `catch` errorHandler env
loop newEnv decode
interruptHandler :: Env -> Interrupt -> InputT IO ()
interruptHandler env _ = do
interruptHandler :: Env -> Bool -> Interrupt -> InputT IO ()
interruptHandler env decode _ = do
outputStrLn "Interrupted with CTRL+C\n\
\You can use the !exit command or CTRL+D to exit"
loop env
loop env decode
processInput :: Env -> String -> IO Env
processInput env input = do
processInput :: Env -> String -> Bool -> IO Env
processInput env input decode = do
let asts = parseTricu input
newEnv = evalTricu env asts
if
| Just r <- Map.lookup "!result" newEnv -> do
putStrLn $ "tricu > " ++ decodeResult r
| otherwise -> return ()
case Map.lookup "!result" newEnv of
Just r -> do
putStrLn $ "tricu > " ++
if decode
then decodeResult r
else show r
Nothing -> pure ()
return newEnv
errorHandler :: Env -> SomeException -> IO (Env)

View File

@ -26,7 +26,6 @@ data TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
| SEmpty
| SModule String
| SImport String String
deriving (Show, Eq, Ord)
@ -34,17 +33,18 @@ data TricuAST
data LToken
= LKeywordT
| LIdentifier String
| LNamespace String
| LIntegerLiteral Int
| LStringLiteral String
| LAssign
| LColon
| LDot
| LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
| LCloseBracket
| LNewline
| LModule String
| LImport String String
deriving (Show, Eq, Ord)

View File

@ -30,7 +30,7 @@ tests = testGroup "Tricu Tests"
, parser
, simpleEvaluation
, lambdas
, baseLibrary
, providedLibraries
, fileEval
, modules
, demos
@ -343,137 +343,101 @@ lambdas = testGroup "Lambda Evaluation Tests"
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
]
baseLibrary :: TestTree
baseLibrary = testGroup "Library Tests"
[ testCase "K combinator 1" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "K combinator 2" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "K combinator 3" $ do
library <- evaluateFile "./lib/base.tri"
let input = "k (t t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "S combinator" $ do
library <- evaluateFile "./lib/base.tri"
let input = "s (t) (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf (Stem Leaf)
, testCase "SKK == I (fully expanded)" $ do
library <- evaluateFile "./lib/base.tri"
let input = "s k k"
env = evalTricu library (parseTricu input)
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
, testCase "I combinator" $ do
library <- evaluateFile "./lib/base.tri"
let input = "i not?"
env = evalTricu library (parseTricu input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork Leaf (Fork Leaf Leaf))
, testCase "Triage test Leaf" $ do
library <- evaluateFile "./lib/base.tri"
providedLibraries :: TestTree
providedLibraries = testGroup "Library Tests"
[ testCase "Triage test Leaf" $ do
library <- evaluateFile "./lib/list.tri"
let input = "test t"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Leaf\""
, testCase "Triage test (Stem Leaf)" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "test (t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Stem\""
, testCase "Triage test (Fork Leaf Leaf)" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "test (t t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Fork\""
, testCase "Boolean NOT: true" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "not? true"
env = result $ evalTricu library (parseTricu input)
env @?= Leaf
, testCase "Boolean NOT: false" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "not? false"
env = result $ evalTricu library (parseTricu input)
env @?= Stem Leaf
, testCase "Boolean AND TF" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FT" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FF" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND TT" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "List head" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "head [(t) (t t) (t t t)]"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "List tail" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "head (tail (tail [(t) (t t) (t t t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "List map" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "head (tail (map (\\a : (t t t)) [(t) (t) (t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "Empty list check" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "emptyList? []"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Non-empty list check" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "not? (emptyList? [(1) (2) (3)])"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Concatenate strings" $ do
library <- evaluateFile "./lib/base.tri"
let input = "lconcat \"Hello, \" \"world!\""
library <- evaluateFile "./lib/list.tri"
let input = "append \"Hello, \" \"world!\""
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Hello, world!\""
, testCase "Verifying Equality" $ do
library <- evaluateFile "./lib/base.tri"
library <- evaluateFile "./lib/list.tri"
let input = "equal? (t t t) (t t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
@ -490,12 +454,12 @@ fileEval = testGroup "File evaluation tests"
res @?= Fork (Stem Leaf) Leaf
, testCase "Mapping and Equality" $ do
library <- liftIO $ evaluateFile "./lib/base.tri"
library <- liftIO $ evaluateFile "./lib/list.tri"
fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
(mainResult fEnv) @?= Stem Leaf
, testCase "Eval and decoding string" $ do
library <- liftIO $ evaluateFile "./lib/base.tri"
library <- liftIO $ evaluateFile "./lib/list.tri"
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
@ -532,6 +496,9 @@ modules = testGroup "Test modules"
, testCase "Lambda expression namespaces" $ do
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
res @?= Leaf
, testCase "Local namespace import chain" $ do
res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
]

View File

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

View File

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

View File

@ -1,5 +1,4 @@
!module Cycle
!import "test/cycle-2.tri" Cycle2
!import "cycle-2.tri" Cycle2
cycle1 = t Cycle2.cycle2

View File

@ -1,5 +1,4 @@
!module Cycle2
!import "test/cycle-1.tri" Cycle1
!import "cycle-1.tri" Cycle1
cycle2 = t Cycle1.cycle1

View File

@ -1,2 +1 @@
!module A
main = (\x : x) t

4
test/local-ns/1.tri Normal file
View File

@ -0,0 +1,4 @@
!import "2.tri" Two
main = Two.x

2
test/local-ns/2.tri Normal file
View File

@ -0,0 +1,2 @@
!import "3.tri" !Local

1
test/local-ns/3.tri Normal file
View File

@ -0,0 +1 @@
x = 3

View File

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

View File

@ -1,5 +0,0 @@
!module Test
!import "lib/base.tri" Lib
main = Lib.not? t

View File

@ -1 +0,0 @@
n = t t t

View File

@ -1,3 +1,2 @@
!module A
!import "./test/multi-level-B.tri" B
!import "multi-level-B.tri" B
main = B.main

View File

@ -1,3 +1,2 @@
!module B
!import "./test/multi-level-C.tri" C
!import "multi-level-C.tri" C
main = C.val

View File

@ -1,2 +1 @@
!module C
val = t

7
test/named-imports/1.tri Normal file
View 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
View File

@ -0,0 +1,2 @@
x = 2

2
test/named-imports/3.tri Normal file
View File

@ -0,0 +1,2 @@
x = 3

View File

@ -1,3 +1,2 @@
!module A
!import "./test/namespace-B.tri" B
!import "namespace-B.tri" B
main = B.x

View File

@ -1,2 +1 @@
!module B
x = t

View File

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

View File

@ -1 +0,0 @@
namedTerm = undefinedForTesting

View File

@ -1,2 +1 @@
!module A
main = undefinedVar

View File

@ -1,7 +1,6 @@
!module A
!import "./test/vars-B.tri" B
!import "vars-B.tri" B
!import "./test/vars-C.tri" C
!import "vars-C.tri" C
main = B.y (C.z)

View File

@ -1,2 +1 @@
!module B
y = \x : x

View File

@ -1,2 +1 @@
!module C
z = t

View File

@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
version: 0.12.0
version: 0.14.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
@ -27,6 +27,7 @@ executable tricu
, cmdargs
, containers
, exceptions
, filepath
, haskeline
, megaparsec
, mtl
@ -54,6 +55,7 @@ test-suite tricu-tests
, cmdargs
, containers
, exceptions
, filepath
, haskeline
, megaparsec
, mtl