Compare commits
14 Commits
contentsto
...
89bb73ed99
| Author | SHA1 | Date | |
|---|---|---|---|
| 89bb73ed99 | |||
| 1c4c49e68d | |||
| e7a6426060 | |||
| 7e16607d96 | |||
| a36ff638a9 | |||
| 0cd849447f | |||
| fe453b9b96 | |||
| fb09b4666e | |||
| efbe9350ed | |||
| 2627627493 | |||
| c008126b14 | |||
|
|
71653311ce | ||
| 0cdc0bfc34 | |||
| c36d963640 |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -6,6 +6,7 @@
|
|||||||
/Dockerfile
|
/Dockerfile
|
||||||
/config.dhall
|
/config.dhall
|
||||||
/result
|
/result
|
||||||
|
/result*
|
||||||
.aider*
|
.aider*
|
||||||
WD
|
WD
|
||||||
bin/
|
bin/
|
||||||
|
|||||||
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
|
||||||
|
```
|
||||||
26
README.md
26
README.md
@@ -6,6 +6,8 @@ tricu (pronounced "tree-shoe") is a programming language experiment in Haskell.
|
|||||||
|
|
||||||
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)`.
|
||||||
|
|
||||||
|
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.
|
||||||
|
|
||||||
## Acknowledgements
|
## Acknowledgements
|
||||||
|
|
||||||
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.
|
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.
|
||||||
@@ -32,15 +34,21 @@ tricu < -- or calculate its size (/demos/size.tri)
|
|||||||
tricu < size not?
|
tricu < size not?
|
||||||
tricu > 12
|
tricu > 12
|
||||||
|
|
||||||
tricu < -- REPL Commands:
|
tricu < !help
|
||||||
tricu < !definitions -- Lists all available definitions
|
tricu version 1.1.0
|
||||||
tricu < !output -- Change output format (Tree, FSL, AST, etc.)
|
Available commands:
|
||||||
tricu < !import -- Import definitions from a file
|
!exit - Exit the REPL
|
||||||
tricu < !exit -- Exit the REPL
|
!clear - Clear the screen
|
||||||
tricu < !clear -- ANSI screen clear
|
!reset - Reset preferences for selected versions
|
||||||
tricu < !save -- Save all REPL definitions to a file that you can !import
|
!help - Show tricu version and available commands
|
||||||
tricu < !reset -- Clear all REPL definitions
|
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
|
||||||
tricu < !version -- Print tricu version
|
!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
|
||||||
|
|||||||
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 = ''
|
||||||
|
'';
|
||||||
|
};
|
||||||
|
};
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|||||||
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)
|
||||||
@@ -1,19 +1,19 @@
|
|||||||
module ContentStore where
|
module ContentStore where
|
||||||
|
|
||||||
import Research
|
import Research
|
||||||
import Parser
|
|
||||||
|
|
||||||
import Control.Monad (foldM, forM)
|
import Control.Monad (foldM, forM_, void)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Char (isHexDigit)
|
||||||
import Data.List (nub, sort)
|
import Data.List (nub, sort)
|
||||||
import Data.Maybe (catMaybes, fromJust)
|
import Data.Maybe (catMaybes, fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Database.SQLite.Simple
|
import Database.SQLite.Simple
|
||||||
import Database.SQLite.Simple.FromRow (FromRow(..), field)
|
|
||||||
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
|
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
|
||||||
|
import System.Environment (lookupEnv)
|
||||||
|
import System.Exit (die)
|
||||||
import System.FilePath ((</>), takeDirectory)
|
import System.FilePath ((</>), takeDirectory)
|
||||||
|
|
||||||
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
|
||||||
|
|
||||||
@@ -44,10 +44,16 @@ initContentStore = do
|
|||||||
dbPath <- getContentStorePath
|
dbPath <- getContentStorePath
|
||||||
createDirectoryIfMissing True (takeDirectory dbPath)
|
createDirectoryIfMissing True (takeDirectory dbPath)
|
||||||
conn <- open 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 (\
|
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
|
||||||
\hash TEXT PRIMARY KEY, \
|
\hash TEXT PRIMARY KEY, \
|
||||||
\names TEXT, \
|
\names TEXT, \
|
||||||
\term_data BLOB, \
|
|
||||||
\metadata TEXT, \
|
\metadata TEXT, \
|
||||||
\created_at INTEGER DEFAULT (strftime('%s','now')), \
|
\created_at INTEGER DEFAULT (strftime('%s','now')), \
|
||||||
\tags TEXT DEFAULT '')"
|
\tags TEXT DEFAULT '')"
|
||||||
@@ -56,12 +62,24 @@ initContentStore = do
|
|||||||
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
|
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
|
||||||
\hash TEXT PRIMARY KEY, \
|
\hash TEXT PRIMARY KEY, \
|
||||||
\node_data BLOB NOT NULL)"
|
\node_data BLOB NOT NULL)"
|
||||||
return conn
|
-- 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 :: IO FilePath
|
||||||
getContentStorePath = do
|
getContentStorePath = do
|
||||||
dataDir <- getXdgDirectory XdgData "tricu"
|
maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
|
||||||
return $ dataDir </> "content-store.db"
|
case maybeLocalPath of
|
||||||
|
Just p -> return p
|
||||||
|
Nothing -> do
|
||||||
|
dataDir <- getXdgDirectory XdgData "tricu"
|
||||||
|
return $ dataDir </> "content-store.db"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -83,8 +101,8 @@ storeTerm conn newNamesStrList term = do
|
|||||||
[] -> do
|
[] -> do
|
||||||
let allNamesToStore = serializeNameList newNamesTextList
|
let allNamesToStore = serializeNameList newNamesTextList
|
||||||
execute conn
|
execute conn
|
||||||
"INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)"
|
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
|
||||||
(termHashText, allNamesToStore, BS.pack [], metadataText, T.pack "")
|
(termHashText, allNamesToStore, metadataText, T.pack "")
|
||||||
[(Only currentNamesText)] -> do
|
[(Only currentNamesText)] -> do
|
||||||
let currentNamesList = parseNameList currentNamesText
|
let currentNamesList = parseNameList currentNamesText
|
||||||
let combinedNamesList = currentNamesList ++ newNamesTextList
|
let combinedNamesList = currentNamesList ++ newNamesTextList
|
||||||
@@ -92,33 +110,35 @@ storeTerm conn newNamesStrList term = do
|
|||||||
execute conn
|
execute conn
|
||||||
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
||||||
(allNamesToStore, metadataText, termHashText)
|
(allNamesToStore, metadataText, termHashText)
|
||||||
_ -> error $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
|
_ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
|
||||||
|
|
||||||
return termHashText
|
return termHashText
|
||||||
|
|
||||||
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
|
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
|
||||||
-- Recursively loads nodes and rebuilds the T structure.
|
-- Recursively loads nodes and rebuilds the T structure.
|
||||||
loadTree conn h
|
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
|
||||||
| h == nodeHash NLeaf = return (Just Leaf) -- NLeaf is implicit, not stored
|
loadTree conn h = do
|
||||||
| otherwise = do
|
maybeNode <- getNodeMerkle conn h
|
||||||
maybeNode <- getNodeMerkle conn h
|
case maybeNode of
|
||||||
case maybeNode of
|
Nothing -> return Nothing
|
||||||
Nothing -> return Nothing
|
Just node -> Just <$> buildTree node
|
||||||
Just node -> Just <$> buildTree node
|
|
||||||
where
|
where
|
||||||
buildTree :: Node -> IO T
|
buildTree :: Node -> IO T
|
||||||
|
buildTree NLeaf = return Leaf
|
||||||
buildTree (NStem childHash) = do
|
buildTree (NStem childHash) = do
|
||||||
child <- fromJust <$> loadTree conn childHash
|
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
|
||||||
return (Stem child)
|
return (Stem child)
|
||||||
buildTree (NFork lHash rHash) = do
|
buildTree (NFork lHash rHash) = do
|
||||||
left <- fromJust <$> loadTree conn lHash
|
left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
|
||||||
right <- fromJust <$> loadTree conn rHash
|
right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
|
||||||
return (Fork left right)
|
return (Fork left right)
|
||||||
|
|
||||||
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
|
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
|
||||||
-- Returns the hash of the root node.
|
-- Returns the hash of the root node.
|
||||||
storeMerkleNodes :: Connection -> T -> IO MerkleHash
|
storeMerkleNodes :: Connection -> T -> IO MerkleHash
|
||||||
storeMerkleNodes _ Leaf = return $ nodeHash NLeaf
|
storeMerkleNodes conn Leaf = do
|
||||||
|
putMerkleNode conn NLeaf
|
||||||
|
return $ nodeHash NLeaf
|
||||||
storeMerkleNodes conn (Stem t) = do
|
storeMerkleNodes conn (Stem t) = do
|
||||||
childHash <- storeMerkleNodes conn t
|
childHash <- storeMerkleNodes conn t
|
||||||
let thisNode = NStem childHash
|
let thisNode = NStem childHash
|
||||||
@@ -161,14 +181,14 @@ listStoredTerms :: Connection -> IO [StoredTerm]
|
|||||||
listStoredTerms conn =
|
listStoredTerms conn =
|
||||||
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
|
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
|
||||||
|
|
||||||
storeEnvironment :: Connection -> Env -> IO [(String, Text)]
|
storeEnvironment :: Connection -> Env -> IO ()
|
||||||
storeEnvironment conn env = do
|
storeEnvironment conn env = do
|
||||||
let defs = Map.toList $ Map.delete "!result" env
|
let defs = Map.toList $ Map.delete "!result" env
|
||||||
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
|
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
|
||||||
|
|
||||||
forM groupedDefs $ \(term, namesList) -> do
|
forM_ groupedDefs $ \(term, namesList) -> case namesList of
|
||||||
hashVal <- storeTerm conn namesList term
|
_:_ -> void $ storeTerm conn namesList term
|
||||||
return (head namesList, hashVal)
|
_ -> errorWithoutStackTrace "storeEnvironment: empty names list"
|
||||||
|
|
||||||
loadTerm :: Connection -> String -> IO (Maybe T)
|
loadTerm :: Connection -> String -> IO (Maybe T)
|
||||||
loadTerm conn identifier = do
|
loadTerm conn identifier = do
|
||||||
@@ -254,3 +274,36 @@ queryMaybeOne conn qry params = do
|
|||||||
case results of
|
case results of
|
||||||
[row] -> return $ Just row
|
[row] -> return $ Just row
|
||||||
_ -> return Nothing
|
_ -> 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
|
||||||
|
|||||||
412
src/Eval.hs
412
src/Eval.hs
@@ -4,14 +4,32 @@ import ContentStore
|
|||||||
import Parser
|
import Parser
|
||||||
import Research
|
import Research
|
||||||
|
|
||||||
import Control.Monad (forM_, foldM)
|
import Control.Monad (foldM)
|
||||||
import Data.List (partition, (\\))
|
import Data.List (partition, (\\), elemIndex, foldl')
|
||||||
import Data.Map (Map)
|
import Data.Map ()
|
||||||
|
import Data.Set (Set)
|
||||||
import Database.SQLite.Simple
|
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
|
import qualified Data.Text as T
|
||||||
import Data.List (foldl')
|
|
||||||
|
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
|
||||||
@@ -41,12 +59,12 @@ evalSingle env term
|
|||||||
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
|
||||||
|
|
||||||
evalASTSync :: Env -> TricuAST -> T
|
evalASTSync :: Env -> TricuAST -> T
|
||||||
evalASTSync env term = case term of
|
evalASTSync env term = case term of
|
||||||
@@ -111,7 +129,7 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
|||||||
case matchingVersions of
|
case matchingVersions of
|
||||||
[] -> return Nothing
|
[] -> return Nothing
|
||||||
[(_, term, _)] -> return $ Just term
|
[(_, term, _)] -> return $ Just term
|
||||||
_ -> return Nothing -- Ambiguous or too many matches
|
_ -> return Nothing
|
||||||
Nothing -> case Map.lookup name selectedVersions of
|
Nothing -> case Map.lookup name selectedVersions of
|
||||||
Just hash -> loadTree conn hash
|
Just hash -> loadTree conn hash
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
@@ -119,74 +137,88 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
|||||||
case versions of
|
case versions of
|
||||||
[] -> return Nothing
|
[] -> return Nothing
|
||||||
[(_, term, _)] -> return $ Just term
|
[(_, term, _)] -> return $ Just term
|
||||||
_ -> return $ Just $ (\(_, t, _) -> t) $ head versions
|
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||||
|
|
||||||
elimLambda :: TricuAST -> TricuAST
|
elimLambda :: TricuAST -> TricuAST
|
||||||
elimLambda = go
|
elimLambda = go
|
||||||
where
|
where
|
||||||
go term
|
go term
|
||||||
| etaReduction term = elimLambda $ etaReduceResult term
|
| etaReduction term = go (etaReduceResult term)
|
||||||
| triagePattern term = _TRI
|
| triagePattern term = _TRI
|
||||||
| composePattern term = _B
|
| composePattern term = _B
|
||||||
| lambdaList term = elimLambda $ lambdaListResult term
|
| lambdaList term = go (lambdaListResult term)
|
||||||
| nestedLambda term = nestedLambdaResult term
|
| nestedLambda term = nestedLambdaResult term
|
||||||
| application term = applicationResult term
|
| application term = applicationResult term
|
||||||
| isSList term = slistTransform term
|
| isSList term = slistTransform term
|
||||||
| otherwise = term
|
| otherwise = term
|
||||||
|
|
||||||
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f)
|
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
|
||||||
etaReduction _ = False
|
etaReduction _ = False
|
||||||
etaReduceResult (SLambda [_] (SApp f _)) = f
|
|
||||||
|
|
||||||
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) = body == triageBody a b c
|
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
|
||||||
|
toDB [c,b,a] body == triageBodyDB
|
||||||
triagePattern _ = False
|
triagePattern _ = False
|
||||||
|
|
||||||
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) = body == composeBody f g x
|
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
|
||||||
|
toDB [x,g,f] body == composeBodyDB
|
||||||
composePattern _ = False
|
composePattern _ = False
|
||||||
|
|
||||||
lambdaList (SLambda [_] (SList _)) = True
|
lambdaList (SLambda [_] (SList _)) = True
|
||||||
lambdaList _ = False
|
lambdaList _ = False
|
||||||
lambdaListResult (SLambda [v] (SList xs)) = SLambda [v] (foldr wrapTLeaf TLeaf xs)
|
|
||||||
wrapTLeaf m r = SApp (SApp TLeaf m) r
|
|
||||||
|
|
||||||
nestedLambda (SLambda (_:_) _) = True
|
nestedLambda (SLambda (_:_) _) = True
|
||||||
nestedLambda _ = False
|
nestedLambda _ = False
|
||||||
nestedLambdaResult (SLambda (v:vs) body)
|
|
||||||
| null vs = toSKI v (go body) -- Changed elimLambda to go
|
|
||||||
| otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go
|
|
||||||
|
|
||||||
application (SApp _ _) = True
|
application (SApp _ _) = True
|
||||||
application _ = False
|
application _ = False
|
||||||
applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go
|
|
||||||
|
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
|
||||||
|
wrapTLeaf m r = SApp (SApp TLeaf m) r
|
||||||
|
lambdaListResult _ = error "lambdaListResult: expected SLambda [v] (SList xs)"
|
||||||
|
|
||||||
|
nestedLambdaResult (SLambda (v:vs) body)
|
||||||
|
| null vs =
|
||||||
|
let body' = go body
|
||||||
|
db = toDB [v] body'
|
||||||
|
in toSKIKiselyov db
|
||||||
|
| otherwise = go (SLambda [v] (SLambda vs body))
|
||||||
|
nestedLambdaResult _ = error "nestedLambdaResult: expected SLambda (_:_) _"
|
||||||
|
|
||||||
|
applicationResult (SApp f g) = SApp (go f) (go g)
|
||||||
|
applicationResult _ = error "applicationResult: expected SApp _ _"
|
||||||
|
|
||||||
isSList (SList _) = True
|
isSList (SList _) = True
|
||||||
isSList _ = False
|
isSList _ = False
|
||||||
|
|
||||||
slistTransform :: TricuAST -> TricuAST
|
slistTransform :: TricuAST -> TricuAST
|
||||||
slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
|
slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
|
||||||
slistTransform ast = ast -- Should not be reached if isSList is the guard
|
slistTransform ast = ast -- Should not be reached
|
||||||
|
|
||||||
toSKI x (SVar y Nothing)
|
_S, _K, _I, _R, _C, _B, _T, _TRI :: TricuAST
|
||||||
| x == y = _I
|
_S = parseSingle "t (t (t t t)) t"
|
||||||
| otherwise = SApp _K (SVar y Nothing)
|
_K = parseSingle "t t"
|
||||||
toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n)
|
_I = parseSingle "t (t (t t)) t"
|
||||||
toSKI x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first
|
_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))"
|
||||||
toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly
|
_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)))"
|
||||||
toSKI _ term = SApp _K term
|
_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"
|
||||||
|
|
||||||
_S = parseSingle "t (t (t t t)) t"
|
triageBody :: String -> String -> String -> TricuAST
|
||||||
_K = parseSingle "t t"
|
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
||||||
_I = parseSingle "t (t (t t)) t"
|
composeBody :: String -> String -> String -> TricuAST
|
||||||
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
|
||||||
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
|
|
||||||
|
|
||||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
|
||||||
composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x)
|
|
||||||
|
|
||||||
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 :: TricuAST -> Set String
|
||||||
freeVars (SVar v Nothing) = Set.singleton v
|
freeVars (SVar v Nothing) = Set.singleton v
|
||||||
freeVars (SVar v (Just _)) = Set.singleton v
|
freeVars (SVar v (Just _)) = Set.singleton v
|
||||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||||
@@ -242,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
|
||||||
@@ -273,22 +305,6 @@ 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."
|
||||||
|
|
||||||
evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
|
||||||
evalWithEnv env mconn selectedVersions ast = do
|
|
||||||
let varNames = findVarNames ast
|
|
||||||
resolvedEnv <- case mconn of
|
|
||||||
Just conn -> foldM (\e name ->
|
|
||||||
if Map.member name e
|
|
||||||
then return e
|
|
||||||
else do
|
|
||||||
mterm <- resolveTermFromStore conn selectedVersions name Nothing
|
|
||||||
case mterm of
|
|
||||||
Just term -> return $ Map.insert name term e
|
|
||||||
Nothing -> return e
|
|
||||||
) env varNames
|
|
||||||
Nothing -> return env
|
|
||||||
return $ evalASTSync resolvedEnv ast
|
|
||||||
|
|
||||||
findVarNames :: TricuAST -> [String]
|
findVarNames :: TricuAST -> [String]
|
||||||
findVarNames ast = case ast of
|
findVarNames ast = case ast of
|
||||||
SVar name _ -> [name]
|
SVar name _ -> [name]
|
||||||
@@ -296,3 +312,283 @@ findVarNames ast = case ast of
|
|||||||
SLambda args body -> findVarNames body \\ args
|
SLambda args body -> findVarNames body \\ args
|
||||||
SDef name args body -> name : (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
|
||||||
|
|||||||
@@ -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)
|
||||||
@@ -152,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)
|
||||||
|
|||||||
16
src/Lexer.hs
16
src/Lexer.hs
@@ -4,13 +4,12 @@ import Research
|
|||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Data.Functor (($>))
|
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]
|
||||||
@@ -23,13 +22,13 @@ 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
|
||||||
@@ -51,7 +50,7 @@ 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
|
||||||
@@ -63,6 +62,7 @@ identifierWithHash = do
|
|||||||
rest <- many $ letterChar
|
rest <- many $ letterChar
|
||||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||||
<|> char '$' <|> char '@' <|> char '%'
|
<|> char '$' <|> char '@' <|> char '%'
|
||||||
|
<|> char '\''
|
||||||
_ <- char '#' -- Consume '#'
|
_ <- char '#' -- Consume '#'
|
||||||
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
|
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
|
||||||
<?> "hash characters (alphanumeric or hyphen)"
|
<?> "hash characters (alphanumeric or hyphen)"
|
||||||
@@ -84,6 +84,7 @@ identifier = do
|
|||||||
rest <- many $ letterChar
|
rest <- many $ letterChar
|
||||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
<|> digitChar <|> 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"
|
||||||
@@ -143,8 +144,8 @@ integerLiteral = do
|
|||||||
|
|
||||||
stringLiteral :: Lexer LToken
|
stringLiteral :: Lexer LToken
|
||||||
stringLiteral = do
|
stringLiteral = do
|
||||||
char '"'
|
void (char '"')
|
||||||
content <- manyTill Lexer.charLiteral (char '"')
|
content <- manyTill Lexer.charLiteral (void (char '"'))
|
||||||
return (LStringLiteral content)
|
return (LStringLiteral content)
|
||||||
|
|
||||||
charLiteral :: Lexer Char
|
charLiteral :: Lexer Char
|
||||||
@@ -163,3 +164,4 @@ charLiteral = escapedChar <|> normalChar
|
|||||||
'\\' -> '\\'
|
'\\' -> '\\'
|
||||||
'"' -> '"'
|
'"' -> '"'
|
||||||
'\'' -> '\''
|
'\'' -> '\''
|
||||||
|
_ -> c
|
||||||
|
|||||||
147
src/Main.hs
147
src/Main.hs
@@ -1,18 +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 ContentStore
|
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
|
||||||
|
|
||||||
@@ -20,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
|
||||||
@@ -53,33 +65,128 @@ 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 may exit with `CTRL+D` or the `!exit` command."
|
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||||
repl
|
repl
|
||||||
Evaluate { file = filePaths, form = form } -> do
|
Evaluate { file = filePaths, form = outputForm } -> do
|
||||||
result <- case filePaths of
|
maybeDbPath <- lookupEnv "TRICU_DB_PATH"
|
||||||
[] -> runTricuT <$> getContents
|
evalResult <- case filePaths of
|
||||||
(filePath:restFilePaths) -> do
|
[] -> do
|
||||||
initialEnv <- evaluateFile filePath
|
initialEnv <- case maybeDbPath of
|
||||||
|
Just _ -> do
|
||||||
|
conn <- initContentStore
|
||||||
|
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 = formatT 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 -> String
|
runTricu :: String -> String
|
||||||
runTricu = formatT TreeCalculus . runTricuT
|
runTricu = formatT TreeCalculus . runTricuT
|
||||||
@@ -124,3 +231,21 @@ runTricuEnvWithEnv env input =
|
|||||||
finalEnv = evalTricu env asts
|
finalEnv = evalTricu env asts
|
||||||
res = result finalEnv
|
res = result finalEnv
|
||||||
in (finalEnv, formatT TreeCalculus res)
|
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
|
||||||
|
|||||||
@@ -8,7 +8,7 @@ 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
|
||||||
@@ -195,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
|
||||||
@@ -248,20 +249,20 @@ 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 Nothing)
|
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
|
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)
|
||||||
@@ -282,8 +283,8 @@ parseVarM = do
|
|||||||
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 (fromIntegral value))
|
pure (SInt (fromIntegral value))
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
fail "Unexpected token while parsing integer literal"
|
fail "Unexpected token while parsing integer literal"
|
||||||
@@ -291,8 +292,8 @@ parseIntLiteralM = do
|
|||||||
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"
|
||||||
@@ -308,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
|
||||||
|
|||||||
178
src/REPL.hs
178
src/REPL.hs
@@ -1,48 +1,44 @@
|
|||||||
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 ContentStore
|
import Wire
|
||||||
|
|
||||||
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
||||||
import Control.Monad (forever, void, when, forM, forM_, foldM, unless)
|
import Control.Exception (SomeException, catch, displayException)
|
||||||
import Data.ByteString (ByteString)
|
import Control.Monad ()
|
||||||
import Data.Maybe (isNothing, isJust, fromJust, catMaybes)
|
import Control.Monad (forever, when, forM_, foldM, unless)
|
||||||
import Database.SQLite.Simple (Connection, Only(..), query, query_, execute, execute_, open)
|
import Control.Monad.Catch (handle)
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Control.Monad.Trans.Class ()
|
||||||
|
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||||
|
import Data.ByteString ()
|
||||||
|
import Data.Char (isSpace)
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy as BL
|
||||||
|
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||||
|
import Data.List (dropWhileEnd, isPrefixOf, find)
|
||||||
|
import Data.Maybe (isJust, fromJust)
|
||||||
|
import Data.Time (getCurrentTime, diffUTCTime)
|
||||||
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||||
|
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||||
|
import Data.Version (showVersion)
|
||||||
|
import Database.SQLite.Simple (Connection, Only(..), query)
|
||||||
|
import Paths_tricu (version)
|
||||||
|
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
|
||||||
|
import System.Console.Haskeline
|
||||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||||
import System.FSNotify
|
import System.FSNotify
|
||||||
import System.FilePath (takeDirectory, (</>))
|
import System.FilePath (takeDirectory, (</>))
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
import Control.Exception (IOException, SomeException, catch
|
|
||||||
, displayException)
|
|
||||||
import Control.Monad (forM_)
|
|
||||||
import Control.Monad.Catch (handle, MonadCatch)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
|
||||||
import Data.Char (isSpace, isUpper)
|
|
||||||
import Data.List ((\\), dropWhile, dropWhileEnd, isPrefixOf, nub, sortBy, groupBy, intercalate, find)
|
|
||||||
import Data.Version (showVersion)
|
|
||||||
import Paths_tricu (version)
|
|
||||||
import System.Console.Haskeline
|
|
||||||
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..),
|
|
||||||
Color(..), ConsoleIntensity(..), clearFromCursorToLineEnd)
|
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T ()
|
||||||
|
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
||||||
import Data.Time (UTCTime, getCurrentTime, diffUTCTime)
|
|
||||||
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
|
|
||||||
|
|
||||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
|
||||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
|
||||||
|
|
||||||
data REPLState = REPLState
|
data REPLState = REPLState
|
||||||
{ replForm :: EvaluatedForm
|
{ replForm :: EvaluatedForm
|
||||||
@@ -80,6 +76,8 @@ repl = do
|
|||||||
, "!versions"
|
, "!versions"
|
||||||
, "!select"
|
, "!select"
|
||||||
, "!tag"
|
, "!tag"
|
||||||
|
, "!export"
|
||||||
|
, "!bundleimport"
|
||||||
]
|
]
|
||||||
|
|
||||||
loop :: REPLState -> InputT IO ()
|
loop :: REPLState -> InputT IO ()
|
||||||
@@ -110,6 +108,8 @@ repl = do
|
|||||||
outputStrLn " !versions - Show all versions of a term by name"
|
outputStrLn " !versions - Show all versions of a term by name"
|
||||||
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
|
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 " !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
|
loop state
|
||||||
| strip s == "!output" -> handleOutput state
|
| strip s == "!output" -> handleOutput state
|
||||||
| strip s == "!definitions" -> handleDefinitions state
|
| strip s == "!definitions" -> handleDefinitions state
|
||||||
@@ -119,28 +119,30 @@ repl = do
|
|||||||
| "!versions" `isPrefixOf` strip s -> handleVersions state
|
| "!versions" `isPrefixOf` strip s -> handleVersions state
|
||||||
| "!select" `isPrefixOf` strip s -> handleSelect state
|
| "!select" `isPrefixOf` strip s -> handleSelect state
|
||||||
| "!tag" `isPrefixOf` strip s -> handleTag state
|
| "!tag" `isPrefixOf` strip s -> handleTag state
|
||||||
|
| "!export" `isPrefixOf` strip s -> handleExport state
|
||||||
|
| "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
|
||||||
| take 2 s == "--" -> loop state
|
| take 2 s == "--" -> loop state
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
result <- liftIO $ catch
|
evalResult <- liftIO $ catch
|
||||||
(processInput state s)
|
(processInput state s)
|
||||||
(errorHandler state)
|
(errorHandler state)
|
||||||
loop result
|
loop evalResult
|
||||||
|
|
||||||
handleOutput :: REPLState -> InputT IO ()
|
handleOutput :: REPLState -> InputT IO ()
|
||||||
handleOutput state = do
|
handleOutput state = do
|
||||||
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
|
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
|
||||||
outputStrLn "Available output formats:"
|
outputStrLn "Available output formats:"
|
||||||
mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f)
|
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
||||||
(zip [1..] formats)
|
(zip [1..] formats)
|
||||||
|
|
||||||
result <- runMaybeT $ do
|
evalResult <- runMaybeT $ do
|
||||||
input <- MaybeT $ getInputLine "Select output format (1-6) < "
|
input <- MaybeT $ getInputLine "Select output format (1-6) < "
|
||||||
case reads input of
|
case reads input of
|
||||||
[(n, "")] | n >= 1 && n <= 6 ->
|
[(n, "")] | n >= 1 && n <= 6 ->
|
||||||
return $ formats !! (n-1)
|
return $ formats !! (n-1)
|
||||||
_ -> MaybeT $ return Nothing
|
_ -> MaybeT $ return Nothing
|
||||||
|
|
||||||
case result of
|
case evalResult of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
outputStrLn "Invalid selection. Keeping current output format."
|
outputStrLn "Invalid selection. Keeping current output format."
|
||||||
loop state
|
loop state
|
||||||
@@ -201,7 +203,7 @@ repl = do
|
|||||||
|
|
||||||
importFile :: REPLState -> String -> InputT IO ()
|
importFile :: REPLState -> String -> InputT IO ()
|
||||||
importFile state cleanFilename = do
|
importFile state cleanFilename = do
|
||||||
code <- liftIO $ readFile cleanFilename
|
_code <- liftIO $ readFile cleanFilename
|
||||||
case replContentStore state of
|
case replContentStore state of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
liftIO $ printError "Content store not initialized"
|
liftIO $ printError "Content store not initialized"
|
||||||
@@ -216,7 +218,7 @@ repl = do
|
|||||||
importedCount <- foldM (\count (name, term) -> do
|
importedCount <- foldM (\count (name, term) -> do
|
||||||
hash <- ContentStore.storeTerm conn [name] term
|
hash <- ContentStore.storeTerm conn [name] term
|
||||||
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||||
return (count + 1)
|
return (count + (1 :: Int))
|
||||||
) 0 defs
|
) 0 defs
|
||||||
|
|
||||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||||
@@ -248,7 +250,7 @@ repl = do
|
|||||||
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
||||||
|
|
||||||
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
||||||
stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do
|
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
lastProcessed <- readIORef lastProcessedRef
|
lastProcessed <- readIORef lastProcessedRef
|
||||||
when (diffUTCTime now lastProcessed > 0.5) $ do
|
when (diffUTCTime now lastProcessed > 0.5) $ do
|
||||||
@@ -259,8 +261,8 @@ repl = do
|
|||||||
|
|
||||||
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
|
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
|
||||||
|
|
||||||
handleUnwatch :: REPLState -> InputT IO ()
|
_handleUnwatch :: REPLState -> InputT IO ()
|
||||||
handleUnwatch state = case replWatchedFile state of
|
_handleUnwatch state = case replWatchedFile state of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
outputStrLn "No file is currently being watched"
|
outputStrLn "No file is currently being watched"
|
||||||
loop state
|
loop state
|
||||||
@@ -275,7 +277,7 @@ repl = do
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
outputStrLn "Content store not initialized"
|
outputStrLn "Content store not initialized"
|
||||||
loop state
|
loop state
|
||||||
Just conn -> do
|
Just _conn -> do
|
||||||
outputStrLn "Environment refreshed from content store (definitions are live)"
|
outputStrLn "Environment refreshed from content store (definitions are live)"
|
||||||
loop state
|
loop state
|
||||||
|
|
||||||
@@ -445,6 +447,74 @@ repl = do
|
|||||||
then do printError $ "No versions found for term name: " ++ ident; return Nothing
|
then do printError $ "No versions found for term name: " ++ ident; return Nothing
|
||||||
else return $ Just $ (\(h,_,_) -> h) $ head versions
|
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 :: REPLState -> Interrupt -> InputT IO ()
|
||||||
interruptHandler state _ = do
|
interruptHandler state _ = do
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
@@ -486,8 +556,8 @@ repl = do
|
|||||||
forM_ asts $ \ast -> do
|
forM_ asts $ \ast -> do
|
||||||
case ast of
|
case ast of
|
||||||
SDef name [] body -> do
|
SDef name [] body -> do
|
||||||
result <- evalAST (Just conn) (replSelectedVersions newState) body
|
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||||
hash <- ContentStore.storeTerm conn [name] result
|
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||||
|
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
putStr "tricu > "
|
putStr "tricu > "
|
||||||
@@ -498,14 +568,14 @@ repl = do
|
|||||||
putStrLn ""
|
putStrLn ""
|
||||||
|
|
||||||
putStr "tricu > "
|
putStr "tricu > "
|
||||||
printResult $ formatT (replForm newState) result
|
printResult $ formatT (replForm newState) evalResult
|
||||||
putStrLn ""
|
putStrLn ""
|
||||||
|
|
||||||
_ -> do
|
_ -> do
|
||||||
result <- evalAST (Just conn) (replSelectedVersions newState) ast
|
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
putStr "tricu > "
|
putStr "tricu > "
|
||||||
printResult $ formatT (replForm newState) result
|
printResult $ formatT (replForm newState) evalResult
|
||||||
putStrLn ""
|
putStrLn ""
|
||||||
return newState
|
return newState
|
||||||
|
|
||||||
@@ -531,13 +601,13 @@ repl = do
|
|||||||
Just conn -> do
|
Just conn -> do
|
||||||
forM_ asts $ \ast -> case ast of
|
forM_ asts $ \ast -> case ast of
|
||||||
SDef name [] body -> do
|
SDef name [] body -> do
|
||||||
result <- evalAST (Just conn) selectedVersions body
|
evalResult <- evalAST (Just conn) selectedVersions body
|
||||||
hash <- ContentStore.storeTerm conn [name] result
|
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||||
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm result
|
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||||
_ -> do
|
_ -> do
|
||||||
result <- evalAST (Just conn) selectedVersions ast
|
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||||
putStrLn $ "tricu > Result: " ++ formatT outputForm result
|
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||||
|
|
||||||
formatTimestamp :: Integer -> String
|
formatTimestamp :: Integer -> String
|
||||||
@@ -552,12 +622,6 @@ repl = do
|
|||||||
putStr $ T.unpack rest
|
putStr $ T.unpack rest
|
||||||
setSGR [Reset]
|
setSGR [Reset]
|
||||||
|
|
||||||
coloredHashString :: T.Text -> String
|
|
||||||
coloredHashString hash =
|
|
||||||
"\ESC[1;36m" ++ T.unpack (T.take 16 hash) ++
|
|
||||||
"\ESC[0;37m" ++ T.unpack (T.drop 16 hash) ++
|
|
||||||
"\ESC[0m"
|
|
||||||
|
|
||||||
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
||||||
withColor intensity color action = do
|
withColor intensity color action = do
|
||||||
setSGR [SetColor Foreground intensity color]
|
setSGR [SetColor Foreground intensity color]
|
||||||
|
|||||||
117
src/Research.hs
117
src/Research.hs
@@ -1,17 +1,18 @@
|
|||||||
module Research where
|
module Research where
|
||||||
|
|
||||||
|
import Crypto.Hash (hash, SHA256, Digest)
|
||||||
import Data.ByteArray (convert)
|
import Data.ByteArray (convert)
|
||||||
import Data.Char (chr, ord)
|
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, unpack)
|
import Data.Text (Text, replace)
|
||||||
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
import Data.Word (Word8)
|
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.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
|
||||||
import Crypto.Hash (hash, SHA256, Digest)
|
|
||||||
|
|
||||||
-- Tree Calculus Types
|
-- Tree Calculus Types
|
||||||
data T = Leaf | Stem T | Fork T T
|
data T = Leaf | Stem T | Fork T T
|
||||||
@@ -19,7 +20,7 @@ data T = Leaf | Stem T | Fork T T
|
|||||||
|
|
||||||
-- Abstract Syntax Tree for tricu
|
-- Abstract Syntax Tree for tricu
|
||||||
data TricuAST
|
data TricuAST
|
||||||
= SVar String (Maybe String) -- Variable name and optional hash prefix
|
= SVar String (Maybe String)
|
||||||
| SInt Integer
|
| SInt Integer
|
||||||
| SStr String
|
| SStr String
|
||||||
| SList [TricuAST]
|
| SList [TricuAST]
|
||||||
@@ -76,36 +77,21 @@ data Node
|
|||||||
-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
|
-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
|
||||||
serializeNode :: Node -> BS.ByteString
|
serializeNode :: Node -> BS.ByteString
|
||||||
serializeNode NLeaf = BS.pack [0x00]
|
serializeNode NLeaf = BS.pack [0x00]
|
||||||
serializeNode (NStem h) = BS.pack [0x01] <> hexToBytes h
|
serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
|
||||||
serializeNode (NFork l r) = BS.pack [0x02] <> hexToBytes l <> hexToBytes r
|
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 a node per the Merkle content-addressing spec.
|
||||||
-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
|
-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
|
||||||
nodeHash :: Node -> MerkleHash
|
nodeHash :: Node -> MerkleHash
|
||||||
nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node))
|
nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
|
||||||
where sha256WithPrefix payload =
|
where sha256WithPrefix payload =
|
||||||
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
|
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
|
||||||
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
|
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
|
||||||
|
|
||||||
-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte)
|
|
||||||
hexToBytes :: Text -> BS.ByteString
|
|
||||||
hexToBytes h = BS.pack $ map combinePair pairs
|
|
||||||
where
|
|
||||||
chars = unpack h
|
|
||||||
pairs = chunkPairs chars
|
|
||||||
chunkPairs :: String -> [(Char, Char)]
|
|
||||||
chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest
|
|
||||||
chunkPairs [] = []
|
|
||||||
chunkPairs _ = error "hexToBytes: odd number of hex digits"
|
|
||||||
combinePair :: (Char, Char) -> Word8
|
|
||||||
combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2)
|
|
||||||
hexDigitToInt :: Char -> Int
|
|
||||||
hexDigitToInt c
|
|
||||||
| '0' <= c && c <= '9' = ord c - ord '0'
|
|
||||||
| 'a' <= c && c <= 'f' = ord c - ord 'a' + 10
|
|
||||||
| 'A' <= c && c <= 'F' = ord c - ord 'A' + 10
|
|
||||||
| otherwise = error $ "Invalid hex digit: " ++ show c
|
|
||||||
|
|
||||||
-- | Deserialize a Node from canonical bytes.
|
-- | Deserialize a Node from canonical bytes.
|
||||||
deserializeNode :: BS.ByteString -> Node
|
deserializeNode :: BS.ByteString -> Node
|
||||||
deserializeNode bs =
|
deserializeNode bs =
|
||||||
@@ -115,26 +101,69 @@ deserializeNode bs =
|
|||||||
|
|
||||||
Just (0x01, rest)
|
Just (0x01, rest)
|
||||||
| BS.length rest == 32 ->
|
| BS.length rest == 32 ->
|
||||||
NStem $ bytesToHex rest
|
NStem $ decodeUtf8 (encode rest)
|
||||||
|
|
||||||
Just (0x02, rest)
|
Just (0x02, rest)
|
||||||
| BS.length rest == 64 ->
|
| BS.length rest == 64 ->
|
||||||
let (l, r) = BS.splitAt 32 rest
|
let (l, r) = BS.splitAt 32 rest
|
||||||
in NFork (bytesToHex l) (bytesToHex r)
|
in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
|
||||||
|
|
||||||
_ -> error "invalid merkle node payload"
|
_ -> errorWithoutStackTrace "invalid merkle node payload"
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------------
|
||||||
|
-- ByteString / bytestream marshalling via existing Tree Calculus conventions
|
||||||
|
-- ---------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Convert 32-byte ByteString back to hex Text
|
-- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
|
||||||
bytesToHex :: BS.ByteString -> Text
|
ofByte :: Word8 -> T
|
||||||
bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs
|
ofByte = ofNumber . fromIntegral
|
||||||
where
|
|
||||||
byteToHexChars :: Word8 -> String
|
-- | Decode a Tree Calculus number as a single byte (Word8).
|
||||||
byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)]
|
-- Rejects values outside the range 0..255.
|
||||||
hexDigit :: Int -> Char
|
toByte :: T -> Either String Word8
|
||||||
hexDigit n
|
toByte t = case toNumber t of
|
||||||
| n < 10 = chr (ord '0' + n)
|
Left err -> Left err
|
||||||
| otherwise = chr (ord 'a' + n - 10)
|
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.
|
-- | Build a Merkle DAG from a Tree Calculus term.
|
||||||
buildMerkle :: T -> Node
|
buildMerkle :: T -> Node
|
||||||
@@ -158,9 +187,9 @@ buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
|
|||||||
apply :: T -> T -> T
|
apply :: T -> T -> T
|
||||||
apply (Fork Leaf a) _ = a
|
apply (Fork Leaf a) _ = a
|
||||||
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
|
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
|
||||||
apply (Fork (Fork a b) c) Leaf = a
|
apply (Fork (Fork _a _b) _c) Leaf = _a
|
||||||
apply (Fork (Fork a b) c) (Stem u) = apply b u
|
apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
|
||||||
apply (Fork (Fork a b) c) (Fork u v) = apply (apply c u) v
|
apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
|
||||||
-- Left associative `t`
|
-- Left associative `t`
|
||||||
apply Leaf b = Stem b
|
apply Leaf b = Stem b
|
||||||
apply (Stem a) b = Fork a b
|
apply (Stem a) b = Fork a b
|
||||||
@@ -202,7 +231,7 @@ 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 . fromInteger) . 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 []
|
||||||
|
|||||||
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
|
||||||
660
test/Spec.hs
660
test/Spec.hs
@@ -6,16 +6,24 @@ 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 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
|
||||||
@@ -32,8 +40,13 @@ tests = testGroup "Tricu Tests"
|
|||||||
, providedLibraries
|
, providedLibraries
|
||||||
, fileEval
|
, fileEval
|
||||||
, modules
|
, modules
|
||||||
-- , demos
|
, demos
|
||||||
, decoding
|
, decoding
|
||||||
|
, elimLambdaSingle
|
||||||
|
, stressElimLambda
|
||||||
|
, byteMarshallingTests
|
||||||
|
, wireTests
|
||||||
|
, byteListUtilities
|
||||||
]
|
]
|
||||||
|
|
||||||
lexer :: TestTree
|
lexer :: TestTree
|
||||||
@@ -532,7 +545,7 @@ 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 \""
|
||||||
@@ -569,3 +582,646 @@ decoding = testGroup "Decoding Tests"
|
|||||||
let input = ofList [ofList [ofString "nested"], ofString "string"]
|
let input = ofList [ofList [ofString "nested"], ofString "string"]
|
||||||
decodeResult input @?= "[[\"nested\"], \"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
|
||||||
|
]
|
||||||
|
|||||||
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.
52
tricu.cabal
52
tricu.cabal
@@ -1,8 +1,8 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
name: tricu
|
name: tricu
|
||||||
version: 1.0.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,21 +15,33 @@ 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
|
||||||
ScopedTypeVariables
|
ScopedTypeVariables
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
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
|
, aeson
|
||||||
, ansi-terminal
|
, ansi-terminal
|
||||||
|
, base16-bytestring
|
||||||
, base64-bytestring
|
, base64-bytestring
|
||||||
, bytestring
|
, bytestring
|
||||||
, cereal
|
|
||||||
, cmdargs
|
, cmdargs
|
||||||
, containers
|
, containers
|
||||||
, cryptonite
|
, cryptonite
|
||||||
@@ -38,23 +50,32 @@ executable tricu
|
|||||||
, filepath
|
, filepath
|
||||||
, fsnotify
|
, fsnotify
|
||||||
, haskeline
|
, haskeline
|
||||||
|
, http-types
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, memory
|
, memory
|
||||||
, mtl
|
, mtl
|
||||||
|
, servant
|
||||||
, sqlite-simple
|
, sqlite-simple
|
||||||
|
, stm
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hunit
|
, tasty-hunit
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, wai
|
||||||
|
, warp
|
||||||
, zlib
|
, 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
|
||||||
@@ -71,9 +92,9 @@ test-suite tricu-tests
|
|||||||
base >=4.7
|
base >=4.7
|
||||||
, aeson
|
, aeson
|
||||||
, ansi-terminal
|
, ansi-terminal
|
||||||
|
, base16-bytestring
|
||||||
, base64-bytestring
|
, base64-bytestring
|
||||||
, bytestring
|
, bytestring
|
||||||
, cereal
|
|
||||||
, cmdargs
|
, cmdargs
|
||||||
, containers
|
, containers
|
||||||
, cryptonite
|
, cryptonite
|
||||||
@@ -82,21 +103,30 @@ test-suite tricu-tests
|
|||||||
, filepath
|
, filepath
|
||||||
, fsnotify
|
, fsnotify
|
||||||
, haskeline
|
, haskeline
|
||||||
|
, http-types
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, memory
|
, memory
|
||||||
, mtl
|
, mtl
|
||||||
|
, servant
|
||||||
, sqlite-simple
|
, sqlite-simple
|
||||||
|
, stm
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hunit
|
, tasty-hunit
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, warp
|
||||||
|
, wai
|
||||||
, zlib
|
, 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