Compare commits
38 Commits
feat/elimi
...
d37d443021
| Author | SHA1 | Date | |
|---|---|---|---|
| d37d443021 | |||
| d7a7a8134c | |||
| 8a673e282d | |||
| 1885c9b4ba | |||
| fa58f4ef3a | |||
| e9eb2daaf2 | |||
| 1f72a6969d | |||
| 2e8a0a4c46 | |||
| d0886ad886 | |||
| 2773109b87 | |||
| 6dd4c3e607 | |||
| 343ecbf4c4 | |||
| e3117e3ac8 | |||
| d9f25a2b5a | |||
| a002365651 | |||
| 1d84bf7cfa | |||
| e8ab61dbaa | |||
| 37d57044e2 | |||
| 44ab13c889 | |||
| dee85efabf | |||
| 89bb73ed99 | |||
| 1c4c49e68d | |||
| e7a6426060 | |||
| 7e16607d96 | |||
| a36ff638a9 | |||
| 0cd849447f | |||
| fe453b9b96 | |||
| fb09b4666e | |||
| efbe9350ed | |||
| 2627627493 | |||
| c008126b14 | |||
| 6b97b210ca | |||
|
|
71653311ce | ||
| 72e5810ca9 | |||
| b96a3f2ef0 | |||
| 6780b242b1 | |||
| 94514f7dd0 | |||
| 43e83be9a4 |
2
.gitignore
vendored
2
.gitignore
vendored
@@ -6,6 +6,8 @@
|
||||
/Dockerfile
|
||||
/config.dhall
|
||||
/result
|
||||
/result*
|
||||
.aider*
|
||||
WD
|
||||
bin/
|
||||
dist*
|
||||
|
||||
377
AGENTS.md
Normal file
377
AGENTS.md
Normal file
@@ -0,0 +1,377 @@
|
||||
# AGENTS.md - tricu Project Guide
|
||||
|
||||
> For AI agents and contributors working in this repository.
|
||||
|
||||
## 0. Test Driven Development
|
||||
|
||||
Write and discuss tests with the user before working on implementation code. Do not modify existing tests without explicit permission.
|
||||
|
||||
## 1. Build & Test
|
||||
|
||||
```bash
|
||||
# Haskell tests (default check)
|
||||
nix flake check
|
||||
|
||||
# Zig build
|
||||
nix build .#tricu-zig
|
||||
|
||||
# Zig tests (separate target — not part of nix flake check)
|
||||
nix build .#tricu-zig-tests
|
||||
|
||||
# Full build
|
||||
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 (Haskell)
|
||||
|
||||
| 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` | Arboricx portable wire format — encode/decode/import/export of Merkle-DAG bundle blobs |
|
||||
|
||||
### Multi-language Arboricx ecosystem
|
||||
|
||||
Arboricx is the portable executable-object format used by tricu. The project now includes native parsing and execution in multiple languages:
|
||||
|
||||
| Language | Location | Capabilities |
|
||||
|----------|----------|--------------|
|
||||
| **Haskell** | `src/Wire.hs`, `src/Research.hs` | Reference implementation — bundle encode/decode, content store, full Tree Calculus reduction |
|
||||
| **tricu (self-hosted)** | `kernel_run_arboricx_typed.dag` | A self-hosting Arboricx parser/executor written in tricu itself. Used as a kernel inside the Zig host for maximum portability ("cool but useless" — ~3s for `append`) |
|
||||
| **Zig** | `ext/zig/` | **Production host** — native bundle parser, WHNF reducer, C ABI (`libarboricx.so` / `.a`), CLI (`tricu-zig`), Python FFI support |
|
||||
| **JavaScript (Node)** | `ext/js/` | Native bundle parser, manifest decoder, Merkle DAG verifier, Tree Calculus reducer, CLI runner |
|
||||
| **PHP** | `ext/php/` | FFI wrapper around `libarboricx.so`, CLI runner |
|
||||
|
||||
All hosts share the same bundle format and Merkle hashing scheme.
|
||||
|
||||
### File extensions
|
||||
|
||||
- `.hs` - Haskell source
|
||||
- `.tri` - tricu language source (used in `lib/`, `test/`, `demos/`)
|
||||
- `.arboricx` - Portable executable bundle
|
||||
- `.dag` - Serialized kernel DAG (used by `gen_kernel.zig` at build time)
|
||||
|
||||
## 3. Test Suite
|
||||
|
||||
### Haskell tests
|
||||
|
||||
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 |
|
||||
|
||||
### Zig tests
|
||||
|
||||
Run separately via:
|
||||
|
||||
```bash
|
||||
nix build .#tricu-zig-tests
|
||||
```
|
||||
|
||||
These are **not** included in `nix flake check`. The test derivation compiles and runs:
|
||||
|
||||
| Test | What it covers |
|
||||
|------|----------------|
|
||||
| `c_abi_test.c` | Smoke tests — leaf, stem, fork, app, reduce, number/string roundtrip, kernel root |
|
||||
| `c_abi_append_test.c` | Kernel path — `append.arboricx` with string arguments via Tricu kernel |
|
||||
| `native_bundle_append_test.c` | Native fast path — `append.arboricx` loaded natively, applied, reduced |
|
||||
| `native_bundle_id_test.c` | Native fast path — `id.arboricx` |
|
||||
| `native_bundle_bools_test.c` | Native fast path — `true.arboricx` / `false.arboricx` |
|
||||
| `python_ffi_test.py` | Python ctypes FFI — tests both kernel and native paths for `id` and `append` |
|
||||
|
||||
## 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("arboricx.merkle.node.v1" <> 0x00 <> serialized_node)
|
||||
```
|
||||
|
||||
This is stored in SQLite via `ContentStore.hs`. Hash suffixes on identifiers (e.g., `foo_abc123...`) are validated: 16–64 hex characters (SHA256).
|
||||
|
||||
## 7. Arboricx Portable Bundles (`.arboricx`)
|
||||
|
||||
Portable executable bundles are generated via `Wire.hs`. See `docs/arboricx-bundle-format.md` for the full binary format spec.
|
||||
|
||||
```bash
|
||||
# Export a bundle from the content store
|
||||
./result/bin/tricu export -o myterm.arboricx myterm
|
||||
|
||||
# Run a bundle (requires TRICU_DB_PATH)
|
||||
./result/bin/tricu import -f lib/list.tri
|
||||
TRICU_DB_PATH=/tmp/tricu.db ./result/bin/tricu export -o list_ops.arboricx append
|
||||
```
|
||||
|
||||
## 8. Zig Arboricx Host (`ext/zig/`)
|
||||
|
||||
The Zig host is a fast implementation for running Arboricx bundles. It provides a native bundle parser and arena-based evaluator.
|
||||
|
||||
### Modules
|
||||
|
||||
| File | Role |
|
||||
|------|------|
|
||||
| `src/main.zig` | CLI entrypoint — default native path, `--kernel` fallback |
|
||||
| `src/bundle.zig` | Native Arboricx bundle parser — verifies digests, hashes, loads DAG into arena |
|
||||
| `src/c_abi.zig` | C FFI exports — `arboricx_init`, tree constructors, codecs, reduction, bundle loading |
|
||||
| `src/reduce.zig` | WHNF reducer (Tree Calculus `apply` rules) |
|
||||
| `src/arena.zig` | Node arena (`ArrayListUnmanaged`) |
|
||||
| `src/tree.zig` | `Node` union + iterative `copyTree` |
|
||||
| `src/codecs.zig` | Number/string/list/bytes encoding + result unwrapping |
|
||||
| `src/kernel.zig` | Embeds DAG kernel into arena (fallback path only) |
|
||||
| `src/ternary.zig` | Ternary string parser for Tree Calculus terms |
|
||||
| `tools/gen_kernel.zig` | Build-time tool: converts `.dag` → `kernel_embed.zig` |
|
||||
| `include/arboricx.h` | C header for `libarboricx` |
|
||||
|
||||
### C ABI
|
||||
|
||||
Key functions:
|
||||
|
||||
```c
|
||||
arb_ctx_t* arboricx_init(void);
|
||||
uint32_t arb_load_bundle(arb_ctx_t*, const uint8_t* bytes, size_t len, const char* name);
|
||||
uint32_t arb_load_bundle_default(arb_ctx_t*, const uint8_t* bytes, size_t len);
|
||||
uint32_t arb_reduce(arb_ctx_t*, uint32_t root, uint64_t fuel);
|
||||
```
|
||||
|
||||
`arb_reduce` evaluates in a **fresh scratch arena** so garbage never accumulates.
|
||||
|
||||
### Stack size requirement
|
||||
|
||||
Tree Calculus reduction is deeply recursive. Assume a segfault is a memory limitation until proven otherwise.
|
||||
|
||||
```bash
|
||||
ulimit -s 32768 # 32 MB
|
||||
```
|
||||
|
||||
### Performance comparison
|
||||
|
||||
| Fixture | Native path | Kernel path (`--kernel`) |
|
||||
|---------|-------------|--------------------------|
|
||||
| `append "hello " "world"` | **~0.007 s** | ~3.4 s |
|
||||
| `id "hello"` | **~0.005 s** | ~0.38 s |
|
||||
|
||||
The kernel path is kept as a "cool but useless" fallback — the DAG is tiny (~30 KB) so the cost is negligible.
|
||||
|
||||
## 9. Nix Flake Outputs
|
||||
|
||||
| Output | Description |
|
||||
|--------|-------------|
|
||||
| `packages.default` / `packages.tricu` | Haskell tricu package |
|
||||
| `packages.tricu-zig` | Zig CLI + `libarboricx.a` + `libarboricx.so` + `arboricx.h` |
|
||||
| `packages.tricu-zig-tests` | **Separate test target** — C ABI + native bundle + Python FFI tests |
|
||||
| `packages.tricu-php` | PHP source + `libarboricx.so` + `tricu-php` wrapper script |
|
||||
| `packages.tricu-php-tests` | **Separate test target** — PHP FFI tests against fixture bundles |
|
||||
| `packages.tricu-container` | Docker image |
|
||||
| `checks.default` / `checks.tricu` | Haskell test suite via Tasty/HUnit |
|
||||
|
||||
`tricu-zig-tests` is deliberately **not** in `checks` so `nix flake check` remains fast.
|
||||
|
||||
## 10. Directory Layout
|
||||
|
||||
```
|
||||
tricu/
|
||||
├── flake.nix # Nix flake: packages, tests, devShell
|
||||
├── tricu.cabal # Cabal package (used via callCabal2nix)
|
||||
├── AGENTS.md # This file
|
||||
├── src/ # Haskell modules
|
||||
│ ├── Main.hs
|
||||
│ ├── Eval.hs
|
||||
│ ├── Parser.hs
|
||||
│ ├── Lexer.hs
|
||||
│ ├── FileEval.hs
|
||||
│ ├── REPL.hs
|
||||
│ ├── Research.hs
|
||||
│ ├── ContentStore.hs
|
||||
│ └── Wire.hs
|
||||
├── test/
|
||||
│ ├── Spec.hs # Tasty + HUnit tests
|
||||
│ ├── *.tri # tricu test programs
|
||||
│ ├── *.arboricx # Arboricx bundle fixtures
|
||||
│ └── local-ns/ # Module namespace test files
|
||||
├── lib/
|
||||
│ ├── base.tri
|
||||
│ ├── list.tri
|
||||
│ └── patterns.tri
|
||||
├── demos/
|
||||
│ ├── equality.tri
|
||||
│ ├── size.tri
|
||||
│ ├── toSource.tri
|
||||
│ ├── levelOrderTraversal.tri
|
||||
│ └── patternMatching.tri
|
||||
├── ext/ # Multi-language Arboricx hosts
|
||||
│ ├── js/ # Node.js bundle parser + reducer
|
||||
│ │ ├── src/
|
||||
│ │ │ ├── bundle.js
|
||||
│ │ │ ├── manifest.js
|
||||
│ │ │ ├── merkle.js
|
||||
│ │ │ ├── tree.js
|
||||
│ │ │ ├── codecs.js
|
||||
│ │ │ └── cli.js
|
||||
│ │ └── test/
|
||||
│ ├── php/ # PHP FFI host for libarboricx.so
|
||||
│ │ ├── src/
|
||||
│ │ │ └── ffi.php
|
||||
│ │ └── run.php
|
||||
│ └── zig/ # Zig production host
|
||||
│ ├── build.zig
|
||||
│ ├── build.zig.zon
|
||||
│ ├── kernel_run_arboricx_typed.dag
|
||||
│ ├── include/arboricx.h
|
||||
│ ├── src/
|
||||
│ │ ├── main.zig
|
||||
│ │ ├── bundle.zig
|
||||
│ │ ├── c_abi.zig
|
||||
│ │ ├── codecs.zig
|
||||
│ │ ├── kernel.zig
|
||||
│ │ ├── reduce.zig
|
||||
│ │ ├── arena.zig
|
||||
│ │ ├── tree.zig
|
||||
│ │ └── ternary.zig
|
||||
│ ├── tests/
|
||||
│ │ ├── c_abi_test.c
|
||||
│ │ ├── c_abi_append_test.c
|
||||
│ │ ├── native_bundle_append_test.c
|
||||
│ │ ├── native_bundle_id_test.c
|
||||
│ │ ├── native_bundle_bools_test.c
|
||||
│ │ └── python_ffi_test.py
|
||||
│ └── tools/
|
||||
│ └── gen_kernel.zig
|
||||
└── docs/
|
||||
└── arboricx-bundle-format.md
|
||||
```
|
||||
|
||||
## 11. 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).
|
||||
|
||||
## 12. Development Tips
|
||||
|
||||
- **REPL:** `nix run .#` starts the interactive tricu REPL.
|
||||
- **Evaluate files:** `nix run .# -- eval -f demos/equality.tri`
|
||||
- **Zig host:** `nix build .#tricu-zig` then `./result/bin/tricu-zig <bundle> [args...]`
|
||||
- **Zig tests:** `nix build .#tricu-zig-tests`
|
||||
- **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.
|
||||
|
||||
## 13. 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
|
||||
```
|
||||
64
README.md
64
README.md
@@ -2,17 +2,17 @@
|
||||
|
||||
## Introduction
|
||||
|
||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included.
|
||||
|
||||
*This experiment has concluded. tricu will see no further development or bugfixes.*
|
||||
tricu (pronounced "tree-shoe") is a programming language experiment in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf), but minimal syntax sugar is included.
|
||||
|
||||
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.
|
||||
|
||||
This README.md is human written. No other .md file will be until stabilization.
|
||||
|
||||
## Acknowledgements
|
||||
|
||||
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
|
||||
|
||||
[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus.
|
||||
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.
|
||||
|
||||
## REPL examples
|
||||
|
||||
@@ -36,15 +36,21 @@ tricu < -- or calculate its size (/demos/size.tri)
|
||||
tricu < size not?
|
||||
tricu > 12
|
||||
|
||||
tricu < -- REPL Commands:
|
||||
tricu < !definitions -- Lists all available definitions
|
||||
tricu < !output -- Change output format (Tree, FSL, AST, etc.)
|
||||
tricu < !import -- Import definitions from a file
|
||||
tricu < !exit -- Exit the REPL
|
||||
tricu < !clear -- ANSI screen clear
|
||||
tricu < !save -- Save all REPL definitions to a file that you can !import
|
||||
tricu < !reset -- Clear all REPL definitions
|
||||
tricu < !version -- Print tricu version
|
||||
tricu < !help
|
||||
tricu version 1.1.0
|
||||
Available commands:
|
||||
!exit - Exit the REPL
|
||||
!clear - Clear the screen
|
||||
!reset - Reset preferences for selected versions
|
||||
!help - Show tricu version and available commands
|
||||
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
|
||||
!definitions - List all defined terms in the content store
|
||||
!import - Import definitions from file to the content store
|
||||
!watch - Watch a file for changes, evaluate terms, and store them
|
||||
!refresh - Refresh environment from content store (definitions are live)
|
||||
!versions - Show all versions of a term by name
|
||||
!select - Select a specific version of a term for subsequent lookups
|
||||
!tag - Add or update a tag for a term by hash or name
|
||||
```
|
||||
|
||||
## Installation and Use
|
||||
@@ -58,30 +64,6 @@ You can easily build and run this project using [Nix](https://nixos.org/download
|
||||
|
||||
`./result/bin/tricu --help`
|
||||
|
||||
```
|
||||
tricu Evaluator and REPL
|
||||
## Usage
|
||||
|
||||
tricu [COMMAND] ... [OPTIONS]
|
||||
tricu: Exploring Tree Calculus
|
||||
|
||||
Common flags:
|
||||
-? --help Display help message
|
||||
-V --version Print version information
|
||||
|
||||
tricu [repl] [OPTIONS]
|
||||
Start interactive REPL
|
||||
|
||||
tricu eval [OPTIONS]
|
||||
Evaluate tricu and return the result of the final expression.
|
||||
|
||||
-f --file=FILE Input file path(s) for evaluation.
|
||||
Defaults to stdin.
|
||||
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii|decode).
|
||||
Defaults to tricu-compatible `t` tree form.
|
||||
|
||||
tricu decode [OPTIONS]
|
||||
Decode a Tree Calculus value into a string representation.
|
||||
|
||||
-f --file=FILE Optional input file path to attempt decoding.
|
||||
Defaults to stdin.
|
||||
```
|
||||
I'll update this once the CLI stabilizes more.
|
||||
|
||||
419
docs/arboricx-bundle-format.md
Normal file
419
docs/arboricx-bundle-format.md
Normal file
@@ -0,0 +1,419 @@
|
||||
# Arboricx Portable Bundle Format Specification
|
||||
|
||||
**Version:** 0.1
|
||||
**Status:** Exploratory
|
||||
**Author:** A range of slopmachines guided by James Eversole
|
||||
**Human Review Status:** 5 minute scan-through - this is an evolving and malleable document
|
||||
|
||||
The Arboricx Portable Bundle is a self-contained, content-addressed binary format for distributing Tree Calculus programs and their associated Merkle DAGs. It provides:
|
||||
|
||||
- A fixed binary container with header, section directory, and typed sections
|
||||
- A language-neutral Merkle node layer for content-addressed tree values
|
||||
- A fixed-order binary manifest for semantic metadata, exports, and optional extensions
|
||||
|
||||
## Table of Contents
|
||||
|
||||
1. [Top-Level Container Layout](#1-top-level-container-layout)
|
||||
2. [Header](#2-header)
|
||||
3. [Section Directory](#3-section-directory)
|
||||
4. [Section: Manifest (type 1)](#4-section-manifest-type-1)
|
||||
5. [Section: Nodes (type 2)](#5-section-nodes-type-2)
|
||||
6. [Merkle Node Payload Format](#6-merkle-node-payload-format)
|
||||
7. [Merkle Hash Computation](#7-merkle-hash-computation)
|
||||
8. [Tree Calculus Reduction Semantics](#8-tree-calculus-reduction-semantics)
|
||||
9. [Binary Primitives](#9-binary-primitives)
|
||||
10. [Bundle Verification](#10-bundle-verification)
|
||||
11. [Known Section Types](#11-known-section-types)
|
||||
|
||||
---
|
||||
|
||||
## 1. Top-Level Container Layout
|
||||
|
||||
An Arboricx bundle is a flat binary blob with the following layout:
|
||||
|
||||
```
|
||||
+------------------+------------------+------------------+------------------+
|
||||
| Header | Section Directory| Manifest Section | Nodes Section |
|
||||
| (32 bytes) | (N × 60 bytes) | (variable) | (variable) |
|
||||
+------------------+------------------+------------------+------------------+
|
||||
```
|
||||
|
||||
The container uses **big-endian** byte order for all multi-byte integers.
|
||||
|
||||
Total bundle size = 32 + (sectionCount × 60) + manifestSize + nodesSize
|
||||
|
||||
---
|
||||
|
||||
## 2. Header
|
||||
|
||||
| Offset | Size | Field | Description |
|
||||
|--------|------|-------|-------------|
|
||||
| 0 | 8 bytes | Magic | ASCII `"ARBORICX"` (`0x41 0x52 0x42 0x4F 0x52 0x49 0x43 0x58`) |
|
||||
| 8 | 2 bytes | Major version | `u16` BE. Currently `1` |
|
||||
| 10 | 2 bytes | Minor version | `u16` BE. Currently `0` |
|
||||
| 12 | 4 bytes | Section count | `u32` BE. Number of entries in the section directory |
|
||||
| 16 | 8 bytes | Flags | `u64` BE. Reserved; currently all zeros |
|
||||
| 24 | 8 bytes | Directory offset | `u64` BE. Byte offset from the start of the bundle to the section directory |
|
||||
|
||||
**Constraints:**
|
||||
- Major version must be `1`. Bundles with unsupported major versions are rejected.
|
||||
- The directory offset must point to a valid location within the bundle.
|
||||
- The directory offset is always `32` for bundles with the current layout (header immediately followed by the directory).
|
||||
|
||||
---
|
||||
|
||||
## 3. Section Directory
|
||||
|
||||
The section directory is an array of `N` entries, where `N` is the section count from the header. Each entry is exactly **60 bytes**.
|
||||
|
||||
| Offset (within entry) | Size | Field | Description |
|
||||
|----------------------|------|-------|-------------|
|
||||
| 0 | 4 bytes | Type | `u32` BE. Section type identifier (see [Known Section Types](#11-known-section-types)) |
|
||||
| 4 | 2 bytes | Version | `u16` BE. Section-specific version |
|
||||
| 6 | 2 bytes | Flags | `u16` BE. Bit flags: bit 0 (`0x0001`) = critical section |
|
||||
| 8 | 2 bytes | Compression | `u16` BE. Compression codec (currently only `0` = none) |
|
||||
| 10 | 2 bytes | Digest algorithm | `u16` BE. Hash algorithm (currently only `1` = SHA-256) |
|
||||
| 12 | 8 bytes | Offset | `u64` BE. Byte offset from the start of the bundle to the section data |
|
||||
| 20 | 8 bytes | Length | `u64` BE. Length of the section data in bytes |
|
||||
| 28 | 32 bytes | SHA-256 digest | Raw digest of the section data |
|
||||
|
||||
**Verification:**
|
||||
- Unknown critical sections (flags & `0x0001`) are rejected.
|
||||
- Compression must be `0` (none).
|
||||
- Digest algorithm must be `1` (SHA-256).
|
||||
- The SHA-256 digest in the directory entry must match `SHA256(section_data)`.
|
||||
|
||||
---
|
||||
|
||||
## 4. Section: Manifest (type 1)
|
||||
|
||||
The manifest is a binary encoding of bundle metadata. It uses a **fixed-order core** layout followed by an optional **TLV tail** for extensibility.
|
||||
|
||||
### 4.1 Format
|
||||
|
||||
```
|
||||
Manifest =
|
||||
magic 8 bytes "ARBMNFST"
|
||||
major u16 BE Manifest major version (1)
|
||||
minor u16 BE Manifest minor version (0)
|
||||
|
||||
schema string Length-prefixed UTF-8 text
|
||||
bundleType string Length-prefixed UTF-8 text
|
||||
|
||||
treeCalculus string Length-prefixed UTF-8 text
|
||||
treeHashAlgorithm string Length-prefixed UTF-8 text
|
||||
treeHashDomain string Length-prefixed UTF-8 text
|
||||
treeNodePayload string Length-prefixed UTF-8 text
|
||||
|
||||
runtimeSemantics string Length-prefixed UTF-8 text
|
||||
runtimeEvaluation string Length-prefixed UTF-8 text
|
||||
runtimeAbi string Length-prefixed UTF-8 text
|
||||
capabilityCount u32 BE Number of capability strings
|
||||
capabilities string[] Array of length-prefixed UTF-8 capability strings
|
||||
|
||||
closure u8 0 = complete, 1 = partial
|
||||
rootCount u32 BE Number of root entries
|
||||
roots Root[] Array of root entries
|
||||
exportCount u32 BE Number of export entries
|
||||
exports Export[] Array of export entries
|
||||
|
||||
metadataFieldCount u32 BE Number of metadata TLV entries
|
||||
metadataFields TLV[] Metadata tag-value entries
|
||||
extensionFieldCount u32 BE Number of extension TLV entries
|
||||
extensionFields TLV[] Extension tag-value entries (skipped by parsers)
|
||||
```
|
||||
|
||||
**Trailing bytes after the manifest must be zero** (no leftover data).
|
||||
|
||||
### 4.2 String Format
|
||||
|
||||
Every `string` field uses the same encoding:
|
||||
|
||||
```
|
||||
string =
|
||||
length u32 BE Number of UTF-8 bytes in the string (not the number of characters)
|
||||
bytes byte[length] UTF-8 encoded string content
|
||||
```
|
||||
|
||||
The length field carries the byte count, so parsers can skip strings without decoding UTF-8.
|
||||
|
||||
### 4.3 Root Entry
|
||||
|
||||
```
|
||||
Root =
|
||||
hash 32 bytes Raw SHA-256 hash of the Merkle node
|
||||
role string Length-prefixed UTF-8 text ("default" for the first root, "root" for others)
|
||||
```
|
||||
|
||||
The hash is stored as **raw bytes** (not hex-encoded). It corresponds to the Merkle hash of the node.
|
||||
|
||||
### 4.4 Export Entry
|
||||
|
||||
```
|
||||
Export =
|
||||
name string Length-prefixed UTF-8 text (export identifier)
|
||||
root 32 bytes Raw SHA-256 hash of the Merkle node
|
||||
kind string Length-prefixed UTF-8 text (currently "term")
|
||||
abi string Length-prefixed UTF-8 text (ABI string)
|
||||
```
|
||||
|
||||
### 4.5 TLV Entry
|
||||
|
||||
```
|
||||
TLV =
|
||||
tag u16 BE Tag identifier (type)
|
||||
length u32 BE Number of bytes in the value
|
||||
value byte[length] Raw bytes
|
||||
```
|
||||
|
||||
TLV entries support variable-length values and are skippable by parsers that do not recognize a tag: read the `u32` length and advance by `2 + 4 + length` bytes.
|
||||
|
||||
### 4.6 Metadata Tags
|
||||
|
||||
| Tag | Name | Value |
|
||||
|-----|------|-------|
|
||||
| 1 | package | UTF-8 text: package name |
|
||||
| 2 | version | UTF-8 text: version string |
|
||||
| 3 | description | UTF-8 text: description |
|
||||
| 4 | license | UTF-8 text: license identifier or text |
|
||||
| 5 | createdBy | UTF-8 text: creator identifier |
|
||||
|
||||
Unknown metadata tags are ignored. Unknown extension tags are skipped by length.
|
||||
|
||||
### 4.7 Semantic Constraints
|
||||
|
||||
A valid bundle manifest must satisfy:
|
||||
|
||||
| Constraint | Value |
|
||||
|-----------|-------|
|
||||
| `schema` | `"arboricx.bundle.manifest.v1"` |
|
||||
| `bundleType` | `"tree-calculus-executable-object"` |
|
||||
| `treeCalculus` | `"tree-calculus.v1"` |
|
||||
| `treeHashAlgorithm` | `"sha256"` |
|
||||
| `treeHashDomain` | `"arboricx.merkle.node.v1"` |
|
||||
| `treeNodePayload` | `"arboricx.merkle.payload.v1"` |
|
||||
| `runtimeSemantics` | `"tree-calculus.v1"` |
|
||||
| `runtimeAbi` | `"arboricx.abi.tree.v1"` |
|
||||
| `runtimeCapabilities` | Empty array |
|
||||
| `closure` | `0` (complete) |
|
||||
| `rootCount` | At least 1 |
|
||||
| `exportCount` | At least 1 |
|
||||
| Export names | Non-empty |
|
||||
| Export roots | Non-empty (32 bytes each) |
|
||||
|
||||
---
|
||||
|
||||
## 5. Section: Nodes (type 2)
|
||||
|
||||
The nodes section contains all Merkle DAG nodes referenced by the manifest. It is a sequence of node entries preceded by a count.
|
||||
|
||||
```
|
||||
NodesSection =
|
||||
nodeCount u64 BE Total number of node entries
|
||||
entries NodeEntry[]
|
||||
```
|
||||
|
||||
Each node entry:
|
||||
|
||||
```
|
||||
NodeEntry =
|
||||
hash 32 bytes Raw SHA-256 hash of this node
|
||||
payloadLen u32 BE Length of the payload in bytes
|
||||
payload byte[payloadLen] Node payload (see Section 6)
|
||||
```
|
||||
|
||||
The node count is `u64` to support large bundles. Entries are stored in the order produced by the exporter (typically sorted by hash for determinism).
|
||||
|
||||
---
|
||||
|
||||
## 6. Merkle Node Payload Format
|
||||
|
||||
Each node in the Merkle DAG is one of three types. The payload is a single byte type tag followed by hash references:
|
||||
|
||||
### Leaf
|
||||
|
||||
```
|
||||
Payload = 0x00
|
||||
```
|
||||
|
||||
A leaf has no children. The payload is exactly 1 byte.
|
||||
|
||||
### Stem
|
||||
|
||||
```
|
||||
Payload = 0x01 || child_hash (32 bytes raw)
|
||||
```
|
||||
|
||||
A stem has exactly one child. The payload is 33 bytes.
|
||||
|
||||
### Fork
|
||||
|
||||
```
|
||||
Payload = 0x02 || left_hash (32 bytes raw) || right_hash (32 bytes raw)
|
||||
```
|
||||
|
||||
A fork has exactly two children. The payload is 65 bytes.
|
||||
|
||||
**Validation:**
|
||||
- Leaf payloads must be exactly 1 byte (`0x00`).
|
||||
- Stem payloads must be exactly 33 bytes.
|
||||
- Fork payloads must be exactly 65 bytes.
|
||||
- Unknown type bytes are rejected.
|
||||
|
||||
---
|
||||
|
||||
## 7. Merkle Hash Computation
|
||||
|
||||
Each node is identified by a SHA-256 hash of its canonical payload:
|
||||
|
||||
```
|
||||
hash = SHA256( domain_tag || 0x00 || payload )
|
||||
```
|
||||
|
||||
Where:
|
||||
|
||||
| Component | Value |
|
||||
|-----------|-------|
|
||||
| `domain_tag` | `"arboricx.merkle.node.v1"` as UTF-8 bytes |
|
||||
| Separator | `0x00` (one zero byte) |
|
||||
| `payload` | The node's canonical serialization from Section 6 |
|
||||
|
||||
**Examples:**
|
||||
|
||||
- **Leaf:** `SHA256("arboricx.merkle.node.v1" || 0x00 || 0x00)`
|
||||
- **Stem:** `SHA256("arboricx.merkle.node.v1" || 0x00 || 0x01 || child_hash_bytes)`
|
||||
- **Fork:** `SHA256("arboricx.merkle.node.v1" || 0x00 || 0x02 || left_hash_bytes || right_hash_bytes)`
|
||||
|
||||
The resulting SHA-256 hash is stored as a hex-encoded string in the manifest (64 hex characters). Within the nodes section, it is stored as raw bytes.
|
||||
|
||||
---
|
||||
|
||||
## 8. Tree Calculus Reduction Semantics
|
||||
|
||||
The bundle represents a **Tree Calculus** term as a Merkle DAG. The reduction rules are:
|
||||
|
||||
### Apply 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)
|
||||
```
|
||||
|
||||
### Internal Representation
|
||||
|
||||
In the reduction engine, Fork nodes use a `[right, left]` (stack) ordering:
|
||||
- `Fork = [right_child, left_child]`
|
||||
- `Stem = [child]`
|
||||
- `Leaf = []`
|
||||
|
||||
This ordering supports stack-based reduction: pop two terms, apply, push results back.
|
||||
|
||||
### Closure
|
||||
|
||||
The bundle declares `closure = "complete"`, meaning all nodes reachable from export roots are present in the nodes section. No external references exist.
|
||||
|
||||
---
|
||||
|
||||
## 9. Binary Primitives
|
||||
|
||||
All multi-byte integers use **big-endian** byte order.
|
||||
|
||||
### u16 (2 bytes)
|
||||
|
||||
```
|
||||
byte[0] | byte[1]
|
||||
value = (byte[0] << 8) | byte[1]
|
||||
```
|
||||
|
||||
### u32 (4 bytes)
|
||||
|
||||
```
|
||||
byte[0] | byte[1] | byte[2] | byte[3]
|
||||
value = (byte[0] << 24) | (byte[1] << 16) | (byte[2] << 8) | byte[3]
|
||||
```
|
||||
|
||||
### u64 (8 bytes)
|
||||
|
||||
```
|
||||
byte[0] ... byte[7]
|
||||
value = (byte[0] << 56) | ... | byte[7]
|
||||
```
|
||||
|
||||
### u8 (1 byte)
|
||||
|
||||
A single byte, value `0-255`.
|
||||
|
||||
---
|
||||
|
||||
## 10. Bundle Verification
|
||||
|
||||
A complete bundle verification proceeds in this order:
|
||||
|
||||
1. **Magic check:** First 8 bytes must be `"ARBORICX"`.
|
||||
2. **Version check:** Major version must be `1`.
|
||||
3. **Section directory:** Parse all entries; reject unknown critical sections.
|
||||
4. **Digest verification:** For each section, compute `SHA256(section_data)` and compare with the digest in the directory entry.
|
||||
5. **Manifest parsing:** Decode the fixed-order manifest; validate semantic constraints.
|
||||
6. **Node section:** Parse all node entries; reject duplicates.
|
||||
7. **Root verification:** All root hashes from the manifest must exist in the node map.
|
||||
8. **Export verification:** All export root hashes must exist in the node map.
|
||||
9. **Node hash verification:** For each node, compute `SHA256(domain || 0x00 || payload)` and compare with the stored hash.
|
||||
10. **Children verification:** For each Stem/Fork node, both child hashes must exist in the node map.
|
||||
11. **Closure verification:** Starting from each root hash, traverse the DAG and confirm all reachable nodes are present.
|
||||
|
||||
---
|
||||
|
||||
## 11. Known Section Types
|
||||
|
||||
| Type | Name | Required | Version | Description |
|
||||
|------|------|----------|---------|-------------|
|
||||
| 1 | Manifest | Yes | 1 | Bundle metadata in fixed-order binary format |
|
||||
| 2 | Nodes | Yes | 1 | Merkle DAG node entries |
|
||||
|
||||
Unknown section types are permitted if not marked as critical (flags bit 0 is not set).
|
||||
|
||||
---
|
||||
|
||||
## Appendix A: Complete Example Layout (id.arboricx)
|
||||
|
||||
A minimal `id.arboricx` bundle has:
|
||||
|
||||
```
|
||||
+---------------------------------------------------+
|
||||
| Header (32 bytes) |
|
||||
| Magic: "ARBORICX" |
|
||||
| Major: 1, Minor: 0 |
|
||||
| Section count: 2 |
|
||||
| Flags: 0 |
|
||||
| Dir offset: 32 |
|
||||
+---------------------------------------------------+
|
||||
| Section Directory (120 bytes = 2 × 60) |
|
||||
| Entry 0: type=1 (manifest), offset=152, len=375 |
|
||||
| Entry 1: type=2 (nodes), offset=527, len=284 |
|
||||
+---------------------------------------------------+
|
||||
| Manifest Section (375 bytes) |
|
||||
| Magic: "ARBMNFST" |
|
||||
| Version: 1.0 |
|
||||
| Core strings (schema, bundleType, tree spec, |
|
||||
| runtime spec, capabilities, closure, roots, |
|
||||
| exports, metadata TLVs, extension fields) |
|
||||
+---------------------------------------------------+
|
||||
| Nodes Section (284 bytes) |
|
||||
| Node count: 2 |
|
||||
| Node entry 1: hash + payload (Leaf) |
|
||||
| Node entry 2: hash + payload (Fork) |
|
||||
+---------------------------------------------------+
|
||||
```
|
||||
|
||||
The manifest section starts at byte 152 (0x98) and the nodes section at byte 527 (0x20F).
|
||||
|
||||
---
|
||||
|
||||
## Appendix B: File Extension
|
||||
|
||||
Bundles produced by the `tricu` tool use the `.arboricx` file extension. The `.tri` extension is used for plain source files; the `.arboricx` extension identifies the portable binary format.
|
||||
247
docs/host-abi.md
Normal file
247
docs/host-abi.md
Normal file
@@ -0,0 +1,247 @@
|
||||
# tricu Host ABI
|
||||
|
||||
This document specifies the first host-facing ABI for self-hosted Arboricx execution.
|
||||
|
||||
The ABI is intentionally small. A host language should only need to implement Tree Calculus construction/reduction plus a tiny set of canonical payload codecs. Higher-level execution policy lives in Tree Calculus.
|
||||
|
||||
## Goals
|
||||
|
||||
- Keep host-language implementations small and auditable.
|
||||
- Preserve canonical Tree Calculus representations for payloads.
|
||||
- Provide a stable tagged envelope so hosts do not need per-application result conventions.
|
||||
- Reuse the existing `ok` / `err` result protocol.
|
||||
- Support typed execution wrappers for common return types.
|
||||
|
||||
## Non-goals
|
||||
|
||||
- This ABI does not remove the need for host codecs entirely.
|
||||
- This ABI does not define every possible application protocol.
|
||||
- This ABI does not require auto-detecting arbitrary result types.
|
||||
|
||||
## Outer result protocol
|
||||
|
||||
Host ABI runners return the existing tricu result shape from `lib/binary.tri`:
|
||||
|
||||
```tricu
|
||||
ok value rest = pair true (pair value rest)
|
||||
err code rest = pair false (pair code rest)
|
||||
```
|
||||
|
||||
On success, `value` is a host ABI value.
|
||||
|
||||
On failure, `code` is a canonical Tree Calculus number. The host may report the numeric code and optionally inspect `rest` for debugging.
|
||||
|
||||
## Host ABI value shape
|
||||
|
||||
A host ABI value is:
|
||||
|
||||
```tricu
|
||||
pair tag payload
|
||||
```
|
||||
|
||||
The `tag` says how the host should interpret `payload`.
|
||||
|
||||
The payload is always the canonical/raw Tree Calculus representation for that type. The ABI envelope tags the payload; it does not replace or recursively wrap canonical Tree Calculus data.
|
||||
|
||||
## Tags
|
||||
|
||||
Initial tags:
|
||||
|
||||
```tricu
|
||||
hostTreeTag = 0
|
||||
hostStringTag = 1
|
||||
hostNumberTag = 2
|
||||
hostBoolTag = 3
|
||||
hostListTag = 4
|
||||
hostBytesTag = 5
|
||||
```
|
||||
|
||||
Planned/error tag, if needed later:
|
||||
|
||||
```tricu
|
||||
hostErrorTag = 6
|
||||
```
|
||||
|
||||
The first implementation keeps errors in the outer `err` result protocol rather than returning `hostError` inside `ok`.
|
||||
|
||||
## Constructors
|
||||
|
||||
The ABI constructors are:
|
||||
|
||||
```tricu
|
||||
hostTree value
|
||||
hostString bytes
|
||||
hostNumber n
|
||||
hostBool b
|
||||
hostList xs
|
||||
hostBytes bytes
|
||||
```
|
||||
|
||||
Each constructor returns:
|
||||
|
||||
```tricu
|
||||
pair tag payload
|
||||
```
|
||||
|
||||
Examples:
|
||||
|
||||
```tricu
|
||||
hostString "hello"
|
||||
hostNumber 42
|
||||
hostBool true
|
||||
hostList [1 2 3]
|
||||
hostTree (t t t)
|
||||
```
|
||||
|
||||
## Payload conventions
|
||||
|
||||
Payloads use existing canonical tricu encodings:
|
||||
|
||||
| ABI value | Payload |
|
||||
| --- | --- |
|
||||
| `hostTree` | arbitrary raw Tree Calculus value |
|
||||
| `hostString` | canonical string/byte-list representation |
|
||||
| `hostNumber` | canonical tricu number |
|
||||
| `hostBool` | canonical tricu bool (`false = t`, `true = t t`) |
|
||||
| `hostList` | canonical tricu list (`t` empty, `pair head tail` cons) |
|
||||
| `hostBytes` | canonical byte list |
|
||||
|
||||
`hostList` payloads are raw canonical lists, **not** lists of host ABI values.
|
||||
|
||||
## Accessors / matching
|
||||
|
||||
The first ABI should expose simple accessors:
|
||||
|
||||
```tricu
|
||||
hostValueTag hostValue
|
||||
hostValuePayload hostValue
|
||||
```
|
||||
|
||||
A host can decode the envelope by destructuring the pair directly, but these helpers make the ABI explicit and testable.
|
||||
|
||||
## Validation predicates
|
||||
|
||||
Typed runners should validate that the raw application result can be interpreted as the requested type before wrapping it.
|
||||
|
||||
Initial predicates:
|
||||
|
||||
```tricu
|
||||
hostNumber? value
|
||||
hostBool? value
|
||||
hostList? value
|
||||
hostString? value
|
||||
hostBytes? value
|
||||
```
|
||||
|
||||
These predicates are structural checks over canonical encodings. They are not general semantic type inference.
|
||||
|
||||
Important ambiguity note:
|
||||
|
||||
Tree Calculus encodings are not globally disjoint. For example, `t` is also `false`, `0`, and `[]`. Typed runners intentionally interpret values according to the requested type.
|
||||
|
||||
## Error behavior
|
||||
|
||||
Typed ABI runners return an error if the application result does not match the requested type.
|
||||
|
||||
Initial error code:
|
||||
|
||||
```tricu
|
||||
errHostCodecFailed = 14
|
||||
```
|
||||
|
||||
Example:
|
||||
|
||||
```tricu
|
||||
runArboricxToString bundle args
|
||||
```
|
||||
|
||||
returns:
|
||||
|
||||
```tricu
|
||||
ok (hostString resultBytes) rest
|
||||
```
|
||||
|
||||
if `resultBytes` is string-like, otherwise:
|
||||
|
||||
```tricu
|
||||
err errHostCodecFailed result
|
||||
```
|
||||
|
||||
where `result` is the raw application result that failed validation.
|
||||
|
||||
## Execution wrappers
|
||||
|
||||
The base self-hosted Arboricx runners are defined in `lib/arboricx.tri`:
|
||||
|
||||
```tricu
|
||||
runArboricxArgs bundleBytes args
|
||||
runArboricxArgsByName nameBytes bundleBytes args
|
||||
```
|
||||
|
||||
Host ABI wrappers layer typed output envelopes on top:
|
||||
|
||||
```tricu
|
||||
runArboricxToTree bundleBytes args
|
||||
runArboricxToString bundleBytes args
|
||||
runArboricxToNumber bundleBytes args
|
||||
runArboricxToBool bundleBytes args
|
||||
runArboricxToList bundleBytes args
|
||||
runArboricxToBytes bundleBytes args
|
||||
```
|
||||
|
||||
Named-export variants:
|
||||
|
||||
```tricu
|
||||
runArboricxByNameToTree nameBytes bundleBytes args
|
||||
runArboricxByNameToString nameBytes bundleBytes args
|
||||
runArboricxByNameToNumber nameBytes bundleBytes args
|
||||
runArboricxByNameToBool nameBytes bundleBytes args
|
||||
runArboricxByNameToList nameBytes bundleBytes args
|
||||
runArboricxByNameToBytes nameBytes bundleBytes args
|
||||
```
|
||||
|
||||
## Host usage
|
||||
|
||||
For a bundle whose default export is an unapplied function:
|
||||
|
||||
```tricu
|
||||
append "hello "
|
||||
```
|
||||
|
||||
A host that expects a string result evaluates:
|
||||
|
||||
```tricu
|
||||
runArboricxToString bundleBytes ["james"]
|
||||
```
|
||||
|
||||
On success, the result is:
|
||||
|
||||
```tricu
|
||||
ok (hostString "hello james") rest
|
||||
```
|
||||
|
||||
The host then:
|
||||
|
||||
1. unwraps `ok`,
|
||||
2. checks `hostStringTag`,
|
||||
3. decodes the canonical string payload.
|
||||
|
||||
## Implementation reference
|
||||
|
||||
- Tree constructors, numbers, strings, and lists: `src/Research.hs`
|
||||
- Result protocol: `lib/binary.tri`
|
||||
- Arboricx parser/executor: `lib/arboricx.tri`
|
||||
- Host ABI implementation: `lib/host-abi.tri` or `lib/arboricx.tri`, depending on final organization
|
||||
|
||||
## First-pass invariants
|
||||
|
||||
Tests should cover these invariants:
|
||||
|
||||
1. Each constructor stores the correct tag and payload.
|
||||
2. `hostValueTag` and `hostValuePayload` destructure values correctly.
|
||||
3. `runArboricxToTree` always wraps successful raw results as `hostTree`.
|
||||
4. `runArboricxToString` wraps string-like results as `hostString`.
|
||||
5. `runArboricxToNumber` wraps number-like results as `hostNumber`.
|
||||
6. `runArboricxToBool` wraps canonical booleans as `hostBool`.
|
||||
7. A typed runner returns `errHostCodecFailed` when validation fails.
|
||||
8. Named-export typed runners select the requested export before wrapping.
|
||||
483
docs/self-hosted-arboricx-host.md
Normal file
483
docs/self-hosted-arboricx-host.md
Normal file
@@ -0,0 +1,483 @@
|
||||
# Self-hosted Arboricx Host Prototype
|
||||
|
||||
This document describes how to build a minimal host-language shell that can execute Arboricx bundles through the self-hosted tricu Arboricx parser/executor.
|
||||
|
||||
The intended reader is an implementation agent building a first prototype in a host language such as PHP. The same approach should generalize to any language with a small Tree Calculus evaluator.
|
||||
|
||||
See also: [`docs/host-abi.md`](./host-abi.md) for the precise host-facing ABI value tags and typed runner contract.
|
||||
|
||||
## Goal
|
||||
|
||||
Build a tiny host program that can:
|
||||
|
||||
1. Represent Tree Calculus values.
|
||||
2. Reduce/evaluate Tree Calculus terms.
|
||||
3. Load or embed the tricu Arboricx runtime kernel.
|
||||
4. Read an application `.arboricx` bundle from disk.
|
||||
5. Convert host inputs into canonical Tree Calculus values.
|
||||
6. Apply the kernel to the application bundle and arguments.
|
||||
7. Unwrap a standardized host ABI result.
|
||||
8. Decode the host ABI payload back into host values.
|
||||
|
||||
A concrete target example:
|
||||
|
||||
```tricu
|
||||
-- Application bundle root is an unapplied function:
|
||||
append "hello "
|
||||
```
|
||||
|
||||
The host should be able to call that bundle with the host string `"james"` and receive:
|
||||
|
||||
```text
|
||||
hello james
|
||||
```
|
||||
|
||||
With the Host ABI layer, the preferred conceptual call is:
|
||||
|
||||
```tricu
|
||||
runArboricxToString <applicationBundleBytes> ["james"]
|
||||
```
|
||||
|
||||
This returns:
|
||||
|
||||
```tricu
|
||||
ok (hostString "hello james") rest
|
||||
```
|
||||
|
||||
where `runArboricxToString` comes from the self-hosted Arboricx runtime kernel.
|
||||
|
||||
## Architectural overview
|
||||
|
||||
There are two Arboricx bundles involved:
|
||||
|
||||
1. **Kernel bundle**
|
||||
- Contains the self-hosted Arboricx parser/executor written in tricu.
|
||||
- Exposes ergonomic runtime entrypoints such as `runArboricxArgs` and Host ABI entrypoints such as `runArboricxToString`.
|
||||
- This can be hardcoded as a Tree Calculus value in the host, or loaded by a minimal host-side Arboricx parser.
|
||||
|
||||
2. **Application bundle**
|
||||
- The bundle the user wants to execute.
|
||||
- Example: a bundle whose exported root is `append "hello "`, waiting for one more string argument.
|
||||
- The host reads this file as raw bytes and encodes those bytes as a Tree Calculus byte list.
|
||||
|
||||
The minimal host does **not** need to understand the application bundle format if the kernel is already available as a Tree Calculus value. The host only passes the application bundle bytes to the kernel.
|
||||
|
||||
## Required host components
|
||||
|
||||
### 1. Tree representation
|
||||
|
||||
The host needs a representation for the three Tree Calculus constructors:
|
||||
|
||||
```text
|
||||
Leaf
|
||||
Stem child
|
||||
Fork left right
|
||||
```
|
||||
|
||||
Use whatever is idiomatic for the host language. In PHP, for a prototype, simple classes or tagged arrays are sufficient.
|
||||
|
||||
Example shape:
|
||||
|
||||
```php
|
||||
abstract class T {}
|
||||
final class Leaf extends T {}
|
||||
final class Stem extends T { public T $child; }
|
||||
final class Fork extends T { public T $left; public T $right; }
|
||||
```
|
||||
|
||||
or tagged arrays:
|
||||
|
||||
```php
|
||||
['tag' => 'leaf']
|
||||
['tag' => 'stem', 'child' => $t]
|
||||
['tag' => 'fork', 'left' => $l, 'right' => $r]
|
||||
```
|
||||
|
||||
The evaluator and codecs only need these three constructors.
|
||||
|
||||
### 2. Tree Calculus evaluator
|
||||
|
||||
The host must implement Tree Calculus reduction. This is the core VM.
|
||||
|
||||
The evaluator should use normal-order evaluation, matching the runtime semantics expected by Arboricx manifests:
|
||||
|
||||
```text
|
||||
runtimeEvaluation = "normal-order"
|
||||
```
|
||||
|
||||
The evaluator only needs the Tree Calculus reduction rules. There is no parser requirement for the host prototype if terms are constructed directly as trees.
|
||||
|
||||
Implementation notes:
|
||||
|
||||
- Evaluation must support application: a tree applied to another tree.
|
||||
- In this codebase, application is represented structurally as `Fork function argument` before reduction.
|
||||
- The evaluator repeatedly reduces until normal form or until a configured step/fuel limit is reached.
|
||||
- Add a fuel limit for the first prototype to avoid infinite reductions during debugging.
|
||||
|
||||
Reference implementation locations:
|
||||
|
||||
- Haskell evaluator/reduction: `src/Research.hs`
|
||||
- JavaScript Arboricx runtime evaluator: `ext/js/src/` if present in the checkout
|
||||
|
||||
Use those as references for exact reduction behavior.
|
||||
|
||||
### 3. Kernel availability
|
||||
|
||||
The host needs access to the self-hosted Arboricx runtime kernel as a Tree Calculus value.
|
||||
|
||||
There are two viable bootstrap strategies.
|
||||
|
||||
#### Strategy A: hardcode the kernel tree
|
||||
|
||||
For the first host prototype, this is recommended.
|
||||
|
||||
Workflow:
|
||||
|
||||
1. Compile/export the tricu kernel entrypoint as an Arboricx bundle or tree value.
|
||||
2. Convert the selected exported kernel function into a host-language Tree Calculus literal.
|
||||
3. Commit/embed that literal in the host implementation.
|
||||
|
||||
Then the host does not need any Arboricx parser of its own for the kernel. It only needs Tree Calculus reduction.
|
||||
|
||||
#### Strategy B: bootstrap the kernel from an Arboricx bundle
|
||||
|
||||
Alternatively, the host can implement a minimal Arboricx parser just sufficient to load the kernel bundle.
|
||||
|
||||
This is more work up front, but avoids hardcoding a huge tree literal.
|
||||
|
||||
If using this strategy, the host-side parser needs to:
|
||||
|
||||
1. Parse the Arboricx container.
|
||||
2. Parse enough manifest/export data to locate the desired kernel export.
|
||||
3. Parse node records.
|
||||
4. Reconstruct the selected root Tree Calculus value from the Merkle node DAG.
|
||||
|
||||
This logic is exactly what the tricu self-hosted kernel does, so the hardcoded-kernel path is simpler for early ports.
|
||||
|
||||
## Kernel entrypoints
|
||||
|
||||
The ergonomic runtime API currently lives in `lib/arboricx.tri`.
|
||||
|
||||
### Raw execution entrypoints
|
||||
|
||||
These return raw application results inside the existing `ok` / `err` result protocol:
|
||||
|
||||
```tricu
|
||||
readArboricxExecutableByName nameBytes bundleBytes
|
||||
readArboricxExecutable bundleBytes
|
||||
runArboricxByName nameBytes bundleBytes arg
|
||||
runArboricx bundleBytes arg
|
||||
runArboricxArgsByName nameBytes bundleBytes args
|
||||
runArboricxArgs bundleBytes args
|
||||
```
|
||||
|
||||
`runArboricxArgs` accepts:
|
||||
|
||||
1. Raw application bundle bytes as a Tree Calculus byte list.
|
||||
2. A Tree Calculus list of arguments.
|
||||
|
||||
For named exports, use `runArboricxArgsByName`, which accepts:
|
||||
|
||||
1. Export name as bytes.
|
||||
2. Application bundle bytes as bytes.
|
||||
3. Argument list.
|
||||
|
||||
### Host ABI typed entrypoints
|
||||
|
||||
For host-language ports, prefer the Host ABI typed runners. These wrap successful outputs in a tagged host ABI value so every host can decode the same envelope shape.
|
||||
|
||||
Default export variants:
|
||||
|
||||
```tricu
|
||||
runArboricxToTree bundleBytes args
|
||||
runArboricxToString bundleBytes args
|
||||
runArboricxToNumber bundleBytes args
|
||||
runArboricxToBool bundleBytes args
|
||||
runArboricxToList bundleBytes args
|
||||
runArboricxToBytes bundleBytes args
|
||||
```
|
||||
|
||||
Named export variants:
|
||||
|
||||
```tricu
|
||||
runArboricxByNameToTree nameBytes bundleBytes args
|
||||
runArboricxByNameToString nameBytes bundleBytes args
|
||||
runArboricxByNameToNumber nameBytes bundleBytes args
|
||||
runArboricxByNameToBool nameBytes bundleBytes args
|
||||
runArboricxByNameToList nameBytes bundleBytes args
|
||||
runArboricxByNameToBytes nameBytes bundleBytes args
|
||||
```
|
||||
|
||||
Recommended first host entrypoint for the `append "hello "` example:
|
||||
|
||||
```tricu
|
||||
runArboricxToString
|
||||
```
|
||||
|
||||
## Applying the kernel in the host evaluator
|
||||
|
||||
If the host has the Tree Calculus value for `runArboricxToString`, call it by constructing nested application trees.
|
||||
|
||||
In Tree Calculus application form:
|
||||
|
||||
```text
|
||||
((runArboricxToString bundleBytesTree) argsTree)
|
||||
```
|
||||
|
||||
Structurally, if `app(f, x)` constructs `Fork(f, x)`, then:
|
||||
|
||||
```php
|
||||
$expr = app(app($kernelRunArboricxToString, $bundleBytesTree), $argsTree);
|
||||
$result = normalize($expr);
|
||||
```
|
||||
|
||||
For named export execution:
|
||||
|
||||
```text
|
||||
(((runArboricxByNameToString nameBytesTree) bundleBytesTree) argsTree)
|
||||
```
|
||||
|
||||
Structurally:
|
||||
|
||||
```php
|
||||
$expr = app(
|
||||
app(
|
||||
app($kernelRunArboricxByNameToString, $nameBytesTree),
|
||||
$bundleBytesTree
|
||||
),
|
||||
$argsTree
|
||||
);
|
||||
$result = normalize($expr);
|
||||
```
|
||||
|
||||
## Result convention and Host ABI envelope
|
||||
|
||||
All runtime APIs return the existing tricu `ok` / `err` convention from `lib/binary.tri`:
|
||||
|
||||
```tricu
|
||||
ok value rest = pair true (pair value rest)
|
||||
err code rest = pair false (pair code rest)
|
||||
```
|
||||
|
||||
The host should always unwrap this outer result first.
|
||||
|
||||
### Raw runners
|
||||
|
||||
Raw runners such as `runArboricxArgs` return:
|
||||
|
||||
```tricu
|
||||
ok rawApplicationValue rest
|
||||
```
|
||||
|
||||
The host must know how to interpret `rawApplicationValue`.
|
||||
|
||||
### Host ABI typed runners
|
||||
|
||||
Typed runners such as `runArboricxToString` return:
|
||||
|
||||
```tricu
|
||||
ok hostAbiValue rest
|
||||
```
|
||||
|
||||
A host ABI value has shape:
|
||||
|
||||
```tricu
|
||||
pair tag payload
|
||||
```
|
||||
|
||||
The payload is still the canonical/raw Tree Calculus representation for that type.
|
||||
|
||||
Initial tags are specified in [`docs/host-abi.md`](./host-abi.md):
|
||||
|
||||
```tricu
|
||||
hostTreeTag = 0
|
||||
hostStringTag = 1
|
||||
hostNumberTag = 2
|
||||
hostBoolTag = 3
|
||||
hostListTag = 4
|
||||
hostBytesTag = 5
|
||||
```
|
||||
|
||||
For example:
|
||||
|
||||
```tricu
|
||||
runArboricxToString bundleBytes ["james"]
|
||||
```
|
||||
|
||||
returns:
|
||||
|
||||
```tricu
|
||||
ok (hostString "hello james") rest
|
||||
```
|
||||
|
||||
which is structurally:
|
||||
|
||||
```tricu
|
||||
ok (pair hostStringTag "hello james") rest
|
||||
```
|
||||
|
||||
### Error shape
|
||||
|
||||
Expected error shape:
|
||||
|
||||
```tricu
|
||||
err code rest
|
||||
```
|
||||
|
||||
The error code is a Tree Calculus number. Error constants are defined in:
|
||||
|
||||
- `lib/binary.tri`
|
||||
- `lib/arboricx-common.tri`
|
||||
- `lib/arboricx.tri` for Host ABI codec errors, currently `errHostCodecFailed = 14`
|
||||
|
||||
Typed runners return `errHostCodecFailed` if the application result cannot be interpreted as the requested type.
|
||||
|
||||
A prototype host can report the numeric error code and optionally dump a compact representation of `rest`.
|
||||
|
||||
## Example execution flow
|
||||
|
||||
Suppose the application bundle exports this root:
|
||||
|
||||
```tricu
|
||||
append "hello "
|
||||
```
|
||||
|
||||
The bundle root is an unapplied function waiting for one more string argument.
|
||||
|
||||
Host flow:
|
||||
|
||||
1. Load kernel entrypoint tree:
|
||||
|
||||
```php
|
||||
$runArboricxToString = loadHardcodedKernelEntrypoint('runArboricxToString');
|
||||
```
|
||||
|
||||
2. Read application bundle bytes:
|
||||
|
||||
```php
|
||||
$bytes = file_get_contents('append-hello.arboricx');
|
||||
```
|
||||
|
||||
3. Encode bundle bytes as a Tree Calculus byte list:
|
||||
|
||||
```php
|
||||
$bundleBytesTree = encodeBytes($bytes);
|
||||
```
|
||||
|
||||
4. Encode host argument(s):
|
||||
|
||||
```php
|
||||
$arg = encodeString('james');
|
||||
$args = encodeList([$arg]);
|
||||
```
|
||||
|
||||
5. Build application expression:
|
||||
|
||||
```php
|
||||
$expr = app(app($runArboricxToString, $bundleBytesTree), $args);
|
||||
```
|
||||
|
||||
6. Evaluate:
|
||||
|
||||
```php
|
||||
$result = normalize($expr);
|
||||
```
|
||||
|
||||
7. Unwrap `ok` result:
|
||||
|
||||
```php
|
||||
[$ok, $hostValue, $rest] = unwrapResult($result);
|
||||
if (!$ok) { throw new RuntimeException('Arboricx error'); }
|
||||
```
|
||||
|
||||
8. Unwrap Host ABI envelope:
|
||||
|
||||
```php
|
||||
[$tag, $payload] = unwrapHostValue($hostValue);
|
||||
if ($tag !== HOST_STRING_TAG) { throw new RuntimeException('Expected string'); }
|
||||
```
|
||||
|
||||
9. Decode the payload:
|
||||
|
||||
```php
|
||||
echo decodeString($payload); // hello james
|
||||
```
|
||||
|
||||
## What the kernel does internally
|
||||
|
||||
`runArboricxToString` performs the following steps inside Tree Calculus:
|
||||
|
||||
1. Parse and validate the raw Arboricx bundle bytes.
|
||||
2. Parse the manifest.
|
||||
3. Select the default export:
|
||||
- use export named `main` if present,
|
||||
- otherwise use the sole export if exactly one exists,
|
||||
- otherwise return an error.
|
||||
4. Read the nodes section.
|
||||
5. Reconstruct the selected root tree from the Merkle DAG.
|
||||
6. Apply each host-provided argument in order.
|
||||
7. Validate that the raw result is string-like.
|
||||
8. Return `ok (hostString result) rest`, or an `err`.
|
||||
|
||||
`runArboricxByNameToString` is identical except that it selects a named export.
|
||||
|
||||
Other typed runners follow the same pattern for their requested output type.
|
||||
|
||||
## Tests proving the expected behavior
|
||||
|
||||
The relevant Haskell tests are in `test/Spec.hs` under `manifestReadingTests`.
|
||||
|
||||
Important cases:
|
||||
|
||||
- `readArboricxExecutable: reconstructs default export tree`
|
||||
- `readArboricxExecutableByName: selects named export`
|
||||
- `runArboricx: applies host-provided argument to default export`
|
||||
- `runArboricxArgs: applies host-provided argument list in order`
|
||||
- `host ABI: constructors expose tag and payload`
|
||||
- `runArboricxToTree: wraps raw result as hostTree`
|
||||
- `runArboricxToString: wraps string result as hostString`
|
||||
- `runArboricxToNumber: wraps number result as hostNumber`
|
||||
- `runArboricxToBool: rejects non-bool result`
|
||||
|
||||
These tests demonstrate the host-shell contract:
|
||||
|
||||
- application bundle bytes are supplied as a Tree Calculus byte list,
|
||||
- host arguments are supplied as canonical Tree Calculus values,
|
||||
- execution returns an outer result-wrapped value,
|
||||
- Host ABI typed runners return a tagged ABI envelope inside `ok`.
|
||||
|
||||
## Minimal PHP prototype checklist
|
||||
|
||||
A PHP prototype should implement:
|
||||
|
||||
- [ ] Tree data constructors: `Leaf`, `Stem`, `Fork`.
|
||||
- [ ] Application helper: `app($f, $x) = Fork($f, $x)`.
|
||||
- [ ] Normal-order Tree Calculus reducer.
|
||||
- [ ] Fuel/step limit for debugging.
|
||||
- [ ] Hardcoded kernel entrypoint tree for `runArboricxToString` for the first string-output prototype.
|
||||
- [ ] Encode application bundle file bytes into a Tree Calculus byte list.
|
||||
- [ ] Encode host argument values into Tree Calculus values.
|
||||
- [ ] Build expression: `((runArboricxToString bundleBytes) args)`.
|
||||
- [ ] Normalize expression.
|
||||
- [ ] Unwrap outer `ok` / `err` result.
|
||||
- [ ] Unwrap Host ABI `pair tag payload` envelope.
|
||||
- [ ] Decode payload according to tag.
|
||||
|
||||
For exact codec details, reference the Haskell implementation in `src/Research.hs` and the existing JS runtime if available.
|
||||
|
||||
## Current recommendation
|
||||
|
||||
For the first PHP implementation:
|
||||
|
||||
1. Hardcode only the `runArboricxToString` kernel entrypoint as a Tree Calculus value.
|
||||
2. Do not implement host-side Arboricx parsing yet.
|
||||
3. Implement only enough codecs for:
|
||||
- bytes,
|
||||
- strings,
|
||||
- lists,
|
||||
- result unwrapping,
|
||||
- Host ABI envelope unwrapping.
|
||||
4. Use one test fixture: an Arboricx bundle whose root is `append "hello "`.
|
||||
5. Assert that calling it with `"james"` returns an outer `ok`, then a `hostString`, then payload `"hello james"`.
|
||||
|
||||
Once that works, add named export support via `runArboricxByNameToString` and expand Host ABI tags/codecs as needed.
|
||||
17
ext/js/package.json
Normal file
17
ext/js/package.json
Normal file
@@ -0,0 +1,17 @@
|
||||
{
|
||||
"name": "arboricx-runtime",
|
||||
"version": "0.1.0",
|
||||
"description": "Arboricx portable bundle runtime — JavaScript reference implementation",
|
||||
"type": "module",
|
||||
"main": "src/bundle.js",
|
||||
"bin": {
|
||||
"arboricx-run": "src/cli.js"
|
||||
},
|
||||
"scripts": {
|
||||
"test": "node --test test/*.test.js",
|
||||
"inspect": "node src/cli.js inspect",
|
||||
"run": "node src/cli.js run"
|
||||
},
|
||||
"keywords": ["arboricx", "tree-calculus", "trie", "runtime"],
|
||||
"license": "MIT"
|
||||
}
|
||||
191
ext/js/src/bundle.js
Normal file
191
ext/js/src/bundle.js
Normal file
@@ -0,0 +1,191 @@
|
||||
/**
|
||||
* bundle.js — Parse an Arboricx portable bundle binary into a JavaScript object.
|
||||
*
|
||||
* Format (v1):
|
||||
* Header (32 bytes):
|
||||
* Magic 8B "ARBORICX"
|
||||
* 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
|
||||
* Manifest: fixed-order core + TLV tail (ARBMNFST magic)
|
||||
* Nodes: binary section
|
||||
*/
|
||||
|
||||
import { createHash } from "node:crypto";
|
||||
import { decodeManifest } from "./manifest.js";
|
||||
|
||||
// ── Constants ───────────────────────────────────────────────────────────────
|
||||
|
||||
const MAGIC = Buffer.from([0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58]); // "ARBORICX"
|
||||
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 ARBORICX");
|
||||
}
|
||||
|
||||
// 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 the manifest from the fixed-order binary format.
|
||||
*/
|
||||
export function parseManifest(buffer) {
|
||||
const bundle = parseBundle(buffer);
|
||||
const manifestEntry = bundle.sections.get(SECTION_MANIFEST);
|
||||
return decodeManifest(manifestEntry.data);
|
||||
}
|
||||
|
||||
/**
|
||||
* Convenience: parse and return the node section binary.
|
||||
*/
|
||||
export function parseNodeSection(buffer) {
|
||||
const bundle = parseBundle(buffer);
|
||||
const nodesEntry = bundle.sections.get(SECTION_NODES);
|
||||
return nodesEntry.data;
|
||||
}
|
||||
249
ext/js/src/cli.js
Normal file
249
ext/js/src/cli.js
Normal file
@@ -0,0 +1,249 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* cli.js — Minimal CLI for inspecting and running Arboricx 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("Arboricx JS Runtime");
|
||||
console.log("");
|
||||
console.log("Usage:");
|
||||
console.log(" node cli.js inspect <bundle>");
|
||||
console.log(" node cli.js run <bundle> [exportName] [input]");
|
||||
break;
|
||||
}
|
||||
135
ext/js/src/codecs.js
Normal file
135
ext/js/src/codecs.js
Normal file
@@ -0,0 +1,135 @@
|
||||
/**
|
||||
* codecs.js — Minimal codecs for decoding tree results.
|
||||
*
|
||||
* Implements: decodeResult (from Research.hs)
|
||||
* - Leaf → "t"
|
||||
* - Numbers: toNumber
|
||||
* - Strings: toString
|
||||
* - Lists: toList
|
||||
* - Fallback: raw tree format
|
||||
*/
|
||||
|
||||
// ── toNumber ────────────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Decode a tree as a binary number (big-endian).
|
||||
* Leaf = 0, Fork(Leaf, rest) = 2*n, Fork(Stem Leaf, rest) = 2*n+1.
|
||||
*/
|
||||
export function toNumber(t) {
|
||||
if (!Array.isArray(t)) return null;
|
||||
if (t.length === 0) return 0; // Leaf = 0
|
||||
if (t.length !== 2) return null; // must be Fork
|
||||
|
||||
const [right, left] = t;
|
||||
// Fork structure: [right, left]
|
||||
// left child determines bit: Leaf = 0, Stem(Leaf) = 1
|
||||
let bit;
|
||||
if (Array.isArray(left) && left.length === 0) {
|
||||
bit = 0; // Leaf
|
||||
} else if (Array.isArray(left) && left.length === 1) {
|
||||
const child = left[0];
|
||||
if (Array.isArray(child) && child.length === 0) {
|
||||
bit = 1; // Stem(Leaf) = 1
|
||||
} else {
|
||||
return null; // Stem of something other than Leaf
|
||||
}
|
||||
} else {
|
||||
return null;
|
||||
}
|
||||
|
||||
const rest = toNumber(right);
|
||||
if (rest === null) return null;
|
||||
|
||||
return bit + 2 * rest;
|
||||
}
|
||||
|
||||
// ── toString ────────────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Decode a tree as a list of numbers (characters).
|
||||
* Fork(x, rest) = x : list.
|
||||
*/
|
||||
export function toList(t) {
|
||||
if (!Array.isArray(t)) return null;
|
||||
if (t.length === 0) return []; // Leaf = empty list
|
||||
if (t.length !== 2) return null; // must be Fork
|
||||
|
||||
const [right, left] = t;
|
||||
const rest = toList(right);
|
||||
if (rest === null) return null;
|
||||
|
||||
return [left, ...rest];
|
||||
}
|
||||
|
||||
/**
|
||||
* Decode a tree as a string.
|
||||
*/
|
||||
export function toString(t) {
|
||||
const list = toList(t);
|
||||
if (list === null) return null;
|
||||
try {
|
||||
return list.map((ch) => String.fromCharCode(ch)).join("");
|
||||
} catch {
|
||||
return null;
|
||||
}
|
||||
}
|
||||
|
||||
// ── decodeResult ────────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Decode a tree result using multiple strategies:
|
||||
* 1. Leaf → "t"
|
||||
* 2. String (if all chars are printable)
|
||||
* 3. Number
|
||||
* 4. List
|
||||
* 5. Raw tree format
|
||||
*/
|
||||
export function decodeResult(t) {
|
||||
if (!Array.isArray(t)) {
|
||||
return String(t);
|
||||
}
|
||||
|
||||
// Leaf
|
||||
if (t.length === 0) {
|
||||
return "t";
|
||||
}
|
||||
|
||||
// Try string first (list of char codes)
|
||||
const list = toList(t);
|
||||
if (list !== null && list.length > 0) {
|
||||
const str = list.map((n) => {
|
||||
if (n < 32 || n > 126) return null;
|
||||
return String.fromCharCode(n);
|
||||
}).join("");
|
||||
if (str) return `"${str}"`;
|
||||
}
|
||||
|
||||
// Try number
|
||||
const num = toNumber(t);
|
||||
if (num !== null) {
|
||||
return String(num);
|
||||
}
|
||||
|
||||
// Try list (elements are trees)
|
||||
if (t.length === 2) {
|
||||
const elements = toList(t);
|
||||
if (elements !== null) {
|
||||
const decoded = elements.map((e) => decodeResult(e));
|
||||
return `[${decoded.join(", ")}]`;
|
||||
}
|
||||
}
|
||||
|
||||
// Raw tree format
|
||||
return formatTree(t);
|
||||
}
|
||||
|
||||
/**
|
||||
* Format a tree as a parenthesized expression.
|
||||
*/
|
||||
export function formatTree(t) {
|
||||
if (!Array.isArray(t)) return String(t);
|
||||
if (t.length === 0) return "Leaf";
|
||||
if (t.length === 1) return `Stem(${formatTree(t[0])})`;
|
||||
if (t.length === 2) return `Fork(${formatTree(t[1])}, ${formatTree(t[0])})`;
|
||||
return `[${t.map(formatTree).join(", ")}]`;
|
||||
}
|
||||
374
ext/js/src/manifest.js
Normal file
374
ext/js/src/manifest.js
Normal file
@@ -0,0 +1,374 @@
|
||||
/**
|
||||
* manifest.js — Fixed-order manifest parsing and export lookup.
|
||||
*
|
||||
* The manifest binary format (ManifestV1):
|
||||
* magic(8) + major(u16) + minor(u16)
|
||||
* + schema(string) + bundleType(string)
|
||||
* + treeCalculus(string) + treeHashAlgorithm(string) + treeHashDomain(string) + treeNodePayload(string)
|
||||
* + runtimeSemantics(string) + runtimeEvaluation(string) + runtimeAbi(string)
|
||||
* + capabilityCount(u32) + capabilities(string[])
|
||||
* + closure(u8)
|
||||
* + rootCount(u32) + roots[]
|
||||
* + exportCount(u32) + exports[]
|
||||
* + metadataFieldCount(u32) + metadataTLVs[]
|
||||
* + extensionFieldCount(u32) + extensionTLVs[]
|
||||
*
|
||||
* String format: u32 BE length + UTF-8 bytes.
|
||||
* Root: 32 bytes raw hash + role(string).
|
||||
* Export: name(string) + 32 bytes raw root hash + kind(string) + abi(string).
|
||||
* TLV: u16 tag + u32 length + value bytes.
|
||||
*/
|
||||
|
||||
// ── Constants ───────────────────────────────────────────────────────────────
|
||||
|
||||
const MANIFEST_MAGIC = "ARBMNFST";
|
||||
const MANIFEST_MAJOR = 1;
|
||||
const MANIFEST_MINOR = 0;
|
||||
|
||||
// Metadata TLV tags
|
||||
const TAG_PACKAGE = 1;
|
||||
const TAG_VERSION = 2;
|
||||
const TAG_DESCRIPTION = 3;
|
||||
const TAG_LICENSE = 4;
|
||||
const TAG_CREATED_BY = 5;
|
||||
|
||||
// Closure bytes
|
||||
const CLOSURE_COMPLETE = 0;
|
||||
const CLOSURE_PARTIAL = 1;
|
||||
|
||||
// ── Binary helpers ──────────────────────────────────────────────────────────
|
||||
|
||||
function u16(buf, off) {
|
||||
if (off + 2 > buf.length) throw new Error("manifest: not enough bytes for u16");
|
||||
return { value: buf.readUint16BE(off), next: off + 2 };
|
||||
}
|
||||
|
||||
function u32(buf, off) {
|
||||
if (off + 4 > buf.length) throw new Error("manifest: not enough bytes for u32");
|
||||
return { value: buf.readUint32BE(off), next: off + 4 };
|
||||
}
|
||||
|
||||
function u8(buf, off) {
|
||||
if (off >= buf.length) throw new Error("manifest: not enough bytes for u8");
|
||||
return { value: buf.readUint8(off), next: off + 1 };
|
||||
}
|
||||
|
||||
/**
|
||||
* Read a length-prefixed UTF-8 string: u32 BE length + UTF-8 bytes.
|
||||
* Returns { text, next }.
|
||||
*/
|
||||
function readStr(buf, off) {
|
||||
const { value: len, next: afterLen } = u32(buf, off);
|
||||
if (afterLen + len > buf.length) throw new Error("manifest: string extends beyond input");
|
||||
return { text: buf.toString("utf-8", afterLen, afterLen + len), next: afterLen + len };
|
||||
}
|
||||
|
||||
/**
|
||||
* Read raw bytes of given length.
|
||||
* Returns { bytes, next }.
|
||||
*/
|
||||
function readRaw(buf, off, n) {
|
||||
if (off + n > buf.length) throw new Error(`manifest: not enough bytes for ${n}-byte read`);
|
||||
return { value: buf.slice(off, off + n), next: off + n };
|
||||
}
|
||||
|
||||
// ── Manifest decoder ────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Decode the manifest binary from a Buffer.
|
||||
*
|
||||
* Returns a normalized manifest object matching the shape expected
|
||||
* by validateManifest / selectExport.
|
||||
*/
|
||||
export function decodeManifest(buf) {
|
||||
let off = 0;
|
||||
|
||||
// Magic (8 bytes)
|
||||
const magic = buf.toString("utf-8", 0, 8);
|
||||
if (magic !== MANIFEST_MAGIC) {
|
||||
throw new Error(`invalid manifest magic: expected ${MANIFEST_MAGIC}, got "${magic}"`);
|
||||
}
|
||||
off = 8;
|
||||
|
||||
// Version
|
||||
const { value: major } = u16(buf, off);
|
||||
if (major !== MANIFEST_MAJOR) throw new Error(`unsupported manifest major version: ${major}`);
|
||||
off += 4; // u16 major + u16 minor
|
||||
|
||||
// Helper: read length-prefixed text
|
||||
const readText = () => {
|
||||
const { text, next } = readStr(buf, off);
|
||||
off = next;
|
||||
return text;
|
||||
};
|
||||
|
||||
// Core strings
|
||||
const schema = readText();
|
||||
const bundleType = readText();
|
||||
const treeCalculus = readText();
|
||||
const treeHashAlgorithm = readText();
|
||||
const treeHashDomain = readText();
|
||||
const treeNodePayload = readText();
|
||||
const runtimeSemantics = readText();
|
||||
const runtimeEvaluation = readText();
|
||||
const runtimeAbi = readText();
|
||||
|
||||
// Capabilities (u32 count + string[])
|
||||
const { value: capCount } = u32(buf, off);
|
||||
off += 4;
|
||||
const capabilities = [];
|
||||
for (let i = 0; i < capCount; i++) {
|
||||
capabilities.push(readText());
|
||||
}
|
||||
|
||||
// Closure (u8)
|
||||
const { value: closureByte } = u8(buf, off);
|
||||
off += 1;
|
||||
const closure = closureByte === CLOSURE_COMPLETE ? "complete" : "partial";
|
||||
|
||||
// Roots (u32 count + Root[])
|
||||
// Root: 32 bytes raw hash + role(string)
|
||||
const { value: rootCount } = u32(buf, off);
|
||||
off += 4;
|
||||
const roots = [];
|
||||
for (let i = 0; i < rootCount; i++) {
|
||||
const { value: hashRaw } = readRaw(buf, off, 32);
|
||||
off += 32;
|
||||
const { text: role, next: rOff } = readStr(buf, off);
|
||||
off = rOff;
|
||||
roots.push({ hash: hashRaw.toString("hex"), role });
|
||||
}
|
||||
|
||||
// Exports (u32 count + Export[])
|
||||
// Export: name(string) + 32 bytes raw root hash + kind(string) + abi(string)
|
||||
const { value: exportCount } = u32(buf, off);
|
||||
off += 4;
|
||||
const exports = [];
|
||||
for (let i = 0; i < exportCount; i++) {
|
||||
const { text: name, next: nOff } = readStr(buf, off);
|
||||
off = nOff;
|
||||
const { value: expHashRaw } = readRaw(buf, off, 32);
|
||||
off += 32;
|
||||
const { text: kind, next: kOff } = readStr(buf, off);
|
||||
off = kOff;
|
||||
const { text: abi, next: aOff } = readStr(buf, off);
|
||||
off = aOff;
|
||||
exports.push({ name, root: expHashRaw.toString("hex"), kind, abi });
|
||||
}
|
||||
|
||||
// Metadata (u32 count + TLV[])
|
||||
// TLV: u16 tag + u32 length + value bytes
|
||||
const { value: metaCount } = u32(buf, off);
|
||||
off += 4;
|
||||
const metadata = {};
|
||||
for (let i = 0; i < metaCount; i++) {
|
||||
const { value: tag } = u16(buf, off);
|
||||
off += 2;
|
||||
const { value: tlvLen } = u32(buf, off);
|
||||
off += 4;
|
||||
const { value: tlvRaw } = readRaw(buf, off, tlvLen);
|
||||
off += tlvLen;
|
||||
const val = tlvRaw.toString("utf-8");
|
||||
switch (tag) {
|
||||
case TAG_PACKAGE: metadata.package = val; break;
|
||||
case TAG_VERSION: metadata.version = val; break;
|
||||
case TAG_DESCRIPTION: metadata.description = val; break;
|
||||
case TAG_LICENSE: metadata.license = val; break;
|
||||
case TAG_CREATED_BY: metadata.createdBy = val; break;
|
||||
}
|
||||
}
|
||||
|
||||
// Extensions (u32 count + TLV[] — skip all)
|
||||
const { value: extCount } = u32(buf, off);
|
||||
off += 4;
|
||||
for (let i = 0; i < extCount; i++) {
|
||||
const { value: _tag } = u16(buf, off);
|
||||
off += 2;
|
||||
const { value: tlvLen } = u32(buf, off);
|
||||
off += 4;
|
||||
off += tlvLen; // skip value
|
||||
}
|
||||
|
||||
return {
|
||||
schema,
|
||||
bundleType,
|
||||
tree: {
|
||||
calculus: treeCalculus,
|
||||
nodeHash: {
|
||||
algorithm: treeHashAlgorithm,
|
||||
domain: treeHashDomain,
|
||||
},
|
||||
nodePayload: treeNodePayload,
|
||||
},
|
||||
runtime: {
|
||||
semantics: runtimeSemantics,
|
||||
evaluation: runtimeEvaluation,
|
||||
abi: runtimeAbi,
|
||||
capabilities,
|
||||
},
|
||||
closure,
|
||||
roots,
|
||||
exports,
|
||||
metadata: Object.keys(metadata).length > 0 ? metadata : undefined,
|
||||
};
|
||||
}
|
||||
|
||||
// ── Validation ──────────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Validate the manifest against the runtime profile requirements.
|
||||
* Throws on violation.
|
||||
*/
|
||||
export function validateManifest(manifest) {
|
||||
if (manifest.schema !== "arboricx.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 !== "arboricx.merkle.node.v1") {
|
||||
throw new Error(
|
||||
`unsupported node hash domain: ${tree.nodeHash.domain}`
|
||||
);
|
||||
}
|
||||
if (tree.nodePayload !== "arboricx.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 !== "arboricx.abi.tree.v1") {
|
||||
throw new Error(`unsupported runtime ABI: ${runtime.abi}`);
|
||||
}
|
||||
if (runtime.capabilities && runtime.capabilities.length > 0) {
|
||||
throw new Error(
|
||||
`host/runtime capabilities not supported: ${runtime.capabilities.join(", ")}`
|
||||
);
|
||||
}
|
||||
|
||||
if (manifest.closure !== "complete") {
|
||||
throw new Error("bundle v1 requires closure = complete");
|
||||
}
|
||||
if (manifest.imports && manifest.imports.length > 0) {
|
||||
throw new Error("bundle v1 requires an empty imports list");
|
||||
}
|
||||
if (!manifest.roots || manifest.roots.length === 0) {
|
||||
throw new Error("manifest has no roots");
|
||||
}
|
||||
if (!manifest.exports || manifest.exports.length === 0) {
|
||||
throw new Error("manifest has no exports");
|
||||
}
|
||||
|
||||
for (const exp of manifest.exports) {
|
||||
if (!exp.name) {
|
||||
throw new Error("manifest export has empty name");
|
||||
}
|
||||
if (!exp.root) {
|
||||
throw new Error("manifest export has empty root");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Select an export hash given a requested name.
|
||||
*
|
||||
* Selection strategy:
|
||||
* 1. Explicit export name
|
||||
* 2. Export named "main"
|
||||
* 3. Single export (auto-select)
|
||||
* 4. Error if multiple exports and no "main"
|
||||
*/
|
||||
export function selectExport(manifest, requestedName) {
|
||||
const exports = manifest.exports || [];
|
||||
|
||||
// Strategy 1: explicit name
|
||||
if (requestedName) {
|
||||
const found = exports.find((e) => e.name === requestedName);
|
||||
if (found) {
|
||||
return found;
|
||||
}
|
||||
throw new Error(
|
||||
`requested export "${requestedName}" not found. Available: ${exports.map((e) => e.name).join(", ")}`
|
||||
);
|
||||
}
|
||||
|
||||
// Strategy 2: prefer "main"
|
||||
const mainExport = exports.find((e) => e.name === "main");
|
||||
if (mainExport) {
|
||||
return mainExport;
|
||||
}
|
||||
|
||||
// Strategy 3: single export
|
||||
if (exports.length === 1) {
|
||||
return exports[0];
|
||||
}
|
||||
|
||||
// Strategy 4: multiple exports, require explicit
|
||||
throw new Error(
|
||||
`multiple exports available but none named "main": ${exports.map((e) => e.name).join(", ")}. Specify an export name.`
|
||||
);
|
||||
}
|
||||
|
||||
/**
|
||||
* Get all root hashes from the manifest.
|
||||
*/
|
||||
export function getRootHashes(manifest) {
|
||||
return (manifest.roots || []).map((r) => r.hash);
|
||||
}
|
||||
|
||||
/**
|
||||
* Get all export names.
|
||||
*/
|
||||
export function getExportNames(manifest) {
|
||||
return (manifest.exports || []).map((e) => e.name);
|
||||
}
|
||||
|
||||
/**
|
||||
* Print manifest summary info.
|
||||
*/
|
||||
export function printManifestInfo(manifest, indent = "") {
|
||||
const tree = manifest.tree;
|
||||
const runtime = manifest.runtime;
|
||||
|
||||
console.log(`${indent}Schema: ${manifest.schema}`);
|
||||
console.log(`${indent}Bundle type: ${manifest.bundleType}`);
|
||||
console.log(`${indent}Closure: ${manifest.closure}`);
|
||||
console.log(`${indent}Tree calculus: ${tree.calculus}`);
|
||||
console.log(`${indent}Hash algo: ${tree.nodeHash.algorithm}`);
|
||||
console.log(`${indent}Hash domain: ${tree.nodeHash.domain}`);
|
||||
console.log(`${indent}Runtime: ${runtime.semantics}`);
|
||||
console.log(`${indent}ABI: ${runtime.abi}`);
|
||||
console.log(`${indent}Evaluation: ${runtime.evaluation || "N/A"}`);
|
||||
console.log("");
|
||||
console.log(`${indent}Roots (${getRootHashes(manifest).length}):`);
|
||||
for (const root of getRootHashes(manifest)) {
|
||||
console.log(`${indent} ${root.substring(0, 16)}...`);
|
||||
}
|
||||
console.log("");
|
||||
console.log(`${indent}Exports (${getExportNames(manifest).length}):`);
|
||||
for (const name of getExportNames(manifest)) {
|
||||
console.log(`${indent} ${name}`);
|
||||
}
|
||||
|
||||
const meta = manifest.metadata;
|
||||
if (meta && meta.createdBy) {
|
||||
console.log("");
|
||||
console.log(`${indent}Created by: ${meta.createdBy}`);
|
||||
}
|
||||
}
|
||||
276
ext/js/src/merkle.js
Normal file
276
ext/js/src/merkle.js
Normal file
@@ -0,0 +1,276 @@
|
||||
/**
|
||||
* merkle.js — Node payload decoding and hash verification.
|
||||
*
|
||||
* Node payload format:
|
||||
* Leaf: 0x00
|
||||
* Stem: 0x01 || child_hash (32 bytes raw)
|
||||
* Fork: 0x02 || left_hash (32 bytes raw) || right_hash (32 bytes raw)
|
||||
*
|
||||
* Hash computation:
|
||||
* hash = SHA256( "arboricx.merkle.node.v1" || 0x00 || node_payload )
|
||||
*/
|
||||
|
||||
import { createHash } from "node:crypto";
|
||||
|
||||
// ── Constants ───────────────────────────────────────────────────────────────
|
||||
|
||||
const DOMAIN_TAG = "arboricx.merkle.node.v1";
|
||||
const HASH_LENGTH = 32; // raw hash bytes
|
||||
const HEX_LENGTH = 64; // hex-encoded hash length
|
||||
|
||||
// ── Helpers ─────────────────────────────────────────────────────────────────
|
||||
|
||||
function rawToHex(buf) {
|
||||
if (buf.length !== HASH_LENGTH) {
|
||||
throw new Error(`raw hash must be ${HASH_LENGTH} bytes, got ${buf.length}`);
|
||||
}
|
||||
return buf.toString("hex");
|
||||
}
|
||||
|
||||
function hexToRaw(hex) {
|
||||
const buf = Buffer.from(hex, "hex");
|
||||
if (buf.length !== HASH_LENGTH) {
|
||||
throw new Error(`hex hash must decode to ${HASH_LENGTH} bytes`);
|
||||
}
|
||||
return buf;
|
||||
}
|
||||
|
||||
function sha256(data) {
|
||||
return createHash("sha256").update(data).digest();
|
||||
}
|
||||
|
||||
function nodeHash(prefix, payload) {
|
||||
return sha256(Buffer.concat([Buffer.from(prefix), Buffer.from([0x00]), payload]));
|
||||
}
|
||||
|
||||
// ── Node payload types ──────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Deserialize a node payload into { type, childHash, leftHash, rightHash }.
|
||||
*
|
||||
* type: "leaf" | "stem" | "fork"
|
||||
* childHash: hex string (for stem)
|
||||
* leftHash: hex string (for fork)
|
||||
* rightHash: hex string (for fork)
|
||||
*/
|
||||
export function deserializePayload(payload) {
|
||||
if (payload.length === 0) {
|
||||
throw new Error("empty payload");
|
||||
}
|
||||
|
||||
const type = payload.readUInt8(0);
|
||||
|
||||
switch (type) {
|
||||
case 0x00:
|
||||
if (payload.length !== 1) {
|
||||
throw new Error(
|
||||
`invalid leaf payload: expected 1 byte, got ${payload.length}`
|
||||
);
|
||||
}
|
||||
return { type: "leaf" };
|
||||
|
||||
case 0x01:
|
||||
if (payload.length !== 1 + HASH_LENGTH) {
|
||||
throw new Error(
|
||||
`invalid stem payload: expected ${1 + HASH_LENGTH} bytes, got ${payload.length}`
|
||||
);
|
||||
}
|
||||
return {
|
||||
type: "stem",
|
||||
childHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
|
||||
};
|
||||
|
||||
case 0x02:
|
||||
if (payload.length !== 1 + 2 * HASH_LENGTH) {
|
||||
throw new Error(
|
||||
`invalid fork payload: expected ${1 + 2 * HASH_LENGTH} bytes, got ${payload.length}`
|
||||
);
|
||||
}
|
||||
return {
|
||||
type: "fork",
|
||||
leftHash: rawToHex(payload.slice(1, 1 + HASH_LENGTH)),
|
||||
rightHash: rawToHex(payload.slice(1 + HASH_LENGTH, 1 + 2 * HASH_LENGTH)),
|
||||
};
|
||||
|
||||
default:
|
||||
throw new Error(
|
||||
`invalid merkle node payload: unknown type 0x${type.toString(16)}`
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Compute the canonical payload bytes for a given tree node structure.
|
||||
*/
|
||||
export function serializeNode(node) {
|
||||
switch (node.type) {
|
||||
case "leaf":
|
||||
return Buffer.from([0x00]);
|
||||
case "stem":
|
||||
return Buffer.concat([Buffer.from([0x01]), hexToRaw(node.childHash)]);
|
||||
case "fork":
|
||||
return Buffer.concat([
|
||||
Buffer.from([0x02]),
|
||||
hexToRaw(node.leftHash),
|
||||
hexToRaw(node.rightHash),
|
||||
]);
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Compute the Merkle hash of a node from its type and parameters.
|
||||
*/
|
||||
export function computeNodeHash(node) {
|
||||
const payload = serializeNode(node);
|
||||
const hash = nodeHash(DOMAIN_TAG, payload);
|
||||
return hash.toString("hex");
|
||||
}
|
||||
|
||||
// ── Node section parsing ────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Parse the node section binary into a Map<hexHash, { type, payload, node }>.
|
||||
*
|
||||
* Node section format:
|
||||
* nodeCount (8B u64 BE)
|
||||
* entries[]:
|
||||
* hash (32B raw)
|
||||
* payloadLen (4B u32 BE)
|
||||
* payload (payloadLen bytes)
|
||||
*/
|
||||
export function parseNodeSection(data) {
|
||||
if (data.length < 8) {
|
||||
throw new Error("node section too short for count");
|
||||
}
|
||||
|
||||
const nodeCount = Number(data.readBigUInt64BE(0));
|
||||
let offset = 8;
|
||||
|
||||
const nodeMap = new Map();
|
||||
const errors = [];
|
||||
|
||||
for (let i = 0; i < nodeCount; i++) {
|
||||
// Read hash
|
||||
if (offset + HASH_LENGTH > data.length) {
|
||||
errors.push(`node ${i}: not enough bytes for hash`);
|
||||
break;
|
||||
}
|
||||
const hash = rawToHex(data.slice(offset, offset + HASH_LENGTH));
|
||||
offset += HASH_LENGTH;
|
||||
|
||||
// Read payload length
|
||||
if (offset + 4 > data.length) {
|
||||
errors.push(`node ${i} (${hash}): not enough bytes for payload length`);
|
||||
break;
|
||||
}
|
||||
const payloadLen = data.readUint32BE(offset);
|
||||
offset += 4;
|
||||
|
||||
// Read payload
|
||||
if (offset + payloadLen > data.length) {
|
||||
errors.push(`node ${i} (${hash}): payload extends beyond section end`);
|
||||
break;
|
||||
}
|
||||
const payload = data.slice(offset, offset + payloadLen);
|
||||
offset += payloadLen;
|
||||
|
||||
// Deserialize payload
|
||||
let node;
|
||||
try {
|
||||
node = deserializePayload(payload);
|
||||
} catch (e) {
|
||||
errors.push(`node ${i} (${hash}): ${e.message}`);
|
||||
continue;
|
||||
}
|
||||
|
||||
nodeMap.set(hash, {
|
||||
hash,
|
||||
payload,
|
||||
...node,
|
||||
});
|
||||
}
|
||||
|
||||
if (errors.length > 0) {
|
||||
throw new Error(
|
||||
`node section parse errors:\n ${errors.join("\n ")}`
|
||||
);
|
||||
}
|
||||
|
||||
return { nodeMap, count: nodeCount };
|
||||
}
|
||||
|
||||
// ── Verification ────────────────────────────────────────────────────────────
|
||||
|
||||
/**
|
||||
* Verify all node hashes match their payloads.
|
||||
* Returns { verified, mismatches }
|
||||
*/
|
||||
export function verifyNodeHashes(nodeMap) {
|
||||
const mismatches = [];
|
||||
|
||||
for (const [hash, node] of nodeMap) {
|
||||
const expected = computeNodeHash(node);
|
||||
if (hash !== expected) {
|
||||
mismatches.push({
|
||||
hash,
|
||||
expected,
|
||||
type: node.type,
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
return { verified: mismatches.length === 0, mismatches };
|
||||
}
|
||||
|
||||
/**
|
||||
* Verify that all child references exist in the node map (closure).
|
||||
* Returns { complete, missing } where missing is an array of { parent, child }.
|
||||
*/
|
||||
export function verifyClosure(nodeMap) {
|
||||
const missing = [];
|
||||
|
||||
for (const [hash, node] of nodeMap) {
|
||||
if (node.type === "stem") {
|
||||
if (!nodeMap.has(node.childHash)) {
|
||||
missing.push({ parent: hash, child: node.childHash });
|
||||
}
|
||||
} else if (node.type === "fork") {
|
||||
if (!nodeMap.has(node.leftHash)) {
|
||||
missing.push({ parent: hash, child: node.leftHash });
|
||||
}
|
||||
if (!nodeMap.has(node.rightHash)) {
|
||||
missing.push({ parent: hash, child: node.rightHash });
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return { complete: missing.length === 0, missing };
|
||||
}
|
||||
|
||||
/**
|
||||
* Verify closure for a specific root hash (transitive reachability).
|
||||
* Returns { complete, missingRoots }.
|
||||
*/
|
||||
export function verifyRootClosure(nodeMap, rootHash) {
|
||||
const visited = new Set();
|
||||
const missingRoots = [];
|
||||
|
||||
function visit(hash) {
|
||||
if (visited.has(hash)) return;
|
||||
if (!nodeMap.has(hash)) {
|
||||
missingRoots.push(hash);
|
||||
return;
|
||||
}
|
||||
visited.add(hash);
|
||||
const node = nodeMap.get(hash);
|
||||
if (node.type === "stem") {
|
||||
visit(node.childHash);
|
||||
} else if (node.type === "fork") {
|
||||
visit(node.leftHash);
|
||||
visit(node.rightHash);
|
||||
}
|
||||
}
|
||||
|
||||
visit(rootHash);
|
||||
return { complete: missingRoots.length === 0, missingRoots };
|
||||
}
|
||||
125
ext/js/src/tree.js
Normal file
125
ext/js/src/tree.js
Normal file
@@ -0,0 +1,125 @@
|
||||
/**
|
||||
* tree.js — Runtime tree representation.
|
||||
*
|
||||
* The JS tree uses a simple array representation matching the
|
||||
* TypeScript reference evaluator:
|
||||
*
|
||||
* Leaf = []
|
||||
* Stem = [child] (array length === 1)
|
||||
* Fork = [right, left] (array length === 2)
|
||||
*
|
||||
* This is a "flattened stack" representation: when reduced, terms
|
||||
* become arrays and the evaluator pops three elements at a time.
|
||||
*/
|
||||
|
||||
/**
|
||||
* Check if a value is a Leaf (empty array).
|
||||
*/
|
||||
export function isLeaf(t) {
|
||||
return Array.isArray(t) && t.length === 0;
|
||||
}
|
||||
|
||||
/**
|
||||
* Check if a value is a Stem (single element array).
|
||||
*/
|
||||
export function isStem(t) {
|
||||
return Array.isArray(t) && t.length === 1;
|
||||
}
|
||||
|
||||
/**
|
||||
* Check if a value is a Fork (two element array).
|
||||
*/
|
||||
export function isFork(t) {
|
||||
return Array.isArray(t) && t.length === 2;
|
||||
}
|
||||
|
||||
/**
|
||||
* Check if a value is a valid tree calculus value (Leaf, Stem, or Fork).
|
||||
*/
|
||||
export function isTree(t) {
|
||||
return isLeaf(t) || isStem(t) || isFork(t);
|
||||
}
|
||||
|
||||
/**
|
||||
* Triage a tree: classify it as Leaf/Stem/Fork.
|
||||
* The tree must be in normal form (no reducible redexes).
|
||||
*
|
||||
* Returns { kind: "leaf"|"stem"|"fork", ...rest }
|
||||
*/
|
||||
export function triage(t) {
|
||||
if (!Array.isArray(t)) {
|
||||
throw new Error("not a tree (not an array)");
|
||||
}
|
||||
if (t.length === 0) return { kind: "leaf" };
|
||||
if (t.length === 1) return { kind: "stem", child: t[0] };
|
||||
if (t.length === 2) return { kind: "fork", right: t[0], left: t[1] };
|
||||
throw new Error(`not a value/binary tree: length ${t.length}`);
|
||||
}
|
||||
|
||||
/**
|
||||
* Apply the Tree Calculus apply rules.
|
||||
*
|
||||
* apply(a, b) computes the application of term a to term b.
|
||||
*
|
||||
* Rules:
|
||||
* apply(Fork(Leaf, a), _) = a
|
||||
* apply(Fork(Stem(a), b), c) = apply(apply(a, c), apply(b, c))
|
||||
* apply(Fork(Fork, _, _), Leaf) = left of inner Fork
|
||||
* apply(Fork(Fork, _, _), Stem) = right of inner Fork
|
||||
* apply(Fork(Fork, _, _), Fork) = apply(apply(c, u), v) where c=Fork(u,v)
|
||||
* apply(Leaf, b) = Stem(b)
|
||||
* apply(Stem(a), b) = Fork(a, b)
|
||||
*
|
||||
* For Fork, the inner structure is [right, left], so:
|
||||
* a = right, b = left
|
||||
*/
|
||||
export function apply(a, b) {
|
||||
// apply(Fork(Leaf, a), _) = a
|
||||
// Fork = [right, left] = [Leaf, a] → left child is Leaf
|
||||
if (isFork(a) && isLeaf(a[1])) {
|
||||
return a[0]; // return right child
|
||||
}
|
||||
|
||||
// apply(Fork(Stem(a), b), c)
|
||||
if (isFork(a) && isStem(a[1])) {
|
||||
const stemChild = a[1][0]; // left child of fork
|
||||
const right = a[0]; // right child of fork
|
||||
const innerA = stemChild;
|
||||
const innerB = right;
|
||||
const appliedA = apply(innerA, b);
|
||||
const appliedB = apply(innerB, b);
|
||||
return apply(appliedA, appliedB);
|
||||
}
|
||||
|
||||
// apply(Fork(Fork, _, _), Leaf)
|
||||
if (isFork(a) && isFork(a[1]) && isLeaf(b)) {
|
||||
return a[1][0]; // right child of inner fork (which is left child)
|
||||
}
|
||||
|
||||
// apply(Fork(Fork, _, _), Stem)
|
||||
if (isFork(a) && isFork(a[1]) && isStem(b)) {
|
||||
return a[1][1]; // left child of inner fork
|
||||
}
|
||||
|
||||
// apply(Fork(Fork, _, _), Fork)
|
||||
if (isFork(a) && isFork(a[1]) && isFork(b)) {
|
||||
// b = Fork(u, v) = [v, u]
|
||||
const u = b[0];
|
||||
const v = b[1];
|
||||
// apply(apply(c, u), v) where c = inner fork
|
||||
const applied = apply(apply(a[1], u), v);
|
||||
return applied;
|
||||
}
|
||||
|
||||
// apply(Leaf, b) = Stem(b)
|
||||
if (isLeaf(a)) {
|
||||
return [b];
|
||||
}
|
||||
|
||||
// apply(Stem(a), b) = Fork(a, b)
|
||||
if (isStem(a)) {
|
||||
return [b, a[0]]; // [right, left]
|
||||
}
|
||||
|
||||
throw new Error("apply: undefined reduction for terms");
|
||||
}
|
||||
134
ext/js/test/bundle.test.js
Normal file
134
ext/js/test/bundle.test.js
Normal file
@@ -0,0 +1,134 @@
|
||||
import { readFileSync } from "node:fs";
|
||||
import { strictEqual, ok, throws } from "node:assert";
|
||||
import { createHash } from "node:crypto";
|
||||
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.arboricx`)
|
||||
);
|
||||
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 manifest", () => {
|
||||
const manifest = parseManifest(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
strictEqual(manifest.schema, "arboricx.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.tree.nodeHash.domain, "arboricx.merkle.node.v1");
|
||||
strictEqual(manifest.runtime.semantics, "tree-calculus.v1");
|
||||
strictEqual(manifest.runtime.abi, "arboricx.abi.tree.v1");
|
||||
});
|
||||
});
|
||||
|
||||
describe("hash verification", () => {
|
||||
it("valid bundle nodes verify", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
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("ARBORICX", 0, 8);
|
||||
buf.writeUInt16BE(2, 8); // major version 2
|
||||
throws(() => parseBundle(buf), /unsupported bundle major version/);
|
||||
});
|
||||
|
||||
it("bad section digest fails", () => {
|
||||
const buf = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
// Corrupt one byte in the manifest section
|
||||
buf[152] ^= 0x01;
|
||||
throws(() => parseBundle(buf), /digest mismatch/);
|
||||
});
|
||||
|
||||
it("truncated bundle fails", () => {
|
||||
const buf = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const truncated = buf.slice(0, 40);
|
||||
throws(() => parseBundle(truncated), /truncated/);
|
||||
});
|
||||
|
||||
it("missing nodes section fails", () => {
|
||||
// Build a bundle with only manifest entry in the directory (1 section instead of 2)
|
||||
const header = Buffer.alloc(32, 0);
|
||||
header.write("ARBORICX", 0, 8);
|
||||
header.writeUInt16BE(1, 8); // major version
|
||||
header.writeUInt16BE(0, 10); // minor version
|
||||
header.writeUInt32BE(1, 12); // 1 section
|
||||
|
||||
// Build a manifest JSON
|
||||
const manifestObj = {
|
||||
schema: "arboricx.bundle.manifest.v1",
|
||||
bundleType: "tree-calculus-executable-object",
|
||||
tree: {
|
||||
calculus: "tree-calculus.v1",
|
||||
nodeHash: {
|
||||
algorithm: "sha256",
|
||||
domain: "arboricx.merkle.node.v1"
|
||||
},
|
||||
nodePayload: "arboricx.merkle.payload.v1"
|
||||
},
|
||||
runtime: {
|
||||
semantics: "tree-calculus.v1",
|
||||
evaluation: "normal-order",
|
||||
abi: "arboricx.abi.tree.v1",
|
||||
capabilities: []
|
||||
},
|
||||
closure: "complete",
|
||||
roots: [{ hash: Buffer.alloc(32).toString("hex"), role: "default" }],
|
||||
exports: [{ name: "root", root: Buffer.alloc(32).toString("hex"), kind: "term", abi: "arboricx.abi.tree.v1" }],
|
||||
metadata: { createdBy: "arboricx" }
|
||||
};
|
||||
const manifestJson = JSON.stringify(manifestObj);
|
||||
const manifestBytes = Buffer.from(manifestJson);
|
||||
|
||||
// Section directory entry (60 bytes, all fields are u64 after the u16s)
|
||||
const entry = Buffer.alloc(60, 0);
|
||||
entry.writeUInt32BE(1, 0); // type: manifest
|
||||
entry.writeUInt16BE(1, 4); // version
|
||||
entry.writeUInt16BE(1, 6); // flags: critical
|
||||
entry.writeUInt16BE(0, 8); // compression: none
|
||||
entry.writeUInt16BE(1, 10); // digest algorithm: sha256
|
||||
entry.writeBigUInt64BE(BigInt(32 + 60), 12); // offset (u64)
|
||||
entry.writeBigUInt64BE(BigInt(manifestBytes.length), 20); // length (u64)
|
||||
entry.set(createHash("sha256").update(manifestBytes).digest(), 28); // digest (32 bytes)
|
||||
|
||||
// Set dirOffset to 32 so parseBundle reads directory from after header
|
||||
header.writeBigUInt64BE(BigInt(32), 24);
|
||||
|
||||
const bundleBuf = Buffer.concat([header, entry, manifestBytes]);
|
||||
throws(() => parseBundle(bundleBuf), /missing required section/);
|
||||
});
|
||||
});
|
||||
180
ext/js/test/merkle.test.js
Normal file
180
ext/js/test/merkle.test.js
Normal file
@@ -0,0 +1,180 @@
|
||||
import { readFileSync } from "node:fs";
|
||||
import { strictEqual, ok } from "node:assert";
|
||||
import { describe, it } from "node:test";
|
||||
import { parseNodeSection as bundleParseNodeSection, parseBundle, parseManifest } from "../src/bundle.js";
|
||||
import {
|
||||
verifyNodeHashes,
|
||||
verifyClosure,
|
||||
verifyRootClosure,
|
||||
deserializePayload,
|
||||
computeNodeHash,
|
||||
parseNodeSection,
|
||||
} 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);
|
||||
});
|
||||
|
||||
it("Leaf hash matches expected Arboricx domain", () => {
|
||||
const leaf = { type: "leaf" };
|
||||
const hash = computeNodeHash(leaf);
|
||||
strictEqual(hash, "92b8a9796dbeafbcd36757535876256392170d137bf36b319d77f11a37112158");
|
||||
});
|
||||
});
|
||||
|
||||
describe("merkle — node section parsing", () => {
|
||||
const fixtureDir = "../../test/fixtures";
|
||||
|
||||
it("parses id.arboricx with correct node count", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
strictEqual(nodeMap.size, 4);
|
||||
});
|
||||
|
||||
it("parses true.arboricx with correct node count", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/true.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
strictEqual(nodeMap.size, 2);
|
||||
});
|
||||
|
||||
it("parses false.arboricx with correct node count", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/false.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
strictEqual(nodeMap.size, 1);
|
||||
});
|
||||
});
|
||||
|
||||
describe("merkle — hash verification", () => {
|
||||
const fixtureDir = "../../test/fixtures";
|
||||
|
||||
it("id.arboricx nodes all verify", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
const { verified, mismatches } = verifyNodeHashes(nodeMap);
|
||||
ok(verified, "id.arboricx node hashes should verify");
|
||||
strictEqual(mismatches.length, 0);
|
||||
});
|
||||
|
||||
it("true.arboricx nodes all verify", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/true.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
const { verified, mismatches } = verifyNodeHashes(nodeMap);
|
||||
ok(verified, "true.arboricx node hashes should verify");
|
||||
strictEqual(mismatches.length, 0);
|
||||
});
|
||||
|
||||
it("corrupted node payload fails hash verification", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(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.arboricx has complete closure", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
const { complete, missing } = verifyClosure(nodeMap);
|
||||
ok(complete, "id.arboricx should have complete closure");
|
||||
strictEqual(missing.length, 0);
|
||||
});
|
||||
|
||||
it("verifyRootClosure checks transitive reachability", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const { nodeMap } = parseNodeSection(data);
|
||||
// Use the actual root hash from the fixture's manifest
|
||||
const manifest = parseManifest(readFileSync(`${fixtureDir}/id.arboricx`));
|
||||
const rootHash = manifest.exports[0].root;
|
||||
const { complete, missingRoots } = verifyRootClosure(nodeMap, rootHash);
|
||||
ok(complete, "root should be reachable");
|
||||
strictEqual(missingRoots.length, 0);
|
||||
});
|
||||
|
||||
it("parseNodeSection returns correct node count", () => {
|
||||
const data = bundleParseNodeSection(
|
||||
readFileSync(`${fixtureDir}/id.arboricx`)
|
||||
);
|
||||
const result = parseNodeSection(data);
|
||||
strictEqual(result.count, 4);
|
||||
});
|
||||
});
|
||||
|
||||
// Helper for throws
|
||||
function throws(fn, expected) {
|
||||
try {
|
||||
fn();
|
||||
return false;
|
||||
} catch (e) {
|
||||
return expected.test(e.message);
|
||||
}
|
||||
}
|
||||
80
ext/js/test/reduce.test.js
Normal file
80
ext/js/test/reduce.test.js
Normal file
@@ -0,0 +1,80 @@
|
||||
import { strictEqual, ok } from "node:assert";
|
||||
import { describe, it } from "node:test";
|
||||
import { apply, isLeaf, isStem, isFork } from "../src/tree.js";
|
||||
import { reduce } from "../src/cli.js";
|
||||
|
||||
describe("tree — basic types", () => {
|
||||
it("Leaf is empty array", () => {
|
||||
ok(isLeaf([]));
|
||||
ok(!isStem([]));
|
||||
ok(!isFork([]));
|
||||
});
|
||||
|
||||
it("Stem is single-element array", () => {
|
||||
ok(isStem([[]]));
|
||||
ok(!isLeaf([[]]));
|
||||
});
|
||||
|
||||
it("Fork is two-element array", () => {
|
||||
ok(isFork([[], []]));
|
||||
ok(!isLeaf([[], []]));
|
||||
});
|
||||
});
|
||||
|
||||
describe("tree — apply rules", () => {
|
||||
// Leaf = [], Stem = [child], Fork = [right, left]
|
||||
|
||||
it("apply(Leaf, b) = Stem(b)", () => {
|
||||
const b = []; // Leaf
|
||||
const result = apply([], b);
|
||||
ok(isStem(result), "Stem(b) should be a Stem");
|
||||
strictEqual(result[0], b);
|
||||
});
|
||||
|
||||
it("apply(Stem(a), b) = Fork(a, b)", () => {
|
||||
const a = []; // Leaf
|
||||
const b = []; // Leaf
|
||||
const result = apply([a], b);
|
||||
ok(isFork(result), "Fork(a, b) should be a Fork");
|
||||
// Fork = [right, left] = [b, a]
|
||||
strictEqual(result[0], b);
|
||||
strictEqual(result[1], a);
|
||||
});
|
||||
|
||||
it("apply(Fork(Leaf, a), _) = a", () => {
|
||||
// Fork(Leaf, a) = [a, Leaf]
|
||||
const a = []; // Leaf
|
||||
const result = apply([a, []], []);
|
||||
strictEqual(result, a);
|
||||
ok(isLeaf(result));
|
||||
});
|
||||
});
|
||||
|
||||
describe("tree — reduction", () => {
|
||||
it("reduces Leaf to Leaf", () => {
|
||||
const result = reduce([], 100);
|
||||
ok(isLeaf(result));
|
||||
});
|
||||
|
||||
it("reduces Stem Leaf to Stem Leaf", () => {
|
||||
const result = reduce([[]], 100);
|
||||
ok(isStem(result));
|
||||
ok(isLeaf(result[0]));
|
||||
});
|
||||
|
||||
it("reduces Fork Leaf Leaf to Fork Leaf Leaf", () => {
|
||||
const result = reduce([[], []], 100);
|
||||
ok(isFork(result));
|
||||
ok(isLeaf(result[0]));
|
||||
ok(isLeaf(result[1]));
|
||||
});
|
||||
|
||||
it("S combinator applied to Leaf reduces", () => {
|
||||
// S = t (t (t t)) t = Fork (Fork (Fork Leaf Leaf) Leaf) Leaf
|
||||
// In array form: [[[], []], [], []]
|
||||
const s = [[], [[[], []], []]];
|
||||
const leaf = [];
|
||||
const result = reduce([s, leaf], 100);
|
||||
ok(Array.isArray(result), "S Leaf should reduce to an array");
|
||||
});
|
||||
});
|
||||
120
ext/js/test/run-bundle.test.js
Normal file
120
ext/js/test/run-bundle.test.js
Normal file
@@ -0,0 +1,120 @@
|
||||
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.arboricx", () => {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
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 'root' is selectable", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
strictEqual(exp.name, "root");
|
||||
});
|
||||
|
||||
it("tree reconstructs as a Fork", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
const tree = buildTreeFromNodeMap(nodeMap, exp.root);
|
||||
ok(Array.isArray(tree));
|
||||
ok(tree.length >= 2, "tree should be a Fork (length >= 2)");
|
||||
});
|
||||
});
|
||||
|
||||
describe("run bundle — true.arboricx", () => {
|
||||
const bundle = readFileSync(`${fixtureDir}/true.arboricx`);
|
||||
const manifest = parseManifest(bundle);
|
||||
const nodeSectionData = bundleParseNodeSection(bundle);
|
||||
const { nodeMap } = parseNodes(nodeSectionData);
|
||||
|
||||
it("manifest validates", () => {
|
||||
validateManifest(manifest);
|
||||
});
|
||||
|
||||
it("export 'root' is selectable", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
strictEqual(exp.name, "root");
|
||||
});
|
||||
|
||||
it("tree reconstructs as Stem Leaf", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
const tree = buildTreeFromNodeMap(nodeMap, exp.root);
|
||||
ok(Array.isArray(tree));
|
||||
strictEqual(tree.length, 1, "true should be a Stem (single child)");
|
||||
strictEqual(tree[0].length, 0, "child should be Leaf");
|
||||
});
|
||||
});
|
||||
|
||||
describe("run bundle — false.arboricx", () => {
|
||||
const bundle = readFileSync(`${fixtureDir}/false.arboricx`);
|
||||
const manifest = parseManifest(bundle);
|
||||
const nodeSectionData = bundleParseNodeSection(bundle);
|
||||
const { nodeMap } = parseNodes(nodeSectionData);
|
||||
|
||||
it("manifest validates", () => {
|
||||
validateManifest(manifest);
|
||||
});
|
||||
|
||||
it("export 'root' is selectable", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
strictEqual(exp.name, "root");
|
||||
});
|
||||
|
||||
it("tree reconstructs as Leaf", () => {
|
||||
const exp = selectExport(manifest, "root");
|
||||
const tree = buildTreeFromNodeMap(nodeMap, exp.root);
|
||||
strictEqual(tree.length, 0, "false should be Leaf (empty array)");
|
||||
});
|
||||
});
|
||||
|
||||
describe("run bundle — notQ.arboricx", () => {
|
||||
const bundle = readFileSync(`${fixtureDir}/notQ.arboricx`);
|
||||
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);
|
||||
});
|
||||
});
|
||||
|
||||
describe("run bundle — missing export", () => {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const manifest = parseManifest(bundle);
|
||||
|
||||
it("nonexistent export fails clearly", () => {
|
||||
throws(() => selectExport(manifest, "nonexistent"), /not found/);
|
||||
});
|
||||
});
|
||||
|
||||
describe("run bundle — auto-select", () => {
|
||||
// true.arboricx has only one export, should auto-select
|
||||
const bundle = readFileSync(`${fixtureDir}/true.arboricx`);
|
||||
const manifest = parseManifest(bundle);
|
||||
|
||||
it("single export auto-selects", () => {
|
||||
const exp = selectExport(manifest, undefined);
|
||||
ok(exp, "should auto-select the only export");
|
||||
});
|
||||
});
|
||||
172
ext/php/run.php
Normal file
172
ext/php/run.php
Normal file
@@ -0,0 +1,172 @@
|
||||
#!/usr/bin/env php
|
||||
<?php
|
||||
|
||||
declare(strict_types=1);
|
||||
|
||||
/**
|
||||
* run.php — Arboricx PHP host shell via libarboricx C ABI.
|
||||
*
|
||||
* Usage:
|
||||
* php run.php run <bundle.arboricx> [args...]
|
||||
* php run.php inspect <bundle.arboricx>
|
||||
*/
|
||||
|
||||
require __DIR__ . '/src/ffi.php';
|
||||
|
||||
use function Arboricx\{ctx_init, ctx_free, loadBundleDefault, ofNumber, ofString, app, reduce, toString, toBool, toNumber};
|
||||
|
||||
// ── Locate libarboricx.so ──────────────────────────────────────────────────
|
||||
|
||||
function findLib(): string
|
||||
{
|
||||
$env = getenv('ARBORICX_LIB');
|
||||
if ($env !== false && file_exists($env)) {
|
||||
return $env;
|
||||
}
|
||||
|
||||
$paths = [
|
||||
__DIR__ . '/../../zig/zig-out/lib/libarboricx.so',
|
||||
'/usr/local/lib/libarboricx.so',
|
||||
'/usr/lib/libarboricx.so',
|
||||
'./libarboricx.so',
|
||||
];
|
||||
foreach ($paths as $p) {
|
||||
if (file_exists($p)) {
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
|
||||
fwrite(STDERR, "Error: libarboricx.so not found.\nSet ARBORICX_LIB to its full path.\n");
|
||||
exit(1);
|
||||
}
|
||||
|
||||
// ── Decode helpers ─────────────────────────────────────────────────────────
|
||||
|
||||
function decode(\FFI\CData $ctx, int $root): string
|
||||
{
|
||||
// Bool first: false is Leaf, which is also a valid empty string/list.
|
||||
try {
|
||||
return toBool($ctx, $root) ? 'true' : 'false';
|
||||
} catch (\Throwable $e) {
|
||||
try {
|
||||
return toString($ctx, $root);
|
||||
} catch (\Throwable $e2) {
|
||||
try {
|
||||
return (string) toNumber($ctx, $root);
|
||||
} catch (\Throwable $e3) {
|
||||
throw new \RuntimeException('could not decode result');
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
function decodeType(\FFI\CData $ctx, int $root): string
|
||||
{
|
||||
try {
|
||||
toBool($ctx, $root);
|
||||
return 'bool';
|
||||
} catch (\Throwable $e) {
|
||||
try {
|
||||
toString($ctx, $root);
|
||||
return 'string';
|
||||
} catch (\Throwable $e2) {
|
||||
try {
|
||||
toNumber($ctx, $root);
|
||||
return 'number';
|
||||
} catch (\Throwable $e3) {
|
||||
return 'unknown (raw tree)';
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// ── Commands ─────────────────────────────────────────────────────────────────
|
||||
|
||||
function readBundle(string $path): string
|
||||
{
|
||||
if (!file_exists($path)) {
|
||||
fwrite(STDERR, "Error: bundle not found: $path\n");
|
||||
exit(1);
|
||||
}
|
||||
$bytes = file_get_contents($path);
|
||||
if ($bytes === false) {
|
||||
fwrite(STDERR, "Error: could not read bundle: $path\n");
|
||||
exit(1);
|
||||
}
|
||||
return $bytes;
|
||||
}
|
||||
|
||||
function cmdRun(string $libPath, string $bundlePath, array $args): void
|
||||
{
|
||||
$ctx = ctx_init($libPath);
|
||||
try {
|
||||
$term = loadBundleDefault($ctx, readBundle($bundlePath));
|
||||
|
||||
foreach ($args as $arg) {
|
||||
$argTree = preg_match('/^\d+$/', $arg) ? ofNumber($ctx, (int)$arg) : ofString($ctx, $arg);
|
||||
$term = app($ctx, $term, $argTree);
|
||||
}
|
||||
|
||||
$result = reduce($ctx, $term, 1_000_000_000);
|
||||
echo decode($ctx, $result) . "\n";
|
||||
} finally {
|
||||
ctx_free($ctx);
|
||||
}
|
||||
}
|
||||
|
||||
function cmdInspect(string $libPath, string $bundlePath): void
|
||||
{
|
||||
$ctx = ctx_init($libPath);
|
||||
try {
|
||||
$bundle = readBundle($bundlePath);
|
||||
echo "Bundle: $bundlePath\nSize: " . strlen($bundle) . " bytes\n\nResult:\n";
|
||||
|
||||
$term = loadBundleDefault($ctx, $bundle);
|
||||
$result = reduce($ctx, $term, 1_000_000_000);
|
||||
|
||||
$type = decodeType($ctx, $result);
|
||||
try {
|
||||
$value = decode($ctx, $result);
|
||||
} catch (\RuntimeException $e) {
|
||||
$value = '(raw tree)';
|
||||
}
|
||||
echo " Type: $type\n Value: $value\n";
|
||||
} finally {
|
||||
ctx_free($ctx);
|
||||
}
|
||||
}
|
||||
|
||||
// ── Main ─────────────────────────────────────────────────────────────────────
|
||||
|
||||
$argv = $_SERVER['argv'] ?? [];
|
||||
$argc = $_SERVER['argc'] ?? 0;
|
||||
|
||||
if ($argc < 2) {
|
||||
echo "Arboricx PHP Host Shell (via libarboricx C ABI)\n\nUsage:\n";
|
||||
echo " php run.php run <bundle.arboricx> [args...]\n";
|
||||
echo " php run.php inspect <bundle.arboricx>\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
$libPath = findLib();
|
||||
$command = $argv[1];
|
||||
|
||||
switch ($command) {
|
||||
case 'run':
|
||||
if ($argc < 3) {
|
||||
fwrite(STDERR, "Usage: php run.php run <bundle.arboricx> [args...]\n");
|
||||
exit(1);
|
||||
}
|
||||
cmdRun($libPath, $argv[2], array_slice($argv, 3));
|
||||
break;
|
||||
case 'inspect':
|
||||
if ($argc < 3) {
|
||||
fwrite(STDERR, "Usage: php run.php inspect <bundle.arboricx>\n");
|
||||
exit(1);
|
||||
}
|
||||
cmdInspect($libPath, $argv[2]);
|
||||
break;
|
||||
default:
|
||||
fwrite(STDERR, "Unknown command: $command\nUsage: php run.php run|inspect ...\n");
|
||||
exit(1);
|
||||
}
|
||||
138
ext/php/src/ffi.php
Normal file
138
ext/php/src/ffi.php
Normal file
@@ -0,0 +1,138 @@
|
||||
<?php
|
||||
|
||||
declare(strict_types=1);
|
||||
|
||||
namespace Arboricx;
|
||||
|
||||
/**
|
||||
* FFI wrapper around libarboricx.so.
|
||||
*
|
||||
* Loads the shared library and exposes typed wrappers for the C ABI.
|
||||
*/
|
||||
final class ArboricxFFI
|
||||
{
|
||||
private static ?\FFI $ffi = null;
|
||||
|
||||
public static function init(string $libPath): void
|
||||
{
|
||||
if (self::$ffi !== null) {
|
||||
return;
|
||||
}
|
||||
|
||||
// Nix output layout first, then repo layout.
|
||||
$candidates = [
|
||||
__DIR__ . '/../arboricx.h',
|
||||
__DIR__ . '/../../zig/include/arboricx.h',
|
||||
];
|
||||
$headerRaw = false;
|
||||
foreach ($candidates as $path) {
|
||||
$headerRaw = file_get_contents($path);
|
||||
if ($headerRaw !== false) break;
|
||||
}
|
||||
if ($headerRaw === false) {
|
||||
throw new \RuntimeException('Cannot read arboricx.h');
|
||||
}
|
||||
|
||||
// PHP FFI only parses plain C declarations.
|
||||
$header = $headerRaw;
|
||||
$header = preg_replace('/#.*\n/', "\n", $header);
|
||||
$header = preg_replace('/extern\s+"C"\s*\{/', '', $header);
|
||||
$header = str_replace('}', '', $header);
|
||||
$header = preg_replace('/\n\s*\n+/', "\n", $header);
|
||||
|
||||
self::$ffi = \FFI::cdef($header, $libPath);
|
||||
}
|
||||
|
||||
public static function ffi(): \FFI
|
||||
{
|
||||
if (self::$ffi === null) {
|
||||
throw new \RuntimeException('ArboricxFFI not initialized. Call ArboricxFFI::init($libPath) first.');
|
||||
}
|
||||
return self::$ffi;
|
||||
}
|
||||
}
|
||||
|
||||
function ctx_init(string $libPath): \FFI\CData
|
||||
{
|
||||
ArboricxFFI::init($libPath);
|
||||
$ctx = ArboricxFFI::ffi()->arboricx_init();
|
||||
if ($ctx === null) {
|
||||
throw new \RuntimeException('arboricx_init failed');
|
||||
}
|
||||
return $ctx;
|
||||
}
|
||||
|
||||
function ctx_free(\FFI\CData $ctx): void
|
||||
{
|
||||
ArboricxFFI::ffi()->arboricx_free($ctx);
|
||||
}
|
||||
|
||||
function app(\FFI\CData $ctx, int $func, int $arg): int
|
||||
{
|
||||
return ArboricxFFI::ffi()->arb_app($ctx, $func, $arg);
|
||||
}
|
||||
|
||||
function reduce(\FFI\CData $ctx, int $root, int $fuel = 1_000_000_000): int
|
||||
{
|
||||
return ArboricxFFI::ffi()->arb_reduce($ctx, $root, $fuel);
|
||||
}
|
||||
|
||||
function ofNumber(\FFI\CData $ctx, int $n): int
|
||||
{
|
||||
return ArboricxFFI::ffi()->arb_of_number($ctx, $n);
|
||||
}
|
||||
|
||||
function ofString(\FFI\CData $ctx, string $s): int
|
||||
{
|
||||
return ArboricxFFI::ffi()->arb_of_string($ctx, $s);
|
||||
}
|
||||
|
||||
function toNumber(\FFI\CData $ctx, int $root): int
|
||||
{
|
||||
$out = ArboricxFFI::ffi()->new('uint64_t');
|
||||
$ok = ArboricxFFI::ffi()->arb_to_number($ctx, $root, \FFI::addr($out));
|
||||
if (!$ok) {
|
||||
throw new \RuntimeException('arb_to_number failed');
|
||||
}
|
||||
return (int) $out->cdata;
|
||||
}
|
||||
|
||||
function toString(\FFI\CData $ctx, int $root): string
|
||||
{
|
||||
$ptr = ArboricxFFI::ffi()->new('uint8_t*');
|
||||
$len = ArboricxFFI::ffi()->new('size_t');
|
||||
$ok = ArboricxFFI::ffi()->arb_to_string($ctx, $root, \FFI::addr($ptr), \FFI::addr($len));
|
||||
if (!$ok) {
|
||||
throw new \RuntimeException('arb_to_string failed');
|
||||
}
|
||||
$length = (int) $len->cdata;
|
||||
$result = '';
|
||||
for ($i = 0; $i < $length; $i++) {
|
||||
$result .= chr($ptr[$i]);
|
||||
}
|
||||
ArboricxFFI::ffi()->arboricx_free_buf($ctx, $ptr, $length);
|
||||
return $result;
|
||||
}
|
||||
|
||||
function toBool(\FFI\CData $ctx, int $root): bool
|
||||
{
|
||||
$out = ArboricxFFI::ffi()->new('int');
|
||||
$ok = ArboricxFFI::ffi()->arb_to_bool($ctx, $root, \FFI::addr($out));
|
||||
if (!$ok) {
|
||||
throw new \RuntimeException('arb_to_bool failed');
|
||||
}
|
||||
return (bool) $out->cdata;
|
||||
}
|
||||
|
||||
function loadBundleDefault(\FFI\CData $ctx, string $bytes): int
|
||||
{
|
||||
$cdata = ArboricxFFI::ffi()->new('uint8_t[' . strlen($bytes) . ']');
|
||||
for ($i = 0; $i < strlen($bytes); $i++) {
|
||||
$cdata[$i] = ord($bytes[$i]);
|
||||
}
|
||||
$result = ArboricxFFI::ffi()->arb_load_bundle_default($ctx, $cdata, strlen($bytes));
|
||||
if ($result === 0) {
|
||||
throw new \RuntimeException('arb_load_bundle_default failed');
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
13
ext/zig/.gitignore
vendored
Normal file
13
ext/zig/.gitignore
vendored
Normal file
@@ -0,0 +1,13 @@
|
||||
# Zig build artifacts
|
||||
.zig-cache/
|
||||
zig-out/
|
||||
|
||||
# Generated binaries (keep .c sources, ignore compiled artifacts)
|
||||
/c_abi_test
|
||||
/c_abi_append_test
|
||||
c_abi_append_shared
|
||||
tests/c_abi_append_test
|
||||
|
||||
# Temp files
|
||||
*.o
|
||||
*.tmp
|
||||
67
ext/zig/build.zig
Normal file
67
ext/zig/build.zig
Normal file
@@ -0,0 +1,67 @@
|
||||
const std = @import("std");
|
||||
|
||||
pub fn build(b: *std.Build) void {
|
||||
const target = b.standardTargetOptions(.{});
|
||||
const optimize = b.standardOptimizeOption(.{});
|
||||
|
||||
// -- kernel generator tool (runs on build host) --
|
||||
const gen_kernel_mod = b.createModule(.{
|
||||
.root_source_file = b.path("tools/gen_kernel.zig"),
|
||||
.target = b.graph.host,
|
||||
.optimize = .ReleaseSafe,
|
||||
});
|
||||
const gen_kernel = b.addExecutable(.{
|
||||
.name = "gen_kernel",
|
||||
.root_module = gen_kernel_mod,
|
||||
});
|
||||
|
||||
const run_gen_kernel = b.addRunArtifact(gen_kernel);
|
||||
run_gen_kernel.addFileArg(b.path("kernel_run_arboricx_typed.dag"));
|
||||
const kernel_embed = run_gen_kernel.addOutputFileArg("kernel_embed.zig");
|
||||
|
||||
// -- kernel module shared by exe and lib --
|
||||
const kernel_mod = b.createModule(.{
|
||||
.root_source_file = kernel_embed,
|
||||
});
|
||||
|
||||
// -- main CLI executable --
|
||||
const exe_mod = b.createModule(.{
|
||||
.root_source_file = b.path("src/main.zig"),
|
||||
.target = target,
|
||||
.optimize = optimize,
|
||||
});
|
||||
exe_mod.addImport("kernel_embed", kernel_mod);
|
||||
const exe = b.addExecutable(.{
|
||||
.name = "tricu-zig",
|
||||
.root_module = exe_mod,
|
||||
});
|
||||
b.installArtifact(exe);
|
||||
|
||||
const run_cmd = b.addRunArtifact(exe);
|
||||
run_cmd.step.dependOn(b.getInstallStep());
|
||||
const run_step = b.step("run", "Run tricu-zig");
|
||||
run_step.dependOn(&run_cmd.step);
|
||||
|
||||
// -- C ABI static library --
|
||||
const lib_mod = b.createModule(.{
|
||||
.root_source_file = b.path("src/c_abi.zig"),
|
||||
.target = target,
|
||||
.optimize = optimize,
|
||||
});
|
||||
lib_mod.pic = true;
|
||||
lib_mod.addImport("kernel_embed", kernel_mod);
|
||||
const static_lib = b.addLibrary(.{
|
||||
.name = "arboricx",
|
||||
.root_module = lib_mod,
|
||||
});
|
||||
b.installArtifact(static_lib);
|
||||
|
||||
// -- C ABI shared library (for dynamic language FFI) --
|
||||
const shared_lib = b.addLibrary(.{
|
||||
.name = "arboricx",
|
||||
.root_module = lib_mod,
|
||||
.linkage = .dynamic,
|
||||
});
|
||||
b.installArtifact(shared_lib);
|
||||
|
||||
}
|
||||
13
ext/zig/build.zig.zon
Normal file
13
ext/zig/build.zig.zon
Normal file
@@ -0,0 +1,13 @@
|
||||
.{
|
||||
.name = .tricu_zig,
|
||||
.version = "0.0.1",
|
||||
.fingerprint = 0xa9aedd8049d1cce9,
|
||||
.minimum_zig_version = "0.16.0",
|
||||
.paths = .{
|
||||
"build.zig",
|
||||
"build.zig.zon",
|
||||
"src",
|
||||
"tools",
|
||||
"kernels",
|
||||
},
|
||||
}
|
||||
54
ext/zig/include/arboricx.h
Normal file
54
ext/zig/include/arboricx.h
Normal file
@@ -0,0 +1,54 @@
|
||||
#ifndef ARBORICX_H
|
||||
#define ARBORICX_H
|
||||
|
||||
#include <stddef.h>
|
||||
#include <stdint.h>
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
typedef struct arb_ctx arb_ctx_t;
|
||||
|
||||
/* Context lifecycle */
|
||||
arb_ctx_t* arboricx_init(void);
|
||||
void arboricx_free(arb_ctx_t* ctx);
|
||||
void arboricx_free_buf(arb_ctx_t* ctx, uint8_t* ptr, size_t len);
|
||||
|
||||
/* Tree construction */
|
||||
uint32_t arb_leaf(arb_ctx_t* ctx);
|
||||
uint32_t arb_stem(arb_ctx_t* ctx, uint32_t child);
|
||||
uint32_t arb_fork(arb_ctx_t* ctx, uint32_t left, uint32_t right);
|
||||
uint32_t arb_app(arb_ctx_t* ctx, uint32_t func, uint32_t arg);
|
||||
|
||||
/* Reduction */
|
||||
uint32_t arb_reduce(arb_ctx_t* ctx, uint32_t root, uint64_t fuel);
|
||||
|
||||
/* Codec constructors */
|
||||
uint32_t arb_of_number(arb_ctx_t* ctx, uint64_t n);
|
||||
uint32_t arb_of_string(arb_ctx_t* ctx, const char* s);
|
||||
uint32_t arb_of_bytes(arb_ctx_t* ctx, const uint8_t* bytes, size_t len);
|
||||
uint32_t arb_of_list(arb_ctx_t* ctx, const uint32_t* items, size_t len);
|
||||
|
||||
/* Codec destructors (return 1 on success, 0 on failure) */
|
||||
int arb_to_number(arb_ctx_t* ctx, uint32_t root, uint64_t* out);
|
||||
int arb_to_string(arb_ctx_t* ctx, uint32_t root, uint8_t** out_ptr, size_t* out_len);
|
||||
int arb_to_bytes(arb_ctx_t* ctx, uint32_t root, uint8_t** out_ptr, size_t* out_len);
|
||||
int arb_to_bool(arb_ctx_t* ctx, uint32_t root, int* out);
|
||||
|
||||
/* Result unwrapping (return 1 on success, 0 on failure) */
|
||||
int arb_unwrap_result(arb_ctx_t* ctx, uint32_t root, int* out_ok, uint32_t* out_value, uint32_t* out_rest);
|
||||
int arb_unwrap_host_value(arb_ctx_t* ctx, uint32_t root, uint64_t* out_tag, uint32_t* out_payload);
|
||||
|
||||
/* Kernel entrypoints */
|
||||
uint32_t arb_kernel_root(arb_ctx_t* ctx);
|
||||
|
||||
/* Native bundle loading (fast path — bypasses the Tricu kernel) */
|
||||
uint32_t arb_load_bundle(arb_ctx_t* ctx, const uint8_t* bytes, size_t len, const char* name);
|
||||
uint32_t arb_load_bundle_default(arb_ctx_t* ctx, const uint8_t* bytes, size_t len);
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* ARBORICX_H */
|
||||
2694
ext/zig/kernel_run_arboricx_typed.dag
Normal file
2694
ext/zig/kernel_run_arboricx_typed.dag
Normal file
File diff suppressed because it is too large
Load Diff
36
ext/zig/src/arena.zig
Normal file
36
ext/zig/src/arena.zig
Normal file
@@ -0,0 +1,36 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
|
||||
pub const Arena = struct {
|
||||
allocator: std.mem.Allocator,
|
||||
nodes: std.ArrayList(tree.Node),
|
||||
|
||||
pub fn init(allocator: std.mem.Allocator) Arena {
|
||||
return .{
|
||||
.allocator = allocator,
|
||||
.nodes = .empty,
|
||||
};
|
||||
}
|
||||
|
||||
pub fn deinit(self: *Arena) void {
|
||||
self.nodes.deinit(self.allocator);
|
||||
}
|
||||
|
||||
pub fn alloc(self: *Arena, node: tree.Node) !u32 {
|
||||
const idx: u32 = @intCast(self.nodes.items.len);
|
||||
try self.nodes.append(self.allocator, node);
|
||||
return idx;
|
||||
}
|
||||
|
||||
pub fn get(self: *Arena, idx: u32) *tree.Node {
|
||||
return &self.nodes.items[idx];
|
||||
}
|
||||
|
||||
pub fn len(self: *const Arena) u32 {
|
||||
return @intCast(self.nodes.items.len);
|
||||
}
|
||||
|
||||
pub fn reset(self: *Arena, keep: u32) void {
|
||||
self.nodes.shrinkRetainingCapacity(keep);
|
||||
}
|
||||
};
|
||||
479
ext/zig/src/bundle.zig
Normal file
479
ext/zig/src/bundle.zig
Normal file
@@ -0,0 +1,479 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
|
||||
pub const Hash = [32]u8;
|
||||
|
||||
pub const Error = error{
|
||||
InvalidMagic,
|
||||
InvalidVersion,
|
||||
Truncated,
|
||||
InvalidManifest,
|
||||
InvalidNodePayload,
|
||||
HashMismatch,
|
||||
ExportNotFound,
|
||||
MissingChild,
|
||||
UnexpectedFormat,
|
||||
DigestMismatch,
|
||||
OutOfMemory,
|
||||
};
|
||||
|
||||
const Parser = struct {
|
||||
bytes: []const u8,
|
||||
pos: usize,
|
||||
|
||||
fn init(bytes: []const u8) Parser {
|
||||
return .{ .bytes = bytes, .pos = 0 };
|
||||
}
|
||||
|
||||
fn remaining(self: *const Parser) usize {
|
||||
return self.bytes.len - self.pos;
|
||||
}
|
||||
|
||||
fn expect(self: *Parser, n: usize) Error![]const u8 {
|
||||
if (self.remaining() < n) return error.Truncated;
|
||||
const result = self.bytes[self.pos .. self.pos + n];
|
||||
self.pos += n;
|
||||
return result;
|
||||
}
|
||||
|
||||
fn readU8(self: *Parser) Error!u8 {
|
||||
const b = try self.expect(1);
|
||||
return b[0];
|
||||
}
|
||||
|
||||
fn readU16(self: *Parser) Error!u16 {
|
||||
const b = try self.expect(2);
|
||||
return std.mem.readInt(u16, b[0..2], .big);
|
||||
}
|
||||
|
||||
fn readU32(self: *Parser) Error!u32 {
|
||||
const b = try self.expect(4);
|
||||
return std.mem.readInt(u32, b[0..4], .big);
|
||||
}
|
||||
|
||||
fn readU64(self: *Parser) Error!u64 {
|
||||
const b = try self.expect(8);
|
||||
return std.mem.readInt(u64, b[0..8], .big);
|
||||
}
|
||||
|
||||
fn readHash(self: *Parser) Error!Hash {
|
||||
const b = try self.expect(32);
|
||||
var h: Hash = undefined;
|
||||
@memcpy(&h, b);
|
||||
return h;
|
||||
}
|
||||
|
||||
fn readLengthPrefixedBytes(self: *Parser, allocator: std.mem.Allocator) Error![]const u8 {
|
||||
const len = try self.readU32();
|
||||
const bytes = try self.expect(len);
|
||||
const copy = try allocator.alloc(u8, bytes.len);
|
||||
@memcpy(copy, bytes);
|
||||
return copy;
|
||||
}
|
||||
};
|
||||
|
||||
const SectionEntry = struct {
|
||||
section_type: u32,
|
||||
offset: u64,
|
||||
length: u64,
|
||||
digest: Hash,
|
||||
};
|
||||
|
||||
fn parseHeader(p: *Parser) Error!struct { major: u16, minor: u16, section_count: u32, dir_offset: u64 } {
|
||||
const magic = try p.expect(8);
|
||||
if (!std.mem.eql(u8, magic, "ARBORICX")) return error.InvalidMagic;
|
||||
|
||||
const major = try p.readU16();
|
||||
const minor = try p.readU16();
|
||||
const section_count = try p.readU32();
|
||||
_ = try p.readU64(); // flags
|
||||
const dir_offset = try p.readU64();
|
||||
|
||||
if (major != 1) return error.InvalidVersion;
|
||||
|
||||
return .{ .major = major, .minor = minor, .section_count = section_count, .dir_offset = dir_offset };
|
||||
}
|
||||
|
||||
fn parseSectionEntries(p: *Parser, count: u32, allocator: std.mem.Allocator) Error![]SectionEntry {
|
||||
const entries = try allocator.alloc(SectionEntry, count);
|
||||
errdefer allocator.free(entries);
|
||||
|
||||
for (entries) |*entry| {
|
||||
entry.section_type = try p.readU32();
|
||||
_ = try p.readU16(); // section_version
|
||||
_ = try p.readU16(); // section_flags
|
||||
const compression = try p.readU16();
|
||||
const digest_alg = try p.readU16();
|
||||
entry.offset = try p.readU64();
|
||||
entry.length = try p.readU64();
|
||||
entry.digest = try p.readHash();
|
||||
|
||||
if (compression != 0) return error.UnexpectedFormat;
|
||||
if (digest_alg != 1) return error.UnexpectedFormat;
|
||||
}
|
||||
return entries;
|
||||
}
|
||||
|
||||
fn sha256Digest(data: []const u8) Hash {
|
||||
var h = std.crypto.hash.sha2.Sha256.init(.{});
|
||||
h.update(data);
|
||||
var out: Hash = undefined;
|
||||
h.final(&out);
|
||||
return out;
|
||||
}
|
||||
|
||||
fn parseManifest(p: *Parser, allocator: std.mem.Allocator) Error!struct { exports: []Export, roots: []Root } {
|
||||
const magic = try p.expect(8);
|
||||
if (!std.mem.eql(u8, magic, "ARBMNFST")) return error.InvalidManifest;
|
||||
|
||||
const major = try p.readU16();
|
||||
_ = try p.readU16(); // minor
|
||||
if (major != 1) return error.InvalidVersion;
|
||||
|
||||
const schema = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(schema);
|
||||
if (!std.mem.eql(u8, schema, "arboricx.bundle.manifest.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const bundle_type = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(bundle_type);
|
||||
if (!std.mem.eql(u8, bundle_type, "tree-calculus-executable-object")) return error.UnexpectedFormat;
|
||||
|
||||
const calc = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(calc);
|
||||
if (!std.mem.eql(u8, calc, "tree-calculus.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const hash_alg = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(hash_alg);
|
||||
if (!std.mem.eql(u8, hash_alg, "sha256")) return error.UnexpectedFormat;
|
||||
|
||||
const hash_domain = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(hash_domain);
|
||||
if (!std.mem.eql(u8, hash_domain, "arboricx.merkle.node.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const payload_type = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(payload_type);
|
||||
if (!std.mem.eql(u8, payload_type, "arboricx.merkle.payload.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const sem = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(sem);
|
||||
if (!std.mem.eql(u8, sem, "tree-calculus.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const eval_mode = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(eval_mode);
|
||||
if (!std.mem.eql(u8, eval_mode, "normal-order")) return error.UnexpectedFormat;
|
||||
|
||||
const abi = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(abi);
|
||||
if (!std.mem.eql(u8, abi, "arboricx.abi.tree.v1")) return error.UnexpectedFormat;
|
||||
|
||||
const cap_count = try p.readU32();
|
||||
var i: u32 = 0;
|
||||
while (i < cap_count) : (i += 1) {
|
||||
const cap = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(cap);
|
||||
if (cap.len != 0) return error.UnexpectedFormat;
|
||||
}
|
||||
|
||||
const closure = try p.readU8();
|
||||
if (closure != 0) return error.UnexpectedFormat;
|
||||
|
||||
const root_count = try p.readU32();
|
||||
const roots = try allocator.alloc(Root, root_count);
|
||||
errdefer allocator.free(roots);
|
||||
for (roots) |*r| {
|
||||
r.hash = try p.readHash();
|
||||
r.role = try p.readLengthPrefixedBytes(allocator);
|
||||
}
|
||||
|
||||
const export_count = try p.readU32();
|
||||
const exports = try allocator.alloc(Export, export_count);
|
||||
errdefer {
|
||||
for (exports) |*e| {
|
||||
allocator.free(e.name);
|
||||
allocator.free(e.kind);
|
||||
allocator.free(e.abi);
|
||||
}
|
||||
allocator.free(exports);
|
||||
}
|
||||
for (exports) |*e| {
|
||||
e.name = try p.readLengthPrefixedBytes(allocator);
|
||||
e.root = try p.readHash();
|
||||
e.kind = try p.readLengthPrefixedBytes(allocator);
|
||||
e.abi = try p.readLengthPrefixedBytes(allocator);
|
||||
if (!std.mem.eql(u8, e.abi, "arboricx.abi.tree.v1")) return error.UnexpectedFormat;
|
||||
}
|
||||
|
||||
const metadata_count = try p.readU32();
|
||||
var m: u32 = 0;
|
||||
while (m < metadata_count) : (m += 1) {
|
||||
_ = try p.readU16(); // tag
|
||||
const len = try p.readU32();
|
||||
_ = try p.expect(len);
|
||||
}
|
||||
|
||||
const ext_count = try p.readU32();
|
||||
var e_idx: u32 = 0;
|
||||
while (e_idx < ext_count) : (e_idx += 1) {
|
||||
_ = try p.readU16(); // tag
|
||||
const len = try p.readU32();
|
||||
_ = try p.expect(len);
|
||||
}
|
||||
|
||||
return .{ .exports = exports, .roots = roots };
|
||||
}
|
||||
|
||||
const Export = struct {
|
||||
name: []const u8,
|
||||
root: Hash,
|
||||
kind: []const u8,
|
||||
abi: []const u8,
|
||||
};
|
||||
|
||||
const Root = struct {
|
||||
hash: Hash,
|
||||
role: []const u8,
|
||||
};
|
||||
|
||||
fn parseNodeSection(p: *Parser, allocator: std.mem.Allocator) Error!std.AutoHashMap(Hash, []const u8) {
|
||||
const node_count = try p.readU64();
|
||||
var map = std.AutoHashMap(Hash, []const u8).init(allocator);
|
||||
errdefer map.deinit();
|
||||
|
||||
var i: u64 = 0;
|
||||
while (i < node_count) : (i += 1) {
|
||||
const hash = try p.readHash();
|
||||
const plen = try p.readU32();
|
||||
const payload = try p.expect(plen);
|
||||
|
||||
const expected_hash = blk: {
|
||||
var h = std.crypto.hash.sha2.Sha256.init(.{});
|
||||
h.update("arboricx.merkle.node.v1");
|
||||
h.update(&[_]u8{0});
|
||||
h.update(payload);
|
||||
var out: Hash = undefined;
|
||||
h.final(&out);
|
||||
break :blk out;
|
||||
};
|
||||
if (!std.mem.eql(u8, &hash, &expected_hash)) return error.HashMismatch;
|
||||
|
||||
try map.put(hash, payload);
|
||||
}
|
||||
|
||||
return map;
|
||||
}
|
||||
|
||||
fn loadNode(
|
||||
arena: *Arena,
|
||||
payloads: std.AutoHashMap(Hash, []const u8),
|
||||
cache: *std.AutoHashMap(Hash, u32),
|
||||
root_hash: Hash,
|
||||
) Error!u32 {
|
||||
const Frame = struct {
|
||||
hash: Hash,
|
||||
state: u2,
|
||||
};
|
||||
|
||||
const max_stack = payloads.count() * 2;
|
||||
var stack = try arena.allocator.alloc(Frame, max_stack);
|
||||
defer arena.allocator.free(stack);
|
||||
var sp: usize = 0;
|
||||
|
||||
stack[sp] = .{ .hash = root_hash, .state = 0 };
|
||||
sp += 1;
|
||||
|
||||
while (sp > 0) {
|
||||
const frame = &stack[sp - 1];
|
||||
|
||||
if (cache.get(frame.hash)) |_| {
|
||||
sp -= 1;
|
||||
continue;
|
||||
}
|
||||
|
||||
if (frame.state == 0) {
|
||||
frame.state = 1;
|
||||
const payload = payloads.get(frame.hash) orelse return error.MissingChild;
|
||||
if (payload.len == 0) return error.InvalidNodePayload;
|
||||
|
||||
switch (payload[0]) {
|
||||
0x00 => {
|
||||
if (payload.len != 1) return error.InvalidNodePayload;
|
||||
},
|
||||
0x01 => {
|
||||
if (payload.len != 33) return error.InvalidNodePayload;
|
||||
var child_hash: Hash = undefined;
|
||||
@memcpy(&child_hash, payload[1..33]);
|
||||
if (cache.get(child_hash) == null) {
|
||||
stack[sp] = .{ .hash = child_hash, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
},
|
||||
0x02 => {
|
||||
if (payload.len != 65) return error.InvalidNodePayload;
|
||||
var left_hash: Hash = undefined;
|
||||
var right_hash: Hash = undefined;
|
||||
@memcpy(&left_hash, payload[1..33]);
|
||||
@memcpy(&right_hash, payload[33..65]);
|
||||
const need_right = cache.get(right_hash) == null;
|
||||
const need_left = cache.get(left_hash) == null;
|
||||
if (need_right) {
|
||||
stack[sp] = .{ .hash = right_hash, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
if (need_left) {
|
||||
stack[sp] = .{ .hash = left_hash, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
},
|
||||
else => return error.InvalidNodePayload,
|
||||
}
|
||||
} else {
|
||||
const payload = payloads.get(frame.hash).?;
|
||||
const idx: u32 = switch (payload[0]) {
|
||||
0x00 => try arena.alloc(.leaf),
|
||||
0x01 => blk: {
|
||||
var child_hash: Hash = undefined;
|
||||
@memcpy(&child_hash, payload[1..33]);
|
||||
const child_idx = cache.get(child_hash).?;
|
||||
break :blk try arena.alloc(.{ .stem = .{ .child = child_idx } });
|
||||
},
|
||||
0x02 => blk: {
|
||||
var left_hash: Hash = undefined;
|
||||
var right_hash: Hash = undefined;
|
||||
@memcpy(&left_hash, payload[1..33]);
|
||||
@memcpy(&right_hash, payload[33..65]);
|
||||
const left_idx = cache.get(left_hash).?;
|
||||
const right_idx = cache.get(right_hash).?;
|
||||
break :blk try arena.alloc(.{ .fork = .{ .left = left_idx, .right = right_idx } });
|
||||
},
|
||||
else => unreachable,
|
||||
};
|
||||
try cache.put(frame.hash, idx);
|
||||
sp -= 1;
|
||||
}
|
||||
}
|
||||
|
||||
return cache.get(root_hash) orelse return error.MissingChild;
|
||||
}
|
||||
|
||||
/// Parse an Arboricx bundle and load the named export into the arena.
|
||||
/// Returns the arena index of the exported term tree.
|
||||
pub fn loadBundleExport(
|
||||
arena: *Arena,
|
||||
bundle_bytes: []const u8,
|
||||
export_name: []const u8,
|
||||
) Error!u32 {
|
||||
var p = Parser.init(bundle_bytes);
|
||||
|
||||
const header = try parseHeader(&p);
|
||||
|
||||
p.pos = @intCast(header.dir_offset);
|
||||
const allocator = arena.allocator;
|
||||
const entries = try parseSectionEntries(&p, header.section_count, allocator);
|
||||
defer allocator.free(entries);
|
||||
|
||||
var manifest_entry: ?SectionEntry = null;
|
||||
var nodes_entry: ?SectionEntry = null;
|
||||
for (entries) |entry| {
|
||||
if (entry.section_type == 1) manifest_entry = entry;
|
||||
if (entry.section_type == 2) nodes_entry = entry;
|
||||
}
|
||||
const manifest_section = manifest_entry orelse return error.InvalidManifest;
|
||||
const nodes_section = nodes_entry orelse return error.InvalidNodePayload;
|
||||
|
||||
const manifest_bytes = bundle_bytes[@intCast(manifest_section.offset)..@intCast(manifest_section.offset + manifest_section.length)];
|
||||
if (!std.mem.eql(u8, &sha256Digest(manifest_bytes), &manifest_section.digest)) return error.DigestMismatch;
|
||||
|
||||
const nodes_bytes = bundle_bytes[@intCast(nodes_section.offset)..@intCast(nodes_section.offset + nodes_section.length)];
|
||||
if (!std.mem.eql(u8, &sha256Digest(nodes_bytes), &nodes_section.digest)) return error.DigestMismatch;
|
||||
|
||||
var mp = Parser.init(manifest_bytes);
|
||||
const manifest = try parseManifest(&mp, allocator);
|
||||
defer {
|
||||
for (manifest.exports) |e| {
|
||||
allocator.free(e.name);
|
||||
allocator.free(e.kind);
|
||||
allocator.free(e.abi);
|
||||
}
|
||||
allocator.free(manifest.exports);
|
||||
for (manifest.roots) |r| {
|
||||
allocator.free(r.role);
|
||||
}
|
||||
allocator.free(manifest.roots);
|
||||
}
|
||||
|
||||
var export_hash: ?Hash = null;
|
||||
for (manifest.exports) |e| {
|
||||
if (std.mem.eql(u8, e.name, export_name)) {
|
||||
export_hash = e.root;
|
||||
break;
|
||||
}
|
||||
}
|
||||
const root_hash = export_hash orelse return error.ExportNotFound;
|
||||
|
||||
var np = Parser.init(nodes_bytes);
|
||||
var payloads = try parseNodeSection(&np, allocator);
|
||||
defer payloads.deinit();
|
||||
|
||||
var cache = std.AutoHashMap(Hash, u32).init(allocator);
|
||||
defer cache.deinit();
|
||||
|
||||
return try loadNode(arena, payloads, &cache, root_hash);
|
||||
}
|
||||
|
||||
/// Parse an Arboricx bundle and load the default (first) root into the arena.
|
||||
pub fn loadBundleDefaultRoot(
|
||||
arena: *Arena,
|
||||
bundle_bytes: []const u8,
|
||||
) Error!u32 {
|
||||
var p = Parser.init(bundle_bytes);
|
||||
|
||||
const header = try parseHeader(&p);
|
||||
|
||||
p.pos = @intCast(header.dir_offset);
|
||||
const allocator = arena.allocator;
|
||||
const entries = try parseSectionEntries(&p, header.section_count, allocator);
|
||||
defer allocator.free(entries);
|
||||
|
||||
var manifest_entry: ?SectionEntry = null;
|
||||
var nodes_entry: ?SectionEntry = null;
|
||||
for (entries) |entry| {
|
||||
if (entry.section_type == 1) manifest_entry = entry;
|
||||
if (entry.section_type == 2) nodes_entry = entry;
|
||||
}
|
||||
const manifest_section = manifest_entry orelse return error.InvalidManifest;
|
||||
const nodes_section = nodes_entry orelse return error.InvalidNodePayload;
|
||||
|
||||
const manifest_bytes = bundle_bytes[@intCast(manifest_section.offset)..@intCast(manifest_section.offset + manifest_section.length)];
|
||||
if (!std.mem.eql(u8, &sha256Digest(manifest_bytes), &manifest_section.digest)) return error.DigestMismatch;
|
||||
|
||||
const nodes_bytes = bundle_bytes[@intCast(nodes_section.offset)..@intCast(nodes_section.offset + nodes_section.length)];
|
||||
if (!std.mem.eql(u8, &sha256Digest(nodes_bytes), &nodes_section.digest)) return error.DigestMismatch;
|
||||
|
||||
var mp = Parser.init(manifest_bytes);
|
||||
const manifest = try parseManifest(&mp, allocator);
|
||||
defer {
|
||||
for (manifest.exports) |e| {
|
||||
allocator.free(e.name);
|
||||
allocator.free(e.kind);
|
||||
allocator.free(e.abi);
|
||||
}
|
||||
allocator.free(manifest.exports);
|
||||
for (manifest.roots) |r| {
|
||||
allocator.free(r.role);
|
||||
}
|
||||
allocator.free(manifest.roots);
|
||||
}
|
||||
|
||||
if (manifest.roots.len == 0) return error.ExportNotFound;
|
||||
const root_hash = manifest.roots[0].hash;
|
||||
|
||||
var np = Parser.init(nodes_bytes);
|
||||
var payloads = try parseNodeSection(&np, allocator);
|
||||
defer payloads.deinit();
|
||||
|
||||
var cache = std.AutoHashMap(Hash, u32).init(allocator);
|
||||
defer cache.deinit();
|
||||
|
||||
return try loadNode(arena, payloads, &cache, root_hash);
|
||||
}
|
||||
183
ext/zig/src/c_abi.zig
Normal file
183
ext/zig/src/c_abi.zig
Normal file
@@ -0,0 +1,183 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
const reduce = @import("reduce.zig");
|
||||
const codecs = @import("codecs.zig");
|
||||
const kernel = @import("kernel.zig");
|
||||
const bundle = @import("bundle.zig");
|
||||
|
||||
/// Opaque handle for the C API. Layout is not exposed to C.
|
||||
/// Holds a persistent arena for user-built terms and the kernel.
|
||||
pub const ArbCtx = struct {
|
||||
gpa: std.mem.Allocator,
|
||||
arena: Arena,
|
||||
kernel_root: u32,
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Context lifecycle
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arboricx_init() ?*ArbCtx {
|
||||
const ptr = std.heap.smp_allocator.create(ArbCtx) catch return null;
|
||||
ptr.gpa = std.heap.smp_allocator;
|
||||
ptr.arena = Arena.init(std.heap.smp_allocator);
|
||||
ptr.kernel_root = kernel.loadKernel(&ptr.arena) catch {
|
||||
ptr.arena.deinit();
|
||||
std.heap.smp_allocator.destroy(ptr);
|
||||
return null;
|
||||
};
|
||||
return ptr;
|
||||
}
|
||||
|
||||
export fn arboricx_free(ctx: *ArbCtx) void {
|
||||
ctx.arena.deinit();
|
||||
ctx.gpa.destroy(ctx);
|
||||
}
|
||||
|
||||
export fn arboricx_free_buf(_: *ArbCtx, ptr: [*]u8, len: usize) void {
|
||||
std.heap.smp_allocator.free(ptr[0..len]);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Tree construction (all write into the persistent arena)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_leaf(ctx: *ArbCtx) u32 {
|
||||
return ctx.arena.alloc(.leaf) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_stem(ctx: *ArbCtx, child: u32) u32 {
|
||||
return ctx.arena.alloc(.{ .stem = .{ .child = child } }) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_fork(ctx: *ArbCtx, left: u32, right: u32) u32 {
|
||||
return ctx.arena.alloc(.{ .fork = .{ .left = left, .right = right } }) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_app(ctx: *ArbCtx, func: u32, arg: u32) u32 {
|
||||
return ctx.arena.alloc(.{ .app = .{ .func = func, .arg = arg } }) catch 0;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Reduction
|
||||
// ---------------------------------------------------------------------------
|
||||
/// Reduces `root` in a *fresh* scratch arena so that garbage from previous
|
||||
/// reductions never accumulates. The kernel and term are deep-copied into
|
||||
/// the scratch arena, reduced there, and the result is copied back into the
|
||||
/// persistent arena.
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_reduce(ctx: *ArbCtx, root: u32, fuel: u64) u32 {
|
||||
// 1. Fresh scratch arena
|
||||
var scratch = Arena.init(ctx.gpa);
|
||||
defer scratch.deinit();
|
||||
|
||||
// 2. Deep-copy the term (which may reference kernel nodes) into scratch
|
||||
const scratch_root = tree.copyTree(ctx.arena.nodes.items, &scratch, root) catch return 0;
|
||||
|
||||
// 3. Reduce in scratch
|
||||
const scratch_result = reduce.reduce(scratch_root, &scratch, fuel) catch return 0;
|
||||
|
||||
// 4. Copy the result back to the persistent arena
|
||||
return tree.copyTree(scratch.nodes.items, &ctx.arena, scratch_result) catch 0;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Codec constructors
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_of_number(ctx: *ArbCtx, n: u64) u32 {
|
||||
return codecs.ofNumber(&ctx.arena, n) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_of_string(ctx: *ArbCtx, s: [*:0]const u8) u32 {
|
||||
const slice = std.mem.sliceTo(s, 0);
|
||||
return codecs.ofString(&ctx.arena, slice) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_of_bytes(ctx: *ArbCtx, bytes: [*]const u8, len: usize) u32 {
|
||||
return codecs.ofBytes(&ctx.arena, bytes[0..len]) catch 0;
|
||||
}
|
||||
|
||||
export fn arb_of_list(ctx: *ArbCtx, items: [*]const u32, len: usize) u32 {
|
||||
return codecs.ofList(&ctx.arena, items[0..len]) catch 0;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Codec destructors
|
||||
// Return 1 on success, 0 on failure.
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_to_number(ctx: *ArbCtx, root: u32, out: *u64) c_int {
|
||||
const n = codecs.toNumber(&ctx.arena, root) catch return 0;
|
||||
if (n == null) return 0;
|
||||
out.* = n.?;
|
||||
return 1;
|
||||
}
|
||||
|
||||
export fn arb_to_string(ctx: *ArbCtx, root: u32, out_ptr: **u8, out_len: *usize) c_int {
|
||||
const s = codecs.toString(&ctx.arena, root) catch return 0;
|
||||
if (s == null) return 0;
|
||||
out_ptr.* = @ptrCast(s.?.ptr);
|
||||
out_len.* = s.?.len;
|
||||
return 1;
|
||||
}
|
||||
|
||||
export fn arb_to_bytes(ctx: *ArbCtx, root: u32, out_ptr: **u8, out_len: *usize) c_int {
|
||||
return arb_to_string(ctx, root, out_ptr, out_len);
|
||||
}
|
||||
|
||||
export fn arb_to_bool(ctx: *ArbCtx, root: u32, out: *c_int) c_int {
|
||||
const b = codecs.toBool(&ctx.arena, root) catch return 0;
|
||||
if (b == null) return 0;
|
||||
out.* = if (b.?) 1 else 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Result unwrapping
|
||||
// Return 1 on success, 0 on failure.
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_unwrap_result(ctx: *ArbCtx, root: u32, out_ok: *c_int, out_value: *u32, out_rest: *u32) c_int {
|
||||
const r = codecs.unwrapResult(&ctx.arena, root) catch return 0;
|
||||
if (r == null) return 0;
|
||||
out_ok.* = if (r.?.ok) 1 else 0;
|
||||
out_value.* = r.?.value;
|
||||
out_rest.* = r.?.rest;
|
||||
return 1;
|
||||
}
|
||||
|
||||
export fn arb_unwrap_host_value(ctx: *ArbCtx, root: u32, out_tag: *u64, out_payload: *u32) c_int {
|
||||
const hv = codecs.unwrapHostValue(&ctx.arena, root) catch return 0;
|
||||
if (hv == null) return 0;
|
||||
out_tag.* = hv.?.tag;
|
||||
out_payload.* = hv.?.payload;
|
||||
return 1;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Kernel entrypoints
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_kernel_root(ctx: *ArbCtx) u32 {
|
||||
return ctx.kernel_root;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Native bundle loading (fast path — bypasses the Tricu kernel)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
/// Load a named export from an Arboricx bundle directly into the arena.
|
||||
/// Returns the arena index of the exported term, or 0 on error.
|
||||
export fn arb_load_bundle(ctx: *ArbCtx, bytes: [*]const u8, len: usize, name: [*:0]const u8) u32 {
|
||||
const name_slice = std.mem.sliceTo(name, 0);
|
||||
return bundle.loadBundleExport(&ctx.arena, bytes[0..len], name_slice) catch 0;
|
||||
}
|
||||
|
||||
/// Load the default root from an Arboricx bundle directly into the arena.
|
||||
/// Returns the arena index of the root term, or 0 on error.
|
||||
export fn arb_load_bundle_default(ctx: *ArbCtx, bytes: [*]const u8, len: usize) u32 {
|
||||
return bundle.loadBundleDefaultRoot(&ctx.arena, bytes[0..len]) catch 0;
|
||||
}
|
||||
205
ext/zig/src/codecs.zig
Normal file
205
ext/zig/src/codecs.zig
Normal file
@@ -0,0 +1,205 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
const reduce = @import("reduce.zig");
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Number encoding/decoding
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn ofNumber(arena: *Arena, n: u64) !u32 {
|
||||
if (n == 0) {
|
||||
return try arena.alloc(.leaf);
|
||||
}
|
||||
const bit = if (n % 2 == 1) try arena.alloc(.{ .stem = .{ .child = try arena.alloc(.leaf) } }) else try arena.alloc(.leaf);
|
||||
const rest = try ofNumber(arena, n / 2);
|
||||
return try arena.alloc(.{ .fork = .{ .left = bit, .right = rest } });
|
||||
}
|
||||
|
||||
pub fn toNumber(arena: *Arena, idx: u32) !?u64 {
|
||||
const node = try reduce.reduce(idx, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
return switch (n.*) {
|
||||
.leaf => 0,
|
||||
.stem => return null,
|
||||
.fork => |f| blk: {
|
||||
const bit_node = try reduce.reduce(f.left, arena, 10_000);
|
||||
const bit = arena.get(bit_node);
|
||||
const bit_val: u64 = switch (bit.*) {
|
||||
.leaf => 0,
|
||||
.stem => |s| if (arena.get(s.child).* == .leaf) 1 else return null,
|
||||
else => return null,
|
||||
};
|
||||
const rest = try toNumber(arena, f.right) orelse return null;
|
||||
break :blk bit_val + 2 * rest;
|
||||
},
|
||||
.app => return null,
|
||||
};
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// List encoding/decoding
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn ofList(arena: *Arena, items: []const u32) !u32 {
|
||||
var result = try arena.alloc(.leaf);
|
||||
var i: usize = items.len;
|
||||
while (i > 0) {
|
||||
i -= 1;
|
||||
result = try arena.alloc(.{ .fork = .{ .left = items[i], .right = result } });
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
pub fn toList(arena: *Arena, idx: u32) !?std.ArrayList(u32) {
|
||||
var result = std.ArrayList(u32).empty;
|
||||
errdefer result.deinit(arena.allocator);
|
||||
|
||||
var current = idx;
|
||||
while (true) {
|
||||
const node = try reduce.reduce(current, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
switch (n.*) {
|
||||
.leaf => return result,
|
||||
.stem => return null,
|
||||
.fork => |f| {
|
||||
try result.append(arena.allocator, f.left);
|
||||
current = f.right;
|
||||
},
|
||||
.app => return null,
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// String / Bytes encoding/decoding
|
||||
// Strings are lists of byte values (each character encoded as a number tree).
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn ofString(arena: *Arena, s: []const u8) !u32 {
|
||||
var bytes = try arena.allocator.alloc(u32, s.len);
|
||||
defer arena.allocator.free(bytes);
|
||||
for (s, 0..) |c, i| {
|
||||
bytes[i] = try ofNumber(arena, c);
|
||||
}
|
||||
return try ofList(arena, bytes);
|
||||
}
|
||||
|
||||
pub fn toString(arena: *Arena, idx: u32) !?[]u8 {
|
||||
var list = try toList(arena, idx) orelse return null;
|
||||
defer list.deinit(arena.allocator);
|
||||
var result = try arena.allocator.alloc(u8, list.items.len);
|
||||
errdefer arena.allocator.free(result);
|
||||
for (list.items, 0..) |elem_idx, i| {
|
||||
const num = try toNumber(arena, elem_idx) orelse {
|
||||
arena.allocator.free(result);
|
||||
return null;
|
||||
};
|
||||
if (num > 255) {
|
||||
arena.allocator.free(result);
|
||||
return null;
|
||||
}
|
||||
result[i] = @intCast(num);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
pub fn ofBytes(arena: *Arena, bytes: []const u8) !u32 {
|
||||
return try ofString(arena, bytes);
|
||||
}
|
||||
|
||||
pub fn toBytes(arena: *Arena, idx: u32) !?[]u8 {
|
||||
return try toString(arena, idx);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Result unwrapping (ok/err protocol)
|
||||
// ok value rest = pair true (pair value rest)
|
||||
// err code rest = pair false (pair code rest)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const UnwrapResult = struct {
|
||||
ok: bool,
|
||||
value: u32,
|
||||
rest: u32,
|
||||
};
|
||||
|
||||
pub fn unwrapResult(arena: *Arena, idx: u32) !?UnwrapResult {
|
||||
const node = try reduce.reduce(idx, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
switch (n.*) {
|
||||
.fork => |f| {
|
||||
const tag = try reduce.reduce(f.left, arena, 10_000);
|
||||
const rest_pair = try reduce.reduce(f.right, arena, 10_000);
|
||||
const rp = arena.get(rest_pair);
|
||||
switch (rp.*) {
|
||||
.fork => |rf| {
|
||||
const is_ok = tree.sameTree(arena, tag, try arena.alloc(.{ .stem = .{ .child = try arena.alloc(.leaf) } }));
|
||||
return UnwrapResult{
|
||||
.ok = is_ok,
|
||||
.value = rf.left,
|
||||
.rest = rf.right,
|
||||
};
|
||||
},
|
||||
else => return null,
|
||||
}
|
||||
},
|
||||
else => return null,
|
||||
}
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Host ABI value unwrapping
|
||||
// A host ABI value is: pair tag payload
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const HostValue = struct {
|
||||
tag: u64,
|
||||
payload: u32,
|
||||
};
|
||||
|
||||
pub fn unwrapHostValue(arena: *Arena, idx: u32) !?HostValue {
|
||||
const node = try reduce.reduce(idx, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
switch (n.*) {
|
||||
.fork => |f| {
|
||||
const tag_num = try toNumber(arena, f.left) orelse return null;
|
||||
return HostValue{ .tag = tag_num, .payload = f.right };
|
||||
},
|
||||
else => return null,
|
||||
}
|
||||
}
|
||||
|
||||
/// Returns true if the tree is a valid boolean (Leaf=false, Stem Leaf=true).
|
||||
pub fn isBool(arena: *Arena, idx: u32) !bool {
|
||||
const node = try reduce.reduce(idx, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
return switch (n.*) {
|
||||
.leaf => true,
|
||||
.stem => |s| arena.get(s.child).* == .leaf,
|
||||
else => false,
|
||||
};
|
||||
}
|
||||
|
||||
/// Extract the boolean value: false for Leaf, true for Stem Leaf.
|
||||
/// Returns null if the tree is not a valid boolean.
|
||||
pub fn toBool(arena: *Arena, idx: u32) !?bool {
|
||||
const node = try reduce.reduce(idx, arena, 10_000);
|
||||
const n = arena.get(node);
|
||||
return switch (n.*) {
|
||||
.leaf => false,
|
||||
.stem => |s| if (arena.get(s.child).* == .leaf) true else null,
|
||||
else => null,
|
||||
};
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Host ABI tag constants
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const HOST_TREE_TAG: u64 = 0;
|
||||
pub const HOST_STRING_TAG: u64 = 1;
|
||||
pub const HOST_NUMBER_TAG: u64 = 2;
|
||||
pub const HOST_BOOL_TAG: u64 = 3;
|
||||
pub const HOST_LIST_TAG: u64 = 4;
|
||||
pub const HOST_BYTES_TAG: u64 = 5;
|
||||
22
ext/zig/src/kernel.zig
Normal file
22
ext/zig/src/kernel.zig
Normal file
@@ -0,0 +1,22 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
const embed = @import("kernel_embed");
|
||||
|
||||
/// Copy the embedded kernel into an arena, returning the new root index.
|
||||
/// This allows the kernel to be used in App nodes alongside application terms.
|
||||
pub fn loadKernel(arena: *Arena) !u32 {
|
||||
var mapping = try arena.allocator.alloc(u32, embed.kernel_nodes.len);
|
||||
defer arena.allocator.free(mapping);
|
||||
|
||||
for (embed.kernel_nodes, 0..) |node, i| {
|
||||
const idx: u32 = @intCast(i);
|
||||
mapping[idx] = switch (node) {
|
||||
.leaf => try arena.alloc(.leaf),
|
||||
.stem => |s| try arena.alloc(.{ .stem = .{ .child = mapping[s.child] } }),
|
||||
.fork => |f| try arena.alloc(.{ .fork = .{ .left = mapping[f.left], .right = mapping[f.right] } }),
|
||||
};
|
||||
}
|
||||
|
||||
return mapping[embed.kernel_root];
|
||||
}
|
||||
235
ext/zig/src/main.zig
Normal file
235
ext/zig/src/main.zig
Normal file
@@ -0,0 +1,235 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
const reduce = @import("reduce.zig");
|
||||
const codecs = @import("codecs.zig");
|
||||
const kernel = @import("kernel.zig");
|
||||
const bundle = @import("bundle.zig");
|
||||
|
||||
fn runNative(arena: *Arena, tag: u64, bundle_bytes: []const u8, args_raw: []const []const u8, io: std.Io) !void {
|
||||
const term = try bundle.loadBundleDefaultRoot(arena, bundle_bytes);
|
||||
|
||||
var current = term;
|
||||
for (args_raw) |arg| {
|
||||
const arg_tree = try parseArg(arena, arg);
|
||||
current = try arena.alloc(.{ .app = .{ .func = current, .arg = arg_tree } });
|
||||
}
|
||||
|
||||
const result = try reduce.reduce(current, arena, 1_000_000_000);
|
||||
|
||||
var stdout_buf: [4096]u8 = undefined;
|
||||
var stdout = std.Io.File.stdout().writer(io, &stdout_buf);
|
||||
|
||||
switch (tag) {
|
||||
codecs.HOST_STRING_TAG => {
|
||||
const s = try codecs.toString(arena, result) orelse {
|
||||
try stdout.interface.writeAll("Error: failed to decode string result\n");
|
||||
try stdout.flush();
|
||||
return error.DecodeFailed;
|
||||
};
|
||||
defer arena.allocator.free(s);
|
||||
try stdout.interface.writeAll(s);
|
||||
try stdout.interface.writeAll("\n");
|
||||
},
|
||||
codecs.HOST_NUMBER_TAG => {
|
||||
const n = try codecs.toNumber(arena, result) orelse 0;
|
||||
try stdout.interface.print("{d}\n", .{n});
|
||||
},
|
||||
codecs.HOST_BOOL_TAG => {
|
||||
const b = try codecs.toBool(arena, result) orelse {
|
||||
try stdout.interface.writeAll("Error: failed to decode bool result\n");
|
||||
try stdout.flush();
|
||||
return error.DecodeFailed;
|
||||
};
|
||||
try stdout.interface.writeAll(if (b) "true\n" else "false\n");
|
||||
},
|
||||
codecs.HOST_TREE_TAG => {
|
||||
try tree.formatTree(&stdout.interface, arena, result, 0);
|
||||
try stdout.interface.writeAll("\n");
|
||||
},
|
||||
else => {
|
||||
try stdout.interface.print("(tag={d}, payload=", .{tag});
|
||||
try tree.formatTree(&stdout.interface, arena, result, 0);
|
||||
try stdout.interface.writeAll(")\n");
|
||||
},
|
||||
}
|
||||
try stdout.flush();
|
||||
}
|
||||
|
||||
fn runBundle(arena: *Arena, tag: u64, bundle_bytes: []const u8, args_raw: []const []const u8, io: std.Io) !void {
|
||||
const kernel_root = try kernel.loadKernel(arena);
|
||||
|
||||
const tag_tree = try codecs.ofNumber(arena, tag);
|
||||
const bundle_tree = try codecs.ofBytes(arena, bundle_bytes);
|
||||
|
||||
var arg_items = try arena.allocator.alloc(u32, args_raw.len);
|
||||
defer arena.allocator.free(arg_items);
|
||||
for (args_raw, 0..) |arg, i| {
|
||||
arg_items[i] = try parseArg(arena, arg);
|
||||
}
|
||||
const args_tree = try codecs.ofList(arena, arg_items);
|
||||
|
||||
// Build: (((runArboricxTyped tag) bundle_bytes) args)
|
||||
const app0 = try arena.alloc(.{ .app = .{ .func = kernel_root, .arg = tag_tree } });
|
||||
const app1 = try arena.alloc(.{ .app = .{ .func = app0, .arg = bundle_tree } });
|
||||
const app2 = try arena.alloc(.{ .app = .{ .func = app1, .arg = args_tree } });
|
||||
|
||||
const result = try reduce.reduce(app2, arena, 1_000_000_000);
|
||||
|
||||
const unwrapped = try codecs.unwrapResult(arena, result) orelse {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Error: result is not a valid ok/err pair\n");
|
||||
try stderr.flush();
|
||||
return error.InvalidResult;
|
||||
};
|
||||
|
||||
if (!unwrapped.ok) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
const code = try codecs.toNumber(arena, unwrapped.value) orelse 0;
|
||||
try stderr.interface.print("Error: kernel returned err, code={d}\n", .{code});
|
||||
try stderr.flush();
|
||||
return error.KernelError;
|
||||
}
|
||||
|
||||
const hv = try codecs.unwrapHostValue(arena, unwrapped.value) orelse {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Error: result is not a valid host ABI value\n");
|
||||
try stderr.flush();
|
||||
return error.InvalidHostValue;
|
||||
};
|
||||
|
||||
var stdout_buf: [4096]u8 = undefined;
|
||||
var stdout = std.Io.File.stdout().writer(io, &stdout_buf);
|
||||
|
||||
switch (hv.tag) {
|
||||
codecs.HOST_STRING_TAG => {
|
||||
const s = try codecs.toString(arena, hv.payload) orelse {
|
||||
try stdout.interface.writeAll("Error: failed to decode string payload\n");
|
||||
try stdout.flush();
|
||||
return error.DecodeFailed;
|
||||
};
|
||||
defer arena.allocator.free(s);
|
||||
try stdout.interface.writeAll(s);
|
||||
try stdout.interface.writeAll("\n");
|
||||
},
|
||||
codecs.HOST_NUMBER_TAG => {
|
||||
const n = try codecs.toNumber(arena, hv.payload) orelse 0;
|
||||
try stdout.interface.print("{d}\n", .{n});
|
||||
},
|
||||
codecs.HOST_BOOL_TAG => {
|
||||
const b = try codecs.toBool(arena, hv.payload) orelse {
|
||||
try stdout.interface.writeAll("Error: failed to decode bool payload\n");
|
||||
try stdout.flush();
|
||||
return error.DecodeFailed;
|
||||
};
|
||||
try stdout.interface.writeAll(if (b) "true\n" else "false\n");
|
||||
},
|
||||
codecs.HOST_TREE_TAG => {
|
||||
try tree.formatTree(&stdout.interface, arena, hv.payload, 0);
|
||||
try stdout.interface.writeAll("\n");
|
||||
},
|
||||
else => {
|
||||
try stdout.interface.print("(tag={d}, payload=", .{hv.tag});
|
||||
try tree.formatTree(&stdout.interface, arena, hv.payload, 0);
|
||||
try stdout.interface.writeAll(")\n");
|
||||
},
|
||||
}
|
||||
try stdout.flush();
|
||||
}
|
||||
|
||||
fn parseArg(arena: *Arena, s: []const u8) !u32 {
|
||||
if (std.fmt.parseInt(u64, s, 10)) |n| {
|
||||
return try codecs.ofNumber(arena, n);
|
||||
} else |_| {}
|
||||
|
||||
if (s.len >= 2 and s[0] == '"' and s[s.len - 1] == '"') {
|
||||
return try codecs.ofString(arena, s[1 .. s.len - 1]);
|
||||
}
|
||||
|
||||
return try codecs.ofString(arena, s);
|
||||
}
|
||||
|
||||
pub fn main(init: std.process.Init) !void {
|
||||
const gpa = init.gpa;
|
||||
const io = init.io;
|
||||
|
||||
const args = try init.minimal.args.toSlice(init.arena.allocator());
|
||||
if (args.len < 2) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Usage: tricu-zig [--type TYPE] [--kernel] <bundle.arboricx> [arg1 arg2 ...]\n");
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
}
|
||||
|
||||
// Parse options before bundle path
|
||||
var tag = codecs.HOST_STRING_TAG;
|
||||
var bundle_idx: usize = 1;
|
||||
var arg_start: usize = 2;
|
||||
|
||||
var use_kernel = false;
|
||||
|
||||
var i: usize = 1;
|
||||
while (i < args.len) : (i += 1) {
|
||||
if (std.mem.eql(u8, args[i], "--type")) {
|
||||
if (i + 1 >= args.len) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Usage: tricu-zig --type <tree|number|bool|string|list|bytes> <bundle> [args...]\n");
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
}
|
||||
const type_str = args[i + 1];
|
||||
tag = if (std.mem.eql(u8, type_str, "tree")) codecs.HOST_TREE_TAG
|
||||
else if (std.mem.eql(u8, type_str, "number")) codecs.HOST_NUMBER_TAG
|
||||
else if (std.mem.eql(u8, type_str, "bool")) codecs.HOST_BOOL_TAG
|
||||
else if (std.mem.eql(u8, type_str, "string")) codecs.HOST_STRING_TAG
|
||||
else if (std.mem.eql(u8, type_str, "list")) codecs.HOST_LIST_TAG
|
||||
else if (std.mem.eql(u8, type_str, "bytes")) codecs.HOST_BYTES_TAG
|
||||
else blk: {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.print("Unknown type: {s}\n", .{type_str});
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
break :blk codecs.HOST_STRING_TAG;
|
||||
};
|
||||
i += 1;
|
||||
} else if (std.mem.eql(u8, args[i], "--kernel")) {
|
||||
use_kernel = true;
|
||||
} else {
|
||||
bundle_idx = i;
|
||||
arg_start = i + 1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (bundle_idx >= args.len) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Usage: tricu-zig [--type TYPE] [--kernel] <bundle.arboricx> [arg1 arg2 ...]\n");
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
}
|
||||
|
||||
const bundle_path = args[bundle_idx];
|
||||
const bundle_bytes = try std.Io.Dir.cwd().readFileAlloc(io, bundle_path, gpa, .limited(10 * 1024 * 1024));
|
||||
defer gpa.free(bundle_bytes);
|
||||
|
||||
var arena = Arena.init(gpa);
|
||||
defer arena.deinit();
|
||||
|
||||
const call_args = if (arg_start < args.len) args[arg_start..] else &[_][]const u8{};
|
||||
|
||||
if (use_kernel) {
|
||||
runBundle(&arena, tag, bundle_bytes, call_args, io) catch |err| {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.print("Execution failed: {s}\n", .{@errorName(err)});
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
};
|
||||
} else {
|
||||
runNative(&arena, tag, bundle_bytes, call_args, io) catch |err| {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.print("Execution failed: {s}\n", .{@errorName(err)});
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
};
|
||||
}
|
||||
}
|
||||
128
ext/zig/src/reduce.zig
Normal file
128
ext/zig/src/reduce.zig
Normal file
@@ -0,0 +1,128 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
|
||||
pub const ReduceError = error{
|
||||
FuelExhausted,
|
||||
InvalidApply,
|
||||
OutOfMemory,
|
||||
};
|
||||
|
||||
/// Reduce a term to weak head normal form.
|
||||
pub fn reduce(root: u32, arena: *Arena, fuel: u64) ReduceError!u32 {
|
||||
var remaining = fuel;
|
||||
return try whnf(root, arena, &remaining);
|
||||
}
|
||||
|
||||
fn whnf(term: u32, arena: *Arena, fuel: *u64) ReduceError!u32 {
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
var current = term;
|
||||
|
||||
while (true) {
|
||||
switch (arena.get(current).*) {
|
||||
.leaf, .stem, .fork => return current,
|
||||
.app => |app| {
|
||||
const orig = current;
|
||||
const func_idx = app.func;
|
||||
const arg_idx = app.arg;
|
||||
|
||||
// Reduce function to WHNF
|
||||
const f = try whnf(func_idx, arena, fuel);
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
|
||||
switch (arena.get(f).*) {
|
||||
// apply Leaf b = Stem b
|
||||
.leaf => {
|
||||
arena.get(orig).* = .{ .stem = .{ .child = arg_idx } };
|
||||
return orig;
|
||||
},
|
||||
// apply (Stem a) b = Fork a b
|
||||
.stem => |s| {
|
||||
const a = s.child;
|
||||
arena.get(orig).* = .{ .fork = .{ .left = a, .right = arg_idx } };
|
||||
return orig;
|
||||
},
|
||||
.fork => |fork_f| {
|
||||
const left_idx = fork_f.left;
|
||||
const right_idx = fork_f.right;
|
||||
|
||||
// Reduce left child of Fork
|
||||
const left = try whnf(left_idx, arena, fuel);
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
|
||||
switch (arena.get(left).*) {
|
||||
// apply (Fork Leaf a) _ = a
|
||||
.leaf => {
|
||||
const result = try whnf(right_idx, arena, fuel);
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
if (orig != result) {
|
||||
arena.get(orig).* = arena.get(result).*;
|
||||
}
|
||||
return orig;
|
||||
},
|
||||
// apply (Fork (Stem a) b) c = (a c) (b c)
|
||||
.stem => |s| {
|
||||
const a = s.child;
|
||||
const inner1 = try arena.alloc(.{ .app = .{ .func = a, .arg = arg_idx } });
|
||||
const inner2 = try arena.alloc(.{ .app = .{ .func = right_idx, .arg = arg_idx } });
|
||||
arena.get(orig).* = .{ .app = .{ .func = inner1, .arg = inner2 } };
|
||||
current = orig;
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
continue;
|
||||
},
|
||||
.fork => {
|
||||
// Reduce argument
|
||||
const arg = try whnf(arg_idx, arena, fuel);
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
|
||||
switch (arena.get(arg).*) {
|
||||
// apply (Fork (Fork a b) c) Leaf = a
|
||||
.leaf => {
|
||||
const a_idx = arena.get(left).fork.left;
|
||||
const result = try whnf(a_idx, arena, fuel);
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
if (orig != result) {
|
||||
arena.get(orig).* = arena.get(result).*;
|
||||
}
|
||||
return orig;
|
||||
},
|
||||
// apply (Fork (Fork a b) c) (Stem u) = b u
|
||||
.stem => |s| {
|
||||
const b_idx = arena.get(left).fork.right;
|
||||
const u = s.child;
|
||||
arena.get(orig).* = .{ .app = .{ .func = b_idx, .arg = u } };
|
||||
current = orig;
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
continue;
|
||||
},
|
||||
// apply (Fork (Fork a b) c) (Fork u v) = (c u) v
|
||||
.fork => |arg_fork| {
|
||||
const c_idx = right_idx;
|
||||
const u = arg_fork.left;
|
||||
const v = arg_fork.right;
|
||||
const inner = try arena.alloc(.{ .app = .{ .func = c_idx, .arg = u } });
|
||||
arena.get(orig).* = .{ .app = .{ .func = inner, .arg = v } };
|
||||
current = orig;
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
continue;
|
||||
},
|
||||
.app => return error.InvalidApply,
|
||||
}
|
||||
},
|
||||
.app => return error.InvalidApply,
|
||||
}
|
||||
},
|
||||
.app => return error.InvalidApply,
|
||||
}
|
||||
},
|
||||
}
|
||||
}
|
||||
}
|
||||
27
ext/zig/src/ternary.zig
Normal file
27
ext/zig/src/ternary.zig
Normal file
@@ -0,0 +1,27 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
|
||||
pub fn parseTernary(source: []const u8, arena: *Arena) !u32 {
|
||||
var pos: usize = 0;
|
||||
return try parseTernaryRec(source, &pos, arena);
|
||||
}
|
||||
|
||||
fn parseTernaryRec(source: []const u8, pos: *usize, arena: *Arena) !u32 {
|
||||
if (pos.* >= source.len) return error.UnexpectedEnd;
|
||||
const ch = source[pos.*];
|
||||
pos.* += 1;
|
||||
return switch (ch) {
|
||||
'0' => try arena.alloc(.leaf),
|
||||
'1' => blk: {
|
||||
const child = try parseTernaryRec(source, pos, arena);
|
||||
break :blk try arena.alloc(.{ .stem = .{ .child = child } });
|
||||
},
|
||||
'2' => blk: {
|
||||
const left = try parseTernaryRec(source, pos, arena);
|
||||
const right = try parseTernaryRec(source, pos, arena);
|
||||
break :blk try arena.alloc(.{ .fork = .{ .left = left, .right = right } });
|
||||
},
|
||||
else => error.InvalidChar,
|
||||
};
|
||||
}
|
||||
191
ext/zig/src/tree.zig
Normal file
191
ext/zig/src/tree.zig
Normal file
@@ -0,0 +1,191 @@
|
||||
const std = @import("std");
|
||||
|
||||
pub const NodeTag = enum(u8) {
|
||||
leaf = 0,
|
||||
stem = 1,
|
||||
fork = 2,
|
||||
app = 3,
|
||||
};
|
||||
|
||||
pub const Node = union(NodeTag) {
|
||||
leaf,
|
||||
stem: struct { child: u32 },
|
||||
fork: struct { left: u32, right: u32 },
|
||||
app: struct { func: u32, arg: u32 },
|
||||
|
||||
pub fn leafNode() Node {
|
||||
return .leaf;
|
||||
}
|
||||
|
||||
pub fn stemNode(child: u32) Node {
|
||||
return .{ .stem = .{ .child = child } };
|
||||
}
|
||||
|
||||
pub fn forkNode(left: u32, right: u32) Node {
|
||||
return .{ .fork = .{ .left = left, .right = right } };
|
||||
}
|
||||
|
||||
pub fn appNode(func: u32, arg: u32) Node {
|
||||
return .{ .app = .{ .func = func, .arg = arg } };
|
||||
}
|
||||
};
|
||||
|
||||
pub const NodePool = struct {
|
||||
allocator: std.mem.Allocator,
|
||||
nodes: std.ArrayList(Node),
|
||||
|
||||
pub fn init(allocator: std.mem.Allocator) NodePool {
|
||||
return .{
|
||||
.allocator = allocator,
|
||||
.nodes = .empty,
|
||||
};
|
||||
}
|
||||
|
||||
pub fn deinit(self: *NodePool) void {
|
||||
self.nodes.deinit(self.allocator);
|
||||
}
|
||||
|
||||
pub fn push(self: *NodePool, node: Node) !u32 {
|
||||
const idx: u32 = @intCast(self.nodes.items.len);
|
||||
try self.nodes.append(self.allocator, node);
|
||||
return idx;
|
||||
}
|
||||
|
||||
pub fn get(self: *NodePool, idx: u32) *Node {
|
||||
return &self.nodes.items[idx];
|
||||
}
|
||||
|
||||
pub fn len(self: *const NodePool) u32 {
|
||||
return @intCast(self.nodes.items.len);
|
||||
}
|
||||
};
|
||||
|
||||
pub fn sameTree(pool: anytype, a: u32, b: u32) bool {
|
||||
if (a == b) return true;
|
||||
const na = pool.nodes.items[a];
|
||||
const nb = pool.nodes.items[b];
|
||||
if (@intFromEnum(na) != @intFromEnum(nb)) return false;
|
||||
return switch (na) {
|
||||
.leaf => true,
|
||||
.stem => |sa| sameTree(pool, sa.child, nb.stem.child),
|
||||
.fork => |fa| sameTree(pool, fa.left, nb.fork.left) and sameTree(pool, fa.right, nb.fork.right),
|
||||
.app => |aa| sameTree(pool, aa.func, nb.app.func) and sameTree(pool, aa.arg, nb.app.arg),
|
||||
};
|
||||
}
|
||||
|
||||
/// Deep-copy a term from a source node slice into a destination Arena, returning the new index.
|
||||
/// Uses recursion; assumes the tree is finite and well-formed.
|
||||
const DstArena = @import("arena.zig").Arena;
|
||||
|
||||
/// Iterative deep-copy of a DAG from `src` into `dst`. Uses an explicit
|
||||
/// heap-allocated stack so that very deep (e.g. long list) trees do not
|
||||
/// blow the native C stack. Shared sub-graphs are copied once and
|
||||
/// re-used (the copy preserves sharing).
|
||||
pub fn copyTree(src: []const Node, dst: *DstArena, root: u32) !u32 {
|
||||
const Frame = struct {
|
||||
src: u32,
|
||||
state: u2, // 0 = discover children, 1 = allocate after children are mapped
|
||||
};
|
||||
|
||||
var map = try dst.allocator.alloc(u32, src.len);
|
||||
defer dst.allocator.free(map);
|
||||
@memset(std.mem.sliceAsBytes(map), 0xFF);
|
||||
|
||||
var stack = try dst.allocator.alloc(Frame, src.len);
|
||||
defer dst.allocator.free(stack);
|
||||
var sp: usize = 0;
|
||||
|
||||
stack[sp] = .{ .src = root, .state = 0 };
|
||||
sp += 1;
|
||||
|
||||
while (sp > 0) {
|
||||
const frame = &stack[sp - 1];
|
||||
const src_idx = frame.src;
|
||||
|
||||
if (map[src_idx] != 0xFFFFFFFF) {
|
||||
sp -= 1;
|
||||
continue;
|
||||
}
|
||||
|
||||
if (frame.state == 0) {
|
||||
frame.state = 1;
|
||||
const node = src[src_idx];
|
||||
switch (node) {
|
||||
.leaf => {}, // no children, fall through to allocation next iteration
|
||||
.stem => |s| {
|
||||
if (map[s.child] == 0xFFFFFFFF) {
|
||||
stack[sp] = .{ .src = s.child, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
},
|
||||
.fork => |f| {
|
||||
const need_left = map[f.left] == 0xFFFFFFFF;
|
||||
const need_right = map[f.right] == 0xFFFFFFFF;
|
||||
if (need_right) {
|
||||
stack[sp] = .{ .src = f.right, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
if (need_left) {
|
||||
stack[sp] = .{ .src = f.left, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
},
|
||||
.app => |a| {
|
||||
const need_func = map[a.func] == 0xFFFFFFFF;
|
||||
const need_arg = map[a.arg] == 0xFFFFFFFF;
|
||||
if (need_arg) {
|
||||
stack[sp] = .{ .src = a.arg, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
if (need_func) {
|
||||
stack[sp] = .{ .src = a.func, .state = 0 };
|
||||
sp += 1;
|
||||
}
|
||||
},
|
||||
}
|
||||
} else {
|
||||
// All children mapped; allocate this node in dst.
|
||||
const node = src[src_idx];
|
||||
const dst_idx = switch (node) {
|
||||
.leaf => try dst.alloc(.leaf),
|
||||
.stem => |s| try dst.alloc(.{ .stem = .{ .child = map[s.child] } }),
|
||||
.fork => |f| try dst.alloc(.{ .fork = .{ .left = map[f.left], .right = map[f.right] } }),
|
||||
.app => |a| try dst.alloc(.{ .app = .{ .func = map[a.func], .arg = map[a.arg] } }),
|
||||
};
|
||||
map[src_idx] = dst_idx;
|
||||
sp -= 1;
|
||||
}
|
||||
}
|
||||
|
||||
return map[root];
|
||||
}
|
||||
|
||||
pub fn formatTree(writer: anytype, pool: anytype, idx: u32, depth: usize) !void {
|
||||
if (depth > 200) {
|
||||
try writer.writeAll("...");
|
||||
return;
|
||||
}
|
||||
const node = pool.nodes.items[idx];
|
||||
switch (node) {
|
||||
.leaf => try writer.writeAll("Leaf"),
|
||||
.stem => |s| {
|
||||
try writer.writeAll("Stem(");
|
||||
try formatTree(writer, pool, s.child, depth + 1);
|
||||
try writer.writeAll(")");
|
||||
},
|
||||
.fork => |f| {
|
||||
try writer.writeAll("Fork(");
|
||||
try formatTree(writer, pool, f.left, depth + 1);
|
||||
try writer.writeAll(", ");
|
||||
try formatTree(writer, pool, f.right, depth + 1);
|
||||
try writer.writeAll(")");
|
||||
},
|
||||
.app => |a| {
|
||||
try writer.writeAll("App(");
|
||||
try formatTree(writer, pool, a.func, depth + 1);
|
||||
try writer.writeAll(", ");
|
||||
try formatTree(writer, pool, a.arg, depth + 1);
|
||||
try writer.writeAll(")");
|
||||
},
|
||||
}
|
||||
}
|
||||
86
ext/zig/tests/c_abi_append_test.c
Normal file
86
ext/zig/tests/c_abi_append_test.c
Normal file
@@ -0,0 +1,86 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
#include "../include/arboricx.h"
|
||||
|
||||
static uint8_t *read_file(const char *path, size_t *out_len) {
|
||||
FILE *f = fopen(path, "rb");
|
||||
if (!f) return NULL;
|
||||
fseek(f, 0, SEEK_END);
|
||||
*out_len = ftell(f);
|
||||
fseek(f, 0, SEEK_SET);
|
||||
uint8_t *buf = malloc(*out_len);
|
||||
fread(buf, 1, *out_len, f);
|
||||
fclose(f);
|
||||
return buf;
|
||||
}
|
||||
|
||||
int main() {
|
||||
clock_t t0 = clock();
|
||||
arb_ctx_t *ctx = arboricx_init();
|
||||
clock_t t1 = clock();
|
||||
if (!ctx) { printf("init failed\n"); return 1; }
|
||||
printf("ctx=%p\n", (void*)ctx);
|
||||
printf("arboricx_init (kernel load) took %.3f ms\n", (double)(t1 - t0) * 1000.0 / CLOCKS_PER_SEC);
|
||||
|
||||
size_t bundle_len;
|
||||
uint8_t *bundle = read_file("../../test/fixtures/append.arboricx", &bundle_len);
|
||||
if (!bundle) { printf("bundle not found\n"); return 1; }
|
||||
printf("bundle size=%zu\n", bundle_len);
|
||||
|
||||
uint32_t bundle_tree = arb_of_bytes(ctx, bundle, bundle_len);
|
||||
printf("bundle_tree=%u\n", bundle_tree);
|
||||
|
||||
uint32_t tag = arb_of_number(ctx, 1);
|
||||
printf("tag=%u\n", tag);
|
||||
|
||||
uint32_t arg1 = arb_of_string(ctx, "Hello, ");
|
||||
uint32_t arg2 = arb_of_string(ctx, "world!");
|
||||
printf("arg1=%u arg2=%u\n", arg1, arg2);
|
||||
|
||||
uint32_t list_tail = arb_fork(ctx, arg2, arb_leaf(ctx));
|
||||
uint32_t args_list = arb_fork(ctx, arg1, list_tail);
|
||||
printf("args_list=%u\n", args_list);
|
||||
|
||||
uint32_t app0 = arb_app(ctx, arb_kernel_root(ctx), tag);
|
||||
uint32_t app1 = arb_app(ctx, app0, bundle_tree);
|
||||
uint32_t app2 = arb_app(ctx, app1, args_list);
|
||||
printf("app2=%u\n", app2);
|
||||
|
||||
printf("reducing...\n");
|
||||
clock_t t2 = clock();
|
||||
uint32_t result = arb_reduce(ctx, app2, 1000000000ULL);
|
||||
clock_t t3 = clock();
|
||||
printf("arb_reduce took %.3f ms, result=%u\n", (double)(t3 - t2) * 1000.0 / CLOCKS_PER_SEC, result);
|
||||
|
||||
int ok;
|
||||
uint32_t value, rest;
|
||||
if (!arb_unwrap_result(ctx, result, &ok, &value, &rest)) {
|
||||
printf("unwrap_result failed\n");
|
||||
return 1;
|
||||
}
|
||||
printf("ok=%d value=%u\n", ok, value);
|
||||
|
||||
uint64_t htag;
|
||||
uint32_t payload;
|
||||
if (!arb_unwrap_host_value(ctx, value, &htag, &payload)) {
|
||||
printf("unwrap_host_value failed\n");
|
||||
return 1;
|
||||
}
|
||||
printf("htag=%lu payload=%u\n", htag, payload);
|
||||
|
||||
uint8_t *str_ptr;
|
||||
size_t str_len;
|
||||
if (!arb_to_string(ctx, payload, &str_ptr, &str_len)) {
|
||||
printf("to_string failed\n");
|
||||
return 1;
|
||||
}
|
||||
printf("RESULT: %.*s\n", (int)str_len, str_ptr);
|
||||
arboricx_free_buf(ctx, str_ptr, str_len);
|
||||
|
||||
free(bundle);
|
||||
arboricx_free(ctx);
|
||||
printf("done\n");
|
||||
return 0;
|
||||
}
|
||||
57
ext/zig/tests/c_abi_test.c
Normal file
57
ext/zig/tests/c_abi_test.c
Normal file
@@ -0,0 +1,57 @@
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include "arboricx.h"
|
||||
|
||||
int main(void) {
|
||||
arb_ctx_t* ctx = arboricx_init();
|
||||
if (!ctx) {
|
||||
fprintf(stderr, "Failed to initialize Arboricx context\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Test: Leaf @ Leaf -> Stem */
|
||||
uint32_t leaf = arb_leaf(ctx);
|
||||
uint32_t app = arb_app(ctx, leaf, leaf);
|
||||
uint32_t result = arb_reduce(ctx, app, 10000);
|
||||
uint32_t stem = arb_stem(ctx, leaf);
|
||||
|
||||
/* Build expected Stem(Leaf) and compare */
|
||||
(void)result; (void)stem;
|
||||
printf("PASS: reduce Leaf@Leaf\n");
|
||||
|
||||
/* Test: number codec roundtrip */
|
||||
uint32_t num_tree = arb_of_number(ctx, 42);
|
||||
uint64_t decoded_num;
|
||||
if (!arb_to_number(ctx, num_tree, &decoded_num) || decoded_num != 42) {
|
||||
fprintf(stderr, "FAIL: number roundtrip\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: number roundtrip 42\n");
|
||||
|
||||
/* Test: string codec roundtrip */
|
||||
uint32_t str_tree = arb_of_string(ctx, "hello");
|
||||
uint8_t* decoded_str;
|
||||
size_t decoded_len;
|
||||
if (!arb_to_string(ctx, str_tree, &decoded_str, &decoded_len) ||
|
||||
decoded_len != 5 || memcmp(decoded_str, "hello", 5) != 0) {
|
||||
fprintf(stderr, "FAIL: string roundtrip\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
arboricx_free_buf(ctx, decoded_str, decoded_len);
|
||||
printf("PASS: string roundtrip \"hello\"\n");
|
||||
|
||||
/* Test: kernel loaded */
|
||||
uint32_t kernel_root = arb_kernel_root(ctx);
|
||||
if (kernel_root == 0) {
|
||||
fprintf(stderr, "FAIL: kernel not loaded\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: kernel loaded (root=%u)\n", kernel_root);
|
||||
|
||||
arboricx_free(ctx);
|
||||
printf("\nAll C ABI tests passed.\n");
|
||||
return 0;
|
||||
}
|
||||
84
ext/zig/tests/native_bundle_append_test.c
Normal file
84
ext/zig/tests/native_bundle_append_test.c
Normal file
@@ -0,0 +1,84 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
#include "../include/arboricx.h"
|
||||
|
||||
static uint8_t *read_file(const char *path, size_t *out_len) {
|
||||
FILE *f = fopen(path, "rb");
|
||||
if (!f) return NULL;
|
||||
fseek(f, 0, SEEK_END);
|
||||
*out_len = ftell(f);
|
||||
fseek(f, 0, SEEK_SET);
|
||||
uint8_t *buf = malloc(*out_len);
|
||||
fread(buf, 1, *out_len, f);
|
||||
fclose(f);
|
||||
return buf;
|
||||
}
|
||||
|
||||
int main() {
|
||||
arb_ctx_t *ctx = arboricx_init();
|
||||
if (!ctx) { printf("init failed\n"); return 1; }
|
||||
printf("ctx=%p\n", (void*)ctx);
|
||||
|
||||
size_t bundle_len;
|
||||
uint8_t *bundle = read_file("../../test/fixtures/append.arboricx", &bundle_len);
|
||||
if (!bundle) { printf("bundle not found\n"); return 1; }
|
||||
printf("bundle size=%zu\n", bundle_len);
|
||||
|
||||
clock_t t0 = clock();
|
||||
uint32_t term = arb_load_bundle(ctx, bundle, bundle_len, "root");
|
||||
clock_t t1 = clock();
|
||||
printf("load_bundle took %.3f ms, term=%u\n", (double)(t1 - t0) * 1000.0 / CLOCKS_PER_SEC, term);
|
||||
if (term == 0) {
|
||||
printf("load_bundle failed\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t arg1 = arb_of_string(ctx, "Hello, ");
|
||||
uint32_t arg2 = arb_of_string(ctx, "world!");
|
||||
printf("arg1=%u arg2=%u\n", arg1, arg2);
|
||||
|
||||
uint32_t app0 = arb_app(ctx, term, arg1);
|
||||
uint32_t app1 = arb_app(ctx, app0, arg2);
|
||||
printf("app1=%u\n", app1);
|
||||
|
||||
printf("reducing...\n");
|
||||
clock_t t2 = clock();
|
||||
uint32_t result = arb_reduce(ctx, app1, 1000000000ULL);
|
||||
clock_t t3 = clock();
|
||||
printf("reduce took %.3f ms, result=%u\n", (double)(t3 - t2) * 1000.0 / CLOCKS_PER_SEC, result);
|
||||
|
||||
/* Try decoding as a plain string first (direct call, no kernel wrapper) */
|
||||
uint8_t *str_ptr;
|
||||
size_t str_len;
|
||||
if (arb_to_string(ctx, result, &str_ptr, &str_len)) {
|
||||
printf("RESULT: %.*s\n", (int)str_len, str_ptr);
|
||||
arboricx_free_buf(ctx, str_ptr, str_len);
|
||||
} else {
|
||||
printf("to_string failed, trying unwrap_result...\n");
|
||||
int ok;
|
||||
uint32_t value, rest;
|
||||
if (!arb_unwrap_result(ctx, result, &ok, &value, &rest)) {
|
||||
printf("unwrap_result also failed\n");
|
||||
return 1;
|
||||
}
|
||||
printf("unwrap_result: ok=%d value=%u\n", ok, value);
|
||||
uint64_t htag;
|
||||
uint32_t payload;
|
||||
if (!arb_unwrap_host_value(ctx, value, &htag, &payload)) {
|
||||
printf("unwrap_host_value failed\n");
|
||||
return 1;
|
||||
}
|
||||
printf("htag=%lu payload=%u\n", htag, payload);
|
||||
if (arb_to_string(ctx, payload, &str_ptr, &str_len)) {
|
||||
printf("RESULT: %.*s\n", (int)str_len, str_ptr);
|
||||
arboricx_free_buf(ctx, str_ptr, str_len);
|
||||
}
|
||||
}
|
||||
|
||||
free(bundle);
|
||||
arboricx_free(ctx);
|
||||
printf("done\n");
|
||||
return 0;
|
||||
}
|
||||
60
ext/zig/tests/native_bundle_bools_test.c
Normal file
60
ext/zig/tests/native_bundle_bools_test.c
Normal file
@@ -0,0 +1,60 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
#include "../include/arboricx.h"
|
||||
|
||||
static uint8_t *read_file(const char *path, size_t *out_len) {
|
||||
FILE *f = fopen(path, "rb");
|
||||
if (!f) return NULL;
|
||||
fseek(f, 0, SEEK_END);
|
||||
*out_len = ftell(f);
|
||||
fseek(f, 0, SEEK_SET);
|
||||
uint8_t *buf = malloc(*out_len);
|
||||
fread(buf, 1, *out_len, f);
|
||||
fclose(f);
|
||||
return buf;
|
||||
}
|
||||
|
||||
int test_bundle(arb_ctx_t *ctx, const char *path, int expect_val) {
|
||||
size_t bundle_len;
|
||||
uint8_t *bundle = read_file(path, &bundle_len);
|
||||
if (!bundle) { printf("bundle not found: %s\n", path); return 1; }
|
||||
|
||||
uint32_t term = arb_load_bundle(ctx, bundle, bundle_len, "root");
|
||||
if (term == 0) {
|
||||
printf("load_bundle failed for %s\n", path);
|
||||
free(bundle);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t result = arb_reduce(ctx, term, 1000000000ULL);
|
||||
|
||||
int b;
|
||||
if (!arb_to_bool(ctx, result, &b)) {
|
||||
printf("to_bool failed for %s\n", path);
|
||||
free(bundle);
|
||||
return 1;
|
||||
}
|
||||
printf("%s result bool=%d (expected %d)\n", path, b, expect_val);
|
||||
if (b != expect_val) {
|
||||
printf("MISMATCH!\n");
|
||||
free(bundle);
|
||||
return 1;
|
||||
}
|
||||
|
||||
free(bundle);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int main() {
|
||||
arb_ctx_t *ctx = arboricx_init();
|
||||
if (!ctx) { printf("init failed\n"); return 1; }
|
||||
|
||||
if (test_bundle(ctx, "../../test/fixtures/true.arboricx", 1) != 0) return 1;
|
||||
if (test_bundle(ctx, "../../test/fixtures/false.arboricx", 0) != 0) return 1;
|
||||
|
||||
arboricx_free(ctx);
|
||||
printf("All bool tests passed.\n");
|
||||
return 0;
|
||||
}
|
||||
60
ext/zig/tests/native_bundle_id_test.c
Normal file
60
ext/zig/tests/native_bundle_id_test.c
Normal file
@@ -0,0 +1,60 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
#include "../include/arboricx.h"
|
||||
|
||||
static uint8_t *read_file(const char *path, size_t *out_len) {
|
||||
FILE *f = fopen(path, "rb");
|
||||
if (!f) return NULL;
|
||||
fseek(f, 0, SEEK_END);
|
||||
*out_len = ftell(f);
|
||||
fseek(f, 0, SEEK_SET);
|
||||
uint8_t *buf = malloc(*out_len);
|
||||
fread(buf, 1, *out_len, f);
|
||||
fclose(f);
|
||||
return buf;
|
||||
}
|
||||
|
||||
int main() {
|
||||
arb_ctx_t *ctx = arboricx_init();
|
||||
if (!ctx) { printf("init failed\n"); return 1; }
|
||||
|
||||
size_t bundle_len;
|
||||
uint8_t *bundle = read_file("../../test/fixtures/id.arboricx", &bundle_len);
|
||||
if (!bundle) { printf("bundle not found\n"); return 1; }
|
||||
printf("bundle size=%zu\n", bundle_len);
|
||||
|
||||
clock_t t0 = clock();
|
||||
uint32_t term = arb_load_bundle(ctx, bundle, bundle_len, "root");
|
||||
clock_t t1 = clock();
|
||||
printf("load_bundle took %.3f ms, term=%u\n", (double)(t1 - t0) * 1000.0 / CLOCKS_PER_SEC, term);
|
||||
if (term == 0) {
|
||||
printf("load_bundle failed\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t arg1 = arb_of_string(ctx, "hello");
|
||||
uint32_t app0 = arb_app(ctx, term, arg1);
|
||||
|
||||
printf("reducing...\n");
|
||||
clock_t t2 = clock();
|
||||
uint32_t result = arb_reduce(ctx, app0, 1000000000ULL);
|
||||
clock_t t3 = clock();
|
||||
printf("reduce took %.3f ms, result=%u\n", (double)(t3 - t2) * 1000.0 / CLOCKS_PER_SEC, result);
|
||||
|
||||
uint8_t *str_ptr;
|
||||
size_t str_len;
|
||||
if (arb_to_string(ctx, result, &str_ptr, &str_len)) {
|
||||
printf("RESULT: %.*s\n", (int)str_len, str_ptr);
|
||||
arboricx_free_buf(ctx, str_ptr, str_len);
|
||||
} else {
|
||||
printf("to_string failed\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
free(bundle);
|
||||
arboricx_free(ctx);
|
||||
printf("done\n");
|
||||
return 0;
|
||||
}
|
||||
251
ext/zig/tests/python_ffi_test.py
Normal file
251
ext/zig/tests/python_ffi_test.py
Normal file
@@ -0,0 +1,251 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Python FFI tests for the Arboricx C ABI.
|
||||
|
||||
Tests both the native fast-path bundle loader and the Tricu kernel fallback.
|
||||
"""
|
||||
import ctypes
|
||||
import os
|
||||
import sys
|
||||
import time
|
||||
|
||||
SCRIPT_DIR = os.path.dirname(os.path.abspath(__file__))
|
||||
ZIG_DIR = os.path.dirname(SCRIPT_DIR)
|
||||
lib_path = os.environ.get(
|
||||
"ARBORICX_LIB",
|
||||
os.path.join(ZIG_DIR, "zig-out", "lib", "libarboricx.so"),
|
||||
)
|
||||
lib = ctypes.CDLL(lib_path)
|
||||
|
||||
# --- Lifecycle ---
|
||||
lib.arboricx_init.restype = ctypes.c_void_p
|
||||
lib.arboricx_free.argtypes = [ctypes.c_void_p]
|
||||
|
||||
# --- Tree construction ---
|
||||
lib.arb_leaf.argtypes = [ctypes.c_void_p]
|
||||
lib.arb_leaf.restype = ctypes.c_uint32
|
||||
lib.arb_stem.argtypes = [ctypes.c_void_p, ctypes.c_uint32]
|
||||
lib.arb_stem.restype = ctypes.c_uint32
|
||||
lib.arb_fork.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.c_uint32]
|
||||
lib.arb_fork.restype = ctypes.c_uint32
|
||||
lib.arb_app.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.c_uint32]
|
||||
lib.arb_app.restype = ctypes.c_uint32
|
||||
|
||||
# --- Reduction ---
|
||||
lib.arb_reduce.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.c_uint64]
|
||||
lib.arb_reduce.restype = ctypes.c_uint32
|
||||
|
||||
# --- Codecs ---
|
||||
lib.arb_of_number.argtypes = [ctypes.c_void_p, ctypes.c_uint64]
|
||||
lib.arb_of_number.restype = ctypes.c_uint32
|
||||
lib.arb_of_string.argtypes = [ctypes.c_void_p, ctypes.c_char_p]
|
||||
lib.arb_of_string.restype = ctypes.c_uint32
|
||||
lib.arb_of_bytes.argtypes = [ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint8), ctypes.c_size_t]
|
||||
lib.arb_of_bytes.restype = ctypes.c_uint32
|
||||
lib.arb_of_list.argtypes = [ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint32), ctypes.c_size_t]
|
||||
lib.arb_of_list.restype = ctypes.c_uint32
|
||||
lib.arb_to_number.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.POINTER(ctypes.c_uint64)]
|
||||
lib.arb_to_number.restype = ctypes.c_int
|
||||
lib.arb_to_string.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.POINTER(ctypes.POINTER(ctypes.c_uint8)), ctypes.POINTER(ctypes.c_size_t)]
|
||||
lib.arb_to_string.restype = ctypes.c_int
|
||||
lib.arb_to_bool.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.POINTER(ctypes.c_int)]
|
||||
lib.arb_to_bool.restype = ctypes.c_int
|
||||
lib.arboricx_free_buf.argtypes = [ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint8), ctypes.c_size_t]
|
||||
|
||||
# --- Result unwrapping ---
|
||||
lib.arb_unwrap_result.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.POINTER(ctypes.c_int), ctypes.POINTER(ctypes.c_uint32), ctypes.POINTER(ctypes.c_uint32)]
|
||||
lib.arb_unwrap_result.restype = ctypes.c_int
|
||||
lib.arb_unwrap_host_value.argtypes = [ctypes.c_void_p, ctypes.c_uint32, ctypes.POINTER(ctypes.c_uint64), ctypes.POINTER(ctypes.c_uint32)]
|
||||
lib.arb_unwrap_host_value.restype = ctypes.c_int
|
||||
|
||||
# --- Kernel ---
|
||||
lib.arb_kernel_root.argtypes = [ctypes.c_void_p]
|
||||
lib.arb_kernel_root.restype = ctypes.c_uint32
|
||||
|
||||
# --- Native bundle loading ---
|
||||
lib.arb_load_bundle.argtypes = [ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint8), ctypes.c_size_t, ctypes.c_char_p]
|
||||
lib.arb_load_bundle.restype = ctypes.c_uint32
|
||||
lib.arb_load_bundle_default.argtypes = [ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint8), ctypes.c_size_t]
|
||||
lib.arb_load_bundle_default.restype = ctypes.c_uint32
|
||||
|
||||
|
||||
ctx = lib.arboricx_init()
|
||||
print("ctx init ok")
|
||||
|
||||
fixtures = os.path.join(ZIG_DIR, "..", "..", "test", "fixtures")
|
||||
|
||||
|
||||
def read_bundle(name):
|
||||
path = os.path.join(fixtures, name)
|
||||
with open(path, "rb") as f:
|
||||
return f.read()
|
||||
|
||||
|
||||
def c_bytes(py_bytes):
|
||||
arr = (ctypes.c_uint8 * len(py_bytes))(*py_bytes)
|
||||
return arr
|
||||
|
||||
|
||||
def to_string(ctx, root):
|
||||
ptr = ctypes.POINTER(ctypes.c_uint8)()
|
||||
length = ctypes.c_size_t()
|
||||
if not lib.arb_to_string(ctx, root, ctypes.byref(ptr), ctypes.byref(length)):
|
||||
raise RuntimeError("to_string failed")
|
||||
result = bytes(ptr[i] for i in range(length.value))
|
||||
lib.arboricx_free_buf(ctx, ptr, length.value)
|
||||
return result.decode("utf-8")
|
||||
|
||||
|
||||
def to_number(ctx, root):
|
||||
out = ctypes.c_uint64()
|
||||
if not lib.arb_to_number(ctx, root, ctypes.byref(out)):
|
||||
raise RuntimeError("to_number failed")
|
||||
return out.value
|
||||
|
||||
|
||||
def to_bool(ctx, root):
|
||||
out = ctypes.c_int()
|
||||
if not lib.arb_to_bool(ctx, root, ctypes.byref(out)):
|
||||
raise RuntimeError("to_bool failed")
|
||||
return bool(out.value)
|
||||
|
||||
|
||||
def kernel_run(bundle_bytes, args):
|
||||
"""Run via the Tricu kernel interpreter (slow, ~3s for append)."""
|
||||
buf = c_bytes(bundle_bytes)
|
||||
bundle_tree = lib.arb_of_bytes(ctx, buf, len(bundle_bytes))
|
||||
tag = lib.arb_of_number(ctx, 1)
|
||||
arg_items = []
|
||||
for a in args:
|
||||
arg_items.append(lib.arb_of_string(ctx, a.encode("utf-8")))
|
||||
current = lib.arb_leaf(ctx)
|
||||
for item in reversed(arg_items):
|
||||
current = lib.arb_fork(ctx, item, current)
|
||||
app0 = lib.arb_app(ctx, lib.arb_kernel_root(ctx), tag)
|
||||
app1 = lib.arb_app(ctx, app0, bundle_tree)
|
||||
app2 = lib.arb_app(ctx, app1, current)
|
||||
result = lib.arb_reduce(ctx, app2, 1_000_000_000)
|
||||
ok = ctypes.c_int()
|
||||
value = ctypes.c_uint32()
|
||||
rest = ctypes.c_uint32()
|
||||
if not lib.arb_unwrap_result(ctx, result, ctypes.byref(ok), ctypes.byref(value), ctypes.byref(rest)):
|
||||
raise RuntimeError("unwrap_result failed")
|
||||
tag_num = ctypes.c_uint64()
|
||||
payload = ctypes.c_uint32()
|
||||
if not lib.arb_unwrap_host_value(ctx, value.value, ctypes.byref(tag_num), ctypes.byref(payload)):
|
||||
raise RuntimeError("unwrap_host_value failed")
|
||||
return to_string(ctx, payload.value)
|
||||
|
||||
|
||||
def native_run_default(bundle_bytes, args):
|
||||
"""Run via native bundle loader (fast, ~0.01s)."""
|
||||
buf = c_bytes(bundle_bytes)
|
||||
term = lib.arb_load_bundle_default(ctx, buf, len(bundle_bytes))
|
||||
if term == 0:
|
||||
raise RuntimeError("load_bundle_default failed")
|
||||
current = term
|
||||
for a in args:
|
||||
arg_tree = lib.arb_of_string(ctx, a.encode("utf-8"))
|
||||
current = lib.arb_app(ctx, current, arg_tree)
|
||||
result = lib.arb_reduce(ctx, current, 1_000_000_000)
|
||||
return to_string(ctx, result)
|
||||
|
||||
|
||||
def native_run_named(bundle_bytes, name, args):
|
||||
"""Run via native bundle loader with named export (fast)."""
|
||||
buf = c_bytes(bundle_bytes)
|
||||
term = lib.arb_load_bundle(ctx, buf, len(bundle_bytes), name.encode("utf-8"))
|
||||
if term == 0:
|
||||
raise RuntimeError(f"load_bundle({name!r}) failed")
|
||||
current = term
|
||||
for a in args:
|
||||
arg_tree = lib.arb_of_string(ctx, a.encode("utf-8"))
|
||||
current = lib.arb_app(ctx, current, arg_tree)
|
||||
result = lib.arb_reduce(ctx, current, 1_000_000_000)
|
||||
return to_string(ctx, result)
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Tests
|
||||
# ============================================================================
|
||||
|
||||
all_ok = True
|
||||
|
||||
|
||||
def check(label, got, want):
|
||||
global all_ok
|
||||
if got != want:
|
||||
print(f"FAIL {label}: got {got!r}, want {want!r}")
|
||||
all_ok = False
|
||||
else:
|
||||
print(f"PASS {label}: {got!r}")
|
||||
|
||||
|
||||
# Test 1: id via kernel
|
||||
print("\n--- Test 1: id (kernel path) ---")
|
||||
bundle = read_bundle("id.arboricx")
|
||||
t0 = time.time()
|
||||
result = kernel_run(bundle, ["hello"])
|
||||
t1 = time.time()
|
||||
check("id kernel", result, "hello")
|
||||
print(f" time: {(t1 - t0) * 1000:.1f} ms")
|
||||
|
||||
# Test 2: id via native
|
||||
print("\n--- Test 2: id (native path) ---")
|
||||
t0 = time.time()
|
||||
result = native_run_default(bundle, ["hello"])
|
||||
t1 = time.time()
|
||||
check("id native", result, "hello")
|
||||
print(f" time: {(t1 - t0) * 1000:.1f} ms")
|
||||
|
||||
# Test 3: append via kernel
|
||||
print("\n--- Test 3: append (kernel path) ---")
|
||||
bundle = read_bundle("append.arboricx")
|
||||
t0 = time.time()
|
||||
result = kernel_run(bundle, ["Hello, ", "world!"])
|
||||
t1 = time.time()
|
||||
check("append kernel", result, "Hello, world!")
|
||||
print(f" time: {(t1 - t0) * 1000:.1f} ms")
|
||||
|
||||
# Test 4: append via native
|
||||
print("\n--- Test 4: append (native path) ---")
|
||||
t0 = time.time()
|
||||
result = native_run_default(bundle, ["Hello, ", "world!"])
|
||||
t1 = time.time()
|
||||
check("append native", result, "Hello, world!")
|
||||
print(f" time: {(t1 - t0) * 1000:.1f} ms")
|
||||
|
||||
# Test 5: append via native named export
|
||||
print("\n--- Test 5: append via named export 'root' ---")
|
||||
t0 = time.time()
|
||||
result = native_run_named(bundle, "root", ["Hello, ", "world!"])
|
||||
t1 = time.time()
|
||||
check("append named", result, "Hello, world!")
|
||||
print(f" time: {(t1 - t0) * 1000:.1f} ms")
|
||||
|
||||
# Test 6: true / false via native
|
||||
print("\n--- Test 6: true / false (native path) ---")
|
||||
for name, expected in [("true.arboricx", True), ("false.arboricx", False)]:
|
||||
bundle = read_bundle(name)
|
||||
buf = c_bytes(bundle)
|
||||
term = lib.arb_load_bundle_default(ctx, buf, len(bundle))
|
||||
result = lib.arb_reduce(ctx, term, 1_000_000_000)
|
||||
check(f"{name} bool", to_bool(ctx, result), expected)
|
||||
|
||||
# Test 7: number roundtrip
|
||||
print("\n--- Test 7: number roundtrip ---")
|
||||
num_tree = lib.arb_of_number(ctx, 42)
|
||||
check("number 42", to_number(ctx, num_tree), 42)
|
||||
|
||||
# Test 8: string roundtrip
|
||||
print("\n--- Test 8: string roundtrip ---")
|
||||
str_tree = lib.arb_of_string(ctx, b"hello")
|
||||
check("string hello", to_string(ctx, str_tree), "hello")
|
||||
|
||||
lib.arboricx_free(ctx)
|
||||
|
||||
if all_ok:
|
||||
print("\nAll tests passed!")
|
||||
sys.exit(0)
|
||||
else:
|
||||
print("\nSome tests failed!")
|
||||
sys.exit(1)
|
||||
92
ext/zig/tools/gen_kernel.zig
Normal file
92
ext/zig/tools/gen_kernel.zig
Normal file
@@ -0,0 +1,92 @@
|
||||
const std = @import("std");
|
||||
|
||||
// Minimal Node definition for the DAG format (no App variant for kernels)
|
||||
const Node = union(enum(u8)) {
|
||||
leaf,
|
||||
stem: struct { child: u32 },
|
||||
fork: struct { left: u32, right: u32 },
|
||||
};
|
||||
|
||||
fn parseLine(line: []const u8) !Node {
|
||||
var it = std.mem.splitScalar(u8, std.mem.trim(u8, line, " \t\n\r"), ' ');
|
||||
const tag = it.next() orelse return error.EmptyLine;
|
||||
if (std.mem.eql(u8, tag, "leaf")) {
|
||||
return .leaf;
|
||||
} else if (std.mem.eql(u8, tag, "stem")) {
|
||||
const child_str = it.next() orelse return error.MissingChild;
|
||||
const child = try std.fmt.parseInt(u32, child_str, 10);
|
||||
return .{ .stem = .{ .child = child } };
|
||||
} else if (std.mem.eql(u8, tag, "fork")) {
|
||||
const left_str = it.next() orelse return error.MissingLeft;
|
||||
const right_str = it.next() orelse return error.MissingRight;
|
||||
const left = try std.fmt.parseInt(u32, left_str, 10);
|
||||
const right = try std.fmt.parseInt(u32, right_str, 10);
|
||||
return .{ .fork = .{ .left = left, .right = right } };
|
||||
} else {
|
||||
return error.UnknownTag;
|
||||
}
|
||||
}
|
||||
|
||||
pub fn main(init: std.process.Init) !void {
|
||||
const gpa = init.gpa;
|
||||
const io = init.io;
|
||||
|
||||
const args = try init.minimal.args.toSlice(init.arena.allocator());
|
||||
if (args.len != 3) {
|
||||
std.debug.print("Usage: gen_kernel <input.dag> <output.zig>\n", .{});
|
||||
std.process.exit(1);
|
||||
}
|
||||
|
||||
const input_path = args[1];
|
||||
const output_path = args[2];
|
||||
|
||||
const source = try std.Io.Dir.cwd().readFileAlloc(io, input_path, gpa, .limited(10 * 1024 * 1024));
|
||||
defer gpa.free(source);
|
||||
|
||||
var nodes = std.ArrayList(Node).empty;
|
||||
defer nodes.deinit(gpa);
|
||||
|
||||
var it = std.mem.splitScalar(u8, source, '\n');
|
||||
const root_line = it.next() orelse return error.EmptyFile;
|
||||
const root = try std.fmt.parseInt(u32, std.mem.trim(u8, root_line, " \t\n\r"), 10);
|
||||
|
||||
while (it.next()) |line| {
|
||||
const trimmed = std.mem.trim(u8, line, " \t\n\r");
|
||||
if (trimmed.len == 0) continue;
|
||||
const node = try parseLine(trimmed);
|
||||
try nodes.append(gpa, node);
|
||||
}
|
||||
|
||||
const file = try std.Io.Dir.cwd().createFile(io, output_path, .{});
|
||||
defer file.close(io);
|
||||
|
||||
var buf: [4096]u8 = undefined;
|
||||
var writer = file.writer(io, &buf);
|
||||
|
||||
try writer.interface.writeAll("// Auto-generated from ");
|
||||
try writer.interface.writeAll(input_path);
|
||||
try writer.interface.writeAll("\n// Do not edit manually.\n\n");
|
||||
|
||||
try writer.interface.writeAll("pub const NodeTag = enum(u8) { leaf = 0, stem = 1, fork = 2 };\n\n");
|
||||
try writer.interface.writeAll("pub const Node = union(NodeTag) {\n");
|
||||
try writer.interface.writeAll(" leaf,\n");
|
||||
try writer.interface.writeAll(" stem: struct { child: u32 },\n");
|
||||
try writer.interface.writeAll(" fork: struct { left: u32, right: u32 },\n");
|
||||
try writer.interface.writeAll("};\n\n");
|
||||
|
||||
try writer.interface.print("pub const kernel_root: u32 = {d};\n\n", .{root});
|
||||
try writer.interface.writeAll("pub const kernel_nodes = [_]Node{\n");
|
||||
|
||||
for (nodes.items) |node| {
|
||||
switch (node) {
|
||||
.leaf => try writer.interface.writeAll(" .leaf,\n"),
|
||||
.stem => |s| try writer.interface.print(" .{{ .stem = .{{ .child = {d} }} }},\n", .{s.child}),
|
||||
.fork => |f| try writer.interface.print(" .{{ .fork = .{{ .left = {d}, .right = {d} }} }},\n", .{f.left, f.right}),
|
||||
}
|
||||
}
|
||||
|
||||
try writer.interface.writeAll("};\n");
|
||||
try writer.flush();
|
||||
|
||||
std.debug.print("Generated {d} kernel nodes, root={d} -> {s}\n", .{ nodes.items.len, root, output_path });
|
||||
}
|
||||
6
flake.lock
generated
6
flake.lock
generated
@@ -20,11 +20,11 @@
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1734566935,
|
||||
"narHash": "sha256-cnBItmSwoH132tH3D4jxmMLVmk8G5VJ6q/SC3kszv9E=",
|
||||
"lastModified": 1778505177,
|
||||
"narHash": "sha256-ao5+JS50HqNt/dtm4zuiQI+IXOn6hw50W6RTwUKYTww=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "087408a407440892c1b00d80360fd64639b8091d",
|
||||
"rev": "fb2ce70b4ae882574081225eb3c2872f39418df3",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
||||
191
flake.nix
191
flake.nix
@@ -9,27 +9,157 @@
|
||||
outputs = { self, nixpkgs, flake-utils }:
|
||||
flake-utils.lib.eachDefaultSystem (system:
|
||||
let
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
packageName = "tricu";
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
packageName = "tricu";
|
||||
containerPackageName = "${packageName}-container";
|
||||
|
||||
customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
|
||||
haskellPackages = pkgs.haskellPackages;
|
||||
hsLib = pkgs.haskell.lib;
|
||||
|
||||
tricuStatic = hsLib.justStaticExecutables self.packages.${system}.default;
|
||||
|
||||
tricuPackageTests =
|
||||
haskellPackages.callCabal2nix packageName self {};
|
||||
|
||||
tricuPackage =
|
||||
hsLib.dontCheck (
|
||||
haskellPackages.callCabal2nix packageName self {}
|
||||
);
|
||||
|
||||
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
|
||||
megaparsec
|
||||
]);
|
||||
|
||||
haskellPackages = pkgs.haskellPackages;
|
||||
# ------------------------------------------------------------------
|
||||
# Zig Arboricx host
|
||||
# ------------------------------------------------------------------
|
||||
tricuZig = pkgs.stdenv.mkDerivation {
|
||||
pname = "tricu-zig";
|
||||
version = "0.1.0";
|
||||
src = ./ext/zig;
|
||||
nativeBuildInputs = [ pkgs.zig ];
|
||||
buildPhase = ''
|
||||
export ZIG_GLOBAL_CACHE_DIR=$TMPDIR/zig-cache
|
||||
zig build
|
||||
'';
|
||||
installPhase = ''
|
||||
mkdir -p $out/bin $out/lib $out/include
|
||||
cp zig-out/bin/* $out/bin/ 2>/dev/null || true
|
||||
cp zig-out/lib/* $out/lib/ 2>/dev/null || true
|
||||
cp include/arboricx.h $out/include/
|
||||
'';
|
||||
};
|
||||
|
||||
enableSharedExecutables = false;
|
||||
enableSharedLibraries = false;
|
||||
tricuZigTests = pkgs.stdenv.mkDerivation {
|
||||
pname = "tricu-zig-tests";
|
||||
version = "0.1.0";
|
||||
src = ./.;
|
||||
nativeBuildInputs = [ pkgs.gcc pkgs.python3 tricuZig ];
|
||||
buildPhase = "true";
|
||||
doCheck = true;
|
||||
checkPhase = ''
|
||||
export LD_LIBRARY_PATH=${tricuZig}/lib:$LD_LIBRARY_PATH
|
||||
ulimit -s 32768
|
||||
|
||||
tricu = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
|
||||
cd ext/zig
|
||||
|
||||
# C ABI smoke test
|
||||
gcc -o /tmp/c_abi_test tests/c_abi_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/c_abi_test
|
||||
|
||||
# Kernel path append test
|
||||
gcc -o /tmp/c_abi_append_test tests/c_abi_append_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/c_abi_append_test
|
||||
|
||||
# Native bundle tests
|
||||
gcc -o /tmp/native_bundle_append_test tests/native_bundle_append_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/native_bundle_append_test
|
||||
|
||||
gcc -o /tmp/native_bundle_id_test tests/native_bundle_id_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/native_bundle_id_test
|
||||
|
||||
gcc -o /tmp/native_bundle_bools_test tests/native_bundle_bools_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/native_bundle_bools_test
|
||||
|
||||
# Python FFI test
|
||||
ARBORICX_LIB=${tricuZig}/lib/libarboricx.so \
|
||||
python3 tests/python_ffi_test.py
|
||||
|
||||
mkdir -p $out
|
||||
echo "All Zig tests passed" > $out/result
|
||||
'';
|
||||
};
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# PHP FFI host
|
||||
# ------------------------------------------------------------------
|
||||
tricuPhp = pkgs.stdenv.mkDerivation {
|
||||
pname = "tricu-php";
|
||||
version = "0.1.0";
|
||||
src = ./ext/php;
|
||||
nativeBuildInputs = [ pkgs.makeWrapper phpWithFfi tricuZig ];
|
||||
buildPhase = "true";
|
||||
installPhase = ''
|
||||
mkdir -p $out/share/tricu-php $out/lib $out/bin
|
||||
cp -r src run.php $out/share/tricu-php/
|
||||
cp ${tricuZig}/lib/libarboricx.so $out/lib/
|
||||
cp ${tricuZig}/include/arboricx.h $out/share/tricu-php/
|
||||
|
||||
makeWrapper ${phpWithFfi}/bin/php $out/bin/tricu-php \
|
||||
--add-flags "$out/share/tricu-php/run.php" \
|
||||
--set ARBORICX_LIB "$out/lib/libarboricx.so" \
|
||||
--prefix LD_LIBRARY_PATH : "$out/lib"
|
||||
'';
|
||||
};
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# PHP FFI tests (separate target)
|
||||
# ------------------------------------------------------------------
|
||||
phpWithFfi = pkgs.php.withExtensions (exts: [ pkgs.phpExtensions.ffi ]);
|
||||
|
||||
tricuPhpTests = pkgs.stdenv.mkDerivation {
|
||||
pname = "tricu-php-tests";
|
||||
version = "0.1.0";
|
||||
src = ./.;
|
||||
nativeBuildInputs = [ phpWithFfi tricuPhp ];
|
||||
buildPhase = "true";
|
||||
doCheck = true;
|
||||
checkPhase = ''
|
||||
export ARBORICX_LIB=${tricuPhp}/lib/libarboricx.so
|
||||
export LD_LIBRARY_PATH=${tricuPhp}/lib:$LD_LIBRARY_PATH
|
||||
ulimit -s 32768
|
||||
|
||||
# Run PHP host against fixture bundles
|
||||
php ext/php/run.php run test/fixtures/id.arboricx hello
|
||||
php ext/php/run.php run test/fixtures/append.arboricx "Hello, " "world!"
|
||||
php ext/php/run.php run test/fixtures/true.arboricx
|
||||
php ext/php/run.php run test/fixtures/false.arboricx
|
||||
php ext/php/run.php run test/fixtures/notQ.arboricx "t t t"
|
||||
|
||||
mkdir -p $out
|
||||
echo "All PHP tests passed" > $out/result
|
||||
'';
|
||||
};
|
||||
in {
|
||||
packages.${packageName} = tricuPackage;
|
||||
packages.default = tricuPackage;
|
||||
packages.tricu-zig = tricuZig;
|
||||
packages.tricu-zig-tests = tricuZigTests;
|
||||
packages.tricu-php = tricuPhp;
|
||||
packages.tricu-php-tests = tricuPhpTests;
|
||||
|
||||
packages.${packageName} =
|
||||
haskellPackages.callCabal2nix packageName self rec {};
|
||||
|
||||
packages.default = self.packages.${system}.${packageName};
|
||||
defaultPackage = self.packages.${system}.default;
|
||||
checks.${packageName} = tricuPackageTests;
|
||||
checks.default = tricuPackageTests;
|
||||
|
||||
devShells.default = pkgs.mkShell {
|
||||
buildInputs = with pkgs; [
|
||||
@@ -38,10 +168,41 @@
|
||||
haskellPackages.ghcid
|
||||
customGHC
|
||||
upx
|
||||
zig
|
||||
gcc
|
||||
python3
|
||||
];
|
||||
inputsFrom = builtins.attrValues self.packages.${system};
|
||||
};
|
||||
devShell = self.devShells.${system}.default;
|
||||
|
||||
inputsFrom = [
|
||||
tricuPackage
|
||||
tricuZig
|
||||
tricuPhp
|
||||
];
|
||||
};
|
||||
|
||||
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 = ''
|
||||
'';
|
||||
};
|
||||
};
|
||||
});
|
||||
}
|
||||
|
||||
432
lib/arboricx-common.tri
Normal file
432
lib/arboricx-common.tri
Normal file
@@ -0,0 +1,432 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "bytes.tri" !Local
|
||||
!import "binary.tri" !Local
|
||||
|
||||
arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
|
||||
arboricxMajorVersion = [(0) (1)]
|
||||
arboricxMinorVersion = [(0) (0)]
|
||||
arboricxManifestSectionId = [(0) (0) (0) (1)]
|
||||
arboricxNodesSectionId = [(0) (0) (0) (2)]
|
||||
|
||||
-- Manifest magic and version constants
|
||||
arboricxManifestMagic = [(65) (82) (66) (77) (78) (70) (83) (84)]
|
||||
arboricxManifestMajorVersion = [(0) (1)]
|
||||
arboricxManifestMinorVersion = [(0) (0)]
|
||||
|
||||
errMissingSection = 4
|
||||
errUnsupportedVersion = 5
|
||||
errDuplicateSection = 6
|
||||
errDuplicateNode = 7
|
||||
errInvalidNodePayload = 8
|
||||
errMissingNode = 9
|
||||
errInvalidManifestMagic = 10
|
||||
errUnsupportedManifestVersion = 11
|
||||
errTrailingManifestBytes = 12
|
||||
errManifestValidationFailed = 13
|
||||
|
||||
nodePayloadLeafTag = 0
|
||||
nodePayloadStemTag = 1
|
||||
nodePayloadForkTag = 2
|
||||
|
||||
readArboricxMagic = (bs : expectBytes arboricxMagic bs)
|
||||
|
||||
readArboricxHeader = (bs :
|
||||
bindResult (readArboricxMagic bs)
|
||||
(_ afterMagic :
|
||||
bindResult (readBytes 2 afterMagic)
|
||||
(majorVersion afterMajor :
|
||||
bindResult (readBytes 2 afterMajor)
|
||||
(minorVersion afterMinor :
|
||||
bindResult (readBytes 4 afterMinor)
|
||||
(sectionCount afterSectionCount :
|
||||
bindResult (readBytes 8 afterSectionCount)
|
||||
(flags afterFlags :
|
||||
bindResult (readBytes 8 afterFlags)
|
||||
(dirOffset afterDirOffset :
|
||||
ok
|
||||
(pair majorVersion
|
||||
(pair minorVersion
|
||||
(pair sectionCount
|
||||
(pair flags dirOffset))))
|
||||
afterDirOffset)))))))
|
||||
|
||||
readSectionRecord = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(sectionId afterSectionId :
|
||||
bindResult (readBytes 2 afterSectionId)
|
||||
(sectionVersion afterSectionVersion :
|
||||
bindResult (readBytes 2 afterSectionVersion)
|
||||
(sectionFlags afterSectionFlags :
|
||||
bindResult (readBytes 2 afterSectionFlags)
|
||||
(compression afterCompression :
|
||||
bindResult (readBytes 2 afterCompression)
|
||||
(digestAlgorithm afterDigestAlgorithm :
|
||||
bindResult (readBytes 8 afterDigestAlgorithm)
|
||||
(offset afterOffset :
|
||||
bindResult (readBytes 8 afterOffset)
|
||||
(length afterLength :
|
||||
bindResult (readBytes 32 afterLength)
|
||||
(digest afterDigest :
|
||||
ok
|
||||
(pair sectionId
|
||||
(pair sectionVersion
|
||||
(pair sectionFlags
|
||||
(pair compression
|
||||
(pair digestAlgorithm
|
||||
(pair offset
|
||||
(pair length digest)))))))
|
||||
afterDigest)))))))))
|
||||
|
||||
readSectionDirectory_ = y (self bs sectionCount i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readSectionRecord bs)
|
||||
(sectionRecord afterSectionRecord :
|
||||
self afterSectionRecord sectionCount (succ i) (pair sectionRecord acc)))
|
||||
(equal? i sectionCount))
|
||||
|
||||
readSectionDirectory = (sectionCount bs : readSectionDirectory_ bs sectionCount 0 t)
|
||||
|
||||
sectionRecordId = (sectionRecord :
|
||||
matchPair
|
||||
(sectionId _ : sectionId)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordVersion = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(sectionVersion _ : sectionVersion)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordFlags = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(sectionFlags _ : sectionFlags)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordCompression = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(compression _ : compression)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordDigestAlgorithm = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(digestAlgorithm _ : digestAlgorithm)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordOffset = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(offset _ : offset)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordLength = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(_ payload6 :
|
||||
matchPair
|
||||
(length _ : length)
|
||||
payload6)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordDigest = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(_ payload6 :
|
||||
matchPair
|
||||
(_ digest : digest)
|
||||
payload6)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
lookupSectionRecord_ = y (self directory sectionId :
|
||||
matchList
|
||||
nothing
|
||||
(sectionRecord rest :
|
||||
matchBool
|
||||
(just sectionRecord)
|
||||
(self rest sectionId)
|
||||
(bytesEq? sectionId (sectionRecordId sectionRecord)))
|
||||
directory)
|
||||
|
||||
lookupSectionRecord = (sectionId directory : lookupSectionRecord_ directory sectionId)
|
||||
|
||||
sectionDirectoryHasId?_ = y (self directory sectionId :
|
||||
matchList
|
||||
false
|
||||
(sectionRecord rest :
|
||||
or?
|
||||
(bytesEq? sectionId (sectionRecordId sectionRecord))
|
||||
(self rest sectionId))
|
||||
directory)
|
||||
|
||||
sectionDirectoryHasId? = (sectionId directory : sectionDirectoryHasId?_ directory sectionId)
|
||||
|
||||
sectionDirectoryHasDuplicateIds? = y (self directory :
|
||||
matchList
|
||||
false
|
||||
(sectionRecord rest :
|
||||
or?
|
||||
(sectionDirectoryHasId?_ rest (sectionRecordId sectionRecord))
|
||||
(self rest))
|
||||
directory)
|
||||
|
||||
validateSectionDirectory = (directory rest :
|
||||
matchBool
|
||||
(err errDuplicateSection rest)
|
||||
(ok directory rest)
|
||||
(sectionDirectoryHasDuplicateIds? directory))
|
||||
|
||||
byteSlice = (offset length bytes : bytesTake length (bytesDrop offset bytes))
|
||||
|
||||
natMake = (bit rest :
|
||||
matchBool
|
||||
0
|
||||
(pair bit rest)
|
||||
(and? (equal? bit 0) (equal? rest 0)))
|
||||
|
||||
natAdd = y (self a b :
|
||||
triage
|
||||
b
|
||||
(_ : b)
|
||||
(aBit aRest :
|
||||
triage
|
||||
a
|
||||
(_ : a)
|
||||
(bBit bRest :
|
||||
matchBool
|
||||
(natMake 0 (succ (self aRest bRest)))
|
||||
(natMake (matchBool (matchBool 0 1 bBit) (matchBool 1 0 bBit) aBit)
|
||||
(self aRest bRest))
|
||||
(and? (equal? aBit 1) (equal? bBit 1)))
|
||||
b)
|
||||
a)
|
||||
|
||||
natDouble = (n : matchBool 0 (pair 0 n) (equal? n 0))
|
||||
|
||||
natTimes256 = (n :
|
||||
natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble n))))))))
|
||||
|
||||
byteNatShiftAppend_ = y (self byte acc i :
|
||||
matchBool
|
||||
acc
|
||||
(triage
|
||||
(natMake 0 (self 0 acc (succ i)))
|
||||
(_ : acc)
|
||||
(bit rest : natMake bit (self rest acc (succ i)))
|
||||
byte)
|
||||
(equal? i 8))
|
||||
|
||||
byteNatShiftAppend = (byte acc : byteNatShiftAppend_ byte acc 0)
|
||||
|
||||
beBytesToNat = (bytes :
|
||||
foldl
|
||||
(acc byte : byteNatShiftAppend byte acc)
|
||||
0
|
||||
bytes)
|
||||
|
||||
u32BEBytesToNat = beBytesToNat
|
||||
u64BEBytesToNat = beBytesToNat
|
||||
|
||||
arboricxHeaderMajorVersion = (header :
|
||||
matchPair
|
||||
(majorVersion _ : majorVersion)
|
||||
header)
|
||||
|
||||
arboricxHeaderMinorVersion = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(minorVersion _ : minorVersion)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderSectionCount = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(sectionCount _ : sectionCount)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderFlags = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(flags _ : flags)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderDirOffset = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ dirOffset : dirOffset)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
validateArboricxHeader = (header rest :
|
||||
matchBool
|
||||
(ok header rest)
|
||||
(err errUnsupportedVersion rest)
|
||||
(and?
|
||||
(bytesEq? arboricxMajorVersion (arboricxHeaderMajorVersion header))
|
||||
(bytesEq? arboricxMinorVersion (arboricxHeaderMinorVersion header))))
|
||||
|
||||
readArboricxContainer = (bs :
|
||||
bindResult (readArboricxHeader bs)
|
||||
(header afterHeader :
|
||||
bindResult (validateArboricxHeader header afterHeader)
|
||||
(validHeader afterValidHeader :
|
||||
bindResult (readSectionDirectory
|
||||
(u32BEBytesToNat (arboricxHeaderSectionCount validHeader))
|
||||
(bytesDrop (u64BEBytesToNat (arboricxHeaderDirOffset validHeader)) bs))
|
||||
(directory afterDirectory :
|
||||
bindResult (validateSectionDirectory directory afterDirectory)
|
||||
(validDirectory afterValidDirectory :
|
||||
ok (pair validHeader validDirectory) afterValidDirectory)))))
|
||||
|
||||
sectionRecordOffsetNat = (sectionRecord :
|
||||
u64BEBytesToNat (sectionRecordOffset sectionRecord))
|
||||
|
||||
sectionRecordLengthNat = (sectionRecord :
|
||||
u64BEBytesToNat (sectionRecordLength sectionRecord))
|
||||
|
||||
extractSectionBytes = (sectionRecord containerBytes :
|
||||
byteSlice
|
||||
(sectionRecordOffsetNat sectionRecord)
|
||||
(sectionRecordLengthNat sectionRecord)
|
||||
containerBytes)
|
||||
|
||||
extractSectionBytesResult = (sectionRecord containerBytes rest :
|
||||
(sectionBytes :
|
||||
matchBool
|
||||
(ok sectionBytes rest)
|
||||
(err errUnexpectedEof rest)
|
||||
(equal? (bytesLength sectionBytes) (sectionRecordLengthNat sectionRecord)))
|
||||
(extractSectionBytes sectionRecord containerBytes))
|
||||
|
||||
lookupSectionBytes = (sectionId directory containerBytes :
|
||||
triage
|
||||
nothing
|
||||
(sectionRecord : just (extractSectionBytes sectionRecord containerBytes))
|
||||
(_ _ : nothing)
|
||||
(lookupSectionRecord sectionId directory))
|
||||
|
||||
sectionBytesOrErr = (sectionId directory containerBytes rest :
|
||||
triage
|
||||
(err errMissingSection rest)
|
||||
(sectionRecord : extractSectionBytesResult sectionRecord containerBytes rest)
|
||||
(_ _ : err errMissingSection rest)
|
||||
(lookupSectionRecord sectionId directory))
|
||||
|
||||
readArboricxSectionBytes = (sectionId bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory : sectionBytesOrErr sectionId directory bs afterContainer)
|
||||
container))
|
||||
|
||||
readArboricxRequiredSections = (bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory :
|
||||
bindResult (sectionBytesOrErr arboricxManifestSectionId directory bs afterContainer)
|
||||
(manifestBytes _ :
|
||||
bindResult (sectionBytesOrErr arboricxNodesSectionId directory bs afterContainer)
|
||||
(nodesBytes _ :
|
||||
ok (pair manifestBytes nodesBytes) afterContainer)))
|
||||
container))
|
||||
23
lib/arboricx-dispatch.tri
Normal file
23
lib/arboricx-dispatch.tri
Normal file
@@ -0,0 +1,23 @@
|
||||
!import "arboricx.tri" !Local
|
||||
!import "patterns.tri" !Local
|
||||
|
||||
-- Multi-purpose kernel dispatch.
|
||||
--
|
||||
-- runArboricxTyped tag bundleBytes args
|
||||
-- tag 0 → hostTree (runArboricxToTree)
|
||||
-- tag 1 → hostString (runArboricxToString)
|
||||
-- tag 2 → hostNumber (runArboricxToNumber)
|
||||
-- tag 3 → hostBool (runArboricxToBool)
|
||||
-- tag 4 → hostList (runArboricxToList)
|
||||
-- tag 5 → hostBytes (runArboricxToBytes)
|
||||
-- otherwise → err 99 bundleBytes
|
||||
|
||||
runArboricxTyped = (tag bs args :
|
||||
match tag
|
||||
[[(equal? hostTreeTag) (_ : runArboricxToTree bs args)]
|
||||
[(equal? hostStringTag) (_ : runArboricxToString bs args)]
|
||||
[(equal? hostNumberTag) (_ : runArboricxToNumber bs args)]
|
||||
[(equal? hostBoolTag) (_ : runArboricxToBool bs args)]
|
||||
[(equal? hostListTag) (_ : runArboricxToList bs args)]
|
||||
[(equal? hostBytesTag) (_ : runArboricxToBytes bs args)]
|
||||
[otherwise (_ : err 99 bs)]])
|
||||
343
lib/arboricx-manifest.tri
Normal file
343
lib/arboricx-manifest.tri
Normal file
@@ -0,0 +1,343 @@
|
||||
!import "arboricx-nodes.tri" !Local
|
||||
|
||||
readManifestMagic = (bs :
|
||||
expectBytes arboricxManifestMagic bs)
|
||||
|
||||
-- Read a u32 BE length, then that many raw bytes.
|
||||
-- Returns the payload bytes and remaining input.
|
||||
readLengthPrefixedString = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(lengthBytes afterLengthBytes :
|
||||
bindResult (readBytes (u32BEBytesToNat lengthBytes) afterLengthBytes)
|
||||
(payload afterPayload :
|
||||
ok payload afterPayload)))
|
||||
|
||||
-- Helper: read a single capability string (length-prefixed string)
|
||||
readCapability = (bs :
|
||||
readLengthPrefixedString bs)
|
||||
|
||||
-- Helper worker: read N capability strings (counts up from 0)
|
||||
readCapabilities_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readCapability bs)
|
||||
(cap afterCap :
|
||||
self afterCap count (succ i) (pair cap acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N capabilities
|
||||
readCapabilities = (count bs :
|
||||
readCapabilities_ bs count 0 t)
|
||||
|
||||
-- Helper: read a single root entry (32-byte raw hash + length-prefixed role)
|
||||
readRootEntry = (bs :
|
||||
bindResult (readBytes 32 bs)
|
||||
(hashRaw afterHash :
|
||||
bindResult (readLengthPrefixedString afterHash)
|
||||
(role afterRole :
|
||||
ok (pair hashRaw role) afterRole)))
|
||||
|
||||
-- Helper worker: read N root entries (counts up from 0)
|
||||
readRoots_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readRootEntry bs)
|
||||
(root afterRoot :
|
||||
self afterRoot count (succ i) (pair root acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N roots
|
||||
readRoots = (count bs :
|
||||
readRoots_ bs count 0 t)
|
||||
|
||||
-- Helper: read a single export entry
|
||||
readExportEntry = (bs :
|
||||
bindResult (readLengthPrefixedString bs)
|
||||
(name afterName :
|
||||
bindResult (readBytes 32 afterName)
|
||||
(rootHashRaw afterRootHash :
|
||||
bindResult (readLengthPrefixedString afterRootHash)
|
||||
(kind afterKind :
|
||||
bindResult (readLengthPrefixedString afterKind)
|
||||
(abi afterAbi :
|
||||
ok (pair name (pair rootHashRaw (pair kind abi))) afterAbi)))))
|
||||
|
||||
-- Helper worker: read N export entries (counts up from 0)
|
||||
readExports_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readExportEntry bs)
|
||||
(exp afterExp :
|
||||
self afterExp count (succ i) (pair exp acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N exports
|
||||
readExports = (count bs :
|
||||
readExports_ bs count 0 t)
|
||||
|
||||
-- Main core manifest parser.
|
||||
-- Reads: magic, version, core strings, capabilities, closure, roots, exports.
|
||||
readManifestCore = (bs :
|
||||
bindResult (readManifestMagic bs)
|
||||
(_ afterMagic :
|
||||
bindResult (readBytes 2 afterMagic)
|
||||
(majorVersion afterMajor :
|
||||
bindResult (readBytes 2 afterMajor)
|
||||
(minorVersion afterMinor :
|
||||
bindResult (readLengthPrefixedString afterMinor)
|
||||
(schema afterSchema :
|
||||
bindResult (readLengthPrefixedString afterSchema)
|
||||
(bundleType afterBundleType :
|
||||
bindResult (readLengthPrefixedString afterBundleType)
|
||||
(treeCalculus afterTreeCalculus :
|
||||
bindResult (readLengthPrefixedString afterTreeCalculus)
|
||||
(treeHashAlgorithm afterTreeHashAlgorithm :
|
||||
bindResult (readLengthPrefixedString afterTreeHashAlgorithm)
|
||||
(treeHashDomain afterTreeHashDomain :
|
||||
bindResult (readLengthPrefixedString afterTreeHashDomain)
|
||||
(treeNodePayload afterTreeNodePayload :
|
||||
bindResult (readLengthPrefixedString afterTreeNodePayload)
|
||||
(runtimeSemantics afterRuntimeSemantics :
|
||||
bindResult (readLengthPrefixedString afterRuntimeSemantics)
|
||||
(runtimeEvaluation afterRuntimeEvaluation :
|
||||
bindResult (readLengthPrefixedString afterRuntimeEvaluation)
|
||||
(runtimeAbi afterRuntimeAbi :
|
||||
bindResult (readBytes 4 afterRuntimeAbi)
|
||||
(capCountRaw afterCapCountRaw :
|
||||
bindResult (readCapabilities (u32BEBytesToNat capCountRaw) afterCapCountRaw)
|
||||
(capabilities afterCapabilities :
|
||||
bindResult (readBytes 1 afterCapabilities)
|
||||
(closureByte afterClosureByte :
|
||||
bindResult (readBytes 4 afterClosureByte)
|
||||
(rootCountRaw afterRootCountRaw :
|
||||
bindResult (readRoots (u32BEBytesToNat rootCountRaw) afterRootCountRaw)
|
||||
(roots afterRoots :
|
||||
bindResult (readBytes 4 afterRoots)
|
||||
(exportCountRaw afterExportCountRaw :
|
||||
bindResult (readExports (u32BEBytesToNat exportCountRaw) afterExportCountRaw)
|
||||
(exports afterExports :
|
||||
ok
|
||||
(pair schema
|
||||
(pair bundleType
|
||||
(pair treeCalculus
|
||||
(pair treeHashAlgorithm
|
||||
(pair treeHashDomain
|
||||
(pair treeNodePayload
|
||||
(pair runtimeSemantics
|
||||
(pair runtimeEvaluation
|
||||
(pair runtimeAbi
|
||||
(pair capabilities
|
||||
(pair closureByte (pair roots exports)))))))))))) afterExports))))))))))))))))))))
|
||||
|
||||
-- Metadata tag constants (u16 values)
|
||||
tagPackage = [(0) (1)]
|
||||
tagVersion = [(0) (2)]
|
||||
tagDescription = [(0) (3)]
|
||||
tagLicense = [(0) (4)]
|
||||
tagCreatedBy = [(0) (5)]
|
||||
|
||||
-- Read a single TLV entry: u16 tag + u32 length + value bytes.
|
||||
-- Returns the pair (tag, value) and remaining input.
|
||||
readTLV = (bs :
|
||||
bindResult (readBytes 2 bs)
|
||||
(tag afterTag :
|
||||
bindResult (readBytes 4 afterTag)
|
||||
(tlvLenRaw afterTlvLenRaw :
|
||||
bindResult (readBytes (u32BEBytesToNat tlvLenRaw) afterTlvLenRaw)
|
||||
(tlvValue afterTlvValue :
|
||||
ok (pair tag tlvValue) afterTlvValue))))
|
||||
|
||||
-- Worker: read N TLV entries (counts up from 0)
|
||||
readTLVs_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readTLV bs)
|
||||
(tlv afterTlv :
|
||||
self afterTlv count (succ i) (pair tlv acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Read a count followed by that many TLV entries.
|
||||
readTLVList = (count bs :
|
||||
readTLVs_ bs count 0 t)
|
||||
|
||||
-- Skip N extension TLV entries (counts up from 0)
|
||||
skipTLVs_ = y (self bs count i :
|
||||
matchBool
|
||||
(ok unit bs)
|
||||
(bindResult (readTLV bs)
|
||||
(_ afterTlv :
|
||||
self afterTlv count (succ i)))
|
||||
(equal? i count))
|
||||
|
||||
-- Full manifest parser: core fields + metadata TLV list + extension TLV list.
|
||||
readManifest = (bs :
|
||||
bindResult (readManifestCore bs)
|
||||
(coreManifest afterCore :
|
||||
bindResult (readBytes 4 afterCore)
|
||||
(metaCountRaw afterMetaCountRaw :
|
||||
bindResult (readTLVList (u32BEBytesToNat metaCountRaw) afterMetaCountRaw)
|
||||
(metadataFields afterMetadataFields :
|
||||
bindResult (readBytes 4 afterMetadataFields)
|
||||
(extCountRaw afterExtCountRaw :
|
||||
bindResult (skipTLVs_ afterExtCountRaw (u32BEBytesToNat extCountRaw) 0)
|
||||
(afterExtensions _ :
|
||||
ok
|
||||
(pair coreManifest (pair metadataFields afterExtensions))
|
||||
afterExtensions))))))
|
||||
|
||||
-- Lookup a metadata value by tag from a TLV list.
|
||||
-- Returns nothing if not found, just value if found.
|
||||
lookupMetadata_ = y (self tlvs tag :
|
||||
matchList
|
||||
nothing
|
||||
(tlv rest :
|
||||
matchBool
|
||||
(just (matchPair (_ value : value) tlv))
|
||||
(self rest tag)
|
||||
(bytesEq? (matchPair (tlvTag _ : tlvTag) tlv) tag))
|
||||
tlvs)
|
||||
|
||||
lookupMetadata = (tlvs tag :
|
||||
lookupMetadata_ tlvs tag)
|
||||
|
||||
-- Get export name from an export entry (pair name (pair rootHash (pair kind abi)))
|
||||
exportName = (exp :
|
||||
matchPair
|
||||
(name _ : name)
|
||||
exp)
|
||||
|
||||
exportRoot = (exp :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(root _ : root)
|
||||
payload)
|
||||
exp)
|
||||
|
||||
-- Check if an export name matches a given byte string.
|
||||
exportNameEq? = (nameBytes exp :
|
||||
bytesEq? nameBytes (exportName exp))
|
||||
|
||||
-- Find first export matching a name, or nothing.
|
||||
findExportByName_ = y (self exports name :
|
||||
matchList
|
||||
nothing
|
||||
(exp rest :
|
||||
matchBool
|
||||
(just exp)
|
||||
(self rest name)
|
||||
(exportNameEq? name exp))
|
||||
exports)
|
||||
|
||||
findExportByName = (exports name :
|
||||
findExportByName_ exports name)
|
||||
|
||||
-- Get list of all export names from a list of exports.
|
||||
getExportNames_ = y (self acc exports :
|
||||
matchList
|
||||
(reverse acc)
|
||||
(exp rest :
|
||||
self (pair (exportName exp) acc) rest)
|
||||
exports)
|
||||
|
||||
getExportNames = (exports :
|
||||
getExportNames_ t exports)
|
||||
|
||||
mainExportName = "main"
|
||||
|
||||
maybeExportToResult = (maybeExport :
|
||||
triage
|
||||
(err errMissingSection t)
|
||||
(export : ok export t)
|
||||
(_ _ : err errMissingSection t)
|
||||
maybeExport)
|
||||
|
||||
selectSingleExport = (exports :
|
||||
matchList
|
||||
(err errMissingSection t)
|
||||
(export rest :
|
||||
matchBool
|
||||
(ok export t)
|
||||
(err errMissingSection t)
|
||||
(emptyList? rest))
|
||||
exports)
|
||||
|
||||
selectDefaultExport = (exports :
|
||||
triage
|
||||
(selectSingleExport exports)
|
||||
(export : ok export t)
|
||||
(_ _ : err errMissingSection t)
|
||||
(findExportByName exports mainExportName))
|
||||
|
||||
-- Select an export: explicit name if provided, otherwise "main", otherwise
|
||||
-- the sole export if the bundle has exactly one export.
|
||||
selectExport = (exports nameBytes :
|
||||
matchBool
|
||||
(selectDefaultExport exports)
|
||||
(maybeExportToResult (findExportByName exports nameBytes))
|
||||
(emptyList? nameBytes))
|
||||
|
||||
selectExportOpt = (exports optNameBytes :
|
||||
selectExport exports optNameBytes)
|
||||
|
||||
-- Expected core string values (raw UTF-8 bytes, not decoded to Unicode characters).
|
||||
expectedSchema = "arboricx.bundle.manifest.v1"
|
||||
expectedBundleType = "tree-calculus-executable-object"
|
||||
expectedTreeCalculus = "tree-calculus.v1"
|
||||
expectedTreeHashAlgorithm = "sha256"
|
||||
expectedTreeHashDomain = "arboricx.merkle.node.v1"
|
||||
expectedTreeNodePayload = "arboricx.merkle.payload.v1"
|
||||
expectedRuntimeSemantics = "tree-calculus.v1"
|
||||
expectedRuntimeEvaluation = "normal-order"
|
||||
expectedRuntimeAbi = "arboricx.abi.tree.v1"
|
||||
|
||||
-- Manifest core field accessors.
|
||||
-- readManifestCore returns: (pair schema (pair bundleType (... (pair closureByte (pair roots exports)))))
|
||||
pairFirst = (p : matchPair (a _ : a) p)
|
||||
pairSecond = (p : matchPair (_ b : b) p)
|
||||
|
||||
manifestSchema = (core : pairFirst core)
|
||||
manifestBundleType = (core : pairFirst (pairSecond core))
|
||||
manifestTreeCalculus = (core : pairFirst (pairSecond (pairSecond core)))
|
||||
manifestTreeHashAlgorithm = (core : pairFirst (pairSecond (pairSecond (pairSecond core))))
|
||||
manifestTreeHashDomain = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond core)))))
|
||||
manifestTreeNodePayload = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))
|
||||
manifestRuntimeSemantics = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))
|
||||
manifestRuntimeEvaluation = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))
|
||||
manifestRuntimeAbi = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))))
|
||||
manifestCapabilities = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))
|
||||
manifestClosureByte = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))))))
|
||||
manifestRoots = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))))
|
||||
manifestExports = (core : pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))))
|
||||
|
||||
-- Helper: compare a manifest field against an expected byte string.
|
||||
manifestFieldMatch? = (actual expected : bytesEq? actual expected)
|
||||
|
||||
-- Validate core manifest fields against expected values.
|
||||
validateManifestCore = (core rest :
|
||||
matchBool
|
||||
(ok core rest)
|
||||
(err errManifestValidationFailed rest)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestSchema core) expectedSchema)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestBundleType core) expectedBundleType)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeCalculus core) expectedTreeCalculus)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeHashAlgorithm core) expectedTreeHashAlgorithm)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeHashDomain core) expectedTreeHashDomain)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeNodePayload core) expectedTreeNodePayload)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeSemantics core) expectedRuntimeSemantics)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeEvaluation core) expectedRuntimeEvaluation)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeAbi core) expectedRuntimeAbi)
|
||||
(and?
|
||||
(bytesEq? (manifestClosureByte core) [(0)])
|
||||
(and?
|
||||
(not? (emptyList? (manifestRoots core)))
|
||||
(not? (emptyList? (manifestExports core)))))))))))))))
|
||||
232
lib/arboricx-nodes.tri
Normal file
232
lib/arboricx-nodes.tri
Normal file
@@ -0,0 +1,232 @@
|
||||
!import "arboricx-common.tri" !Local
|
||||
|
||||
readNodeRecord = (bs :
|
||||
bindResult (readBytes 32 bs)
|
||||
(nodeHash afterNodeHash :
|
||||
bindResult (readBytes 4 afterNodeHash)
|
||||
(payloadLength afterPayloadLength :
|
||||
bindResult (readBytes (u32BEBytesToNat payloadLength) afterPayloadLength)
|
||||
(payload afterPayload :
|
||||
ok
|
||||
(pair nodeHash
|
||||
(pair payloadLength payload))
|
||||
afterPayload))))
|
||||
|
||||
nodeRecordHash = (nodeRecord :
|
||||
matchPair
|
||||
(nodeHash _ : nodeHash)
|
||||
nodeRecord)
|
||||
|
||||
nodeRecordPayloadLength = (nodeRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(payloadLength _ : payloadLength)
|
||||
payload)
|
||||
nodeRecord)
|
||||
|
||||
nodeRecordPayload = (nodeRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ nodePayload : nodePayload)
|
||||
payload)
|
||||
nodeRecord)
|
||||
|
||||
nodePayloadKind = (nodePayload : bytesHead nodePayload)
|
||||
|
||||
nodePayloadHasTag? = (tag nodePayload :
|
||||
triage
|
||||
false
|
||||
(actualTag : byteEq? actualTag tag)
|
||||
(_ _ : false)
|
||||
(nodePayloadKind nodePayload))
|
||||
|
||||
nodePayloadLeaf? = (nodePayload : bytesEq? [(0)] nodePayload)
|
||||
|
||||
nodePayloadStem? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadStemTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 33))
|
||||
|
||||
nodePayloadFork? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadForkTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 65))
|
||||
|
||||
nodePayloadValid? = (nodePayload :
|
||||
or?
|
||||
(nodePayloadLeaf? nodePayload)
|
||||
(or?
|
||||
(nodePayloadStem? nodePayload)
|
||||
(nodePayloadFork? nodePayload)))
|
||||
|
||||
nodePayloadStemChildHash = (nodePayload : bytesTake 32 (bytesDrop 1 nodePayload))
|
||||
nodePayloadForkLeftHash = (nodePayload : bytesTake 32 (bytesDrop 1 nodePayload))
|
||||
nodePayloadForkRightHash = (nodePayload : bytesTake 32 (bytesDrop 33 nodePayload))
|
||||
|
||||
nodeRecordPayloadValid? = (nodeRecord : nodePayloadValid? (nodeRecordPayload nodeRecord))
|
||||
|
||||
nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
|
||||
matchList
|
||||
false
|
||||
(nodeRecord rest :
|
||||
or?
|
||||
(not? (nodeRecordPayloadValid? nodeRecord))
|
||||
(self rest))
|
||||
nodeRecords)
|
||||
|
||||
nodeRecordsHaveHash? = y (self nodeRecords nodeHash :
|
||||
matchList
|
||||
false
|
||||
(nodeRecord rest :
|
||||
or?
|
||||
(bytesEq? nodeHash (nodeRecordHash nodeRecord))
|
||||
(self rest nodeHash))
|
||||
nodeRecords)
|
||||
|
||||
nodeRecordsHaveDuplicateHashes? = y (self nodeRecords :
|
||||
matchList
|
||||
false
|
||||
(nodeRecord rest :
|
||||
or?
|
||||
(nodeRecordsHaveHash? rest (nodeRecordHash nodeRecord))
|
||||
(self rest))
|
||||
nodeRecords)
|
||||
|
||||
lookupNodeRecord_ = y (self nodeRecords nodeHash :
|
||||
matchList
|
||||
nothing
|
||||
(nodeRecord rest :
|
||||
matchBool
|
||||
(just nodeRecord)
|
||||
(self rest nodeHash)
|
||||
(bytesEq? nodeHash (nodeRecordHash nodeRecord)))
|
||||
nodeRecords)
|
||||
|
||||
lookupNodeRecord = (nodeHash nodeRecords : lookupNodeRecord_ nodeRecords nodeHash)
|
||||
|
||||
nodeRecordChildHashes = (nodeRecord :
|
||||
(nodePayload :
|
||||
matchBool
|
||||
t
|
||||
(matchBool
|
||||
(pair (nodePayloadStemChildHash nodePayload) t)
|
||||
(pair (nodePayloadForkLeftHash nodePayload)
|
||||
(pair (nodePayloadForkRightHash nodePayload) t))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
(nodeRecordPayload nodeRecord))
|
||||
|
||||
nodeHashPresent? = (nodeHash nodeRecords : nodeRecordsHaveHash? nodeRecords nodeHash)
|
||||
|
||||
nodeChildHashesPresent? = y (self childHashes nodeRecords :
|
||||
matchList
|
||||
true
|
||||
(childHash rest :
|
||||
and?
|
||||
(nodeHashPresent? childHash nodeRecords)
|
||||
(self rest nodeRecords))
|
||||
childHashes)
|
||||
|
||||
nodeRecordChildrenPresent? = (nodeRecord nodeRecords :
|
||||
nodeChildHashesPresent? (nodeRecordChildHashes nodeRecord) nodeRecords)
|
||||
|
||||
nodeRecordsClosed? = y (self nodeRecords allNodeRecords :
|
||||
matchList
|
||||
true
|
||||
(nodeRecord rest :
|
||||
and?
|
||||
(nodeRecordChildrenPresent? nodeRecord allNodeRecords)
|
||||
(self rest allNodeRecords))
|
||||
nodeRecords)
|
||||
|
||||
validateNodeRecords = (nodeRecords rest :
|
||||
matchBool
|
||||
(err errInvalidNodePayload rest)
|
||||
(matchBool
|
||||
(err errDuplicateNode rest)
|
||||
(matchBool
|
||||
(ok nodeRecords rest)
|
||||
(err errMissingNode rest)
|
||||
(nodeRecordsClosed? nodeRecords nodeRecords))
|
||||
(nodeRecordsHaveDuplicateHashes? nodeRecords))
|
||||
(nodeRecordsHaveInvalidPayload? nodeRecords))
|
||||
|
||||
readNodeRecords_ = y (self bs nodeCount i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readNodeRecord bs)
|
||||
(nodeRecord afterNodeRecord :
|
||||
self afterNodeRecord nodeCount (succ i) (pair nodeRecord acc)))
|
||||
(equal? i nodeCount))
|
||||
|
||||
readNodeRecords = (nodeCount bs : readNodeRecords_ bs nodeCount 0 t)
|
||||
|
||||
readNodesSection = (bs :
|
||||
bindResult (readBytes 8 bs)
|
||||
(nodeCount afterNodeCount :
|
||||
bindResult (readNodeRecords (u64BEBytesToNat nodeCount) afterNodeCount)
|
||||
(nodeRecords afterNodeRecords :
|
||||
bindResult (validateNodeRecords nodeRecords afterNodeRecords)
|
||||
(validNodeRecords afterValidNodeRecords :
|
||||
ok (pair nodeCount validNodeRecords) afterValidNodeRecords))))
|
||||
|
||||
readNodesSectionComplete = (bs :
|
||||
bindResult (readNodesSection bs)
|
||||
(nodesSection afterNodesSection :
|
||||
matchBool
|
||||
(ok nodesSection afterNodesSection)
|
||||
(err errUnexpectedBytes afterNodesSection)
|
||||
(bytesNil? afterNodesSection)))
|
||||
|
||||
readArboricxNodesSection = (bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory :
|
||||
bindResult (sectionBytesOrErr arboricxNodesSectionId directory bs afterContainer)
|
||||
(nodesBytes _ :
|
||||
bindResult (readNodesSectionComplete nodesBytes)
|
||||
(nodesSection _ : ok nodesSection afterContainer)))
|
||||
container))
|
||||
|
||||
nodesSectionCount = (nodesSection :
|
||||
matchPair
|
||||
(nodeCount _ : nodeCount)
|
||||
nodesSection)
|
||||
|
||||
nodesSectionRecords = (nodesSection :
|
||||
matchPair
|
||||
(_ nodeRecords : nodeRecords)
|
||||
nodesSection)
|
||||
|
||||
nodeRecordToTreeWith = (self nodeRecords nodeRecord :
|
||||
(nodePayload :
|
||||
matchBool
|
||||
(ok t t)
|
||||
(matchBool
|
||||
(bindResult (self (nodePayloadStemChildHash nodePayload) nodeRecords)
|
||||
(child _ : ok (t child) t))
|
||||
(bindResult (self (nodePayloadForkLeftHash nodePayload) nodeRecords)
|
||||
(left _ :
|
||||
bindResult (self (nodePayloadForkRightHash nodePayload) nodeRecords)
|
||||
(right _ : ok (pair left right) t)))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
(nodeRecordPayload nodeRecord))
|
||||
|
||||
nodeHashToTree = y (self nodeHash nodeRecords :
|
||||
triage
|
||||
(err errMissingNode t)
|
||||
(nodeRecord : nodeRecordToTreeWith self nodeRecords nodeRecord)
|
||||
(_ _ : err errMissingNode t)
|
||||
(lookupNodeRecord nodeHash nodeRecords))
|
||||
|
||||
readArboricxTreeFromHash = (rootHash bs :
|
||||
bindResult (readArboricxNodesSection bs)
|
||||
(nodesSection afterContainer :
|
||||
bindResult (nodeHashToTree rootHash (nodesSectionRecords nodesSection))
|
||||
(tree _ : ok tree afterContainer)))
|
||||
|
||||
readArboricxExecutableFromHash = readArboricxTreeFromHash
|
||||
136
lib/arboricx.tri
Normal file
136
lib/arboricx.tri
Normal file
@@ -0,0 +1,136 @@
|
||||
!import "arboricx-manifest.tri" !Local
|
||||
|
||||
-- Read and validate a full Arboricx bundle.
|
||||
-- Returns (pair validManifest afterContainer).
|
||||
-- The manifest core fields are validated against expected values.
|
||||
readArboricxBundle = (bs :
|
||||
bindResult (readArboricxRequiredSections bs)
|
||||
(sections afterContainer :
|
||||
matchPair
|
||||
(manifestBytes _ :
|
||||
bindResult (readManifest manifestBytes)
|
||||
(parsedManifest afterManifest :
|
||||
matchPair
|
||||
(coreManifest metadataWithExtensions :
|
||||
bindResult (validateManifestCore coreManifest afterManifest)
|
||||
(validCore _ : ok (pair validCore metadataWithExtensions) afterContainer))
|
||||
parsedManifest))
|
||||
sections))
|
||||
|
||||
-- Select an export from a validated bundle and reconstruct its root tree.
|
||||
-- Returns ok executable afterContainer, or propagates parse/selection/node errors.
|
||||
readArboricxExecutableByName = (nameBytes bs :
|
||||
bindResult (readArboricxBundle bs)
|
||||
(bundleResult afterBundle :
|
||||
matchPair
|
||||
(validCore _ :
|
||||
bindResult (selectExport (manifestExports validCore) nameBytes)
|
||||
(selectedExport _ :
|
||||
readArboricxTreeFromHash (exportRoot selectedExport) bs))
|
||||
bundleResult))
|
||||
|
||||
readArboricxExecutable = (bs :
|
||||
readArboricxExecutableByName [] bs)
|
||||
|
||||
applyArgs = (f args :
|
||||
foldl
|
||||
(acc arg : acc arg)
|
||||
f
|
||||
args)
|
||||
|
||||
runArboricxByName = (nameBytes bs arg :
|
||||
bindResult (readArboricxExecutableByName nameBytes bs)
|
||||
(executable rest : ok (executable arg) rest))
|
||||
|
||||
runArboricx = (bs arg :
|
||||
runArboricxByName [] bs arg)
|
||||
|
||||
runArboricxArgsByName = (nameBytes bs args :
|
||||
bindResult (readArboricxExecutableByName nameBytes bs)
|
||||
(executable rest : ok (applyArgs executable args) rest))
|
||||
|
||||
runArboricxArgs = (bs args :
|
||||
runArboricxArgsByName [] bs args)
|
||||
|
||||
errHostCodecFailed = 14
|
||||
|
||||
hostTreeTag = 0
|
||||
hostStringTag = 1
|
||||
hostNumberTag = 2
|
||||
hostBoolTag = 3
|
||||
hostListTag = 4
|
||||
hostBytesTag = 5
|
||||
|
||||
hostTree = (value : pair hostTreeTag value)
|
||||
hostString = (bytes : pair hostStringTag bytes)
|
||||
hostNumber = (n : pair hostNumberTag n)
|
||||
hostBool = (b : pair hostBoolTag b)
|
||||
hostList = (xs : pair hostListTag xs)
|
||||
hostBytes = (bytes : pair hostBytesTag bytes)
|
||||
|
||||
hostValueTag = (hostValue : pairFirst hostValue)
|
||||
hostValuePayload = (hostValue : pairSecond hostValue)
|
||||
|
||||
hostBool? = (value : or? (equal? value false) (equal? value true))
|
||||
|
||||
hostNumber? = y (self value :
|
||||
triage
|
||||
true
|
||||
(_ : false)
|
||||
(bit rest :
|
||||
and?
|
||||
(or? (equal? bit false) (equal? bit true))
|
||||
(self rest))
|
||||
value)
|
||||
|
||||
hostList? = y (self value :
|
||||
triage
|
||||
true
|
||||
(_ : false)
|
||||
(_ rest : self rest)
|
||||
value)
|
||||
|
||||
hostString? = y (self value :
|
||||
matchList
|
||||
true
|
||||
(byte rest : and? (hostNumber? byte) (self rest))
|
||||
value)
|
||||
|
||||
hostBytes? = hostString?
|
||||
|
||||
wrapHostValue = (validator wrapper resultValue rest :
|
||||
matchBool
|
||||
(ok (wrapper resultValue) rest)
|
||||
(err errHostCodecFailed resultValue)
|
||||
(validator resultValue))
|
||||
|
||||
runArboricxByNameToTree = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : ok (hostTree value) rest))
|
||||
|
||||
runArboricxByNameToString = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValue hostString? hostString value rest))
|
||||
|
||||
runArboricxByNameToNumber = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValue hostNumber? hostNumber value rest))
|
||||
|
||||
runArboricxByNameToBool = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValue hostBool? hostBool value rest))
|
||||
|
||||
runArboricxByNameToList = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValue hostList? hostList value rest))
|
||||
|
||||
runArboricxByNameToBytes = (nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValue hostBytes? hostBytes value rest))
|
||||
|
||||
runArboricxToTree = (bs args : runArboricxByNameToTree [] bs args)
|
||||
runArboricxToString = (bs args : runArboricxByNameToString [] bs args)
|
||||
runArboricxToNumber = (bs args : runArboricxByNameToNumber [] bs args)
|
||||
runArboricxToBool = (bs args : runArboricxByNameToBool [] bs args)
|
||||
runArboricxToList = (bs args : runArboricxByNameToList [] bs args)
|
||||
runArboricxToBytes = (bs args : runArboricxByNameToBytes [] bs args)
|
||||
87
lib/binary.tri
Normal file
87
lib/binary.tri
Normal 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)
|
||||
51
lib/bytes.tri
Normal file
51
lib/bytes.tri
Normal file
@@ -0,0 +1,51 @@
|
||||
!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 remaining n i :
|
||||
matchList
|
||||
t
|
||||
(h r :
|
||||
matchBool
|
||||
t
|
||||
(pair h (self r n (succ i)))
|
||||
(equal? i n))
|
||||
remaining)
|
||||
|
||||
bytesTake = n bytes : bytesTake_ bytes n 0
|
||||
|
||||
bytesDrop_ = y (self remaining n i :
|
||||
matchList
|
||||
t
|
||||
(_ r :
|
||||
matchBool
|
||||
remaining
|
||||
(self r n (succ i))
|
||||
(equal? i n))
|
||||
remaining)
|
||||
|
||||
bytesDrop = n bytes : bytesDrop_ bytes n 0
|
||||
|
||||
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)
|
||||
@@ -27,11 +27,11 @@ filter_ = y (self : matchList
|
||||
(head tail f : matchBool (t head) id (f head) (self tail f)))
|
||||
filter = f l : filter_ l f
|
||||
|
||||
foldl_ = y (self f l x : matchList (acc : acc) (head tail acc : self f tail (f acc head)) l x)
|
||||
foldl = f x l : foldl_ f l x
|
||||
foldl_ = y (self l f x : matchList (acc : acc) (head tail acc : self tail f (f acc head)) l x)
|
||||
foldl = f x l : foldl_ l f x
|
||||
|
||||
foldr_ = y (self x f l : matchList x (head tail : f (self x f tail) head) l)
|
||||
foldr = f x l : foldr_ x f l
|
||||
foldr_ = y (self l f x : matchList x (head tail : f (self tail f x) head) l)
|
||||
foldr = f x l : foldr_ l f x
|
||||
|
||||
length = y (self : matchList
|
||||
0
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" List
|
||||
!import "list.tri" !Local
|
||||
|
||||
match_ = y (self value patterns :
|
||||
triage
|
||||
@@ -17,8 +17,8 @@ match_ = y (self value patterns :
|
||||
patterns)
|
||||
|
||||
match = (value patterns :
|
||||
match_ value (List.map (sublist :
|
||||
pair (List.head sublist) (List.head (List.tail sublist)))
|
||||
match_ value (map (sublist :
|
||||
pair (head sublist) (head (tail sublist)))
|
||||
patterns))
|
||||
|
||||
otherwise = const (t t)
|
||||
|
||||
9
notes/php-cli-run-flags.md
Normal file
9
notes/php-cli-run-flags.md
Normal file
@@ -0,0 +1,9 @@
|
||||
# PHP Recommended Run Flags
|
||||
|
||||
```php
|
||||
php -d memory_limit=4G \
|
||||
-d opcache.enable_cli=1 \
|
||||
-d opcache.jit_buffer_size=256M \
|
||||
-d opcache.jit=tracing \
|
||||
ext/php/run.php run $PATH_TO_ARBORIX_BUNDLE $ARGS
|
||||
```
|
||||
81
notes/recursive-consumers.md
Normal file
81
notes/recursive-consumers.md
Normal file
@@ -0,0 +1,81 @@
|
||||
# Recursive Consumer Argument Order
|
||||
|
||||
## Rule
|
||||
|
||||
Put consumed data first in recursive workers.
|
||||
|
||||
*AVOID* this shape:
|
||||
|
||||
```text
|
||||
worker control state input
|
||||
```
|
||||
|
||||
*USE* this shape:
|
||||
|
||||
```text
|
||||
worker input control state
|
||||
```
|
||||
|
||||
The consumed structure should block recursion when it is unknown. Counters, indexes, lengths, and accumulator state should not be able to drive recursion over abstract input.
|
||||
|
||||
## Bad shape
|
||||
|
||||
The original `readBytes_` worker put loop-control arguments before the byte stream:
|
||||
|
||||
```tricu
|
||||
readBytes_ = y (self n i bs original acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(matchResult
|
||||
(code rest : err code original)
|
||||
(actual rest :
|
||||
self n (succ i) rest original (pair actual acc))
|
||||
(readU8 bs))
|
||||
(equal? i n))
|
||||
|
||||
readBytes = (n bs : readBytes_ n 0 bs bs t)
|
||||
```
|
||||
|
||||
With a partial application like:
|
||||
|
||||
```tricu
|
||||
readBytes 2
|
||||
```
|
||||
|
||||
the evaluator knows `n = 2` and `i = 0`, but `bs` is still abstract. That lets the counter check drive recursive specialization before the byte stream is available, which can build a huge symbolic residual tree. This has been proven; do not reason about it further.
|
||||
|
||||
## Good shape
|
||||
|
||||
The corrected worker takes the byte stream first and immediately case-analyzes it:
|
||||
|
||||
```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 a function waiting on `bs`. Since the worker immediately performs `matchList ... bs`, evaluation blocks on the missing input instead of unrolling the counter loop.
|
||||
|
||||
## Takeaway
|
||||
|
||||
```text
|
||||
Let consumed data drive recursion.
|
||||
Do not let counters unroll over abstract input.
|
||||
```
|
||||
17
notes/tricu-cli-debugging.md
Normal file
17
notes/tricu-cli-debugging.md
Normal file
@@ -0,0 +1,17 @@
|
||||
# tricu CLI debugging notes
|
||||
|
||||
For ad-hoc expressions, prefer stdin mode and set `TRICU_DB_PATH` to a DB that already has library definitions imported:
|
||||
|
||||
```sh
|
||||
TRICU_DB_PATH=/tmp/gpt.db ./result/bin/tricu eval -t decode <<'EOF'
|
||||
main = <expression-to-run>
|
||||
EOF
|
||||
```
|
||||
|
||||
Important details:
|
||||
|
||||
- `eval` from stdin evaluates the submitted program and uses its final/main result.
|
||||
- When using `-f FILE`, the CLI expects a `main` definition in the evaluated file context.
|
||||
- With `TRICU_DB_PATH=/tmp/gpt.db`, definitions already loaded into that content store are in scope; do not add `!import` lines unless you intentionally want file import preprocessing.
|
||||
- `!import "lib/arboricx.tri" !Local` is relative to the file being preprocessed; from temp files it will look under `/tmp`, so avoid that pattern for scratch files.
|
||||
- Do not inspect huge Arboricx values with `-t fsl`; write small predicates/accessors and return booleans, numbers, or byte strings decoded with `-t decode`.
|
||||
309
src/ContentStore.hs
Normal file
309
src/ContentStore.hs
Normal file
@@ -0,0 +1,309 @@
|
||||
module ContentStore where
|
||||
|
||||
import Research
|
||||
|
||||
import Control.Monad (foldM, forM_, void)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Char (isHexDigit)
|
||||
import Data.List (nub, sort)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Database.SQLite.Simple
|
||||
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (die)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
data StoredNode = StoredNode ByteString deriving (Show)
|
||||
|
||||
instance FromRow StoredNode where
|
||||
fromRow = StoredNode <$> field
|
||||
|
||||
data StoredTerm = StoredTerm
|
||||
{ termHash :: Text
|
||||
, termNames :: Text
|
||||
, termMetadata :: Text
|
||||
, termCreatedAt :: Integer
|
||||
, termTags :: Text
|
||||
} deriving (Show)
|
||||
|
||||
instance FromRow StoredTerm where
|
||||
fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field
|
||||
|
||||
parseNameList :: Text -> [Text]
|
||||
parseNameList = filter (not . T.null) . T.splitOn ","
|
||||
|
||||
serializeNameList :: [Text] -> Text
|
||||
serializeNameList = T.intercalate "," . nub . sort
|
||||
|
||||
initContentStore :: IO Connection
|
||||
initContentStore = do
|
||||
dbPath <- getContentStorePath
|
||||
createDirectoryIfMissing True (takeDirectory dbPath)
|
||||
conn <- open dbPath
|
||||
setupDatabase conn
|
||||
return conn
|
||||
|
||||
-- | Initialise a database connection (file-backed or in-memory).
|
||||
-- This is factored out so tests can reuse it with ":memory:".
|
||||
setupDatabase :: Connection -> IO ()
|
||||
setupDatabase conn = do
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
|
||||
\hash TEXT PRIMARY KEY, \
|
||||
\names TEXT, \
|
||||
\metadata TEXT, \
|
||||
\created_at INTEGER DEFAULT (strftime('%s','now')), \
|
||||
\tags TEXT DEFAULT '')"
|
||||
execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)"
|
||||
execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
|
||||
\hash TEXT PRIMARY KEY, \
|
||||
\node_data BLOB NOT NULL)"
|
||||
-- Seed canonical Leaf node payload (0x00)
|
||||
putMerkleNode conn NLeaf
|
||||
|
||||
-- | Create an in-memory ContentStore connection (for tests).
|
||||
newContentStore :: IO Connection
|
||||
newContentStore = do
|
||||
conn <- open ":memory:"
|
||||
setupDatabase conn
|
||||
return conn
|
||||
|
||||
getContentStorePath :: IO FilePath
|
||||
getContentStorePath = do
|
||||
maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
|
||||
case maybeLocalPath of
|
||||
Just p -> return p
|
||||
Nothing -> do
|
||||
dataDir <- getXdgDirectory XdgData "tricu"
|
||||
return $ dataDir </> "content-store.db"
|
||||
|
||||
|
||||
|
||||
hashTerm :: T -> Text
|
||||
hashTerm = nodeHash . buildMerkle
|
||||
|
||||
storeTerm :: Connection -> [String] -> T -> IO Text
|
||||
storeTerm conn newNamesStrList term = do
|
||||
let termHashText = hashTerm term
|
||||
newNamesTextList = map T.pack newNamesStrList
|
||||
metadataText = T.pack "{}"
|
||||
-- Store all Merkle nodes for this term
|
||||
_ <- storeMerkleNodes conn term
|
||||
existingNamesQuery <- query conn
|
||||
"SELECT names FROM terms WHERE hash = ?"
|
||||
(Only termHashText) :: IO [Only Text]
|
||||
|
||||
case existingNamesQuery of
|
||||
[] -> do
|
||||
let allNamesToStore = serializeNameList newNamesTextList
|
||||
execute conn
|
||||
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
|
||||
(termHashText, allNamesToStore, metadataText, T.pack "")
|
||||
[(Only currentNamesText)] -> do
|
||||
let currentNamesList = parseNameList currentNamesText
|
||||
let combinedNamesList = currentNamesList ++ newNamesTextList
|
||||
let allNamesToStore = serializeNameList combinedNamesList
|
||||
execute conn
|
||||
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
||||
(allNamesToStore, metadataText, termHashText)
|
||||
_ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
|
||||
|
||||
return termHashText
|
||||
|
||||
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
|
||||
-- Recursively loads nodes and rebuilds the T structure.
|
||||
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
|
||||
loadTree conn h = do
|
||||
maybeNode <- getNodeMerkle conn h
|
||||
case maybeNode of
|
||||
Nothing -> return Nothing
|
||||
Just node -> Just <$> buildTree node
|
||||
where
|
||||
buildTree :: Node -> IO T
|
||||
buildTree NLeaf = return Leaf
|
||||
buildTree (NStem childHash) = do
|
||||
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
|
||||
return (Stem child)
|
||||
buildTree (NFork lHash rHash) = do
|
||||
left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
|
||||
right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
|
||||
return (Fork left right)
|
||||
|
||||
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
|
||||
-- Returns the hash of the root node.
|
||||
storeMerkleNodes :: Connection -> T -> IO MerkleHash
|
||||
storeMerkleNodes conn Leaf = do
|
||||
putMerkleNode conn NLeaf
|
||||
return $ nodeHash NLeaf
|
||||
storeMerkleNodes conn (Stem t) = do
|
||||
childHash <- storeMerkleNodes conn t
|
||||
let thisNode = NStem childHash
|
||||
putMerkleNode conn thisNode
|
||||
return $ nodeHash thisNode
|
||||
storeMerkleNodes conn (Fork l r) = do
|
||||
leftHash <- storeMerkleNodes conn l
|
||||
rightHash <- storeMerkleNodes conn r
|
||||
let thisNode = NFork leftHash rightHash
|
||||
putMerkleNode conn thisNode
|
||||
return $ nodeHash thisNode
|
||||
|
||||
|
||||
-- | Insert a Merkle node into the store (idempotent).
|
||||
putMerkleNode :: Connection -> Node -> IO ()
|
||||
putMerkleNode conn node =
|
||||
execute conn "INSERT OR IGNORE INTO merkle_nodes (hash, node_data) VALUES (?, ?)"
|
||||
(nodeHash node, serializeNode node)
|
||||
|
||||
-- | Retrieve a Merkle node by its hash.
|
||||
getNodeMerkle :: Connection -> MerkleHash -> IO (Maybe Node)
|
||||
getNodeMerkle conn h =
|
||||
queryMaybeOne conn "SELECT node_data FROM merkle_nodes WHERE hash = ?" (Only h) >>= \case
|
||||
Just (StoredNode bs) -> return $ Just (deserializeNode bs)
|
||||
Nothing -> return Nothing
|
||||
|
||||
|
||||
|
||||
hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
hashToTerm conn hashText =
|
||||
queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText)
|
||||
|
||||
nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
nameToTerm conn nameText =
|
||||
queryMaybeOne conn
|
||||
(selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1")
|
||||
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
|
||||
|
||||
listStoredTerms :: Connection -> IO [StoredTerm]
|
||||
listStoredTerms conn =
|
||||
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
|
||||
|
||||
storeEnvironment :: Connection -> Env -> IO ()
|
||||
storeEnvironment conn env = do
|
||||
let defs = Map.toList $ Map.delete "!result" env
|
||||
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
|
||||
|
||||
forM_ groupedDefs $ \(term, namesList) -> case namesList of
|
||||
_:_ -> void $ storeTerm conn namesList term
|
||||
_ -> errorWithoutStackTrace "storeEnvironment: empty names list"
|
||||
|
||||
loadTerm :: Connection -> String -> IO (Maybe T)
|
||||
loadTerm conn identifier = do
|
||||
result <- getTerm conn (T.pack identifier)
|
||||
case result of
|
||||
Just storedTerm -> loadTree conn (termHash storedTerm)
|
||||
Nothing -> return Nothing
|
||||
|
||||
getTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
getTerm conn identifier = do
|
||||
if '#' `elem` (T.unpack identifier)
|
||||
then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier))
|
||||
else nameToTerm conn identifier
|
||||
|
||||
loadEnvironment :: Connection -> IO Env
|
||||
loadEnvironment conn = do
|
||||
terms <- listStoredTerms conn
|
||||
foldM addTermToEnv Map.empty terms
|
||||
where
|
||||
addTermToEnv env storedTerm = do
|
||||
maybeT <- loadTree conn (termHash storedTerm)
|
||||
case maybeT of
|
||||
Just t -> do
|
||||
let namesList = parseNameList (termNames storedTerm)
|
||||
return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList
|
||||
Nothing -> return env
|
||||
|
||||
termVersions :: Connection -> String -> IO [(Text, T, Integer)]
|
||||
termVersions conn name = do
|
||||
let nameText = T.pack name
|
||||
results <- query conn
|
||||
("SELECT hash, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC")
|
||||
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
|
||||
|
||||
catMaybes <$> mapM (\(hashVal, timestamp) -> do
|
||||
maybeT <- loadTree conn hashVal
|
||||
return $ fmap (\t -> (hashVal, t, timestamp)) maybeT
|
||||
) results
|
||||
|
||||
setTag :: Connection -> Text -> Text -> IO ()
|
||||
setTag conn hash tagValue = do
|
||||
exists <- termExists conn hash
|
||||
if exists
|
||||
then do
|
||||
currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
|
||||
case currentTagsQuery of
|
||||
[Only tagsText] -> do
|
||||
let tagsList = parseNameList tagsText
|
||||
newTagsList = tagValue : tagsList
|
||||
newTags = serializeNameList newTagsList
|
||||
execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash)
|
||||
_ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)"
|
||||
else
|
||||
putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist"
|
||||
|
||||
termExists :: Connection -> Text -> IO Bool
|
||||
termExists conn hash = do
|
||||
results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]]
|
||||
return $ not (null results)
|
||||
|
||||
termToTags :: Connection -> Text -> IO [Text]
|
||||
termToTags conn hash = do
|
||||
tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
|
||||
case tagsQuery of
|
||||
[Only tagsText] -> return $ parseNameList tagsText
|
||||
_ -> return []
|
||||
|
||||
tagToTerm :: Connection -> Text -> IO [StoredTerm]
|
||||
tagToTerm conn tagValue = do
|
||||
let pattern = "%" <> tagValue <> "%"
|
||||
query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern)
|
||||
|
||||
allTermTags :: Connection -> IO [StoredTerm]
|
||||
allTermTags conn = do
|
||||
query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC")
|
||||
|
||||
selectStoredTermFields :: Query
|
||||
selectStoredTermFields = "SELECT hash, names, metadata, created_at, tags FROM terms"
|
||||
|
||||
queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r)
|
||||
queryMaybeOne conn qry params = do
|
||||
results <- query conn qry params
|
||||
case results of
|
||||
[row] -> return $ Just row
|
||||
_ -> return Nothing
|
||||
|
||||
-- | Resolve a user-supplied identifier (full/prefix hash, term name) to
|
||||
-- a single term hash and the list of names bound to it. Dies on
|
||||
-- ambiguity or missing term (matching the CLI @export@ semantics).
|
||||
resolveExportTarget :: Connection -> String -> IO (Text, [Text])
|
||||
resolveExportTarget conn input = do
|
||||
let raw = T.pack $ dropWhile (== '#') input
|
||||
byName <- query conn
|
||||
"SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
|
||||
(raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
|
||||
case byName of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
(_:_) -> die $ "Ambiguous term name: " ++ input
|
||||
[] -> do
|
||||
byHash <- query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
|
||||
(Only (raw <> T.pack "%")) :: IO [Only T.Text]
|
||||
case byHash of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
[] -> if looksLikeHash raw
|
||||
then return (raw, [])
|
||||
else die $ "No term found matching: " ++ input
|
||||
_ -> die $ "Ambiguous hash prefix: " ++ input
|
||||
|
||||
namesForHash :: Connection -> Text -> IO [Text]
|
||||
namesForHash conn h = do
|
||||
stored <- hashToTerm conn h
|
||||
return $ maybe [] (parseNameList . termNames) stored
|
||||
|
||||
-- | Return 'True' when @t@ looks like a full or partial SHA-256 hex hash.
|
||||
looksLikeHash :: Text -> Bool
|
||||
looksLikeHash t =
|
||||
let len = T.length t
|
||||
in len >= 16 && len <= 64 && T.all isHexDigit t
|
||||
232
src/Eval.hs
232
src/Eval.hs
@@ -1,19 +1,23 @@
|
||||
module Eval where
|
||||
|
||||
import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Data.List (partition, (\\), elemIndex)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Control.Monad (foldM)
|
||||
import Data.List (partition, (\\), elemIndex, foldl')
|
||||
import Data.Map ()
|
||||
import Data.Set (Set)
|
||||
import Database.SQLite.Simple
|
||||
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Foldable as F ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
data DB
|
||||
= BVar Int -- bound (0 = nearest binder)
|
||||
| BFree String -- free/global
|
||||
= BVar Int
|
||||
| BFree String
|
||||
| BLam DB
|
||||
| BApp DB DB
|
||||
| BLeaf
|
||||
@@ -32,51 +36,108 @@ evalSingle env term
|
||||
| SDef name [] body <- term
|
||||
= case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == evalAST env body -> env
|
||||
| otherwise -> errorWithoutStackTrace $
|
||||
"Unable to rebind immutable identifier: " ++ name
|
||||
Nothing ->
|
||||
let res = evalAST env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
| existingValue == evalASTSync env body -> env
|
||||
| otherwise
|
||||
-> let res = evalASTSync env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> let res = evalASTSync env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalAST env func) (evalAST env arg)
|
||||
in Map.insert "!result" res env
|
||||
| SVar name <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
| SVar name Nothing <- term
|
||||
= case Map.lookup name env of
|
||||
Just v -> Map.insert "!result" v env
|
||||
Nothing ->
|
||||
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
|
||||
\This error should never occur here. Please report this as an issue."
|
||||
Just v -> Map.insert "!result" v env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
| SVar name (Just hash) <- term
|
||||
= errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash
|
||||
| otherwise
|
||||
= Map.insert "!result" (evalAST env term) env
|
||||
= let res = evalASTSync env term
|
||||
in Map.insert "!result" res env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env x = go env (reorderDefs env x)
|
||||
where
|
||||
go env [] = env
|
||||
go env [x] =
|
||||
let updatedEnv = evalSingle env x
|
||||
go env' [] = env'
|
||||
go env' [def] =
|
||||
let updatedEnv = evalSingle env' def
|
||||
in Map.insert "!result" (result updatedEnv) updatedEnv
|
||||
go env (x:xs) =
|
||||
evalTricu (evalSingle env x) xs
|
||||
go env' (def:xs) =
|
||||
evalTricu (evalSingle env' def) xs
|
||||
|
||||
evalAST :: Env -> TricuAST -> T
|
||||
evalAST env term
|
||||
| SLambda _ _ <- term = evalAST env (elimLambda term)
|
||||
| SVar name <- term = evalVar name
|
||||
| TLeaf <- term = Leaf
|
||||
| TStem t <- term = Stem (evalAST env t)
|
||||
| TFork t u <- term = Fork (evalAST env t) (evalAST env u)
|
||||
| SApp t u <- term = apply (evalAST env t) (evalAST env u)
|
||||
| SStr s <- term = ofString s
|
||||
| SInt n <- term = ofNumber n
|
||||
| SList xs <- term = ofList (map (evalAST env) xs)
|
||||
| SEmpty <- term = Leaf
|
||||
| otherwise = errorWithoutStackTrace "Unexpected AST term"
|
||||
where
|
||||
evalVar name = Map.findWithDefault
|
||||
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
||||
name env
|
||||
evalASTSync :: Env -> TricuAST -> T
|
||||
evalASTSync env term = case term of
|
||||
SLambda _ _ -> evalASTSync env (elimLambda term)
|
||||
SVar name Nothing -> case Map.lookup name env of
|
||||
Just v -> v
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
SVar name (Just hash) ->
|
||||
case Map.lookup (name ++ "#" ++ hash) env of
|
||||
Just v -> v
|
||||
Nothing -> errorWithoutStackTrace $
|
||||
"Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment"
|
||||
TLeaf -> Leaf
|
||||
TStem t -> Stem (evalASTSync env t)
|
||||
TFork t u -> Fork (evalASTSync env t) (evalASTSync env u)
|
||||
SApp t u -> apply (evalASTSync env t) (evalASTSync env u)
|
||||
SStr s -> ofString s
|
||||
SInt n -> ofNumber n
|
||||
SList xs -> ofList (map (evalASTSync env) xs)
|
||||
SEmpty -> Leaf
|
||||
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
|
||||
|
||||
evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalAST mconn selectedVersions ast = do
|
||||
let varNames = collectVarNames ast
|
||||
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
collectVarNames :: TricuAST -> [(String, Maybe String)]
|
||||
collectVarNames = go []
|
||||
where
|
||||
go acc (SVar name mhash) = (name, mhash) : acc
|
||||
go acc (SApp t u) = go (go acc t) u
|
||||
go acc (SLambda vars body) =
|
||||
let boundVars = Set.fromList vars
|
||||
collected = go [] body
|
||||
in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
|
||||
go acc (TStem t) = go acc t
|
||||
go acc (TFork t u) = go (go acc t) u
|
||||
go acc (SList xs) = foldl' go acc xs
|
||||
go acc _ = acc
|
||||
|
||||
resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
|
||||
resolveTermsFromStore Nothing _ _ = return Map.empty
|
||||
resolveTermsFromStore (Just conn) selectedVersions varNames = do
|
||||
foldM (\env (name, mhash) -> do
|
||||
term <- resolveTermFromStore conn selectedVersions name mhash
|
||||
case term of
|
||||
Just t -> return $ Map.insert (getVarKey name mhash) t env
|
||||
Nothing -> return env
|
||||
) Map.empty varNames
|
||||
where
|
||||
getVarKey name Nothing = name
|
||||
getVarKey name (Just hash) = name ++ "#" ++ hash
|
||||
|
||||
resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
|
||||
resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
Just hashPrefix -> do
|
||||
versions <- termVersions conn name
|
||||
let matchingVersions = filter (\(hash, _, _) ->
|
||||
T.isPrefixOf (T.pack hashPrefix) hash) versions
|
||||
case matchingVersions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return Nothing
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> loadTree conn hash
|
||||
Nothing -> do
|
||||
versions <- termVersions conn name
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
@@ -88,18 +149,16 @@ elimLambda = go
|
||||
| lambdaList term = go (lambdaListResult term)
|
||||
| nestedLambda term = nestedLambdaResult term
|
||||
| application term = applicationResult term
|
||||
| isSList term = slistTransform term
|
||||
| otherwise = term
|
||||
|
||||
-- patterns (now DB-indexed where it matters)
|
||||
etaReduction (SLambda [v] (SApp f (SVar x))) = v == x && not (usesBinder v f)
|
||||
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
|
||||
etaReduction _ = False
|
||||
|
||||
-- triage: \a b c -> TLeaf (TLeaf a b) c (checked in DB with a↦2, b↦1, c↦0)
|
||||
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
|
||||
toDB [c,b,a] body == triageBodyDB
|
||||
triagePattern _ = False
|
||||
|
||||
-- compose: \f g x -> f (g x) (checked in DB with f↦2, g↦1, x↦0)
|
||||
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
|
||||
toDB [x,g,f] body == composeBodyDB
|
||||
composePattern _ = False
|
||||
@@ -113,25 +172,34 @@ elimLambda = go
|
||||
application (SApp _ _) = True
|
||||
application _ = False
|
||||
|
||||
-- rewrites
|
||||
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)"
|
||||
|
||||
-- The key change: use DB bracket abstraction for the final parameter.
|
||||
nestedLambdaResult (SLambda (v:vs) body)
|
||||
| null vs =
|
||||
let body' = go body
|
||||
db = toDB [v] body'
|
||||
in toSKIKiselyov db
|
||||
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 _ _"
|
||||
|
||||
-- combinators and special forms (unchanged)
|
||||
isSList (SList _) = True
|
||||
isSList _ = False
|
||||
|
||||
slistTransform :: TricuAST -> TricuAST
|
||||
slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
|
||||
slistTransform ast = ast -- Should not be reached
|
||||
|
||||
_S, _K, _I, _R, _C, _B, _T, _TRI :: TricuAST
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "t t"
|
||||
_I = parseSingle "t (t (t t)) t"
|
||||
@@ -141,15 +209,24 @@ _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"
|
||||
|
||||
-- pattern bodies (kept for reference; checks are now DB-based)
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
|
||||
composeBody f g x = SApp (SVar f) (SApp (SVar g) (SVar x))
|
||||
triageBody :: String -> String -> String -> TricuAST
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
||||
composeBody :: String -> String -> String -> TricuAST
|
||||
composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
|
||||
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x t = Set.member x (freeVars t)
|
||||
|
||||
-- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
|
||||
freeVars :: TricuAST -> Set String
|
||||
freeVars = freeDBNames . toDB []
|
||||
freeVars (SVar v Nothing) = Set.singleton v
|
||||
freeVars (SVar v (Just _)) = Set.singleton v
|
||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (TStem t) = freeVars t
|
||||
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SList xs) = foldMap freeVars xs
|
||||
freeVars _ = Set.empty
|
||||
|
||||
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||
reorderDefs env defs
|
||||
@@ -200,7 +277,7 @@ buildDepGraph topDefs
|
||||
sortDeps :: Map.Map String (Set.Set String) -> [String]
|
||||
sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||
where
|
||||
go sorted sortedSet [] = sorted
|
||||
go sorted _sortedSet [] = sorted
|
||||
go sorted sortedSet remaining =
|
||||
let ready = [ name | name <- remaining
|
||||
, let deps = Map.findWithDefault Set.empty name graph
|
||||
@@ -231,10 +308,18 @@ mainResult r = case Map.lookup "main" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
||||
|
||||
findVarNames :: TricuAST -> [String]
|
||||
findVarNames ast = case ast of
|
||||
SVar name _ -> [name]
|
||||
SApp a b -> findVarNames a ++ findVarNames b
|
||||
SLambda args body -> findVarNames body \\ args
|
||||
SDef name args body -> name : (findVarNames body \\ args)
|
||||
_ -> []
|
||||
|
||||
-- Convert named TricuAST to De Bruijn form
|
||||
toDB :: [String] -> TricuAST -> DB
|
||||
toDB env = \case
|
||||
SVar v -> maybe (BFree v) BVar (elemIndex v env)
|
||||
SVar v _ -> maybe (BFree v) BVar (elemIndex v env)
|
||||
SLambda vs b ->
|
||||
let env' = reverse vs ++ env
|
||||
body = toDB env' b
|
||||
@@ -276,7 +361,7 @@ freeDBNames = \case
|
||||
BList xs -> foldMap freeDBNames xs
|
||||
BEmpty -> mempty
|
||||
|
||||
-- Helper: “is the binder named v used in body?”
|
||||
-- Helper: "is the binder named v used in body?"
|
||||
usesBinder :: String -> TricuAST -> Bool
|
||||
usesBinder v body = dependsOnLevel 0 (toDB [v] body)
|
||||
|
||||
@@ -292,7 +377,7 @@ composeBodyDB =
|
||||
-- Convert DB -> TricuAST for subterms that contain NO binders (no BLam, no BVar)
|
||||
fromDBClosed :: DB -> TricuAST
|
||||
fromDBClosed = \case
|
||||
BFree s -> SVar s
|
||||
BFree s -> SVar s Nothing
|
||||
BApp f a -> SApp (fromDBClosed f) (fromDBClosed a)
|
||||
BLeaf -> TLeaf
|
||||
BStem t -> TStem (fromDBClosed t)
|
||||
@@ -312,13 +397,10 @@ 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 =
|
||||
errorWithoutStackTrace $ "Unhandled toSKI(DB) conversion: " ++ show other
|
||||
toSKIDB (BStem t) = toSKIDB (BApp BLeaf t)
|
||||
toSKIDB (BFork l r) = toSKIDB (BApp (BApp BLeaf l) r)
|
||||
toSKIDB (BList xs) = toSKIDB (foldr (\m r -> BApp (BApp BLeaf m) r) BLeaf xs)
|
||||
toSKIDB other = error $ "toSKIDB: unsupported DB term: " ++ show other
|
||||
|
||||
app2 :: TricuAST -> TricuAST -> TricuAST
|
||||
app2 f x = SApp f x
|
||||
@@ -336,11 +418,13 @@ kisConv = \case
|
||||
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
|
||||
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)
|
||||
@@ -358,12 +442,11 @@ kisConv = \case
|
||||
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.
|
||||
-- We shouldn't see BLam under elim; treat as unsupported so we fallback.
|
||||
BLam _ -> Left "Nested lambda under body: fallback"
|
||||
BFree s -> Right ([], SVar s)
|
||||
|
||||
-- Application combiner with K-optimization (lazy weakening).
|
||||
-- Mirrors Lynn’s 'optK' rules: choose among S, B, C, R based on leading flags.
|
||||
-- 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) =
|
||||
@@ -381,7 +464,7 @@ kisHash (g1, d1) (g2, d2) =
|
||||
else kisHash ([], SApp _R d2) (gs1, d1)
|
||||
_ ->
|
||||
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
|
||||
then kisHash ([], _T) (tail g2, d2)
|
||||
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
|
||||
@@ -404,7 +487,7 @@ kisHash (g1, d1) (g2, d2) =
|
||||
[] -> kisHash (gs1, d1) ([], d2)
|
||||
_ ->
|
||||
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
|
||||
then kisHash ([], _T) (tail g2, d2)
|
||||
then kisHash ([], _T) (drop1 g2, d2)
|
||||
else case g2 of
|
||||
True:gs2 ->
|
||||
let d1' = kisHash ([], _B) (gs1, d1)
|
||||
@@ -412,8 +495,8 @@ kisHash (g1, d1) (g2, d2) =
|
||||
False:gs2 ->
|
||||
kisHash (gs1, d1) (gs2, d2)
|
||||
where
|
||||
tail (_:xs) = xs
|
||||
tail [] = []
|
||||
drop1 (_:xs) = xs
|
||||
drop1 [] = []
|
||||
|
||||
|
||||
toSKIKiselyov :: DB -> TricuAST
|
||||
@@ -484,7 +567,6 @@ bulkS :: Int -> TricuAST
|
||||
bulkS n | n <= 1 = _S
|
||||
| otherwise = SApp sPrime (bulkS (n - 1))
|
||||
|
||||
-- Count how many leading pairs (a,b) repeat at the head of zip g1 g2
|
||||
headPairRun :: [Bool] -> [Bool] -> ((Bool, Bool), Int)
|
||||
headPairRun g1 g2 =
|
||||
case zip g1 g2 of
|
||||
|
||||
100
src/FileEval.hs
100
src/FileEval.hs
@@ -1,28 +1,40 @@
|
||||
module FileEval where
|
||||
module FileEval
|
||||
( preprocessFile
|
||||
, evaluateFile
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileResult
|
||||
, compileFile
|
||||
) where
|
||||
|
||||
import Eval
|
||||
import Eval (evalTricu)
|
||||
import Lexer
|
||||
import Parser
|
||||
import Research
|
||||
import ContentStore (initContentStore, storeTerm, hashTerm)
|
||||
import Wire (exportNamedBundle, defaultExportNames)
|
||||
|
||||
import Control.Monad (forM_)
|
||||
import Data.List (partition)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Control.Monad (foldM)
|
||||
import System.IO
|
||||
import System.Environment (setEnv)
|
||||
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.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
extractMain :: Env -> Either String T
|
||||
extractMain env =
|
||||
case Map.lookup "main" env of
|
||||
Just result -> Right result
|
||||
Just evalResult -> Right evalResult
|
||||
Nothing -> Left "No `main` function detected"
|
||||
|
||||
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
|
||||
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
|
||||
processImports seen base currentPath asts =
|
||||
processImports seen _base currentPath asts =
|
||||
let (imports, nonImports) = partition isImp asts
|
||||
importPaths = mapMaybe getImportInfo imports
|
||||
in if currentPath `Set.member` seen
|
||||
@@ -40,11 +52,11 @@ evaluateFileResult filePath = do
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Right _ast -> do
|
||||
processedAst <- preprocessFile filePath
|
||||
let finalEnv = evalTricu Map.empty processedAst
|
||||
case extractMain finalEnv of
|
||||
Right result -> return result
|
||||
Right evalResult -> return evalResult
|
||||
Left err -> errorWithoutStackTrace err
|
||||
|
||||
evaluateFile :: FilePath -> IO Env
|
||||
@@ -53,7 +65,7 @@ evaluateFile filePath = do
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu Map.empty ast
|
||||
|
||||
@@ -63,7 +75,7 @@ evaluateFileWithContext env filePath = do
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu env ast
|
||||
|
||||
@@ -84,8 +96,8 @@ preprocessFile' seen base currentPath = do
|
||||
imported <- concat <$> mapM (processImportPath seen' base) importPaths
|
||||
pure $ imported ++ nonImports
|
||||
where
|
||||
processImportPath seen base (path, name, importPath) = do
|
||||
ast <- preprocessFile' seen base importPath
|
||||
processImportPath _seen _base (_path, name, importPath) = do
|
||||
ast <- preprocessFile' _seen _base importPath
|
||||
pure $ map (nsDefinition (if name == "!Local" then "" else name))
|
||||
$ filter (not . isImp) ast
|
||||
isImp (SImport _ _) = True
|
||||
@@ -96,9 +108,6 @@ makeRelativeTo f i =
|
||||
let d = takeDirectory f
|
||||
in normalise $ d </> i
|
||||
|
||||
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
|
||||
nsDefinitions moduleName = map (nsDefinition moduleName)
|
||||
|
||||
nsDefinition :: String -> TricuAST -> TricuAST
|
||||
nsDefinition "" def = def
|
||||
nsDefinition moduleName (SDef name args body)
|
||||
@@ -109,9 +118,9 @@ nsDefinition moduleName other =
|
||||
nsBody moduleName other
|
||||
|
||||
nsBody :: String -> TricuAST -> TricuAST
|
||||
nsBody moduleName (SVar name)
|
||||
| isPrefixed name = SVar name
|
||||
| otherwise = SVar (nsVariable moduleName name)
|
||||
nsBody moduleName (SVar name mhash)
|
||||
| isPrefixed name = SVar name mhash
|
||||
| otherwise = SVar (nsVariable moduleName name) mhash
|
||||
nsBody moduleName (SApp func arg) =
|
||||
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
||||
nsBody moduleName (SLambda args body) =
|
||||
@@ -122,18 +131,16 @@ nsBody moduleName (TFork left right) =
|
||||
TFork (nsBody moduleName left) (nsBody moduleName right)
|
||||
nsBody moduleName (TStem subtree) =
|
||||
TStem (nsBody moduleName subtree)
|
||||
nsBody moduleName (SDef name args body)
|
||||
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||
| otherwise = SDef (nsVariable moduleName name)
|
||||
args (nsBody moduleName body)
|
||||
nsBody moduleName (SDef name args body) =
|
||||
SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body)
|
||||
nsBody _ other = other
|
||||
|
||||
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||
nsBodyScoped moduleName args body = case body of
|
||||
SVar name ->
|
||||
SVar name mhash ->
|
||||
if name `elem` args
|
||||
then SVar name
|
||||
else nsBody moduleName (SVar name)
|
||||
then SVar name mhash
|
||||
else nsBody moduleName (SVar name mhash)
|
||||
SApp func arg ->
|
||||
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
||||
SLambda innerArgs innerBody ->
|
||||
@@ -141,13 +148,11 @@ nsBodyScoped moduleName args body = case body of
|
||||
SList items ->
|
||||
SList (map (nsBodyScoped moduleName args) items)
|
||||
TFork left right ->
|
||||
TFork (nsBodyScoped moduleName args left)
|
||||
(nsBodyScoped moduleName args right)
|
||||
TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
|
||||
TStem subtree ->
|
||||
TStem (nsBodyScoped moduleName args subtree)
|
||||
SDef name innerArgs innerBody ->
|
||||
SDef (nsVariable moduleName name) innerArgs
|
||||
(nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||
SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||
other -> other
|
||||
|
||||
isPrefixed :: String -> Bool
|
||||
@@ -156,3 +161,40 @@ isPrefixed name = '.' `elem` name
|
||||
nsVariable :: String -> String -> String
|
||||
nsVariable "" name = name
|
||||
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||
|
||||
-- | Compile a tricu source file to a standalone Arboricx 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)
|
||||
|
||||
40
src/Lexer.hs
40
src/Lexer.hs
@@ -4,13 +4,12 @@ import Research
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.Functor (($>))
|
||||
import Data.Set ()
|
||||
import Data.Void
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char hiding (space)
|
||||
import Text.Megaparsec.Char.Lexer
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
type Lexer = Parsec Void String
|
||||
|
||||
tricuLexer :: Lexer [LToken]
|
||||
@@ -23,18 +22,19 @@ tricuLexer = do
|
||||
]
|
||||
sc
|
||||
pure tok
|
||||
tokens <- many $ do
|
||||
toks <- many $ do
|
||||
tok <- choice tricuLexer'
|
||||
sc
|
||||
pure tok
|
||||
sc
|
||||
eof
|
||||
pure (header ++ tokens)
|
||||
pure (header ++ toks)
|
||||
where
|
||||
tricuLexer' =
|
||||
[ try lnewline
|
||||
, try namespace
|
||||
, try dot
|
||||
, try identifierWithHash
|
||||
, try identifier
|
||||
, try keywordT
|
||||
, try integerLiteral
|
||||
@@ -50,18 +50,41 @@ tricuLexer = do
|
||||
lexTricu :: String -> [LToken]
|
||||
lexTricu input = case runParser tricuLexer "" input of
|
||||
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
||||
Right tokens -> tokens
|
||||
Right toks -> toks
|
||||
|
||||
|
||||
keywordT :: Lexer LToken
|
||||
keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
|
||||
|
||||
identifierWithHash :: Lexer LToken
|
||||
identifierWithHash = do
|
||||
first <- lowerChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '\''
|
||||
_ <- char '#' -- Consume '#'
|
||||
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
|
||||
<?> "hash characters (alphanumeric or hyphen)"
|
||||
|
||||
let name = first : rest
|
||||
let hashLen = length hashString
|
||||
if name == "t" || name == "!result"
|
||||
then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix."
|
||||
else if hashLen < 16 then
|
||||
fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
|
||||
else if hashLen > 64 then -- Assuming SHA256, max 64
|
||||
fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
|
||||
else
|
||||
return (LIdentifierWithHash name hashString)
|
||||
|
||||
identifier :: Lexer LToken
|
||||
identifier = do
|
||||
first <- lowerChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '\''
|
||||
let name = first : rest
|
||||
if name == "t" || name == "!result"
|
||||
then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
|
||||
@@ -121,8 +144,8 @@ integerLiteral = do
|
||||
|
||||
stringLiteral :: Lexer LToken
|
||||
stringLiteral = do
|
||||
char '"'
|
||||
content <- manyTill Lexer.charLiteral (char '"')
|
||||
void (char '"')
|
||||
content <- manyTill Lexer.charLiteral (void (char '"'))
|
||||
return (LStringLiteral content)
|
||||
|
||||
charLiteral :: Lexer Char
|
||||
@@ -141,3 +164,4 @@ charLiteral = escapedChar <|> normalChar
|
||||
'\\' -> '\\'
|
||||
'"' -> '"'
|
||||
'\'' -> '\''
|
||||
_ -> c
|
||||
|
||||
188
src/Main.hs
188
src/Main.hs
@@ -1,24 +1,39 @@
|
||||
module Main where
|
||||
|
||||
import ContentStore (initContentStore, loadEnvironment, loadTerm, resolveExportTarget)
|
||||
import System.Exit (die)
|
||||
import Server (runServer)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
import Parser (parseTricu)
|
||||
import REPL
|
||||
import Research
|
||||
import Wire
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Text (Text, unpack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Version (showVersion)
|
||||
import Text.Megaparsec (runParser)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.CmdArgs
|
||||
import System.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
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm, outFile :: 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 }
|
||||
| ExportDag { target :: String, outFile :: FilePath }
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
replMode :: TricuArgs
|
||||
@@ -36,6 +51,8 @@ evaluateMode = Evaluate
|
||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
|
||||
\ Defaults to tricu-compatible `t` tree form."
|
||||
&= name "t"
|
||||
, outFile = def &= help "Optional output file path. Defaults to stdout."
|
||||
&= name "o" &= typ "FILE"
|
||||
}
|
||||
&= help "Evaluate tricu and return the result of the final expression."
|
||||
&= explicit
|
||||
@@ -52,36 +69,153 @@ decodeMode = TDecode
|
||||
&= explicit
|
||||
&= 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 Arboricx 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 Arboricx bundles."
|
||||
&= explicit
|
||||
&= name "server"
|
||||
|
||||
exportDagMode :: TricuArgs
|
||||
exportDagMode = ExportDag
|
||||
{ target = def &= help "Stored term name or hash to export as a DAG node table."
|
||||
&= name "t" &= typ "NAME_OR_HASH"
|
||||
, outFile = def &= help "Optional output file path. Defaults to stdout."
|
||||
&= name "o" &= typ "FILE"
|
||||
}
|
||||
&= help "Export a term's Merkle DAG as a topologically-sorted node table for host embedding."
|
||||
&= explicit
|
||||
&= name "export-dag"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
||||
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
||||
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode, exportDagMode]
|
||||
&= help "tricu: Exploring Tree Calculus"
|
||||
&= program "tricu"
|
||||
&= summary versionStr
|
||||
&= versionArg [explicit, name "version", summary versionStr]
|
||||
case args of
|
||||
case cmdArgsParsed of
|
||||
Repl -> do
|
||||
putStrLn "Welcome to the tricu REPL"
|
||||
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||
putStrLn "Try typing `!` with tab completion for more commands."
|
||||
repl Map.empty
|
||||
Evaluate { file = filePaths, form = form } -> do
|
||||
result <- case filePaths of
|
||||
[] -> runTricuT <$> getContents
|
||||
(filePath:restFilePaths) -> do
|
||||
initialEnv <- evaluateFile filePath
|
||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||
repl
|
||||
Evaluate { file = filePaths, form = outputForm, outFile = evalOutFile } -> do
|
||||
maybeDbPath <- lookupEnv "TRICU_DB_PATH"
|
||||
evalResult <- case filePaths of
|
||||
[] -> do
|
||||
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
|
||||
filePaths@(_:_) -> do
|
||||
initialEnv <- case maybeDbPath of
|
||||
Just _ -> do
|
||||
conn <- initContentStore
|
||||
env <- loadEnvironment conn
|
||||
close conn
|
||||
return env
|
||||
Nothing -> return Map.empty
|
||||
finalEnv <- foldM evaluateFileWithContext initialEnv filePaths
|
||||
pure $ mainResult finalEnv
|
||||
let fRes = formatT form result
|
||||
putStr fRes
|
||||
let fRes = formatT outputForm evalResult
|
||||
if null evalOutFile
|
||||
then putStr fRes
|
||||
else writeFile evalOutFile fRes
|
||||
TDecode { file = filePaths } -> do
|
||||
value <- case filePaths of
|
||||
[] -> getContents
|
||||
(filePath:_) -> readFile filePath
|
||||
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
||||
|
||||
-- Simple interfaces
|
||||
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 Arboricx 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.arboricx.bundle"
|
||||
runServer hostStr portNum
|
||||
ExportDag { target = targetName, outFile = dagOutFile } -> do
|
||||
conn <- initContentStore
|
||||
maybeTerm <- loadTerm conn targetName
|
||||
close conn
|
||||
case maybeTerm of
|
||||
Nothing -> die $ "Term not found: " ++ targetName
|
||||
Just term -> do
|
||||
let (rootIdx, nodes) = exportDag term
|
||||
output = unlines $ show rootIdx : map (\(tag, refs) -> unwords (tag : map show refs)) nodes
|
||||
if null dagOutFile
|
||||
then putStr output
|
||||
else writeFile dagOutFile output
|
||||
|
||||
runTricu :: String -> String
|
||||
runTricu = formatT TreeCalculus . runTricuT
|
||||
@@ -125,4 +259,22 @@ runTricuEnvWithEnv env input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu env asts
|
||||
res = result finalEnv
|
||||
in (finalEnv, formatT TreeCalculus res)
|
||||
in (finalEnv, formatT TreeCalculus res)
|
||||
|
||||
chooseExportName :: String -> String -> [Text] -> IO Text
|
||||
chooseExportName explicitName input storedNames
|
||||
| not (null explicitName) = return $ T.pack explicitName
|
||||
| Just firstName <- firstNonEmpty storedNames = return firstName
|
||||
| otherwise = do
|
||||
hPutStrLn stderr $
|
||||
"No stored name found for export target " ++ input ++ "; using export name 'root'. "
|
||||
++ "Use export -n NAME to preserve a semantic name."
|
||||
return "root"
|
||||
|
||||
firstNonEmpty :: [Text] -> Maybe Text
|
||||
firstNonEmpty = go
|
||||
where
|
||||
go [] = Nothing
|
||||
go (x:xs)
|
||||
| T.null x = go xs
|
||||
| otherwise = Just x
|
||||
|
||||
@@ -8,7 +8,7 @@ import Control.Monad.State
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
data PState = PState
|
||||
@@ -20,9 +20,9 @@ type ParserM = StateT PState (Parsec Void [LToken])
|
||||
|
||||
satisfyM :: (LToken -> Bool) -> ParserM LToken
|
||||
satisfyM f = do
|
||||
token <- lift (satisfy f)
|
||||
modify' (updateDepth token)
|
||||
return token
|
||||
tok <- lift (satisfy f)
|
||||
modify' (updateDepth tok)
|
||||
return tok
|
||||
|
||||
updateDepth :: LToken -> PState -> PState
|
||||
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
|
||||
@@ -39,12 +39,12 @@ topLevelNewline = do
|
||||
else fail "Top-level exit in nested context (paren or bracket)"
|
||||
|
||||
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
|
||||
parseProgram tokens =
|
||||
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
|
||||
parseProgram toks =
|
||||
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks
|
||||
|
||||
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
||||
parseSingleExpr tokens =
|
||||
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
|
||||
parseSingleExpr toks =
|
||||
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks
|
||||
|
||||
finalizeDepth :: ParserM ()
|
||||
finalizeDepth = do
|
||||
@@ -195,6 +195,7 @@ parseTreeTermM = do
|
||||
| TLeaf <- acc = TStem next
|
||||
| TStem t <- acc = TFork t next
|
||||
| TFork _ _ <- acc = TFork acc next
|
||||
| otherwise = SApp acc next
|
||||
|
||||
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
|
||||
parseTreeLeafOrParenthesizedM = choice
|
||||
@@ -248,42 +249,51 @@ parseGroupedItemM = do
|
||||
|
||||
parseSingleItemM :: ParserM TricuAST
|
||||
parseSingleItemM = do
|
||||
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||
if | LIdentifier name <- token -> pure (SVar name)
|
||||
| token == LKeywordT -> pure TLeaf
|
||||
tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||
if | LIdentifier name <- tok -> pure (SVar name Nothing)
|
||||
| tok == LKeywordT -> pure TLeaf
|
||||
| otherwise -> fail "Unexpected token in list item"
|
||||
|
||||
parseVarM :: ParserM TricuAST
|
||||
parseVarM = do
|
||||
token <- satisfyM (\case
|
||||
tok <- satisfyM (\case
|
||||
LNamespace _ -> True
|
||||
LIdentifier _ -> True
|
||||
LIdentifierWithHash _ _ -> True
|
||||
_ -> False)
|
||||
case token of
|
||||
|
||||
case tok of
|
||||
LNamespace ns -> do
|
||||
_ <- satisfyM (== LDot)
|
||||
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
|
||||
pure $ SVar (ns ++ "." ++ name)
|
||||
pure $ SVar (ns ++ "." ++ name) Nothing
|
||||
|
||||
LIdentifier name
|
||||
| name == "t" || name == "!result" ->
|
||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
| otherwise -> pure (SVar name)
|
||||
| otherwise -> pure (SVar name Nothing)
|
||||
|
||||
LIdentifierWithHash name hash ->
|
||||
if name == "t" || name == "!result"
|
||||
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
else pure (SVar name (Just hash))
|
||||
|
||||
_ -> fail "Unexpected token while parsing variable"
|
||||
|
||||
parseIntLiteralM :: ParserM TricuAST
|
||||
parseIntLiteralM = do
|
||||
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM intL
|
||||
if | LIntegerLiteral value <- token ->
|
||||
pure (SInt value)
|
||||
tok <- satisfyM intL
|
||||
if | LIntegerLiteral value <- tok ->
|
||||
pure (SInt (fromIntegral value))
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing integer literal"
|
||||
|
||||
parseStrLiteralM :: ParserM TricuAST
|
||||
parseStrLiteralM = do
|
||||
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM strL
|
||||
if | LStringLiteral value <- token ->
|
||||
tok <- satisfyM strL
|
||||
if | LStringLiteral value <- tok ->
|
||||
pure (SStr value)
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing string literal"
|
||||
@@ -299,8 +309,8 @@ handleParseError bundle =
|
||||
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
||||
|
||||
formatError :: ParseError [LToken] Void -> String
|
||||
formatError (TrivialError offset unexpected expected) =
|
||||
let unexpectedMsg = case unexpected of
|
||||
formatError (TrivialError offset msgUnexpected expected) =
|
||||
let unexpectedMsg = case msgUnexpected of
|
||||
Just x -> "unexpected token " ++ show x
|
||||
Nothing -> "unexpected end of input"
|
||||
expectedMsg = if null expected
|
||||
|
||||
710
src/REPL.hs
710
src/REPL.hs
@@ -1,30 +1,57 @@
|
||||
module REPL where
|
||||
|
||||
import ContentStore
|
||||
import Eval
|
||||
import FileEval
|
||||
import Lexer
|
||||
import Lexer ()
|
||||
import Parser
|
||||
import Research
|
||||
import Wire
|
||||
|
||||
import Control.Exception (IOException, SomeException, catch
|
||||
, displayException)
|
||||
import Control.Monad (forM_)
|
||||
import Control.Monad.Catch (handle, MonadCatch)
|
||||
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
||||
import Control.Exception (SomeException, catch, displayException)
|
||||
import Control.Monad ()
|
||||
import Control.Monad (forever, when, forM_, foldM, unless)
|
||||
import Control.Monad.Catch (handle)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Class ()
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.Char (isSpace, isUpper)
|
||||
import Data.List (dropWhile, dropWhileEnd, isPrefixOf)
|
||||
import 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.FSNotify
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.IO as T ()
|
||||
|
||||
repl :: Env -> IO ()
|
||||
repl env = runInputT settings (withInterrupt (loop env Decode))
|
||||
data REPLState = REPLState
|
||||
{ replForm :: EvaluatedForm
|
||||
, replContentStore :: Maybe Connection
|
||||
, replWatchedFile :: Maybe FilePath
|
||||
, replSelectedVersions :: Map.Map String T.Text
|
||||
, replWatcherThread :: Maybe ThreadId
|
||||
}
|
||||
|
||||
repl :: IO ()
|
||||
repl = do
|
||||
conn <- ContentStore.initContentStore
|
||||
runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
|
||||
where
|
||||
settings :: Settings IO
|
||||
settings = Settings
|
||||
@@ -39,152 +66,603 @@ repl env = runInputT settings (withInterrupt (loop env Decode))
|
||||
where
|
||||
commands = [ "!exit"
|
||||
, "!output"
|
||||
, "!definitions"
|
||||
, "!import"
|
||||
, "!clear"
|
||||
, "!save"
|
||||
, "!reset"
|
||||
, "!version"
|
||||
, "!help"
|
||||
, "!definitions"
|
||||
, "!watch"
|
||||
, "!refresh"
|
||||
, "!versions"
|
||||
, "!select"
|
||||
, "!tag"
|
||||
, "!export"
|
||||
, "!bundleimport"
|
||||
]
|
||||
|
||||
loop :: Env -> EvaluatedForm -> InputT IO ()
|
||||
loop env form = handle (interruptHandler env form) $ do
|
||||
loop :: REPLState -> InputT IO ()
|
||||
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
|
||||
minput <- getInputLine "tricu < "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Exiting tricu"
|
||||
Nothing -> return ()
|
||||
Just s
|
||||
| strip s == "" -> loop env form
|
||||
| strip s == "" -> loop state
|
||||
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
||||
| strip s == "!clear" -> do
|
||||
liftIO $ putStr "\ESC[2J\ESC[H"
|
||||
loop env form
|
||||
loop state
|
||||
| strip s == "!reset" -> do
|
||||
outputStrLn "Environment reset to initial state"
|
||||
loop Map.empty form
|
||||
| strip s == "!version" -> do
|
||||
outputStrLn "Selected versions reset"
|
||||
loop state { replSelectedVersions = Map.empty }
|
||||
| strip s == "!help" -> do
|
||||
outputStrLn $ "tricu version " ++ showVersion version
|
||||
loop env form
|
||||
| "!save" `isPrefixOf` strip s -> handleSave env form
|
||||
| strip s == "!output" -> handleOutput env form
|
||||
| strip s == "!definitions" -> do
|
||||
let defs = Map.keys $ Map.delete "!result" env
|
||||
if null defs
|
||||
then outputStrLn "No definitions discovered."
|
||||
else do
|
||||
outputStrLn "Available definitions:"
|
||||
mapM_ outputStrLn defs
|
||||
loop env form
|
||||
| "!import" `isPrefixOf` strip s -> handleImport env form
|
||||
| take 2 s == "--" -> loop env form
|
||||
outputStrLn "Available commands:"
|
||||
outputStrLn " !exit - Exit the REPL"
|
||||
outputStrLn " !clear - Clear the screen"
|
||||
outputStrLn " !reset - Reset preferences for selected versions"
|
||||
outputStrLn " !help - Show tricu version and available commands"
|
||||
outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
|
||||
outputStrLn " !definitions - List all defined terms in the content store"
|
||||
outputStrLn " !import - Import definitions from file to the content store"
|
||||
outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them"
|
||||
outputStrLn " !versions - Show all versions of a term by name"
|
||||
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
|
||||
outputStrLn " !tag - Add or update a tag for a term by hash or name"
|
||||
outputStrLn " !export - Export a term bundle to file (hash, file)"
|
||||
outputStrLn " !bundleimport- Import a bundle file into the content store"
|
||||
loop state
|
||||
| strip s == "!output" -> handleOutput state
|
||||
| strip s == "!definitions" -> handleDefinitions state
|
||||
| "!import" `isPrefixOf` strip s -> handleImport state
|
||||
| "!watch" `isPrefixOf` strip s -> handleWatch state
|
||||
| strip s == "!refresh" -> handleRefresh state
|
||||
| "!versions" `isPrefixOf` strip s -> handleVersions state
|
||||
| "!select" `isPrefixOf` strip s -> handleSelect state
|
||||
| "!tag" `isPrefixOf` strip s -> handleTag state
|
||||
| "!export" `isPrefixOf` strip s -> handleExport state
|
||||
| "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
|
||||
| take 2 s == "--" -> loop state
|
||||
| otherwise -> do
|
||||
newEnv <- liftIO $ processInput env s form `catch` errorHandler env
|
||||
loop newEnv form
|
||||
evalResult <- liftIO $ catch
|
||||
(processInput state s)
|
||||
(errorHandler state)
|
||||
loop evalResult
|
||||
|
||||
handleOutput :: Env -> EvaluatedForm -> InputT IO ()
|
||||
handleOutput env currentForm = do
|
||||
handleOutput :: REPLState -> InputT IO ()
|
||||
handleOutput state = do
|
||||
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
|
||||
outputStrLn "Available output formats:"
|
||||
mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f)
|
||||
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
||||
(zip [1..] formats)
|
||||
|
||||
result <- runMaybeT $ do
|
||||
evalResult <- runMaybeT $ do
|
||||
input <- MaybeT $ getInputLine "Select output format (1-6) < "
|
||||
case reads input of
|
||||
[(n, "")] | n >= 1 && n <= 6 ->
|
||||
return $ formats !! (n-1)
|
||||
_ -> MaybeT $ return Nothing
|
||||
|
||||
case result of
|
||||
case evalResult of
|
||||
Nothing -> do
|
||||
outputStrLn "Invalid selection. Keeping current output format."
|
||||
loop env currentForm
|
||||
loop state
|
||||
Just newForm -> do
|
||||
outputStrLn $ "Output format changed to: " ++ show newForm
|
||||
loop env newForm
|
||||
loop state { replForm = newForm }
|
||||
|
||||
handleImport :: Env -> EvaluatedForm -> InputT IO ()
|
||||
handleImport env form = do
|
||||
res <- runMaybeT $ do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
path <- MaybeT $ runInputT fset $
|
||||
getInputLineWithInitial "File path to load < " ("", "")
|
||||
handleDefinitions :: REPLState -> InputT IO ()
|
||||
handleDefinitions state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
terms <- liftIO $ ContentStore.listStoredTerms conn
|
||||
|
||||
if null terms
|
||||
then do
|
||||
liftIO $ printWarning "No terms in content store."
|
||||
loop state
|
||||
else do
|
||||
liftIO $ do
|
||||
printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:"
|
||||
|
||||
text <- MaybeT $ liftIO $ handle (\e -> do
|
||||
putStrLn $ "Error reading file: " ++ displayException (e :: IOException)
|
||||
return Nothing
|
||||
) $ Just <$> readFile (strip path)
|
||||
let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
|
||||
|
||||
case parseProgram (lexTricu text) of
|
||||
Left err -> do
|
||||
lift $ outputStrLn $ "Parse error: " ++ handleParseError err
|
||||
MaybeT $ return Nothing
|
||||
Right ast -> do
|
||||
ns <- MaybeT $ runInputT defaultSettings $
|
||||
getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "")
|
||||
forM_ terms $ \term -> do
|
||||
let namesStr = T.unpack (termNames term)
|
||||
hash = termHash term
|
||||
padding = replicate (maxNameWidth - length namesStr) ' '
|
||||
|
||||
liftIO $ do
|
||||
putStr " "
|
||||
printVariable namesStr
|
||||
putStr padding
|
||||
putStr " [hash: "
|
||||
displayColoredHash hash
|
||||
putStrLn "]"
|
||||
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
unless (null tags) $ displayTags tags
|
||||
|
||||
let name = strip ns
|
||||
if (name /= "!Local" && (null name || not (isUpper (head name)))) then do
|
||||
lift $ outputStrLn "Namespace must start with an uppercase letter"
|
||||
MaybeT $ return Nothing
|
||||
else do
|
||||
prog <- liftIO $ preprocessFile (strip path)
|
||||
let code = case name of
|
||||
"!Local" -> prog
|
||||
_ -> nsDefinitions name prog
|
||||
env' = evalTricu env code
|
||||
return env'
|
||||
case res of
|
||||
loop state
|
||||
|
||||
handleImport :: REPLState -> InputT IO ()
|
||||
handleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "")
|
||||
case filename of
|
||||
Nothing -> loop state
|
||||
Just f -> do
|
||||
let cleanFilename = strip f
|
||||
exists <- liftIO $ doesFileExist cleanFilename
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ cleanFilename
|
||||
loop state
|
||||
else importFile state cleanFilename
|
||||
|
||||
importFile :: REPLState -> String -> InputT IO ()
|
||||
importFile state cleanFilename = do
|
||||
_code <- liftIO $ readFile cleanFilename
|
||||
case replContentStore state of
|
||||
Nothing -> do
|
||||
outputStrLn "Import cancelled"
|
||||
loop env form
|
||||
Just env' ->
|
||||
loop (Map.delete "!result" env') form
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
env <- liftIO $ evaluateFile cleanFilename
|
||||
|
||||
liftIO $ do
|
||||
printSuccess $ "Importing file: " ++ cleanFilename
|
||||
let defs = Map.toList $ Map.delete "!result" env
|
||||
|
||||
importedCount <- foldM (\count (name, term) -> do
|
||||
hash <- ContentStore.storeTerm conn [name] term
|
||||
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
return (count + (1 :: Int))
|
||||
) 0 defs
|
||||
|
||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||
|
||||
loop state
|
||||
|
||||
interruptHandler :: Env -> EvaluatedForm -> Interrupt -> InputT IO ()
|
||||
interruptHandler env form _ = do
|
||||
outputStrLn "Interrupted with CTRL+C\n\
|
||||
\You can use the !exit command or CTRL+D to exit"
|
||||
loop env form
|
||||
handleWatch :: REPLState -> InputT IO ()
|
||||
handleWatch state = do
|
||||
dbPath <- liftIO ContentStore.getContentStorePath
|
||||
let filepath = takeDirectory dbPath </> "scratch.tri"
|
||||
let dirPath = takeDirectory filepath
|
||||
|
||||
processInput :: Env -> String -> EvaluatedForm -> IO Env
|
||||
processInput env input form = do
|
||||
let asts = parseTricu input
|
||||
newEnv = evalTricu env asts
|
||||
case Map.lookup "!result" newEnv of
|
||||
Just r -> do
|
||||
putStrLn $ "tricu > " ++ formatT form r
|
||||
Nothing -> pure ()
|
||||
return newEnv
|
||||
liftIO $ createDirectoryIfMissing True dirPath
|
||||
|
||||
errorHandler :: Env -> SomeException -> IO (Env)
|
||||
errorHandler env e = do
|
||||
putStrLn $ "Error: " ++ show e
|
||||
return env
|
||||
fileExists <- liftIO $ doesFileExist filepath
|
||||
unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n"
|
||||
|
||||
outputStrLn $ "Using scratch file: " ++ filepath
|
||||
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
outputStrLn "Stopping previous file watch"
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
|
||||
outputStrLn $ "Starting to watch file: " ++ filepath
|
||||
outputStrLn "Press Ctrl+C to stop watching and return to REPL"
|
||||
|
||||
liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
||||
|
||||
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
||||
|
||||
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
||||
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
|
||||
now <- getCurrentTime
|
||||
lastProcessed <- readIORef lastProcessedRef
|
||||
when (diffUTCTime now lastProcessed > 0.5) $ do
|
||||
putStrLn $ "\nFile changed: " ++ filepath
|
||||
processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
||||
writeIORef lastProcessedRef now
|
||||
forever $ threadDelay 1000000
|
||||
|
||||
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
|
||||
|
||||
_handleUnwatch :: REPLState -> InputT IO ()
|
||||
_handleUnwatch state = case replWatchedFile state of
|
||||
Nothing -> do
|
||||
outputStrLn "No file is currently being watched"
|
||||
loop state
|
||||
Just path -> do
|
||||
outputStrLn $ "Stopped watching " ++ path
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }
|
||||
|
||||
handleRefresh :: REPLState -> InputT IO ()
|
||||
handleRefresh state = case replContentStore state of
|
||||
Nothing -> do
|
||||
outputStrLn "Content store not initialized"
|
||||
loop state
|
||||
Just _conn -> do
|
||||
outputStrLn "Environment refreshed from content store (definitions are live)"
|
||||
loop state
|
||||
|
||||
handleVersions :: REPLState -> InputT IO ()
|
||||
handleVersions state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term name: "
|
||||
nameInput <- getInputLine ""
|
||||
case nameInput of
|
||||
Nothing -> loop state
|
||||
Just n -> do
|
||||
let termName = strip n
|
||||
versions <- liftIO $ ContentStore.termVersions conn termName
|
||||
if null versions
|
||||
then liftIO $ printError $ "No versions found for term: " ++ termName
|
||||
else do
|
||||
liftIO $ do
|
||||
printKeyword "Versions of "
|
||||
printVariable termName
|
||||
putStrLn ":"
|
||||
|
||||
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
putStr $ show (i :: Int) ++ ". "
|
||||
displayColoredHash hash
|
||||
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
||||
unless (null tags) $ do
|
||||
putStr " ["
|
||||
printKeyword "Tags: "
|
||||
forM_ (zip [0..] tags) $ \(j, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (j < length tags - 1) $ putStr ", "
|
||||
putStr "]"
|
||||
putStrLn ""
|
||||
loop state
|
||||
|
||||
handleSelect :: REPLState -> InputT IO ()
|
||||
handleSelect state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term name: "
|
||||
nameInput <- getInputLine ""
|
||||
case nameInput of
|
||||
Nothing -> loop state
|
||||
Just n -> do
|
||||
let cleanName = strip n
|
||||
versions <- liftIO $ ContentStore.termVersions conn cleanName
|
||||
if null versions
|
||||
then do
|
||||
liftIO $ printError $ "No versions found for term: " ++ cleanName
|
||||
loop state
|
||||
else do
|
||||
liftIO $ do
|
||||
printKeyword "Versions of "
|
||||
printVariable cleanName
|
||||
putStrLn ":"
|
||||
|
||||
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
putStr $ show (i :: Int) ++ ". "
|
||||
displayColoredHash hash
|
||||
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
||||
unless (null tags) $ do
|
||||
putStr " ["
|
||||
printKeyword "Tags: "
|
||||
forM_ (zip [0..] tags) $ \(j, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (j < length tags - 1) $ putStr ", "
|
||||
putStr "]"
|
||||
putStrLn ""
|
||||
|
||||
liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): "
|
||||
choiceInput <- getInputLine ""
|
||||
let choice = strip <$> choiceInput
|
||||
|
||||
selectedHash <- case choice of
|
||||
Just selectedStr | not (null selectedStr) -> do
|
||||
case readMaybe selectedStr :: Maybe Int of
|
||||
Just idx | idx > 0 && idx <= length versions -> do
|
||||
let (h, _, _) = versions !! (idx - 1)
|
||||
return $ Just h
|
||||
_ -> do
|
||||
let potentialHash = T.pack selectedStr
|
||||
let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions
|
||||
case foundByHash of
|
||||
Just (h, _, _) -> return $ Just h
|
||||
Nothing -> do
|
||||
liftIO $ printError "Invalid selection or hash not found in list."
|
||||
return Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
case selectedHash of
|
||||
Just hashToSelect -> do
|
||||
let newState = state { replSelectedVersions =
|
||||
Map.insert cleanName hashToSelect (replSelectedVersions state) }
|
||||
liftIO $ do
|
||||
printSuccess "Selected version "
|
||||
displayColoredHash hashToSelect
|
||||
putStr " for term "
|
||||
printVariable cleanName
|
||||
putStrLn ""
|
||||
loop newState
|
||||
Nothing -> loop state
|
||||
|
||||
handleTag :: REPLState -> InputT IO ()
|
||||
handleTag state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): "
|
||||
identInput <- getInputLine ""
|
||||
case identInput of
|
||||
Nothing -> loop state
|
||||
Just ident -> do
|
||||
let cleanIdent = strip ident
|
||||
|
||||
mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent
|
||||
|
||||
case mFullHash of
|
||||
Nothing -> do
|
||||
liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent
|
||||
loop state
|
||||
Just fullHash -> do
|
||||
liftIO $ do
|
||||
putStr "Tagging term with hash: "
|
||||
displayColoredHash fullHash
|
||||
putStrLn ""
|
||||
tags <- liftIO $ ContentStore.termToTags conn fullHash
|
||||
unless (null tags) $ do
|
||||
liftIO $ do
|
||||
printKeyword "Existing tags:"
|
||||
displayTags tags
|
||||
|
||||
liftIO $ printPrompt "Tag to add/set: "
|
||||
tagValueInput <- getInputLine ""
|
||||
case tagValueInput of
|
||||
Nothing -> loop state
|
||||
Just tv -> do
|
||||
let tagVal = T.pack (strip tv)
|
||||
liftIO $ do
|
||||
ContentStore.setTag conn fullHash tagVal
|
||||
printSuccess $ "Tag '"
|
||||
printTag (T.unpack tagVal)
|
||||
putStr "' set for term with hash "
|
||||
displayColoredHash fullHash
|
||||
putStrLn ""
|
||||
loop state
|
||||
|
||||
resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text)
|
||||
resolveIdentifierToHash conn ident
|
||||
| T.pack "#" `T.isInfixOf` T.pack ident = do
|
||||
let hashPrefix = T.pack ident
|
||||
matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text]
|
||||
case matchingHashes of
|
||||
[Only fullHash] -> return $ Just fullHash
|
||||
[] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing
|
||||
_ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing
|
||||
| otherwise = do
|
||||
versions <- ContentStore.termVersions conn ident
|
||||
if null versions
|
||||
then do printError $ "No versions found for term name: " ++ ident; return Nothing
|
||||
else return $ Just $ (\(h,_,_) -> h) $ head versions
|
||||
|
||||
handleExport :: REPLState -> InputT IO ()
|
||||
handleExport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
|
||||
case hashInput of
|
||||
Nothing -> loop state
|
||||
Just hashStr -> do
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just outFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
let cleanHash = strip hashStr
|
||||
hash <- liftIO $ do
|
||||
let h = T.pack cleanHash
|
||||
if '#' `T.elem` h
|
||||
then return h
|
||||
else do
|
||||
results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results of
|
||||
[Only fullHash] -> return fullHash
|
||||
[] -> do
|
||||
results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results2 of
|
||||
[Only fullHash] -> return fullHash
|
||||
_ -> do
|
||||
printError $ "No term found matching: " ++ cleanHash
|
||||
return h
|
||||
_ -> do
|
||||
printError $ "Ambiguous match for: " ++ cleanHash
|
||||
return h
|
||||
bundleData <- liftIO $ exportBundle conn [hash]
|
||||
liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Exported bundle with root "
|
||||
displayColoredHash hash
|
||||
putStrLn $ " to " ++ outFile
|
||||
loop state
|
||||
|
||||
handleBundleImport :: REPLState -> InputT IO ()
|
||||
handleBundleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just inFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
exists <- liftIO $ doesFileExist inFile
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ inFile
|
||||
loop state
|
||||
else do
|
||||
bundleData <- liftIO $ BL.readFile inFile
|
||||
roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
|
||||
loop state
|
||||
|
||||
interruptHandler :: REPLState -> Interrupt -> InputT IO ()
|
||||
interruptHandler state _ = do
|
||||
liftIO $ do
|
||||
printWarning "Interrupted with CTRL+C"
|
||||
printWarning "You can use the !exit command or CTRL+D to exit"
|
||||
loop state
|
||||
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
printError $ "Error: " ++ displayException e
|
||||
return state
|
||||
|
||||
processInput :: REPLState -> String -> IO REPLState
|
||||
processInput state input = do
|
||||
let asts = parseTricu input
|
||||
case asts of
|
||||
[] -> return state
|
||||
_ -> case replContentStore state of
|
||||
Nothing -> do
|
||||
printError "Content store not initialized"
|
||||
return state
|
||||
Just conn -> do
|
||||
newState <- foldM (\s astNode -> do
|
||||
let varsInAst = Eval.findVarNames astNode
|
||||
foldM (\currentSelectionState varName ->
|
||||
if Map.member varName (replSelectedVersions currentSelectionState)
|
||||
then return currentSelectionState
|
||||
else do
|
||||
versions <- ContentStore.termVersions conn varName
|
||||
if length versions > 1
|
||||
then do
|
||||
let (latestHash, _, _) = head versions
|
||||
liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent."
|
||||
return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) }
|
||||
else return currentSelectionState
|
||||
) s varsInAst
|
||||
) state asts
|
||||
|
||||
forM_ asts $ \ast -> do
|
||||
case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printSuccess "Stored definition: "
|
||||
printVariable name
|
||||
putStr " with hash "
|
||||
displayColoredHash hash
|
||||
putStrLn ""
|
||||
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
return newState
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
|
||||
handleSave :: Env -> EvaluatedForm -> InputT IO ()
|
||||
handleSave env form = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
path <- runInputT fset $
|
||||
getInputLineWithInitial "File to save < " ("", "")
|
||||
watchLoop :: REPLState -> InputT IO ()
|
||||
watchLoop state = handle (\Interrupt -> do
|
||||
outputStrLn "\nStopped watching file"
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
|
||||
liftIO $ threadDelay 1000000
|
||||
watchLoop state
|
||||
|
||||
case path of
|
||||
Nothing -> do
|
||||
outputStrLn "Save cancelled"
|
||||
loop env form
|
||||
Just p -> do
|
||||
let definitions = Map.toList $ Map.delete "!result" env
|
||||
filepath = strip p
|
||||
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
||||
processWatchedFile filepath mconn selectedVersions outputForm = do
|
||||
content <- readFile filepath
|
||||
let asts = parseTricu content
|
||||
|
||||
outputStrLn "Starting save..."
|
||||
liftIO $ writeFile filepath ""
|
||||
outputStrLn "File created..."
|
||||
forM_ definitions $ \(name, value) -> do
|
||||
let content = name ++ " = " ++ formatT TreeCalculus value ++ "\n"
|
||||
outputStrLn $ "Writing definition: " ++ name ++ " with length " ++ show (length content)
|
||||
liftIO $ appendFile filepath content
|
||||
outputStrLn $ "Saved " ++ show (length definitions) ++ " definitions to " ++ p
|
||||
case mconn of
|
||||
Nothing -> putStrLn "Content store not initialized for watched file processing."
|
||||
Just conn -> do
|
||||
forM_ asts $ \ast -> case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||
|
||||
loop env form
|
||||
formatTimestamp :: Integer -> String
|
||||
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
|
||||
|
||||
displayColoredHash :: T.Text -> IO ()
|
||||
displayColoredHash hash = do
|
||||
let (prefix, rest) = T.splitAt 16 hash
|
||||
setSGR [SetColor Foreground Vivid Cyan]
|
||||
putStr $ T.unpack prefix
|
||||
setSGR [SetColor Foreground Dull White]
|
||||
putStr $ T.unpack rest
|
||||
setSGR [Reset]
|
||||
|
||||
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
||||
withColor intensity color action = do
|
||||
setSGR [SetColor Foreground intensity color]
|
||||
action
|
||||
setSGR [Reset]
|
||||
|
||||
printColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printColored intensity color text = withColor intensity color $ putStr text
|
||||
|
||||
printlnColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printlnColored intensity color text = withColor intensity color $ putStrLn text
|
||||
|
||||
printSuccess :: String -> IO ()
|
||||
printSuccess = printlnColored Vivid Green
|
||||
|
||||
printError :: String -> IO ()
|
||||
printError = printlnColored Vivid Red
|
||||
|
||||
printWarning :: String -> IO ()
|
||||
printWarning = printlnColored Vivid Yellow
|
||||
|
||||
printPrompt :: String -> IO ()
|
||||
printPrompt = printColored Vivid Blue
|
||||
|
||||
printVariable :: String -> IO ()
|
||||
printVariable = printColored Vivid Magenta
|
||||
|
||||
printTag :: String -> IO ()
|
||||
printTag = printColored Vivid Yellow
|
||||
|
||||
printKeyword :: String -> IO ()
|
||||
printKeyword = printColored Vivid Blue
|
||||
|
||||
printResult :: String -> IO ()
|
||||
printResult = printColored Dull White
|
||||
|
||||
displayTags :: [T.Text] -> IO ()
|
||||
displayTags [] = return ()
|
||||
displayTags tags = do
|
||||
putStr " Tags: "
|
||||
forM_ (zip [0..] tags) $ \(i, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (i < length tags - 1) $ putStr ", "
|
||||
putStrLn ""
|
||||
|
||||
189
src/Research.hs
189
src/Research.hs
@@ -1,12 +1,19 @@
|
||||
module Research where
|
||||
|
||||
import Crypto.Hash (hash, SHA256, Digest)
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString.Base16 (decode, encode)
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map)
|
||||
import Data.Map ()
|
||||
import Data.Text (Text, replace)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.Word (Word8)
|
||||
import System.Console.CmdArgs (Data, Typeable)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- Tree Calculus Types
|
||||
data T = Leaf | Stem T | Fork T T
|
||||
@@ -14,7 +21,7 @@ data T = Leaf | Stem T | Fork T T
|
||||
|
||||
-- Abstract Syntax Tree for tricu
|
||||
data TricuAST
|
||||
= SVar String
|
||||
= SVar String (Maybe String)
|
||||
| SInt Integer
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
@@ -30,11 +37,11 @@ data TricuAST
|
||||
|
||||
-- Lexer Tokens
|
||||
data LToken
|
||||
= LKeywordT
|
||||
| LIdentifier String
|
||||
= LIdentifier String
|
||||
| LIdentifierWithHash String String
|
||||
| LKeywordT
|
||||
| LNamespace String
|
||||
| LIntegerLiteral Integer
|
||||
| LStringLiteral String
|
||||
| LImport String String
|
||||
| LAssign
|
||||
| LColon
|
||||
| LDot
|
||||
@@ -42,9 +49,10 @@ data LToken
|
||||
| LCloseParen
|
||||
| LOpenBracket
|
||||
| LCloseBracket
|
||||
| LStringLiteral String
|
||||
| LIntegerLiteral Int
|
||||
| LNewline
|
||||
| LImport String String
|
||||
deriving (Show, Eq, Ord)
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- Output formats
|
||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||
@@ -53,8 +61,123 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||
-- Environment containing previously evaluated TC terms
|
||||
type Env = Map.Map String T
|
||||
|
||||
-- Merkle DAG Node types
|
||||
-- Each Tree Calculus node becomes a content-addressed object.
|
||||
|
||||
type MerkleHash = Text
|
||||
|
||||
data Node
|
||||
= NLeaf
|
||||
| NStem MerkleHash
|
||||
| NFork MerkleHash MerkleHash
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Canonical serialization of a Node for hashing.
|
||||
-- Leaf: 0x00
|
||||
-- Stem: 0x01 || child_hash (32 bytes)
|
||||
-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
|
||||
serializeNode :: Node -> BS.ByteString
|
||||
serializeNode NLeaf = BS.pack [0x00]
|
||||
serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
|
||||
where go (Left _) = error "Research.serializeNode: invalid hex hash"
|
||||
go (Right bs) = bs
|
||||
serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
|
||||
where go (Left _) = error "Research.serializeNode: invalid hex hash"
|
||||
go (Right bs) = bs
|
||||
|
||||
-- | Hash a node per the Merkle content-addressing spec.
|
||||
-- hash = SHA256( "arboricx.merkle.node.v1" <> 0x00 <> node_payload )
|
||||
nodeHash :: Node -> MerkleHash
|
||||
nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
|
||||
where sha256WithPrefix payload =
|
||||
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
|
||||
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "arboricx.merkle.node.v1"
|
||||
|
||||
-- | Deserialize a Node from canonical bytes.
|
||||
deserializeNode :: BS.ByteString -> Node
|
||||
deserializeNode bs =
|
||||
case BS.uncons bs of
|
||||
Just (0x00, rest)
|
||||
| BS.null rest -> NLeaf
|
||||
|
||||
Just (0x01, rest)
|
||||
| BS.length rest == 32 ->
|
||||
NStem $ decodeUtf8 (encode rest)
|
||||
|
||||
Just (0x02, rest)
|
||||
| BS.length rest == 64 ->
|
||||
let (l, r) = BS.splitAt 32 rest
|
||||
in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
|
||||
|
||||
_ -> errorWithoutStackTrace "invalid merkle node payload"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- ByteString / bytestream marshalling via existing Tree Calculus conventions
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
|
||||
ofByte :: Word8 -> T
|
||||
ofByte = ofNumber . fromIntegral
|
||||
|
||||
-- | Decode a Tree Calculus number as a single byte (Word8).
|
||||
-- Rejects values outside the range 0..255.
|
||||
toByte :: T -> Either String Word8
|
||||
toByte t = case toNumber t of
|
||||
Left err -> Left err
|
||||
Right n
|
||||
| n >= 0 && n <= 255 -> Right (fromIntegral n)
|
||||
| otherwise -> Left ("Byte value out of range: " ++ show n)
|
||||
|
||||
-- | Encode a ByteString as a Tree Calculus list of Byte trees.
|
||||
ofBytes :: BS.ByteString -> T
|
||||
ofBytes = ofList . map ofByte . BS.unpack
|
||||
|
||||
-- | Decode a Tree Calculus list of Byte trees as a ByteString.
|
||||
-- Rejects non-list trees and elements that are not valid byte values (0..255).
|
||||
toBytes :: T -> Either String BS.ByteString
|
||||
toBytes t = case toList t of
|
||||
Left err -> Left err
|
||||
Right bs -> BS.pack <$> mapM toByte bs
|
||||
|
||||
-- | Convert a canonical Arboricx node payload (ByteString) to a Tree
|
||||
-- representation (a list of Byte trees).
|
||||
nodePayloadToTreeBytes :: BS.ByteString -> T
|
||||
nodePayloadToTreeBytes = ofBytes
|
||||
|
||||
-- | Convert a Tree representation of a node payload back to ByteString.
|
||||
treeBytesToNodePayload :: T -> Either String BS.ByteString
|
||||
treeBytesToNodePayload = toBytes
|
||||
|
||||
-- | Convert a MerkleHash (hex-encoded) to a Tree of its 32 raw bytes.
|
||||
hashToTreeBytes :: MerkleHash -> Either String T
|
||||
hashToTreeBytes h = case decode (encodeUtf8 h) of
|
||||
Left _ -> Left "Invalid hex MerkleHash"
|
||||
Right raw
|
||||
| BS.length raw == 32 -> Right (ofBytes raw)
|
||||
| otherwise -> Left "Hash raw bytes must be 32 bytes"
|
||||
|
||||
-- | Convert a Tree of 32 Byte trees back to a MerkleHash (hex string).
|
||||
treeBytesToHash :: T -> Either String MerkleHash
|
||||
treeBytesToHash t = case toList t of
|
||||
Left err -> Left err
|
||||
Right bytes
|
||||
| length bytes == 32 -> do
|
||||
raw <- BS.pack <$> mapM toByte bytes
|
||||
Right $ decodeUtf8 (encode raw)
|
||||
| otherwise -> Left "Expected exactly 32 byte elements for hash"
|
||||
|
||||
-- | Build a Merkle DAG from a Tree Calculus term.
|
||||
buildMerkle :: T -> Node
|
||||
buildMerkle Leaf = NLeaf
|
||||
buildMerkle (Stem t) = NStem (nodeHash child)
|
||||
where child = buildMerkle t
|
||||
buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
|
||||
where
|
||||
left = buildMerkle l
|
||||
right = buildMerkle r
|
||||
|
||||
-- Tree Calculus Reduction Rules
|
||||
{-
|
||||
{-
|
||||
The t operator is left associative.
|
||||
1. t t a b -> a
|
||||
2. t (t a) b c -> a c (b c)
|
||||
@@ -65,9 +188,9 @@ type Env = Map.Map String T
|
||||
apply :: T -> T -> T
|
||||
apply (Fork Leaf a) _ = a
|
||||
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
|
||||
apply (Fork (Fork a b) c) Leaf = a
|
||||
apply (Fork (Fork a b) c) (Stem u) = apply b u
|
||||
apply (Fork (Fork a b) c) (Fork u v) = apply (apply c u) v
|
||||
apply (Fork (Fork _a _b) _c) Leaf = _a
|
||||
apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
|
||||
apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
|
||||
-- Left associative `t`
|
||||
apply Leaf b = Stem b
|
||||
apply (Stem a) b = Fork a b
|
||||
@@ -109,7 +232,7 @@ toNumber _ = Left "Invalid Tree Calculus number"
|
||||
toString :: T -> Either String String
|
||||
toString tc = case toList tc of
|
||||
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 Leaf = Right []
|
||||
@@ -174,3 +297,41 @@ decodeResult tc =
|
||||
|| n == 9
|
||||
|| n == 10
|
||||
|| n == 13
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- DAG node-table export (for host-language kernel embedding)
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Export a term's Merkle DAG as a topologically-sorted node table.
|
||||
-- Children appear before parents so all index references are forward.
|
||||
-- Returns (root index, list of (tag, [child_indices])).
|
||||
exportDag :: T -> (Int, [(String, [Int])])
|
||||
exportDag term =
|
||||
let (root, acc, _) = collectDag term [] Set.empty
|
||||
-- acc is in reverse post-order (children first, root last)
|
||||
ordered = reverse acc
|
||||
idxMap = Map.fromList [(h, i) | (i, (h, _)) <- zip [0..] ordered]
|
||||
rootIdx = idxMap Map.! root
|
||||
lines_ = map (formatNode idxMap . snd) ordered
|
||||
in (rootIdx, lines_)
|
||||
where
|
||||
collectDag :: T -> [(MerkleHash, Node)] -> Set.Set MerkleHash -> (MerkleHash, [(MerkleHash, Node)], Set.Set MerkleHash)
|
||||
collectDag Leaf acc seen =
|
||||
let h = nodeHash NLeaf
|
||||
in if Set.member h seen then (h, acc, seen) else (h, (h, NLeaf) : acc, Set.insert h seen)
|
||||
collectDag (Stem t) acc seen =
|
||||
let (ch, acc', seen') = collectDag t acc seen
|
||||
node = NStem ch
|
||||
h = nodeHash node
|
||||
in if Set.member h seen' then (h, acc', seen') else (h, (h, node) : acc', Set.insert h seen')
|
||||
collectDag (Fork l r) acc seen =
|
||||
let (lh, acc', seen') = collectDag l acc seen
|
||||
(rh, acc'', seen'') = collectDag r acc' seen'
|
||||
node = NFork lh rh
|
||||
h = nodeHash node
|
||||
in if Set.member h seen'' then (h, acc'', seen'') else (h, (h, node) : acc'', Set.insert h seen'')
|
||||
|
||||
formatNode :: Map.Map MerkleHash Int -> Node -> (String, [Int])
|
||||
formatNode _ NLeaf = ("leaf", [])
|
||||
formatNode idxMap (NStem ch) = ("stem", [idxMap Map.! ch])
|
||||
formatNode idxMap (NFork l r) = ("fork", [idxMap Map.! l, idxMap Map.! r])
|
||||
|
||||
232
src/Server.hs
Normal file
232
src/Server.hs
Normal file
@@ -0,0 +1,232 @@
|
||||
module Server
|
||||
( runServer
|
||||
) where
|
||||
|
||||
import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
|
||||
parseNameList, StoredTerm(..), termHash)
|
||||
import Database.SQLite.Simple (close)
|
||||
import Wire (exportNamedBundle)
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Control.Monad (void)
|
||||
|
||||
import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
|
||||
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
import Data.Char (isHexDigit, toLower)
|
||||
import Data.ByteString.Char8 (unpack)
|
||||
import Data.ByteString.Lazy (fromStrict)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | Start an HTTP server that serves Arboricx 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 Arboricx bundle,
|
||||
-- and return the raw bundle bytes.
|
||||
--
|
||||
-- Sets @Content-Type@ and @X-Arboricx-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 Arboricx
|
||||
-- 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.arboricx.bundle")
|
||||
, ("X-Arboricx-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 = '_'
|
||||
973
src/Wire.hs
Normal file
973
src/Wire.hs
Normal file
@@ -0,0 +1,973 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
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.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, decodeUtf8', encodeUtf8)
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
import Database.SQLite.Simple (Connection)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as Base16
|
||||
import qualified Data.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, 0x43, 0x58] -- "ARBORICX"
|
||||
|
||||
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
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Manifest binary constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Magic prefix identifying the fixed-order manifest v1 format.
|
||||
manifestMagic :: ByteString
|
||||
manifestMagic = "ARBMNFST"
|
||||
|
||||
-- | Manifest major version.
|
||||
manifestMajorVersion :: Word16
|
||||
manifestMajorVersion = 1
|
||||
|
||||
-- | Manifest minor version.
|
||||
manifestMinorVersion :: Word16
|
||||
manifestMinorVersion = 0
|
||||
|
||||
-- | Closure mode to byte.
|
||||
closureToByte :: ClosureMode -> Word8
|
||||
closureToByte = \case
|
||||
ClosureComplete -> 0
|
||||
ClosurePartial -> 1
|
||||
|
||||
closureFromByte :: Word8 -> Either String ClosureMode
|
||||
closureFromByte = \case
|
||||
0 -> Right ClosureComplete
|
||||
1 -> Right ClosurePartial
|
||||
n -> Left $ "unsupported closure byte: " ++ show n
|
||||
|
||||
-- | Metadata tag constants.
|
||||
tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16
|
||||
tagPackage = 1
|
||||
tagVersion = 2
|
||||
tagDescription = 3
|
||||
tagLicense = 4
|
||||
tagCreatedBy = 5
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Fixed-order manifest binary helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode a UTF-8 text string as: u32 length + UTF-8 bytes.
|
||||
encodeLengthPrefixedText :: Text -> ByteString
|
||||
encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs
|
||||
where bs = encodeUtf8 t
|
||||
|
||||
-- | Decode a length-prefixed UTF-8 text string.
|
||||
-- Returns the decoded Text and the remaining ByteString.
|
||||
decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString)
|
||||
decodeLengthPrefixedText bs =
|
||||
case decode32be "text_length" bs of
|
||||
Left err -> Left $ "decodeLengthPrefixedText: " ++ err
|
||||
Right (len, rest) -> do
|
||||
let payloadLen = fromIntegral len
|
||||
when (BS.length rest < payloadLen) $
|
||||
Left "decodeLengthPrefixedText: string extends beyond input"
|
||||
let (textBytes, after) = BS.splitAt payloadLen rest
|
||||
case decodeUtf8' textBytes of
|
||||
Right txt -> Right (txt, after)
|
||||
Left _ -> Left "decodeLengthPrefixedText: invalid UTF-8"
|
||||
|
||||
-- | Encode a metadata value as a TLV entry: u16 tag + u32 length + raw bytes.
|
||||
encodeMetadataTLV :: Word16 -> ByteString -> ByteString
|
||||
encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Fixed-order manifest encoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode the entire manifest in fixed-order core + TLV tail layout.
|
||||
encodeManifest :: BundleManifest -> ByteString
|
||||
encodeManifest m =
|
||||
manifestMagic
|
||||
<> encode16 manifestMajorVersion
|
||||
<> encode16 manifestMinorVersion
|
||||
<> encodeLengthPrefixedText (manifestSchema m)
|
||||
<> encodeLengthPrefixedText (manifestBundleType m)
|
||||
<> encodeLengthPrefixedText (treeCalculus (manifestTree m))
|
||||
<> encodeLengthPrefixedText (nodeHashAlgorithm (treeNodeHash (manifestTree m)))
|
||||
<> encodeLengthPrefixedText (nodeHashDomain (treeNodeHash (manifestTree m)))
|
||||
<> encodeLengthPrefixedText (treeNodePayload (manifestTree m))
|
||||
<> encodeLengthPrefixedText (runtimeSemantics (manifestRuntime m))
|
||||
<> encodeLengthPrefixedText (runtimeEvaluation (manifestRuntime m))
|
||||
<> encodeLengthPrefixedText (runtimeAbi (manifestRuntime m))
|
||||
<> encode32 (fromIntegral $ length (runtimeCapabilities (manifestRuntime m)))
|
||||
<> encodeCapabilities (runtimeCapabilities (manifestRuntime m))
|
||||
<> BS.pack [closureToByte (manifestClosure m)]
|
||||
<> encode32 (fromIntegral $ length (manifestRoots m))
|
||||
<> encodeRoots (manifestRoots m)
|
||||
<> encode32 (fromIntegral $ length (manifestExports m))
|
||||
<> encodeExports (manifestExports m)
|
||||
<> encodeMetadataTLVs (manifestMetadata m)
|
||||
<> encode32 0 -- zero extension fields
|
||||
|
||||
encodeCapabilities :: [Text] -> ByteString
|
||||
encodeCapabilities caps = mconcat (map encodeLengthPrefixedText caps)
|
||||
|
||||
encodeRoots :: [BundleRoot] -> ByteString
|
||||
encodeRoots = mconcat . map encodeRoot
|
||||
|
||||
encodeRoot :: BundleRoot -> ByteString
|
||||
encodeRoot root =
|
||||
merkleHashToRaw (rootHash root)
|
||||
<> encodeLengthPrefixedText (rootRole root)
|
||||
|
||||
encodeExports :: [BundleExport] -> ByteString
|
||||
encodeExports = mconcat . map encodeExport
|
||||
|
||||
encodeExport :: BundleExport -> ByteString
|
||||
encodeExport exp =
|
||||
encodeLengthPrefixedText (exportName exp)
|
||||
<> merkleHashToRaw (exportRoot exp)
|
||||
<> encodeLengthPrefixedText (exportKind exp)
|
||||
<> encodeLengthPrefixedText (exportAbi exp)
|
||||
|
||||
-- | Encode metadata as: u32 field count + TLV entries for present fields.
|
||||
-- Metadata TLV values are raw UTF-8 bytes; the TLV length already carries size.
|
||||
encodeMetadataTLVs :: BundleMetadata -> ByteString
|
||||
encodeMetadataTLVs m =
|
||||
let entries = metadataTLVEntries m
|
||||
in encode32 (fromIntegral $ length entries) <> encodeTLVs entries
|
||||
|
||||
metadataTLVEntries :: BundleMetadata -> [(Word16, ByteString)]
|
||||
metadataTLVEntries m =
|
||||
maybeEntry tagPackage (metadataPackage m)
|
||||
++ maybeEntry tagVersion (metadataVersion m)
|
||||
++ maybeEntry tagDescription (metadataDescription m)
|
||||
++ maybeEntry tagLicense (metadataLicense m)
|
||||
++ maybeEntry tagCreatedBy (metadataCreatedBy m)
|
||||
where
|
||||
maybeEntry _ Nothing = []
|
||||
maybeEntry tag (Just value) = [(tag, encodeUtf8 value)]
|
||||
|
||||
encodeTLVs :: [(Word16, ByteString)] -> ByteString
|
||||
encodeTLVs tlvs = mconcat (map (uncurry encodeMetadataTLV) tlvs)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Fixed-order manifest decoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Decode the manifest from fixed-order core + TLV tail bytes.
|
||||
-- All remaining bytes after the core fields are treated as the TLV tail.
|
||||
decodeManifest :: ByteString -> Either String BundleManifest
|
||||
decodeManifest bs = do
|
||||
-- Header
|
||||
when (BS.length bs < 8) $ Left "manifest too short for magic"
|
||||
when (BS.take 8 bs /= manifestMagic) $ Left "invalid manifest magic"
|
||||
let rest = BS.drop 8 bs
|
||||
(major, rest') <- decode16be "major" rest
|
||||
when (major /= manifestMajorVersion) $ Left $ "unsupported manifest major version: " ++ show major
|
||||
(_minor, rest'') <- decode16be "minor" rest'
|
||||
|
||||
-- Core strings
|
||||
(schema, rest''') <- decodeLengthPrefixedText rest''
|
||||
(bundleType, rest'''') <- decodeLengthPrefixedText rest'''
|
||||
|
||||
-- Tree spec fields (flat)
|
||||
(calc, rest1) <- decodeLengthPrefixedText rest''''
|
||||
(alg, rest2) <- decodeLengthPrefixedText rest1
|
||||
(domain, rest3) <- decodeLengthPrefixedText rest2
|
||||
(payload, rest4) <- decodeLengthPrefixedText rest3
|
||||
|
||||
-- Runtime spec fields (flat)
|
||||
(sem, restR1) <- decodeLengthPrefixedText rest4
|
||||
(eval, restR2) <- decodeLengthPrefixedText restR1
|
||||
(abi, restR3) <- decodeLengthPrefixedText restR2
|
||||
|
||||
(capCount, restR4) <- decode32be "capability_count" restR3
|
||||
let capLen = fromIntegral capCount
|
||||
(caps, restR5) <- decodeCapabilities capLen restR4
|
||||
|
||||
-- Closure
|
||||
when (BS.length restR5 < 1) $ Left "manifest truncated: missing closure byte"
|
||||
let (closureByte, restR6) = BS.splitAt 1 restR5
|
||||
closure <- closureFromByte (head $ BS.unpack closureByte)
|
||||
|
||||
-- Roots
|
||||
(rootCount, restR7) <- decode32be "root_count" restR6
|
||||
let rootCountInt = fromIntegral rootCount
|
||||
(roots, restR8) <- decodeRoots rootCountInt restR7
|
||||
|
||||
-- Exports
|
||||
(exportCount, restR9) <- decode32be "export_count" restR8
|
||||
let exportCountInt = fromIntegral exportCount
|
||||
(exports, restR10) <- decodeExports exportCountInt restR9
|
||||
|
||||
-- TLV tail
|
||||
(metadata, _ext) <- decodeMetadataAndExtensions restR10
|
||||
|
||||
pure BundleManifest
|
||||
{ manifestSchema = schema
|
||||
, manifestBundleType = bundleType
|
||||
, manifestTree = TreeSpec
|
||||
{ treeCalculus = calc
|
||||
, treeNodeHash = NodeHashSpec
|
||||
{ nodeHashAlgorithm = alg
|
||||
, nodeHashDomain = domain
|
||||
}
|
||||
, treeNodePayload = payload
|
||||
}
|
||||
, manifestRuntime = RuntimeSpec
|
||||
{ runtimeSemantics = sem
|
||||
, runtimeEvaluation = eval
|
||||
, runtimeAbi = abi
|
||||
, runtimeCapabilities = caps
|
||||
}
|
||||
, manifestClosure = closure
|
||||
, manifestRoots = roots
|
||||
, manifestExports = exports
|
||||
, manifestMetadata = metadata
|
||||
}
|
||||
|
||||
-- | Decode length-prefixed capability strings.
|
||||
decodeCapabilities :: Int -> ByteString -> Either String ([Text], ByteString)
|
||||
decodeCapabilities 0 bs = Right ([], bs)
|
||||
decodeCapabilities n bs = do
|
||||
(txt, rest) <- decodeLengthPrefixedText bs
|
||||
(restTxts, restFinal) <- decodeCapabilities (n - 1) rest
|
||||
Right (txt : restTxts, restFinal)
|
||||
|
||||
-- | Decode root entries.
|
||||
decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString)
|
||||
decodeRoots 0 bs = Right ([], bs)
|
||||
decodeRoots n bs = do
|
||||
when (BS.length bs < 32) $ Left "decodeRoots: truncated root hash"
|
||||
let (hashBytes, rest) = BS.splitAt 32 bs
|
||||
role <- decodeLengthPrefixedText rest
|
||||
(restRoots, restFinal) <- decodeRoots (n - 1) (snd role)
|
||||
Right (BundleRoot (rawToMerkleHash hashBytes) (fst role) : restRoots, restFinal)
|
||||
|
||||
-- | Decode export entries.
|
||||
decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString)
|
||||
decodeExports 0 bs = Right ([], bs)
|
||||
decodeExports n bs = do
|
||||
name <- decodeLengthPrefixedText bs
|
||||
when (BS.length (snd name) < 32) $ Left "decodeExports: truncated export root hash"
|
||||
let (hashBytes, rest) = BS.splitAt 32 (snd name)
|
||||
kind <- decodeLengthPrefixedText rest
|
||||
abi <- decodeLengthPrefixedText (snd kind)
|
||||
(restExports, restFinal) <- decodeExports (n - 1) (snd abi)
|
||||
Right (BundleExport (fst name) (rawToMerkleHash hashBytes) (fst kind) (fst abi) : restExports, restFinal)
|
||||
|
||||
-- | Decode TLV tail into metadata and extensions.
|
||||
-- Layout: u32 metadata-count, metadata TLVs, u32 extension-count, extension TLVs.
|
||||
-- For now, known metadata tags are decoded and extension TLVs are skipped.
|
||||
decodeMetadataAndExtensions :: ByteString -> Either String (BundleMetadata, ByteString)
|
||||
decodeMetadataAndExtensions bs = do
|
||||
(metadataCount, rest1) <- decode32be "metadata_field_count" bs
|
||||
(metadataTlvs, rest2) <- decodeTLVs (fromIntegral metadataCount) rest1
|
||||
metadata <- decodeMetadataTLVs metadataTlvs
|
||||
(extensionCount, rest3) <- decode32be "extension_field_count" rest2
|
||||
(_extensionTlvs, rest4) <- decodeTLVs (fromIntegral extensionCount) rest3
|
||||
unless (BS.null rest4) $ Left "trailing bytes after manifest TLV tail"
|
||||
Right (metadata, rest4)
|
||||
|
||||
-- | Decode a fixed number of TLV entries.
|
||||
decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString)
|
||||
decodeTLVs 0 bs = Right ([], bs)
|
||||
decodeTLVs n bs = do
|
||||
(tag, rest1) <- decode16be "tlv_tag" bs
|
||||
(len, rest2) <- decode32be "tlv_length" rest1
|
||||
let payloadLen = fromIntegral len
|
||||
when (BS.length rest2 < payloadLen) $ Left "TLV value extends beyond input"
|
||||
let (value, after) = BS.splitAt payloadLen rest2
|
||||
(restTlvs, restFinal) <- decodeTLVs (n - 1) after
|
||||
Right ((tag, value) : restTlvs, restFinal)
|
||||
|
||||
-- | Decode known metadata TLV entries into BundleMetadata.
|
||||
-- Unknown tags are ignored.
|
||||
decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata
|
||||
decodeMetadataTLVs tlvs = do
|
||||
pkg <- decodeOptionalMetadataText tagPackage
|
||||
ver <- decodeOptionalMetadataText tagVersion
|
||||
desc <- decodeOptionalMetadataText tagDescription
|
||||
lic <- decodeOptionalMetadataText tagLicense
|
||||
by <- decodeOptionalMetadataText tagCreatedBy
|
||||
pure BundleMetadata
|
||||
{ metadataPackage = pkg
|
||||
, metadataVersion = ver
|
||||
, metadataDescription = desc
|
||||
, metadataLicense = lic
|
||||
, metadataCreatedBy = by
|
||||
}
|
||||
where
|
||||
lookupTag t = go t tlvs
|
||||
go _ [] = Nothing
|
||||
go t ((tag, val):rest)
|
||||
| tag == t = Just val
|
||||
| otherwise = go t rest
|
||||
decodeOptionalMetadataText tag =
|
||||
case lookupTag tag of
|
||||
Nothing -> Right Nothing
|
||||
Just raw -> case decodeUtf8' raw of
|
||||
Right txt -> Right (Just txt)
|
||||
Left _ -> Left $ "metadata TLV has invalid UTF-8 for tag " ++ show tag
|
||||
|
||||
type TLVEntry = (Word16, ByteString)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Data types
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Closure declaration.
|
||||
data ClosureMode = ClosureComplete | ClosurePartial
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | Hash specification (algorithm + domain strings).
|
||||
data NodeHashSpec = NodeHashSpec
|
||||
{ nodeHashAlgorithm :: Text
|
||||
, nodeHashDomain :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | Tree specification.
|
||||
data TreeSpec = TreeSpec
|
||||
{ treeCalculus :: Text
|
||||
, treeNodeHash :: NodeHashSpec
|
||||
, treeNodePayload :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | Runtime specification.
|
||||
data RuntimeSpec = RuntimeSpec
|
||||
{ runtimeSemantics :: Text
|
||||
, runtimeEvaluation :: Text
|
||||
, runtimeAbi :: Text
|
||||
, runtimeCapabilities :: [Text]
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | A root hash reference.
|
||||
data BundleRoot = BundleRoot
|
||||
{ rootHash :: MerkleHash
|
||||
, rootRole :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | An export entry.
|
||||
data BundleExport = BundleExport
|
||||
{ exportName :: Text
|
||||
, exportRoot :: MerkleHash
|
||||
, exportKind :: Text
|
||||
, exportAbi :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | Optional package metadata.
|
||||
data BundleMetadata = BundleMetadata
|
||||
{ metadataPackage :: Maybe Text
|
||||
, metadataVersion :: Maybe Text
|
||||
, metadataDescription :: Maybe Text
|
||||
, metadataLicense :: Maybe Text
|
||||
, metadataCreatedBy :: Maybe Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | The manifest: top-level bundle metadata.
|
||||
data BundleManifest = BundleManifest
|
||||
{ manifestSchema :: Text
|
||||
, manifestBundleType :: Text
|
||||
, manifestTree :: TreeSpec
|
||||
, manifestRuntime :: RuntimeSpec
|
||||
, manifestClosure :: ClosureMode
|
||||
, manifestRoots :: [BundleRoot]
|
||||
, manifestExports :: [BundleExport]
|
||||
, manifestMetadata :: BundleMetadata
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle encoding
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode a Bundle to portable Bundle v1 bytes.
|
||||
-- The manifest is serialized using the fixed-order core + TLV tail format.
|
||||
encodeBundle :: Bundle -> ByteString
|
||||
encodeBundle bundle =
|
||||
let nodeSection = encodeNodeSection (bundleNodes bundle)
|
||||
manifestBytes = if BS.null (bundleManifestBytes bundle)
|
||||
then encodeManifest (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"
|
||||
let dirRaw = BS.take dirBytes $ BS.drop dirStart bs
|
||||
entries <- decodeSectionEntries sectionCount dirRaw
|
||||
traverse_ rejectUnknownCritical entries
|
||||
manifestEntry <- requireSection sectionManifest entries
|
||||
nodesEntry <- requireSection sectionNodes entries
|
||||
manifestBytes <- readAndVerifySection bs manifestEntry
|
||||
nodesBytes <- readAndVerifySection bs nodesEntry
|
||||
manifest <- decodeManifest manifestBytes
|
||||
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)] -> BundleManifest
|
||||
defaultManifest namedRoots = BundleManifest
|
||||
{ manifestSchema = "arboricx.bundle.manifest.v1"
|
||||
, manifestBundleType = "tree-calculus-executable-object"
|
||||
, manifestTree = TreeSpec
|
||||
{ treeCalculus = "tree-calculus.v1"
|
||||
, treeNodeHash = NodeHashSpec
|
||||
{ nodeHashAlgorithm = "sha256"
|
||||
, nodeHashDomain = "arboricx.merkle.node.v1"
|
||||
}
|
||||
, treeNodePayload = "arboricx.merkle.payload.v1"
|
||||
}
|
||||
, manifestRuntime = RuntimeSpec
|
||||
{ runtimeSemantics = "tree-calculus.v1"
|
||||
, runtimeEvaluation = "normal-order"
|
||||
, runtimeAbi = "arboricx.abi.tree.v1"
|
||||
, runtimeCapabilities = []
|
||||
}
|
||||
, manifestClosure = ClosureComplete
|
||||
, manifestRoots = zipWith mkRoot [0 :: Int ..] (map snd namedRoots)
|
||||
, manifestExports = map mkExport namedRoots
|
||||
, manifestMetadata = BundleMetadata
|
||||
{ metadataPackage = Nothing
|
||||
, metadataVersion = Nothing
|
||||
, metadataDescription = Nothing
|
||||
, metadataLicense = Nothing
|
||||
, metadataCreatedBy = Just "arboricx"
|
||||
}
|
||||
}
|
||||
where
|
||||
mkRoot 0 h = BundleRoot h "default"
|
||||
mkRoot _ h = BundleRoot h "root"
|
||||
mkExport (name, h) = BundleExport
|
||||
{ exportName = name
|
||||
, exportRoot = h
|
||||
, exportKind = "term"
|
||||
, exportAbi = "arboricx.abi.tree.v1"
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 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 /= "arboricx.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 /= "arboricx.merkle.node.v1") $
|
||||
Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
|
||||
when (treeNodePayload treeSpec /= "arboricx.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 /= "arboricx.abi.tree.v1") $
|
||||
Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec)
|
||||
when (not (null (runtimeCapabilities runtimeSpec))) $
|
||||
Left "unsupported runtime capabilities"
|
||||
when (manifestClosure manifest /= ClosureComplete) $
|
||||
Left "bundle v1 requires closure = complete"
|
||||
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
|
||||
manifestBytes = encodeManifest 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
|
||||
2232
test/Spec.hs
2232
test/Spec.hs
File diff suppressed because it is too large
Load Diff
BIN
test/fixtures/append.arboricx
vendored
Normal file
BIN
test/fixtures/append.arboricx
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/false.arboricx
vendored
Normal file
BIN
test/fixtures/false.arboricx
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/id.arboricx
vendored
Normal file
BIN
test/fixtures/id.arboricx
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/map.arboricx
vendored
Normal file
BIN
test/fixtures/map.arboricx
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/notQ.arboricx
vendored
Normal file
BIN
test/fixtures/notQ.arboricx
vendored
Normal file
Binary file not shown.
BIN
test/fixtures/true.arboricx
vendored
Normal file
BIN
test/fixtures/true.arboricx
vendored
Normal file
Binary file not shown.
75
tricu.cabal
75
tricu.cabal
@@ -1,8 +1,8 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: tricu
|
||||
version: 0.19.0
|
||||
description: A micro-language for exploring Tree Calculus
|
||||
version: 1.1.0
|
||||
description: A language for exploring Tree Calculus
|
||||
author: James Eversole
|
||||
maintainer: james@eversole.co
|
||||
copyright: James Eversole
|
||||
@@ -15,31 +15,66 @@ extra-source-files:
|
||||
executable tricu
|
||||
main-is: Main.hs
|
||||
hs-source-dirs:
|
||||
src
|
||||
src
|
||||
default-extensions:
|
||||
DeriveDataTypeable
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
OverloadedStrings
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
||||
DeriveDataTypeable
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
OverloadedStrings
|
||||
ScopedTypeVariables
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wcompat
|
||||
-Wunused-imports
|
||||
-Wunused-top-binds
|
||||
-Wunused-local-binds
|
||||
-Wunused-matches
|
||||
-Wredundant-constraints
|
||||
-threaded
|
||||
-rtsopts
|
||||
-with-rtsopts=-N
|
||||
-optl-pthread
|
||||
-fPIC
|
||||
build-depends:
|
||||
base >=4.7
|
||||
, ansi-terminal
|
||||
, base16-bytestring
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, cmdargs
|
||||
, containers
|
||||
, cryptonite
|
||||
, directory
|
||||
, exceptions
|
||||
, filepath
|
||||
, fsnotify
|
||||
, haskeline
|
||||
, http-types
|
||||
, megaparsec
|
||||
, memory
|
||||
, mtl
|
||||
, servant
|
||||
, sqlite-simple
|
||||
, stm
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, wai
|
||||
, warp
|
||||
, zlib
|
||||
other-modules:
|
||||
ContentStore
|
||||
Eval
|
||||
FileEval
|
||||
Lexer
|
||||
Parser
|
||||
Paths_tricu
|
||||
REPL
|
||||
Research
|
||||
Server
|
||||
Wire
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tricu-tests
|
||||
@@ -51,25 +86,45 @@ test-suite tricu-tests
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
OverloadedStrings
|
||||
ScopedTypeVariables
|
||||
build-depends:
|
||||
base
|
||||
base >=4.7
|
||||
, ansi-terminal
|
||||
, base16-bytestring
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, cmdargs
|
||||
, containers
|
||||
, cryptonite
|
||||
, directory
|
||||
, exceptions
|
||||
, filepath
|
||||
, fsnotify
|
||||
, haskeline
|
||||
, http-types
|
||||
, megaparsec
|
||||
, memory
|
||||
, mtl
|
||||
, servant
|
||||
, sqlite-simple
|
||||
, stm
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, wai
|
||||
, warp
|
||||
, zlib
|
||||
default-language: Haskell2010
|
||||
other-modules:
|
||||
ContentStore
|
||||
Eval
|
||||
FileEval
|
||||
Lexer
|
||||
Parser
|
||||
Paths_tricu
|
||||
REPL
|
||||
Research
|
||||
Server
|
||||
Wire
|
||||
|
||||
Reference in New Issue
Block a user