19 Commits

Author SHA1 Message Date
fe453b9b96 Wire prepped and basics tested 2026-05-06 08:25:07 -05:00
fb09b4666e Seeded root leaf prep for wire 2026-05-05 19:16:16 -05:00
efbe9350ed Zero Warnings Plan
Zero GHC warnings with new opts. General cleanup and updates.
2026-05-05 18:32:11 -05:00
2627627493 Picking development back up
Merge Kiselyov optimizations and De Bruijn indices
General clean up
2026-05-05 15:56:23 -05:00
c008126b14 Merge branch 'contentstore' 2026-05-05 14:09:42 -05:00
6b97b210ca Full Merkle tree resolution 2026-05-05 14:08:50 -05:00
James Eversole
71653311ce Documentation updates 2026-05-05 10:03:15 -05:00
0cdc0bfc34 "size" function nodes down from 454 to 321 2025-08-07 20:08:59 -05:00
c36d963640 Update README to reflect completion of experiment 2025-05-29 13:39:44 -05:00
72e5810ca9 Update README to reflect completion of experiment 2025-05-29 13:31:21 -05:00
b96a3f2ef0 Fixes list and name lookup bugs 2025-05-26 17:56:07 -05:00
6780b242b1 Use exact name matches in nameToTerm 2025-05-26 09:04:03 -05:00
94514f7dd0 Update README and !help REPL command 2025-05-22 16:52:37 -05:00
43e83be9a4 Merge content store 2025-05-22 16:46:30 -05:00
3717942589 Clean up and list SKI conversion fix 2025-04-24 12:14:38 -05:00
b8e2743103 Updates to demos 2025-04-16 14:23:53 -05:00
25bfe139e8 String escaping using backslash 2025-04-15 10:52:53 -05:00
f2beb86d8a Drop backslash from lambda definitions 2025-04-15 10:34:38 -05:00
5024a2be4c Revert flake.nix 2025-02-08 10:24:14 -06:00
30 changed files with 3455 additions and 648 deletions

1
.gitignore vendored
View File

@@ -6,6 +6,7 @@
/Dockerfile
/config.dhall
/result
.aider*
WD
bin/
dist*

157
AGENTS.md Normal file
View File

@@ -0,0 +1,157 @@
# AGENTS.md — tricu Project Guide
> For AI agents and contributors working in this repository.
## 1. Build & Test
```bash
# Full build + tests
nix build .#
```
### ⚠️ Never call `cabal` directly
> **Rule of thumb:** if it builds, links, or tests, it goes through `nix`.
## 2. Project Overview
**tricu** (pronounced "tree-shoe") is a programming-language experiment written in Haskell. It implements [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extension of Barry Jay's Tree Calculus, with lambda-abstraction sugar that gets eliminated back to pure tree calculus terms.
### Core types (in `src/Research.hs`)
| Type | Description |
|------|-------------|
| `T = Leaf \| Stem T \| Fork T T` | Tree Calculus term (the runtime value) |
| `TricuAST` | Parsed AST with `SDef`, `SApp`, `SLambda`, etc. |
| `LToken` | Lexer tokens |
| `Node` / `MerkleHash` | Content-addressed Merkle DAG nodes |
### Source modules
| Module | Purpose |
|--------|---------|
| `Main.hs` | CLI entry point (`cmdargs`), three modes: `repl`, `eval`, `decode` |
| `Eval.hs` | Interpreter: `evalTricu`, `result`, `evalSingle` |
| `Parser.hs` | Megaparsec parser → `TricuAST` |
| `Lexer.hs` | Megaparsec lexer → `LToken` |
| `FileEval.hs` | File loading, module imports, `!import` |
| `REPL.hs` | Interactive Read-Eval-Print Loop (haskeline) |
| `Research.hs` | Core types, `apply` reduction, booleans, marshalling (`ofString`, `ofNumber`), output formatters (`toAscii`, `toTernaryString`, `decodeResult`) |
| `ContentStore.hs` | SQLite-backed term persistence |
### File extensions
- `.hs` — Haskell source
- `.tri` — tricu language source (used in `lib/`, `test/`, `demos/`)
## 3. Test Suite
Tests live in `test/Spec.hs` and use **Tasty** + **HUnit**.
```bash
nix flake check # or: nix build .#test
```
### Test groups
| Group | What it covers |
|-------|----------------|
| `lexer` | Megaparsec lexer — identifiers, keywords, strings, escapes, invalid tokens |
| `parser` | Parser — defs, lambda, applications, lists, comments, parentheses |
| `simpleEvaluation` | Core `apply` reduction rules, variable substitution, immutability |
| `lambdas` | Lambda elimination, SKI calculus, higher-order functions, currying, shadowing, free vars |
| `providedLibraries` | `lib/list.tri` — triage, booleans, list ops (`head`, `tail`, `map`, `emptyList?`, `append`, `equal?`) |
| `fileEval` | Loading `.tri` files, multi-file context, decode |
| `modules` | `!import`, cyclic deps, namespacing, multi-level imports, unresolved vars, local namespaces |
| `demos` | `demos/*.tri` — structural equality, `toSource`, `size`, level-order traversal |
| `decoding` | `decodeResult` — Leaf, numbers, strings, lists, mixed |
| `elimLambdaSingle` | Lambda elimination: eta reduction, SDef binding, semantics preservation |
| `stressElimLambda` | Lambda elimination stress test: 200 vars, 800-body curried lambda |
### Suggesting tests
You do not write or modify tests. The user writes tests to constrain your outputs. You must adhere your code to tests or suggest modifications to tests.
If the user gives you explicit permission to implement a test you may proceed.
## 4. tricu Language Quick Reference
```
t → Leaf (the base term)
t t → Stem Leaf
t t t → Fork Leaf Leaf
x = t → Define term x = Leaf
id = (a : a) → Lambda identity (eliminates to tree calculus)
head (map f xs) → From lib/list.tri
!import "./path.tri" NS → Import file under namespace
-- line comment
```
## 5. Output Formats
The `eval` command accepts `--form` (shorthand `-t`):
| Format | Value | Description |
|--------|-------|-------------|
| `tree` | `TreeCalculus` | Simple `t` form (default) |
| `fsl` | `FSL` | Full show representation |
| `ast` | `AST` | Parsed AST representation |
| `ternary` | `Ternary` | Ternary string encoding |
| `ascii` | `Ascii` | ASCII-art tree diagram |
| `decode` | `Decode` | Human-readable (strings, numbers, lists) |
## 6. Content Addressing
Each `T` term is content-addressed via a Merkle DAG:
```
NLeaf → 0x00
NStem(h) → 0x01 || h (32 bytes)
NFork(l,r) → 0x02 || l (32 bytes) || r (32 bytes)
hash = SHA256("tricu.merkle.node.v1" <> 0x00 <> serialized_node)
```
This is stored in SQLite via `ContentStore.hs`. Hash suffixes on identifiers (e.g., `foo_abc123...`) are validated: 1664 hex characters (SHA256).
## 7. Directory Layout
```
tricu/
├── flake.nix # Nix flake: packages, tests, devShell
├── tricu.cabal # Cabal package (used via callCabal2nix)
├── src/ # Haskell modules
│ ├── Main.hs
│ ├── Eval.hs
│ ├── Parser.hs
│ ├── Lexer.hs
│ ├── FileEval.hs
│ ├── REPL.hs
│ ├── Research.hs
│ └── ContentStore.hs
├── test/
│ ├── Spec.hs # Tasty + HUnit tests
│ ├── *.tri # tricu test programs
│ └── local-ns/ # Module namespace test files
├── lib/
│ ├── base.tri
│ ├── list.tri
│ └── patterns.tri
├── demos/
│ ├── equality.tri
│ ├── size.tri
│ ├── toSource.tri
│ ├── levelOrderTraversal.tri
│ └── patternMatching.tri
└── AGENTS.md # This file
```
## 8. Development Tips
- **REPL:** `nix run .#` starts the interactive tricu REPL.
- **Evaluate files:** `nix run .# -- eval -f demos/equality.tri`
- **GHC options:** `-threaded -rtsopts -with-rtsopts=-N` for parallel runtime. Use `-N` RTS flag for multi-core.
- **Upx** is in the devShell for binary compression if needed.

View File

@@ -2,37 +2,31 @@
## 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 should expect breaking changes with every commit.*
tricu (pronounced "tree-shoe") is a programming language experiment in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form 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.
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
## Features
## Acknowledgements
- Tree Calculus operator: `t`
- Assignments: `x = t t`
- Immutable definitions
- 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 : append a "!") [("Hello")]`
- Intensionality blurs the distinction between functions and data (see REPL examples)
- Simple module system for code organization
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda.
## Versioning
This really is a repo for experimentation so I'm not doing anything sane with the versioning for now. If I decide to stabilize the project we'll start anew at 2.0.
## REPL examples
```
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 : append i " world!") [("Hello, ")])
tricu < id = (a : a) -- Lambda abstraction is eliminated to tree calculus terms
tricu < head (map (i : append i " world!") [("Hello, ")])
tricu > "Hello, world!"
tricu < id (head (map (\i : append 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.
tricu < triage = (\a b c : t (t a b) c)
tricu < test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
tricu < triage = (a b c : t (t a b) c)
tricu < test = triage "Leaf" (z : "Stem") (a b : "Fork")
tricu < test (t t)
tricu > "Stem"
tricu < -- We can even convert a term back to source code (/demos/toSource.tri)
@@ -42,22 +36,26 @@ tricu < -- or calculate its size (/demos/size.tri)
tricu < size not?
tricu > 12
tricu < -- REPL Commands:
tricu < !definitions -- Lists all available definitions
tricu < !output -- Change output format (Tree, FSL, AST, etc.)
tricu < !import -- Import definitions from a file
tricu < !exit -- Exit the REPL
tricu < !clear -- ANSI screen clear
tricu < !save -- Save all REPL definitions to a file that you can !import
tricu < !reset -- Clear all REPL definitions
tricu < !version -- Print tricu version
tricu < !help
tricu version 1.1.0
Available commands:
!exit - Exit the REPL
!clear - Clear the screen
!reset - Reset preferences for selected versions
!help - Show tricu version and available commands
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
!definitions - List all defined terms in the content store
!import - Import definitions from file to the content store
!watch - Watch a file for changes, evaluate terms, and store them
!refresh - Refresh environment from content store (definitions are live)
!versions - Show all versions of a term by name
!select - Select a specific version of a term for subsequent lookups
!tag - Add or update a tag for a term by hash or name
```
## Installation and Use
[Releases are available for Linux.](https://git.eversole.co/James/tricu/releases)
Or you can easily build and run this project using [Nix](https://nixos.org/download/).
You can easily build and run this project using [Nix](https://nixos.org/download/).
- Quick Start (REPL):
- `nix run git+https://git.eversole.co/James/tricu`
@@ -93,15 +91,3 @@ tricu decode [OPTIONS]
-f --file=FILE Optional input file path to attempt decoding.
Defaults to stdin.
```
## Collaborating
I am happy to accept issue reports, pull requests, or questions about tricu [via email](mailto:james@eversole.co).
If you want to collaborate but don't want to email back-and-forth, please reach out via email once to let me know and I will provision a git.eversole.co account for you.
## Acknowledgements
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus.

View File

@@ -11,20 +11,17 @@ demo_true = t t
not_TC? = t (t (t t) (t t t)) (t t (t t t))
-- /demos/toSource.tri contains an explanation of `triage`
demo_triage = \a b c : t (t a b) c
demo_matchBool = (\ot of : demo_triage
of
(\_ : ot)
(\_ _ : ot)
)
demo_triage = a b c : t (t a b) c
demo_matchBool = a b : demo_triage b (_ : a) (_ _ : a)
-- Lambda representation of the Boolean `not` function
not_Lambda? = demo_matchBool demo_false demo_true
-- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many
-- As tricu eliminates Lambda terms to SKI combinators, the tree form of many
-- functions defined via Lambda terms are larger than the most efficient TC
-- representation. Between different languages that evaluate to tree calculus
-- terms, the exact implementation of Lambda elimination may differ and lead
-- to different tree representations even if they share extensional behavior.
-- representation possible. Between different languages that evaluate to tree
-- calculus terms, the exact implementation of Lambda elimination may differ
-- and lead to different trees even if they share extensional behavior.
-- Let's see if these are the same:
lambdaEqualsTC = equal? not_TC? not_Lambda?

View File

@@ -18,15 +18,15 @@ main = exampleTwo
-- / / \
-- 4 5 6
label = \node : head node
label = node : head node
left = (\node : if (emptyList? node)
left = node : (if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
(head (tail node))))
right = (\node : if (emptyList? node)
right = node : (if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
@@ -34,25 +34,25 @@ right = (\node : if (emptyList? node)
[]
(head (tail (tail node))))))
processLevel = y (\self queue : if (emptyList? queue)
processLevel = y (self queue : if (emptyList? queue)
[]
(pair (map label queue) (self (filter
(\node : not? (emptyList? node))
(node : not? (emptyList? node))
(append (map left queue) (map right queue))))))
levelOrderTraversal_ = \a : processLevel (t a t)
levelOrderTraversal_ = a : processLevel (t a t)
toLineString = y (\self levels : if (emptyList? levels)
toLineString = y (self levels : if (emptyList? levels)
""
(append
(append (map (\x : append x " ") (head levels)) "")
(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)
levelOrderToString = s : toLineString (levelOrderTraversal_ s)
flatten = foldl (\acc x : append acc x) ""
flatten = foldl (acc x : append acc x) ""
levelOrderTraversal = \s : append (t 10 t) (flatten (levelOrderToString s))
levelOrderTraversal = s : append (t 10 t) (flatten (levelOrderToString s))
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]

37
demos/patternMatching.tri Normal file
View File

@@ -0,0 +1,37 @@
!import "../lib/patterns.tri" !Local
-- We can do conditional pattern matching by providing a list of lists, where
-- each sublist contains a boolean expression and a function to return if said
-- boolean expression evaluates to true.
value = 42
main = match value [[(equal? "Hello") (_ : ", world!")] [(equal? 42) (_ : "The answer.")]]
-- < main
-- > "The answer."
matchExample = (x : match x
[[(equal? 1) (_ : "one")]
[(equal? 2) (_ : "two")]
[(equal? 3) (_ : "three")]
[(equal? 4) (_ : "four")]
[(equal? 5) (_ : "five")]
[(equal? 6) (_ : "six")]
[(equal? 7) (_ : "seven")]
[(equal? 8) (_ : "eight")]
[(equal? 9) (_ : "nine")]
[(equal? 10) (_ : "ten")]
[ otherwise (_ : "I ran out of fingers!")]])
-- < matchExample 3
-- > "three"
-- < matchExample 5
-- > "five"
-- < matchExample 9
-- > "nine"
-- < matchExample 11
-- > "I ran out of fingers!"
-- < matchExample "three"
-- > "I ran out of fingers!"
-- < matchExample [("hello") ("world")]
-- > "I ran out of fingers!"

View File

@@ -3,11 +3,9 @@
main = size size
size = (\x :
(y (\self x :
compose succ
(triage
(\x : x)
self
(\x y : compose (self x) (self y))
x)) x 0))
size = x : y (self x : compose succ (triage
id
self
(x y : compose (self x) (self y))
x)
) x 0

View File

@@ -18,25 +18,25 @@ main = toSource not?
sourceLeaf = t (head "t")
-- Stem case
sourceStem = (\convert : (\a rest :
sourceStem = convert : (a rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the argument.
(t (head ")") rest)))))) -- Close with ")" and append the rest.
(t (head ")") rest))))) -- Close with ")" and append the rest.
-- Fork case
sourceFork = (\convert : (\a b rest :
sourceFork = convert : (a b rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the first arg.
(t (head " ") -- Add another space.
(convert b -- Recursively convert the second arg.
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
(t (head ")") rest))))))) -- Close with ")" and append the rest.
-- Wrapper around triage
toSource_ = y (\self arg :
toSource_ = y (self arg :
triage
sourceLeaf -- `triage` "a" case, Leaf
(sourceStem self) -- `triage` "b" case, Stem
@@ -44,7 +44,7 @@ toSource_ = y (\self arg :
arg) -- The term to be inspected
-- toSource takes a single TC term and returns a String
toSource = \v : toSource_ v ""
toSource = v : toSource_ v ""
exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

44
flake.lock generated
View File

@@ -18,55 +18,25 @@
"type": "github"
}
},
"nh2pkgs": {
"flake": false,
"locked": {
"lastModified": 1718490232,
"narHash": "sha256-0Fh3aJZuTJVmiiKY/5SyvHlfhZ3HeZTDUQnd+Fx6/Qo=",
"type": "tarball",
"url": "https://github.com/nh2/nixpkgs/archive/ede5282c487a1fd2de64303ba59adad6726f1225.tar.gz"
},
"original": {
"type": "tarball",
"url": "https://github.com/nh2/nixpkgs/archive/ede5282c487a1fd2de64303ba59adad6726f1225.tar.gz"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1738797219,
"narHash": "sha256-KRwX9Z1XavpgeSDVM/THdFd6uH8rNm/6R+7kIbGa+2s=",
"lastModified": 1734566935,
"narHash": "sha256-cnBItmSwoH132tH3D4jxmMLVmk8G5VJ6q/SC3kszv9E=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "1da52dd49a127ad74486b135898da2cef8c62665",
"rev": "087408a407440892c1b00d80360fd64639b8091d",
"type": "github"
},
"original": {
"id": "nixpkgs",
"type": "indirect"
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nh2pkgs": "nh2pkgs",
"nixpkgs": "nixpkgs",
"static-haskell-nix": "static-haskell-nix"
}
},
"static-haskell-nix": {
"flake": false,
"locked": {
"lastModified": 1718492291,
"narHash": "sha256-XbBHPJk3ln+uLW+Dsio7vJNYnsHhmqenbI7cLsP8kHg=",
"owner": "nh2",
"repo": "static-haskell-nix",
"rev": "481e7d73ca624278ef0f840a0a2ba09e3a583217",
"type": "github"
},
"original": {
"owner": "nh2",
"repo": "static-haskell-nix",
"type": "github"
"nixpkgs": "nixpkgs"
}
},
"systems": {

View File

@@ -2,56 +2,63 @@
description = "tricu";
inputs = {
nh2pkgs = {
url = "https://github.com/nh2/nixpkgs/archive/ede5282c487a1fd2de64303ba59adad6726f1225.tar.gz";
type = "tarball";
flake = false;
};
static-haskell-nix = {
url = "github:nh2/static-haskell-nix";
flake = false;
};
nixpkgs.url = "github:NixOS/nixpkgs";
flake-utils.url = "github:numtide/flake-utils";
};
outputs = { self, flake-utils, nh2pkgs, nixpkgs, static-haskell-nix }:
outputs = { self, nixpkgs, flake-utils }:
flake-utils.lib.eachDefaultSystem (system:
let
compiler = "ghc948";
pkgs = nixpkgs.legacyPackages.${system};
packageName = "tricu";
overlay = self: super: {
haskell = super.haskell // {
packages = super.haskell.packages // {
${compiler} = super.haskell.packages.${compiler}.override {
overrides = final: prev: {
${packageName} = prev.callCabal2nix packageName ./. {};
};
};
};
};
};
haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib;
overlays = [overlay];
tricuPackage =
haskellPackages.callCabal2nix packageName self {};
pkgs = import nh2pkgs { inherit overlays system; };
tricuTests =
hsLib.overrideCabal tricuPackage (old: {
doCheck = true;
survey = import "${static-haskell-nix}/survey" { inherit compiler pkgs; };
configureFlags = (old.configureFlags or []) ++ [
"--enable-tests"
];
tricuStatic = survey.haskellPackages.${packageName};
checkPhase = ''
runHook preCheck
./Setup test tricu-tests --show-details=direct
runHook postCheck
'';
});
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
in {
packages.default = tricuStatic;
packages.${packageName} = tricuPackage;
packages.default = tricuPackage;
packages.test = tricuTests;
checks.${packageName} = tricuTests;
checks.default = tricuTests;
defaultPackage = self.packages.${system}.default;
devShells.default = pkgs.mkShell {
buildInputs = with survey; [
buildInputs = with pkgs; [
haskellPackages.cabal-install
haskellPackages.ghc-events
haskellPackages.ghcid
] ++ [pkgs.upx];
inputsFrom = builtins.attrValues self.packages.${system};
customGHC
upx
];
inputsFrom = [
tricuPackage
];
};
devShell = self.devShells.${system}.default;
});
}

View File

@@ -1,74 +1,74 @@
false = t
_ = t
true = t t
id = \a : a
const = \a b : a
id = a : a
const = a b : a
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
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
(\x : x x)
(\a0 a1 a2 : t (t a0) (t t a2) a1))
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)
compose = f g x : f (g x)
triage = \leaf stem fork : t (t leaf stem) fork
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
triage = leaf stem fork : t (t leaf stem) fork
test = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
matchBool = (\ot of : triage
matchBool = (ot of : triage
of
(\_ : ot)
(\_ _ : ot)
(_ : ot)
(_ _ : ot)
)
lAnd = (triage
(\_ : false)
(\_ x : x)
(\_ _ x : x))
(_ : false)
(_ x : x)
(_ _ x : x))
lOr = (triage
(\x : x)
(\_ _ : true)
(\_ _ _ : true))
(x : x)
(_ _ : true)
(_ _ _ : true))
matchPair = \a : triage _ _ a
matchPair = a : triage _ _ a
not? = matchBool false true
and? = matchBool id (\_ : false)
and? = matchBool id (_ : false)
or? = (\x z :
or? = (x z :
matchBool
(matchBool true true z)
(matchBool true false z)
x)
xor? = (\x z :
xor? = (x z :
matchBool
(matchBool false true z)
(matchBool true false z)
x)
equal? = y (\self : triage
equal? = y (self : triage
(triage
true
(\_ : false)
(\_ _ : false))
(\ax :
(_ : false)
(_ _ : false))
(ax :
triage
false
(self ax)
(\_ _ : false))
(\ax ay :
(_ _ : false))
(ax ay :
triage
false
(\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
(_ : false)
(bx by : lAnd (self ax bx) (self ay by))))
succ = y (\self :
succ = y (self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
(_ tail : t t (self tail))
t))

View File

@@ -1,68 +1,70 @@
!import "base.tri" !Local
matchList = \a b : triage a _ b
_ = t
emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
matchList = a b : triage a _ b
append = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
emptyList? = matchList true (_ _ : false)
head = matchList t (head _ : head)
tail = matchList t (_ tail : tail)
lExist? = y (\self x : matchList
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)))
(h z : or? (equal? x h) (self x z)))
map_ = y (\self :
map_ = y (self :
matchList
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = \f l : map_ l f
(_ : 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
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
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
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
length = y (self : matchList
0
(\_ tail : succ (self tail)))
(_ tail : succ (self tail)))
reverse = y (\self : matchList
reverse = y (self : matchList
t
(\head tail : append (self tail) (pair head t)))
(head tail : append (self tail) (pair head t)))
snoc = y (\self x : matchList
snoc = y (self x : matchList
(pair x t)
(\h z : pair h (self x z)))
(h z : pair h (self x z)))
count = y (\self x : matchList
count = y (self x : matchList
0
(\h z : matchBool
(h z : matchBool
(succ (self x z))
(self x z)
(equal? x h)))
last = y (\self : matchList
last = y (self : matchList
t
(\hd tl : matchBool
(hd tl : matchBool
hd
(self tl)
(emptyList? tl)))
all? = y (\self pred : matchList
all? = y (self pred : matchList
true
(\h z : and? (pred h) (self pred z)))
(h z : and? (pred h) (self pred z)))
any? = y (\self pred : matchList
any? = y (self pred : matchList
false
(\h z : or? (pred h) (self pred z)))
(h z : or? (pred h) (self pred z)))
intersect = \xs ys : filter (\x : lExist? x ys) xs
intersect = xs ys : filter (x : lExist? x ys) xs

View File

@@ -1,36 +1,24 @@
!import "base.tri" !Local
!import "list.tri" !Local
match_ = y (\self value patterns :
match_ = y (self value patterns :
triage
t
(\_ : t)
(\pattern rest :
(_ : t)
(pattern rest :
triage
t
(\_ : t)
(\test result :
(_ : t)
(test result :
if (test value)
(result value)
(self value rest))
pattern)
patterns)
match = (\value patterns :
match_ value (map (\sublist :
match = (value patterns :
match_ value (map (sublist :
pair (head sublist) (head (tail sublist)))
patterns))
otherwise = const (t t)
matchExample = (\x : match x
[[(equal? 1) (\_ : "one")]
[(equal? 2) (\_ : "two")]
[(equal? 3) (\_ : "three")]
[(equal? 4) (\_ : "four")]
[(equal? 5) (\_ : "five")]
[(equal? 6) (\_ : "six")]
[(equal? 7) (\_ : "seven")]
[(equal? 8) (\_ : "eight")]
[(equal? 9) (\_ : "nine")]
[(equal? 10) (\_ : "ten")]
[ otherwise (\_ : "I ran out of fingers!")]])

269
src/ContentStore.hs Normal file
View File

@@ -0,0 +1,269 @@
module ContentStore where
import Research
import Control.Monad (foldM, forM_, void)
import Data.ByteString (ByteString)
import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>), takeDirectory)
import qualified Data.Map as Map
import qualified Data.Text as T
data StoredNode = StoredNode ByteString deriving (Show)
instance FromRow StoredNode where
fromRow = StoredNode <$> field
data StoredTerm = StoredTerm
{ termHash :: Text
, termNames :: Text
, termMetadata :: Text
, termCreatedAt :: Integer
, termTags :: Text
} deriving (Show)
instance FromRow StoredTerm where
fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field
parseNameList :: Text -> [Text]
parseNameList = filter (not . T.null) . T.splitOn ","
serializeNameList :: [Text] -> Text
serializeNameList = T.intercalate "," . nub . sort
initContentStore :: IO Connection
initContentStore = do
dbPath <- getContentStorePath
createDirectoryIfMissing True (takeDirectory dbPath)
conn <- open dbPath
setupDatabase conn
return conn
-- | Initialise a database connection (file-backed or in-memory).
-- This is factored out so tests can reuse it with ":memory:".
setupDatabase :: Connection -> IO ()
setupDatabase conn = do
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
\hash TEXT PRIMARY KEY, \
\names TEXT, \
\metadata TEXT, \
\created_at INTEGER DEFAULT (strftime('%s','now')), \
\tags TEXT DEFAULT '')"
execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)"
execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)"
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
\hash TEXT PRIMARY KEY, \
\node_data BLOB NOT NULL)"
-- Seed canonical Leaf node payload (0x00)
putMerkleNode conn NLeaf
-- | Create an in-memory ContentStore connection (for tests).
newContentStore :: IO Connection
newContentStore = do
conn <- open ":memory:"
setupDatabase conn
return conn
getContentStorePath :: IO FilePath
getContentStorePath = do
dataDir <- getXdgDirectory XdgData "tricu"
return $ dataDir </> "content-store.db"
hashTerm :: T -> Text
hashTerm = nodeHash . buildMerkle
storeTerm :: Connection -> [String] -> T -> IO Text
storeTerm conn newNamesStrList term = do
let termHashText = hashTerm term
newNamesTextList = map T.pack newNamesStrList
metadataText = T.pack "{}"
-- Store all Merkle nodes for this term
_ <- storeMerkleNodes conn term
existingNamesQuery <- query conn
"SELECT names FROM terms WHERE hash = ?"
(Only termHashText) :: IO [Only Text]
case existingNamesQuery of
[] -> do
let allNamesToStore = serializeNameList newNamesTextList
execute conn
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
(termHashText, allNamesToStore, metadataText, T.pack "")
[(Only currentNamesText)] -> do
let currentNamesList = parseNameList currentNamesText
let combinedNamesList = currentNamesList ++ newNamesTextList
let allNamesToStore = serializeNameList combinedNamesList
execute conn
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
(allNamesToStore, metadataText, termHashText)
_ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
return termHashText
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
-- Recursively loads nodes and rebuilds the T structure.
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
loadTree conn h = do
maybeNode <- getNodeMerkle conn h
case maybeNode of
Nothing -> return Nothing
Just node -> Just <$> buildTree node
where
buildTree :: Node -> IO T
buildTree NLeaf = return Leaf
buildTree (NStem childHash) = do
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
return (Stem child)
buildTree (NFork lHash rHash) = do
left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
return (Fork left right)
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
-- Returns the hash of the root node.
storeMerkleNodes :: Connection -> T -> IO MerkleHash
storeMerkleNodes conn Leaf = do
putMerkleNode conn NLeaf
return $ nodeHash NLeaf
storeMerkleNodes conn (Stem t) = do
childHash <- storeMerkleNodes conn t
let thisNode = NStem childHash
putMerkleNode conn thisNode
return $ nodeHash thisNode
storeMerkleNodes conn (Fork l r) = do
leftHash <- storeMerkleNodes conn l
rightHash <- storeMerkleNodes conn r
let thisNode = NFork leftHash rightHash
putMerkleNode conn thisNode
return $ nodeHash thisNode
-- | Insert a Merkle node into the store (idempotent).
putMerkleNode :: Connection -> Node -> IO ()
putMerkleNode conn node =
execute conn "INSERT OR IGNORE INTO merkle_nodes (hash, node_data) VALUES (?, ?)"
(nodeHash node, serializeNode node)
-- | Retrieve a Merkle node by its hash.
getNodeMerkle :: Connection -> MerkleHash -> IO (Maybe Node)
getNodeMerkle conn h =
queryMaybeOne conn "SELECT node_data FROM merkle_nodes WHERE hash = ?" (Only h) >>= \case
Just (StoredNode bs) -> return $ Just (deserializeNode bs)
Nothing -> return Nothing
hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
hashToTerm conn hashText =
queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText)
nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
nameToTerm conn nameText =
queryMaybeOne conn
(selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1")
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
listStoredTerms :: Connection -> IO [StoredTerm]
listStoredTerms conn =
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
storeEnvironment :: Connection -> Env -> IO ()
storeEnvironment conn env = do
let defs = Map.toList $ Map.delete "!result" env
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
forM_ groupedDefs $ \(term, namesList) -> case namesList of
_:_ -> void $ storeTerm conn namesList term
_ -> errorWithoutStackTrace "storeEnvironment: empty names list"
loadTerm :: Connection -> String -> IO (Maybe T)
loadTerm conn identifier = do
result <- getTerm conn (T.pack identifier)
case result of
Just storedTerm -> loadTree conn (termHash storedTerm)
Nothing -> return Nothing
getTerm :: Connection -> Text -> IO (Maybe StoredTerm)
getTerm conn identifier = do
if '#' `elem` (T.unpack identifier)
then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier))
else nameToTerm conn identifier
loadEnvironment :: Connection -> IO Env
loadEnvironment conn = do
terms <- listStoredTerms conn
foldM addTermToEnv Map.empty terms
where
addTermToEnv env storedTerm = do
maybeT <- loadTree conn (termHash storedTerm)
case maybeT of
Just t -> do
let namesList = parseNameList (termNames storedTerm)
return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList
Nothing -> return env
termVersions :: Connection -> String -> IO [(Text, T, Integer)]
termVersions conn name = do
let nameText = T.pack name
results <- query conn
("SELECT hash, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC")
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
catMaybes <$> mapM (\(hashVal, timestamp) -> do
maybeT <- loadTree conn hashVal
return $ fmap (\t -> (hashVal, t, timestamp)) maybeT
) results
setTag :: Connection -> Text -> Text -> IO ()
setTag conn hash tagValue = do
exists <- termExists conn hash
if exists
then do
currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
case currentTagsQuery of
[Only tagsText] -> do
let tagsList = parseNameList tagsText
newTagsList = tagValue : tagsList
newTags = serializeNameList newTagsList
execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash)
_ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)"
else
putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist"
termExists :: Connection -> Text -> IO Bool
termExists conn hash = do
results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]]
return $ not (null results)
termToTags :: Connection -> Text -> IO [Text]
termToTags conn hash = do
tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
case tagsQuery of
[Only tagsText] -> return $ parseNameList tagsText
_ -> return []
tagToTerm :: Connection -> Text -> IO [StoredTerm]
tagToTerm conn tagValue = do
let pattern = "%" <> tagValue <> "%"
query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern)
allTermTags :: Connection -> IO [StoredTerm]
allTermTags conn = do
query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC")
selectStoredTermFields :: Query
selectStoredTermFields = "SELECT hash, names, metadata, created_at, tags FROM terms"
queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r)
queryMaybeOne conn qry params = do
results <- query conn qry params
case results of
[row] -> return $ Just row
_ -> return Nothing

View File

@@ -1,120 +1,229 @@
module Eval where
import ContentStore
import Parser
import Research
import Data.List (partition, (\\))
import Data.Map (Map)
import Control.Monad (foldM)
import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map ()
import Data.Set (Set)
import Database.SQLite.Simple
import qualified Data.Foldable as F ()
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
data DB
= BVar Int
| BFree String
| BLam DB
| BApp DB DB
| BLeaf
| BStem DB
| BFork DB DB
| BStr String
| BInt Integer
| BList [DB]
| BEmpty
deriving (Eq, Show)
type Uses = [Bool]
evalSingle :: Env -> TricuAST -> Env
evalSingle env term
| SDef name [] body <- term
= case Map.lookup name env of
Just existingValue
| existingValue == evalAST env body -> env
| otherwise -> errorWithoutStackTrace $
"Unable to rebind immutable identifier: " ++ name
Nothing ->
let res = evalAST env body
in Map.insert "!result" res (Map.insert name res env)
| existingValue == evalASTSync env body -> env
| otherwise
-> let res = evalASTSync env body
in Map.insert "!result" res (Map.insert name res env)
Nothing
-> let res = evalASTSync env body
in Map.insert "!result" res (Map.insert name res env)
| SApp func arg <- term
= let res = apply (evalAST env func) (evalAST env arg)
in Map.insert "!result" res env
| SVar name <- term
= let res = apply (evalASTSync env func) (evalASTSync env arg)
in Map.insert "!result" res env
| SVar name Nothing <- term
= case Map.lookup name env of
Just v -> Map.insert "!result" v env
Nothing ->
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
\This error should never occur here. Please report this as an issue."
Just v -> Map.insert "!result" v env
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
| SVar name (Just hash) <- term
= errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash
| otherwise
= Map.insert "!result" (evalAST env term) env
= let res = evalASTSync env term
in Map.insert "!result" res env
evalTricu :: Env -> [TricuAST] -> Env
evalTricu env x = go env (reorderDefs env x)
where
go env [] = env
go env [x] =
let updatedEnv = evalSingle env x
go env' [] = env'
go env' [def] =
let updatedEnv = evalSingle env' def
in Map.insert "!result" (result updatedEnv) updatedEnv
go env (x:xs) =
evalTricu (evalSingle env x) xs
go env' (def:xs) =
evalTricu (evalSingle env' def) xs
evalAST :: Env -> TricuAST -> T
evalAST env term
| SLambda _ _ <- term = evalAST env (elimLambda term)
| SVar name <- term = evalVar name
| TLeaf <- term = Leaf
| TStem t <- term = Stem (evalAST env t)
| TFork t u <- term = Fork (evalAST env t) (evalAST env u)
| SApp t u <- term = apply (evalAST env t) (evalAST env u)
| SStr s <- term = ofString s
| SInt n <- term = ofNumber n
| SList xs <- term = ofList (map (evalAST env) xs)
| SEmpty <- term = Leaf
| otherwise = errorWithoutStackTrace "Unexpected AST term"
where
evalVar name = Map.findWithDefault
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
name env
evalASTSync :: Env -> TricuAST -> T
evalASTSync env term = case term of
SLambda _ _ -> evalASTSync env (elimLambda term)
SVar name Nothing -> case Map.lookup name env of
Just v -> v
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
SVar name (Just hash) ->
case Map.lookup (name ++ "#" ++ hash) env of
Just v -> v
Nothing -> errorWithoutStackTrace $
"Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment"
TLeaf -> Leaf
TStem t -> Stem (evalASTSync env t)
TFork t u -> Fork (evalASTSync env t) (evalASTSync env u)
SApp t u -> apply (evalASTSync env t) (evalASTSync env u)
SStr s -> ofString s
SInt n -> ofNumber n
SList xs -> ofList (map (evalASTSync env) xs)
SEmpty -> Leaf
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
evalAST mconn selectedVersions ast = do
let varNames = collectVarNames ast
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
return $ evalASTSync resolvedEnv ast
collectVarNames :: TricuAST -> [(String, Maybe String)]
collectVarNames = go []
where
go acc (SVar name mhash) = (name, mhash) : acc
go acc (SApp t u) = go (go acc t) u
go acc (SLambda vars body) =
let boundVars = Set.fromList vars
collected = go [] body
in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
go acc (TStem t) = go acc t
go acc (TFork t u) = go (go acc t) u
go acc (SList xs) = foldl' go acc xs
go acc _ = acc
resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
resolveTermsFromStore Nothing _ _ = return Map.empty
resolveTermsFromStore (Just conn) selectedVersions varNames = do
foldM (\env (name, mhash) -> do
term <- resolveTermFromStore conn selectedVersions name mhash
case term of
Just t -> return $ Map.insert (getVarKey name mhash) t env
Nothing -> return env
) Map.empty varNames
where
getVarKey name Nothing = name
getVarKey name (Just hash) = name ++ "#" ++ hash
resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
resolveTermFromStore conn selectedVersions name mhash = case mhash of
Just hashPrefix -> do
versions <- termVersions conn name
let matchingVersions = filter (\(hash, _, _) ->
T.isPrefixOf (T.pack hashPrefix) hash) versions
case matchingVersions of
[] -> return Nothing
[(_, term, _)] -> return $ Just term
_ -> return Nothing
Nothing -> case Map.lookup name selectedVersions of
Just hash -> loadTree conn hash
Nothing -> do
versions <- termVersions conn name
case versions of
[] -> return Nothing
[(_, term, _)] -> return $ Just term
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
elimLambda :: TricuAST -> TricuAST
elimLambda = go
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
go term
| etaReduction term = go (etaReduceResult term)
| triagePattern term = _TRI
| composePattern term = _B
| lambdaList term = go (lambdaListResult term)
| nestedLambda term = nestedLambdaResult term
| application term = applicationResult term
| isSList term = slistTransform term
| otherwise = term
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
etaReduction _ = False
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
toDB [c,b,a] body == triageBodyDB
triagePattern _ = False
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
toDB [x,g,f] body == composeBodyDB
composePattern _ = False
lambdaList (SLambda [_] (SList _)) = True
lambdaList _ = False
nestedLambda (SLambda (_:_) _) = True
nestedLambda _ = False
application (SApp _ _) = True
application _ = False
etaReduceResult (SLambda [_] (SApp f _)) = f
etaReduceResult _ = error "etaReduceResult: expected SLambda [v] (SApp f _)"
lambdaListResult (SLambda [v] (SList xs)) =
SLambda [v] (foldr wrapTLeaf TLeaf xs)
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 == SApp (SVar f) (SApp (SVar g) (SVar x)) = _B
-- General elimination
go (SLambda [v] (SList xs))
= elimLambda (SLambda [v] (foldr wrapTLeaf TLeaf xs))
where wrapTLeaf m r = SApp (SApp TLeaf m) r
go (SLambda (v:vs) body)
| null vs = toSKI v (elimLambda body)
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
go (SApp f g) = SApp (elimLambda f) (elimLambda g)
go x = x
wrapTLeaf m r = SApp (SApp TLeaf m) r
lambdaListResult _ = error "lambdaListResult: expected SLambda [v] (SList xs)"
toSKI x (SVar y)
| x == y = _I
| otherwise = SApp _K (SVar y)
toSKI x t@(SApp n u)
| not (isFree x t) = SApp _K t
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
toSKI x t
| not (isFree x t) = SApp _K t
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
nestedLambdaResult (SLambda (v:vs) body)
| null vs =
let body' = go body
db = toDB [v] body'
in toSKIKiselyov db
| otherwise = go (SLambda [v] (SLambda vs body))
nestedLambdaResult _ = error "nestedLambdaResult: expected SLambda (_:_) _"
_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"
applicationResult (SApp f g) = SApp (go f) (go g)
applicationResult _ = error "applicationResult: expected SApp _ _"
isSList (SList _) = True
isSList _ = False
slistTransform :: TricuAST -> TricuAST
slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
slistTransform ast = ast -- Should not be reached
_S, _K, _I, _R, _C, _B, _T, _TRI :: TricuAST
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t"
_R = parseSingle "(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 (t t t)) t)))) (t t (t t))))))) (t t))"
_C = parseSingle "(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 (t t)))"
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
_T = SApp _C _I
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
triageBody :: String -> String -> String -> TricuAST
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
composeBody :: String -> String -> String -> TricuAST
composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
isFree x t = Set.member x (freeVars t)
freeVars :: TricuAST -> Set.Set String
freeVars (SVar v ) = Set.singleton v
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 (SDef _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
freeVars _ = Set.empty
-- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
freeVars :: TricuAST -> Set String
freeVars (SVar v Nothing) = Set.singleton v
freeVars (SVar v (Just _)) = Set.singleton v
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
freeVars _ = Set.empty
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
reorderDefs env defs
@@ -131,7 +240,7 @@ reorderDefs env defs
graph = buildDepGraph defsOnly
sortedDefs = sortDeps graph
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
orderedDefs = map (\name -> defMap Map.! name) sortedDefs
orderedDefs = map (defMap Map.!) sortedDefs
freeVarsDefs = foldMap snd defsWithFreeVars
freeVarsOthers = foldMap freeVars others
@@ -139,8 +248,8 @@ reorderDefs env defs
validNames = Set.fromList defNames `Set.union` Set.fromList (Map.keys env)
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
isDef (SDef _ _ _) = True
isDef _ = False
isDef SDef {} = True
isDef _ = False
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
buildDepGraph topDefs
@@ -165,7 +274,7 @@ buildDepGraph topDefs
sortDeps :: Map.Map String (Set.Set String) -> [String]
sortDeps graph = go [] Set.empty (Map.keys graph)
where
go sorted sortedSet [] = sorted
go sorted _sortedSet [] = sorted
go sorted sortedSet remaining =
let ready = [ name | name <- remaining
, let deps = Map.findWithDefault Set.empty name graph
@@ -195,3 +304,291 @@ mainResult :: Env -> T
mainResult r = case Map.lookup "main" r of
Just a -> a
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
findVarNames :: TricuAST -> [String]
findVarNames ast = case ast of
SVar name _ -> [name]
SApp a b -> findVarNames a ++ findVarNames b
SLambda args body -> findVarNames body \\ args
SDef name args body -> name : (findVarNames body \\ args)
_ -> []
-- Convert named TricuAST to De Bruijn form
toDB :: [String] -> TricuAST -> DB
toDB env = \case
SVar v _ -> maybe (BFree v) BVar (elemIndex v env)
SLambda vs b ->
let env' = reverse vs ++ env
body = toDB env' b
in foldr (\_ acc -> BLam acc) body vs
SApp f a -> BApp (toDB env f) (toDB env a)
TLeaf -> BLeaf
TStem t -> BStem (toDB env t)
TFork l r -> BFork (toDB env l) (toDB env r)
SStr s -> BStr s
SInt n -> BInt n
SList xs -> BList (map (toDB env) xs)
SEmpty -> BEmpty
SDef{} -> error "toDB: unexpected SDef at this stage"
SImport _ _ -> BEmpty
-- Does a term depend on the current binder (level 0)?
dependsOnLevel :: Int -> DB -> Bool
dependsOnLevel lvl = \case
BVar k -> k == lvl
BLam t -> dependsOnLevel (lvl + 1) t
BApp f a -> dependsOnLevel lvl f || dependsOnLevel lvl a
BStem t -> dependsOnLevel lvl t
BFork l r -> dependsOnLevel lvl l || dependsOnLevel lvl r
BList xs -> any (dependsOnLevel lvl) xs
_ -> False
-- Collect free *global* names (i.e., unbound)
freeDBNames :: DB -> Set String
freeDBNames = \case
BFree s -> Set.singleton s
BVar _ -> mempty
BLam t -> freeDBNames t
BApp f a -> freeDBNames f <> freeDBNames a
BLeaf -> mempty
BStem t -> freeDBNames t
BFork l r -> freeDBNames l <> freeDBNames r
BStr _ -> mempty
BInt _ -> mempty
BList xs -> foldMap freeDBNames xs
BEmpty -> mempty
-- Helper: "is the binder named v used in body?"
usesBinder :: String -> TricuAST -> Bool
usesBinder v body = dependsOnLevel 0 (toDB [v] body)
-- Expected DB bodies for the named special patterns (under env [a,b,c] -> indices 2,1,0)
triageBodyDB :: DB
triageBodyDB =
BApp (BApp BLeaf (BApp (BApp BLeaf (BVar 2)) (BVar 1))) (BVar 0)
composeBodyDB :: DB
composeBodyDB =
BApp (BVar 2) (BApp (BVar 1) (BVar 0))
-- Convert DB -> TricuAST for subterms that contain NO binders (no BLam, no BVar)
fromDBClosed :: DB -> TricuAST
fromDBClosed = \case
BFree s -> SVar s Nothing
BApp f a -> SApp (fromDBClosed f) (fromDBClosed a)
BLeaf -> TLeaf
BStem t -> TStem (fromDBClosed t)
BFork l r -> TFork (fromDBClosed l) (fromDBClosed r)
BStr s -> SStr s
BInt n -> SInt n
BList xs -> SList (map fromDBClosed xs)
BEmpty -> SEmpty
-- Anything bound would be a logic error if we call this correctly.
BLam _ -> error "fromDBClosed: unexpected BLam"
BVar _ -> error "fromDBClosed: unexpected bound variable"
-- DB-native bracket abstraction over the innermost binder (level 0).
-- This mirrors your old toSKI, but is purely index-driven.
toSKIDB :: DB -> TricuAST
toSKIDB t
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
toSKIDB (BVar 0) = _I
toSKIDB (BApp n u) = SApp (SApp _S (toSKIDB n)) (toSKIDB u)
toSKIDB (BList xs) =
let anyUses = any (dependsOnLevel 0) xs
in if not anyUses
then SApp _K (SList (map fromDBClosed xs))
else SList (map toSKIDB xs)
toSKIDB _other = _K `SApp` TLeaf
app2 :: TricuAST -> TricuAST -> TricuAST
app2 f x = SApp f x
app3 :: TricuAST -> TricuAST -> TricuAST -> TricuAST
app3 f x y = SApp (SApp f x) y
-- Core converter that *does not* perform the λ-step; it just returns (Γ, d).
-- Supported shapes: variables, applications, closed literals (Leaf/Int/Str/Empty),
-- closed lists. For anything where the binder occurs under structural nodes
-- (Stem/Fork/List-with-use), we deliberately bail so the caller can fall back.
kisConv :: DB -> Either String (Uses, TricuAST)
kisConv = \case
BVar 0 -> Right ([True], _I)
BVar n | n > 0 -> do
(g,d) <- kisConv (BVar (n - 1))
Right (False:g, d)
BVar n -> Right ([], SVar ("BVar" ++ show n) Nothing)
BFree s -> Right ([], SVar s Nothing)
BApp e1 e2 -> do
(g1,d1) <- kisConv e1
(g2,d2) <- kisConv e2
let g = zipWithDefault False (||) g1 g2 -- <- propagate Γ outside (#)
d = kisHash (g1,d1) (g2,d2) -- <- (#) yields only the term
Right (g, d)
-- Treat closed constants as free 'combinator leaves' (no binder use).
BLeaf -> Right ([], TLeaf)
BStr s -> Right ([], SStr s)
BInt n -> Right ([], SInt n)
BEmpty -> Right ([], SEmpty)
-- Closed list: allowed. If binder is used anywhere, we punt to fallback.
BList xs
| any (dependsOnLevel 0) xs -> Left "List with binder use: fallback"
| otherwise -> Right ([], SList (map fromDBClosed xs))
-- For structural nodes, only allow if *closed* wrt the binder.
BStem t
| dependsOnLevel 0 t -> Left "Stem with binder use: fallback"
| otherwise -> Right ([], TStem (fromDBClosed t))
BFork l r
| dependsOnLevel 0 l || dependsOnLevel 0 r -> Left "Fork with binder use: fallback"
| otherwise -> Right ([], TFork (fromDBClosed l) (fromDBClosed r))
-- We shouldn't see BLam under elim; treat as unsupported so we fallback.
BLam _ -> Left "Nested lambda under body: fallback"
-- Application combiner with K-optimization (lazy weakening).
-- Mirrors Lynn's 'optK' rules: choose among S, B, C, R based on leading flags.
-- η-aware (#) with K-optimization (adapted from TS kiselyov_eta)
kisHash :: (Uses, TricuAST) -> (Uses, TricuAST) -> TricuAST
kisHash (g1, d1) (g2, d2) =
case g1 of
[] -> case g2 of
[] -> SApp d1 d2
True:gs2 -> if isId2 (g2, d2)
then d1
else kisHash ([], SApp _B d1) (gs2, d2)
False:gs2 -> kisHash ([], d1) (gs2, d2)
True:gs1 -> case g2 of
[] -> if isId2 (g1, d1)
then SApp _T d2
else kisHash ([], SApp _R d2) (gs1, d1)
_ ->
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
then kisHash ([], _T) (drop1 g2, d2)
else
-- NEW: coalesce the longest run of identical head pairs and apply bulk op once
let ((h1, h2), count) = headPairRun g1 g2
g1' = drop count g1
g2' = drop count g2
in case (h1, h2) of
(False, False) ->
kisHash (g1', d1) (g2', d2)
(False, True) ->
let d1' = kisHash ([], bulkB count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
(True, False) ->
let d1' = kisHash ([], bulkC count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
(True, True) ->
let d1' = kisHash ([], bulkS count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
False:gs1 -> case g2 of
[] -> kisHash (gs1, d1) ([], d2)
_ ->
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
then kisHash ([], _T) (drop1 g2, d2)
else case g2 of
True:gs2 ->
let d1' = kisHash ([], _B) (gs1, d1)
in kisHash (gs1, d1') (gs2, d2)
False:gs2 ->
kisHash (gs1, d1) (gs2, d2)
where
drop1 (_:xs) = xs
drop1 [] = []
toSKIKiselyov :: DB -> TricuAST
toSKIKiselyov body =
case kisConv body of
Right ([], d) -> SApp _K d
Right (True:_ , d) -> d
Right (False:g, d) -> kisHash ([], _K) (g, d) -- no snd
Left _ -> starSKIBCOpEtaDB body -- was: toSKIDB body
zipWithDefault :: a -> (a -> a -> a) -> [a] -> [a] -> [a]
zipWithDefault d f [] ys = map (f d) ys
zipWithDefault d f xs [] = map (\x -> f x d) xs
zipWithDefault d f (x:xs) (y:ys) = f x y : zipWithDefault d f xs ys
isNode :: TricuAST -> Bool
isNode t = case t of
TLeaf -> True
_ -> False
isApp2 :: TricuAST -> Maybe (TricuAST, TricuAST)
isApp2 (SApp a b) = Just (a, b)
isApp2 _ = Nothing
isKop :: TricuAST -> Bool
isKop t = case isApp2 t of
Just (a,b) -> isNode a && isNode b
_ -> False
-- detects the two canonical I-shapes in the tree calculus:
-- △ (△ (△ △)) x OR △ (△ △ △) △
isId :: TricuAST -> Bool
isId t = case isApp2 t of
Just (ab, c) -> case isApp2 ab of
Just (a, b) | isNode a ->
case isApp2 b of
Just (b1, b2) ->
(isNode b1 && isKop b2) ||
(isKop b1 && isNode b2 && isNode c)
_ -> False
_ -> False
_ -> False
-- head-True only, tail empty, and term is identity
isId2 :: (Uses, TricuAST) -> Bool
isId2 (True:[], t) = isId t
isId2 _ = False
-- Bulk helpers built from SKI (no new primitives)
bPrime :: TricuAST
bPrime = SApp _B _B -- B' = B B
cPrime :: TricuAST
cPrime = SApp (SApp _B (SApp _B _C)) _B -- C' = B (B C) B
sPrime :: TricuAST
sPrime = SApp (SApp _B (SApp _B _S)) _B -- S' = B (B S) B
bulkB :: Int -> TricuAST
bulkB n | n <= 1 = _B
| otherwise = SApp bPrime (bulkB (n - 1))
bulkC :: Int -> TricuAST
bulkC n | n <= 1 = _C
| otherwise = SApp cPrime (bulkC (n - 1))
bulkS :: Int -> TricuAST
bulkS n | n <= 1 = _S
| otherwise = SApp sPrime (bulkS (n - 1))
headPairRun :: [Bool] -> [Bool] -> ((Bool, Bool), Int)
headPairRun g1 g2 =
case zip g1 g2 of
[] -> ((False, False), 0)
(h:rest) -> (h, 1 + length (takeWhile (== h) rest))
-- DB-native star_skibc_op_eta (adapted from strategies.mts), binder = level 0
starSKIBCOpEtaDB :: DB -> TricuAST
starSKIBCOpEtaDB t
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
starSKIBCOpEtaDB (BVar 0) = _I
starSKIBCOpEtaDB (BApp e1 e2)
-- if binder not in right: use C
| not (dependsOnLevel 0 e2)
= SApp (SApp _C (starSKIBCOpEtaDB e1)) (fromDBClosed e2)
-- if binder not in left:
| not (dependsOnLevel 0 e1)
= case e2 of
-- η case: \x. f x ==> f
BVar 0 -> fromDBClosed e1
_ -> SApp (SApp _B (fromDBClosed e1)) (starSKIBCOpEtaDB e2)
-- otherwise: S
| otherwise
= SApp (SApp _S (starSKIBCOpEtaDB e1)) (starSKIBCOpEtaDB e2)
-- Structural nodes with binder underneath: fall back to plain SKI (rare)
starSKIBCOpEtaDB other = toSKIDB other

View File

@@ -5,11 +5,11 @@ import Lexer
import Parser
import Research
import Control.Monad ()
import Data.List (partition)
import Data.Maybe (mapMaybe)
import Control.Monad (foldM)
import System.IO
import System.FilePath (takeDirectory, normalise, (</>))
import System.IO ()
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -17,12 +17,12 @@ import qualified Data.Set as Set
extractMain :: Env -> Either String T
extractMain env =
case Map.lookup "main" env of
Just result -> Right result
Just evalResult -> Right evalResult
Nothing -> Left "No `main` function detected"
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
processImports seen base currentPath asts =
processImports seen _base currentPath asts =
let (imports, nonImports) = partition isImp asts
importPaths = mapMaybe getImportInfo imports
in if currentPath `Set.member` seen
@@ -40,11 +40,11 @@ evaluateFileResult filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
processedAst <- preprocessFile filePath
let finalEnv = evalTricu Map.empty processedAst
case extractMain finalEnv of
Right result -> return result
Right evalResult -> return evalResult
Left err -> errorWithoutStackTrace err
evaluateFile :: FilePath -> IO Env
@@ -53,7 +53,7 @@ evaluateFile filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu Map.empty ast
@@ -63,7 +63,7 @@ evaluateFileWithContext env filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu env ast
@@ -84,8 +84,8 @@ preprocessFile' seen base currentPath = do
imported <- concat <$> mapM (processImportPath seen' base) importPaths
pure $ imported ++ nonImports
where
processImportPath seen base (path, name, importPath) = do
ast <- preprocessFile' seen base importPath
processImportPath _seen _base (_path, name, importPath) = do
ast <- preprocessFile' _seen _base importPath
pure $ map (nsDefinition (if name == "!Local" then "" else name))
$ filter (not . isImp) ast
isImp (SImport _ _) = True
@@ -109,9 +109,9 @@ nsDefinition moduleName other =
nsBody moduleName other
nsBody :: String -> TricuAST -> TricuAST
nsBody moduleName (SVar name)
| isPrefixed name = SVar name
| otherwise = SVar (nsVariable moduleName name)
nsBody moduleName (SVar name mhash)
| isPrefixed name = SVar name mhash
| otherwise = SVar (nsVariable moduleName name) mhash
nsBody moduleName (SApp func arg) =
SApp (nsBody moduleName func) (nsBody moduleName arg)
nsBody moduleName (SLambda args body) =
@@ -122,18 +122,16 @@ 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 moduleName (SDef name args body) =
SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body)
nsBody _ other = other
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
nsBodyScoped moduleName args body = case body of
SVar name ->
SVar name mhash ->
if name `elem` args
then SVar name
else nsBody moduleName (SVar name)
then SVar name mhash
else nsBody moduleName (SVar name mhash)
SApp func arg ->
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
SLambda innerArgs innerBody ->
@@ -141,13 +139,11 @@ nsBodyScoped moduleName args body = case body of
SList items ->
SList (map (nsBodyScoped moduleName args) items)
TFork left right ->
TFork (nsBodyScoped moduleName args left)
(nsBodyScoped moduleName args right)
TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
TStem subtree ->
TStem (nsBodyScoped moduleName args subtree)
SDef name innerArgs innerBody ->
SDef (nsVariable moduleName name) innerArgs
(nsBodyScoped moduleName (args ++ innerArgs) innerBody)
SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
other -> other
isPrefixed :: String -> Bool

View File

@@ -4,13 +4,12 @@ import Research
import Control.Monad (void)
import Data.Functor (($>))
import Data.Set ()
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char hiding (space)
import Text.Megaparsec.Char.Lexer
import qualified Data.Set as Set
type Lexer = Parsec Void String
tricuLexer :: Lexer [LToken]
@@ -23,25 +22,25 @@ tricuLexer = do
]
sc
pure tok
tokens <- many $ do
toks <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
pure (header ++ tokens)
pure (header ++ toks)
where
tricuLexer' =
[ try lnewline
, try namespace
, try dot
, try identifierWithHash
, try identifier
, try keywordT
, try integerLiteral
, try stringLiteral
, assign
, colon
, backslash
, openParen
, closeParen
, openBracket
@@ -51,18 +50,39 @@ tricuLexer = do
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens
Right toks -> toks
keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
identifierWithHash :: Lexer LToken
identifierWithHash = do
first <- lowerChar <|> char '_'
rest <- many $ letterChar
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
<|> char '$' <|> char '@' <|> char '%'
_ <- char '#' -- Consume '#'
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
<?> "hash characters (alphanumeric or hyphen)"
let name = first : rest
let hashLen = length hashString
if name == "t" || name == "!result"
then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix."
else if hashLen < 16 then
fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
else if hashLen > 64 then -- Assuming SHA256, max 64
fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
else
return (LIdentifierWithHash name hashString)
identifier :: Lexer LToken
identifier = do
first <- lowerChar <|> char '_'
rest <- many $ letterChar
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
<|> char '$' <|> char '@' <|> char '%'
let name = first : rest
if name == "t" || name == "!result"
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
@@ -94,9 +114,6 @@ assign = char '=' $> LAssign
colon :: Lexer LToken
colon = char ':' $> LColon
backslash :: Lexer LToken
backslash = char '\\' $> LBackslash
openParen :: Lexer LToken
openParen = char '(' $> LOpenParen
@@ -125,8 +142,24 @@ integerLiteral = do
stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- many (noneOf ['"'])
char '"' --"
void (char '"')
content <- manyTill Lexer.charLiteral (void (char '"'))
return (LStringLiteral content)
charLiteral :: Lexer Char
charLiteral = escapedChar <|> normalChar
where
normalChar = noneOf ['"', '\\']
escapedChar = do
void $ char '\\'
c <- oneOf ['n', 't', 'r', 'f', 'b', '\\', '"', '\'']
return $ case c of
'n' -> '\n'
't' -> '\t'
'r' -> '\r'
'f' -> '\f'
'b' -> '\b'
'\\' -> '\\'
'"' -> '"'
'\'' -> '\''
_ -> c

View File

@@ -1,17 +1,28 @@
module Main where
import ContentStore (initContentStore, termNames, hashToTerm, parseNameList)
import Eval (evalTricu, mainResult, result)
import FileEval
import Parser (parseTricu)
import REPL
import Research
import Wire
import Control.Monad (foldM)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isHexDigit)
import Control.Monad.IO.Class ()
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Data.Version (showVersion)
import Text.Megaparsec (runParser)
import Paths_tricu (version)
import System.Console.CmdArgs
import System.IO (hPutStrLn, stderr)
import System.Exit (die)
import Text.Megaparsec ()
import qualified Data.ByteString.Lazy as BL
import Database.SQLite.Simple (Connection, Only(..), close)
import qualified Database.SQLite.Simple as DB (query)
import qualified Data.Map as Map
@@ -19,6 +30,8 @@ data TricuArgs
= Repl
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
| TDecode { file :: [FilePath] }
| Export { hash :: String, exportNameOpt :: String, outFile :: FilePath }
| Import { inFile :: FilePath }
deriving (Show, Data, Typeable)
replMode :: TricuArgs
@@ -52,38 +65,157 @@ decodeMode = TDecode
&= explicit
&= name "decode"
exportMode :: TricuArgs
exportMode = Export
{ hash = def &= help "Full/prefix hash or stored term name to export."
&= name "h" &= typ "HASH_OR_NAME"
, exportNameOpt = def &= help "Export name to place in the bundle manifest. Defaults to the stored term name when exporting by name; otherwise defaults to root."
&= name "n" &= typ "NAME"
, outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
}
&= help "Export a Merkle bundle from the content store."
&= explicit
&= name "export"
importMode :: TricuArgs
importMode = Import
{ inFile = def &= help "Path to the bundle file to import."
&= name "f" &= typ "FILE"
}
&= help "Import a Merkle bundle into the content store."
&= explicit
&= name "import"
main :: IO ()
main = do
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, exportMode, importMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary versionStr
&= versionArg [explicit, name "version", summary versionStr]
case args of
case cmdArgsParsed of
Repl -> do
putStrLn "Welcome to the tricu REPL"
putStrLn "You can exit with `CTRL+D` or the `!exit` command.`"
repl Map.empty
Evaluate { file = filePaths, form = form } -> do
result <- case filePaths of
[] -> do
t <- getContents
pure $ runTricu t
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
Evaluate { file = filePaths, form = outputForm } -> do
evalResult <- case filePaths of
[] -> runTricuT <$> getContents
(filePath:restFilePaths) -> do
initialEnv <- evaluateFile filePath
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
pure $ mainResult finalEnv
let fRes = formatResult form result
let fRes = formatT outputForm evalResult
putStr fRes
TDecode { file = filePaths } -> do
value <- case filePaths of
[] -> getContents
(filePath:_) -> readFile filePath
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
Export { hash = hashStr, exportNameOpt = exportNameArg, outFile = outFile } -> do
conn <- initContentStore
(resolvedHash, storedNames) <- resolveExportTarget conn hashStr
exportName <- chooseExportName exportNameArg hashStr storedNames
bundleData <- exportNamedBundle conn [(exportName, resolvedHash)]
BL.writeFile outFile (BL.fromStrict bundleData)
putStrLn $ "Exported bundle export " ++ unpack exportName ++ " -> " ++ unpack resolvedHash ++ " to " ++ outFile
close conn
Import { inFile = inFile } -> do
conn <- initContentStore
bundleData <- BL.readFile inFile
roots <- importBundle conn (BL.toStrict bundleData)
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
close conn
runTricu :: String -> T
runTricu input =
runTricu :: String -> String
runTricu = formatT TreeCalculus . runTricuT
runTricuT :: String -> T
runTricuT input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
in result finalEnv
runTricuEnv :: Env -> String -> String
runTricuEnv env = formatT TreeCalculus . runTricuTEnv env
runTricuTEnv :: Env -> String -> T
runTricuTEnv env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
in result finalEnv
runTricuWithEnvT :: String -> (Env, T)
runTricuWithEnvT input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
in (finalEnv, result finalEnv)
runTricuWithEnv :: String -> (Env, String)
runTricuWithEnv input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
res = result finalEnv
in (finalEnv, formatT TreeCalculus res)
runTricuEnvWithEnvT :: Env -> String -> (Env, T)
runTricuEnvWithEnvT env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
in (finalEnv, result finalEnv)
runTricuEnvWithEnv :: Env -> String -> (Env, String)
runTricuEnvWithEnv env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
res = result finalEnv
in (finalEnv, formatT TreeCalculus res)
resolveExportTarget :: Connection -> String -> IO (Text, [Text])
resolveExportTarget conn input = do
let raw = T.pack $ dropWhile (== '#') input
byName <- DB.query conn
"SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
(raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
case byName of
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
(_:_) -> die $ "Ambiguous term name: " ++ input
[] -> do
byHash <- DB.query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
(Only (raw <> T.pack "%")) :: IO [Only T.Text]
case byHash of
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
[] -> if looksLikeHash raw
then return (raw, [])
else die $ "No term found matching: " ++ input
_ -> die $ "Ambiguous hash prefix: " ++ input
namesForHash :: Connection -> Text -> IO [Text]
namesForHash conn h = do
stored <- hashToTerm conn h
return $ maybe [] (parseNameList . termNames) stored
chooseExportName :: String -> String -> [Text] -> IO Text
chooseExportName explicitName input storedNames
| not (null explicitName) = return $ T.pack explicitName
| Just firstName <- firstNonEmpty storedNames = return firstName
| otherwise = do
hPutStrLn stderr $
"No stored name found for export target " ++ input ++ "; using export name 'root'. "
++ "Use export -n NAME to preserve a semantic name."
return "root"
firstNonEmpty :: [Text] -> Maybe Text
firstNonEmpty = go
where
go [] = Nothing
go (x:xs)
| T.null x = go xs
| otherwise = Just x
looksLikeHash :: Text -> Bool
looksLikeHash t =
let len = T.length t
in len >= 16 && len <= 64 && T.all isHexDigit t

View File

@@ -8,7 +8,7 @@ import Control.Monad.State
import Data.List.NonEmpty (toList)
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
import qualified Data.Set as Set
data PState = PState
@@ -20,9 +20,9 @@ type ParserM = StateT PState (Parsec Void [LToken])
satisfyM :: (LToken -> Bool) -> ParserM LToken
satisfyM f = do
token <- lift (satisfy f)
modify' (updateDepth token)
return token
tok <- lift (satisfy f)
modify' (updateDepth tok)
return tok
updateDepth :: LToken -> PState -> PState
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
@@ -39,12 +39,12 @@ topLevelNewline = do
else fail "Top-level exit in nested context (paren or bracket)"
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
parseProgram tokens =
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseProgram toks =
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
parseSingleExpr tokens =
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseSingleExpr toks =
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks
finalizeDepth :: ParserM ()
finalizeDepth = do
@@ -130,7 +130,6 @@ parseFunctionM = do
parseLambdaM :: ParserM TricuAST
parseLambdaM = do
let ident = (\case LIdentifier _ -> True; _ -> False)
_ <- satisfyM (== LBackslash)
params <- some (satisfyM ident)
_ <- satisfyM (== LColon)
scnParserM
@@ -145,11 +144,11 @@ parseLambdaExpressionM = choice
parseAtomicLambdaM :: ParserM TricuAST
parseAtomicLambdaM = choice
[ parseVarM
[ try parseLambdaM
, parseVarM
, parseTreeLeafM
, parseLiteralM
, parseListLiteralM
, try parseLambdaM
, between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
]
@@ -196,6 +195,7 @@ parseTreeTermM = do
| TLeaf <- acc = TStem next
| TStem t <- acc = TFork t next
| TFork _ _ <- acc = TFork acc next
| otherwise = SApp acc next
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
parseTreeLeafOrParenthesizedM = choice
@@ -205,7 +205,8 @@ parseTreeLeafOrParenthesizedM = choice
parseAtomicM :: ParserM TricuAST
parseAtomicM = choice
[ parseVarM
[ try parseLambdaM
, parseVarM
, parseTreeLeafM
, parseListLiteralM
, parseGroupedM
@@ -248,42 +249,51 @@ parseGroupedItemM = do
parseSingleItemM :: ParserM TricuAST
parseSingleItemM = do
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
if | LIdentifier name <- token -> pure (SVar name)
| token == LKeywordT -> pure TLeaf
tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
if | LIdentifier name <- tok -> pure (SVar name Nothing)
| tok == LKeywordT -> pure TLeaf
| otherwise -> fail "Unexpected token in list item"
parseVarM :: ParserM TricuAST
parseVarM = do
token <- satisfyM (\case
tok <- satisfyM (\case
LNamespace _ -> True
LIdentifier _ -> True
LIdentifierWithHash _ _ -> True
_ -> False)
case token of
case tok of
LNamespace ns -> do
_ <- satisfyM (== LDot)
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
pure $ SVar (ns ++ "." ++ name)
pure $ SVar (ns ++ "." ++ name) Nothing
LIdentifier name
| name == "t" || name == "!result" ->
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
| otherwise -> pure (SVar name)
| otherwise -> pure (SVar name Nothing)
LIdentifierWithHash name hash ->
if name == "t" || name == "!result"
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
else pure (SVar name (Just hash))
_ -> fail "Unexpected token while parsing variable"
parseIntLiteralM :: ParserM TricuAST
parseIntLiteralM = do
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
token <- satisfyM intL
if | LIntegerLiteral value <- token ->
pure (SInt value)
tok <- satisfyM intL
if | LIntegerLiteral value <- tok ->
pure (SInt (fromIntegral value))
| otherwise ->
fail "Unexpected token while parsing integer literal"
parseStrLiteralM :: ParserM TricuAST
parseStrLiteralM = do
let strL = (\case LStringLiteral _ -> True; _ -> False)
token <- satisfyM strL
if | LStringLiteral value <- token ->
tok <- satisfyM strL
if | LStringLiteral value <- tok ->
pure (SStr value)
| otherwise ->
fail "Unexpected token while parsing string literal"
@@ -299,8 +309,8 @@ handleParseError bundle =
in unlines ("Parse error(s) encountered:" : formattedErrors)
formatError :: ParseError [LToken] Void -> String
formatError (TrivialError offset unexpected expected) =
let unexpectedMsg = case unexpected of
formatError (TrivialError offset msgUnexpected expected) =
let unexpectedMsg = case msgUnexpected of
Just x -> "unexpected token " ++ show x
Nothing -> "unexpected end of input"
expectedMsg = if null expected

View File

@@ -1,31 +1,57 @@
module REPL where
import ContentStore
import Eval
import FileEval
import Lexer
import Lexer ()
import Parser
import Research
import Wire
import Control.Exception (IOException, SomeException, catch, displayException)
import Control.Monad (forM_)
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
import Control.Exception (SomeException, catch, displayException)
import Control.Monad ()
import Control.Monad (forever, when, forM_, foldM, unless)
import Control.Monad.Catch (handle)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Catch (handle, MonadCatch)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Class ()
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Char (isSpace, isUpper)
import Data.List ( dropWhile
, dropWhileEnd
, isPrefixOf)
import System.Console.Haskeline
import Paths_tricu (version)
import Data.ByteString ()
import Data.Char (isSpace)
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (dropWhileEnd, isPrefixOf, find)
import Data.Maybe (isJust, fromJust)
import Data.Time (getCurrentTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Version (showVersion)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Database.SQLite.Simple (Connection, Only(..), query)
import Paths_tricu (version)
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
import System.Console.Haskeline
import System.Directory (doesFileExist, createDirectoryIfMissing)
import System.FSNotify
import System.FilePath (takeDirectory, (</>))
import Text.Read (readMaybe)
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T ()
repl :: Env -> IO ()
repl env = runInputT settings (withInterrupt (loop env Decode))
data REPLState = REPLState
{ replForm :: EvaluatedForm
, replContentStore :: Maybe Connection
, replWatchedFile :: Maybe FilePath
, replSelectedVersions :: Map.Map String T.Text
, replWatcherThread :: Maybe ThreadId
}
repl :: IO ()
repl = do
conn <- ContentStore.initContentStore
runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
where
settings :: Settings IO
settings = Settings
@@ -40,152 +66,603 @@ repl env = runInputT settings (withInterrupt (loop env Decode))
where
commands = [ "!exit"
, "!output"
, "!definitions"
, "!import"
, "!clear"
, "!save"
, "!reset"
, "!version"
, "!help"
, "!definitions"
, "!watch"
, "!refresh"
, "!versions"
, "!select"
, "!tag"
, "!export"
, "!bundleimport"
]
loop :: Env -> EvaluatedForm -> InputT IO ()
loop env form = handle (interruptHandler env form) $ do
loop :: REPLState -> InputT IO ()
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Exiting tricu"
Nothing -> return ()
Just s
| strip s == "" -> loop env form
| strip s == "" -> loop state
| strip s == "!exit" -> outputStrLn "Exiting tricu"
| strip s == "!clear" -> do
liftIO $ putStr "\ESC[2J\ESC[H"
loop env form
loop state
| strip s == "!reset" -> do
outputStrLn "Environment reset to initial state"
loop Map.empty form
| strip s == "!version" -> do
outputStrLn "Selected versions reset"
loop state { replSelectedVersions = Map.empty }
| strip s == "!help" -> do
outputStrLn $ "tricu version " ++ showVersion version
loop env form
| "!save" `isPrefixOf` strip s -> handleSave env form
| strip s == "!output" -> handleOutput env form
| strip s == "!definitions" -> do
let defs = Map.keys $ Map.delete "!result" env
if null defs
then outputStrLn "No definitions discovered."
else do
outputStrLn "Available definitions:"
mapM_ outputStrLn defs
loop env form
| "!import" `isPrefixOf` strip s -> handleImport env form
| take 2 s == "--" -> loop env form
outputStrLn "Available commands:"
outputStrLn " !exit - Exit the REPL"
outputStrLn " !clear - Clear the screen"
outputStrLn " !reset - Reset preferences for selected versions"
outputStrLn " !help - Show tricu version and available commands"
outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
outputStrLn " !definitions - List all defined terms in the content store"
outputStrLn " !import - Import definitions from file to the content store"
outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them"
outputStrLn " !versions - Show all versions of a term by name"
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
outputStrLn " !tag - Add or update a tag for a term by hash or name"
outputStrLn " !export - Export a term bundle to file (hash, file)"
outputStrLn " !bundleimport- Import a bundle file into the content store"
loop state
| strip s == "!output" -> handleOutput state
| strip s == "!definitions" -> handleDefinitions state
| "!import" `isPrefixOf` strip s -> handleImport state
| "!watch" `isPrefixOf` strip s -> handleWatch state
| strip s == "!refresh" -> handleRefresh state
| "!versions" `isPrefixOf` strip s -> handleVersions state
| "!select" `isPrefixOf` strip s -> handleSelect state
| "!tag" `isPrefixOf` strip s -> handleTag state
| "!export" `isPrefixOf` strip s -> handleExport state
| "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
| take 2 s == "--" -> loop state
| otherwise -> do
newEnv <- liftIO $ processInput env s form `catch` errorHandler env
loop newEnv form
evalResult <- liftIO $ catch
(processInput state s)
(errorHandler state)
loop evalResult
handleOutput :: Env -> EvaluatedForm -> InputT IO ()
handleOutput env currentForm = do
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f)
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
result <- runMaybeT $ do
evalResult <- runMaybeT $ do
input <- MaybeT $ getInputLine "Select output format (1-6) < "
case reads input of
[(n, "")] | n >= 1 && n <= 6 ->
return $ formats !! (n-1)
_ -> MaybeT $ return Nothing
case result of
case evalResult of
Nothing -> do
outputStrLn "Invalid selection. Keeping current output format."
loop env currentForm
loop state
Just newForm -> do
outputStrLn $ "Output format changed to: " ++ show newForm
loop env newForm
loop state { replForm = newForm }
handleImport :: Env -> EvaluatedForm -> InputT IO ()
handleImport env form = do
res <- runMaybeT $ do
let fset = setComplete completeFilename defaultSettings
path <- MaybeT $ runInputT fset $
getInputLineWithInitial "File path to load < " ("", "")
handleDefinitions :: REPLState -> InputT IO ()
handleDefinitions state = case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
terms <- liftIO $ ContentStore.listStoredTerms conn
text <- MaybeT $ liftIO $ handle (\e -> do
putStrLn $ "Error reading file: " ++ displayException (e :: IOException)
return Nothing
) $ Just <$> readFile (strip path)
if null terms
then do
liftIO $ printWarning "No terms in content store."
loop state
else do
liftIO $ do
printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:"
case parseProgram (lexTricu text) of
Left err -> do
lift $ outputStrLn $ "Parse error: " ++ handleParseError err
MaybeT $ return Nothing
Right ast -> do
ns <- MaybeT $ runInputT defaultSettings $
getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "")
let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
let name = strip ns
if (name /= "!Local" && (null name || not (isUpper (head name)))) then do
lift $ outputStrLn "Namespace must start with an uppercase letter"
MaybeT $ return Nothing
else do
prog <- liftIO $ preprocessFile (strip path)
let code = case name of
"!Local" -> prog
_ -> nsDefinitions name prog
env' = evalTricu env code
return env'
case res of
forM_ terms $ \term -> do
let namesStr = T.unpack (termNames term)
hash = termHash term
padding = replicate (maxNameWidth - length namesStr) ' '
liftIO $ do
putStr " "
printVariable namesStr
putStr padding
putStr " [hash: "
displayColoredHash hash
putStrLn "]"
tags <- ContentStore.termToTags conn hash
unless (null tags) $ displayTags tags
loop state
handleImport :: REPLState -> InputT IO ()
handleImport state = do
let fset = setComplete completeFilename defaultSettings
filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "")
case filename of
Nothing -> loop state
Just f -> do
let cleanFilename = strip f
exists <- liftIO $ doesFileExist cleanFilename
if not exists
then do
liftIO $ printError $ "File not found: " ++ cleanFilename
loop state
else importFile state cleanFilename
importFile :: REPLState -> String -> InputT IO ()
importFile state cleanFilename = do
_code <- liftIO $ readFile cleanFilename
case replContentStore state of
Nothing -> do
outputStrLn "Import cancelled"
loop env form
Just env' ->
loop (Map.delete "!result" env') form
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
env <- liftIO $ evaluateFile cleanFilename
interruptHandler :: Env -> EvaluatedForm -> Interrupt -> InputT IO ()
interruptHandler env form _ = do
outputStrLn "Interrupted with CTRL+C\n\
\You can use the !exit command or CTRL+D to exit"
loop env form
liftIO $ do
printSuccess $ "Importing file: " ++ cleanFilename
let defs = Map.toList $ Map.delete "!result" env
processInput :: Env -> String -> EvaluatedForm -> IO Env
processInput env input form = do
let asts = parseTricu input
newEnv = evalTricu env asts
case Map.lookup "!result" newEnv of
Just r -> do
putStrLn $ "tricu > " ++ formatResult form r
Nothing -> pure ()
return newEnv
importedCount <- foldM (\count (name, term) -> do
hash <- ContentStore.storeTerm conn [name] term
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
return (count + (1 :: Int))
) 0 defs
errorHandler :: Env -> SomeException -> IO (Env)
errorHandler env e = do
putStrLn $ "Error: " ++ show e
return env
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
loop state
handleWatch :: REPLState -> InputT IO ()
handleWatch state = do
dbPath <- liftIO ContentStore.getContentStorePath
let filepath = takeDirectory dbPath </> "scratch.tri"
let dirPath = takeDirectory filepath
liftIO $ createDirectoryIfMissing True dirPath
fileExists <- liftIO $ doesFileExist filepath
unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n"
outputStrLn $ "Using scratch file: " ++ filepath
when (isJust (replWatcherThread state)) $ do
outputStrLn "Stopping previous file watch"
liftIO $ killThread (fromJust $ replWatcherThread state)
outputStrLn $ "Starting to watch file: " ++ filepath
outputStrLn "Press Ctrl+C to stop watching and return to REPL"
liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
now <- getCurrentTime
lastProcessed <- readIORef lastProcessedRef
when (diffUTCTime now lastProcessed > 0.5) $ do
putStrLn $ "\nFile changed: " ++ filepath
processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
writeIORef lastProcessedRef now
forever $ threadDelay 1000000
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
_handleUnwatch :: REPLState -> InputT IO ()
_handleUnwatch state = case replWatchedFile state of
Nothing -> do
outputStrLn "No file is currently being watched"
loop state
Just path -> do
outputStrLn $ "Stopped watching " ++ path
when (isJust (replWatcherThread state)) $ do
liftIO $ killThread (fromJust $ replWatcherThread state)
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }
handleRefresh :: REPLState -> InputT IO ()
handleRefresh state = case replContentStore state of
Nothing -> do
outputStrLn "Content store not initialized"
loop state
Just _conn -> do
outputStrLn "Environment refreshed from content store (definitions are live)"
loop state
handleVersions :: REPLState -> InputT IO ()
handleVersions state = case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
liftIO $ printPrompt "Term name: "
nameInput <- getInputLine ""
case nameInput of
Nothing -> loop state
Just n -> do
let termName = strip n
versions <- liftIO $ ContentStore.termVersions conn termName
if null versions
then liftIO $ printError $ "No versions found for term: " ++ termName
else do
liftIO $ do
printKeyword "Versions of "
printVariable termName
putStrLn ":"
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
tags <- ContentStore.termToTags conn hash
putStr $ show (i :: Int) ++ ". "
displayColoredHash hash
putStr $ " (" ++ formatTimestamp ts ++ ")"
unless (null tags) $ do
putStr " ["
printKeyword "Tags: "
forM_ (zip [0..] tags) $ \(j, tag) -> do
printTag (T.unpack tag)
when (j < length tags - 1) $ putStr ", "
putStr "]"
putStrLn ""
loop state
handleSelect :: REPLState -> InputT IO ()
handleSelect state = case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
liftIO $ printPrompt "Term name: "
nameInput <- getInputLine ""
case nameInput of
Nothing -> loop state
Just n -> do
let cleanName = strip n
versions <- liftIO $ ContentStore.termVersions conn cleanName
if null versions
then do
liftIO $ printError $ "No versions found for term: " ++ cleanName
loop state
else do
liftIO $ do
printKeyword "Versions of "
printVariable cleanName
putStrLn ":"
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
tags <- ContentStore.termToTags conn hash
putStr $ show (i :: Int) ++ ". "
displayColoredHash hash
putStr $ " (" ++ formatTimestamp ts ++ ")"
unless (null tags) $ do
putStr " ["
printKeyword "Tags: "
forM_ (zip [0..] tags) $ \(j, tag) -> do
printTag (T.unpack tag)
when (j < length tags - 1) $ putStr ", "
putStr "]"
putStrLn ""
liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): "
choiceInput <- getInputLine ""
let choice = strip <$> choiceInput
selectedHash <- case choice of
Just selectedStr | not (null selectedStr) -> do
case readMaybe selectedStr :: Maybe Int of
Just idx | idx > 0 && idx <= length versions -> do
let (h, _, _) = versions !! (idx - 1)
return $ Just h
_ -> do
let potentialHash = T.pack selectedStr
let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions
case foundByHash of
Just (h, _, _) -> return $ Just h
Nothing -> do
liftIO $ printError "Invalid selection or hash not found in list."
return Nothing
_ -> return Nothing
case selectedHash of
Just hashToSelect -> do
let newState = state { replSelectedVersions =
Map.insert cleanName hashToSelect (replSelectedVersions state) }
liftIO $ do
printSuccess "Selected version "
displayColoredHash hashToSelect
putStr " for term "
printVariable cleanName
putStrLn ""
loop newState
Nothing -> loop state
handleTag :: REPLState -> InputT IO ()
handleTag state = case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): "
identInput <- getInputLine ""
case identInput of
Nothing -> loop state
Just ident -> do
let cleanIdent = strip ident
mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent
case mFullHash of
Nothing -> do
liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent
loop state
Just fullHash -> do
liftIO $ do
putStr "Tagging term with hash: "
displayColoredHash fullHash
putStrLn ""
tags <- liftIO $ ContentStore.termToTags conn fullHash
unless (null tags) $ do
liftIO $ do
printKeyword "Existing tags:"
displayTags tags
liftIO $ printPrompt "Tag to add/set: "
tagValueInput <- getInputLine ""
case tagValueInput of
Nothing -> loop state
Just tv -> do
let tagVal = T.pack (strip tv)
liftIO $ do
ContentStore.setTag conn fullHash tagVal
printSuccess $ "Tag '"
printTag (T.unpack tagVal)
putStr "' set for term with hash "
displayColoredHash fullHash
putStrLn ""
loop state
resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text)
resolveIdentifierToHash conn ident
| T.pack "#" `T.isInfixOf` T.pack ident = do
let hashPrefix = T.pack ident
matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text]
case matchingHashes of
[Only fullHash] -> return $ Just fullHash
[] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing
_ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing
| otherwise = do
versions <- ContentStore.termVersions conn ident
if null versions
then do printError $ "No versions found for term name: " ++ ident; return Nothing
else return $ Just $ (\(h,_,_) -> h) $ head versions
handleExport :: REPLState -> InputT IO ()
handleExport state = do
let fset = setComplete completeFilename defaultSettings
hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
case hashInput of
Nothing -> loop state
Just hashStr -> do
fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
case fileInput of
Nothing -> loop state
Just outFile -> case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
let cleanHash = strip hashStr
hash <- liftIO $ do
let h = T.pack cleanHash
if '#' `T.elem` h
then return h
else do
results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
(Only (h <> "%")) :: IO [Only T.Text]
case results of
[Only fullHash] -> return fullHash
[] -> do
results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
(Only (h <> "%")) :: IO [Only T.Text]
case results2 of
[Only fullHash] -> return fullHash
_ -> do
printError $ "No term found matching: " ++ cleanHash
return h
_ -> do
printError $ "Ambiguous match for: " ++ cleanHash
return h
bundleData <- liftIO $ exportBundle conn [hash]
liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
liftIO $ do
printSuccess $ "Exported bundle with root "
displayColoredHash hash
putStrLn $ " to " ++ outFile
loop state
handleBundleImport :: REPLState -> InputT IO ()
handleBundleImport state = do
let fset = setComplete completeFilename defaultSettings
fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
case fileInput of
Nothing -> loop state
Just inFile -> case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
exists <- liftIO $ doesFileExist inFile
if not exists
then do
liftIO $ printError $ "File not found: " ++ inFile
loop state
else do
bundleData <- liftIO $ BL.readFile inFile
roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
liftIO $ do
printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
loop state
interruptHandler :: REPLState -> Interrupt -> InputT IO ()
interruptHandler state _ = do
liftIO $ do
printWarning "Interrupted with CTRL+C"
printWarning "You can use the !exit command or CTRL+D to exit"
loop state
errorHandler :: REPLState -> SomeException -> IO REPLState
errorHandler state e = do
printError $ "Error: " ++ displayException e
return state
processInput :: REPLState -> String -> IO REPLState
processInput state input = do
let asts = parseTricu input
case asts of
[] -> return state
_ -> case replContentStore state of
Nothing -> do
printError "Content store not initialized"
return state
Just conn -> do
newState <- foldM (\s astNode -> do
let varsInAst = Eval.findVarNames astNode
foldM (\currentSelectionState varName ->
if Map.member varName (replSelectedVersions currentSelectionState)
then return currentSelectionState
else do
versions <- ContentStore.termVersions conn varName
if length versions > 1
then do
let (latestHash, _, _) = head versions
liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent."
return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) }
else return currentSelectionState
) s varsInAst
) state asts
forM_ asts $ \ast -> do
case ast of
SDef name [] body -> do
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
hash <- ContentStore.storeTerm conn [name] evalResult
liftIO $ do
putStr "tricu > "
printSuccess "Stored definition: "
printVariable name
putStr " with hash "
displayColoredHash hash
putStrLn ""
putStr "tricu > "
printResult $ formatT (replForm newState) evalResult
putStrLn ""
_ -> do
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
liftIO $ do
putStr "tricu > "
printResult $ formatT (replForm newState) evalResult
putStrLn ""
return newState
strip :: String -> String
strip = dropWhileEnd isSpace . dropWhile isSpace
handleSave :: Env -> EvaluatedForm -> InputT IO ()
handleSave env form = do
let fset = setComplete completeFilename defaultSettings
path <- runInputT fset $
getInputLineWithInitial "File to save < " ("", "")
watchLoop :: REPLState -> InputT IO ()
watchLoop state = handle (\Interrupt -> do
outputStrLn "\nStopped watching file"
when (isJust (replWatcherThread state)) $ do
liftIO $ killThread (fromJust $ replWatcherThread state)
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
liftIO $ threadDelay 1000000
watchLoop state
case path of
Nothing -> do
outputStrLn "Save cancelled"
loop env form
Just p -> do
let definitions = Map.toList $ Map.delete "!result" env
filepath = strip p
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
processWatchedFile filepath mconn selectedVersions outputForm = do
content <- readFile filepath
let asts = parseTricu content
outputStrLn "Starting save..."
liftIO $ writeFile filepath ""
outputStrLn "File created..."
forM_ definitions $ \(name, value) -> do
let content = name ++ " = " ++ formatResult TreeCalculus value ++ "\n"
outputStrLn $ "Writing definition: " ++ name ++ " with length " ++ show (length content)
liftIO $ appendFile filepath content
outputStrLn $ "Saved " ++ show (length definitions) ++ " definitions to " ++ p
case mconn of
Nothing -> putStrLn "Content store not initialized for watched file processing."
Just conn -> do
forM_ asts $ \ast -> case ast of
SDef name [] body -> do
evalResult <- evalAST (Just conn) selectedVersions body
hash <- ContentStore.storeTerm conn [name] evalResult
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
_ -> do
evalResult <- evalAST (Just conn) selectedVersions ast
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
putStrLn $ "tricu > Processed file: " ++ filepath
loop env form
formatTimestamp :: Integer -> String
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
displayColoredHash :: T.Text -> IO ()
displayColoredHash hash = do
let (prefix, rest) = T.splitAt 16 hash
setSGR [SetColor Foreground Vivid Cyan]
putStr $ T.unpack prefix
setSGR [SetColor Foreground Dull White]
putStr $ T.unpack rest
setSGR [Reset]
withColor :: ColorIntensity -> Color -> IO () -> IO ()
withColor intensity color action = do
setSGR [SetColor Foreground intensity color]
action
setSGR [Reset]
printColored :: ColorIntensity -> Color -> String -> IO ()
printColored intensity color text = withColor intensity color $ putStr text
printlnColored :: ColorIntensity -> Color -> String -> IO ()
printlnColored intensity color text = withColor intensity color $ putStrLn text
printSuccess :: String -> IO ()
printSuccess = printlnColored Vivid Green
printError :: String -> IO ()
printError = printlnColored Vivid Red
printWarning :: String -> IO ()
printWarning = printlnColored Vivid Yellow
printPrompt :: String -> IO ()
printPrompt = printColored Vivid Blue
printVariable :: String -> IO ()
printVariable = printColored Vivid Magenta
printTag :: String -> IO ()
printTag = printColored Vivid Yellow
printKeyword :: String -> IO ()
printKeyword = printColored Vivid Blue
printResult :: String -> IO ()
printResult = printColored Dull White
displayTags :: [T.Text] -> IO ()
displayTags [] = return ()
displayTags tags = do
putStr " Tags: "
forM_ (zip [0..] tags) $ \(i, tag) -> do
printTag (T.unpack tag)
when (i < length tags - 1) $ putStr ", "
putStrLn ""

View File

@@ -1,12 +1,17 @@
module Research where
import Crypto.Hash (hash, SHA256, Digest)
import Data.ByteArray (convert)
import Data.ByteString.Base16 (decode, encode)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Map ()
import Data.Text (Text, replace)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import System.Console.CmdArgs (Data, Typeable)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text as T
-- Tree Calculus Types
data T = Leaf | Stem T | Fork T T
@@ -14,8 +19,8 @@ data T = Leaf | Stem T | Fork T T
-- Abstract Syntax Tree for tricu
data TricuAST
= SVar String
| SInt Int
= SVar String (Maybe String)
| SInt Integer
| SStr String
| SList [TricuAST]
| SDef String [String] TricuAST
@@ -30,22 +35,22 @@ data TricuAST
-- Lexer Tokens
data LToken
= LKeywordT
| LIdentifier String
= LIdentifier String
| LIdentifierWithHash String String
| LKeywordT
| LNamespace String
| LIntegerLiteral Int
| LStringLiteral String
| LImport String String
| LAssign
| LColon
| LDot
| LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
| LCloseBracket
| LStringLiteral String
| LIntegerLiteral Int
| LNewline
| LImport String String
deriving (Show, Eq, Ord)
deriving (Eq, Show, Ord)
-- Output formats
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
@@ -54,6 +59,66 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
-- Environment containing previously evaluated TC terms
type Env = Map.Map String T
-- Merkle DAG Node types
-- Each Tree Calculus node becomes a content-addressed object.
type MerkleHash = Text
data Node
= NLeaf
| NStem MerkleHash
| NFork MerkleHash MerkleHash
deriving (Show, Eq, Ord)
-- | Canonical serialization of a Node for hashing.
-- Leaf: 0x00
-- Stem: 0x01 || child_hash (32 bytes)
-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
serializeNode :: Node -> BS.ByteString
serializeNode NLeaf = BS.pack [0x00]
serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
where go (Left _) = error "Research.serializeNode: invalid hex hash"
go (Right bs) = bs
serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
where go (Left _) = error "Research.serializeNode: invalid hex hash"
go (Right bs) = bs
-- | Hash a node per the Merkle content-addressing spec.
-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
nodeHash :: Node -> MerkleHash
nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
where sha256WithPrefix payload =
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
-- | Deserialize a Node from canonical bytes.
deserializeNode :: BS.ByteString -> Node
deserializeNode bs =
case BS.uncons bs of
Just (0x00, rest)
| BS.null rest -> NLeaf
Just (0x01, rest)
| BS.length rest == 32 ->
NStem $ decodeUtf8 (encode rest)
Just (0x02, rest)
| BS.length rest == 64 ->
let (l, r) = BS.splitAt 32 rest
in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
_ -> errorWithoutStackTrace "invalid merkle node payload"
-- | Build a Merkle DAG from a Tree Calculus term.
buildMerkle :: T -> Node
buildMerkle Leaf = NLeaf
buildMerkle (Stem t) = NStem (nodeHash child)
where child = buildMerkle t
buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
where
left = buildMerkle l
right = buildMerkle r
-- Tree Calculus Reduction Rules
{-
The t operator is left associative.
@@ -66,9 +131,9 @@ type Env = Map.Map String T
apply :: T -> T -> T
apply (Fork Leaf a) _ = a
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
apply (Fork (Fork a b) c) Leaf = a
apply (Fork (Fork a b) c) (Stem u) = apply b u
apply (Fork (Fork a b) c) (Fork u v) = apply (apply c u) v
apply (Fork (Fork _a _b) _c) Leaf = _a
apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
-- Left associative `t`
apply Leaf b = Stem b
apply (Stem a) b = Fork a b
@@ -85,9 +150,9 @@ _not = Fork (Fork _true (Fork Leaf _false)) Leaf
-- Marshalling
ofString :: String -> T
ofString str = ofList $ map (ofNumber . fromEnum) str
ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
ofNumber :: Int -> T
ofNumber :: Integer -> T
ofNumber 0 = Leaf
ofNumber n =
Fork
@@ -97,7 +162,7 @@ ofNumber n =
ofList :: [T] -> T
ofList = foldr Fork Leaf
toNumber :: T -> Either String Int
toNumber :: T -> Either String Integer
toNumber Leaf = Right 0
toNumber (Fork Leaf rest) = case toNumber rest of
Right n -> Right (2 * n)
@@ -109,8 +174,8 @@ toNumber _ = Left "Invalid Tree Calculus number"
toString :: T -> Either String String
toString tc = case toList tc of
Right list -> traverse (fmap toEnum . toNumber) list
Left err -> Left "Invalid Tree Calculus string"
Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
Left _ -> Left "Invalid Tree Calculus string"
toList :: T -> Either String [T]
toList Leaf = Right []
@@ -120,13 +185,13 @@ toList (Fork x rest) = case toList rest of
toList _ = Left "Invalid Tree Calculus list"
-- Outputs
formatResult :: EvaluatedForm -> T -> String
formatResult TreeCalculus = toSimpleT . show
formatResult FSL = show
formatResult AST = show . toAST
formatResult Ternary = toTernaryString
formatResult Ascii = toAscii
formatResult Decode = decodeResult
formatT :: EvaluatedForm -> T -> String
formatT TreeCalculus = toSimpleT . show
formatT FSL = show
formatT AST = show . toAST
formatT Ternary = toTernaryString
formatT Ascii = toAscii
formatT Decode = decodeResult
toSimpleT :: String -> String
toSimpleT s = T.unpack
@@ -167,7 +232,7 @@ decodeResult tc =
(_, _, Right n) -> show n
(_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
(_, Right [], _) -> "[]"
_ -> formatResult TreeCalculus tc
_ -> formatT TreeCalculus tc
where
isCommonChar c =
let n = fromEnum c

870
src/Wire.hs Normal file
View File

@@ -0,0 +1,870 @@
{-# LANGUAGE DeriveGeneric #-}
module Wire
( Bundle (..)
, BundleManifest (..)
, TreeSpec (..)
, NodeHashSpec (..)
, RuntimeSpec (..)
, BundleRoot (..)
, BundleExport (..)
, BundleMetadata (..)
, ClosureMode (..)
, encodeBundle
, decodeBundle
, verifyBundle
, collectReachableNodes
, exportBundle
, exportNamedBundle
, importBundle
) where
import ContentStore (getNodeMerkle, loadTree, putMerkleNode, storeTerm)
import Research
import Control.Exception (SomeException, evaluate, try)
import Control.Monad (foldM, unless, when)
import Crypto.Hash (Digest, SHA256, hash)
import Data.Aeson ( FromJSON (..)
, ToJSON (..)
, Value (String)
, eitherDecodeStrict'
, encode
, object
, withObject
, (.:)
, (.:?)
, (.!=)
, (.=)
)
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import Data.Foldable (traverse_)
import Data.Map (Map)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Word (Word16, Word32, Word64, Word8)
import Database.SQLite.Simple (Connection)
import GHC.Generics (Generic)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
-- | Portable bundle major/minor version supported by this module.
bundleMajorVersion :: Word16
bundleMajorVersion = 1
bundleMinorVersion :: Word16
bundleMinorVersion = 0
-- | Header magic for the portable executable-object container.
bundleMagic :: ByteString
bundleMagic = BS.pack [0x54, 0x52, 0x49, 0x43, 0x55, 0x42, 0x4e, 0x44] -- "TRICUBND"
headerLength :: Int
headerLength = 32
sectionEntryLength :: Int
sectionEntryLength = 60
sectionManifest, sectionNodes :: Word32
sectionManifest = 1
sectionNodes = 2
flagCritical :: Word16
flagCritical = 0x0001
compressionNone, digestSha256 :: Word16
compressionNone = 0
digestSha256 = 1
-- | Backwards compatibility for the original experimental node-list format.
legacyMagic :: ByteString
legacyMagic = BS.pack [0x54, 0x52, 0x49, 0x43, 0x55] -- "TRICU"
legacyWireVersion :: Word8
legacyWireVersion = 0x01
-- | Closure declaration. V1 only accepts complete bundles for import.
data ClosureMode = ClosureComplete | ClosurePartial
deriving (Show, Eq, Ord, Generic)
instance ToJSON ClosureMode where
toJSON ClosureComplete = String "complete"
toJSON ClosurePartial = String "partial"
instance FromJSON ClosureMode where
parseJSON (String "complete") = pure ClosureComplete
parseJSON (String "partial") = pure ClosurePartial
parseJSON _ = fail "closure must be \"complete\" or \"partial\""
data NodeHashSpec = NodeHashSpec
{ nodeHashAlgorithm :: Text
, nodeHashDomain :: Text
} deriving (Show, Eq, Ord, Generic)
instance ToJSON NodeHashSpec where
toJSON s = object
[ "algorithm" .= nodeHashAlgorithm s
, "domain" .= nodeHashDomain s
]
instance FromJSON NodeHashSpec where
parseJSON = withObject "NodeHashSpec" $ \o -> NodeHashSpec
<$> o .: "algorithm"
<*> o .: "domain"
data TreeSpec = TreeSpec
{ treeCalculus :: Text
, treeNodeHash :: NodeHashSpec
, treeNodePayload :: Text
} deriving (Show, Eq, Ord, Generic)
instance ToJSON TreeSpec where
toJSON s = object
[ "calculus" .= treeCalculus s
, "nodeHash" .= treeNodeHash s
, "nodePayload" .= treeNodePayload s
]
instance FromJSON TreeSpec where
parseJSON = withObject "TreeSpec" $ \o -> TreeSpec
<$> o .: "calculus"
<*> o .: "nodeHash"
<*> o .: "nodePayload"
data RuntimeSpec = RuntimeSpec
{ runtimeSemantics :: Text
, runtimeEvaluation :: Text
, runtimeAbi :: Text
, runtimeCapabilities :: [Text]
} deriving (Show, Eq, Ord, Generic)
instance ToJSON RuntimeSpec where
toJSON s = object
[ "semantics" .= runtimeSemantics s
, "evaluation" .= runtimeEvaluation s
, "abi" .= runtimeAbi s
, "capabilities" .= runtimeCapabilities s
]
instance FromJSON RuntimeSpec where
parseJSON = withObject "RuntimeSpec" $ \o -> RuntimeSpec
<$> o .: "semantics"
<*> o .: "evaluation"
<*> o .: "abi"
<*> o .:? "capabilities" .!= []
data BundleRoot = BundleRoot
{ rootHash :: MerkleHash
, rootRole :: Text
} deriving (Show, Eq, Ord, Generic)
instance ToJSON BundleRoot where
toJSON r = object
[ "hash" .= rootHash r
, "role" .= rootRole r
]
instance FromJSON BundleRoot where
parseJSON = withObject "BundleRoot" $ \o -> BundleRoot
<$> o .: "hash"
<*> o .:? "role" .!= "root"
data BundleExport = BundleExport
{ exportName :: Text
, exportRoot :: MerkleHash
, exportKind :: Text
, exportAbi :: Text
, exportInput :: Maybe Text
, exportOutput :: Maybe Text
} deriving (Show, Eq, Ord, Generic)
instance ToJSON BundleExport where
toJSON e = object
[ "name" .= exportName e
, "root" .= exportRoot e
, "kind" .= exportKind e
, "abi" .= exportAbi e
, "input" .= exportInput e
, "output" .= exportOutput e
]
instance FromJSON BundleExport where
parseJSON = withObject "BundleExport" $ \o -> BundleExport
<$> o .: "name"
<*> o .: "root"
<*> o .:? "kind" .!= "term"
<*> o .:? "abi" .!= "tricu.abi.tree.v1"
<*> o .:? "input"
<*> o .:? "output"
data BundleMetadata = BundleMetadata
{ metadataPackage :: Maybe Text
, metadataVersion :: Maybe Text
, metadataDescription :: Maybe Text
, metadataLicense :: Maybe Text
, metadataCreatedBy :: Maybe Text
} deriving (Show, Eq, Ord, Generic)
instance ToJSON BundleMetadata where
toJSON m = object
[ "package" .= metadataPackage m
, "version" .= metadataVersion m
, "description" .= metadataDescription m
, "license" .= metadataLicense m
, "createdBy" .= metadataCreatedBy m
]
instance FromJSON BundleMetadata where
parseJSON = withObject "BundleMetadata" $ \o -> BundleMetadata
<$> o .:? "package"
<*> o .:? "version"
<*> o .:? "description"
<*> o .:? "license"
<*> o .:? "createdBy"
data BundleManifest = BundleManifest
{ manifestSchema :: Text
, manifestBundleType :: Text
, manifestTree :: TreeSpec
, manifestRuntime :: RuntimeSpec
, manifestClosure :: ClosureMode
, manifestRoots :: [BundleRoot]
, manifestExports :: [BundleExport]
, manifestImports :: [Value]
, manifestSections :: Value
, manifestMetadata :: BundleMetadata
} deriving (Show, Eq, Generic)
instance ToJSON BundleManifest where
toJSON m = object
[ "schema" .= manifestSchema m
, "bundleType" .= manifestBundleType m
, "tree" .= manifestTree m
, "runtime" .= manifestRuntime m
, "closure" .= manifestClosure m
, "roots" .= manifestRoots m
, "exports" .= manifestExports m
, "imports" .= manifestImports m
, "sections" .= manifestSections m
, "metadata" .= manifestMetadata m
]
instance FromJSON BundleManifest where
parseJSON = withObject "BundleManifest" $ \o -> BundleManifest
<$> o .: "schema"
<*> o .: "bundleType"
<*> o .: "tree"
<*> o .: "runtime"
<*> o .: "closure"
<*> o .: "roots"
<*> o .: "exports"
<*> o .:? "imports" .!= []
<*> o .:? "sections" .!= object []
<*> o .:? "metadata" .!= BundleMetadata Nothing Nothing Nothing Nothing Nothing
-- | Portable executable-object bundle.
--
-- Merkle node payloads remain the language-neutral executable core:
-- Leaf = 0x00; Stem = 0x01 || child_hash; Fork = 0x02 || left_hash || right_hash.
-- Names, exports, runtime metadata, and package metadata live in the manifest layer.
data Bundle = Bundle
{ bundleVersion :: Word16
, bundleRoots :: [MerkleHash]
, bundleNodes :: Map MerkleHash ByteString
, bundleManifest :: BundleManifest
, bundleManifestBytes :: ByteString
} deriving (Show, Eq)
-- | Encode a Bundle to portable Bundle v1 bytes.
encodeBundle :: Bundle -> ByteString
encodeBundle bundle =
let nodeSection = encodeNodeSection (bundleNodes bundle)
manifestBytes = if BS.null (bundleManifestBytes bundle)
then BL.toStrict (encode (bundleManifest bundle))
else bundleManifestBytes bundle
sectionCount = 2
dirOffset = fromIntegral headerLength
sectionDirLength = sectionCount * sectionEntryLength
manifestOffset = fromIntegral (headerLength + sectionDirLength)
nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes)
manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone
manifestOffset (fromIntegral $ BS.length manifestBytes) manifestBytes
nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone
nodesOffset (fromIntegral $ BS.length nodeSection) nodeSection
header = encodeHeader bundleMajorVersion bundleMinorVersion
(fromIntegral sectionCount) 0 dirOffset
in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection
-- | Decode portable Bundle v1 bytes, with fallback support for the previous
-- experimental TRICU node-list format.
decodeBundle :: ByteString -> Either String Bundle
decodeBundle bs
| BS.take (BS.length bundleMagic) bs == bundleMagic = decodePortableBundle bs
| BS.take (BS.length legacyMagic) bs == legacyMagic = decodeLegacyBundle bs
| otherwise = Left "invalid magic"
-- ---------------------------------------------------------------------------
-- Portable container encoding / decoding
-- ---------------------------------------------------------------------------
data SectionEntry = SectionEntry
{ seType :: Word32
, seVersion :: Word16
, seFlags :: Word16
, seCompression :: Word16
, seDigestAlgorithm :: Word16
, seOffset :: Word64
, seLength :: Word64
, seDigest :: ByteString
} deriving (Show, Eq)
encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString
encodeHeader major minor sectionCount flags dirOffset =
bundleMagic
<> encode16 major
<> encode16 minor
<> encode32 sectionCount
<> encode64 flags
<> encode64 dirOffset
encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString -> ByteString
encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes sectionBytes =
encode32 sectionType
<> encode16 sectionVersion
<> encode16 sectionFlags
<> encode16 compression
<> encode16 digestSha256
<> encode64 offset
<> encode64 lengthBytes
<> sha256 sectionBytes
decodePortableBundle :: ByteString -> Either String Bundle
decodePortableBundle bs = do
(major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs
when (major /= bundleMajorVersion) $
Left $ "unsupported bundle major version: " ++ show major
let dirStart = fromIntegral dirOffset
dirBytes = fromIntegral sectionCount * sectionEntryLength
when (BS.length bs < dirStart + dirBytes) $
Left "bundle truncated in section directory"
entries <- decodeSectionEntries sectionCount (BS.take dirBytes $ BS.drop dirStart bs)
traverse_ rejectUnknownCritical entries
manifestEntry <- requireSection sectionManifest entries
nodesEntry <- requireSection sectionNodes entries
manifestBytes <- readAndVerifySection bs manifestEntry
nodesBytes <- readAndVerifySection bs nodesEntry
manifest <- case eitherDecodeStrict' manifestBytes of
Left err -> Left $ "invalid manifest JSON: " ++ err
Right m -> Right m
nodes <- decodeNodeSection nodesBytes
let roots = map rootHash (manifestRoots manifest)
return Bundle
{ bundleVersion = major * 1000 + minor
, bundleRoots = roots
, bundleNodes = nodes
, bundleManifest = manifest
, bundleManifestBytes = manifestBytes
}
rejectUnknownCritical :: SectionEntry -> Either String ()
rejectUnknownCritical entry =
let known = seType entry `elem` [sectionManifest, sectionNodes]
critical = seFlags entry .&. flagCritical /= 0
in when (critical && not known) $
Left $ "unknown critical section type: " ++ show (seType entry)
requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry
requireSection sectionType entries =
case filter ((== sectionType) . seType) entries of
[entry] -> Right entry
[] -> Left $ "missing required section type: " ++ show sectionType
_ -> Left $ "duplicate section type: " ++ show sectionType
readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString
readAndVerifySection bs entry = do
when (seCompression entry /= compressionNone) $
Left $ "unsupported compression codec in section " ++ show (seType entry)
when (seDigestAlgorithm entry /= digestSha256) $
Left $ "unsupported digest algorithm in section " ++ show (seType entry)
let offset = fromIntegral (seOffset entry)
len = fromIntegral (seLength entry)
when (offset < 0 || len < 0 || BS.length bs < offset + len) $
Left $ "section extends beyond bundle end: " ++ show (seType entry)
let sectionBytes = BS.take len $ BS.drop offset bs
when (sha256 sectionBytes /= seDigest entry) $
Left $ "section digest mismatch: " ++ show (seType entry)
Right sectionBytes
decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64)
decodePortableHeader bs
| BS.length bs < headerLength = Left "bundle too short for header"
| BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic"
| otherwise = do
(major, r1) <- decode16be "major_version" (BS.drop 8 bs)
(minor, r2) <- decode16be "minor_version" r1
(sectionCount, r3) <- decode32be "section_count" r2
(flags, r4) <- decode64be "flags" r3
(dirOffset, _) <- decode64be "directory_offset" r4
Right (major, minor, sectionCount, flags, dirOffset)
decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry]
decodeSectionEntries count bytes = reverse <$> go count bytes []
where
go 0 _ acc = Right acc
go n bs acc = do
when (BS.length bs < sectionEntryLength) $
Left "section directory truncated"
(sectionType, r1) <- decode32be "section_type" bs
(sectionVersion, r2) <- decode16be "section_version" r1
(sectionFlags, r3) <- decode16be "section_flags" r2
(compression, r4) <- decode16be "compression_codec" r3
(digAlg, r5) <- decode16be "digest_algorithm" r4
(offset, r6) <- decode64be "section_offset" r5
(len, r7) <- decode64be "section_length" r6
let (dig, rest) = BS.splitAt 32 r7
when (BS.length dig /= 32) $ Left "section digest truncated"
let entry = SectionEntry sectionType sectionVersion sectionFlags compression digAlg offset len dig
go (n - 1) rest (entry : acc)
-- ---------------------------------------------------------------------------
-- Manifest construction
-- ---------------------------------------------------------------------------
defaultManifest :: [(Text, MerkleHash)] -> Int -> BundleManifest
defaultManifest namedRoots nodeCount = BundleManifest
{ manifestSchema = "tricu.bundle.manifest.v1"
, manifestBundleType = "tree-calculus-executable-object"
, manifestTree = TreeSpec
{ treeCalculus = "tree-calculus.v1"
, treeNodeHash = NodeHashSpec
{ nodeHashAlgorithm = "sha256"
, nodeHashDomain = "tricu.merkle.node.v1"
}
, treeNodePayload = "tricu.merkle.payload.v1"
}
, manifestRuntime = RuntimeSpec
{ runtimeSemantics = "tree-calculus.v1"
, runtimeEvaluation = "normal-order"
, runtimeAbi = "tricu.abi.tree.v1"
, runtimeCapabilities = []
}
, manifestClosure = ClosureComplete
, manifestRoots = zipWith mkRoot [0 :: Int ..] (map snd namedRoots)
, manifestExports = map mkExport namedRoots
, manifestImports = []
, manifestSections = object
[ "nodes" .= object
[ "count" .= nodeCount
, "payload" .= ("tricu.merkle.payload.v1" :: Text)
]
]
, manifestMetadata = BundleMetadata
{ metadataPackage = Nothing
, metadataVersion = Nothing
, metadataDescription = Nothing
, metadataLicense = Nothing
, metadataCreatedBy = Just "tricu"
}
}
where
mkRoot 0 h = BundleRoot h "default"
mkRoot _ h = BundleRoot h "root"
mkExport (name, h) = BundleExport
{ exportName = name
, exportRoot = h
, exportKind = "term"
, exportAbi = "tricu.abi.tree.v1"
, exportInput = Nothing
, exportOutput = Nothing
}
-- ---------------------------------------------------------------------------
-- Node section encoding / decoding
-- ---------------------------------------------------------------------------
encodeNodeSection :: Map MerkleHash ByteString -> ByteString
encodeNodeSection nodes =
encode64 (fromIntegral $ Map.size nodes)
<> mconcat (map nodeEntryToBinary $ Map.toAscList nodes)
-- | Encode a single (hash, canonical-payload) node entry.
nodeEntryToBinary :: (MerkleHash, ByteString) -> ByteString
nodeEntryToBinary (h, payload) =
merkleHashToRaw h
<> encode32 (fromIntegral $ BS.length payload)
<> payload
decodeNodeSection :: ByteString -> Either String (Map MerkleHash ByteString)
decodeNodeSection bs = do
(nodeCount, rest) <- decode64be "node_count" bs
decodeNodeEntries nodeCount rest
-- | Decode a sequence of node entries.
decodeNodeEntries :: Word64 -> ByteString -> Either String (Map MerkleHash ByteString)
decodeNodeEntries count bs = go count bs Map.empty
where
go 0 rest acc
| BS.null rest = Right acc
| otherwise = Left "trailing bytes after node section"
go n bytes acc
| BS.length bytes < 36 =
Left "not enough bytes for node entry header (hash + length)"
| otherwise = do
let (hashBytes, rest) = BS.splitAt 32 bytes
(plen, rest') <- decode32be "payload_len" rest
let payloadLen = fromIntegral plen
if BS.length rest' < payloadLen
then Left "payload extends beyond node section end"
else do
let (payload, after) = BS.splitAt payloadLen rest'
h = rawToMerkleHash hashBytes
when (Map.member h acc) $
Left $ "duplicate node entry: " ++ unpack h
go (n - 1) after (Map.insert h payload acc)
-- ---------------------------------------------------------------------------
-- Legacy bundle decoding (read-only compatibility)
-- ---------------------------------------------------------------------------
decodeLegacyBundle :: ByteString -> Either String Bundle
decodeLegacyBundle bs
| BS.length bs < 14 = Left "bundle too short"
| BS.take 5 bs /= legacyMagic = Left "invalid legacy magic"
| BS.index bs 5 /= legacyWireVersion =
Left $ "unsupported legacy wire version: " ++ show (BS.index bs 5)
| otherwise = do
(rootCount, rest) <- decode32be "root_count" $ BS.drop 6 bs
(nodeCount, rest') <- decode32be "node_count" rest
let rootBytesLen = fromIntegral rootCount * 32
if BS.length rest' < rootBytesLen
then Left "bundle truncated in root hashes"
else do
let rawRoots = BS.take rootBytesLen rest'
afterRoots = BS.drop rootBytesLen rest'
roots =
[ rawToMerkleHash (BS.take 32 (BS.drop (i * 32) rawRoots))
| i <- [0 :: Int .. fromIntegral rootCount - 1]
]
namedRoots = zip (defaultExportNames $ length roots) roots
nodes <- decodeLegacyNodeEntries nodeCount afterRoots
let manifest = defaultManifest namedRoots (Map.size nodes)
return Bundle
{ bundleVersion = 1
, bundleRoots = roots
, bundleNodes = nodes
, bundleManifest = manifest
, bundleManifestBytes = BL.toStrict (encode manifest)
}
decodeLegacyNodeEntries :: Word32 -> ByteString -> Either String (Map MerkleHash ByteString)
decodeLegacyNodeEntries count bs = fst <$> go count bs Map.empty
where
go 0 rest acc = Right (acc, rest)
go n bytes acc
| BS.length bytes < 36 =
Left "not enough bytes for node entry header (hash + length)"
| otherwise = do
let (hashBytes, rest) = BS.splitAt 32 bytes
(plen, rest') <- decode32be "payload_len" rest
let payloadLen = fromIntegral plen
if BS.length rest' < payloadLen
then Left "payload extends beyond legacy bundle end"
else do
let (payload, after) = BS.splitAt payloadLen rest'
h = rawToMerkleHash hashBytes
when (Map.member h acc) $
Left $ "duplicate node entry: " ++ unpack h
go (n - 1) after (Map.insert h payload acc)
-- ---------------------------------------------------------------------------
-- Bundle verification
-- ---------------------------------------------------------------------------
verifyBundle :: Bundle -> Either String ()
verifyBundle bundle
| bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle)
| Map.null (bundleNodes bundle) = Left "bundle has no nodes"
verifyBundle bundle = do
verifyManifest (bundleManifest bundle)
let nodeMap = bundleNodes bundle
rootSet = Set.fromList (bundleRoots bundle)
manifestRootSet = Set.fromList (map rootHash $ manifestRoots $ bundleManifest bundle)
exportRoots = map exportRoot $ manifestExports $ bundleManifest bundle
unless (rootSet == manifestRootSet) $
Left "bundle root list does not match manifest roots"
traverse_ (requirePresent "root hash missing from bundle") (bundleRoots bundle)
traverse_ (requirePresent "export root hash missing from bundle") exportRoots
decoded <- traverse verifyNodePayload (Map.toList nodeMap)
traverse_ (verifyChildrenPresent nodeMap) decoded
verifyCompleteClosure nodeMap (bundleRoots bundle)
where
requirePresent label h =
unless (Map.member h (bundleNodes bundle)) $
Left $ label ++ ": " ++ unpack h
verifyManifest :: BundleManifest -> Either String ()
verifyManifest manifest = do
when (manifestSchema manifest /= "tricu.bundle.manifest.v1") $
Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest)
when (manifestBundleType manifest /= "tree-calculus-executable-object") $
Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest)
let treeSpec = manifestTree manifest
hashSpec = treeNodeHash treeSpec
runtimeSpec = manifestRuntime manifest
when (treeCalculus treeSpec /= "tree-calculus.v1") $
Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec)
when (nodeHashAlgorithm hashSpec /= "sha256") $
Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec)
when (nodeHashDomain hashSpec /= "tricu.merkle.node.v1") $
Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
when (treeNodePayload treeSpec /= "tricu.merkle.payload.v1") $
Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec)
when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $
Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec)
when (runtimeAbi runtimeSpec /= "tricu.abi.tree.v1") $
Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec)
unless (null $ runtimeCapabilities runtimeSpec) $
Left "host/runtime capabilities are not supported by bundle v1"
when (manifestClosure manifest /= ClosureComplete) $
Left "bundle v1 imports require closure = complete"
unless (null $ manifestImports manifest) $
Left "bundle v1 imports require an empty imports list"
when (null $ manifestRoots manifest) $
Left "manifest has no roots"
when (null $ manifestExports manifest) $
Left "manifest has no exports"
traverse_ verifyExport (manifestExports manifest)
where
verifyExport exported = do
when (T.null $ exportName exported) $
Left "manifest export has empty name"
when (T.null $ exportRoot exported) $
Left "manifest export has empty root"
verifyNodePayload :: (MerkleHash, ByteString) -> Either String (MerkleHash, Node)
verifyNodePayload (h, payload) = do
node <- safeDeserializeNode payload
let actual = nodeHash node
unless (actual == h) $
Left $ "node hash mismatch for " ++ unpack h ++ "; payload hashes to " ++ unpack actual
Right (h, node)
verifyChildrenPresent :: Map MerkleHash ByteString -> (MerkleHash, Node) -> Either String ()
verifyChildrenPresent nodeMap (h, node) =
case node of
NLeaf -> Right ()
NStem child -> requireChild h child
NFork left right -> requireChild h left >> requireChild h right
where
requireChild parent child =
unless (Map.member child nodeMap) $
Left $ "missing child node referenced by " ++ unpack parent ++ ": " ++ unpack child
verifyCompleteClosure :: Map MerkleHash ByteString -> [MerkleHash] -> Either String ()
verifyCompleteClosure nodeMap roots = do
_ <- foldM visit Set.empty roots
Right ()
where
visit seen h
| Set.member h seen = Right seen
| otherwise = do
payload <- case Map.lookup h nodeMap of
Nothing -> Left $ "closure missing node: " ++ unpack h
Just p -> Right p
node <- safeDeserializeNode payload
let seen' = Set.insert h seen
case node of
NLeaf -> Right seen'
NStem child -> visit seen' child
NFork left right -> visit seen' left >>= \seenL -> visit seenL right
safeDeserializeNode :: ByteString -> Either String Node
safeDeserializeNode payload =
case BS.uncons payload of
Just (0x00, rest)
| BS.null rest -> Right NLeaf
| otherwise -> Left "invalid leaf payload length"
Just (0x01, rest)
| BS.length rest == 32 -> Right $ NStem (rawToMerkleHash rest)
| otherwise -> Left "invalid stem payload length"
Just (0x02, rest)
| BS.length rest == 64 ->
let (left, right) = BS.splitAt 32 rest
in Right $ NFork (rawToMerkleHash left) (rawToMerkleHash right)
| otherwise -> Left "invalid fork payload length"
_ -> Left "invalid merkle node payload"
-- ---------------------------------------------------------------------------
-- Reachability traversal
-- ---------------------------------------------------------------------------
collectReachableNodes :: Connection -> MerkleHash -> IO [(MerkleHash, ByteString)]
collectReachableNodes conn root = do
let go seen current = do
case Map.lookup current seen of
Just _ -> return seen
Nothing -> do
maybeNode <- getNodeMerkle conn current
case maybeNode of
Nothing -> error $ "exportBundle: missing Merkle node: " ++ unpack current
Just node -> do
let payload = serializeNode node
seen' = Map.insert current payload seen
case node of
NLeaf -> return seen'
NStem childHash -> go seen' childHash
NFork lHash rHash -> go seen' lHash >>= \seenL -> go seenL rHash
seen <- go Map.empty root
return $ Map.toAscList seen
-- ---------------------------------------------------------------------------
-- High-level export / import
-- ---------------------------------------------------------------------------
exportBundle :: Connection -> [MerkleHash] -> IO ByteString
exportBundle conn hashes = exportNamedBundle conn (zip (defaultExportNames $ length hashes) hashes)
exportNamedBundle :: Connection -> [(Text, MerkleHash)] -> IO ByteString
exportNamedBundle conn namedHashes = do
let hashes = map snd namedHashes
entries <- concat <$> mapM (collectReachableNodes conn) hashes
let nodeMap = Map.fromList entries
manifest = defaultManifest namedHashes (Map.size nodeMap)
manifestBytes = BL.toStrict (encode manifest)
bundle = Bundle
{ bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion
, bundleRoots = hashes
, bundleNodes = nodeMap
, bundleManifest = manifest
, bundleManifestBytes = manifestBytes
}
return $ encodeBundle bundle
importBundle :: Connection -> ByteString -> IO [MerkleHash]
importBundle conn bs = case decodeBundle bs of
Left err -> error $ "Wire.importBundle: " ++ err
Right bundle -> case verifyBundle bundle of
Left err -> error $ "Wire.importBundle verify: " ++ err
Right () -> do
traverse_ (\payload -> do
node <- deserializeForImport payload
putMerkleNode conn node
)
(Map.elems $ bundleNodes bundle)
registerBundleExports conn bundle
return $ bundleRoots bundle
registerBundleExports :: Connection -> Bundle -> IO ()
registerBundleExports conn bundle =
traverse_ registerExport (manifestExports $ bundleManifest bundle)
where
registerExport exported = do
maybeTree <- loadTree conn (exportRoot exported)
case maybeTree of
Nothing -> error $ "Wire.importBundle: export root missing after node import: " ++ unpack (exportRoot exported)
Just tree -> do
_ <- storeTerm conn [unpack $ exportName exported] tree
return ()
-- ---------------------------------------------------------------------------
-- Primitive binary helpers
-- ---------------------------------------------------------------------------
encode16 :: Word16 -> ByteString
encode16 w = BS.pack
[ fromIntegral (shiftR w 8)
, fromIntegral w
]
encode32 :: Word32 -> ByteString
encode32 w = BS.pack
[ fromIntegral (shiftR w 24)
, fromIntegral (shiftR w 16)
, fromIntegral (shiftR w 8)
, fromIntegral w
]
encode64 :: Word64 -> ByteString
encode64 w = BS.pack
[ fromIntegral (shiftR w 56)
, fromIntegral (shiftR w 48)
, fromIntegral (shiftR w 40)
, fromIntegral (shiftR w 32)
, fromIntegral (shiftR w 24)
, fromIntegral (shiftR w 16)
, fromIntegral (shiftR w 8)
, fromIntegral w
]
decode16be :: String -> ByteString -> Either String (Word16, ByteString)
decode16be label bs
| BS.length bs < 2 = Left (label ++ ": not enough bytes for u16")
| otherwise =
let b0 = fromIntegral (BS.index bs 0) :: Word16
b1 = fromIntegral (BS.index bs 1) :: Word16
in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs)
-- | Decode a big-endian u32 from the head of a ByteString.
decode32be :: String -> ByteString -> Either String (Word32, ByteString)
decode32be label bs
| BS.length bs < 4 = Left (label ++ ": not enough bytes for u32")
| otherwise =
let b0 = fromIntegral (BS.index bs 0) :: Word32
b1 = fromIntegral (BS.index bs 1) :: Word32
b2 = fromIntegral (BS.index bs 2) :: Word32
b3 = fromIntegral (BS.index bs 3) :: Word32
val = (b0 `shiftL` 24) .|. (b1 `shiftL` 16)
.|. (b2 `shiftL` 8) .|. b3
in Right (val, BS.drop 4 bs)
decode64be :: String -> ByteString -> Either String (Word64, ByteString)
decode64be label bs
| BS.length bs < 8 = Left (label ++ ": not enough bytes for u64")
| otherwise =
let byte i = fromIntegral (BS.index bs i) :: Word64
val = (byte 0 `shiftL` 56) .|. (byte 1 `shiftL` 48)
.|. (byte 2 `shiftL` 40) .|. (byte 3 `shiftL` 32)
.|. (byte 4 `shiftL` 24) .|. (byte 5 `shiftL` 16)
.|. (byte 6 `shiftL` 8) .|. byte 7
in Right (val, BS.drop 8 bs)
-- ---------------------------------------------------------------------------
-- Hash conversion
-- ---------------------------------------------------------------------------
-- | Convert a hex MerkleHash to its raw 32-byte representation.
merkleHashToRaw :: MerkleHash -> ByteString
merkleHashToRaw h =
case Base16.decode (encodeUtf8 h) of
Left _ -> error $ "Wire.merkleHashToRaw: invalid hex: " ++ show h
Right bs
| BS.length bs == 32 -> bs
| otherwise -> error $ "Wire.merkleHashToRaw: expected 32 bytes: " ++ show h
-- | Convert raw 32 bytes back to a hex MerkleHash.
rawToMerkleHash :: ByteString -> MerkleHash
rawToMerkleHash bs = decodeUtf8 (Base16.encode bs)
sha256 :: ByteString -> ByteString
sha256 bytes = convert ((hash bytes) :: Digest SHA256)
defaultExportNames :: Int -> [Text]
defaultExportNames n =
case n of
0 -> []
1 -> ["root"]
_ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]
deserializeForImport :: ByteString -> IO Node
deserializeForImport payload = do
result <- try (evaluate $ deserializeNode payload) :: IO (Either SomeException Node)
case result of
Left err -> error $ "Wire.importBundle: invalid merkle node payload: " ++ show err
Right node -> return node

View File

@@ -6,23 +6,30 @@ import Lexer
import Parser
import REPL
import Research
import Wire
import ContentStore
import Control.Exception (evaluate, try, SomeException)
import Control.Monad.IO.Class (liftIO)
import Data.Bits (xor)
import Data.List (isInfixOf)
import Data.Text (Text, unpack)
import Data.Word (Word8)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Text.Megaparsec (runParser)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
import Database.SQLite.Simple (close, Connection)
main :: IO ()
main = defaultMain tests
runTricu :: String -> String
runTricu s = show $ result (evalTricu Map.empty $ parseTricu s)
tricuTestString :: String -> String
tricuTestString s = show $ result (evalTricu Map.empty $ parseTricu s)
tests :: TestTree
tests = testGroup "Tricu Tests"
@@ -35,6 +42,9 @@ tests = testGroup "Tricu Tests"
, modules
, demos
, decoding
, elimLambdaSingle
, stressElimLambda
, wireTests
]
lexer :: TestTree
@@ -51,7 +61,22 @@ lexer = testGroup "Lexer Tests"
, testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\""
expect = Right [LStringLiteral "hello\\nworld"]
expect = Right [LStringLiteral "hello\nworld"]
runParser tricuLexer "" input @?= expect
, testCase "Lex multiple escaped characters in strings" $ do
let input = "\"tab:\\t newline:\\n quote:\\\" backslash:\\\\\""
expect = Right [LStringLiteral "tab:\t newline:\n quote:\" backslash:\\"]
runParser tricuLexer "" input @?= expect
, testCase "Lex escaped characters in string literals" $ do
let input = "x = \"line1\\nline2\\tindented\""
expect = Right [LIdentifier "x", LAssign, LStringLiteral "line1\nline2\tindented"]
runParser tricuLexer "" input @?= expect
, testCase "Lex empty string with escape sequence" $ do
let input = "\"\\\"\""
expect = Right [LStringLiteral "\""]
runParser tricuLexer "" input @?= expect
, testCase "Lex mixed literals" $ do
@@ -87,8 +112,8 @@ parser = testGroup "Parser Tests"
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
, testCase "Parse function definitions" $ do
let input = "x = (\\a b c : a)"
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
let input = "x = (a b c : a)"
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a" Nothing))))
parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do
@@ -107,8 +132,8 @@ parser = testGroup "Parser Tests"
parseSingle input @?= expect
, testCase "Parse function with applications" $ do
let input = "f = (\\x : t x)"
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
let input = "f = (x : t x)"
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x" Nothing)))
parseSingle input @?= expect
, testCase "Parse nested lists" $ do
@@ -149,23 +174,23 @@ parser = testGroup "Parser Tests"
parseSingle input @?= expect
, 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 = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do
let input = "(\\a : a)"
expect = (SLambda ["a"] (SVar "a"))
let input = "(a : a)"
expect = (SLambda ["a"] (SVar "a" Nothing))
parseSingle input @?= expect
, testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)"
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
let input = "x = (a b : a)"
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing)))
parseSingle input @?= expect
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\nx (t)"
expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
let input = "x = (a : a)\nx (t)"
expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf]
parseTricu input @?= expect
, testCase "Comments 1" $ do
@@ -251,7 +276,7 @@ simpleEvaluation = testGroup "Evaluation Tests"
, testCase "Immutable definitions" $ do
let input = "x = t t\nx = t\nx"
env = evalTricu Map.empty (parseTricu input)
result <- try (evaluate (runTricu input)) :: IO (Either SomeException String)
result <- try (evaluate (tricuTestString input)) :: IO (Either SomeException String)
case result of
Left _ -> return ()
Right _ -> assertFailure "Expected evaluation error"
@@ -259,7 +284,7 @@ simpleEvaluation = testGroup "Evaluation Tests"
, testCase "Apply identity to Boolean Not" $ do
let not = "(t (t (t t) (t t t)) t)"
let input = "x = (\\a : a)\nx " ++ not
let input = "x = (a : a)\nx " ++ not
env = evalTricu Map.empty (parseTricu input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
]
@@ -267,85 +292,85 @@ simpleEvaluation = testGroup "Evaluation Tests"
lambdas :: TestTree
lambdas = testGroup "Lambda Evaluation Tests"
[ testCase "Lambda Identity Function" $ do
let input = "id = (\\x : x)\nid t"
runTricu input @?= "Leaf"
let input = "id = (x : x)\nid t"
tricuTestString input @?= "Leaf"
, testCase "Lambda Constant Function (K combinator)" $ do
let input = "k = (\\x y : x)\nk t (t t)"
runTricu input @?= "Leaf"
let input = "k = (x y : x)\nk t (t t)"
tricuTestString input @?= "Leaf"
, testCase "Lambda Application with Variable" $ do
let input = "id = (\\x : x)\nval = t t\nid val"
runTricu input @?= "Stem Leaf"
let input = "id = (x : x)\nval = t t\nid val"
tricuTestString input @?= "Stem Leaf"
, testCase "Lambda Application with Multiple Arguments" $ do
let input = "apply = (\\f x y : f x y)\nk = (\\a b : a)\napply k t (t t)"
runTricu input @?= "Leaf"
let input = "apply = (f x y : f x y)\nk = (a b : a)\napply k t (t t)"
tricuTestString input @?= "Leaf"
, testCase "Nested Lambda Application" $ do
let input = "apply = (\\f x y : f x y)\nid = (\\x : x)\napply (\\f x : f x) id t"
runTricu input @?= "Leaf"
let input = "apply = (f x y : f x y)\nid = (x : x)\napply (f x : f x) id t"
tricuTestString input @?= "Leaf"
, testCase "Lambda with a complex body" $ do
let input = "f = (\\x : t (t x))\nf t"
runTricu input @?= "Stem (Stem Leaf)"
let input = "f = (x : t (t x))\nf t"
tricuTestString input @?= "Stem (Stem Leaf)"
, testCase "Lambda returning a function" $ do
let input = "f = (\\x : (\\y : x))\ng = f t\ng (t t)"
runTricu input @?= "Leaf"
let input = "f = (x : (y : x))\ng = f t\ng (t t)"
tricuTestString input @?= "Leaf"
, testCase "Lambda with Shadowing" $ do
let input = "f = (\\x : (\\x : x))\nf t (t t)"
runTricu input @?= "Stem Leaf"
let input = "f = (x : (x : x))\nf t (t t)"
tricuTestString input @?= "Stem Leaf"
, testCase "Lambda returning another lambda" $ do
let input = "k = (\\x : (\\y : x))\nk_app = k t\nk_app (t t)"
runTricu input @?= "Leaf"
let input = "k = (x : (y : x))\nk_app = k t\nk_app (t t)"
tricuTestString input @?= "Leaf"
, testCase "Lambda with free variables" $ do
let input = "y = t t\nf = (\\x : y)\nf t"
runTricu input @?= "Stem Leaf"
let input = "y = t t\nf = (x : y)\nf t"
tricuTestString input @?= "Stem Leaf"
, testCase "SKI Composition" $ do
let input = "s = (\\x y z : x z (y z))\nk = (\\x y : x)\ni = (\\x : x)\ncomp = s k i\ncomp t (t t)"
runTricu input @?= "Stem (Stem Leaf)"
let input = "s = (x y z : x z (y z))\nk = (x y : x)\ni = (x : x)\ncomp = s k i\ncomp t (t t)"
tricuTestString input @?= "Stem (Stem Leaf)"
, testCase "Lambda with multiple parameters and application" $ do
let input = "f = (\\a b c : t a b c)\nf t (t t) (t t t)"
runTricu input @?= "Stem Leaf"
let input = "f = (a b c : t a b c)\nf t (t t) (t t t)"
tricuTestString input @?= "Stem Leaf"
, testCase "Lambda with nested application in the body" $ do
let input = "f = (\\x : t (t (t x)))\nf t"
runTricu input @?= "Stem (Stem (Stem Leaf))"
let input = "f = (x : t (t (t x)))\nf t"
tricuTestString input @?= "Stem (Stem (Stem Leaf))"
, testCase "Lambda returning a function and applying it" $ do
let input = "f = (\\x : (\\y : t x y))\ng = f t\ng (t t)"
runTricu input @?= "Fork Leaf (Stem Leaf)"
let input = "f = (x : (y : t x y))\ng = f t\ng (t t)"
tricuTestString input @?= "Fork Leaf (Stem Leaf)"
, testCase "Lambda applying a variable" $ do
let input = "id = (\\x : x)\na = t t\nid a"
runTricu input @?= "Stem Leaf"
let input = "id = (x : x)\na = t t\nid a"
tricuTestString input @?= "Stem Leaf"
, testCase "Nested lambda abstractions in the same expression" $ do
let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
runTricu input @?= "Leaf"
let input = "f = (x : (y : x y))\ng = (z : z)\nf g t"
tricuTestString input @?= "Leaf"
, testCase "Lambda applied to string literal" $ do
let input = "f = (\\x : x)\nf \"hello\""
runTricu input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) Leaf))))"
let input = "f = (x : x)\nf \"hello\""
tricuTestString input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) Leaf))))"
, testCase "Lambda applied to integer literal" $ do
let input = "f = (\\x : x)\nf 42"
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
let input = "f = (x : x)\nf 42"
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
, testCase "Lambda applied to list literal" $ do
let input = "f = (\\x : x)\nf [t (t t)]"
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
let input = "f = (x : x)\nf [t (t t)]"
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
, testCase "Lambda containing list literal" $ do
let input = "(\\a : [(a)]) 1"
runTricu input @?= "Fork (Fork (Stem Leaf) Leaf) Leaf"
let input = "(a : [(a)]) 1"
tricuTestString input @?= "Fork (Fork (Stem Leaf) Leaf) Leaf"
]
providedLibraries :: TestTree
@@ -419,7 +444,7 @@ providedLibraries = testGroup "Library Tests"
, testCase "List map" $ do
library <- evaluateFile "./lib/list.tri"
let input = "head (tail (map (\\a : (t t t)) [(t) (t) (t)]))"
let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
@@ -518,7 +543,7 @@ demos = testGroup "Test provided demo functionality"
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"
decodeResult res @?= "321"
, 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 \""
@@ -555,3 +580,346 @@ decoding = testGroup "Decoding Tests"
let input = ofList [ofList [ofString "nested"], ofString "string"]
decodeResult input @?= "[[\"nested\"], \"string\"]"
]
elimLambdaSingle :: TestTree
elimLambdaSingle = testCase "elimLambda preserves eval, fires eta, and SDef binds" $ do
-- 1) eta reduction, purely structural and parsed from source
let [etaIn] = parseTricu "x : f x"
[fRef ] = parseTricu "f"
elimLambda etaIn @?= fRef
-- 2) SDef binds its own name and parameters
let [defFXY] = parseTricu "f x y : f x"
fv = freeVars defFXY
assertBool "f should be bound in SDef" ("f" `Set.notMember` fv)
assertBool "x should be bound in SDef" ("x" `Set.notMember` fv)
assertBool "y should be bound in SDef" ("y" `Set.notMember` fv)
-- 3) semantics preserved on a small program that exercises compose and triage
let src =
unlines
[ "false = t"
, "_ = t"
, "true = t t"
, "id = a : a"
, "const = a b : a"
, "compose = f g x : f (g x)"
, "triage = leaf stem fork : t (t leaf stem) fork"
, "test = triage \"Leaf\" (_ : \"Stem\") (_ _ : \"Fork\")"
, "main = compose id id test"
]
prog = parseTricu src
progElim = map elimLambda prog
evalBefore = result (evalTricu Map.empty prog)
evalAfter = result (evalTricu Map.empty progElim)
evalAfter @?= evalBefore
stressElimLambda :: TestTree
stressElimLambda = testCase "stress elimLambda on wide list under deep curried lambda" $ do
let numVars = 200
numBody = 800
vars = [ "x" ++ show i | i <- [1..numVars] ]
body = "(" ++ unwords (replicate numBody "t") ++ ")"
etaOne = "h : f h"
etaTwo = "k : id k"
defId = "id = a : a"
lambda = unwords vars ++ " : " ++ body
src = unlines
[ defId
, etaOne
, "compose = f g x : f (g x)"
, "f = t t"
, etaTwo
, lambda
, "main = compose id id (" ++ head vars ++ " : f " ++ head vars ++ ")"
]
prog = parseTricu src
let out = map elimLambda prog
let noLambda term = case term of
SLambda _ _ -> False
SApp f g -> noLambda f && noLambda g
SList xs -> all noLambda xs
TFork l r -> noLambda l && noLambda r
TStem u -> noLambda u
_ -> True
assertBool "all lambdas eliminated" (all noLambda out)
let before = result (evalTricu Map.empty prog)
after = result (evalTricu Map.empty out)
after @?= before
-- --------------------------------------------------------------------------
-- Wire module tests
-- --------------------------------------------------------------------------
-- | Helper: create a temporary file-backed DB, store a term, return the
-- connection and the term (so callers can compare after round-trip).
storeTermInTempDB :: String -> IO (Connection, Text, T)
storeTermInTempDB src = do
conn <- newContentStore
let asts = parseTricu src
finalEnv = evalTricu Map.empty asts
term = result finalEnv
-- storeMerkleNodes returns MerkleHash as Text; storeTerm expects [String]
_ <- storeTerm conn [] term
return (conn, hashTerm term, term)
-- | Load a term from a DB by its stored hash Text.
loadTermByHash :: Connection -> Text -> IO T
loadTermByHash conn h = do
maybeTerm <- loadTree conn h
case maybeTerm of
Just t -> return t
Nothing -> errorWithoutStackTrace $ "hash not found in store: " ++ Data.Text.unpack h
-- | Flip one byte in a ByteString at the given index.
corruptByte :: ByteString -> Int -> ByteString
corruptByte bs i = BS.take i bs <> BS.pack [(BS.index bs i `xor` 0x01)] <> BS.drop (i + 1) bs
wireTests :: TestTree
wireTests = testGroup "Wire Tests"
[ testCase "Portable bundle: header and manifest declare Tree Calculus object format" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "id = a : a"
, "main = id t"
]
wireData <- exportBundle srcConn [termHash]
BS.take 8 wireData @?= BS.pack [0x54, 0x52, 0x49, 0x43, 0x55, 0x42, 0x4e, 0x44]
case decodeBundle wireData of
Left err -> assertFailure $ "decodeBundle failed: " ++ err
Right bundle -> do
let manifest = bundleManifest bundle
tree = manifestTree manifest
hashSpec = treeNodeHash tree
runtime = manifestRuntime manifest
manifestSchema manifest @?= "tricu.bundle.manifest.v1"
manifestBundleType manifest @?= "tree-calculus-executable-object"
manifestClosure manifest @?= ClosureComplete
treeCalculus tree @?= "tree-calculus.v1"
treeNodePayload tree @?= "tricu.merkle.payload.v1"
nodeHashAlgorithm hashSpec @?= "sha256"
nodeHashDomain hashSpec @?= "tricu.merkle.node.v1"
runtimeSemantics runtime @?= "tree-calculus.v1"
runtimeAbi runtime @?= "tricu.abi.tree.v1"
runtimeCapabilities runtime @?= []
bundleRoots bundle @?= [termHash]
map exportRoot (manifestExports manifest) @?= [termHash]
close srcConn
, testCase "Portable bundle: named exports are manifest aliases for Merkle roots" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "validateEmail = a : a"
, "main = validateEmail t"
]
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
case decodeBundle wireData of
Left err -> assertFailure $ "decodeBundle failed: " ++ err
Right bundle -> do
bundleRoots bundle @?= [termHash]
case manifestExports (bundleManifest bundle) of
[exported] -> do
exportName exported @?= "validateEmail"
exportRoot exported @?= termHash
exportKind exported @?= "term"
exportAbi exported @?= "tricu.abi.tree.v1"
exports -> assertFailure $ "Expected one export, got: " ++ show exports
close srcConn
, testCase "Portable bundle: renaming an export changes bundle bytes but not tree identity" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "f = a : a"
, "main = f t"
]
mainBundleData <- exportNamedBundle srcConn [("main", termHash)]
renamedBundleData <- exportNamedBundle srcConn [("validate", termHash)]
assertBool "Renaming an export should change the manifest/bundle bytes"
(mainBundleData /= renamedBundleData)
case (decodeBundle mainBundleData, decodeBundle renamedBundleData) of
(Right mainBundle, Right renamedBundle) -> do
bundleRoots mainBundle @?= [termHash]
bundleRoots renamedBundle @?= [termHash]
map exportRoot (manifestExports $ bundleManifest mainBundle)
@?= map exportRoot (manifestExports $ bundleManifest renamedBundle)
map exportName (manifestExports $ bundleManifest mainBundle) @?= ["main"]
map exportName (manifestExports $ bundleManifest renamedBundle) @?= ["validate"]
(Left err, _) -> assertFailure $ "decodeBundle main failed: " ++ err
(_, Left err) -> assertFailure $ "decodeBundle renamed failed: " ++ err
close srcConn
, testCase "Portable bundle: exact byte export is deterministic" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "x = t t"
, "main = t x"
]
first <- exportBundle srcConn [termHash]
second <- exportBundle srcConn [termHash]
first @?= second
close srcConn
, testCase "Portable bundle: raw section tampering is rejected by digest verification" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "x = t"
, "main = t x"
]
wireData <- exportBundle srcConn [termHash]
let tampered = corruptByte wireData (BS.length wireData - 1)
case decodeBundle tampered of
Left err -> assertBool ("Expected section digest mismatch, got: " ++ err)
("digest mismatch" `isInfixOf` err)
Right _ -> assertFailure "Expected decodeBundle to reject tampered section bytes"
close srcConn
, testCase "Portable bundle: unsupported manifest semantics are rejected" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "x = t"
, "main = t x"
]
wireData <- exportBundle srcConn [termHash]
case decodeBundle wireData of
Left err -> assertFailure $ "decodeBundle failed: " ++ err
Right bundle -> do
let manifest = bundleManifest bundle
partialBundle = bundle
{ bundleManifest = manifest { manifestClosure = ClosurePartial }
, bundleManifestBytes = BS.empty
}
capabilityBundle = bundle
{ bundleManifest = manifest
{ manifestRuntime = (manifestRuntime manifest)
{ runtimeCapabilities = ["host.io"]
}
}
, bundleManifestBytes = BS.empty
}
wrongHashBundle = bundle
{ bundleManifest = manifest
{ manifestTree = (manifestTree manifest)
{ treeNodeHash = (treeNodeHash $ manifestTree manifest)
{ nodeHashAlgorithm = "blake3" }
}
}
, bundleManifestBytes = BS.empty
}
case verifyBundle partialBundle of
Left err -> assertBool ("Expected closure error, got: " ++ err) ("closure = complete" `isInfixOf` err)
Right () -> assertFailure "Expected partial closure to be rejected"
case verifyBundle capabilityBundle of
Left err -> assertBool ("Expected capability error, got: " ++ err) ("capabilities" `isInfixOf` err)
Right () -> assertFailure "Expected runtime capabilities to be rejected"
case verifyBundle wrongHashBundle of
Left err -> assertBool ("Expected hash algorithm error, got: " ++ err) ("node hash algorithm" `isInfixOf` err)
Right () -> assertFailure "Expected unsupported node hash algorithm to be rejected"
close srcConn
, testCase "Portable bundle: import registers manifest export names in fresh content store" $ do
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
[ "validateEmail = a : a"
, "main = validateEmail t"
]
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
dstConn <- newContentStore
_ <- importBundle dstConn wireData
loadedByHash <- loadTermByHash dstConn termHash
loadedByName <- loadTerm dstConn "validateEmail"
loadedByHash @?= originalTerm
loadedByName @?= Just originalTerm
close srcConn
close dstConn
, testCase "Round-trip: store, export, import, load" $ do
-- Store a term
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
[ "x = t"
, "y = t x"
, "z = t y"
, "main = z"
]
-- Export by root hash
wireData <- exportBundle srcConn [termHash]
-- Import into a fresh DB
dstConn <- newContentStore
_ <- importBundle dstConn wireData
-- Load the term back and compare
loadedTerm <- loadTermByHash dstConn termHash
loadedTerm @?= originalTerm
-- Cleanup
close srcConn
close dstConn
, testCase "Round-trip: evaluate from original, export, import, load root" $ do
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
[ "add = a b : t (t a) b"
, "val = add (t t) (t)"
, "main = val"
]
-- Export
wireData <- exportBundle srcConn [termHash]
-- Import into fresh DB
dstConn <- newContentStore
_ <- importBundle dstConn wireData
-- Load the root term by hash and compare
loadedTerm <- loadTermByHash dstConn termHash
loadedTerm @?= originalTerm
close srcConn
close dstConn
, testCase "Negative: corrupt payload byte causes import to fail" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "x = t"
, "y = t x"
, "z = t y"
, "main = z"
]
wireData <- exportBundle srcConn [termHash]
-- Decode, mutate one node's payload byte, re-encode
case decodeBundle wireData of
Left err -> assertFailure $ "decodeBundle failed: " ++ err
Right bundle -> do
let (h, payload) =
head
[ (h', p)
| (h', p) <- Map.toList (bundleNodes bundle)
, BS.length p > 0
]
payload' = BS.pack [(BS.head payload `xor` 0x01)] <> BS.tail payload
bundle' = bundle { bundleNodes = Map.insert h payload' (bundleNodes bundle) }
wireData' = encodeBundle bundle'
dstConn <- newContentStore
result <- try (importBundle dstConn wireData') :: IO (Either SomeException [MerkleHash])
case result of
Left e ->
assertBool ("Expected hash mismatch or invalid payload, got: " ++ show e)
$ "mismatch" `isInfixOf` show e || "invalid" `isInfixOf` show e
Right _ ->
assertFailure "Expected import to fail on corrupted payload"
close dstConn
close srcConn
, testCase "Negative: missing child node causes import to fail" $ do
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
[ "x = t"
, "y = t x"
, "z = t y"
, "main = z"
]
wireData <- exportBundle srcConn [termHash]
-- Decode, remove a node, re-encode
case decodeBundle wireData of
Left err -> assertFailure $ "decodeBundle failed: " ++ err
Right bundle -> do
let nodeList = Map.toList (bundleNodes bundle)
trimmed = Map.fromList (tail nodeList)
newBundle = bundle { bundleNodes = trimmed }
newWire = encodeBundle newBundle
dstConn <- newContentStore
result <- try (importBundle dstConn newWire) :: IO (Either SomeException [MerkleHash])
case result of
Left e ->
assertBool ("Expected verify error, got: " ++ show e) True
Right _ ->
assertFailure "Expected import to fail on missing child node"
close dstConn
close srcConn
]

View File

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

View File

@@ -1 +1 @@
main = (\x : x) t
main = (x : x) t

View File

@@ -1,2 +1,2 @@
x = map (\i : append "Successfully concatenated " i) [("two strings!")]
x = map (i : append "Successfully concatenated " i) [("two strings!")]
main = equal? x [("Successfully concatenated two strings!")]

View File

@@ -1,21 +1,21 @@
compose = \f g x : f (g x)
compose = f g x : f (g x)
succ = y (\self :
succ = y (self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
(_ tail : t t (self tail))
t))
size = (\x :
(y (\self x :
size = (x :
(y (self x :
compose succ
(triage
(\x : x)
(x : x)
self
(\x y : compose (self x) (self y))
(x y : compose (self x) (self y))
x)) x 0))
size size

View File

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

View File

@@ -1 +1 @@
y = \x : x
y = x : x

View File

@@ -1,8 +1,8 @@
cabal-version: 1.12
name: tricu
version: 0.18.1
description: A micro-language for exploring Tree Calculus
version: 1.1.0
description: A language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
copyright: James Eversole
@@ -15,31 +15,62 @@ extra-source-files:
executable tricu
main-is: Main.hs
hs-source-dirs:
src
src
default-extensions:
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
ScopedTypeVariables
ghc-options:
-Wall
-Wcompat
-Wunused-imports
-Wunused-top-binds
-Wunused-local-binds
-Wunused-matches
-Wredundant-constraints
-threaded
-rtsopts
-with-rtsopts=-N
-optl-pthread
-fPIC
build-depends:
base >=4.7
, aeson
, ansi-terminal
, base16-bytestring
, base64-bytestring
, bytestring
, cereal
, cmdargs
, containers
, cryptonite
, directory
, exceptions
, filepath
, fsnotify
, haskeline
, megaparsec
, memory
, mtl
, sqlite-simple
, tasty
, tasty-hunit
, text
, time
, transformers
, zlib
other-modules:
ContentStore
Eval
FileEval
Lexer
Parser
Paths_tricu
REPL
Research
Wire
default-language: Haskell2010
test-suite tricu-tests
@@ -51,25 +82,41 @@ test-suite tricu-tests
LambdaCase
MultiWayIf
OverloadedStrings
ScopedTypeVariables
build-depends:
base
base >=4.7
, aeson
, ansi-terminal
, base16-bytestring
, base64-bytestring
, bytestring
, cereal
, cmdargs
, containers
, cryptonite
, directory
, exceptions
, filepath
, fsnotify
, haskeline
, megaparsec
, memory
, mtl
, sqlite-simple
, tasty
, tasty-hunit
, tasty-quickcheck
, text
, time
, transformers
, zlib
default-language: Haskell2010
other-modules:
ContentStore
Eval
FileEval
Lexer
Parser
Paths_tricu
REPL
Research
Wire