Compare commits
32 Commits
0.15.0
...
89bb73ed99
| Author | SHA1 | Date | |
|---|---|---|---|
| 89bb73ed99 | |||
| 1c4c49e68d | |||
| e7a6426060 | |||
| 7e16607d96 | |||
| a36ff638a9 | |||
| 0cd849447f | |||
| fe453b9b96 | |||
| fb09b4666e | |||
| efbe9350ed | |||
| 2627627493 | |||
| c008126b14 | |||
| 6b97b210ca | |||
|
|
71653311ce | ||
| 0cdc0bfc34 | |||
| c36d963640 | |||
| 72e5810ca9 | |||
| b96a3f2ef0 | |||
| 6780b242b1 | |||
| 94514f7dd0 | |||
| 43e83be9a4 | |||
| 3717942589 | |||
| b8e2743103 | |||
| 25bfe139e8 | |||
| f2beb86d8a | |||
| 5024a2be4c | |||
| fccee3e61c | |||
| ad1918aa6f | |||
| 0a505172b4 | |||
| e6e18239a7 | |||
| 871245b567 | |||
| 30b9505d5f | |||
| f4e50353ed |
2
.gitignore
vendored
2
.gitignore
vendored
@@ -6,6 +6,8 @@
|
|||||||
/Dockerfile
|
/Dockerfile
|
||||||
/config.dhall
|
/config.dhall
|
||||||
/result
|
/result
|
||||||
|
/result*
|
||||||
|
.aider*
|
||||||
WD
|
WD
|
||||||
bin/
|
bin/
|
||||||
dist*
|
dist*
|
||||||
|
|||||||
334
AGENTS.md
Normal file
334
AGENTS.md
Normal file
@@ -0,0 +1,334 @@
|
|||||||
|
# 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 |
|
||||||
|
| `Wire.hs` | Arborix portable wire format — encode/decode/import/export of Merkle-DAG bundle blobs |
|
||||||
|
|
||||||
|
### 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("arborix.merkle.node.v1" <> 0x00 <> serialized_node)
|
||||||
|
```
|
||||||
|
|
||||||
|
This is stored in SQLite via `ContentStore.hs`. Hash suffixes on identifiers (e.g., `foo_abc123...`) are validated: 16–64 hex characters (SHA256).
|
||||||
|
|
||||||
|
## 7. Arborix Portable Wire Format
|
||||||
|
|
||||||
|
The **Arborix wire format** (module `Wire.hs`) defines a portable binary bundle for exchanging Tree Calculus terms, their Merkle DAGs, and associated metadata. It is versioned and schema-driven.
|
||||||
|
|
||||||
|
### Header
|
||||||
|
|
||||||
|
```
|
||||||
|
+------------------+-----------------+------------------+----------------+
|
||||||
|
| Magic (8 bytes) | Major (2 bytes) | Minor (2 bytes) | Section Count |
|
||||||
|
| | | | (4 bytes) |
|
||||||
|
+------------------+-----------------+------------------+----------------+
|
||||||
|
| Flags (8 bytes) | Dir Offset (8 bytes)
|
||||||
|
+------------------+-----------------+------------------+
|
||||||
|
```
|
||||||
|
|
||||||
|
- **Magic**: `ARBORIX\0` (`0x41 0x52 0x42 0x4f 0x52 0x49 0x58 0x00`)
|
||||||
|
- **Header length**: 32 bytes
|
||||||
|
- **Major version**: `1` | **Minor version**: `0`
|
||||||
|
|
||||||
|
### Section Directory
|
||||||
|
|
||||||
|
Immediately follows the header. Each section entry is 60 bytes:
|
||||||
|
|
||||||
|
```
|
||||||
|
+------------------+------------------+-----------------+------------------+
|
||||||
|
| Type (4 bytes) | Version (2 bytes)| Flags (2 bytes) | Compression (2) |
|
||||||
|
+------------------+------------------+-----------------+------------------+
|
||||||
|
| Digest Algo (2) | Offset (8 bytes) | Length (8 bytes)| SHA256 digest (32)|
|
||||||
|
+------------------+------------------+-----------------+------------------+
|
||||||
|
```
|
||||||
|
|
||||||
|
Known section types:
|
||||||
|
|
||||||
|
| Type | Name | Required | Description |
|
||||||
|
|------|-----------|----------|-------------|
|
||||||
|
| 1 | manifest | Yes | JSON manifest metadata |
|
||||||
|
| 2 | nodes | Yes | Binary Merkle node payloads |
|
||||||
|
|
||||||
|
### Section 1 — Manifest (JSON)
|
||||||
|
|
||||||
|
The manifest describes the bundle's semantics, exports, and schema. Key fields:
|
||||||
|
|
||||||
|
| Field | Value | Description |
|
||||||
|
|-------|-------|-------------|
|
||||||
|
| `schema` | `"arborix.bundle.manifest.v1"` | Manifest schema version |
|
||||||
|
| `bundleType` | `"tree-calculus-executable-object"` | Bundle category |
|
||||||
|
| `tree.calculus` | `"tree-calculus.v1"` | Tree calculus version |
|
||||||
|
| `tree.nodeHash.algorithm` | `"sha256"` | Hash algorithm |
|
||||||
|
| `tree.nodeHash.domain` | `"arborix.merkle.node.v1"` | Hash domain string |
|
||||||
|
| `tree.nodePayload` | `"arborix.merkle.payload.v1"` | Payload encoding |
|
||||||
|
| `runtime.semantics` | `"tree-calculus.v1"` | Evaluation semantics |
|
||||||
|
| `runtime.abi` | `"arborix.abi.tree.v1"` | Runtime ABI |
|
||||||
|
| `closure` | `"complete"` | Bundle must be a complete DAG |
|
||||||
|
| `roots` | `[{"hash": "...", "role": "..."}]` | Named root hashes |
|
||||||
|
| `exports` | `[{"name": "...", "root": "..."}]` | Export aliases for roots |
|
||||||
|
| `metadata.createdBy` | `"arborix"` | Originator |
|
||||||
|
|
||||||
|
### Section 2 — Nodes (Binary)
|
||||||
|
|
||||||
|
```
|
||||||
|
+------------------+-------------------+-------------------+-----------------+
|
||||||
|
| Node Count (8) | Hash (32 bytes) | Payload Len (4) | Payload (N) |
|
||||||
|
+------------------+-------------------+-------------------+-----------------+
|
||||||
|
```
|
||||||
|
|
||||||
|
Each node entry contains:
|
||||||
|
- 32-byte Merkle hash (hex-encoded in identifiers, raw in binary)
|
||||||
|
- 4-byte big-endian payload length
|
||||||
|
- N bytes of serialized node payload (`0x00` for Leaf, `0x01 || hash` for Stem, `0x02 || left || right` for Fork)
|
||||||
|
|
||||||
|
### Bundle verification flow
|
||||||
|
|
||||||
|
1. Check magic bytes
|
||||||
|
2. Validate major version
|
||||||
|
3. Parse section directory
|
||||||
|
4. For each section: verify SHA256 digest against actual bytes
|
||||||
|
5. Decode JSON manifest
|
||||||
|
6. Decode binary node entries into Merkle DAG
|
||||||
|
7. Verify all root hashes present in manifest exist in node map
|
||||||
|
8. Verify export root hashes present
|
||||||
|
9. Verify children references are complete (no dangling nodes)
|
||||||
|
10. Reject unknown critical sections
|
||||||
|
|
||||||
|
### Data types (Wire.hs)
|
||||||
|
|
||||||
|
| Type | Purpose |
|
||||||
|
|------|---------|
|
||||||
|
| `Bundle` | Top-level bundle: version, roots, nodes map, manifest |
|
||||||
|
| `BundleManifest` | JSON metadata: schema, tree spec, runtime spec, roots, exports |
|
||||||
|
| `TreeSpec` | Tree calculus version + hash algorithm + payload encoding |
|
||||||
|
| `NodeHashSpec` | Hash algorithm and domain string |
|
||||||
|
| `RuntimeSpec` | Semantics, evaluation order, ABI, capabilities |
|
||||||
|
| `BundleRoot` | Root hash + role (`"default"` or `"root"`) |
|
||||||
|
| `BundleExport` | Export name + root hash + kind + ABI |
|
||||||
|
| `BundleMetadata` | Optional package, version, description, license, createdBy |
|
||||||
|
| `ClosureMode` | `ClosureComplete` or `ClosurePartial` |
|
||||||
|
|
||||||
|
### Key functions
|
||||||
|
|
||||||
|
| Function | Signature | Purpose |
|
||||||
|
|----------|-----------|---------|
|
||||||
|
| `encodeBundle` | `Bundle → ByteString` | Serialize bundle to wire bytes |
|
||||||
|
| `decodeBundle` | `ByteString → Either String Bundle` | Parse wire bytes into Bundle |
|
||||||
|
| `verifyBundle` | `Bundle → Either String ()` | Validate DAG, manifest, roots |
|
||||||
|
| `collectReachableNodes` | `Connection → MerkleHash → IO [(MerkleHash, ByteString)]` | Traverse DAG from root |
|
||||||
|
| `exportBundle` | `Connection → [MerkleHash] → IO ByteString` | Build bundle from content store |
|
||||||
|
| `exportNamedBundle` | `Connection → [(Text, MerkleHash)] → IO ByteString` | Build with named roots |
|
||||||
|
| `importBundle` | `Connection → ByteString → IO [MerkleHash]` | Import bundle into content store |
|
||||||
|
|
||||||
|
## 8. 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
|
||||||
|
│ └── Wire.hs # Arborix portable wire format
|
||||||
|
├── 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
|
||||||
|
```
|
||||||
|
|
||||||
|
## 9. JS Arborix Runtime
|
||||||
|
|
||||||
|
A JavaScript implementation of the Arborix portable bundle runtime lives in `ext/js/`.
|
||||||
|
It is a reference implementation — not a tricu source parser. It reads `.tri.bundle` files produced by the Haskell toolchain, verifies Merkle node hashes, reconstructs tree values, and reduces them.
|
||||||
|
|
||||||
|
From project root:
|
||||||
|
```bash
|
||||||
|
node ext/js/src/cli.js inspect test/fixtures/id.tri.bundle
|
||||||
|
node ext/js/src/cli.js run test/fixtures/true.tri.bundle
|
||||||
|
```
|
||||||
|
|
||||||
|
The JS runtime implements:
|
||||||
|
- Bundle binary format parsing (header, section directory, manifest, nodes)
|
||||||
|
- SHA-256 Merkle node hash verification against canonical payloads
|
||||||
|
- Closure verification (all child references present)
|
||||||
|
- Tree reconstruction from node DAG
|
||||||
|
- Core `apply` reduction rules
|
||||||
|
- Basic codecs (decodeResult)
|
||||||
|
- CLI: `inspect` and `run` commands
|
||||||
|
|
||||||
|
## 10. Content Store Workflow (Custom DB)
|
||||||
|
|
||||||
|
The content store location is controlled by the `TRICU_DB_PATH` environment variable. When set, `eval` mode automatically loads all stored terms into the initial environment, so you can call any previously imported/evaluated term by name.
|
||||||
|
|
||||||
|
```bash
|
||||||
|
# Use a local DB
|
||||||
|
export TRICU_DB_PATH=/tmp/tricu-local.db
|
||||||
|
|
||||||
|
# Import terms from the standard library
|
||||||
|
./result/bin/tricu import -f lib/list.tri
|
||||||
|
|
||||||
|
# Now use them in eval mode
|
||||||
|
echo "not? (t t)" | ./result/bin/tricu eval -t decode
|
||||||
|
# Output: t
|
||||||
|
|
||||||
|
echo "not? (t t t)" | ./result/bin/tricu eval -t decode
|
||||||
|
# Output: Stem Leaf
|
||||||
|
|
||||||
|
echo "equal? (t t) (t t t)" | ./result/bin/tricu eval -t decode
|
||||||
|
# Output: t
|
||||||
|
|
||||||
|
# Check what's in the store
|
||||||
|
./result/bin/tricu
|
||||||
|
t> !definitions
|
||||||
|
```
|
||||||
|
|
||||||
|
Without `TRICU_DB_PATH` set, `eval` uses only the terms defined in the input file(s).
|
||||||
|
|
||||||
|
## 11. 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.
|
||||||
|
|
||||||
|
## 12. Viewing Haskell Dependency Docs from Nix
|
||||||
|
|
||||||
|
When you need Haddock documentation for a Haskell dependency available in Nixpkgs, build the package's `doc` output directly with `^doc`.
|
||||||
|
|
||||||
|
Example:
|
||||||
|
|
||||||
|
Replace `megaparsec` with the dependency name you need:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
nix build "nixpkgs#haskellPackages.${pkg}^doc"
|
||||||
|
```
|
||||||
|
|
||||||
|
View the available documentation files:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
find ./result-doc -type f \( -name '*.html' -o -name '*.haddock' \) | sort
|
||||||
|
```
|
||||||
54
README.md
54
README.md
@@ -2,37 +2,29 @@
|
|||||||
|
|
||||||
## Introduction
|
## Introduction
|
||||||
|
|
||||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
|
tricu (pronounced "tree-shoe") is a 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 under active development and you should expect breaking changes with every commit.*
|
|
||||||
|
|
||||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||||
|
|
||||||
## Features
|
I have fully embraced the slopmachine (LLM-assisted development) for this project. Nothing is stable or sacred. We will discover sanity at the end of the journey but we won't strive for it until then.
|
||||||
|
|
||||||
- Tree Calculus operator: `t`
|
## Acknowledgements
|
||||||
- Assignments: `x = t t`
|
|
||||||
- Immutable definitions
|
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.
|
||||||
- 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
|
|
||||||
|
|
||||||
## REPL examples
|
## REPL examples
|
||||||
|
|
||||||
```
|
```
|
||||||
tricu < -- Anything after `--` on a single line is a comment
|
tricu < -- Anything after `--` on a single line is a comment
|
||||||
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
|
tricu < id = (a : a) -- Lambda abstraction is eliminated to tree calculus terms
|
||||||
tricu < head (map (\i : append i " world!") [("Hello, ")])
|
tricu < head (map (i : append i " world!") [("Hello, ")])
|
||||||
tricu > "Hello, world!"
|
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 > "Hello, world!"
|
||||||
|
|
||||||
tricu < -- Intensionality! We can inspect the structure of a function or data.
|
tricu < -- Intensionality! We can inspect the structure of a function or data.
|
||||||
tricu < triage = (\a b c : t (t a b) c)
|
tricu < triage = (a b c : t (t a b) c)
|
||||||
tricu < test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
|
tricu < test = triage "Leaf" (z : "Stem") (a b : "Fork")
|
||||||
tricu < test (t t)
|
tricu < test (t t)
|
||||||
tricu > "Stem"
|
tricu > "Stem"
|
||||||
tricu < -- We can even convert a term back to source code (/demos/toSource.tri)
|
tricu < -- We can even convert a term back to source code (/demos/toSource.tri)
|
||||||
@@ -41,13 +33,27 @@ tricu > "(t (t (t t) (t t t)) (t t (t t t)))"
|
|||||||
tricu < -- or calculate its size (/demos/size.tri)
|
tricu < -- or calculate its size (/demos/size.tri)
|
||||||
tricu < size not?
|
tricu < size not?
|
||||||
tricu > 12
|
tricu > 12
|
||||||
|
|
||||||
|
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
|
## Installation and Use
|
||||||
|
|
||||||
[Releases are available for Linux.](https://git.eversole.co/James/tricu/releases)
|
You can easily build and run this project using [Nix](https://nixos.org/download/).
|
||||||
|
|
||||||
Or you can easily build and run this project using [Nix](https://nixos.org/download/).
|
|
||||||
|
|
||||||
- Quick Start (REPL):
|
- Quick Start (REPL):
|
||||||
- `nix run git+https://git.eversole.co/James/tricu`
|
- `nix run git+https://git.eversole.co/James/tricu`
|
||||||
@@ -83,9 +89,3 @@ tricu decode [OPTIONS]
|
|||||||
-f --file=FILE Optional input file path to attempt decoding.
|
-f --file=FILE Optional input file path to attempt decoding.
|
||||||
Defaults to stdin.
|
Defaults to stdin.
|
||||||
```
|
```
|
||||||
|
|
||||||
## 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.
|
|
||||||
|
|||||||
@@ -11,20 +11,17 @@ demo_true = t t
|
|||||||
not_TC? = t (t (t t) (t t t)) (t t (t t t))
|
not_TC? = t (t (t t) (t t t)) (t t (t t t))
|
||||||
|
|
||||||
-- /demos/toSource.tri contains an explanation of `triage`
|
-- /demos/toSource.tri contains an explanation of `triage`
|
||||||
demo_triage = \a b c : t (t a b) c
|
demo_triage = a b c : t (t a b) c
|
||||||
demo_matchBool = (\ot of : demo_triage
|
demo_matchBool = a b : demo_triage b (_ : a) (_ _ : a)
|
||||||
of
|
|
||||||
(\_ : ot)
|
|
||||||
(\_ _ : ot)
|
|
||||||
)
|
|
||||||
-- Lambda representation of the Boolean `not` function
|
-- Lambda representation of the Boolean `not` function
|
||||||
not_Lambda? = demo_matchBool demo_false demo_true
|
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
|
-- functions defined via Lambda terms are larger than the most efficient TC
|
||||||
-- representation. Between different languages that evaluate to tree calculus
|
-- representation possible. Between different languages that evaluate to tree
|
||||||
-- terms, the exact implementation of Lambda elimination may differ and lead
|
-- calculus terms, the exact implementation of Lambda elimination may differ
|
||||||
-- to different tree representations even if they share extensional behavior.
|
-- and lead to different trees even if they share extensional behavior.
|
||||||
|
|
||||||
-- Let's see if these are the same:
|
-- Let's see if these are the same:
|
||||||
lambdaEqualsTC = equal? not_TC? not_Lambda?
|
lambdaEqualsTC = equal? not_TC? not_Lambda?
|
||||||
|
|||||||
@@ -18,47 +18,47 @@ main = exampleTwo
|
|||||||
-- / / \
|
-- / / \
|
||||||
-- 4 5 6
|
-- 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))
|
(if (emptyList? (tail node))
|
||||||
[]
|
[]
|
||||||
(head (tail node))))
|
(head (tail node))))
|
||||||
|
|
||||||
right = (\node : if (emptyList? node)
|
right = node : (if (emptyList? node)
|
||||||
[]
|
[]
|
||||||
(if (emptyList? (tail node))
|
(if (emptyList? (tail node))
|
||||||
[]
|
[]
|
||||||
(if (emptyList? (tail (tail node)))
|
(if (emptyList? (tail (tail node)))
|
||||||
[]
|
[]
|
||||||
(head (tail (tail 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
|
(pair (map label queue) (self (filter
|
||||||
(\node : not? (emptyList? node))
|
(node : not? (emptyList? node))
|
||||||
(append (map left queue) (map right queue))))))
|
(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
|
||||||
(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))))))
|
(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")
|
exampleOne = levelOrderTraversal [("1")
|
||||||
[("2") [("4") t t] t]
|
[("2") [("4") t t] t]
|
||||||
[("3") [("5") t t] [("6") t t]]]
|
[("3") [("5") t t] [("6") t t]]]
|
||||||
|
|
||||||
exampleTwo = levelOrderTraversal [("1")
|
exampleTwo = levelOrderTraversal [("1")
|
||||||
[("2") [("4") [("8") t t] [("9") t t]]
|
[("2") [("4") [("8") t t] [("9") t t]]
|
||||||
[("6") [("10") t t] [("12") t t]]]
|
[("6") [("10") t t] [("12") t t]]]
|
||||||
[("3") [("5") [("11") t t] t] [("7") t t]]]
|
[("3") [("5") [("11") t t] t] [("7") t t]]]
|
||||||
|
|||||||
37
demos/patternMatching.tri
Normal file
37
demos/patternMatching.tri
Normal 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!"
|
||||||
@@ -3,11 +3,9 @@
|
|||||||
|
|
||||||
main = size size
|
main = size size
|
||||||
|
|
||||||
size = (\x :
|
size = x : y (self x : compose succ (triage
|
||||||
(y (\self x :
|
id
|
||||||
compose succ
|
self
|
||||||
(triage
|
(x y : compose (self x) (self y))
|
||||||
(\x : x)
|
x)
|
||||||
self
|
) x 0
|
||||||
(\x y : compose (self x) (self y))
|
|
||||||
x)) x 0))
|
|
||||||
|
|||||||
@@ -18,25 +18,25 @@ main = toSource not?
|
|||||||
sourceLeaf = t (head "t")
|
sourceLeaf = t (head "t")
|
||||||
|
|
||||||
-- Stem case
|
-- Stem case
|
||||||
sourceStem = (\convert : (\a rest :
|
sourceStem = convert : (a rest :
|
||||||
t (head "(") -- Start with a left parenthesis "(".
|
t (head "(") -- Start with a left parenthesis "(".
|
||||||
(t (head "t") -- Add a "t"
|
(t (head "t") -- Add a "t"
|
||||||
(t (head " ") -- Add a space.
|
(t (head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the argument.
|
(convert a -- Recursively convert the argument.
|
||||||
(t (head ")") rest)))))) -- Close with ")" and append the rest.
|
(t (head ")") rest))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Fork case
|
-- Fork case
|
||||||
sourceFork = (\convert : (\a b rest :
|
sourceFork = convert : (a b rest :
|
||||||
t (head "(") -- Start with a left parenthesis "(".
|
t (head "(") -- Start with a left parenthesis "(".
|
||||||
(t (head "t") -- Add a "t"
|
(t (head "t") -- Add a "t"
|
||||||
(t (head " ") -- Add a space.
|
(t (head " ") -- Add a space.
|
||||||
(convert a -- Recursively convert the first arg.
|
(convert a -- Recursively convert the first arg.
|
||||||
(t (head " ") -- Add another space.
|
(t (head " ") -- Add another space.
|
||||||
(convert b -- Recursively convert the second arg.
|
(convert b -- Recursively convert the second arg.
|
||||||
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
|
(t (head ")") rest))))))) -- Close with ")" and append the rest.
|
||||||
|
|
||||||
-- Wrapper around triage
|
-- Wrapper around triage
|
||||||
toSource_ = y (\self arg :
|
toSource_ = y (self arg :
|
||||||
triage
|
triage
|
||||||
sourceLeaf -- `triage` "a" case, Leaf
|
sourceLeaf -- `triage` "a" case, Leaf
|
||||||
(sourceStem self) -- `triage` "b" case, Stem
|
(sourceStem self) -- `triage` "b" case, Stem
|
||||||
@@ -44,7 +44,7 @@ toSource_ = y (\self arg :
|
|||||||
arg) -- The term to be inspected
|
arg) -- The term to be inspected
|
||||||
|
|
||||||
-- toSource takes a single TC term and returns a String
|
-- toSource takes a single TC term and returns a String
|
||||||
toSource = \v : toSource_ v ""
|
toSource = v : toSource_ v ""
|
||||||
|
|
||||||
exampleOne = toSource true -- OUT: "(t t)"
|
exampleOne = toSource true -- OUT: "(t t)"
|
||||||
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||||
|
|||||||
49
ext/bundle-runtime-profile-v1.md
Normal file
49
ext/bundle-runtime-profile-v1.md
Normal file
@@ -0,0 +1,49 @@
|
|||||||
|
1. Scope
|
||||||
|
This profile defines the minimum required behavior for runtimes that execute tricu bundles.
|
||||||
|
|
||||||
|
2. Non-goals
|
||||||
|
No tricu source parsing.
|
||||||
|
No lambda elimination.
|
||||||
|
No module system.
|
||||||
|
No package manager.
|
||||||
|
No local DB requirement.
|
||||||
|
No authoring names beyond bundle exports.
|
||||||
|
|
||||||
|
3. Required bundle sections
|
||||||
|
Header
|
||||||
|
Manifest/exports
|
||||||
|
Merkle nodes
|
||||||
|
|
||||||
|
4. Optional/skippable sections
|
||||||
|
Source, debug, package metadata, signatures, provenance, etc.
|
||||||
|
|
||||||
|
5. Entrypoint selection
|
||||||
|
Explicit export name first.
|
||||||
|
Else export named main.
|
||||||
|
Else single default root.
|
||||||
|
Else error.
|
||||||
|
|
||||||
|
6. Node payload format
|
||||||
|
Leaf/Stem/Fork byte layouts.
|
||||||
|
|
||||||
|
7. Hash verification
|
||||||
|
Domain string and payload hashing rules.
|
||||||
|
|
||||||
|
8. Closure verification
|
||||||
|
All referenced child hashes must exist.
|
||||||
|
|
||||||
|
9. Runtime representation
|
||||||
|
Suggested JS representation, but not normative.
|
||||||
|
|
||||||
|
10. Reduction semantics
|
||||||
|
The six Tree Calculus apply rules.
|
||||||
|
|
||||||
|
11. Codecs for v1
|
||||||
|
Raw tree required.
|
||||||
|
Maybe string/bool optional or experimental.
|
||||||
|
|
||||||
|
12. Required error cases
|
||||||
|
Bad magic/version, missing export, hash mismatch, malformed payload, missing child.
|
||||||
|
|
||||||
|
13. Test fixtures
|
||||||
|
List of bundles the implementation must pass.
|
||||||
17
ext/js/package.json
Normal file
17
ext/js/package.json
Normal file
@@ -0,0 +1,17 @@
|
|||||||
|
{
|
||||||
|
"name": "arborix-runtime",
|
||||||
|
"version": "0.1.0",
|
||||||
|
"description": "Arborix portable bundle runtime — JavaScript reference implementation",
|
||||||
|
"type": "module",
|
||||||
|
"main": "src/bundle.js",
|
||||||
|
"bin": {
|
||||||
|
"arborix-run": "src/cli.js"
|
||||||
|
},
|
||||||
|
"scripts": {
|
||||||
|
"test": "node --test test/*.test.js",
|
||||||
|
"inspect": "node src/cli.js inspect",
|
||||||
|
"run": "node src/cli.js run"
|
||||||
|
},
|
||||||
|
"keywords": ["arborix", "tree-calculus", "trie", "runtime"],
|
||||||
|
"license": "MIT"
|
||||||
|
}
|
||||||
188
ext/js/src/bundle.js
Normal file
188
ext/js/src/bundle.js
Normal file
@@ -0,0 +1,188 @@
|
|||||||
|
/**
|
||||||
|
* bundle.js — Parse an Arborix portable bundle binary into a JavaScript object.
|
||||||
|
*
|
||||||
|
* Format (v1):
|
||||||
|
* Header (32 bytes):
|
||||||
|
* Magic 8B "ARBORIX\0"
|
||||||
|
* Major 2B u16 BE (must be 1)
|
||||||
|
* Minor 2B u16 BE
|
||||||
|
* SectionCount 4B u32 BE
|
||||||
|
* Flags 8B u64 BE
|
||||||
|
* DirOffset 8B u64 BE
|
||||||
|
* Section Directory (SectionCount × 60 bytes):
|
||||||
|
* Type 4B u32 BE
|
||||||
|
* Version 2B u16 BE
|
||||||
|
* Flags 2B u16 BE (bit 0 = critical)
|
||||||
|
* Compression 2B u16 BE
|
||||||
|
* DigestAlgo 2B u16 BE
|
||||||
|
* Offset 8B u64 BE
|
||||||
|
* Length 8B u64 BE
|
||||||
|
* SHA256Digest 32B raw
|
||||||
|
*/
|
||||||
|
|
||||||
|
import { createHash } from "node:crypto";
|
||||||
|
|
||||||
|
// ── Constants ───────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
const MAGIC = Buffer.from([0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00]); // "ARBORIX\0"
|
||||||
|
const HEADER_LENGTH = 32;
|
||||||
|
const SECTION_ENTRY_LENGTH = 60;
|
||||||
|
const SECTION_MANIFEST = 1;
|
||||||
|
const SECTION_NODES = 2;
|
||||||
|
const FLAG_CRITICAL = 0x0001;
|
||||||
|
const COMPRESSION_NONE = 0;
|
||||||
|
const DIGEST_SHA256 = 1;
|
||||||
|
const MAJOR_VERSION = 1;
|
||||||
|
const MINOR_VERSION = 0;
|
||||||
|
|
||||||
|
// ── Helpers ─────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
function readU16BE(buf, offset) {
|
||||||
|
return buf.readUint16BE(offset);
|
||||||
|
}
|
||||||
|
function readU32BE(buf, offset) {
|
||||||
|
return buf.readUint32BE(offset);
|
||||||
|
}
|
||||||
|
function readU64BE(buf, offset) {
|
||||||
|
return buf.readBigUInt64BE(offset);
|
||||||
|
}
|
||||||
|
|
||||||
|
function sha256(data) {
|
||||||
|
return createHash("sha256").update(data).digest();
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Public API ──────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Parse a bundle Buffer into a Bundle object.
|
||||||
|
*
|
||||||
|
* Returns { version, sectionCount, sections } where sections maps
|
||||||
|
* section type numbers to parsed section info (offset, length, data).
|
||||||
|
*/
|
||||||
|
export function parseBundle(buffer) {
|
||||||
|
if (buffer.length < HEADER_LENGTH) {
|
||||||
|
throw new Error("bundle too short for header");
|
||||||
|
}
|
||||||
|
|
||||||
|
// Check magic
|
||||||
|
if (!buffer.slice(0, 8).equals(MAGIC)) {
|
||||||
|
throw new Error("invalid magic: expected ARBORIX\\0");
|
||||||
|
}
|
||||||
|
|
||||||
|
// Parse header
|
||||||
|
const major = readU16BE(buffer, 8);
|
||||||
|
const minor = readU16BE(buffer, 10);
|
||||||
|
const sectionCount = readU32BE(buffer, 12);
|
||||||
|
|
||||||
|
if (major !== MAJOR_VERSION) {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported bundle major version: ${major} (expected ${MAJOR_VERSION})`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
const dirOffset = Number(readU64BE(buffer, 24));
|
||||||
|
|
||||||
|
// Parse section directory
|
||||||
|
const dirStart = dirOffset;
|
||||||
|
const dirEnd = dirStart + sectionCount * SECTION_ENTRY_LENGTH;
|
||||||
|
|
||||||
|
if (buffer.length < dirEnd) {
|
||||||
|
throw new Error("bundle truncated in section directory");
|
||||||
|
}
|
||||||
|
|
||||||
|
const entries = [];
|
||||||
|
for (let i = 0; i < sectionCount; i++) {
|
||||||
|
const off = dirStart + i * SECTION_ENTRY_LENGTH;
|
||||||
|
const entry = {
|
||||||
|
type: readU32BE(buffer, off),
|
||||||
|
version: readU16BE(buffer, off + 4),
|
||||||
|
flags: readU16BE(buffer, off + 6),
|
||||||
|
compression: readU16BE(buffer, off + 8),
|
||||||
|
digestAlgorithm: readU16BE(buffer, off + 10),
|
||||||
|
offset: Number(readU64BE(buffer, off + 12)),
|
||||||
|
length: Number(readU64BE(buffer, off + 20)),
|
||||||
|
digest: buffer.slice(off + 28, off + 28 + 32),
|
||||||
|
};
|
||||||
|
entries.push(entry);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Validate sections
|
||||||
|
for (const entry of entries) {
|
||||||
|
const isCritical = (entry.flags & FLAG_CRITICAL) !== 0;
|
||||||
|
const isKnown =
|
||||||
|
entry.type === SECTION_MANIFEST || entry.type === SECTION_NODES;
|
||||||
|
if (isCritical && !isKnown) {
|
||||||
|
throw new Error(`unknown critical section type: ${entry.type}`);
|
||||||
|
}
|
||||||
|
if (entry.compression !== COMPRESSION_NONE) {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported compression codec in section ${entry.type}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
if (entry.digestAlgorithm !== DIGEST_SHA256) {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported digest algorithm in section ${entry.type}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Verify section digests and extract data
|
||||||
|
const sections = new Map();
|
||||||
|
for (const entry of entries) {
|
||||||
|
if (entry.offset < 0 || entry.length < 0) {
|
||||||
|
throw new Error(`section ${entry.type} has negative offset/length`);
|
||||||
|
}
|
||||||
|
if (buffer.length < entry.offset + entry.length) {
|
||||||
|
throw new Error(
|
||||||
|
`section ${entry.type} extends beyond bundle end`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
const data = buffer.slice(entry.offset, entry.offset + entry.length);
|
||||||
|
|
||||||
|
// Verify digest
|
||||||
|
const computed = sha256(data);
|
||||||
|
if (!computed.equals(entry.digest)) {
|
||||||
|
throw new Error(
|
||||||
|
`section digest mismatch for section type ${entry.type}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
sections.set(entry.type, {
|
||||||
|
...entry,
|
||||||
|
data,
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
||||||
|
// Check required sections
|
||||||
|
if (!sections.has(SECTION_MANIFEST)) {
|
||||||
|
throw new Error("missing required section: manifest");
|
||||||
|
}
|
||||||
|
if (!sections.has(SECTION_NODES)) {
|
||||||
|
throw new Error("missing required section: nodes");
|
||||||
|
}
|
||||||
|
|
||||||
|
return {
|
||||||
|
version: `${major}.${minor}`,
|
||||||
|
sectionCount,
|
||||||
|
sections,
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Convenience: parse and return just the manifest JSON.
|
||||||
|
*/
|
||||||
|
export function parseManifest(buffer) {
|
||||||
|
const bundle = parseBundle(buffer);
|
||||||
|
const manifestEntry = bundle.sections.get(SECTION_MANIFEST);
|
||||||
|
return JSON.parse(manifestEntry.data.toString("utf-8"));
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Convenience: parse and return the node section binary.
|
||||||
|
*/
|
||||||
|
export function parseNodeSection(buffer) {
|
||||||
|
const bundle = parseBundle(buffer);
|
||||||
|
const nodesEntry = bundle.sections.get(SECTION_NODES);
|
||||||
|
return nodesEntry.data;
|
||||||
|
}
|
||||||
249
ext/js/src/cli.js
Normal file
249
ext/js/src/cli.js
Normal file
@@ -0,0 +1,249 @@
|
|||||||
|
#!/usr/bin/env node
|
||||||
|
/**
|
||||||
|
* cli.js — Minimal CLI for inspecting and running Arborix bundles.
|
||||||
|
*
|
||||||
|
* Usage:
|
||||||
|
* node cli.js inspect <bundle>
|
||||||
|
* node cli.js run <bundle> [exportName] [input]
|
||||||
|
*/
|
||||||
|
|
||||||
|
import { readFileSync } from "node:fs";
|
||||||
|
import { parseBundle, parseManifest } from "./bundle.js";
|
||||||
|
import { parseNodeSection as parseNodeSectionMerkle } from "./merkle.js";
|
||||||
|
import {
|
||||||
|
validateManifest,
|
||||||
|
selectExport,
|
||||||
|
printManifestInfo,
|
||||||
|
} from "./manifest.js";
|
||||||
|
import { parseNodeSection as parseNodeSectionBundle } from "./bundle.js";
|
||||||
|
import {
|
||||||
|
verifyNodeHashes,
|
||||||
|
verifyClosure,
|
||||||
|
verifyRootClosure,
|
||||||
|
} from "./merkle.js";
|
||||||
|
import { isTree, apply, triage, isFork, isStem } from "./tree.js";
|
||||||
|
import { decodeResult, formatTree } from "./codecs.js";
|
||||||
|
|
||||||
|
// ── Commands ────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
function cmdInspect(bundlePath) {
|
||||||
|
const buffer = readFileSync(bundlePath);
|
||||||
|
try {
|
||||||
|
const manifest = parseManifest(buffer);
|
||||||
|
validateManifest(manifest);
|
||||||
|
|
||||||
|
const nodeSectionBytes = parseNodeSectionBundle(buffer);
|
||||||
|
const { nodeMap } = parseNodeSectionMerkle(nodeSectionBytes);
|
||||||
|
|
||||||
|
console.log(`Bundle: ${bundlePath}`);
|
||||||
|
console.log("");
|
||||||
|
|
||||||
|
printManifestInfo(manifest, " ");
|
||||||
|
|
||||||
|
console.log(` Nodes: ${nodeMap.size}`);
|
||||||
|
|
||||||
|
// Verify hashes
|
||||||
|
const { verified: hashesOk, mismatches } = verifyNodeHashes(nodeMap);
|
||||||
|
console.log(` Hash verification: ${hashesOk ? "OK" : "FAIL"}`);
|
||||||
|
for (const m of mismatches) {
|
||||||
|
console.log(` MISMATCH ${m.type} ${m.hash.substring(0, 16)}... expected ${m.expected.substring(0, 16)}...`);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Verify closure
|
||||||
|
const { complete: closureOk, missing } = verifyClosure(nodeMap);
|
||||||
|
console.log(` Closure verification: ${closureOk ? "OK" : "FAIL"}`);
|
||||||
|
for (const m of missing) {
|
||||||
|
console.log(` MISSING ${m.parent.substring(0, 16)}... → ${m.child.substring(0, 16)}...`);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Verify root closure for each export
|
||||||
|
for (const exp of manifest.exports || []) {
|
||||||
|
const { complete, missingRoots } = verifyRootClosure(
|
||||||
|
nodeMap,
|
||||||
|
exp.root
|
||||||
|
);
|
||||||
|
if (!complete) {
|
||||||
|
console.log(
|
||||||
|
` Root closure for "${exp.name}": FAIL — missing: ${missingRoots
|
||||||
|
.map((r) => r.substring(0, 16) + "...")
|
||||||
|
.join(", ")}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
console.log("");
|
||||||
|
console.log("Inspection complete.");
|
||||||
|
} catch (e) {
|
||||||
|
console.error(`Error: ${e.message}`);
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
function cmdRun(bundlePath, exportName, inputArg) {
|
||||||
|
const buffer = readFileSync(bundlePath);
|
||||||
|
let result;
|
||||||
|
try {
|
||||||
|
const manifest = parseManifest(buffer);
|
||||||
|
validateManifest(manifest);
|
||||||
|
|
||||||
|
const selectedExport = selectExport(manifest, exportName);
|
||||||
|
|
||||||
|
const nodeSectionBytes = parseNodeSectionBundle(buffer);
|
||||||
|
const { nodeMap } = parseNodeSectionMerkle(nodeSectionBytes);
|
||||||
|
|
||||||
|
// Verify hashes
|
||||||
|
const { verified, mismatches } = verifyNodeHashes(nodeMap);
|
||||||
|
if (!verified) {
|
||||||
|
console.error(
|
||||||
|
`Node hash mismatch:\n ${mismatches
|
||||||
|
.map((m) => ` ${m.type}: ${m.hash} (expected ${m.expected})`)
|
||||||
|
.join("\n")}`
|
||||||
|
);
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Reconstruct the tree for the selected export
|
||||||
|
const root = buildTreeFromNodeMap(nodeMap, selectedExport.root);
|
||||||
|
if (!isTree(root)) {
|
||||||
|
console.error("Reconstructed root is not a valid tree value");
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Apply input if provided
|
||||||
|
let term = root;
|
||||||
|
if (inputArg !== undefined) {
|
||||||
|
// TODO: parse input (string/number) into a tree
|
||||||
|
// For now, just run the term as-is
|
||||||
|
}
|
||||||
|
|
||||||
|
// Reduce with fuel limit
|
||||||
|
const finalTerm = reduce(term, 1_000_000);
|
||||||
|
|
||||||
|
// Print result as tree calculus form
|
||||||
|
console.log(formatTree(finalTerm));
|
||||||
|
} catch (e) {
|
||||||
|
console.error(`Error: ${e.message}`);
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Tree reconstruction ─────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Reconstruct a tree from a node map.
|
||||||
|
*
|
||||||
|
* Node map: Map<hexHash, { type, childHash?, leftHash?, rightHash? }>
|
||||||
|
*
|
||||||
|
* Returns the tree representation: [] for Leaf, [child] for Stem, [right, left] for Fork.
|
||||||
|
* Uses memoization to avoid re-processing nodes.
|
||||||
|
*/
|
||||||
|
export function buildTreeFromNodeMap(nodeMap, hash, memo = new Map()) {
|
||||||
|
if (memo.has(hash)) return memo.get(hash);
|
||||||
|
|
||||||
|
const node = nodeMap.get(hash);
|
||||||
|
if (!node) {
|
||||||
|
throw new Error(`missing node in bundle: ${hash}`);
|
||||||
|
}
|
||||||
|
|
||||||
|
let tree;
|
||||||
|
switch (node.type) {
|
||||||
|
case "leaf":
|
||||||
|
tree = [];
|
||||||
|
break;
|
||||||
|
case "stem":
|
||||||
|
tree = [buildTreeFromNodeMap(nodeMap, node.childHash, memo)];
|
||||||
|
break;
|
||||||
|
case "fork":
|
||||||
|
tree = [
|
||||||
|
buildTreeFromNodeMap(nodeMap, node.rightHash, memo),
|
||||||
|
buildTreeFromNodeMap(nodeMap, node.leftHash, memo),
|
||||||
|
];
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
throw new Error(`unknown node type: ${node.type}`);
|
||||||
|
}
|
||||||
|
|
||||||
|
memo.set(hash, tree);
|
||||||
|
return tree;
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Reduction ───────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Reduce a term to normal form with a fuel limit.
|
||||||
|
* Uses the stack-based approach from the TS evaluator.
|
||||||
|
*/
|
||||||
|
export function reduce(term, fuel) {
|
||||||
|
const stack = [term];
|
||||||
|
let remaining = fuel;
|
||||||
|
|
||||||
|
while (stack.length >= 2 && remaining-- > 0) {
|
||||||
|
// Pop right (top), then left
|
||||||
|
const b = stack.pop(); // right
|
||||||
|
const a = stack.pop(); // left
|
||||||
|
|
||||||
|
if (stack.length >= 2) {
|
||||||
|
// Push a back for potential further reduction
|
||||||
|
stack.push(a);
|
||||||
|
}
|
||||||
|
|
||||||
|
const result = apply(a, b);
|
||||||
|
|
||||||
|
if (isTree(result)) {
|
||||||
|
// If result is a value, push it. But if it's a Fork/Stem,
|
||||||
|
// we need to push its components for further reduction.
|
||||||
|
if (isFork(result)) {
|
||||||
|
// Push right first (so it's popped second), then left
|
||||||
|
stack.push(result[1]); // left
|
||||||
|
stack.push(result[0]); // right
|
||||||
|
} else if (isStem(result)) {
|
||||||
|
stack.push(result[0]); // child
|
||||||
|
} else {
|
||||||
|
stack.push(result); // Leaf
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
// Not a tree — push as-is (shouldn't happen after buildTree)
|
||||||
|
stack.push(result);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (remaining <= 0) {
|
||||||
|
throw new Error("reduction step limit exceeded");
|
||||||
|
}
|
||||||
|
|
||||||
|
if (stack.length === 1) {
|
||||||
|
return stack[0];
|
||||||
|
}
|
||||||
|
return stack[0]; // fallback
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Main ────────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
const args = process.argv.slice(2);
|
||||||
|
const command = args[0];
|
||||||
|
|
||||||
|
switch (command) {
|
||||||
|
case "inspect": {
|
||||||
|
if (args.length < 2) {
|
||||||
|
console.error("Usage: node cli.js inspect <bundle>");
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
cmdInspect(args[1]);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
case "run": {
|
||||||
|
if (args.length < 2) {
|
||||||
|
console.error("Usage: node cli.js run <bundle> [exportName] [input]");
|
||||||
|
process.exit(1);
|
||||||
|
}
|
||||||
|
cmdRun(args[1], args[2], args[3]);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
default:
|
||||||
|
console.log("Arborix JS Runtime");
|
||||||
|
console.log("");
|
||||||
|
console.log("Usage:");
|
||||||
|
console.log(" node cli.js inspect <bundle>");
|
||||||
|
console.log(" node cli.js run <bundle> [exportName] [input]");
|
||||||
|
break;
|
||||||
|
}
|
||||||
135
ext/js/src/codecs.js
Normal file
135
ext/js/src/codecs.js
Normal file
@@ -0,0 +1,135 @@
|
|||||||
|
/**
|
||||||
|
* codecs.js — Minimal codecs for decoding tree results.
|
||||||
|
*
|
||||||
|
* Implements: decodeResult (from Research.hs)
|
||||||
|
* - Leaf → "t"
|
||||||
|
* - Numbers: toNumber
|
||||||
|
* - Strings: toString
|
||||||
|
* - Lists: toList
|
||||||
|
* - Fallback: raw tree format
|
||||||
|
*/
|
||||||
|
|
||||||
|
// ── toNumber ────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Decode a tree as a binary number (big-endian).
|
||||||
|
* Leaf = 0, Fork(Leaf, rest) = 2*n, Fork(Stem Leaf, rest) = 2*n+1.
|
||||||
|
*/
|
||||||
|
export function toNumber(t) {
|
||||||
|
if (!Array.isArray(t)) return null;
|
||||||
|
if (t.length === 0) return 0; // Leaf = 0
|
||||||
|
if (t.length !== 2) return null; // must be Fork
|
||||||
|
|
||||||
|
const [right, left] = t;
|
||||||
|
// Fork structure: [right, left]
|
||||||
|
// left child determines bit: Leaf = 0, Stem(Leaf) = 1
|
||||||
|
let bit;
|
||||||
|
if (Array.isArray(left) && left.length === 0) {
|
||||||
|
bit = 0; // Leaf
|
||||||
|
} else if (Array.isArray(left) && left.length === 1) {
|
||||||
|
const child = left[0];
|
||||||
|
if (Array.isArray(child) && child.length === 0) {
|
||||||
|
bit = 1; // Stem(Leaf) = 1
|
||||||
|
} else {
|
||||||
|
return null; // Stem of something other than Leaf
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
|
||||||
|
const rest = toNumber(right);
|
||||||
|
if (rest === null) return null;
|
||||||
|
|
||||||
|
return bit + 2 * rest;
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── toString ────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Decode a tree as a list of numbers (characters).
|
||||||
|
* Fork(x, rest) = x : list.
|
||||||
|
*/
|
||||||
|
export function toList(t) {
|
||||||
|
if (!Array.isArray(t)) return null;
|
||||||
|
if (t.length === 0) return []; // Leaf = empty list
|
||||||
|
if (t.length !== 2) return null; // must be Fork
|
||||||
|
|
||||||
|
const [right, left] = t;
|
||||||
|
const rest = toList(right);
|
||||||
|
if (rest === null) return null;
|
||||||
|
|
||||||
|
return [left, ...rest];
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Decode a tree as a string.
|
||||||
|
*/
|
||||||
|
export function toString(t) {
|
||||||
|
const list = toList(t);
|
||||||
|
if (list === null) return null;
|
||||||
|
try {
|
||||||
|
return list.map((ch) => String.fromCharCode(ch)).join("");
|
||||||
|
} catch {
|
||||||
|
return null;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── decodeResult ────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Decode a tree result using multiple strategies:
|
||||||
|
* 1. Leaf → "t"
|
||||||
|
* 2. String (if all chars are printable)
|
||||||
|
* 3. Number
|
||||||
|
* 4. List
|
||||||
|
* 5. Raw tree format
|
||||||
|
*/
|
||||||
|
export function decodeResult(t) {
|
||||||
|
if (!Array.isArray(t)) {
|
||||||
|
return String(t);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Leaf
|
||||||
|
if (t.length === 0) {
|
||||||
|
return "t";
|
||||||
|
}
|
||||||
|
|
||||||
|
// Try string first (list of char codes)
|
||||||
|
const list = toList(t);
|
||||||
|
if (list !== null && list.length > 0) {
|
||||||
|
const str = list.map((n) => {
|
||||||
|
if (n < 32 || n > 126) return null;
|
||||||
|
return String.fromCharCode(n);
|
||||||
|
}).join("");
|
||||||
|
if (str) return `"${str}"`;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Try number
|
||||||
|
const num = toNumber(t);
|
||||||
|
if (num !== null) {
|
||||||
|
return String(num);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Try list (elements are trees)
|
||||||
|
if (t.length === 2) {
|
||||||
|
const elements = toList(t);
|
||||||
|
if (elements !== null) {
|
||||||
|
const decoded = elements.map((e) => decodeResult(e));
|
||||||
|
return `[${decoded.join(", ")}]`;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Raw tree format
|
||||||
|
return formatTree(t);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Format a tree as a parenthesized expression.
|
||||||
|
*/
|
||||||
|
export function formatTree(t) {
|
||||||
|
if (!Array.isArray(t)) return String(t);
|
||||||
|
if (t.length === 0) return "Leaf";
|
||||||
|
if (t.length === 1) return `Stem(${formatTree(t[0])})`;
|
||||||
|
if (t.length === 2) return `Fork(${formatTree(t[1])}, ${formatTree(t[0])})`;
|
||||||
|
return `[${t.map(formatTree).join(", ")}]`;
|
||||||
|
}
|
||||||
167
ext/js/src/manifest.js
Normal file
167
ext/js/src/manifest.js
Normal file
@@ -0,0 +1,167 @@
|
|||||||
|
/**
|
||||||
|
* manifest.js — Minimal manifest parsing and export lookup.
|
||||||
|
*
|
||||||
|
* The manifest is a JSON object with fields:
|
||||||
|
* schema, bundleType, tree, runtime, closure, roots, exports,
|
||||||
|
* imports, sections, metadata
|
||||||
|
*
|
||||||
|
* We parse only what we need for runtime entrypoint selection.
|
||||||
|
*/
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Validate the manifest against the runtime profile requirements.
|
||||||
|
* Throws on violation.
|
||||||
|
*/
|
||||||
|
export function validateManifest(manifest) {
|
||||||
|
if (manifest.schema !== "arborix.bundle.manifest.v1") {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported manifest schema: ${manifest.schema}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
if (manifest.bundleType !== "tree-calculus-executable-object") {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported bundle type: ${manifest.bundleType}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
const tree = manifest.tree;
|
||||||
|
if (tree.calculus !== "tree-calculus.v1") {
|
||||||
|
throw new Error(`unsupported calculus: ${tree.calculus}`);
|
||||||
|
}
|
||||||
|
if (tree.nodeHash.algorithm !== "sha256") {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported node hash algorithm: ${tree.nodeHash.algorithm}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
if (tree.nodeHash.domain !== "tricu.merkle.node.v1" && tree.nodeHash.domain !== "arborix.merkle.node.v1") {
|
||||||
|
throw new Error(
|
||||||
|
`unsupported node hash domain: ${tree.nodeHash.domain}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
if (tree.nodePayload !== "arborix.merkle.payload.v1") {
|
||||||
|
throw new Error(`unsupported node payload: ${tree.nodePayload}`);
|
||||||
|
}
|
||||||
|
|
||||||
|
const runtime = manifest.runtime;
|
||||||
|
if (runtime.semantics !== "tree-calculus.v1") {
|
||||||
|
throw new Error(`unsupported runtime semantics: ${runtime.semantics}`);
|
||||||
|
}
|
||||||
|
if (runtime.abi !== "arborix.abi.tree.v1") {
|
||||||
|
throw new Error(`unsupported runtime ABI: ${runtime.abi}`);
|
||||||
|
}
|
||||||
|
if (runtime.capabilities && runtime.capabilities.length > 0) {
|
||||||
|
throw new Error(
|
||||||
|
`host/runtime capabilities not supported: ${runtime.capabilities.join(", ")}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (manifest.closure !== "complete") {
|
||||||
|
throw new Error("bundle v1 requires closure = complete");
|
||||||
|
}
|
||||||
|
if (manifest.imports && manifest.imports.length > 0) {
|
||||||
|
throw new Error("bundle v1 requires an empty imports list");
|
||||||
|
}
|
||||||
|
if (!manifest.roots || manifest.roots.length === 0) {
|
||||||
|
throw new Error("manifest has no roots");
|
||||||
|
}
|
||||||
|
if (!manifest.exports || manifest.exports.length === 0) {
|
||||||
|
throw new Error("manifest has no exports");
|
||||||
|
}
|
||||||
|
|
||||||
|
for (const exp of manifest.exports) {
|
||||||
|
if (!exp.name) {
|
||||||
|
throw new Error("manifest export has empty name");
|
||||||
|
}
|
||||||
|
if (!exp.root) {
|
||||||
|
throw new Error("manifest export has empty root");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Select an export hash given a requested name.
|
||||||
|
*
|
||||||
|
* Selection strategy:
|
||||||
|
* 1. Explicit export name
|
||||||
|
* 2. Export named "main"
|
||||||
|
* 3. Single export (auto-select)
|
||||||
|
* 4. Error if multiple exports and no "main"
|
||||||
|
*/
|
||||||
|
export function selectExport(manifest, requestedName) {
|
||||||
|
const exports = manifest.exports || [];
|
||||||
|
|
||||||
|
// Strategy 1: explicit name
|
||||||
|
if (requestedName) {
|
||||||
|
const found = exports.find((e) => e.name === requestedName);
|
||||||
|
if (found) {
|
||||||
|
return found;
|
||||||
|
}
|
||||||
|
throw new Error(
|
||||||
|
`requested export "${requestedName}" not found. Available: ${exports.map((e) => e.name).join(", ")}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
// Strategy 2: prefer "main"
|
||||||
|
const mainExport = exports.find((e) => e.name === "main");
|
||||||
|
if (mainExport) {
|
||||||
|
return mainExport;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Strategy 3: single export
|
||||||
|
if (exports.length === 1) {
|
||||||
|
return exports[0];
|
||||||
|
}
|
||||||
|
|
||||||
|
// Strategy 4: multiple exports, require explicit
|
||||||
|
throw new Error(
|
||||||
|
`multiple exports available but none named "main": ${exports.map((e) => e.name).join(", ")}. Specify an export name.`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Get all root hashes from the manifest.
|
||||||
|
*/
|
||||||
|
export function getRootHashes(manifest) {
|
||||||
|
return (manifest.roots || []).map((r) => r.hash);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Get all export names.
|
||||||
|
*/
|
||||||
|
export function getExportNames(manifest) {
|
||||||
|
return (manifest.exports || []).map((e) => e.name);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Print manifest summary info.
|
||||||
|
*/
|
||||||
|
export function printManifestInfo(manifest, indent = "") {
|
||||||
|
const tree = manifest.tree;
|
||||||
|
const runtime = manifest.runtime;
|
||||||
|
|
||||||
|
console.log(`${indent}Schema: ${manifest.schema}`);
|
||||||
|
console.log(`${indent}Bundle type: ${manifest.bundleType}`);
|
||||||
|
console.log(`${indent}Closure: ${manifest.closure}`);
|
||||||
|
console.log(`${indent}Tree calculus: ${tree.calculus}`);
|
||||||
|
console.log(`${indent}Hash algo: ${tree.nodeHash.algorithm}`);
|
||||||
|
console.log(`${indent}Hash domain: ${tree.nodeHash.domain}`);
|
||||||
|
console.log(`${indent}Runtime: ${runtime.semantics}`);
|
||||||
|
console.log(`${indent}ABI: ${runtime.abi}`);
|
||||||
|
console.log(`${indent}Evaluation: ${runtime.evaluation || "N/A"}`);
|
||||||
|
console.log("");
|
||||||
|
console.log(`${indent}Roots (${getRootHashes(manifest).length}):`);
|
||||||
|
for (const root of getRootHashes(manifest)) {
|
||||||
|
console.log(`${indent} ${root.substring(0, 16)}...`);
|
||||||
|
}
|
||||||
|
console.log("");
|
||||||
|
console.log(`${indent}Exports (${getExportNames(manifest).length}):`);
|
||||||
|
for (const name of getExportNames(manifest)) {
|
||||||
|
console.log(`${indent} ${name}`);
|
||||||
|
}
|
||||||
|
|
||||||
|
const meta = manifest.metadata;
|
||||||
|
if (meta && meta.createdBy) {
|
||||||
|
console.log("");
|
||||||
|
console.log(`${indent}Created by: ${meta.createdBy}`);
|
||||||
|
}
|
||||||
|
}
|
||||||
276
ext/js/src/merkle.js
Normal file
276
ext/js/src/merkle.js
Normal file
@@ -0,0 +1,276 @@
|
|||||||
|
/**
|
||||||
|
* merkle.js — Node payload decoding and hash verification.
|
||||||
|
*
|
||||||
|
* Node payload format:
|
||||||
|
* Leaf: 0x00
|
||||||
|
* Stem: 0x01 || child_hash (32 bytes raw)
|
||||||
|
* Fork: 0x02 || left_hash (32 bytes raw) || right_hash (32 bytes raw)
|
||||||
|
*
|
||||||
|
* Hash computation:
|
||||||
|
* hash = SHA256( "tricu.merkle.node.v1" || 0x00 || node_payload )
|
||||||
|
*/
|
||||||
|
|
||||||
|
import { createHash } from "node:crypto";
|
||||||
|
|
||||||
|
// ── Constants ───────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
const DOMAIN_TAG = "tricu.merkle.node.v1";
|
||||||
|
const HASH_LENGTH = 32; // raw hash bytes
|
||||||
|
const HEX_LENGTH = 64; // hex-encoded hash length
|
||||||
|
|
||||||
|
// ── Helpers ─────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
function rawToHex(buf) {
|
||||||
|
if (buf.length !== HASH_LENGTH) {
|
||||||
|
throw new Error(`raw hash must be ${HASH_LENGTH} bytes, got ${buf.length}`);
|
||||||
|
}
|
||||||
|
return buf.toString("hex");
|
||||||
|
}
|
||||||
|
|
||||||
|
function hexToRaw(hex) {
|
||||||
|
const buf = Buffer.from(hex, "hex");
|
||||||
|
if (buf.length !== HASH_LENGTH) {
|
||||||
|
throw new Error(`hex hash must decode to ${HASH_LENGTH} bytes`);
|
||||||
|
}
|
||||||
|
return buf;
|
||||||
|
}
|
||||||
|
|
||||||
|
function sha256(data) {
|
||||||
|
return createHash("sha256").update(data).digest();
|
||||||
|
}
|
||||||
|
|
||||||
|
function nodeHash(prefix, payload) {
|
||||||
|
return sha256(Buffer.concat([Buffer.from(prefix), Buffer.from([0x00]), payload]));
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Node payload types ──────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Deserialize a node payload into { type, childHash, leftHash, rightHash }.
|
||||||
|
*
|
||||||
|
* type: "leaf" | "stem" | "fork"
|
||||||
|
* childHash: hex string (for stem)
|
||||||
|
* leftHash: hex string (for fork)
|
||||||
|
* rightHash: hex string (for fork)
|
||||||
|
*/
|
||||||
|
export function deserializePayload(payload) {
|
||||||
|
if (payload.length === 0) {
|
||||||
|
throw new Error("empty payload");
|
||||||
|
}
|
||||||
|
|
||||||
|
const type = payload.readUInt8(0);
|
||||||
|
|
||||||
|
switch (type) {
|
||||||
|
case 0x00:
|
||||||
|
if (payload.length !== 1) {
|
||||||
|
throw new Error(
|
||||||
|
`invalid leaf payload: expected 1 byte, got ${payload.length}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
return { type: "leaf" };
|
||||||
|
|
||||||
|
case 0x01:
|
||||||
|
if (payload.length !== 1 + HASH_LENGTH) {
|
||||||
|
throw new Error(
|
||||||
|
`invalid stem payload: expected ${1 + HASH_LENGTH} bytes, got ${payload.length}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
return {
|
||||||
|
type: "stem",
|
||||||
|
childHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
|
||||||
|
};
|
||||||
|
|
||||||
|
case 0x02:
|
||||||
|
if (payload.length !== 1 + 2 * HASH_LENGTH) {
|
||||||
|
throw new Error(
|
||||||
|
`invalid fork payload: expected ${1 + 2 * HASH_LENGTH} bytes, got ${payload.length}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
return {
|
||||||
|
type: "fork",
|
||||||
|
leftHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
|
||||||
|
rightHash: rawToHex(payload.slice(1 + HASH_LENGTH, 1 + 2 * HASH_LENGTH)),
|
||||||
|
};
|
||||||
|
|
||||||
|
default:
|
||||||
|
throw new Error(
|
||||||
|
`invalid merkle node payload: unknown type 0x${type.toString(16)}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Compute the canonical payload bytes for a given tree node structure.
|
||||||
|
*/
|
||||||
|
export function serializeNode(node) {
|
||||||
|
switch (node.type) {
|
||||||
|
case "leaf":
|
||||||
|
return Buffer.from([0x00]);
|
||||||
|
case "stem":
|
||||||
|
return Buffer.concat([Buffer.from([0x01]), hexToRaw(node.childHash)]);
|
||||||
|
case "fork":
|
||||||
|
return Buffer.concat([
|
||||||
|
Buffer.from([0x02]),
|
||||||
|
hexToRaw(node.leftHash),
|
||||||
|
hexToRaw(node.rightHash),
|
||||||
|
]);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Compute the Merkle hash of a node from its type and parameters.
|
||||||
|
*/
|
||||||
|
export function computeNodeHash(node) {
|
||||||
|
const payload = serializeNode(node);
|
||||||
|
const hash = nodeHash(DOMAIN_TAG, payload);
|
||||||
|
return hash.toString("hex");
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Node section parsing ────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Parse the node section binary into a Map<hexHash, { type, payload, node }>.
|
||||||
|
*
|
||||||
|
* Node section format:
|
||||||
|
* nodeCount (8B u64 BE)
|
||||||
|
* entries[]:
|
||||||
|
* hash (32B raw)
|
||||||
|
* payloadLen (4B u32 BE)
|
||||||
|
* payload (payloadLen bytes)
|
||||||
|
*/
|
||||||
|
export function parseNodeSection(data) {
|
||||||
|
if (data.length < 8) {
|
||||||
|
throw new Error("node section too short for count");
|
||||||
|
}
|
||||||
|
|
||||||
|
const nodeCount = Number(data.readBigUInt64BE(0));
|
||||||
|
let offset = 8;
|
||||||
|
|
||||||
|
const nodeMap = new Map();
|
||||||
|
const errors = [];
|
||||||
|
|
||||||
|
for (let i = 0; i < nodeCount; i++) {
|
||||||
|
// Read hash
|
||||||
|
if (offset + HASH_LENGTH > data.length) {
|
||||||
|
errors.push(`node ${i}: not enough bytes for hash`);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
const hash = rawToHex(data.slice(offset, offset + HASH_LENGTH));
|
||||||
|
offset += HASH_LENGTH;
|
||||||
|
|
||||||
|
// Read payload length
|
||||||
|
if (offset + 4 > data.length) {
|
||||||
|
errors.push(`node ${i} (${hash}): not enough bytes for payload length`);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
const payloadLen = data.readUint32BE(offset);
|
||||||
|
offset += 4;
|
||||||
|
|
||||||
|
// Read payload
|
||||||
|
if (offset + payloadLen > data.length) {
|
||||||
|
errors.push(`node ${i} (${hash}): payload extends beyond section end`);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
const payload = data.slice(offset, offset + payloadLen);
|
||||||
|
offset += payloadLen;
|
||||||
|
|
||||||
|
// Deserialize payload
|
||||||
|
let node;
|
||||||
|
try {
|
||||||
|
node = deserializePayload(payload);
|
||||||
|
} catch (e) {
|
||||||
|
errors.push(`node ${i} (${hash}): ${e.message}`);
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
|
||||||
|
nodeMap.set(hash, {
|
||||||
|
hash,
|
||||||
|
payload,
|
||||||
|
...node,
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
||||||
|
if (errors.length > 0) {
|
||||||
|
throw new Error(
|
||||||
|
`node section parse errors:\n ${errors.join("\n ")}`
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
return { nodeMap, count: nodeCount };
|
||||||
|
}
|
||||||
|
|
||||||
|
// ── Verification ────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Verify all node hashes match their payloads.
|
||||||
|
* Returns { verified, mismatches }
|
||||||
|
*/
|
||||||
|
export function verifyNodeHashes(nodeMap) {
|
||||||
|
const mismatches = [];
|
||||||
|
|
||||||
|
for (const [hash, node] of nodeMap) {
|
||||||
|
const expected = computeNodeHash(node);
|
||||||
|
if (hash !== expected) {
|
||||||
|
mismatches.push({
|
||||||
|
hash,
|
||||||
|
expected,
|
||||||
|
type: node.type,
|
||||||
|
});
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return { verified: mismatches.length === 0, mismatches };
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Verify that all child references exist in the node map (closure).
|
||||||
|
* Returns { complete, missing } where missing is an array of { parent, child }.
|
||||||
|
*/
|
||||||
|
export function verifyClosure(nodeMap) {
|
||||||
|
const missing = [];
|
||||||
|
|
||||||
|
for (const [hash, node] of nodeMap) {
|
||||||
|
if (node.type === "stem") {
|
||||||
|
if (!nodeMap.has(node.childHash)) {
|
||||||
|
missing.push({ parent: hash, child: node.childHash });
|
||||||
|
}
|
||||||
|
} else if (node.type === "fork") {
|
||||||
|
if (!nodeMap.has(node.leftHash)) {
|
||||||
|
missing.push({ parent: hash, child: node.leftHash });
|
||||||
|
}
|
||||||
|
if (!nodeMap.has(node.rightHash)) {
|
||||||
|
missing.push({ parent: hash, child: node.rightHash });
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return { complete: missing.length === 0, missing };
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Verify closure for a specific root hash (transitive reachability).
|
||||||
|
* Returns { complete, missingRoots }.
|
||||||
|
*/
|
||||||
|
export function verifyRootClosure(nodeMap, rootHash) {
|
||||||
|
const visited = new Set();
|
||||||
|
const missingRoots = [];
|
||||||
|
|
||||||
|
function visit(hash) {
|
||||||
|
if (visited.has(hash)) return;
|
||||||
|
if (!nodeMap.has(hash)) {
|
||||||
|
missingRoots.push(hash);
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
visited.add(hash);
|
||||||
|
const node = nodeMap.get(hash);
|
||||||
|
if (node.type === "stem") {
|
||||||
|
visit(node.childHash);
|
||||||
|
} else if (node.type === "fork") {
|
||||||
|
visit(node.leftHash);
|
||||||
|
visit(node.rightHash);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
visit(rootHash);
|
||||||
|
return { complete: missingRoots.length === 0, missingRoots };
|
||||||
|
}
|
||||||
125
ext/js/src/tree.js
Normal file
125
ext/js/src/tree.js
Normal file
@@ -0,0 +1,125 @@
|
|||||||
|
/**
|
||||||
|
* tree.js — Runtime tree representation.
|
||||||
|
*
|
||||||
|
* The JS tree uses a simple array representation matching the
|
||||||
|
* TypeScript reference evaluator:
|
||||||
|
*
|
||||||
|
* Leaf = []
|
||||||
|
* Stem = [child] (array length === 1)
|
||||||
|
* Fork = [right, left] (array length === 2)
|
||||||
|
*
|
||||||
|
* This is a "flattened stack" representation: when reduced, terms
|
||||||
|
* become arrays and the evaluator pops three elements at a time.
|
||||||
|
*/
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Check if a value is a Leaf (empty array).
|
||||||
|
*/
|
||||||
|
export function isLeaf(t) {
|
||||||
|
return Array.isArray(t) && t.length === 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Check if a value is a Stem (single element array).
|
||||||
|
*/
|
||||||
|
export function isStem(t) {
|
||||||
|
return Array.isArray(t) && t.length === 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Check if a value is a Fork (two element array).
|
||||||
|
*/
|
||||||
|
export function isFork(t) {
|
||||||
|
return Array.isArray(t) && t.length === 2;
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Check if a value is a valid tree calculus value (Leaf, Stem, or Fork).
|
||||||
|
*/
|
||||||
|
export function isTree(t) {
|
||||||
|
return isLeaf(t) || isStem(t) || isFork(t);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Triage a tree: classify it as Leaf/Stem/Fork.
|
||||||
|
* The tree must be in normal form (no reducible redexes).
|
||||||
|
*
|
||||||
|
* Returns { kind: "leaf"|"stem"|"fork", ...rest }
|
||||||
|
*/
|
||||||
|
export function triage(t) {
|
||||||
|
if (!Array.isArray(t)) {
|
||||||
|
throw new Error("not a tree (not an array)");
|
||||||
|
}
|
||||||
|
if (t.length === 0) return { kind: "leaf" };
|
||||||
|
if (t.length === 1) return { kind: "stem", child: t[0] };
|
||||||
|
if (t.length === 2) return { kind: "fork", right: t[0], left: t[1] };
|
||||||
|
throw new Error(`not a value/binary tree: length ${t.length}`);
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Apply the Tree Calculus apply rules.
|
||||||
|
*
|
||||||
|
* apply(a, b) computes the application of term a to term b.
|
||||||
|
*
|
||||||
|
* Rules:
|
||||||
|
* apply(Fork(Leaf, a), _) = a
|
||||||
|
* apply(Fork(Stem(a), b), c) = apply(apply(a, c), apply(b, c))
|
||||||
|
* apply(Fork(Fork, _, _), Leaf) = left of inner Fork
|
||||||
|
* apply(Fork(Fork, _, _), Stem) = right of inner Fork
|
||||||
|
* apply(Fork(Fork, _, _), Fork) = apply(apply(c, u), v) where c=Fork(u,v)
|
||||||
|
* apply(Leaf, b) = Stem(b)
|
||||||
|
* apply(Stem(a), b) = Fork(a, b)
|
||||||
|
*
|
||||||
|
* For Fork, the inner structure is [right, left], so:
|
||||||
|
* a = right, b = left
|
||||||
|
*/
|
||||||
|
export function apply(a, b) {
|
||||||
|
// apply(Fork(Leaf, a), _) = a
|
||||||
|
// Fork = [right, left] = [Leaf, a] → left child is Leaf
|
||||||
|
if (isFork(a) && isLeaf(a[1])) {
|
||||||
|
return a[0]; // return right child
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Fork(Stem(a), b), c)
|
||||||
|
if (isFork(a) && isStem(a[1])) {
|
||||||
|
const stemChild = a[1][0]; // left child of fork
|
||||||
|
const right = a[0]; // right child of fork
|
||||||
|
const innerA = stemChild;
|
||||||
|
const innerB = right;
|
||||||
|
const appliedA = apply(innerA, b);
|
||||||
|
const appliedB = apply(innerB, b);
|
||||||
|
return apply(appliedA, appliedB);
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Fork(Fork, _, _), Leaf)
|
||||||
|
if (isFork(a) && isFork(a[1]) && isLeaf(b)) {
|
||||||
|
return a[1][0]; // right child of inner fork (which is left child)
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Fork(Fork, _, _), Stem)
|
||||||
|
if (isFork(a) && isFork(a[1]) && isStem(b)) {
|
||||||
|
return a[1][1]; // left child of inner fork
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Fork(Fork, _, _), Fork)
|
||||||
|
if (isFork(a) && isFork(a[1]) && isFork(b)) {
|
||||||
|
// b = Fork(u, v) = [v, u]
|
||||||
|
const u = b[0];
|
||||||
|
const v = b[1];
|
||||||
|
// apply(apply(c, u), v) where c = inner fork
|
||||||
|
const applied = apply(apply(a[1], u), v);
|
||||||
|
return applied;
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Leaf, b) = Stem(b)
|
||||||
|
if (isLeaf(a)) {
|
||||||
|
return [b];
|
||||||
|
}
|
||||||
|
|
||||||
|
// apply(Stem(a), b) = Fork(a, b)
|
||||||
|
if (isStem(a)) {
|
||||||
|
return [b, a[0]]; // [right, left]
|
||||||
|
}
|
||||||
|
|
||||||
|
throw new Error("apply: undefined reduction for terms");
|
||||||
|
}
|
||||||
67
ext/js/test/bundle.test.js
Normal file
67
ext/js/test/bundle.test.js
Normal file
@@ -0,0 +1,67 @@
|
|||||||
|
import { readFileSync } from "node:fs";
|
||||||
|
import { strictEqual, ok, throws } from "node:assert";
|
||||||
|
import { describe, it } from "node:test";
|
||||||
|
import {
|
||||||
|
parseBundle,
|
||||||
|
parseManifest,
|
||||||
|
} from "../src/bundle.js";
|
||||||
|
import {
|
||||||
|
parseNodeSection as bundleParseNodeSection,
|
||||||
|
} from "../src/bundle.js";
|
||||||
|
import {
|
||||||
|
verifyNodeHashes,
|
||||||
|
parseNodeSection as parseNodes,
|
||||||
|
} from "../src/merkle.js";
|
||||||
|
|
||||||
|
const fixtureDir = "test/fixtures";
|
||||||
|
|
||||||
|
describe("bundle parsing", () => {
|
||||||
|
it("valid bundle parses header and sections", () => {
|
||||||
|
const bundle = parseBundle(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
strictEqual(bundle.version, "1.0");
|
||||||
|
strictEqual(bundle.sectionCount, 2);
|
||||||
|
ok(bundle.sections.has(1)); // manifest
|
||||||
|
ok(bundle.sections.has(2)); // nodes
|
||||||
|
});
|
||||||
|
|
||||||
|
it("parseManifest returns valid JSON", () => {
|
||||||
|
const manifest = parseManifest(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
strictEqual(manifest.schema, "arborix.bundle.manifest.v1");
|
||||||
|
strictEqual(manifest.bundleType, "tree-calculus-executable-object");
|
||||||
|
strictEqual(manifest.closure, "complete");
|
||||||
|
strictEqual(manifest.tree.calculus, "tree-calculus.v1");
|
||||||
|
strictEqual(manifest.tree.nodeHash.algorithm, "sha256");
|
||||||
|
strictEqual(manifest.runtime.semantics, "tree-calculus.v1");
|
||||||
|
strictEqual(manifest.runtime.abi, "arborix.abi.tree.v1");
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("hash verification", () => {
|
||||||
|
it("valid bundle nodes verify", () => {
|
||||||
|
const data = bundleParseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
const { verified } = verifyNodeHashes(nodeMap);
|
||||||
|
ok(verified, "all node hashes should verify");
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("errors", () => {
|
||||||
|
it("bad magic fails", () => {
|
||||||
|
const buf = Buffer.alloc(32, 0);
|
||||||
|
buf.write("WRONGMAG", 0, 8);
|
||||||
|
throws(() => parseBundle(buf), /invalid magic/);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("unsupported version fails", () => {
|
||||||
|
const buf = Buffer.alloc(32, 0);
|
||||||
|
buf.write("ARBORIX\0", 0, 8);
|
||||||
|
buf.writeUInt16BE(2, 8); // major version 2
|
||||||
|
throws(() => parseBundle(buf), /unsupported bundle major version/);
|
||||||
|
});
|
||||||
|
});
|
||||||
148
ext/js/test/merkle.test.js
Normal file
148
ext/js/test/merkle.test.js
Normal file
@@ -0,0 +1,148 @@
|
|||||||
|
import { readFileSync } from "node:fs";
|
||||||
|
import { strictEqual, ok } from "node:assert";
|
||||||
|
import { describe, it } from "node:test";
|
||||||
|
import { parseNodeSection } from "../src/bundle.js";
|
||||||
|
import {
|
||||||
|
verifyNodeHashes,
|
||||||
|
verifyClosure,
|
||||||
|
verifyRootClosure,
|
||||||
|
deserializePayload,
|
||||||
|
computeNodeHash,
|
||||||
|
} from "../src/merkle.js";
|
||||||
|
|
||||||
|
describe("merkle — deserializePayload", () => {
|
||||||
|
it("Leaf (0x00)", () => {
|
||||||
|
const result = deserializePayload(Buffer.from([0x00]));
|
||||||
|
strictEqual(result.type, "leaf");
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Stem (0x01 + 32 bytes)", () => {
|
||||||
|
const childHash = Buffer.alloc(32, 0xab);
|
||||||
|
const payload = Buffer.concat([Buffer.from([0x01]), childHash]);
|
||||||
|
const result = deserializePayload(payload);
|
||||||
|
strictEqual(result.type, "stem");
|
||||||
|
strictEqual(result.childHash, "ab".repeat(32));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Fork (0x02 + 64 bytes)", () => {
|
||||||
|
const left = Buffer.alloc(32, 0x01);
|
||||||
|
const right = Buffer.alloc(32, 0x02);
|
||||||
|
const payload = Buffer.concat([Buffer.from([0x02]), left, right]);
|
||||||
|
const result = deserializePayload(payload);
|
||||||
|
strictEqual(result.type, "fork");
|
||||||
|
strictEqual(result.leftHash, "01".repeat(32));
|
||||||
|
strictEqual(result.rightHash, "02".repeat(32));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Leaf with extra bytes fails", () => {
|
||||||
|
throws(() => deserializePayload(Buffer.from([0x00, 0x00])), /invalid leaf/);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Unknown type fails", () => {
|
||||||
|
throws(() => deserializePayload(Buffer.from([0xff])), /unknown type/);
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("merkle — computeNodeHash", () => {
|
||||||
|
it("Leaf hash is correct length", () => {
|
||||||
|
const leaf = { type: "leaf" };
|
||||||
|
const hash = computeNodeHash(leaf);
|
||||||
|
strictEqual(hash.length, 64);
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("merkle — node section parsing", () => {
|
||||||
|
const fixtureDir = "test/fixtures";
|
||||||
|
|
||||||
|
it("parses id.tri.bundle with correct node count", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
strictEqual(nodeMap.size, 4);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("parses true.tri.bundle with correct node count", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/true.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
strictEqual(nodeMap.size, 2);
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("merkle — hash verification", () => {
|
||||||
|
const fixtureDir = "test/fixtures";
|
||||||
|
|
||||||
|
it("id.tri.bundle nodes all verify", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
const { verified, mismatches } = verifyNodeHashes(nodeMap);
|
||||||
|
ok(verified, "id.tri.bundle node hashes should verify");
|
||||||
|
strictEqual(mismatches.length, 0);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("corrupted node payload fails hash verification", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
// Find a stem node to corrupt
|
||||||
|
let stemKey = null;
|
||||||
|
for (const [key, node] of nodeMap) {
|
||||||
|
if (node.type === "stem") { stemKey = key; break; }
|
||||||
|
}
|
||||||
|
ok(stemKey, "should find a stem node to corrupt");
|
||||||
|
const stem = nodeMap.get(stemKey);
|
||||||
|
// Corrupt the child hash so serializeNode produces a different payload
|
||||||
|
const corrupted = {
|
||||||
|
...stem,
|
||||||
|
childHash: "00".repeat(32),
|
||||||
|
payload: Buffer.concat([Buffer.from([0x01]), Buffer.alloc(32, 0x00)]),
|
||||||
|
};
|
||||||
|
nodeMap.set(stemKey, corrupted);
|
||||||
|
const { verified, mismatches } = verifyNodeHashes(nodeMap);
|
||||||
|
ok(!verified, "corrupted stem should fail hash verification");
|
||||||
|
ok(mismatches.length > 0, "should have mismatches");
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("merkle — closure verification", () => {
|
||||||
|
const fixtureDir = "test/fixtures";
|
||||||
|
|
||||||
|
it("id.tri.bundle has complete closure", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
const { complete, missing } = verifyClosure(nodeMap);
|
||||||
|
ok(complete, "id.tri.bundle should have complete closure");
|
||||||
|
strictEqual(missing.length, 0);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("verifyRootClosure checks transitive reachability", () => {
|
||||||
|
const data = parseNodeSection(
|
||||||
|
readFileSync(`${fixtureDir}/id.tri.bundle`)
|
||||||
|
);
|
||||||
|
const { nodeMap } = parseNodes(data);
|
||||||
|
const rootHash = "039cc9aacf5be78ec1975713e6ad154a36988e3f3df18589b0d0c801d0825d78";
|
||||||
|
const { complete, missingRoots } = verifyRootClosure(nodeMap, rootHash);
|
||||||
|
ok(complete, "root should be reachable");
|
||||||
|
strictEqual(missingRoots.length, 0);
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
// Helper import
|
||||||
|
import { parseNodeSection as parseNodes } from "../src/merkle.js";
|
||||||
|
|
||||||
|
// Helper for throws
|
||||||
|
function throws(fn, expected) {
|
||||||
|
try {
|
||||||
|
fn();
|
||||||
|
return false;
|
||||||
|
} catch (e) {
|
||||||
|
return expected.test(e.message);
|
||||||
|
}
|
||||||
|
}
|
||||||
80
ext/js/test/reduce.test.js
Normal file
80
ext/js/test/reduce.test.js
Normal file
@@ -0,0 +1,80 @@
|
|||||||
|
import { strictEqual, ok } from "node:assert";
|
||||||
|
import { describe, it } from "node:test";
|
||||||
|
import { apply, isLeaf, isStem, isFork } from "../src/tree.js";
|
||||||
|
import { reduce } from "../src/cli.js";
|
||||||
|
|
||||||
|
describe("tree — basic types", () => {
|
||||||
|
it("Leaf is empty array", () => {
|
||||||
|
ok(isLeaf([]));
|
||||||
|
ok(!isStem([]));
|
||||||
|
ok(!isFork([]));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Stem is single-element array", () => {
|
||||||
|
ok(isStem([[]]));
|
||||||
|
ok(!isLeaf([[]]));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("Fork is two-element array", () => {
|
||||||
|
ok(isFork([[], []]));
|
||||||
|
ok(!isLeaf([[], []]));
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("tree — apply rules", () => {
|
||||||
|
// Leaf = [], Stem = [child], Fork = [right, left]
|
||||||
|
|
||||||
|
it("apply(Leaf, b) = Stem(b)", () => {
|
||||||
|
const b = []; // Leaf
|
||||||
|
const result = apply([], b);
|
||||||
|
ok(isStem(result), "Stem(b) should be a Stem");
|
||||||
|
strictEqual(result[0], b);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("apply(Stem(a), b) = Fork(a, b)", () => {
|
||||||
|
const a = []; // Leaf
|
||||||
|
const b = []; // Leaf
|
||||||
|
const result = apply([a], b);
|
||||||
|
ok(isFork(result), "Fork(a, b) should be a Fork");
|
||||||
|
// Fork = [right, left] = [b, a]
|
||||||
|
strictEqual(result[0], b);
|
||||||
|
strictEqual(result[1], a);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("apply(Fork(Leaf, a), _) = a", () => {
|
||||||
|
// Fork(Leaf, a) = [a, Leaf]
|
||||||
|
const a = []; // Leaf
|
||||||
|
const result = apply([a, []], []);
|
||||||
|
strictEqual(result, a);
|
||||||
|
ok(isLeaf(result));
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("tree — reduction", () => {
|
||||||
|
it("reduces Leaf to Leaf", () => {
|
||||||
|
const result = reduce([], 100);
|
||||||
|
ok(isLeaf(result));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("reduces Stem Leaf to Stem Leaf", () => {
|
||||||
|
const result = reduce([[]], 100);
|
||||||
|
ok(isStem(result));
|
||||||
|
ok(isLeaf(result[0]));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("reduces Fork Leaf Leaf to Fork Leaf Leaf", () => {
|
||||||
|
const result = reduce([[], []], 100);
|
||||||
|
ok(isFork(result));
|
||||||
|
ok(isLeaf(result[0]));
|
||||||
|
ok(isLeaf(result[1]));
|
||||||
|
});
|
||||||
|
|
||||||
|
it("S combinator applied to Leaf reduces", () => {
|
||||||
|
// S = t (t (t t)) t = Fork (Fork (Fork Leaf Leaf) Leaf) Leaf
|
||||||
|
// In array form: [[[], []], [], []]
|
||||||
|
const s = [[], [[[], []], []]];
|
||||||
|
const leaf = [];
|
||||||
|
const result = reduce([s, leaf], 100);
|
||||||
|
ok(Array.isArray(result), "S Leaf should reduce to an array");
|
||||||
|
});
|
||||||
|
});
|
||||||
84
ext/js/test/run-bundle.test.js
Normal file
84
ext/js/test/run-bundle.test.js
Normal file
@@ -0,0 +1,84 @@
|
|||||||
|
import { readFileSync } from "node:fs";
|
||||||
|
import { strictEqual, ok, throws } from "node:assert";
|
||||||
|
import { describe, it } from "node:test";
|
||||||
|
import { parseManifest } from "../src/bundle.js";
|
||||||
|
import { parseNodeSection as bundleParseNodeSection } from "../src/bundle.js";
|
||||||
|
import { validateManifest, selectExport } from "../src/manifest.js";
|
||||||
|
import { verifyNodeHashes, parseNodeSection as parseNodes } from "../src/merkle.js";
|
||||||
|
import { buildTreeFromNodeMap } from "../src/cli.js";
|
||||||
|
|
||||||
|
const fixtureDir = "test/fixtures";
|
||||||
|
|
||||||
|
describe("run bundle — id.tri.bundle", () => {
|
||||||
|
const bundle = readFileSync(`${fixtureDir}/id.tri.bundle`);
|
||||||
|
const manifest = parseManifest(bundle);
|
||||||
|
const nodeSectionData = bundleParseNodeSection(bundle);
|
||||||
|
const { nodeMap } = parseNodes(nodeSectionData);
|
||||||
|
|
||||||
|
it("manifest validates", () => {
|
||||||
|
validateManifest(manifest);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("node hashes verify", () => {
|
||||||
|
const { verified } = verifyNodeHashes(nodeMap);
|
||||||
|
ok(verified);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("export 'id' is selectable", () => {
|
||||||
|
const exp = selectExport(manifest, "id");
|
||||||
|
strictEqual(exp.name, "id");
|
||||||
|
});
|
||||||
|
|
||||||
|
it("tree reconstructs as a Fork", () => {
|
||||||
|
const exp = selectExport(manifest, "id");
|
||||||
|
const tree = buildTreeFromNodeMap(nodeMap, exp.root);
|
||||||
|
ok(Array.isArray(tree));
|
||||||
|
// id = t (t t) = Fork (Stem Leaf) Leaf...
|
||||||
|
// In Haskell: id = S = t (t (t t)) t
|
||||||
|
// This is Fork (Fork (Fork Leaf Leaf) Leaf) Leaf
|
||||||
|
// In array form: [[[], []], [], []]
|
||||||
|
ok(tree.length >= 2, "tree should be a Fork (length >= 2)");
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("run bundle — true.tri.bundle", () => {
|
||||||
|
const bundle = readFileSync(`${fixtureDir}/true.tri.bundle`);
|
||||||
|
const manifest = parseManifest(bundle);
|
||||||
|
const nodeSectionData = bundleParseNodeSection(bundle);
|
||||||
|
const { nodeMap } = parseNodes(nodeSectionData);
|
||||||
|
|
||||||
|
it("manifest validates", () => {
|
||||||
|
validateManifest(manifest);
|
||||||
|
});
|
||||||
|
|
||||||
|
it("export 'const' is selectable", () => {
|
||||||
|
const exp = selectExport(manifest, "const");
|
||||||
|
strictEqual(exp.name, "const");
|
||||||
|
});
|
||||||
|
|
||||||
|
it("tree reconstructs", () => {
|
||||||
|
const exp = selectExport(manifest, "const");
|
||||||
|
const tree = buildTreeFromNodeMap(nodeMap, exp.root);
|
||||||
|
ok(Array.isArray(tree));
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("run bundle — missing export", () => {
|
||||||
|
const bundle = readFileSync(`${fixtureDir}/id.tri.bundle`);
|
||||||
|
const manifest = parseManifest(bundle);
|
||||||
|
|
||||||
|
it("nonexistent export fails clearly", () => {
|
||||||
|
throws(() => selectExport(manifest, "nonexistent"), /not found/);
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
describe("run bundle — auto-select", () => {
|
||||||
|
// true.tri.bundle has only one export, should auto-select
|
||||||
|
const bundle = readFileSync(`${fixtureDir}/true.tri.bundle`);
|
||||||
|
const manifest = parseManifest(bundle);
|
||||||
|
|
||||||
|
it("single export auto-selects", () => {
|
||||||
|
const exp = selectExport(manifest, undefined);
|
||||||
|
ok(exp, "should auto-select the only export");
|
||||||
|
});
|
||||||
|
});
|
||||||
74
flake.nix
74
flake.nix
@@ -9,26 +9,45 @@
|
|||||||
outputs = { self, nixpkgs, flake-utils }:
|
outputs = { self, nixpkgs, flake-utils }:
|
||||||
flake-utils.lib.eachDefaultSystem (system:
|
flake-utils.lib.eachDefaultSystem (system:
|
||||||
let
|
let
|
||||||
pkgs = nixpkgs.legacyPackages.${system};
|
pkgs = nixpkgs.legacyPackages.${system};
|
||||||
packageName = "tricu";
|
packageName = "tricu";
|
||||||
containerPackageName = "${packageName}-container";
|
containerPackageName = "${packageName}-container";
|
||||||
|
|
||||||
customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
|
haskellPackages = pkgs.haskellPackages;
|
||||||
|
hsLib = pkgs.haskell.lib;
|
||||||
|
|
||||||
|
tricuStatic = hsLib.justStaticExecutables self.packages.${system}.default;
|
||||||
|
|
||||||
|
tricuPackage =
|
||||||
|
haskellPackages.callCabal2nix packageName self {};
|
||||||
|
|
||||||
|
tricuTests =
|
||||||
|
hsLib.overrideCabal tricuPackage (old: {
|
||||||
|
doCheck = true;
|
||||||
|
|
||||||
|
configureFlags = (old.configureFlags or []) ++ [
|
||||||
|
"--enable-tests"
|
||||||
|
];
|
||||||
|
|
||||||
|
checkPhase = ''
|
||||||
|
runHook preCheck
|
||||||
|
./Setup test tricu-tests --show-details=direct
|
||||||
|
runHook postCheck
|
||||||
|
'';
|
||||||
|
});
|
||||||
|
|
||||||
|
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
|
||||||
megaparsec
|
megaparsec
|
||||||
]);
|
]);
|
||||||
|
|
||||||
haskellPackages = pkgs.haskellPackages;
|
|
||||||
|
|
||||||
enableSharedExecutables = false;
|
|
||||||
enableSharedLibraries = false;
|
|
||||||
|
|
||||||
tricu = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
|
|
||||||
in {
|
in {
|
||||||
|
packages.${packageName} = tricuPackage;
|
||||||
|
packages.default = tricuPackage;
|
||||||
|
|
||||||
packages.${packageName} =
|
packages.test = tricuTests;
|
||||||
haskellPackages.callCabal2nix packageName self rec {};
|
|
||||||
|
checks.${packageName} = tricuTests;
|
||||||
|
checks.default = tricuTests;
|
||||||
|
|
||||||
packages.default = self.packages.${system}.${packageName};
|
|
||||||
defaultPackage = self.packages.${system}.default;
|
defaultPackage = self.packages.${system}.default;
|
||||||
|
|
||||||
devShells.default = pkgs.mkShell {
|
devShells.default = pkgs.mkShell {
|
||||||
@@ -39,9 +58,36 @@
|
|||||||
customGHC
|
customGHC
|
||||||
upx
|
upx
|
||||||
];
|
];
|
||||||
inputsFrom = builtins.attrValues self.packages.${system};
|
|
||||||
|
inputsFrom = [
|
||||||
|
tricuPackage
|
||||||
|
];
|
||||||
};
|
};
|
||||||
devShell = self.devShells.${system}.default;
|
devShell = self.devShells.${system}.default;
|
||||||
|
|
||||||
|
packages.${containerPackageName} = pkgs.dockerTools.buildImage {
|
||||||
|
name = "tricu";
|
||||||
|
|
||||||
|
copyToRoot = pkgs.buildEnv {
|
||||||
|
name = "image-root";
|
||||||
|
paths = [ tricuStatic ];
|
||||||
|
pathsToLink = [ "/bin" ];
|
||||||
|
};
|
||||||
|
tag = "latest";
|
||||||
|
config = {
|
||||||
|
Cmd = [
|
||||||
|
"/bin/tricu"
|
||||||
|
"server"
|
||||||
|
"-h" "0.0.0.0"
|
||||||
|
"-p" "8787"
|
||||||
|
];
|
||||||
|
WorkingDir = "/app";
|
||||||
|
ExposedPorts = {
|
||||||
|
"8787/tcp" = {};
|
||||||
|
};
|
||||||
|
extraCommands = ''
|
||||||
|
'';
|
||||||
|
};
|
||||||
|
};
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|||||||
64
lib/base.tri
64
lib/base.tri
@@ -1,74 +1,74 @@
|
|||||||
false = t
|
false = t
|
||||||
_ = t
|
_ = t
|
||||||
true = t t
|
true = t t
|
||||||
id = \a : a
|
id = a : a
|
||||||
const = \a b : a
|
const = a b : a
|
||||||
pair = t
|
pair = t
|
||||||
if = \cond then else : t (t else (t t then)) t cond
|
if = cond then else : t (t else (t t then)) t cond
|
||||||
|
|
||||||
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
|
y = ((mut wait fun : wait mut (x : fun (wait mut x)))
|
||||||
(\x : x x)
|
(x : x x)
|
||||||
(\a0 a1 a2 : t (t a0) (t t a2) a1))
|
(a0 a1 a2 : t (t a0) (t t a2) a1))
|
||||||
|
|
||||||
compose = \f g x : f (g x)
|
compose = f g x : f (g x)
|
||||||
|
|
||||||
triage = \leaf stem fork : t (t leaf stem) fork
|
triage = leaf stem fork : t (t leaf stem) fork
|
||||||
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
test = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
|
||||||
|
|
||||||
matchBool = (\ot of : triage
|
matchBool = (ot of : triage
|
||||||
of
|
of
|
||||||
(\_ : ot)
|
(_ : ot)
|
||||||
(\_ _ : ot)
|
(_ _ : ot)
|
||||||
)
|
)
|
||||||
|
|
||||||
lAnd = (triage
|
lAnd = (triage
|
||||||
(\_ : false)
|
(_ : false)
|
||||||
(\_ x : x)
|
(_ x : x)
|
||||||
(\_ _ x : x))
|
(_ _ x : x))
|
||||||
|
|
||||||
lOr = (triage
|
lOr = (triage
|
||||||
(\x : x)
|
(x : x)
|
||||||
(\_ _ : true)
|
(_ _ : true)
|
||||||
(\_ _ _ : true))
|
(_ _ _ : true))
|
||||||
|
|
||||||
matchPair = \a : triage _ _ a
|
matchPair = a : triage _ _ a
|
||||||
|
|
||||||
not? = matchBool false true
|
not? = matchBool false true
|
||||||
and? = matchBool id (\_ : false)
|
and? = matchBool id (_ : false)
|
||||||
|
|
||||||
or? = (\x z :
|
or? = (x z :
|
||||||
matchBool
|
matchBool
|
||||||
(matchBool true true z)
|
(matchBool true true z)
|
||||||
(matchBool true false z)
|
(matchBool true false z)
|
||||||
x)
|
x)
|
||||||
|
|
||||||
xor? = (\x z :
|
xor? = (x z :
|
||||||
matchBool
|
matchBool
|
||||||
(matchBool false true z)
|
(matchBool false true z)
|
||||||
(matchBool true false z)
|
(matchBool true false z)
|
||||||
x)
|
x)
|
||||||
|
|
||||||
equal? = y (\self : triage
|
equal? = y (self : triage
|
||||||
(triage
|
(triage
|
||||||
true
|
true
|
||||||
(\_ : false)
|
(_ : false)
|
||||||
(\_ _ : false))
|
(_ _ : false))
|
||||||
(\ax :
|
(ax :
|
||||||
triage
|
triage
|
||||||
false
|
false
|
||||||
(self ax)
|
(self ax)
|
||||||
(\_ _ : false))
|
(_ _ : false))
|
||||||
(\ax ay :
|
(ax ay :
|
||||||
triage
|
triage
|
||||||
false
|
false
|
||||||
(\_ : false)
|
(_ : false)
|
||||||
(\bx by : lAnd (self ax bx) (self ay by))))
|
(bx by : lAnd (self ax bx) (self ay by))))
|
||||||
|
|
||||||
succ = y (\self :
|
succ = y (self :
|
||||||
triage
|
triage
|
||||||
1
|
1
|
||||||
t
|
t
|
||||||
(triage
|
(triage
|
||||||
(t (t t))
|
(t (t t))
|
||||||
(\_ tail : t t (self tail))
|
(_ tail : t t (self tail))
|
||||||
t))
|
t))
|
||||||
|
|||||||
49
lib/bytes.tri
Normal file
49
lib/bytes.tri
Normal file
@@ -0,0 +1,49 @@
|
|||||||
|
!import "base.tri" !Local
|
||||||
|
!import "list.tri" !Local
|
||||||
|
|
||||||
|
nothing = t
|
||||||
|
just = x : t x
|
||||||
|
|
||||||
|
bytesIsNil = emptyList?
|
||||||
|
|
||||||
|
bytesHead = matchList nothing (h _ : just h)
|
||||||
|
|
||||||
|
bytesTail = matchList nothing (_ r : just r)
|
||||||
|
|
||||||
|
byteEq = equal?
|
||||||
|
bytesLength = length
|
||||||
|
bytesAppend = append
|
||||||
|
|
||||||
|
bytesTake_ = y (self n i remaining :
|
||||||
|
matchBool
|
||||||
|
t
|
||||||
|
(matchList
|
||||||
|
t
|
||||||
|
(h r : pair h (self n (succ i) r))
|
||||||
|
remaining)
|
||||||
|
(equal? i n))
|
||||||
|
|
||||||
|
bytesTake = n bytes : bytesTake_ n 0 bytes
|
||||||
|
|
||||||
|
bytesDrop_ = y (self n i remaining :
|
||||||
|
matchBool
|
||||||
|
remaining
|
||||||
|
(matchList
|
||||||
|
t
|
||||||
|
(_ r : self n (succ i) r)
|
||||||
|
remaining)
|
||||||
|
(equal? i n))
|
||||||
|
|
||||||
|
bytesDrop = n bytes : bytesDrop_ n 0 bytes
|
||||||
|
|
||||||
|
bytesSplitAt = n bytes : pair (bytesTake n bytes) (bytesDrop n bytes)
|
||||||
|
|
||||||
|
bytesEq = y (self xs ys :
|
||||||
|
matchList
|
||||||
|
(matchList true (_ _ : false) ys)
|
||||||
|
(xh xt :
|
||||||
|
matchList
|
||||||
|
false
|
||||||
|
(yh yt : and? (byteEq xh yh) (self xt yt))
|
||||||
|
ys)
|
||||||
|
xs)
|
||||||
83
lib/list.tri
83
lib/list.tri
@@ -1,77 +1,70 @@
|
|||||||
!import "base.tri" !Local
|
!import "base.tri" !Local
|
||||||
|
|
||||||
matchList = \a b : triage a _ b
|
_ = t
|
||||||
|
|
||||||
emptyList? = matchList true (\_ _ : false)
|
matchList = a b : triage a _ b
|
||||||
head = matchList t (\head _ : head)
|
|
||||||
tail = matchList t (\_ tail : tail)
|
|
||||||
|
|
||||||
append = y (\self : matchList
|
emptyList? = matchList true (_ _ : false)
|
||||||
(\k : k)
|
head = matchList t (head _ : head)
|
||||||
(\h r k : pair h (self r k)))
|
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
|
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
|
matchList
|
||||||
(\_ : t)
|
(_ : t)
|
||||||
(\head tail f : pair (f head) (self tail f)))
|
(head tail f : pair (f head) (self tail f)))
|
||||||
map = \f l : map_ l f
|
map = f l : map_ l f
|
||||||
|
|
||||||
filter_ = y (\self : matchList
|
filter_ = y (self : matchList
|
||||||
(\_ : t)
|
(_ : t)
|
||||||
(\head tail f : matchBool (t head) id (f head) (self tail f)))
|
(head tail f : matchBool (t head) id (f head) (self tail f)))
|
||||||
filter = \f l : filter_ l f
|
filter = f l : filter_ l f
|
||||||
|
|
||||||
foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
|
foldl_ = y (self f l x : matchList (acc : acc) (head tail acc : self f tail (f acc head)) l x)
|
||||||
foldl = \f x l : foldl_ f l x
|
foldl = f x l : foldl_ f l x
|
||||||
|
|
||||||
foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
|
foldr_ = y (self x f l : matchList x (head tail : f (self x f tail) head) l)
|
||||||
foldr = \f x l : foldr_ x f l
|
foldr = f x l : foldr_ x f l
|
||||||
|
|
||||||
length = y (\self : matchList
|
length = y (self : matchList
|
||||||
0
|
0
|
||||||
(\_ tail : succ (self tail)))
|
(_ tail : succ (self tail)))
|
||||||
|
|
||||||
reverse = y (\self : matchList
|
reverse = y (self : matchList
|
||||||
t
|
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)
|
(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
|
0
|
||||||
(\h z : matchBool
|
(h z : matchBool
|
||||||
(succ (self x z))
|
(succ (self x z))
|
||||||
(self x z)
|
(self x z)
|
||||||
(equal? x h)))
|
(equal? x h)))
|
||||||
|
|
||||||
last = y (\self : matchList
|
last = y (self : matchList
|
||||||
t
|
t
|
||||||
(\hd tl : matchBool
|
(hd tl : matchBool
|
||||||
hd
|
hd
|
||||||
(self tl)
|
(self tl)
|
||||||
(emptyList? tl)))
|
(emptyList? tl)))
|
||||||
|
|
||||||
all? = y (\self pred : matchList
|
all? = y (self pred : matchList
|
||||||
true
|
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
|
false
|
||||||
(\h z : or? (pred h) (self pred z)))
|
(h z : or? (pred h) (self pred z)))
|
||||||
|
|
||||||
unique_ = y (\self seen : matchList
|
intersect = xs ys : filter (x : lExist? x ys) xs
|
||||||
t
|
|
||||||
(\head rest : matchBool
|
|
||||||
(self seen rest)
|
|
||||||
(pair head (self (pair head seen) rest))
|
|
||||||
(lExist? head seen)))
|
|
||||||
unique = \xs : unique_ t xs
|
|
||||||
|
|
||||||
intersect = \xs ys : filter (\x : lExist? x ys) xs
|
|
||||||
union = \xs ys : unique (append xs ys)
|
|
||||||
|
|||||||
@@ -1,35 +1,24 @@
|
|||||||
|
!import "base.tri" !Local
|
||||||
!import "list.tri" !Local
|
!import "list.tri" !Local
|
||||||
|
|
||||||
match_ = y (\self value patterns :
|
match_ = y (self value patterns :
|
||||||
triage
|
triage
|
||||||
t
|
t
|
||||||
(\_ : t)
|
(_ : t)
|
||||||
(\pattern rest :
|
(pattern rest :
|
||||||
triage
|
triage
|
||||||
t
|
t
|
||||||
(\_ : t)
|
(_ : t)
|
||||||
(\test result :
|
(test result :
|
||||||
if (test value)
|
if (test value)
|
||||||
(result value)
|
(result value)
|
||||||
(self value rest))
|
(self value rest))
|
||||||
pattern)
|
pattern)
|
||||||
patterns)
|
patterns)
|
||||||
|
|
||||||
match = (\value patterns :
|
match = (value patterns :
|
||||||
match_ value (map (\sublist :
|
match_ value (map (sublist :
|
||||||
pair (head sublist) (head (tail sublist)))
|
pair (head sublist) (head (tail sublist)))
|
||||||
patterns))
|
patterns))
|
||||||
|
|
||||||
otherwise = const (t t)
|
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!")]])
|
|
||||||
|
|||||||
309
src/ContentStore.hs
Normal file
309
src/ContentStore.hs
Normal file
@@ -0,0 +1,309 @@
|
|||||||
|
module ContentStore where
|
||||||
|
|
||||||
|
import Research
|
||||||
|
|
||||||
|
import Control.Monad (foldM, forM_, void)
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Char (isHexDigit)
|
||||||
|
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.Environment (lookupEnv)
|
||||||
|
import System.Exit (die)
|
||||||
|
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
|
||||||
|
maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
|
||||||
|
case maybeLocalPath of
|
||||||
|
Just p -> return p
|
||||||
|
Nothing -> 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
|
||||||
|
|
||||||
|
-- | Resolve a user-supplied identifier (full/prefix hash, term name) to
|
||||||
|
-- a single term hash and the list of names bound to it. Dies on
|
||||||
|
-- ambiguity or missing term (matching the CLI @export@ semantics).
|
||||||
|
resolveExportTarget :: Connection -> String -> IO (Text, [Text])
|
||||||
|
resolveExportTarget conn input = do
|
||||||
|
let raw = T.pack $ dropWhile (== '#') input
|
||||||
|
byName <- 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 <- 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
|
||||||
|
|
||||||
|
-- | Return 'True' when @t@ looks like a full or partial SHA-256 hex hash.
|
||||||
|
looksLikeHash :: Text -> Bool
|
||||||
|
looksLikeHash t =
|
||||||
|
let len = T.length t
|
||||||
|
in len >= 16 && len <= 64 && T.all isHexDigit t
|
||||||
572
src/Eval.hs
572
src/Eval.hs
@@ -1,117 +1,229 @@
|
|||||||
module Eval where
|
module Eval where
|
||||||
|
|
||||||
|
import ContentStore
|
||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
|
||||||
import Data.List (partition, (\\))
|
import Control.Monad (foldM)
|
||||||
import Data.Map (Map)
|
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.Map as Map
|
||||||
import qualified Data.Set as Set
|
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 -> TricuAST -> Env
|
||||||
evalSingle env term
|
evalSingle env term
|
||||||
| SDef name [] body <- term
|
| SDef name [] body <- term
|
||||||
= case Map.lookup name env of
|
= case Map.lookup name env of
|
||||||
Just existingValue
|
Just existingValue
|
||||||
| existingValue == evalAST env body -> env
|
| existingValue == evalASTSync env body -> env
|
||||||
| otherwise -> errorWithoutStackTrace $
|
| otherwise
|
||||||
"Unable to rebind immutable identifier: " ++ name
|
-> let res = evalASTSync env body
|
||||||
Nothing ->
|
in Map.insert "!result" res (Map.insert name res env)
|
||||||
let res = evalAST env body
|
Nothing
|
||||||
in Map.insert "!result" res (Map.insert name res env)
|
-> let res = evalASTSync env body
|
||||||
|
in Map.insert "!result" res (Map.insert name res env)
|
||||||
| SApp func arg <- term
|
| SApp func arg <- term
|
||||||
= let res = apply (evalAST env func) (evalAST env arg)
|
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||||
in Map.insert "!result" res env
|
in Map.insert "!result" res env
|
||||||
| SVar name <- term
|
| SVar name Nothing <- term
|
||||||
= case Map.lookup name env of
|
= case Map.lookup name env of
|
||||||
Just v -> Map.insert "!result" v env
|
Just v -> Map.insert "!result" v env
|
||||||
Nothing ->
|
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||||
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
|
| SVar name (Just hash) <- term
|
||||||
\This error should never occur here. Please report this as an issue."
|
= errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash
|
||||||
| otherwise
|
| 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 -> [TricuAST] -> Env
|
||||||
evalTricu env x = go env (reorderDefs env x)
|
evalTricu env x = go env (reorderDefs env x)
|
||||||
where
|
where
|
||||||
go env [] = env
|
go env' [] = env'
|
||||||
go env [x] =
|
go env' [def] =
|
||||||
let updatedEnv = evalSingle env x
|
let updatedEnv = evalSingle env' def
|
||||||
in Map.insert "!result" (result updatedEnv) updatedEnv
|
in Map.insert "!result" (result updatedEnv) updatedEnv
|
||||||
go env (x:xs) =
|
go env' (def:xs) =
|
||||||
evalTricu (evalSingle env x) xs
|
evalTricu (evalSingle env' def) xs
|
||||||
|
|
||||||
evalAST :: Env -> TricuAST -> T
|
evalASTSync :: Env -> TricuAST -> T
|
||||||
evalAST env term
|
evalASTSync env term = case term of
|
||||||
| SLambda _ _ <- term = evalAST env (elimLambda term)
|
SLambda _ _ -> evalASTSync env (elimLambda term)
|
||||||
| SVar name <- term = evalVar name
|
SVar name Nothing -> case Map.lookup name env of
|
||||||
| TLeaf <- term = Leaf
|
Just v -> v
|
||||||
| TStem t <- term = Stem (evalAST env t)
|
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||||
| TFork t u <- term = Fork (evalAST env t) (evalAST env u)
|
SVar name (Just hash) ->
|
||||||
| SApp t u <- term = apply (evalAST env t) (evalAST env u)
|
case Map.lookup (name ++ "#" ++ hash) env of
|
||||||
| SStr s <- term = ofString s
|
Just v -> v
|
||||||
| SInt n <- term = ofNumber n
|
Nothing -> errorWithoutStackTrace $
|
||||||
| SList xs <- term = ofList (map (evalAST env) xs)
|
"Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment"
|
||||||
| SEmpty <- term = Leaf
|
TLeaf -> Leaf
|
||||||
| otherwise = errorWithoutStackTrace "Unexpected AST term"
|
TStem t -> Stem (evalASTSync env t)
|
||||||
where
|
TFork t u -> Fork (evalASTSync env t) (evalASTSync env u)
|
||||||
evalVar name = Map.findWithDefault
|
SApp t u -> apply (evalASTSync env t) (evalASTSync env u)
|
||||||
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
SStr s -> ofString s
|
||||||
name env
|
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 :: TricuAST -> TricuAST
|
||||||
elimLambda = go
|
elimLambda = go
|
||||||
where
|
where
|
||||||
-- η-reduction
|
go term
|
||||||
go (SLambda [v] (SApp f (SVar x)))
|
| etaReduction term = go (etaReduceResult term)
|
||||||
| v == x && not (isFree v f) = elimLambda f
|
| triagePattern term = _TRI
|
||||||
-- Triage optimization
|
| composePattern term = _B
|
||||||
go (SLambda [a] (SLambda [b] (SLambda [c] body)))
|
| lambdaList term = go (lambdaListResult term)
|
||||||
| body == triageBody = _TRIAGE
|
| 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
|
where
|
||||||
triageBody =
|
wrapTLeaf m r = SApp (SApp TLeaf m) r
|
||||||
SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
|
lambdaListResult _ = error "lambdaListResult: expected SLambda [v] (SList xs)"
|
||||||
-- 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: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
|
|
||||||
|
|
||||||
toSKI x (SVar y)
|
nestedLambdaResult (SLambda (v:vs) body)
|
||||||
| x == y = _I
|
| null vs =
|
||||||
| otherwise = SApp _K (SVar y)
|
let body' = go body
|
||||||
toSKI x t@(SApp n u)
|
db = toDB [v] body'
|
||||||
| not (isFree x t) = SApp _K t
|
in toSKIKiselyov db
|
||||||
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
| otherwise = go (SLambda [v] (SLambda vs body))
|
||||||
toSKI x t
|
nestedLambdaResult _ = error "nestedLambdaResult: expected SLambda (_:_) _"
|
||||||
| not (isFree x t) = SApp _K t
|
|
||||||
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
|
|
||||||
|
|
||||||
_S = parseSingle "t (t (t t t)) t"
|
applicationResult (SApp f g) = SApp (go f) (go g)
|
||||||
_K = parseSingle "t t"
|
applicationResult _ = error "applicationResult: expected SApp _ _"
|
||||||
_I = parseSingle "t (t (t t)) t"
|
|
||||||
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
isSList (SList _) = True
|
||||||
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
|
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 :: String -> TricuAST -> Bool
|
||||||
isFree x = Set.member x . freeVars
|
isFree x t = Set.member x (freeVars t)
|
||||||
|
|
||||||
freeVars :: TricuAST -> Set.Set String
|
-- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
|
||||||
freeVars (SVar v ) = Set.singleton v
|
freeVars :: TricuAST -> Set String
|
||||||
freeVars (SInt _ ) = Set.empty
|
freeVars (SVar v Nothing) = Set.singleton v
|
||||||
freeVars (SStr _ ) = Set.empty
|
freeVars (SVar v (Just _)) = Set.singleton v
|
||||||
freeVars (SList s ) = foldMap freeVars s
|
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||||
freeVars (SApp f a ) = freeVars f <> freeVars a
|
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||||
freeVars TLeaf = Set.empty
|
freeVars _ = 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
|
|
||||||
|
|
||||||
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||||
reorderDefs env defs
|
reorderDefs env defs
|
||||||
@@ -128,7 +240,7 @@ reorderDefs env defs
|
|||||||
graph = buildDepGraph defsOnly
|
graph = buildDepGraph defsOnly
|
||||||
sortedDefs = sortDeps graph
|
sortedDefs = sortDeps graph
|
||||||
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
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
|
freeVarsDefs = foldMap snd defsWithFreeVars
|
||||||
freeVarsOthers = foldMap freeVars others
|
freeVarsOthers = foldMap freeVars others
|
||||||
@@ -136,8 +248,8 @@ reorderDefs env defs
|
|||||||
validNames = Set.fromList defNames `Set.union` Set.fromList (Map.keys env)
|
validNames = Set.fromList defNames `Set.union` Set.fromList (Map.keys env)
|
||||||
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||||
|
|
||||||
isDef (SDef _ _ _) = True
|
isDef SDef {} = True
|
||||||
isDef _ = False
|
isDef _ = False
|
||||||
|
|
||||||
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||||
buildDepGraph topDefs
|
buildDepGraph topDefs
|
||||||
@@ -162,7 +274,7 @@ buildDepGraph topDefs
|
|||||||
sortDeps :: Map.Map String (Set.Set String) -> [String]
|
sortDeps :: Map.Map String (Set.Set String) -> [String]
|
||||||
sortDeps graph = go [] Set.empty (Map.keys graph)
|
sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||||
where
|
where
|
||||||
go sorted sortedSet [] = sorted
|
go sorted _sortedSet [] = sorted
|
||||||
go sorted sortedSet remaining =
|
go sorted sortedSet remaining =
|
||||||
let ready = [ name | name <- remaining
|
let ready = [ name | name <- remaining
|
||||||
, let deps = Map.findWithDefault Set.empty name graph
|
, let deps = Map.findWithDefault Set.empty name graph
|
||||||
@@ -192,3 +304,291 @@ mainResult :: Env -> T
|
|||||||
mainResult r = case Map.lookup "main" r of
|
mainResult r = case Map.lookup "main" r of
|
||||||
Just a -> a
|
Just a -> a
|
||||||
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
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
|
||||||
|
|||||||
100
src/FileEval.hs
100
src/FileEval.hs
@@ -1,28 +1,40 @@
|
|||||||
module FileEval where
|
module FileEval
|
||||||
|
( preprocessFile
|
||||||
|
, evaluateFile
|
||||||
|
, evaluateFileWithContext
|
||||||
|
, evaluateFileResult
|
||||||
|
, compileFile
|
||||||
|
) where
|
||||||
|
|
||||||
import Eval
|
import Eval (evalTricu)
|
||||||
import Lexer
|
import Lexer
|
||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
import ContentStore (initContentStore, storeTerm, hashTerm)
|
||||||
|
import Wire (exportNamedBundle, defaultExportNames)
|
||||||
|
|
||||||
|
import Control.Monad (forM_)
|
||||||
import Data.List (partition)
|
import Data.List (partition)
|
||||||
import Data.Maybe (mapMaybe)
|
import Data.Maybe (mapMaybe)
|
||||||
import Control.Monad (foldM)
|
import System.Environment (setEnv)
|
||||||
import System.IO
|
|
||||||
import System.FilePath (takeDirectory, normalise, (</>))
|
import System.FilePath (takeDirectory, normalise, (</>))
|
||||||
|
import System.Exit (die)
|
||||||
|
import Database.SQLite.Simple (close)
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
extractMain :: Env -> Either String T
|
extractMain :: Env -> Either String T
|
||||||
extractMain env =
|
extractMain env =
|
||||||
case Map.lookup "main" env of
|
case Map.lookup "main" env of
|
||||||
Just result -> Right result
|
Just evalResult -> Right evalResult
|
||||||
Nothing -> Left "No `main` function detected"
|
Nothing -> Left "No `main` function detected"
|
||||||
|
|
||||||
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
|
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
|
||||||
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
|
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
|
||||||
processImports seen base currentPath asts =
|
processImports seen _base currentPath asts =
|
||||||
let (imports, nonImports) = partition isImp asts
|
let (imports, nonImports) = partition isImp asts
|
||||||
importPaths = mapMaybe getImportInfo imports
|
importPaths = mapMaybe getImportInfo imports
|
||||||
in if currentPath `Set.member` seen
|
in if currentPath `Set.member` seen
|
||||||
@@ -40,11 +52,11 @@ evaluateFileResult filePath = do
|
|||||||
let tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right ast -> do
|
Right _ast -> do
|
||||||
processedAst <- preprocessFile filePath
|
processedAst <- preprocessFile filePath
|
||||||
let finalEnv = evalTricu Map.empty processedAst
|
let finalEnv = evalTricu Map.empty processedAst
|
||||||
case extractMain finalEnv of
|
case extractMain finalEnv of
|
||||||
Right result -> return result
|
Right evalResult -> return evalResult
|
||||||
Left err -> errorWithoutStackTrace err
|
Left err -> errorWithoutStackTrace err
|
||||||
|
|
||||||
evaluateFile :: FilePath -> IO Env
|
evaluateFile :: FilePath -> IO Env
|
||||||
@@ -53,7 +65,7 @@ evaluateFile filePath = do
|
|||||||
let tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right ast -> do
|
Right _ast -> do
|
||||||
ast <- preprocessFile filePath
|
ast <- preprocessFile filePath
|
||||||
pure $ evalTricu Map.empty ast
|
pure $ evalTricu Map.empty ast
|
||||||
|
|
||||||
@@ -63,7 +75,7 @@ evaluateFileWithContext env filePath = do
|
|||||||
let tokens = lexTricu contents
|
let tokens = lexTricu contents
|
||||||
case parseProgram tokens of
|
case parseProgram tokens of
|
||||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||||
Right ast -> do
|
Right _ast -> do
|
||||||
ast <- preprocessFile filePath
|
ast <- preprocessFile filePath
|
||||||
pure $ evalTricu env ast
|
pure $ evalTricu env ast
|
||||||
|
|
||||||
@@ -84,8 +96,8 @@ preprocessFile' seen base currentPath = do
|
|||||||
imported <- concat <$> mapM (processImportPath seen' base) importPaths
|
imported <- concat <$> mapM (processImportPath seen' base) importPaths
|
||||||
pure $ imported ++ nonImports
|
pure $ imported ++ nonImports
|
||||||
where
|
where
|
||||||
processImportPath seen base (path, name, importPath) = do
|
processImportPath _seen _base (_path, name, importPath) = do
|
||||||
ast <- preprocessFile' seen base importPath
|
ast <- preprocessFile' _seen _base importPath
|
||||||
pure $ map (nsDefinition (if name == "!Local" then "" else name))
|
pure $ map (nsDefinition (if name == "!Local" then "" else name))
|
||||||
$ filter (not . isImp) ast
|
$ filter (not . isImp) ast
|
||||||
isImp (SImport _ _) = True
|
isImp (SImport _ _) = True
|
||||||
@@ -96,9 +108,6 @@ makeRelativeTo f i =
|
|||||||
let d = takeDirectory f
|
let d = takeDirectory f
|
||||||
in normalise $ d </> i
|
in normalise $ d </> i
|
||||||
|
|
||||||
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
|
|
||||||
nsDefinitions moduleName = map (nsDefinition moduleName)
|
|
||||||
|
|
||||||
nsDefinition :: String -> TricuAST -> TricuAST
|
nsDefinition :: String -> TricuAST -> TricuAST
|
||||||
nsDefinition "" def = def
|
nsDefinition "" def = def
|
||||||
nsDefinition moduleName (SDef name args body)
|
nsDefinition moduleName (SDef name args body)
|
||||||
@@ -109,9 +118,9 @@ nsDefinition moduleName other =
|
|||||||
nsBody moduleName other
|
nsBody moduleName other
|
||||||
|
|
||||||
nsBody :: String -> TricuAST -> TricuAST
|
nsBody :: String -> TricuAST -> TricuAST
|
||||||
nsBody moduleName (SVar name)
|
nsBody moduleName (SVar name mhash)
|
||||||
| isPrefixed name = SVar name
|
| isPrefixed name = SVar name mhash
|
||||||
| otherwise = SVar (nsVariable moduleName name)
|
| otherwise = SVar (nsVariable moduleName name) mhash
|
||||||
nsBody moduleName (SApp func arg) =
|
nsBody moduleName (SApp func arg) =
|
||||||
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
||||||
nsBody moduleName (SLambda args body) =
|
nsBody moduleName (SLambda args body) =
|
||||||
@@ -122,18 +131,16 @@ nsBody moduleName (TFork left right) =
|
|||||||
TFork (nsBody moduleName left) (nsBody moduleName right)
|
TFork (nsBody moduleName left) (nsBody moduleName right)
|
||||||
nsBody moduleName (TStem subtree) =
|
nsBody moduleName (TStem subtree) =
|
||||||
TStem (nsBody moduleName subtree)
|
TStem (nsBody moduleName subtree)
|
||||||
nsBody moduleName (SDef name args body)
|
nsBody moduleName (SDef name args body) =
|
||||||
| isPrefixed name = SDef name args (nsBody moduleName body)
|
SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body)
|
||||||
| otherwise = SDef (nsVariable moduleName name)
|
|
||||||
args (nsBody moduleName body)
|
|
||||||
nsBody _ other = other
|
nsBody _ other = other
|
||||||
|
|
||||||
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||||
nsBodyScoped moduleName args body = case body of
|
nsBodyScoped moduleName args body = case body of
|
||||||
SVar name ->
|
SVar name mhash ->
|
||||||
if name `elem` args
|
if name `elem` args
|
||||||
then SVar name
|
then SVar name mhash
|
||||||
else nsBody moduleName (SVar name)
|
else nsBody moduleName (SVar name mhash)
|
||||||
SApp func arg ->
|
SApp func arg ->
|
||||||
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
||||||
SLambda innerArgs innerBody ->
|
SLambda innerArgs innerBody ->
|
||||||
@@ -141,13 +148,11 @@ nsBodyScoped moduleName args body = case body of
|
|||||||
SList items ->
|
SList items ->
|
||||||
SList (map (nsBodyScoped moduleName args) items)
|
SList (map (nsBodyScoped moduleName args) items)
|
||||||
TFork left right ->
|
TFork left right ->
|
||||||
TFork (nsBodyScoped moduleName args left)
|
TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
|
||||||
(nsBodyScoped moduleName args right)
|
|
||||||
TStem subtree ->
|
TStem subtree ->
|
||||||
TStem (nsBodyScoped moduleName args subtree)
|
TStem (nsBodyScoped moduleName args subtree)
|
||||||
SDef name innerArgs innerBody ->
|
SDef name innerArgs innerBody ->
|
||||||
SDef (nsVariable moduleName name) innerArgs
|
SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||||
(nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
|
||||||
other -> other
|
other -> other
|
||||||
|
|
||||||
isPrefixed :: String -> Bool
|
isPrefixed :: String -> Bool
|
||||||
@@ -156,3 +161,40 @@ isPrefixed name = '.' `elem` name
|
|||||||
nsVariable :: String -> String -> String
|
nsVariable :: String -> String -> String
|
||||||
nsVariable "" name = name
|
nsVariable "" name = name
|
||||||
nsVariable moduleName name = moduleName ++ "." ++ name
|
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||||
|
|
||||||
|
-- | Compile a tricu source file to a standalone Arborix bundle.
|
||||||
|
-- Uses a temp content store so it does not collide with the global one.
|
||||||
|
-- Supports multiple named exports; each is stored separately in the
|
||||||
|
-- temp store so that resolveExportTarget can look them up by name.
|
||||||
|
compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
|
||||||
|
compileFile inputPath outputPath maybeNames = do
|
||||||
|
-- Evaluate the file to get the full environment
|
||||||
|
env <- evaluateFile inputPath
|
||||||
|
-- Look up each requested definition name
|
||||||
|
let defaultNames = ["main"]
|
||||||
|
wantedNames = if null maybeNames then defaultNames else maybeNames
|
||||||
|
wantedNamesUnpacked = map T.unpack wantedNames
|
||||||
|
compiledTerms <- mapM (\n -> case Map.lookup n env of
|
||||||
|
Nothing -> die $ "No definition '" ++ n ++ "' found in " ++ inputPath
|
||||||
|
Just t -> return (n, t)) wantedNamesUnpacked
|
||||||
|
let compiledMap :: Map.Map T.Text T = Map.fromList
|
||||||
|
$ map (\(n,t) -> (T.pack n, t)) compiledTerms
|
||||||
|
compiledNames :: [T.Text] = Map.keys compiledMap
|
||||||
|
compiledTermsList :: [T] = Map.elems compiledMap
|
||||||
|
-- Create a temp content store
|
||||||
|
setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
|
||||||
|
conn <- initContentStore
|
||||||
|
-- Store each term in the temp store under its requested name
|
||||||
|
forM_ (zip compiledNames compiledTermsList) $ \(n, t) ->
|
||||||
|
storeTerm conn [T.unpack n] t
|
||||||
|
-- Generate default export names when none were supplied
|
||||||
|
let expNames = if null maybeNames
|
||||||
|
then defaultExportNames (length compiledNames)
|
||||||
|
else compiledNames
|
||||||
|
exports :: [(T.Text, MerkleHash)] = zip expNames (map hashTerm compiledTermsList)
|
||||||
|
-- Export the bundle (exportNamedBundle returns already-encoded bytes)
|
||||||
|
bundleData <- exportNamedBundle conn exports
|
||||||
|
BL.writeFile outputPath (BL.fromStrict bundleData)
|
||||||
|
close conn
|
||||||
|
putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
|
||||||
|
putStrLn $ " exports: " ++ T.unpack (T.intercalate ", " expNames)
|
||||||
|
|||||||
82
src/Lexer.hs
82
src/Lexer.hs
@@ -3,13 +3,13 @@ module Lexer where
|
|||||||
import Research
|
import Research
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
|
import Data.Functor (($>))
|
||||||
|
import Data.Set ()
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
import Text.Megaparsec.Char hiding (space)
|
import Text.Megaparsec.Char hiding (space)
|
||||||
import Text.Megaparsec.Char.Lexer
|
import Text.Megaparsec.Char.Lexer
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
|
|
||||||
type Lexer = Parsec Void String
|
type Lexer = Parsec Void String
|
||||||
|
|
||||||
tricuLexer :: Lexer [LToken]
|
tricuLexer :: Lexer [LToken]
|
||||||
@@ -22,25 +22,25 @@ tricuLexer = do
|
|||||||
]
|
]
|
||||||
sc
|
sc
|
||||||
pure tok
|
pure tok
|
||||||
tokens <- many $ do
|
toks <- many $ do
|
||||||
tok <- choice tricuLexer'
|
tok <- choice tricuLexer'
|
||||||
sc
|
sc
|
||||||
pure tok
|
pure tok
|
||||||
sc
|
sc
|
||||||
eof
|
eof
|
||||||
pure (header ++ tokens)
|
pure (header ++ toks)
|
||||||
where
|
where
|
||||||
tricuLexer' =
|
tricuLexer' =
|
||||||
[ try lnewline
|
[ try lnewline
|
||||||
, try namespace
|
, try namespace
|
||||||
, try dot
|
, try dot
|
||||||
|
, try identifierWithHash
|
||||||
, try identifier
|
, try identifier
|
||||||
, try keywordT
|
, try keywordT
|
||||||
, try integerLiteral
|
, try integerLiteral
|
||||||
, try stringLiteral
|
, try stringLiteral
|
||||||
, assign
|
, assign
|
||||||
, colon
|
, colon
|
||||||
, backslash
|
|
||||||
, openParen
|
, openParen
|
||||||
, closeParen
|
, closeParen
|
||||||
, openBracket
|
, openBracket
|
||||||
@@ -50,20 +50,43 @@ tricuLexer = do
|
|||||||
lexTricu :: String -> [LToken]
|
lexTricu :: String -> [LToken]
|
||||||
lexTricu input = case runParser tricuLexer "" input of
|
lexTricu input = case runParser tricuLexer "" input of
|
||||||
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
||||||
Right tokens -> tokens
|
Right toks -> toks
|
||||||
|
|
||||||
|
|
||||||
keywordT :: Lexer LToken
|
keywordT :: Lexer LToken
|
||||||
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
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 '\''
|
||||||
|
_ <- 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 :: Lexer LToken
|
||||||
identifier = do
|
identifier = do
|
||||||
first <- lowerChar <|> char '_'
|
first <- lowerChar <|> char '_'
|
||||||
rest <- many $ letterChar
|
rest <- many $ letterChar
|
||||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||||
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
|
<|> char '$' <|> char '@' <|> char '%'
|
||||||
|
<|> char '\''
|
||||||
let name = first : rest
|
let name = first : rest
|
||||||
if (name == "t" || name == "!result")
|
if name == "t" || name == "!result"
|
||||||
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
|
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
|
||||||
else return (LIdentifier name)
|
else return (LIdentifier name)
|
||||||
|
|
||||||
@@ -76,7 +99,7 @@ namespace = do
|
|||||||
return (LNamespace name)
|
return (LNamespace name)
|
||||||
|
|
||||||
dot :: Lexer LToken
|
dot :: Lexer LToken
|
||||||
dot = char '.' *> pure LDot
|
dot = char '.' $> LDot
|
||||||
|
|
||||||
lImport :: Lexer LToken
|
lImport :: Lexer LToken
|
||||||
lImport = do
|
lImport = do
|
||||||
@@ -88,28 +111,25 @@ lImport = do
|
|||||||
return (LImport path name)
|
return (LImport path name)
|
||||||
|
|
||||||
assign :: Lexer LToken
|
assign :: Lexer LToken
|
||||||
assign = char '=' *> pure LAssign
|
assign = char '=' $> LAssign
|
||||||
|
|
||||||
colon :: Lexer LToken
|
colon :: Lexer LToken
|
||||||
colon = char ':' *> pure LColon
|
colon = char ':' $> LColon
|
||||||
|
|
||||||
backslash :: Lexer LToken
|
|
||||||
backslash = char '\\' *> pure LBackslash
|
|
||||||
|
|
||||||
openParen :: Lexer LToken
|
openParen :: Lexer LToken
|
||||||
openParen = char '(' *> pure LOpenParen
|
openParen = char '(' $> LOpenParen
|
||||||
|
|
||||||
closeParen :: Lexer LToken
|
closeParen :: Lexer LToken
|
||||||
closeParen = char ')' *> pure LCloseParen
|
closeParen = char ')' $> LCloseParen
|
||||||
|
|
||||||
openBracket :: Lexer LToken
|
openBracket :: Lexer LToken
|
||||||
openBracket = char '[' *> pure LOpenBracket
|
openBracket = char '[' $> LOpenBracket
|
||||||
|
|
||||||
closeBracket :: Lexer LToken
|
closeBracket :: Lexer LToken
|
||||||
closeBracket = char ']' *> pure LCloseBracket
|
closeBracket = char ']' $> LCloseBracket
|
||||||
|
|
||||||
lnewline :: Lexer LToken
|
lnewline :: Lexer LToken
|
||||||
lnewline = char '\n' *> pure LNewline
|
lnewline = char '\n' $> LNewline
|
||||||
|
|
||||||
sc :: Lexer ()
|
sc :: Lexer ()
|
||||||
sc = space
|
sc = space
|
||||||
@@ -124,8 +144,24 @@ integerLiteral = do
|
|||||||
|
|
||||||
stringLiteral :: Lexer LToken
|
stringLiteral :: Lexer LToken
|
||||||
stringLiteral = do
|
stringLiteral = do
|
||||||
char '"'
|
void (char '"')
|
||||||
content <- many (noneOf ['"'])
|
content <- manyTill Lexer.charLiteral (void (char '"'))
|
||||||
char '"' --"
|
|
||||||
return (LStringLiteral content)
|
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
|
||||||
|
|||||||
192
src/Main.hs
192
src/Main.hs
@@ -1,17 +1,26 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import ContentStore (initContentStore, loadEnvironment, resolveExportTarget)
|
||||||
|
import Server (runServer)
|
||||||
import Eval (evalTricu, mainResult, result)
|
import Eval (evalTricu, mainResult, result)
|
||||||
import FileEval
|
import FileEval
|
||||||
import Parser (parseTricu)
|
import Parser (parseTricu)
|
||||||
import REPL
|
import REPL
|
||||||
import Research
|
import Research
|
||||||
|
import Wire
|
||||||
|
|
||||||
import Control.Monad (foldM)
|
import Control.Monad (foldM)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Data.Text (Text, unpack)
|
||||||
|
import qualified Data.Text as T
|
||||||
import Data.Version (showVersion)
|
import Data.Version (showVersion)
|
||||||
import Text.Megaparsec (runParser)
|
|
||||||
import Paths_tricu (version)
|
import Paths_tricu (version)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs
|
||||||
|
import System.Environment (lookupEnv)
|
||||||
|
import System.IO (hPutStrLn, stderr)
|
||||||
|
import Text.Megaparsec ()
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy as BL
|
||||||
|
import Database.SQLite.Simple (close)
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
@@ -19,6 +28,10 @@ data TricuArgs
|
|||||||
= Repl
|
= Repl
|
||||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||||
| TDecode { file :: [FilePath] }
|
| TDecode { file :: [FilePath] }
|
||||||
|
| Compile { inputFile :: FilePath, outFile :: FilePath, names :: [String] }
|
||||||
|
| Export { hash :: String, exportNameOpt :: String, outFile :: FilePath, names :: [String] }
|
||||||
|
| Import { inFile :: FilePath }
|
||||||
|
| Serve { host :: String, port :: Int }
|
||||||
deriving (Show, Data, Typeable)
|
deriving (Show, Data, Typeable)
|
||||||
|
|
||||||
replMode :: TricuArgs
|
replMode :: TricuArgs
|
||||||
@@ -52,38 +65,187 @@ decodeMode = TDecode
|
|||||||
&= explicit
|
&= explicit
|
||||||
&= name "decode"
|
&= name "decode"
|
||||||
|
|
||||||
|
exportMode :: TricuArgs
|
||||||
|
exportMode = Export
|
||||||
|
{ hash = def &= help "Hash or stored term name(s) to export (comma-separated)."
|
||||||
|
&= name "h" &= typ "HASH_OR_NAME"
|
||||||
|
, exportNameOpt = def &= help "Export name (legacy; use -n NAME for full control)."
|
||||||
|
&= name "n" &= typ "NAME"
|
||||||
|
, outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
|
||||||
|
, names = def &= help "Export name(s) for the bundle manifest (comma-separated or repeated -n)."
|
||||||
|
&= typ "NAME"
|
||||||
|
}
|
||||||
|
&= 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"
|
||||||
|
|
||||||
|
compileMode :: TricuArgs
|
||||||
|
compileMode = Compile
|
||||||
|
{ inputFile = def &= help "Path to the tricu source file (.tri) to compile."
|
||||||
|
&= name "f" &= typ "FILE"
|
||||||
|
, outFile = def &= help "Output bundle file path (.tri.bundle)."
|
||||||
|
&= name "o" &= typ "FILE"
|
||||||
|
, names = def &= help "Definition name(s) to export as bundle roots (comma-separated or repeated -x). Defaults to 'main'."
|
||||||
|
&= name "x" &= typ "NAME"
|
||||||
|
}
|
||||||
|
&= help "Compile a tricu source file into a standalone Arborix portable bundle."
|
||||||
|
&= explicit
|
||||||
|
&= name "compile"
|
||||||
|
|
||||||
|
serveMode :: TricuArgs
|
||||||
|
serveMode = Serve
|
||||||
|
{ host = "127.0.0.1" &= help "Host to bind the server to." &= name "h" &= typ "HOST"
|
||||||
|
, port = 8787 &= help "HTTP port to listen on." &= name "p" &= typ "PORT"
|
||||||
|
}
|
||||||
|
&= help "Start a read-only HTTP server for exporting Arborix bundles."
|
||||||
|
&= explicit
|
||||||
|
&= name "server"
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
||||||
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode]
|
||||||
&= help "tricu: Exploring Tree Calculus"
|
&= help "tricu: Exploring Tree Calculus"
|
||||||
&= program "tricu"
|
&= program "tricu"
|
||||||
&= summary versionStr
|
&= summary versionStr
|
||||||
&= versionArg [explicit, name "version", summary versionStr]
|
&= versionArg [explicit, name "version", summary versionStr]
|
||||||
case args of
|
case cmdArgsParsed of
|
||||||
Repl -> do
|
Repl -> do
|
||||||
putStrLn "Welcome to the tricu REPL"
|
putStrLn "Welcome to the tricu REPL"
|
||||||
putStrLn "You can exit with `CTRL+D` or the `!exit` command.`"
|
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||||
repl Map.empty
|
repl
|
||||||
Evaluate { file = filePaths, form = form } -> do
|
Evaluate { file = filePaths, form = outputForm } -> do
|
||||||
result <- case filePaths of
|
maybeDbPath <- lookupEnv "TRICU_DB_PATH"
|
||||||
|
evalResult <- case filePaths of
|
||||||
[] -> do
|
[] -> do
|
||||||
t <- getContents
|
initialEnv <- case maybeDbPath of
|
||||||
pure $ runTricu t
|
Just _ -> do
|
||||||
(filePath:restFilePaths) -> do
|
conn <- initContentStore
|
||||||
initialEnv <- evaluateFile filePath
|
env <- loadEnvironment conn
|
||||||
|
close conn
|
||||||
|
return env
|
||||||
|
Nothing -> return Map.empty
|
||||||
|
input <- getContents
|
||||||
|
pure $ runTricuTEnv initialEnv input
|
||||||
|
(_:restFilePaths) -> do
|
||||||
|
initialEnv <- case maybeDbPath of
|
||||||
|
Just _ -> do
|
||||||
|
conn <- initContentStore
|
||||||
|
env <- loadEnvironment conn
|
||||||
|
close conn
|
||||||
|
return env
|
||||||
|
Nothing -> return Map.empty
|
||||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||||
pure $ mainResult finalEnv
|
pure $ mainResult finalEnv
|
||||||
let fRes = formatResult form result
|
let fRes = formatT outputForm evalResult
|
||||||
putStr fRes
|
putStr fRes
|
||||||
TDecode { file = filePaths } -> do
|
TDecode { file = filePaths } -> do
|
||||||
value <- case filePaths of
|
value <- case filePaths of
|
||||||
[] -> getContents
|
[] -> getContents
|
||||||
(filePath:_) -> readFile filePath
|
(filePath:_) -> readFile filePath
|
||||||
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
||||||
|
Export { hash = hashStr, exportNameOpt = legacyName, names = namesArg, outFile = outFilePath } -> do
|
||||||
|
conn <- initContentStore
|
||||||
|
let hashList = T.split (== ',') (T.pack hashStr)
|
||||||
|
hashes <- mapM (\h -> do
|
||||||
|
(resolvedHash, _) <- resolveExportTarget conn (T.unpack h)
|
||||||
|
return resolvedHash) hashList
|
||||||
|
-- Merge legacy -n and new -n (names); names wins when non-empty
|
||||||
|
let allNames = if null namesArg
|
||||||
|
then if null legacyName then [] else [legacyName]
|
||||||
|
else namesArg
|
||||||
|
let expNames = if null allNames
|
||||||
|
then defaultExportNames (length hashes)
|
||||||
|
else map T.pack allNames
|
||||||
|
let exports = zip expNames hashes
|
||||||
|
bundleData <- exportNamedBundle conn exports
|
||||||
|
BL.writeFile outFilePath (BL.fromStrict bundleData)
|
||||||
|
putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ outFilePath
|
||||||
|
close conn
|
||||||
|
Import { inFile = importFile } -> do
|
||||||
|
conn <- initContentStore
|
||||||
|
bundleData <- BL.readFile importFile
|
||||||
|
roots <- importBundle conn (BL.toStrict bundleData)
|
||||||
|
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||||
|
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
|
||||||
|
close conn
|
||||||
|
Compile { inputFile = compileInputFile, outFile = compileOutFile, names = namesArg } ->
|
||||||
|
let exportNames = if null namesArg then [] else map T.pack namesArg
|
||||||
|
in compileFile compileInputFile compileOutFile exportNames
|
||||||
|
Serve { host = hostStr, port = portNum } -> do
|
||||||
|
putStrLn $ "Starting Arborix bundle server on " ++ hostStr ++ ":" ++ show portNum
|
||||||
|
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
|
||||||
|
putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
|
||||||
|
putStrLn $ " Content-Type: application/vnd.arborix.bundle"
|
||||||
|
runServer hostStr portNum
|
||||||
|
|
||||||
runTricu :: String -> T
|
runTricu :: String -> String
|
||||||
runTricu input =
|
runTricu = formatT TreeCalculus . runTricuT
|
||||||
|
|
||||||
|
runTricuT :: String -> T
|
||||||
|
runTricuT input =
|
||||||
let asts = parseTricu input
|
let asts = parseTricu input
|
||||||
finalEnv = evalTricu Map.empty asts
|
finalEnv = evalTricu Map.empty asts
|
||||||
in result finalEnv
|
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)
|
||||||
|
|
||||||
|
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
|
||||||
|
|||||||
@@ -3,12 +3,12 @@ module Parser where
|
|||||||
import Lexer
|
import Lexer
|
||||||
import Research
|
import Research
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.List.NonEmpty (toList)
|
import Data.List.NonEmpty (toList)
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
data PState = PState
|
data PState = PState
|
||||||
@@ -20,9 +20,9 @@ type ParserM = StateT PState (Parsec Void [LToken])
|
|||||||
|
|
||||||
satisfyM :: (LToken -> Bool) -> ParserM LToken
|
satisfyM :: (LToken -> Bool) -> ParserM LToken
|
||||||
satisfyM f = do
|
satisfyM f = do
|
||||||
token <- lift (satisfy f)
|
tok <- lift (satisfy f)
|
||||||
modify' (updateDepth token)
|
modify' (updateDepth tok)
|
||||||
return token
|
return tok
|
||||||
|
|
||||||
updateDepth :: LToken -> PState -> PState
|
updateDepth :: LToken -> PState -> PState
|
||||||
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
|
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)"
|
else fail "Top-level exit in nested context (paren or bracket)"
|
||||||
|
|
||||||
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
|
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
|
||||||
parseProgram tokens =
|
parseProgram toks =
|
||||||
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
|
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks
|
||||||
|
|
||||||
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
||||||
parseSingleExpr tokens =
|
parseSingleExpr toks =
|
||||||
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
|
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks
|
||||||
|
|
||||||
finalizeDepth :: ParserM ()
|
finalizeDepth :: ParserM ()
|
||||||
finalizeDepth = do
|
finalizeDepth = do
|
||||||
@@ -130,7 +130,6 @@ parseFunctionM = do
|
|||||||
parseLambdaM :: ParserM TricuAST
|
parseLambdaM :: ParserM TricuAST
|
||||||
parseLambdaM = do
|
parseLambdaM = do
|
||||||
let ident = (\case LIdentifier _ -> True; _ -> False)
|
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||||
_ <- satisfyM (== LBackslash)
|
|
||||||
params <- some (satisfyM ident)
|
params <- some (satisfyM ident)
|
||||||
_ <- satisfyM (== LColon)
|
_ <- satisfyM (== LColon)
|
||||||
scnParserM
|
scnParserM
|
||||||
@@ -145,11 +144,11 @@ parseLambdaExpressionM = choice
|
|||||||
|
|
||||||
parseAtomicLambdaM :: ParserM TricuAST
|
parseAtomicLambdaM :: ParserM TricuAST
|
||||||
parseAtomicLambdaM = choice
|
parseAtomicLambdaM = choice
|
||||||
[ parseVarM
|
[ try parseLambdaM
|
||||||
|
, parseVarM
|
||||||
, parseTreeLeafM
|
, parseTreeLeafM
|
||||||
, parseLiteralM
|
, parseLiteralM
|
||||||
, parseListLiteralM
|
, parseListLiteralM
|
||||||
, try parseLambdaM
|
|
||||||
, between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
|
, between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
|
||||||
]
|
]
|
||||||
|
|
||||||
@@ -196,6 +195,7 @@ parseTreeTermM = do
|
|||||||
| TLeaf <- acc = TStem next
|
| TLeaf <- acc = TStem next
|
||||||
| TStem t <- acc = TFork t next
|
| TStem t <- acc = TFork t next
|
||||||
| TFork _ _ <- acc = TFork acc next
|
| TFork _ _ <- acc = TFork acc next
|
||||||
|
| otherwise = SApp acc next
|
||||||
|
|
||||||
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
|
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
|
||||||
parseTreeLeafOrParenthesizedM = choice
|
parseTreeLeafOrParenthesizedM = choice
|
||||||
@@ -205,7 +205,8 @@ parseTreeLeafOrParenthesizedM = choice
|
|||||||
|
|
||||||
parseAtomicM :: ParserM TricuAST
|
parseAtomicM :: ParserM TricuAST
|
||||||
parseAtomicM = choice
|
parseAtomicM = choice
|
||||||
[ parseVarM
|
[ try parseLambdaM
|
||||||
|
, parseVarM
|
||||||
, parseTreeLeafM
|
, parseTreeLeafM
|
||||||
, parseListLiteralM
|
, parseListLiteralM
|
||||||
, parseGroupedM
|
, parseGroupedM
|
||||||
@@ -248,42 +249,51 @@ parseGroupedItemM = do
|
|||||||
|
|
||||||
parseSingleItemM :: ParserM TricuAST
|
parseSingleItemM :: ParserM TricuAST
|
||||||
parseSingleItemM = do
|
parseSingleItemM = do
|
||||||
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||||
if | LIdentifier name <- token -> pure (SVar name)
|
if | LIdentifier name <- tok -> pure (SVar name Nothing)
|
||||||
| token == LKeywordT -> pure TLeaf
|
| tok == LKeywordT -> pure TLeaf
|
||||||
| otherwise -> fail "Unexpected token in list item"
|
| otherwise -> fail "Unexpected token in list item"
|
||||||
|
|
||||||
parseVarM :: ParserM TricuAST
|
parseVarM :: ParserM TricuAST
|
||||||
parseVarM = do
|
parseVarM = do
|
||||||
token <- satisfyM (\case
|
tok <- satisfyM (\case
|
||||||
LNamespace _ -> True
|
LNamespace _ -> True
|
||||||
LIdentifier _ -> True
|
LIdentifier _ -> True
|
||||||
|
LIdentifierWithHash _ _ -> True
|
||||||
_ -> False)
|
_ -> False)
|
||||||
case token of
|
|
||||||
|
case tok of
|
||||||
LNamespace ns -> do
|
LNamespace ns -> do
|
||||||
_ <- satisfyM (== LDot)
|
_ <- satisfyM (== LDot)
|
||||||
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
|
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
|
||||||
pure $ SVar (ns ++ "." ++ name)
|
pure $ SVar (ns ++ "." ++ name) Nothing
|
||||||
|
|
||||||
LIdentifier name
|
LIdentifier name
|
||||||
| name == "t" || name == "!result" ->
|
| name == "t" || name == "!result" ->
|
||||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||||
| otherwise -> 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"
|
_ -> fail "Unexpected token while parsing variable"
|
||||||
|
|
||||||
parseIntLiteralM :: ParserM TricuAST
|
parseIntLiteralM :: ParserM TricuAST
|
||||||
parseIntLiteralM = do
|
parseIntLiteralM = do
|
||||||
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
||||||
token <- satisfyM intL
|
tok <- satisfyM intL
|
||||||
if | LIntegerLiteral value <- token ->
|
if | LIntegerLiteral value <- tok ->
|
||||||
pure (SInt value)
|
pure (SInt (fromIntegral value))
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
fail "Unexpected token while parsing integer literal"
|
fail "Unexpected token while parsing integer literal"
|
||||||
|
|
||||||
parseStrLiteralM :: ParserM TricuAST
|
parseStrLiteralM :: ParserM TricuAST
|
||||||
parseStrLiteralM = do
|
parseStrLiteralM = do
|
||||||
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
||||||
token <- satisfyM strL
|
tok <- satisfyM strL
|
||||||
if | LStringLiteral value <- token ->
|
if | LStringLiteral value <- tok ->
|
||||||
pure (SStr value)
|
pure (SStr value)
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
fail "Unexpected token while parsing string literal"
|
fail "Unexpected token while parsing string literal"
|
||||||
@@ -299,8 +309,8 @@ handleParseError bundle =
|
|||||||
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
||||||
|
|
||||||
formatError :: ParseError [LToken] Void -> String
|
formatError :: ParseError [LToken] Void -> String
|
||||||
formatError (TrivialError offset unexpected expected) =
|
formatError (TrivialError offset msgUnexpected expected) =
|
||||||
let unexpectedMsg = case unexpected of
|
let unexpectedMsg = case msgUnexpected of
|
||||||
Just x -> "unexpected token " ++ show x
|
Just x -> "unexpected token " ++ show x
|
||||||
Nothing -> "unexpected end of input"
|
Nothing -> "unexpected end of input"
|
||||||
expectedMsg = if null expected
|
expectedMsg = if null expected
|
||||||
|
|||||||
700
src/REPL.hs
700
src/REPL.hs
@@ -1,31 +1,62 @@
|
|||||||
module REPL where
|
module REPL where
|
||||||
|
|
||||||
|
import ContentStore
|
||||||
import Eval
|
import Eval
|
||||||
import FileEval
|
import FileEval
|
||||||
import Lexer
|
import Lexer ()
|
||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
import Wire
|
||||||
|
|
||||||
import Control.Exception (SomeException, catch)
|
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.IO.Class (liftIO)
|
||||||
import Control.Monad.Catch (handle, MonadCatch)
|
import Control.Monad.Trans.Class ()
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||||
|
import Data.ByteString ()
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.List ( dropWhile
|
|
||||||
, dropWhileEnd
|
import qualified Data.ByteString.Lazy as BL
|
||||||
, isPrefixOf)
|
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 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.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.Map as Map
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.IO as T ()
|
||||||
|
|
||||||
repl :: Env -> IO ()
|
data REPLState = REPLState
|
||||||
repl env = runInputT settings (withInterrupt (loop env True))
|
{ 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
|
where
|
||||||
settings :: Settings IO
|
settings :: Settings IO
|
||||||
settings = Settings
|
settings = Settings
|
||||||
{ complete = completeWord Nothing " \t" completeCommands
|
{ complete = completeWord Nothing " \t" completeCommands
|
||||||
, historyFile = Just ".tricu_history"
|
, historyFile = Just "~/.local/state/tricu/history"
|
||||||
, autoAddHistory = True
|
, autoAddHistory = True
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -33,84 +64,605 @@ repl env = runInputT settings (withInterrupt (loop env True))
|
|||||||
completeCommands str = return $ map simpleCompletion $
|
completeCommands str = return $ map simpleCompletion $
|
||||||
filter (str `isPrefixOf`) commands
|
filter (str `isPrefixOf`) commands
|
||||||
where
|
where
|
||||||
commands = ["!exit", "!decode", "!definitions", "!import"]
|
commands = [ "!exit"
|
||||||
|
, "!output"
|
||||||
|
, "!import"
|
||||||
|
, "!clear"
|
||||||
|
, "!reset"
|
||||||
|
, "!help"
|
||||||
|
, "!definitions"
|
||||||
|
, "!watch"
|
||||||
|
, "!refresh"
|
||||||
|
, "!versions"
|
||||||
|
, "!select"
|
||||||
|
, "!tag"
|
||||||
|
, "!export"
|
||||||
|
, "!bundleimport"
|
||||||
|
]
|
||||||
|
|
||||||
loop :: Env -> Bool -> InputT IO ()
|
loop :: REPLState -> InputT IO ()
|
||||||
loop env decode = handle (interruptHandler env decode) $ do
|
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
|
||||||
minput <- getInputLine "tricu < "
|
minput <- getInputLine "tricu < "
|
||||||
case minput of
|
case minput of
|
||||||
Nothing -> outputStrLn "Exiting tricu"
|
Nothing -> return ()
|
||||||
Just s
|
Just s
|
||||||
| strip s == "" -> loop env decode
|
| strip s == "" -> loop state
|
||||||
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
||||||
| strip s == "!decode" -> do
|
| strip s == "!clear" -> do
|
||||||
outputStrLn $ "Decoding " ++ (if decode then "disabled" else "enabled")
|
liftIO $ putStr "\ESC[2J\ESC[H"
|
||||||
loop env (not decode)
|
loop state
|
||||||
| strip s == "!definitions" -> do
|
| strip s == "!reset" -> do
|
||||||
let defs = Map.keys $ Map.delete "!result" env
|
outputStrLn "Selected versions reset"
|
||||||
if null defs
|
loop state { replSelectedVersions = Map.empty }
|
||||||
then outputStrLn "No definitions discovered."
|
| strip s == "!help" -> do
|
||||||
else do
|
outputStrLn $ "tricu version " ++ showVersion version
|
||||||
outputStrLn "Available definitions:"
|
outputStrLn "Available commands:"
|
||||||
mapM_ outputStrLn defs
|
outputStrLn " !exit - Exit the REPL"
|
||||||
loop env decode
|
outputStrLn " !clear - Clear the screen"
|
||||||
| "!import" `isPrefixOf` strip s -> handleImport env decode
|
outputStrLn " !reset - Reset preferences for selected versions"
|
||||||
| take 2 s == "--" -> loop env decode
|
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
|
| otherwise -> do
|
||||||
newEnv <- liftIO $ processInput env s decode `catch` errorHandler env
|
evalResult <- liftIO $ catch
|
||||||
loop newEnv decode
|
(processInput state s)
|
||||||
|
(errorHandler state)
|
||||||
|
loop evalResult
|
||||||
|
|
||||||
handleImport :: Env -> Bool -> InputT IO ()
|
handleOutput :: REPLState -> InputT IO ()
|
||||||
handleImport env decode = do
|
handleOutput state = do
|
||||||
result <- runMaybeT $ do
|
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
|
||||||
let fileSettings = setComplete completeFilename defaultSettings
|
outputStrLn "Available output formats:"
|
||||||
path <- MaybeT $ runInputT fileSettings $
|
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
||||||
getInputLineWithInitial "File path to load < " ("", "")
|
(zip [1..] formats)
|
||||||
|
|
||||||
contents <- liftIO $ readFile (strip path)
|
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
|
||||||
|
|
||||||
if | Left err <- parseProgram (lexTricu contents) -> do
|
case evalResult of
|
||||||
lift $ outputStrLn $ "Parse error: " ++ handleParseError err
|
Nothing -> do
|
||||||
MaybeT $ return Nothing
|
outputStrLn "Invalid selection. Keeping current output format."
|
||||||
| Right ast <- parseProgram (lexTricu contents) -> do
|
loop state
|
||||||
ns <- MaybeT $ runInputT defaultSettings $
|
Just newForm -> do
|
||||||
getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "")
|
outputStrLn $ "Output format changed to: " ++ show newForm
|
||||||
|
loop state { replForm = newForm }
|
||||||
|
|
||||||
processedAst <- liftIO $ preprocessFile (strip path)
|
handleDefinitions :: REPLState -> InputT IO ()
|
||||||
let namespacedAst | strip ns == "!Local" = processedAst
|
handleDefinitions state = case replContentStore state of
|
||||||
| otherwise = nsDefinitions (strip ns) processedAst
|
Nothing -> do
|
||||||
loadedEnv = evalTricu env namespacedAst
|
liftIO $ printError "Content store not initialized"
|
||||||
return loadedEnv
|
loop state
|
||||||
|
Just conn -> do
|
||||||
|
terms <- liftIO $ ContentStore.listStoredTerms conn
|
||||||
|
|
||||||
|
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:"
|
||||||
|
|
||||||
if | Nothing <- result -> do
|
let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
|
||||||
outputStrLn "Import cancelled."
|
|
||||||
loop env decode
|
|
||||||
| Just loadedEnv <- result ->
|
|
||||||
loop (Map.delete "!result" loadedEnv) decode
|
|
||||||
|
|
||||||
interruptHandler :: Env -> Bool -> Interrupt -> InputT IO ()
|
forM_ terms $ \term -> do
|
||||||
interruptHandler env decode _ = do
|
let namesStr = T.unpack (termNames term)
|
||||||
outputStrLn "Interrupted with CTRL+C\n\
|
hash = termHash term
|
||||||
\You can use the !exit command or CTRL+D to exit"
|
padding = replicate (maxNameWidth - length namesStr) ' '
|
||||||
loop env decode
|
|
||||||
|
liftIO $ do
|
||||||
|
putStr " "
|
||||||
|
printVariable namesStr
|
||||||
|
putStr padding
|
||||||
|
putStr " [hash: "
|
||||||
|
displayColoredHash hash
|
||||||
|
putStrLn "]"
|
||||||
|
|
||||||
|
tags <- ContentStore.termToTags conn hash
|
||||||
|
unless (null tags) $ displayTags tags
|
||||||
|
|
||||||
processInput :: Env -> String -> Bool -> IO Env
|
loop state
|
||||||
processInput env input decode = do
|
|
||||||
let asts = parseTricu input
|
|
||||||
newEnv = evalTricu env asts
|
|
||||||
case Map.lookup "!result" newEnv of
|
|
||||||
Just r -> do
|
|
||||||
putStrLn $ "tricu > " ++
|
|
||||||
if decode
|
|
||||||
then decodeResult r
|
|
||||||
else show r
|
|
||||||
Nothing -> pure ()
|
|
||||||
return newEnv
|
|
||||||
|
|
||||||
errorHandler :: Env -> SomeException -> IO (Env)
|
handleImport :: REPLState -> InputT IO ()
|
||||||
errorHandler env e = do
|
handleImport state = do
|
||||||
putStrLn $ "Error: " ++ show e
|
let fset = setComplete completeFilename defaultSettings
|
||||||
return env
|
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
|
||||||
|
liftIO $ printError "Content store not initialized"
|
||||||
|
loop state
|
||||||
|
Just conn -> do
|
||||||
|
env <- liftIO $ evaluateFile cleanFilename
|
||||||
|
|
||||||
|
liftIO $ do
|
||||||
|
printSuccess $ "Importing file: " ++ cleanFilename
|
||||||
|
let defs = Map.toList $ Map.delete "!result" env
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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 :: String -> String
|
||||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
||||||
|
processWatchedFile filepath mconn selectedVersions outputForm = do
|
||||||
|
content <- readFile filepath
|
||||||
|
let asts = parseTricu content
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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 ""
|
||||||
|
|||||||
218
src/Research.hs
218
src/Research.hs
@@ -1,13 +1,18 @@
|
|||||||
module Research where
|
module Research where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Crypto.Hash (hash, SHA256, Digest)
|
||||||
|
import Data.ByteArray (convert)
|
||||||
|
import Data.ByteString.Base16 (decode, encode)
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Data.Map (Map)
|
import Data.Map ()
|
||||||
import Data.Text (Text, replace)
|
import Data.Text (Text, replace)
|
||||||
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
|
import Data.Word (Word8)
|
||||||
import System.Console.CmdArgs (Data, Typeable)
|
import System.Console.CmdArgs (Data, Typeable)
|
||||||
|
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
-- Tree Calculus Types
|
-- Tree Calculus Types
|
||||||
data T = Leaf | Stem T | Fork T T
|
data T = Leaf | Stem T | Fork T T
|
||||||
@@ -15,8 +20,8 @@ data T = Leaf | Stem T | Fork T T
|
|||||||
|
|
||||||
-- Abstract Syntax Tree for tricu
|
-- Abstract Syntax Tree for tricu
|
||||||
data TricuAST
|
data TricuAST
|
||||||
= SVar String
|
= SVar String (Maybe String)
|
||||||
| SInt Int
|
| SInt Integer
|
||||||
| SStr String
|
| SStr String
|
||||||
| SList [TricuAST]
|
| SList [TricuAST]
|
||||||
| SDef String [String] TricuAST
|
| SDef String [String] TricuAST
|
||||||
@@ -31,22 +36,22 @@ data TricuAST
|
|||||||
|
|
||||||
-- Lexer Tokens
|
-- Lexer Tokens
|
||||||
data LToken
|
data LToken
|
||||||
= LKeywordT
|
= LIdentifier String
|
||||||
| LIdentifier String
|
| LIdentifierWithHash String String
|
||||||
|
| LKeywordT
|
||||||
| LNamespace String
|
| LNamespace String
|
||||||
| LIntegerLiteral Int
|
| LImport String String
|
||||||
| LStringLiteral String
|
|
||||||
| LAssign
|
| LAssign
|
||||||
| LColon
|
| LColon
|
||||||
| LDot
|
| LDot
|
||||||
| LBackslash
|
|
||||||
| LOpenParen
|
| LOpenParen
|
||||||
| LCloseParen
|
| LCloseParen
|
||||||
| LOpenBracket
|
| LOpenBracket
|
||||||
| LCloseBracket
|
| LCloseBracket
|
||||||
|
| LStringLiteral String
|
||||||
|
| LIntegerLiteral Int
|
||||||
| LNewline
|
| LNewline
|
||||||
| LImport String String
|
deriving (Eq, Show, Ord)
|
||||||
deriving (Show, Eq, Ord)
|
|
||||||
|
|
||||||
-- Output formats
|
-- Output formats
|
||||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||||
@@ -55,15 +60,139 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
|||||||
-- Environment containing previously evaluated TC terms
|
-- Environment containing previously evaluated TC terms
|
||||||
type Env = Map.Map String T
|
type Env = Map.Map String T
|
||||||
|
|
||||||
-- Tree Calculus Reduction
|
-- 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"
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------------
|
||||||
|
-- ByteString / bytestream marshalling via existing Tree Calculus conventions
|
||||||
|
-- ---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
|
||||||
|
ofByte :: Word8 -> T
|
||||||
|
ofByte = ofNumber . fromIntegral
|
||||||
|
|
||||||
|
-- | Decode a Tree Calculus number as a single byte (Word8).
|
||||||
|
-- Rejects values outside the range 0..255.
|
||||||
|
toByte :: T -> Either String Word8
|
||||||
|
toByte t = case toNumber t of
|
||||||
|
Left err -> Left err
|
||||||
|
Right n
|
||||||
|
| n >= 0 && n <= 255 -> Right (fromIntegral n)
|
||||||
|
| otherwise -> Left ("Byte value out of range: " ++ show n)
|
||||||
|
|
||||||
|
-- | Encode a ByteString as a Tree Calculus list of Byte trees.
|
||||||
|
ofBytes :: BS.ByteString -> T
|
||||||
|
ofBytes = ofList . map ofByte . BS.unpack
|
||||||
|
|
||||||
|
-- | Decode a Tree Calculus list of Byte trees as a ByteString.
|
||||||
|
-- Rejects non-list trees and elements that are not valid byte values (0..255).
|
||||||
|
toBytes :: T -> Either String BS.ByteString
|
||||||
|
toBytes t = case toList t of
|
||||||
|
Left err -> Left err
|
||||||
|
Right bs -> BS.pack <$> mapM toByte bs
|
||||||
|
|
||||||
|
-- | Convert a canonical Arborix node payload (ByteString) to a Tree
|
||||||
|
-- representation (a list of Byte trees).
|
||||||
|
nodePayloadToTreeBytes :: BS.ByteString -> T
|
||||||
|
nodePayloadToTreeBytes = ofBytes
|
||||||
|
|
||||||
|
-- | Convert a Tree representation of a node payload back to ByteString.
|
||||||
|
treeBytesToNodePayload :: T -> Either String BS.ByteString
|
||||||
|
treeBytesToNodePayload = toBytes
|
||||||
|
|
||||||
|
-- | Convert a MerkleHash (hex-encoded) to a Tree of its 32 raw bytes.
|
||||||
|
hashToTreeBytes :: MerkleHash -> Either String T
|
||||||
|
hashToTreeBytes h = case decode (encodeUtf8 h) of
|
||||||
|
Left _ -> Left "Invalid hex MerkleHash"
|
||||||
|
Right raw
|
||||||
|
| BS.length raw == 32 -> Right (ofBytes raw)
|
||||||
|
| otherwise -> Left "Hash raw bytes must be 32 bytes"
|
||||||
|
|
||||||
|
-- | Convert a Tree of 32 Byte trees back to a MerkleHash (hex string).
|
||||||
|
treeBytesToHash :: T -> Either String MerkleHash
|
||||||
|
treeBytesToHash t = case toList t of
|
||||||
|
Left err -> Left err
|
||||||
|
Right bytes
|
||||||
|
| length bytes == 32 -> do
|
||||||
|
raw <- BS.pack <$> mapM toByte bytes
|
||||||
|
Right $ decodeUtf8 (encode raw)
|
||||||
|
| otherwise -> Left "Expected exactly 32 byte elements for hash"
|
||||||
|
|
||||||
|
-- | 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.
|
||||||
|
1. t t a b -> a
|
||||||
|
2. t (t a) b c -> a c (b c)
|
||||||
|
3a. t (t a b) c t -> a
|
||||||
|
3b. t (t a b) c (t u) -> b u
|
||||||
|
3c. t (t a b) c (t u v) -> c u v
|
||||||
|
-}
|
||||||
apply :: T -> T -> T
|
apply :: T -> T -> T
|
||||||
apply Leaf b = Stem b
|
apply (Fork Leaf a) _ = a
|
||||||
apply (Stem a) b = Fork a b
|
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
|
||||||
apply (Fork Leaf a) _ = a
|
apply (Fork (Fork _a _b) _c) Leaf = _a
|
||||||
apply (Fork (Stem a1) a2) b = apply (apply a1 b) (apply a2 b)
|
apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
|
||||||
apply (Fork (Fork a1 a2) a3) Leaf = a1
|
apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
|
||||||
apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u
|
-- Left associative `t`
|
||||||
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
|
apply Leaf b = Stem b
|
||||||
|
apply (Stem a) b = Fork a b
|
||||||
|
|
||||||
-- Booleans
|
-- Booleans
|
||||||
_false :: T
|
_false :: T
|
||||||
@@ -77,9 +206,9 @@ _not = Fork (Fork _true (Fork Leaf _false)) Leaf
|
|||||||
|
|
||||||
-- Marshalling
|
-- Marshalling
|
||||||
ofString :: String -> T
|
ofString :: String -> T
|
||||||
ofString str = ofList (map ofNumber (map fromEnum str))
|
ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
|
||||||
|
|
||||||
ofNumber :: Int -> T
|
ofNumber :: Integer -> T
|
||||||
ofNumber 0 = Leaf
|
ofNumber 0 = Leaf
|
||||||
ofNumber n =
|
ofNumber n =
|
||||||
Fork
|
Fork
|
||||||
@@ -87,10 +216,9 @@ ofNumber n =
|
|||||||
(ofNumber (n `div` 2))
|
(ofNumber (n `div` 2))
|
||||||
|
|
||||||
ofList :: [T] -> T
|
ofList :: [T] -> T
|
||||||
ofList [] = Leaf
|
ofList = foldr Fork Leaf
|
||||||
ofList (x:xs) = Fork x (ofList xs)
|
|
||||||
|
|
||||||
toNumber :: T -> Either String Int
|
toNumber :: T -> Either String Integer
|
||||||
toNumber Leaf = Right 0
|
toNumber Leaf = Right 0
|
||||||
toNumber (Fork Leaf rest) = case toNumber rest of
|
toNumber (Fork Leaf rest) = case toNumber rest of
|
||||||
Right n -> Right (2 * n)
|
Right n -> Right (2 * n)
|
||||||
@@ -102,8 +230,8 @@ toNumber _ = Left "Invalid Tree Calculus number"
|
|||||||
|
|
||||||
toString :: T -> Either String String
|
toString :: T -> Either String String
|
||||||
toString tc = case toList tc of
|
toString tc = case toList tc of
|
||||||
Right list -> traverse (fmap toEnum . toNumber) list
|
Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
|
||||||
Left err -> Left "Invalid Tree Calculus string"
|
Left _ -> Left "Invalid Tree Calculus string"
|
||||||
|
|
||||||
toList :: T -> Either String [T]
|
toList :: T -> Either String [T]
|
||||||
toList Leaf = Right []
|
toList Leaf = Right []
|
||||||
@@ -113,20 +241,20 @@ toList (Fork x rest) = case toList rest of
|
|||||||
toList _ = Left "Invalid Tree Calculus list"
|
toList _ = Left "Invalid Tree Calculus list"
|
||||||
|
|
||||||
-- Outputs
|
-- Outputs
|
||||||
formatResult :: EvaluatedForm -> T -> String
|
formatT :: EvaluatedForm -> T -> String
|
||||||
formatResult TreeCalculus = toSimpleT . show
|
formatT TreeCalculus = toSimpleT . show
|
||||||
formatResult FSL = show
|
formatT FSL = show
|
||||||
formatResult AST = show . toAST
|
formatT AST = show . toAST
|
||||||
formatResult Ternary = toTernaryString
|
formatT Ternary = toTernaryString
|
||||||
formatResult Ascii = toAscii
|
formatT Ascii = toAscii
|
||||||
formatResult Decode = decodeResult
|
formatT Decode = decodeResult
|
||||||
|
|
||||||
toSimpleT :: String -> String
|
toSimpleT :: String -> String
|
||||||
toSimpleT s = T.unpack
|
toSimpleT s = T.unpack
|
||||||
$ replace "Fork" "t"
|
$ replace "Fork" "t"
|
||||||
$ replace "Stem" "t"
|
$ replace "Stem" "t"
|
||||||
$ replace "Leaf" "t"
|
$ replace "Leaf" "t"
|
||||||
$ (T.pack s)
|
$ T.pack s
|
||||||
|
|
||||||
toTernaryString :: T -> String
|
toTernaryString :: T -> String
|
||||||
toTernaryString Leaf = "0"
|
toTernaryString Leaf = "0"
|
||||||
@@ -153,8 +281,18 @@ toAscii tree = go tree "" True
|
|||||||
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
||||||
|
|
||||||
decodeResult :: T -> String
|
decodeResult :: T -> String
|
||||||
decodeResult tc
|
decodeResult Leaf = "t"
|
||||||
| Right num <- toNumber tc = show num
|
decodeResult tc =
|
||||||
| Right str <- toString tc = "\"" ++ str ++ "\""
|
case (toString tc, toList tc, toNumber tc) of
|
||||||
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
(Right s, _, _) | all isCommonChar s -> "\"" ++ s ++ "\""
|
||||||
| otherwise = formatResult TreeCalculus tc
|
(_, _, Right n) -> show n
|
||||||
|
(_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
|
||||||
|
(_, Right [], _) -> "[]"
|
||||||
|
_ -> formatT TreeCalculus tc
|
||||||
|
where
|
||||||
|
isCommonChar c =
|
||||||
|
let n = fromEnum c
|
||||||
|
in (n >= 32 && n <= 126)
|
||||||
|
|| n == 9
|
||||||
|
|| n == 10
|
||||||
|
|| n == 13
|
||||||
|
|||||||
232
src/Server.hs
Normal file
232
src/Server.hs
Normal file
@@ -0,0 +1,232 @@
|
|||||||
|
module Server
|
||||||
|
( runServer
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
|
||||||
|
parseNameList, StoredTerm(..), termHash)
|
||||||
|
import Database.SQLite.Simple (close)
|
||||||
|
import Wire (exportNamedBundle)
|
||||||
|
|
||||||
|
import Control.Monad (when)
|
||||||
|
import Data.Maybe (catMaybes)
|
||||||
|
import Control.Monad (void)
|
||||||
|
|
||||||
|
import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
|
||||||
|
import Network.Wai
|
||||||
|
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
|
||||||
|
|
||||||
|
import Data.String (fromString)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||||
|
import Data.Char (isHexDigit, toLower)
|
||||||
|
import Data.ByteString.Char8 (unpack)
|
||||||
|
import Data.ByteString.Lazy (fromStrict)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
-- | Start an HTTP server that serves Arborix bundles from the
|
||||||
|
-- local content store.
|
||||||
|
--
|
||||||
|
-- This is a read-only export surface. Clients fetch bundle bytes
|
||||||
|
-- and independently inspect / verify / run them. The server does
|
||||||
|
-- not execute bundles.
|
||||||
|
--
|
||||||
|
-- Bind host defaults to @127.0.0.1@.
|
||||||
|
--
|
||||||
|
-- Endpoints
|
||||||
|
-- ---------
|
||||||
|
-- GET /health - 200 "ok"
|
||||||
|
-- GET /bundle/name/:name - export single term by name
|
||||||
|
-- GET /bundle/hash/:hash - export single term by hash
|
||||||
|
-- GET /bundle/roots?n=...&h=... - export multiple roots (n=name, h=hash)
|
||||||
|
-- GET /terms - plain-text listing (debug)
|
||||||
|
--
|
||||||
|
runServer :: String -> Int -> IO ()
|
||||||
|
runServer hostStr port =
|
||||||
|
runSettings settings app
|
||||||
|
where
|
||||||
|
settings = setPort port $ setHost (fromString hostStr) defaultSettings
|
||||||
|
|
||||||
|
-- | WAI application backed by the content store.
|
||||||
|
-- Uses the same database path as @eval@ mode (env var
|
||||||
|
-- @TRICU_DB_PATH@ or the default location).
|
||||||
|
app :: Application
|
||||||
|
app request respond = case (requestMethod request, pathInfo request) of
|
||||||
|
("GET", ["health"]) ->
|
||||||
|
respond $ healthResponse
|
||||||
|
|
||||||
|
("GET", ["bundle", "roots"]) ->
|
||||||
|
rootsHandler request respond
|
||||||
|
|
||||||
|
("GET", ["bundle", "name", nameText]) -> do
|
||||||
|
body <- nameHandler nameText
|
||||||
|
respond body
|
||||||
|
|
||||||
|
("GET", ["bundle", "hash", hashText]) -> do
|
||||||
|
body <- hashHandler hashText
|
||||||
|
respond body
|
||||||
|
|
||||||
|
("GET", ["terms"]) -> do
|
||||||
|
body <- termsResponse
|
||||||
|
respond body
|
||||||
|
|
||||||
|
("POST", _) ->
|
||||||
|
respond $ responseLBS status405 [] "Method not allowed"
|
||||||
|
|
||||||
|
("PUT", _) ->
|
||||||
|
respond $ responseLBS status405 [] "Method not allowed"
|
||||||
|
|
||||||
|
("DELETE", _) ->
|
||||||
|
respond $ responseLBS status405 [] "Method not allowed"
|
||||||
|
|
||||||
|
_ ->
|
||||||
|
respond $ responseLBS status404 [] "not found"
|
||||||
|
|
||||||
|
healthResponse :: Response
|
||||||
|
healthResponse = responseLBS status200 [] "ok"
|
||||||
|
|
||||||
|
-- | GET /bundle/roots?n=root&n=helper&h=abc123...
|
||||||
|
-- Resolve multiple named roots (by stored term name or raw hash)
|
||||||
|
-- and return a single bundle containing all of them.
|
||||||
|
--
|
||||||
|
-- Query parameters:
|
||||||
|
-- - @n=<name>@ — one or more stored term names (resolved via nameToTerm)
|
||||||
|
-- - @h=<hash>@ — one or more full Merkle hashes (validated as 16-64 hex chars)
|
||||||
|
--
|
||||||
|
-- The bundle manifest receives all resolved (name, hash) pairs as roots
|
||||||
|
-- and exports. The node section is the union of all reachable nodes.
|
||||||
|
rootsHandler :: Request -> (Response -> IO a) -> IO a
|
||||||
|
rootsHandler request respond = do
|
||||||
|
conn <- initContentStore
|
||||||
|
let qs = queryString request
|
||||||
|
nParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "n"]
|
||||||
|
hParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "h"]
|
||||||
|
-- Resolve 'n' params to (name, hash) pairs
|
||||||
|
nResults <- mapM (\nVal -> do
|
||||||
|
stored <- nameToTerm conn (decodeUtf8 nVal)
|
||||||
|
case stored of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just t -> return $ Just (decodeUtf8 nVal, termHash t)) nParams
|
||||||
|
let namedHashesFromN = catMaybes nResults
|
||||||
|
-- Validate 'h' params and build (name, hash) pairs
|
||||||
|
namedHashesFromH <- mapM (\hVal -> do
|
||||||
|
let raw = T.pack (dropWhile (=='#') (T.unpack (decodeUtf8 hVal)))
|
||||||
|
if T.all isHexDigit raw && T.length raw >= 16
|
||||||
|
then do
|
||||||
|
stored <- hashToTerm conn raw
|
||||||
|
let names = maybe "root" firstOrRoot (termNames <$> stored)
|
||||||
|
return $ Just (names, raw)
|
||||||
|
else return Nothing)
|
||||||
|
hParams
|
||||||
|
let allNamedHashes = namedHashesFromN ++ catMaybes namedHashesFromH
|
||||||
|
-- Require at least one root
|
||||||
|
when (null allNamedHashes) $ do
|
||||||
|
let resp = responseLBS status400 [] "400 Bad Request: at least one n= or h= parameter required"
|
||||||
|
close conn
|
||||||
|
void $ respond resp
|
||||||
|
-- Build and return the bundle
|
||||||
|
bundleData <- exportNamedBundle conn allNamedHashes
|
||||||
|
let firstHash = snd (head allNamedHashes)
|
||||||
|
cd = T.pack "attachment; filename=roots.bundle"
|
||||||
|
close conn
|
||||||
|
respond $ responseLBS status200
|
||||||
|
(bundleHeaders firstHash cd)
|
||||||
|
(fromStrict bundleData)
|
||||||
|
|
||||||
|
-- | GET /bundle/name/:name
|
||||||
|
-- Resolve a stored term name, export it as an Arborix bundle,
|
||||||
|
-- and return the raw bundle bytes.
|
||||||
|
--
|
||||||
|
-- Sets @Content-Type@ and @X-Arborix-Root-Hash@ headers.
|
||||||
|
-- Returns 404 when the name does not resolve to any stored term.
|
||||||
|
nameHandler :: Text -> IO Response
|
||||||
|
nameHandler nameText = do
|
||||||
|
conn <- initContentStore
|
||||||
|
stored <- nameToTerm conn nameText
|
||||||
|
case stored of
|
||||||
|
Nothing -> do
|
||||||
|
close conn
|
||||||
|
return $ textResponse status404 ("not found: " <> nameText)
|
||||||
|
Just term' -> do
|
||||||
|
let th = termHash term'
|
||||||
|
namedHashes = [(firstOrRoot (termNames term'), th)]
|
||||||
|
bundleData <- exportNamedBundle conn namedHashes
|
||||||
|
let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
|
||||||
|
close conn
|
||||||
|
return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
|
||||||
|
|
||||||
|
-- | GET /bundle/hash/:hash
|
||||||
|
-- Resolve a full Merkle hash and export the root as an Arborix
|
||||||
|
-- bundle.
|
||||||
|
--
|
||||||
|
-- - Malformed hash (non-hex or < 16 chars): 400
|
||||||
|
-- - Well-formed but absent: 404
|
||||||
|
-- - Present: 200 with bundle bytes
|
||||||
|
hashHandler :: Text -> IO Response
|
||||||
|
hashHandler hashText =
|
||||||
|
let raw = T.pack (dropWhile (== '#') (T.unpack hashText))
|
||||||
|
in if not (T.all isHexDigit raw) || T.length raw < 16
|
||||||
|
then return $ responseLBS status400 [] "400 Bad Request: invalid hash"
|
||||||
|
else do
|
||||||
|
conn <- initContentStore
|
||||||
|
stored <- hashToTerm conn raw
|
||||||
|
case stored of
|
||||||
|
Nothing -> do
|
||||||
|
close conn
|
||||||
|
return $ textResponse status404 ("not found: " <> hashText)
|
||||||
|
Just term' -> do
|
||||||
|
let th = termHash term'
|
||||||
|
namedHashes' = [(firstOrRoot (termNames term'), th)]
|
||||||
|
bundleData <- exportNamedBundle conn namedHashes'
|
||||||
|
close conn
|
||||||
|
return $ responseLBS status200
|
||||||
|
(bundleHeaders th "attachment; filename=hash.bundle")
|
||||||
|
(fromStrict bundleData)
|
||||||
|
|
||||||
|
-- | GET /terms
|
||||||
|
-- Plain-text listing of all stored terms (debugging only).
|
||||||
|
termsResponse :: IO Response
|
||||||
|
termsResponse = do
|
||||||
|
conn <- initContentStore
|
||||||
|
terms <- listStoredTerms conn
|
||||||
|
close conn
|
||||||
|
let lines' = [ names <> " " <> hash <> " " <> T.pack (show created)
|
||||||
|
| term <- terms
|
||||||
|
, let names = termNames term
|
||||||
|
, let hash = termHash term
|
||||||
|
, let created = termCreatedAt term ]
|
||||||
|
return $ responseLBS status200
|
||||||
|
[ (hContentType, encodeUtf8 "text/plain; charset=utf-8")
|
||||||
|
]
|
||||||
|
(fromStrict $ encodeUtf8 $ T.unlines lines')
|
||||||
|
|
||||||
|
textResponse :: Status -> Text -> Response
|
||||||
|
textResponse status body =
|
||||||
|
responseLBS status
|
||||||
|
[ (hContentType, encodeUtf8 "text/plain; charset=utf-8") ]
|
||||||
|
(fromStrict $ encodeUtf8 body)
|
||||||
|
|
||||||
|
bundleHeaders :: Text -> Text -> [Header]
|
||||||
|
bundleHeaders root cd =
|
||||||
|
[ (hContentType, encodeUtf8 "application/vnd.arborix.bundle")
|
||||||
|
, ("X-Arborix-Root-Hash", encodeUtf8 root)
|
||||||
|
, ("Content-Disposition", encodeUtf8 cd)
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | Pick the first stored name, falling back to "root" when names are empty.
|
||||||
|
firstOrRoot :: Text -> Text
|
||||||
|
firstOrRoot names =
|
||||||
|
case parseNameList names of
|
||||||
|
[] -> "root"
|
||||||
|
(x:_) -> x
|
||||||
|
|
||||||
|
-- | Sanitise a string to a safe filename prefix.
|
||||||
|
safeFileName :: String -> String
|
||||||
|
safeFileName = map go
|
||||||
|
where
|
||||||
|
go c
|
||||||
|
| c >= 'a' && c <= 'z' = c
|
||||||
|
| c >= 'A' && c <= 'Z' = c
|
||||||
|
| c >= '0' && c <= '9' = c
|
||||||
|
| c == '-' = c
|
||||||
|
| c == '_' = c
|
||||||
|
| otherwise = '_'
|
||||||
810
src/Wire.hs
Normal file
810
src/Wire.hs
Normal file
@@ -0,0 +1,810 @@
|
|||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
|
module Wire
|
||||||
|
( Bundle (..)
|
||||||
|
, BundleManifest (..)
|
||||||
|
, TreeSpec (..)
|
||||||
|
, NodeHashSpec (..)
|
||||||
|
, RuntimeSpec (..)
|
||||||
|
, BundleRoot (..)
|
||||||
|
, BundleExport (..)
|
||||||
|
, BundleMetadata (..)
|
||||||
|
, ClosureMode (..)
|
||||||
|
, encodeBundle
|
||||||
|
, decodeBundle
|
||||||
|
, verifyBundle
|
||||||
|
, collectReachableNodes
|
||||||
|
, exportBundle
|
||||||
|
, exportNamedBundle
|
||||||
|
, importBundle
|
||||||
|
, defaultExportNames
|
||||||
|
) 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)
|
||||||
|
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 [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00] -- "ARBORIX\0"
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
-- | 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" .!= "arborix.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.
|
||||||
|
decodeBundle :: ByteString -> Either String Bundle
|
||||||
|
decodeBundle bs
|
||||||
|
| BS.take (BS.length bundleMagic) bs == bundleMagic = decodePortableBundle 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 = "arborix.bundle.manifest.v1"
|
||||||
|
, manifestBundleType = "tree-calculus-executable-object"
|
||||||
|
, manifestTree = TreeSpec
|
||||||
|
{ treeCalculus = "tree-calculus.v1"
|
||||||
|
, treeNodeHash = NodeHashSpec
|
||||||
|
{ nodeHashAlgorithm = "sha256"
|
||||||
|
, nodeHashDomain = "arborix.merkle.node.v1"
|
||||||
|
}
|
||||||
|
, treeNodePayload = "arborix.merkle.payload.v1"
|
||||||
|
}
|
||||||
|
, manifestRuntime = RuntimeSpec
|
||||||
|
{ runtimeSemantics = "tree-calculus.v1"
|
||||||
|
, runtimeEvaluation = "normal-order"
|
||||||
|
, runtimeAbi = "arborix.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" .= ("arborix.merkle.payload.v1" :: Text)
|
||||||
|
]
|
||||||
|
]
|
||||||
|
, manifestMetadata = BundleMetadata
|
||||||
|
{ metadataPackage = Nothing
|
||||||
|
, metadataVersion = Nothing
|
||||||
|
, metadataDescription = Nothing
|
||||||
|
, metadataLicense = Nothing
|
||||||
|
, metadataCreatedBy = Just "arborix"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
where
|
||||||
|
mkRoot 0 h = BundleRoot h "default"
|
||||||
|
mkRoot _ h = BundleRoot h "root"
|
||||||
|
mkExport (name, h) = BundleExport
|
||||||
|
{ exportName = name
|
||||||
|
, exportRoot = h
|
||||||
|
, exportKind = "term"
|
||||||
|
, exportAbi = "arborix.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)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------------
|
||||||
|
-- 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 /= "arborix.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 /= "arborix.merkle.node.v1") $
|
||||||
|
Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
|
||||||
|
when (treeNodePayload treeSpec /= "arborix.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 /= "arborix.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
|
||||||
827
test/Spec.hs
827
test/Spec.hs
@@ -6,23 +6,30 @@ import Lexer
|
|||||||
import Parser
|
import Parser
|
||||||
import REPL
|
import REPL
|
||||||
import Research
|
import Research
|
||||||
|
import Wire
|
||||||
|
import ContentStore
|
||||||
|
|
||||||
import Control.Exception (evaluate, try, SomeException)
|
import Control.Exception (evaluate, try, SomeException)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Data.Bits (xor)
|
||||||
import Data.List (isInfixOf)
|
import Data.List (isInfixOf)
|
||||||
|
import Data.Text (Text, unpack)
|
||||||
|
import Data.Word (Word8)
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
import Test.Tasty.QuickCheck
|
|
||||||
import Text.Megaparsec (runParser)
|
import Text.Megaparsec (runParser)
|
||||||
|
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
import Database.SQLite.Simple (close, Connection)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain tests
|
main = defaultMain tests
|
||||||
|
|
||||||
runTricu :: String -> String
|
tricuTestString :: String -> String
|
||||||
runTricu s = show $ result (evalTricu Map.empty $ parseTricu s)
|
tricuTestString s = show $ result (evalTricu Map.empty $ parseTricu s)
|
||||||
|
|
||||||
tests :: TestTree
|
tests :: TestTree
|
||||||
tests = testGroup "Tricu Tests"
|
tests = testGroup "Tricu Tests"
|
||||||
@@ -34,6 +41,12 @@ tests = testGroup "Tricu Tests"
|
|||||||
, fileEval
|
, fileEval
|
||||||
, modules
|
, modules
|
||||||
, demos
|
, demos
|
||||||
|
, decoding
|
||||||
|
, elimLambdaSingle
|
||||||
|
, stressElimLambda
|
||||||
|
, byteMarshallingTests
|
||||||
|
, wireTests
|
||||||
|
, byteListUtilities
|
||||||
]
|
]
|
||||||
|
|
||||||
lexer :: TestTree
|
lexer :: TestTree
|
||||||
@@ -50,7 +63,22 @@ lexer = testGroup "Lexer Tests"
|
|||||||
|
|
||||||
, testCase "Lex escaped characters in strings" $ do
|
, testCase "Lex escaped characters in strings" $ do
|
||||||
let input = "\"hello\\nworld\""
|
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
|
runParser tricuLexer "" input @?= expect
|
||||||
|
|
||||||
, testCase "Lex mixed literals" $ do
|
, testCase "Lex mixed literals" $ do
|
||||||
@@ -86,8 +114,8 @@ parser = testGroup "Parser Tests"
|
|||||||
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
|
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
|
||||||
|
|
||||||
, testCase "Parse function definitions" $ do
|
, testCase "Parse function definitions" $ do
|
||||||
let input = "x = (\\a b c : a)"
|
let input = "x = (a b c : a)"
|
||||||
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a" Nothing))))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse nested Tree Calculus terms" $ do
|
, testCase "Parse nested Tree Calculus terms" $ do
|
||||||
@@ -106,8 +134,8 @@ parser = testGroup "Parser Tests"
|
|||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse function with applications" $ do
|
, testCase "Parse function with applications" $ do
|
||||||
let input = "f = (\\x : t x)"
|
let input = "f = (x : t x)"
|
||||||
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x" Nothing)))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse nested lists" $ do
|
, testCase "Parse nested lists" $ do
|
||||||
@@ -148,23 +176,23 @@ parser = testGroup "Parser Tests"
|
|||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse nested parentheses in function body" $ do
|
, testCase "Parse nested parentheses in function body" $ do
|
||||||
let input = "f = (\\x : t (t (t t)))"
|
let input = "f = (x : t (t (t t)))"
|
||||||
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse lambda abstractions" $ do
|
, testCase "Parse lambda abstractions" $ do
|
||||||
let input = "(\\a : a)"
|
let input = "(a : a)"
|
||||||
expect = (SLambda ["a"] (SVar "a"))
|
expect = (SLambda ["a"] (SVar "a" Nothing))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
||||||
let input = "x = (\\a b : a)"
|
let input = "x = (a b : a)"
|
||||||
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing)))
|
||||||
parseSingle input @?= expect
|
parseSingle input @?= expect
|
||||||
|
|
||||||
, testCase "Grouping T terms with parentheses in function application" $ do
|
, testCase "Grouping T terms with parentheses in function application" $ do
|
||||||
let input = "x = (\\a : a)\nx (t)"
|
let input = "x = (a : a)\nx (t)"
|
||||||
expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
|
expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf]
|
||||||
parseTricu input @?= expect
|
parseTricu input @?= expect
|
||||||
|
|
||||||
, testCase "Comments 1" $ do
|
, testCase "Comments 1" $ do
|
||||||
@@ -250,7 +278,7 @@ simpleEvaluation = testGroup "Evaluation Tests"
|
|||||||
, testCase "Immutable definitions" $ do
|
, testCase "Immutable definitions" $ do
|
||||||
let input = "x = t t\nx = t\nx"
|
let input = "x = t t\nx = t\nx"
|
||||||
env = evalTricu Map.empty (parseTricu input)
|
env = evalTricu Map.empty (parseTricu input)
|
||||||
result <- try (evaluate (runTricu input)) :: IO (Either SomeException String)
|
result <- try (evaluate (tricuTestString input)) :: IO (Either SomeException String)
|
||||||
case result of
|
case result of
|
||||||
Left _ -> return ()
|
Left _ -> return ()
|
||||||
Right _ -> assertFailure "Expected evaluation error"
|
Right _ -> assertFailure "Expected evaluation error"
|
||||||
@@ -258,7 +286,7 @@ simpleEvaluation = testGroup "Evaluation Tests"
|
|||||||
|
|
||||||
, testCase "Apply identity to Boolean Not" $ do
|
, testCase "Apply identity to Boolean Not" $ do
|
||||||
let not = "(t (t (t t) (t t t)) t)"
|
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)
|
env = evalTricu Map.empty (parseTricu input)
|
||||||
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
||||||
]
|
]
|
||||||
@@ -266,81 +294,85 @@ simpleEvaluation = testGroup "Evaluation Tests"
|
|||||||
lambdas :: TestTree
|
lambdas :: TestTree
|
||||||
lambdas = testGroup "Lambda Evaluation Tests"
|
lambdas = testGroup "Lambda Evaluation Tests"
|
||||||
[ testCase "Lambda Identity Function" $ do
|
[ testCase "Lambda Identity Function" $ do
|
||||||
let input = "id = (\\x : x)\nid t"
|
let input = "id = (x : x)\nid t"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda Constant Function (K combinator)" $ do
|
, testCase "Lambda Constant Function (K combinator)" $ do
|
||||||
let input = "k = (\\x y : x)\nk t (t t)"
|
let input = "k = (x y : x)\nk t (t t)"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda Application with Variable" $ do
|
, testCase "Lambda Application with Variable" $ do
|
||||||
let input = "id = (\\x : x)\nval = t t\nid val"
|
let input = "id = (x : x)\nval = t t\nid val"
|
||||||
runTricu input @?= "Stem Leaf"
|
tricuTestString input @?= "Stem Leaf"
|
||||||
|
|
||||||
, testCase "Lambda Application with Multiple Arguments" $ do
|
, 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)"
|
let input = "apply = (f x y : f x y)\nk = (a b : a)\napply k t (t t)"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Nested Lambda Application" $ do
|
, testCase "Nested Lambda Application" $ do
|
||||||
let input = "apply = (\\f x y : f x y)\nid = (\\x : x)\napply (\\f x : f x) id t"
|
let input = "apply = (f x y : f x y)\nid = (x : x)\napply (f x : f x) id t"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda with a complex body" $ do
|
, testCase "Lambda with a complex body" $ do
|
||||||
let input = "f = (\\x : t (t x))\nf t"
|
let input = "f = (x : t (t x))\nf t"
|
||||||
runTricu input @?= "Stem (Stem Leaf)"
|
tricuTestString input @?= "Stem (Stem Leaf)"
|
||||||
|
|
||||||
, testCase "Lambda returning a function" $ do
|
, testCase "Lambda returning a function" $ do
|
||||||
let input = "f = (\\x : (\\y : x))\ng = f t\ng (t t)"
|
let input = "f = (x : (y : x))\ng = f t\ng (t t)"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda with Shadowing" $ do
|
, testCase "Lambda with Shadowing" $ do
|
||||||
let input = "f = (\\x : (\\x : x))\nf t (t t)"
|
let input = "f = (x : (x : x))\nf t (t t)"
|
||||||
runTricu input @?= "Stem Leaf"
|
tricuTestString input @?= "Stem Leaf"
|
||||||
|
|
||||||
, testCase "Lambda returning another lambda" $ do
|
, testCase "Lambda returning another lambda" $ do
|
||||||
let input = "k = (\\x : (\\y : x))\nk_app = k t\nk_app (t t)"
|
let input = "k = (x : (y : x))\nk_app = k t\nk_app (t t)"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda with free variables" $ do
|
, testCase "Lambda with free variables" $ do
|
||||||
let input = "y = t t\nf = (\\x : y)\nf t"
|
let input = "y = t t\nf = (x : y)\nf t"
|
||||||
runTricu input @?= "Stem Leaf"
|
tricuTestString input @?= "Stem Leaf"
|
||||||
|
|
||||||
, testCase "SKI Composition" $ do
|
, 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)"
|
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)"
|
tricuTestString input @?= "Stem (Stem Leaf)"
|
||||||
|
|
||||||
, testCase "Lambda with multiple parameters and application" $ do
|
, 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)"
|
let input = "f = (a b c : t a b c)\nf t (t t) (t t t)"
|
||||||
runTricu input @?= "Stem Leaf"
|
tricuTestString input @?= "Stem Leaf"
|
||||||
|
|
||||||
, testCase "Lambda with nested application in the body" $ do
|
, testCase "Lambda with nested application in the body" $ do
|
||||||
let input = "f = (\\x : t (t (t x)))\nf t"
|
let input = "f = (x : t (t (t x)))\nf t"
|
||||||
runTricu input @?= "Stem (Stem (Stem Leaf))"
|
tricuTestString input @?= "Stem (Stem (Stem Leaf))"
|
||||||
|
|
||||||
, testCase "Lambda returning a function and applying it" $ do
|
, testCase "Lambda returning a function and applying it" $ do
|
||||||
let input = "f = (\\x : (\\y : t x y))\ng = f t\ng (t t)"
|
let input = "f = (x : (y : t x y))\ng = f t\ng (t t)"
|
||||||
runTricu input @?= "Fork Leaf (Stem Leaf)"
|
tricuTestString input @?= "Fork Leaf (Stem Leaf)"
|
||||||
|
|
||||||
, testCase "Lambda applying a variable" $ do
|
, testCase "Lambda applying a variable" $ do
|
||||||
let input = "id = (\\x : x)\na = t t\nid a"
|
let input = "id = (x : x)\na = t t\nid a"
|
||||||
runTricu input @?= "Stem Leaf"
|
tricuTestString input @?= "Stem Leaf"
|
||||||
|
|
||||||
, testCase "Nested lambda abstractions in the same expression" $ do
|
, testCase "Nested lambda abstractions in the same expression" $ do
|
||||||
let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
|
let input = "f = (x : (y : x y))\ng = (z : z)\nf g t"
|
||||||
runTricu input @?= "Leaf"
|
tricuTestString input @?= "Leaf"
|
||||||
|
|
||||||
, testCase "Lambda with a string literal" $ do
|
, testCase "Lambda applied to string literal" $ do
|
||||||
let input = "f = (\\x : x)\nf \"hello\""
|
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))))"
|
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 with an integer literal" $ do
|
, testCase "Lambda applied to integer literal" $ do
|
||||||
let input = "f = (\\x : x)\nf 42"
|
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)))))"
|
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
|
||||||
|
|
||||||
, testCase "Lambda with a list literal" $ do
|
, testCase "Lambda applied to list literal" $ do
|
||||||
let input = "f = (\\x : x)\nf [t (t t)]"
|
let input = "f = (x : x)\nf [t (t t)]"
|
||||||
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
|
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
|
||||||
|
|
||||||
|
, testCase "Lambda containing list literal" $ do
|
||||||
|
let input = "(a : [(a)]) 1"
|
||||||
|
tricuTestString input @?= "Fork (Fork (Stem Leaf) Leaf) Leaf"
|
||||||
]
|
]
|
||||||
|
|
||||||
providedLibraries :: TestTree
|
providedLibraries :: TestTree
|
||||||
@@ -414,7 +446,7 @@ providedLibraries = testGroup "Library Tests"
|
|||||||
|
|
||||||
, testCase "List map" $ do
|
, testCase "List map" $ do
|
||||||
library <- evaluateFile "./lib/list.tri"
|
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)
|
env = evalTricu library (parseTricu input)
|
||||||
result env @?= Fork Leaf Leaf
|
result env @?= Fork Leaf Leaf
|
||||||
|
|
||||||
@@ -513,8 +545,683 @@ demos = testGroup "Test provided demo functionality"
|
|||||||
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
|
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
|
||||||
, testCase "Determining the size of functions" $ do
|
, testCase "Determining the size of functions" $ do
|
||||||
res <- liftIO $ evaluateFileResult "./demos/size.tri"
|
res <- liftIO $ evaluateFileResult "./demos/size.tri"
|
||||||
decodeResult res @?= "454"
|
decodeResult res @?= "321"
|
||||||
, testCase "Level Order Traversal demo" $ do
|
, testCase "Level Order Traversal demo" $ do
|
||||||
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
|
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
|
||||||
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
|
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
|
||||||
]
|
]
|
||||||
|
|
||||||
|
decoding :: TestTree
|
||||||
|
decoding = testGroup "Decoding Tests"
|
||||||
|
[ testCase "Decode Leaf" $ do
|
||||||
|
decodeResult Leaf @?= "t"
|
||||||
|
|
||||||
|
, testCase "Decode list of non-ASCII numbers" $ do
|
||||||
|
let input = ofList [ofNumber 1, ofNumber 14, ofNumber 6]
|
||||||
|
decodeResult input @?= "[1, 14, 6]"
|
||||||
|
|
||||||
|
, testCase "Decode list of ASCII numbers as a string" $ do
|
||||||
|
let input = ofList [ofNumber 97, ofNumber 98, ofNumber 99]
|
||||||
|
decodeResult input @?= "\"abc\""
|
||||||
|
|
||||||
|
, testCase "Decode small number" $ do
|
||||||
|
decodeResult (ofNumber 42) @?= "42"
|
||||||
|
|
||||||
|
, testCase "Decode large number" $ do
|
||||||
|
decodeResult (ofNumber 9999) @?= "9999"
|
||||||
|
|
||||||
|
, testCase "Decode string in list" $ do
|
||||||
|
let input = ofList [ofString "hello", ofString "world"]
|
||||||
|
decodeResult input @?= "[\"hello\", \"world\"]"
|
||||||
|
|
||||||
|
, testCase "Decode mixed list with strings" $ do
|
||||||
|
let input = ofList [ofString "hello", ofNumber 42, ofString "world"]
|
||||||
|
decodeResult input @?= "[\"hello\", 42, \"world\"]"
|
||||||
|
|
||||||
|
, testCase "Decode nested lists with strings" $ do
|
||||||
|
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
|
||||||
|
|
||||||
|
-- --------------------------------------------------------------------------
|
||||||
|
-- Byte marshalling tests
|
||||||
|
-- --------------------------------------------------------------------------
|
||||||
|
|
||||||
|
byteMarshallingTests :: TestTree
|
||||||
|
byteMarshallingTests = testGroup "Byte Marshalling Tests"
|
||||||
|
[ testCase "ofByte / toByte round-trip: 0" $ do
|
||||||
|
let w8 = (0 :: Word8)
|
||||||
|
toByte (ofByte w8) @?= Right w8
|
||||||
|
|
||||||
|
, testCase "ofByte / toByte round-trip: 1" $ do
|
||||||
|
let w8 = (1 :: Word8)
|
||||||
|
toByte (ofByte w8) @?= Right w8
|
||||||
|
|
||||||
|
, testCase "ofByte / toByte round-trip: 127" $ do
|
||||||
|
let w8 = (127 :: Word8)
|
||||||
|
toByte (ofByte w8) @?= Right w8
|
||||||
|
|
||||||
|
, testCase "ofByte / toByte round-trip: 128" $ do
|
||||||
|
let w8 = (128 :: Word8)
|
||||||
|
toByte (ofByte w8) @?= Right w8
|
||||||
|
|
||||||
|
, testCase "ofByte / toByte round-trip: 255" $ do
|
||||||
|
let w8 = (255 :: Word8)
|
||||||
|
toByte (ofByte w8) @?= Right w8
|
||||||
|
|
||||||
|
, testCase "toByte rejects value > 255" $ do
|
||||||
|
-- ofNumber 256 = Fork Leaf (Fork Leaf Leaf) — value 256
|
||||||
|
toByte (ofNumber 256) @?= Left "Byte value out of range: 256"
|
||||||
|
|
||||||
|
, testCase "toByte accepts Leaf" $ do
|
||||||
|
toByte (Leaf) @?= Right 0
|
||||||
|
|
||||||
|
, testCase "toByte rejects non-number tree" $ do
|
||||||
|
toByte (Stem Leaf) @?= Left "Invalid Tree Calculus number"
|
||||||
|
toByte (Stem (Stem Leaf)) @?= Left "Invalid Tree Calculus number"
|
||||||
|
|
||||||
|
, testCase "ofBytes / toBytes round-trip: empty ByteString" $ do
|
||||||
|
toBytes (ofBytes BS.empty) @?= Right BS.empty
|
||||||
|
|
||||||
|
, testCase "ofBytes / toBytes round-trip: [0x00]" $ do
|
||||||
|
toBytes (ofBytes (BS.pack [0x00])) @?= Right (BS.pack [0x00])
|
||||||
|
|
||||||
|
, testCase "ofBytes / toBytes round-trip: [0xff]" $ do
|
||||||
|
toBytes (ofBytes (BS.pack [0xff])) @?= Right (BS.pack [0xff])
|
||||||
|
|
||||||
|
, testCase "ofBytes / toBytes round-trip: mixed bytes" $ do
|
||||||
|
let bytes = BS.pack [0x00, 0x01, 0x7f, 0x80, 0xff, 0x41, 0x42, 0x43]
|
||||||
|
toBytes (ofBytes bytes) @?= Right bytes
|
||||||
|
|
||||||
|
, testCase "toBytes rejects non-list tree" $ do
|
||||||
|
-- Leaf is a valid list (empty), so this won't work.
|
||||||
|
-- Stem Leaf is not a list.
|
||||||
|
toBytes (Stem Leaf) @?= Left "Invalid Tree Calculus list"
|
||||||
|
|
||||||
|
, testCase "toBytes rejects list containing invalid byte (>255)" $ do
|
||||||
|
-- [ofNumber 256, ofNumber 1] — first element is > 255
|
||||||
|
let badList = ofList [ofNumber 256, ofNumber 1]
|
||||||
|
toBytes badList @?= Left "Byte value out of range: 256"
|
||||||
|
|
||||||
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Leaf payload" $ do
|
||||||
|
-- Leaf payload is 0x00 (1 byte)
|
||||||
|
let payload = BS.pack [0x00]
|
||||||
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
||||||
|
|
||||||
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Stem payload" $ do
|
||||||
|
-- Stem payload: 0x01 || 32-byte hash = 33 bytes
|
||||||
|
let payload = BS.pack (0x01 : replicate 32 0x42)
|
||||||
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
||||||
|
|
||||||
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Fork payload" $ do
|
||||||
|
-- Fork payload: 0x02 || 32-byte hash || 32-byte hash = 65 bytes
|
||||||
|
let payload = BS.pack (0x02 : replicate 64 0x42)
|
||||||
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
||||||
|
|
||||||
|
, testCase "hashToTreeBytes / treeBytesToHash round-trip" $ do
|
||||||
|
-- Use a known 32-byte hash (SHA256 of "")
|
||||||
|
let hashStr :: MerkleHash
|
||||||
|
hashStr = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
||||||
|
case hashToTreeBytes hashStr of
|
||||||
|
Left err -> assertFailure $ "hashToTreeBytes failed: " ++ err
|
||||||
|
Right tree -> treeBytesToHash tree @?= Right hashStr
|
||||||
|
|
||||||
|
, testCase "hashToTreeBytes rejects invalid hex hash" $ do
|
||||||
|
hashToTreeBytes "not-a-hash" @?= Left "Invalid hex MerkleHash"
|
||||||
|
|
||||||
|
, testCase "hashToTreeBytes rejects non-32-byte hash" $ do
|
||||||
|
-- "00" decodes to 1 byte, not 32
|
||||||
|
hashToTreeBytes "00" @?= Left "Hash raw bytes must be 32 bytes"
|
||||||
|
|
||||||
|
, testCase "treeBytesToHash rejects wrong byte count" $ do
|
||||||
|
-- Only 16 bytes, not 32
|
||||||
|
let t16 = ofBytes (BS.pack [0x41 | _ <- [1..16]])
|
||||||
|
treeBytesToHash t16 @?= Left "Expected exactly 32 byte elements for hash"
|
||||||
|
]
|
||||||
|
|
||||||
|
-- --------------------------------------------------------------------------
|
||||||
|
-- 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 [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00]
|
||||||
|
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 @?= "arborix.bundle.manifest.v1"
|
||||||
|
manifestBundleType manifest @?= "tree-calculus-executable-object"
|
||||||
|
manifestClosure manifest @?= ClosureComplete
|
||||||
|
treeCalculus tree @?= "tree-calculus.v1"
|
||||||
|
treeNodePayload tree @?= "arborix.merkle.payload.v1"
|
||||||
|
nodeHashAlgorithm hashSpec @?= "sha256"
|
||||||
|
nodeHashDomain hashSpec @?= "arborix.merkle.node.v1"
|
||||||
|
runtimeSemantics runtime @?= "tree-calculus.v1"
|
||||||
|
runtimeAbi runtime @?= "arborix.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 @?= "arborix.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
|
||||||
|
]
|
||||||
|
|
||||||
|
-- --------------------------------------------------------------------------
|
||||||
|
-- Byte-list utility tests
|
||||||
|
-- Expected values built with canonical Haskell-side T constructors.
|
||||||
|
-- --------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Helpers for byte-list test expectations.
|
||||||
|
trueT :: T
|
||||||
|
trueT = Stem Leaf
|
||||||
|
|
||||||
|
falseT :: T
|
||||||
|
falseT = Leaf
|
||||||
|
|
||||||
|
nothingT :: T
|
||||||
|
nothingT = Leaf
|
||||||
|
|
||||||
|
justT :: T -> T
|
||||||
|
justT = Stem
|
||||||
|
|
||||||
|
pairT :: T -> T -> T
|
||||||
|
pairT = Fork
|
||||||
|
|
||||||
|
byteT :: Integer -> T
|
||||||
|
byteT = ofNumber
|
||||||
|
|
||||||
|
bytesT :: [Integer] -> T
|
||||||
|
bytesT = ofList . fmap byteT
|
||||||
|
|
||||||
|
byteListUtilities :: TestTree
|
||||||
|
byteListUtilities = testGroup "Byte List Utility Tests"
|
||||||
|
[ testCase "isNil: empty list is nil" $ do
|
||||||
|
let input = "bytesIsNil []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= trueT
|
||||||
|
|
||||||
|
, testCase "isNil: non-empty list is not nil" $ do
|
||||||
|
let input = "bytesIsNil [(1)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
|
||||||
|
, testCase "head: empty list is nothing" $ do
|
||||||
|
let input = "bytesHead []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= nothingT
|
||||||
|
|
||||||
|
, testCase "head: non-empty list returns first element" $ do
|
||||||
|
let input = "bytesHead [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= justT (byteT 1)
|
||||||
|
|
||||||
|
, testCase "tail: empty list is nothing" $ do
|
||||||
|
let input = "bytesTail []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= nothingT
|
||||||
|
|
||||||
|
, testCase "tail: non-empty list returns rest" $ do
|
||||||
|
let input = "bytesTail [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= justT (bytesT [2])
|
||||||
|
|
||||||
|
, testCase "length: empty list is zero" $ do
|
||||||
|
let input = "bytesLength []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= ofNumber 0
|
||||||
|
|
||||||
|
, testCase "length: single element list is one" $ do
|
||||||
|
let input = "bytesLength [(1)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= ofNumber 1
|
||||||
|
|
||||||
|
, testCase "length: three element list is three" $ do
|
||||||
|
let input = "bytesLength [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= ofNumber 3
|
||||||
|
|
||||||
|
, testCase "append: empty ++ [1,2] = [1,2]" $ do
|
||||||
|
let input = "bytesAppend [] [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2]
|
||||||
|
|
||||||
|
, testCase "append: [1,2] ++ [3] = [1,2,3]" $ do
|
||||||
|
let input = "bytesAppend [(1) (2)] [(3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2,3]
|
||||||
|
|
||||||
|
, testCase "append: [1,2] ++ empty = [1,2]" $ do
|
||||||
|
let input = "bytesAppend [(1) (2)] []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2]
|
||||||
|
|
||||||
|
, testCase "take: take 0 any list = empty" $ do
|
||||||
|
let input = "bytesTake 0 [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT []
|
||||||
|
|
||||||
|
, testCase "take: take 2 [1,2,3] = [1,2]" $ do
|
||||||
|
let input = "bytesTake 2 [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2]
|
||||||
|
|
||||||
|
, testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do
|
||||||
|
let input = "bytesTake 5 [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2]
|
||||||
|
|
||||||
|
, testCase "drop: drop 0 any list = list" $ do
|
||||||
|
let input = "bytesDrop 0 [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [1,2,3]
|
||||||
|
|
||||||
|
, testCase "drop: drop 2 [1,2,3] = [3]" $ do
|
||||||
|
let input = "bytesDrop 2 [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT [3]
|
||||||
|
|
||||||
|
, testCase "drop: drop 5 [1,2] = empty (overlong)" $ do
|
||||||
|
let input = "bytesDrop 5 [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= bytesT []
|
||||||
|
|
||||||
|
, testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do
|
||||||
|
let input = "bytesSplitAt 0 [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= pairT (bytesT []) (bytesT [1,2])
|
||||||
|
|
||||||
|
, testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
|
||||||
|
let input = "bytesSplitAt 2 [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= pairT (bytesT [1,2]) (bytesT [3])
|
||||||
|
|
||||||
|
, testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do
|
||||||
|
let input = "bytesSplitAt 5 [(1) (2)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= pairT (bytesT [1,2]) (bytesT [])
|
||||||
|
|
||||||
|
, testCase "byteEq: equal bytes are equal" $ do
|
||||||
|
let input = "byteEq 1 1"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= trueT
|
||||||
|
|
||||||
|
, testCase "byteEq: unequal bytes are not equal" $ do
|
||||||
|
let input = "byteEq 1 2"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
|
||||||
|
, testCase "bytesEq: empty == empty" $ do
|
||||||
|
let input = "bytesEq [] []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= trueT
|
||||||
|
|
||||||
|
, testCase "bytesEq: empty != [1]" $ do
|
||||||
|
let input = "bytesEq [] [(1)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
|
||||||
|
, testCase "bytesEq: [1] != empty" $ do
|
||||||
|
let input = "bytesEq [(1)] []"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
|
||||||
|
, testCase "bytesEq: equal lists are equal" $ do
|
||||||
|
let input = "bytesEq [(1) (2) (3)] [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= trueT
|
||||||
|
|
||||||
|
, testCase "bytesEq: different last element" $ do
|
||||||
|
let input = "bytesEq [(1) (2) (3)] [(1) (2) (4)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
|
||||||
|
, testCase "bytesEq: different lengths" $ do
|
||||||
|
let input = "bytesEq [(1) (2)] [(1) (2) (3)]"
|
||||||
|
library <- evaluateFile "./lib/bytes.tri"
|
||||||
|
let env = evalTricu library (parseTricu input)
|
||||||
|
result env @?= falseT
|
||||||
|
]
|
||||||
|
|||||||
@@ -1,9 +1,9 @@
|
|||||||
-- This is a tricu comment!
|
-- This is a tricu comment!
|
||||||
-- t (t t) (t (t t t))
|
-- t (t t) (t (t t t))
|
||||||
-- t (t t t) (t t)
|
-- t (t t t) (t t)
|
||||||
-- x = (\a : a)
|
-- x = (a : a)
|
||||||
main = t (t t) t -- Fork (Stem Leaf) Leaf
|
main = t (t t) t -- Fork (Stem Leaf) Leaf
|
||||||
-- t t
|
-- t t
|
||||||
-- x
|
-- x
|
||||||
-- x = (\a : a)
|
-- x = (a : a)
|
||||||
-- t
|
-- t
|
||||||
|
|||||||
BIN
test/fixtures/equalQ.tri.bundle
vendored
Normal file
BIN
test/fixtures/equalQ.tri.bundle
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/false.tri.bundle
vendored
Normal file
BIN
test/fixtures/false.tri.bundle
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/id.tri.bundle
vendored
Normal file
BIN
test/fixtures/id.tri.bundle
vendored
Normal file
Binary file not shown.
2
test/fixtures/notQ.tri
vendored
Normal file
2
test/fixtures/notQ.tri
vendored
Normal file
@@ -0,0 +1,2 @@
|
|||||||
|
\!import "base.tri" _
|
||||||
|
main = not?
|
||||||
BIN
test/fixtures/notQ.tri.bundle
vendored
Normal file
BIN
test/fixtures/notQ.tri.bundle
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/true.tri.bundle
vendored
Normal file
BIN
test/fixtures/true.tri.bundle
vendored
Normal file
Binary file not shown.
@@ -1 +1 @@
|
|||||||
main = (\x : x) t
|
main = (x : x) t
|
||||||
|
|||||||
@@ -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!")]
|
main = equal? x [("Successfully concatenated two strings!")]
|
||||||
|
|||||||
@@ -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
|
triage
|
||||||
1
|
1
|
||||||
t
|
t
|
||||||
(triage
|
(triage
|
||||||
(t (t t))
|
(t (t t))
|
||||||
(\_ tail : t t (self tail))
|
(_ tail : t t (self tail))
|
||||||
t))
|
t))
|
||||||
|
|
||||||
size = (\x :
|
size = (x :
|
||||||
(y (\self x :
|
(y (self x :
|
||||||
compose succ
|
compose succ
|
||||||
(triage
|
(triage
|
||||||
(\x : x)
|
(x : x)
|
||||||
self
|
self
|
||||||
(\x y : compose (self x) (self y))
|
(x y : compose (self x) (self y))
|
||||||
x)) x 0))
|
x)) x 0))
|
||||||
|
|
||||||
size size
|
size size
|
||||||
|
|||||||
@@ -1 +1 @@
|
|||||||
head (map (\i : append "String " i) [("test!")])
|
head (map (i : append "String " i) [("test!")])
|
||||||
|
|||||||
@@ -1 +1 @@
|
|||||||
y = \x : x
|
y = x : x
|
||||||
|
|||||||
77
tricu.cabal
77
tricu.cabal
@@ -1,8 +1,8 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
name: tricu
|
name: tricu
|
||||||
version: 0.15.0
|
version: 1.1.0
|
||||||
description: A micro-language for exploring Tree Calculus
|
description: A language for exploring Tree Calculus
|
||||||
author: James Eversole
|
author: James Eversole
|
||||||
maintainer: james@eversole.co
|
maintainer: james@eversole.co
|
||||||
copyright: James Eversole
|
copyright: James Eversole
|
||||||
@@ -15,31 +15,67 @@ extra-source-files:
|
|||||||
executable tricu
|
executable tricu
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
default-extensions:
|
default-extensions:
|
||||||
DeriveDataTypeable
|
DeriveDataTypeable
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiWayIf
|
MultiWayIf
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
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:
|
build-depends:
|
||||||
base >=4.7
|
base >=4.7
|
||||||
|
, aeson
|
||||||
|
, ansi-terminal
|
||||||
|
, base16-bytestring
|
||||||
|
, base64-bytestring
|
||||||
|
, bytestring
|
||||||
, cmdargs
|
, cmdargs
|
||||||
, containers
|
, containers
|
||||||
|
, cryptonite
|
||||||
|
, directory
|
||||||
, exceptions
|
, exceptions
|
||||||
, filepath
|
, filepath
|
||||||
|
, fsnotify
|
||||||
, haskeline
|
, haskeline
|
||||||
|
, http-types
|
||||||
, megaparsec
|
, megaparsec
|
||||||
|
, memory
|
||||||
, mtl
|
, mtl
|
||||||
|
, servant
|
||||||
|
, sqlite-simple
|
||||||
|
, stm
|
||||||
|
, tasty
|
||||||
|
, tasty-hunit
|
||||||
, text
|
, text
|
||||||
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, wai
|
||||||
|
, warp
|
||||||
|
, zlib
|
||||||
other-modules:
|
other-modules:
|
||||||
|
ContentStore
|
||||||
Eval
|
Eval
|
||||||
FileEval
|
FileEval
|
||||||
Lexer
|
Lexer
|
||||||
Parser
|
Parser
|
||||||
|
Paths_tricu
|
||||||
REPL
|
REPL
|
||||||
Research
|
Research
|
||||||
|
Server
|
||||||
|
Wire
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite tricu-tests
|
test-suite tricu-tests
|
||||||
@@ -51,25 +87,46 @@ test-suite tricu-tests
|
|||||||
LambdaCase
|
LambdaCase
|
||||||
MultiWayIf
|
MultiWayIf
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
|
ScopedTypeVariables
|
||||||
build-depends:
|
build-depends:
|
||||||
base
|
base >=4.7
|
||||||
|
, aeson
|
||||||
|
, ansi-terminal
|
||||||
|
, base16-bytestring
|
||||||
|
, base64-bytestring
|
||||||
|
, bytestring
|
||||||
, cmdargs
|
, cmdargs
|
||||||
, containers
|
, containers
|
||||||
|
, cryptonite
|
||||||
|
, directory
|
||||||
, exceptions
|
, exceptions
|
||||||
, filepath
|
, filepath
|
||||||
|
, fsnotify
|
||||||
, haskeline
|
, haskeline
|
||||||
|
, http-types
|
||||||
, megaparsec
|
, megaparsec
|
||||||
|
, memory
|
||||||
, mtl
|
, mtl
|
||||||
|
, servant
|
||||||
|
, sqlite-simple
|
||||||
|
, stm
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hunit
|
, tasty-hunit
|
||||||
, tasty-quickcheck
|
|
||||||
, text
|
, text
|
||||||
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, warp
|
||||||
|
, wai
|
||||||
|
, zlib
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
other-modules:
|
other-modules:
|
||||||
|
ContentStore
|
||||||
Eval
|
Eval
|
||||||
FileEval
|
FileEval
|
||||||
Lexer
|
Lexer
|
||||||
Parser
|
Parser
|
||||||
|
Paths_tricu
|
||||||
REPL
|
REPL
|
||||||
Research
|
Research
|
||||||
|
Server
|
||||||
|
Wire
|
||||||
|
|||||||
Reference in New Issue
Block a user