18 Commits

Author SHA1 Message Date
e8ab61dbaa Data-first recursive consumers in readBytes
Reorder recursive byte-stream consumers so the consumed input is inspected
before loop-control arguments can drive evaluation. Previously, partially
applying `readBytes` to a known count, such as `readBytes 2`, allowed the
evaluator to specialize the recursive worker using known counter values
while the byte stream was still abstract. This caused symbolic recursion
over unknown input and produced an enormous normal form.

The recursive worker now takes the byte stream first and immediately
case-analyzes it. As a result, partial application blocks at the input
boundary instead of unrolling the counter loop.

This preserves the fully-applied behavior of `readBytes`, while making partial
application such as `readBytes 2` normalize safely.
2026-05-07 10:07:43 -05:00
37d57044e2 Idiomatic naming in libs 2026-05-07 08:15:32 -05:00
44ab13c889 Beginning Arborix work in tricu 2026-05-06 20:10:33 -05:00
dee85efabf Tree-native binary processing 2026-05-06 19:36:53 -05:00
89bb73ed99 Tree-native byte processing 2026-05-06 18:53:17 -05:00
1c4c49e68d Byte marshalling 2026-05-06 17:25:42 -05:00
e7a6426060 Support multiple named exports globally
Add multi-root bundle support across the toolchain:
 - `compile`: Accept multiple definition names via `-x NAME` (repeatable or
   comma-separated). Exports all requested definitions as named roots in a
   single bundle. Defaults to "main" when no names are given.
 - `export`: Accept comma-separated hashes in the positional argument and
   multiple `-n`/`names` flags. Exports all resolved roots in one bundle.
 - Server: Add `GET /bundle/roots?n=...&h=...` endpoint that resolves
   multiple stored-term names and/or raw Merkle hashes, returning a single
   bundle containing all of them as roots.
 - Wire: Export `defaultExportNames` helper for generating default export
   names when none are supplied.
 - Drop `cereal` dependency from `tricu.cabal` (no longer used).
2026-05-06 15:30:56 -05:00
7e16607d96 Drop slopdashes and add container build 2026-05-06 14:40:33 -05:00
a36ff638a9 feat: HTTP server for exporting Arborix bundles
Introduces a read-only HTTP server (WAI/Warp) backed by the content
store, exposing three bundle-export endpoints:

- GET /bundle/name/:name   — export by stored term name
- GET /bundle/hash/:hash   — export by full Merkle hash
- GET /terms               — plain-text listing (debug)

Also adds `tricu server` (aka `--serve`) CLI mode, move `resolveExportTarget` /
 `namesForHash` / `looksLikeHash` out of `Main.hs` into `ContentStore.hs`,
and cleans up unused exports and imports across `FileEval.hs` and `Wire.hs`.
2026-05-06 14:22:36 -05:00
0cd849447f Initial JS runtime and Arborix Implementation 2026-05-06 11:50:44 -05:00
fe453b9b96 Wire prepped and basics tested 2026-05-06 08:25:07 -05:00
fb09b4666e Seeded root leaf prep for wire 2026-05-05 19:16:16 -05:00
efbe9350ed Zero Warnings Plan
Zero GHC warnings with new opts. General cleanup and updates.
2026-05-05 18:32:11 -05:00
2627627493 Picking development back up
Merge Kiselyov optimizations and De Bruijn indices
General clean up
2026-05-05 15:56:23 -05:00
c008126b14 Merge branch 'contentstore' 2026-05-05 14:09:42 -05:00
James Eversole
71653311ce Documentation updates 2026-05-05 10:03:15 -05:00
0cdc0bfc34 "size" function nodes down from 454 to 321 2025-08-07 20:08:59 -05:00
c36d963640 Update README to reflect completion of experiment 2025-05-29 13:39:44 -05:00
38 changed files with 5338 additions and 274 deletions

1
.gitignore vendored
View File

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

342
AGENTS.md Normal file
View File

@@ -0,0 +1,342 @@
# 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
```
### 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
```
CRITICAL:
When working with recursion in `tricu` files:
1. Put consumed data first in recursive workers.
2. Let data shape drive recursion.
3. Do not let counters unroll over abstract input.
## 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: 1664 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
```

View File

@@ -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

View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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");
}

View 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
View 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);
}
}

View 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");
});
});

View 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");
});
});

View File

@@ -9,26 +9,28 @@
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 {};
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} = checks.${packageName} = tricuPackage;
haskellPackages.callCabal2nix packageName self rec {}; checks.default = tricuPackage;
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 +41,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 = ''
'';
};
};
}); });
} }

22
lib/arborix.tri Normal file
View File

@@ -0,0 +1,22 @@
!import "base.tri" !Local
!import "list.tri" !Local
!import "bytes.tri" !Local
!import "binary.tri" !Local
arborixMagic = [(65) (82) (66) (79) (82) (73) (88) (0)]
readArborixMagic = (bs : expectBytes arborixMagic bs)
readArborixHeader = (bs :
bindResult (readArborixMagic bs)
(_ afterMagic :
bindResult (readBytes 2 afterMagic)
(majorVersion afterMajor :
bindResult (readBytes 2 afterMajor)
(minorVersion afterMinor :
bindResult (readBytes 4 afterMinor)
(sectionCount afterSectionCount :
ok
(pair majorVersion
(pair minorVersion sectionCount))
afterSectionCount)))))

87
lib/binary.tri Normal file
View File

@@ -0,0 +1,87 @@
!import "base.tri" !Local
!import "list.tri" !Local
!import "bytes.tri" !Local
errUnexpectedEof = 1
errUnexpectedBytes = 2
errUnexpectedByte = 3
ok = value rest : pair true (pair value rest)
err = code rest : pair false (pair code rest)
matchResult = (errCase okCase result :
matchPair
(tag payload :
matchPair
(value rest :
matchBool
(okCase value rest)
(errCase value rest)
tag)
payload)
result)
readU8 = (bytes : matchList
(err errUnexpectedEof t)
(h r : ok h r)
bytes)
readBytes_ = y (self bs n i original acc :
matchList
(matchBool
(ok (reverse acc) bs)
(err errUnexpectedEof original)
(equal? i n))
(h r :
matchBool
(ok (reverse acc) bs)
(self r n (succ i) original (pair h acc))
(equal? i n))
bs)
readBytes = (n bs : readBytes_ bs n 0 bs t)
unit = t
expectBytes_ = y (self expected bs original :
matchList
(ok unit bs)
(expectedByte expectedRest :
matchResult
(code rest : err code original)
(actual rest :
matchBool
(self expectedRest rest original)
(err errUnexpectedBytes original)
(byteEq? actual expectedByte))
(readU8 bs))
expected)
expectBytes = (expected bs : expectBytes_ expected bs bs)
expectU8 = (expected bs :
matchResult
(code rest : err code bs)
(actual rest :
matchBool
(ok unit rest)
(err errUnexpectedByte bs)
(byteEq? actual expected))
(readU8 bs))
mapResult = (f result :
matchResult
(code rest : err code rest)
(value rest : ok (f value) rest)
result)
bindResult = (result f :
matchResult
(code rest : err code rest)
(value rest : f value rest)
result)
read2 = (bs : readBytes 2 bs)
read4 = (bs : readBytes 4 bs)
readU16BEBytes = (bs : read2 bs)
readU32BEBytes = (bs : read4 bs)

49
lib/bytes.tri Normal file
View File

@@ -0,0 +1,49 @@
!import "base.tri" !Local
!import "list.tri" !Local
nothing = t
just = x : t x
bytesNil? = 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)

View File

@@ -0,0 +1,267 @@
# Recursive Consumer Argument Order
## Core issue
Partial application is generally fine in tricu. The problem appears with recursive consumer functions when loop-control arguments are known before the consumed data is available.
The concrete case was `readBytes`.
This worked:
```tricu
(readBytes 2) [(1) (2) (3)]
```
This used to explode in space:
```tricu
readBytes 2
```
At first this looked like a general partial-application problem, but it was not. Other partial applications, such as partially applying `map`, normalized safely. The issue was the argument order and recursive shape of `readBytes_`.
## What went wrong
The original worker had loop-control arguments before the byte stream:
```tricu
readBytes_ = y (self n i bs original acc : ...)
readBytes = (n bs : readBytes_ n 0 bs bs t)
```
After partially applying:
```tricu
readBytes 2
```
the evaluator knew:
```text
n = 2
i = 0
```
but did not know:
```text
bs
original
acc
```
Because the counter values were known, the evaluator could reduce checks like:
```tricu
equal? i n
```
and begin unrolling recursion symbolically before the byte stream existed. That produced a large residual tree describing possible stream cases, rests, and accumulated values.
The bug was not recursion itself. The bug was allowing counters to drive recursion while the consumed structure was still abstract.
## Why `map`-style partial application is safe
A partially-applied list consumer such as:
```tricu
map (i : append i " world!")
```
is safe because recursion is blocked on the missing list argument. The function cannot recurse until it sees whether the list is empty or a cons cell.
Safe shape:
```text
waiting for input
recursion blocked until input is supplied
```
Unsafe shape:
```text
waiting for input
known counters still allow symbolic recursion
```
## Fix
Put the consumed data first in the recursive worker and make the first major operation inspect that data.
Corrected shape:
```tricu
readBytes_ = y (self bs n i original acc :
matchList
(matchBool
(ok (reverse acc) bs)
(err errUnexpectedEof original)
(equal? i n))
(h r :
matchBool
(ok (reverse acc) bs)
(self r n (succ i) original (pair h acc))
(equal? i n))
bs)
readBytes = (n bs : readBytes_ bs n 0 bs t)
```
Now:
```tricu
readBytes 2
```
becomes:
```tricu
bs : readBytes_ bs 2 0 bs t
```
Since `bs` is abstract and the worker immediately performs:
```tricu
matchList ... bs
```
evaluation blocks at the data boundary instead of unrolling the counter loop.
## General rule
For recursive consumers, the consumed structure should drive evaluation.
Prefer:
```tricu
worker = y (self input control state :
matchInput
baseCase
(piece rest : ... self rest control nextState ...)
input)
```
Avoid:
```tricu
worker = y (self control state input :
if controlDone
done
(... self nextControl nextState rest ...))
```
In practice:
```text
worker input control state
```
is safer than:
```text
worker control state input
```
## Accumulators
Be careful not to finalize or transform an abstract accumulator too early.
For example:
```tricu
ok (reverse acc) bs
```
is fine when reached after concrete input has driven the recursion, but it can become pathological if reached while `acc` is still abstract.
Guidelines:
- Accumulate cheaply during recursion.
- Finalize, reverse, or validate only after input has forced the function to a concrete success point.
- Do not let counters select a success branch while the accumulator is still abstract.
## Parser guidance
For byte or parser consumers, prefer streaming over global slicing of unknown input.
Prefer:
```tricu
read one byte
compare or accumulate
recurse on rest
```
Avoid relying on:
```tricu
taken = bytesTake n bs
rest = bytesDrop n bs
enough = bytesLength taken == n
```
The slice-based version may be correct on concrete input but can behave badly when partially applied over abstract input.
Streaming alone is not enough; the recursive worker must also be data-first.
## Checklist
When writing a recursive consumer, ask:
1. What structure is consumed?
2. What argument should block recursion when unknown?
3. Are counters available before the consumed structure?
4. Could partial application specialize the loop before data arrives?
5. Does any branch process an abstract accumulator or rest value?
6. Does the worker put consumed data before counters and state?
## Safe and unsafe examples
Safe:
```tricu
readU8
bs : readU8 bs
readBytes 2 [(1) (2) (3)]
(readBytes 2) [(1) (2) (3)]
map (i : append i " world!")
```
Previously unsafe before the data-first rewrite:
```tricu
readBytes 2
readBytes_ 2 0
```
## Implication for Arborix
Arborix parsers will include many recursive consumers:
- read N bytes
- read N section records
- scan records for an ID
- parse node records
- validate closures
These should use data-first recursive workers.
Avoid:
```tricu
readSectionRecords_ count index bs acc
```
Prefer:
```tricu
readSectionRecords_ bs count index acc
```
## Short rule
```text
Put consumed data first in recursive workers.
Let data shape drive recursion.
Do not let counters unroll over abstract input.
```

View File

@@ -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

View File

@@ -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

View File

@@ -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)

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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]

View File

@@ -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
View 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 = '_'

808
src/Wire.hs Normal file
View File

@@ -0,0 +1,808 @@
{-# 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

File diff suppressed because it is too large Load Diff

BIN
test/fixtures/equalQ.tri.bundle vendored Normal file

Binary file not shown.

BIN
test/fixtures/false.tri.bundle vendored Normal file

Binary file not shown.

BIN
test/fixtures/id.tri.bundle vendored Normal file

Binary file not shown.

2
test/fixtures/notQ.tri vendored Normal file
View File

@@ -0,0 +1,2 @@
\!import "base.tri" _
main = not?

BIN
test/fixtures/notQ.tri.bundle vendored Normal file

Binary file not shown.

BIN
test/fixtures/true.tri.bundle vendored Normal file

Binary file not shown.

View File

@@ -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