Compare commits
50 Commits
contentsto
...
bf30d5945e
| Author | SHA1 | Date | |
|---|---|---|---|
| bf30d5945e | |||
| 7ae3fc33f4 | |||
| 1c17d4c94a | |||
| e2a1744508 | |||
| 020fa769a9 | |||
| 2e13583de3 | |||
| 593aa96193 | |||
| e2d035286d | |||
| 8d5e76db1c | |||
| e3dcf5edd7 | |||
| 8f7684a1bb | |||
| 983a0cc5a7 | |||
| d6df01105c | |||
| 31bf7094f4 | |||
| e0b1e95729 | |||
| ea748b2e5e | |||
| 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 | |||
|
|
71653311ce | ||
| 0cdc0bfc34 | |||
| c36d963640 |
@@ -1,65 +0,0 @@
|
||||
name: Test, Build, and Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- '*'
|
||||
|
||||
jobs:
|
||||
test:
|
||||
container:
|
||||
image: docker.matri.cx/nix-runner:v0.1.0
|
||||
credentials:
|
||||
username: ${{ secrets.REGISTRY_USERNAME }}
|
||||
password: ${{ secrets.REGISTRY_PASSWORD }}
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
with:
|
||||
fetch-depth: 0
|
||||
|
||||
- name: Set up cache for Cabal
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: |
|
||||
~/.cache/cabal
|
||||
~/.config/cabal
|
||||
~/.local/state/cabal
|
||||
key: cabal-${{ hashFiles('tricu.cabal') }}
|
||||
restore-keys: |
|
||||
cabal-
|
||||
|
||||
- name: Initialize Cabal and update package list
|
||||
run: |
|
||||
nix develop --command cabal update
|
||||
|
||||
- name: Run test suite
|
||||
run: |
|
||||
nix develop --command cabal test
|
||||
|
||||
build:
|
||||
needs: test
|
||||
container:
|
||||
image: docker.matri.cx/nix-runner:v0.1.0
|
||||
credentials:
|
||||
username: ${{ secrets.REGISTRY_USERNAME }}
|
||||
password: ${{ secrets.REGISTRY_PASSWORD }}
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
with:
|
||||
fetch-depth: 0
|
||||
|
||||
- name: Build and shrink binary
|
||||
run: |
|
||||
nix build
|
||||
cp -L ./result/bin/tricu ./tricu
|
||||
chmod 755 ./tricu
|
||||
nix develop --command upx ./tricu
|
||||
|
||||
- name: Release binary
|
||||
uses: akkuman/gitea-release-action@v1
|
||||
with:
|
||||
files: |-
|
||||
./tricu
|
||||
token: '${{ secrets.RELEASE_TOKEN }}'
|
||||
body: '${{ gitea.event.head_commit.message }}'
|
||||
prerelease: true
|
||||
1
.gitignore
vendored
1
.gitignore
vendored
@@ -6,6 +6,7 @@
|
||||
/Dockerfile
|
||||
/config.dhall
|
||||
/result
|
||||
/result*
|
||||
.aider*
|
||||
WD
|
||||
bin/
|
||||
|
||||
373
AGENTS.md
Normal file
373
AGENTS.md
Normal file
@@ -0,0 +1,373 @@
|
||||
# AGENTS.md - tricu Project Guide
|
||||
|
||||
> For AI agents and contributors working in this repository.
|
||||
|
||||
## 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
|
||||
```
|
||||
61
README.md
61
README.md
@@ -2,10 +2,16 @@
|
||||
|
||||
## Introduction
|
||||
|
||||
tricu (pronounced "tree-shoe") is a programming language experiment in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf), terms, but minimal syntax sugar is included.
|
||||
tricu (pronounced "tree-shoe") is an experimental programming language written 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). I will refer to this "family" of calculi as TC.
|
||||
|
||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||
|
||||
In the `ext/` directory there are implementations of TC evaluators and tooling in other languages. Here be dragons; beware.
|
||||
|
||||
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 100% 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). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda.
|
||||
@@ -32,15 +38,22 @@ 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
|
||||
!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
|
||||
!export - Export a term bundle to file (hash, file)
|
||||
!bundleimport- Import a bundle file into the content store
|
||||
```
|
||||
|
||||
## Installation and Use
|
||||
@@ -54,30 +67,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.
|
||||
|
||||
240
bench/ApplyStats.hs
Normal file
240
bench/ApplyStats.hs
Normal file
@@ -0,0 +1,240 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module ApplyStats
|
||||
( ApplyStats(..)
|
||||
, emptyApplyStats
|
||||
, emptyApplyStatsSampled
|
||||
, applyCounted
|
||||
, runApplyCounted
|
||||
, runApplySampledWithProgress
|
||||
, runApplyGlobalCounted
|
||||
, printApplyStats
|
||||
) where
|
||||
|
||||
import Research
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.List as L
|
||||
import Data.Ord (comparing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Debug.Trace (trace)
|
||||
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
|
||||
import Data.IORef
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Threaded stats (slow but pure)
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
type Hash = Text
|
||||
type AppKey = (Hash, Hash)
|
||||
|
||||
data ApplyStats = ApplyStats
|
||||
{ totalApplyCalls :: !Int
|
||||
, uniqueApps :: !(M.Map AppKey Int)
|
||||
, sampleInterval :: !Int
|
||||
, sampleCounter :: !Int
|
||||
, progressEvery :: !Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
emptyApplyStats :: ApplyStats
|
||||
emptyApplyStats = emptyApplyStatsSampled 1
|
||||
|
||||
emptyApplyStatsSampled :: Int -> ApplyStats
|
||||
emptyApplyStatsSampled n = ApplyStats
|
||||
{ totalApplyCalls = 0
|
||||
, uniqueApps = M.empty
|
||||
, sampleInterval = max 1 n
|
||||
, sampleCounter = 0
|
||||
, progressEvery = 0
|
||||
}
|
||||
|
||||
bump :: T -> T -> ApplyStats -> ApplyStats
|
||||
bump !f !x !st =
|
||||
let !counter' = sampleCounter st + 1
|
||||
!total' = totalApplyCalls st + 1
|
||||
!stBase = st { totalApplyCalls = total'
|
||||
, sampleCounter = counter'
|
||||
}
|
||||
!st' = if counter' `mod` sampleInterval st /= 0
|
||||
then stBase
|
||||
else let !hf = termHash f
|
||||
!hx = termHash x
|
||||
!k = (hf, hx)
|
||||
!m = M.insertWith (+) k 1 (uniqueApps st)
|
||||
in stBase { uniqueApps = m }
|
||||
in case progressEvery st of
|
||||
0 -> st'
|
||||
n | total' `mod` n == 0 ->
|
||||
trace ("apply calls so far: " ++ show total') st'
|
||||
_ -> st'
|
||||
|
||||
termHash :: T -> Hash
|
||||
termHash Leaf =
|
||||
nodeHash NLeaf
|
||||
termHash (Stem t) =
|
||||
nodeHash (NStem (termHash t))
|
||||
termHash (Fork l r) =
|
||||
nodeHash (NFork (termHash l) (termHash r))
|
||||
|
||||
applyCounted :: T -> T -> ApplyStats -> (T, ApplyStats)
|
||||
applyCounted !f !x !st0 =
|
||||
let !st1 = bump f x st0
|
||||
in applyStepCounted f x st1
|
||||
|
||||
applyStepCounted :: T -> T -> ApplyStats -> (T, ApplyStats)
|
||||
applyStepCounted (Fork Leaf a) _ st =
|
||||
(a, st)
|
||||
applyStepCounted (Fork (Stem a) b) c st =
|
||||
let (!ac, !st1) = applyCounted a c st
|
||||
(!bc, !st2) = applyCounted b c st1
|
||||
in applyCounted ac bc st2
|
||||
applyStepCounted (Fork (Fork a _b) _c) Leaf st =
|
||||
(a, st)
|
||||
applyStepCounted (Fork (Fork _a b) _c) (Stem u) st =
|
||||
applyCounted b u st
|
||||
applyStepCounted (Fork (Fork _a _b) c) (Fork u v) st =
|
||||
let (!cu, !st1) = applyCounted c u st
|
||||
in applyCounted cu v st1
|
||||
applyStepCounted Leaf b st =
|
||||
(Stem b, st)
|
||||
applyStepCounted (Stem a) b st =
|
||||
(Fork a b, st)
|
||||
|
||||
runApplyCounted :: T -> T -> (T, ApplyStats)
|
||||
runApplyCounted !f !x =
|
||||
applyCounted f x emptyApplyStats
|
||||
|
||||
runApplySampled :: Int -> T -> T -> (T, ApplyStats)
|
||||
runApplySampled !n !f !x =
|
||||
applyCounted f x (emptyApplyStatsSampled n)
|
||||
|
||||
runApplySampledWithProgress :: Int -> Int -> T -> T -> (T, ApplyStats)
|
||||
runApplySampledWithProgress !interval !progress !f !x =
|
||||
let st = (emptyApplyStatsSampled interval) { progressEvery = progress }
|
||||
in applyCounted f x st
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Global mutable stats (fast, unsafe, single-threaded only)
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
{-# NOINLINE globalTotalCount #-}
|
||||
globalTotalCount :: IORef Int
|
||||
globalTotalCount = unsafePerformIO (newIORef 0)
|
||||
|
||||
{-# NOINLINE globalInterval #-}
|
||||
globalInterval :: IORef Int
|
||||
globalInterval = unsafePerformIO (newIORef 1)
|
||||
|
||||
{-# NOINLINE globalMap #-}
|
||||
globalMap :: IORef (M.Map AppKey Int)
|
||||
globalMap = unsafePerformIO (newIORef M.empty)
|
||||
|
||||
{-# NOINLINE globalProgress #-}
|
||||
globalProgress :: IORef Int
|
||||
globalProgress = unsafePerformIO (newIORef 0)
|
||||
|
||||
resetGlobalStats :: Int -> Int -> IO ()
|
||||
resetGlobalStats !interval !progress = do
|
||||
writeIORef globalTotalCount 0
|
||||
writeIORef globalInterval (max 1 interval)
|
||||
writeIORef globalMap M.empty
|
||||
writeIORef globalProgress progress
|
||||
|
||||
readGlobalStats :: IO ApplyStats
|
||||
readGlobalStats = do
|
||||
total <- readIORef globalTotalCount
|
||||
m <- readIORef globalMap
|
||||
pure ApplyStats
|
||||
{ totalApplyCalls = total
|
||||
, uniqueApps = m
|
||||
, sampleInterval = 0
|
||||
, sampleCounter = 0
|
||||
, progressEvery = 0
|
||||
}
|
||||
|
||||
{-# INLINE globalBump #-}
|
||||
globalBump :: T -> T -> ()
|
||||
globalBump !f !x = unsafeDupablePerformIO $ do
|
||||
!total <- readIORef globalTotalCount
|
||||
let !total' = total + 1
|
||||
writeIORef globalTotalCount total'
|
||||
!interval <- readIORef globalInterval
|
||||
!progress <- readIORef globalProgress
|
||||
let !_ = if progress > 0 && total' `mod` progress == 0
|
||||
then trace ("apply calls so far: " ++ show total') ()
|
||||
else ()
|
||||
if total' `mod` interval /= 0
|
||||
then pure ()
|
||||
else do
|
||||
let !hf = termHash f
|
||||
!hx = termHash x
|
||||
!k = (hf, hx)
|
||||
!m <- readIORef globalMap
|
||||
writeIORef globalMap (M.insertWith (+) k 1 m)
|
||||
pure ()
|
||||
|
||||
applyGlobalCounted :: T -> T -> T
|
||||
applyGlobalCounted !f !x =
|
||||
let !_ = globalBump f x
|
||||
in applyGlobalStep f x
|
||||
|
||||
applyGlobalStep :: T -> T -> T
|
||||
applyGlobalStep (Fork Leaf a) _ = a
|
||||
applyGlobalStep (Fork (Stem a) b) c =
|
||||
applyGlobalCounted (applyGlobalCounted a c) (applyGlobalCounted b c)
|
||||
applyGlobalStep (Fork (Fork a _b) _c) Leaf = a
|
||||
applyGlobalStep (Fork (Fork _a b) _c) (Stem u) = applyGlobalCounted b u
|
||||
applyGlobalStep (Fork (Fork _a _b) c) (Fork u v) =
|
||||
applyGlobalCounted (applyGlobalCounted c u) v
|
||||
applyGlobalStep Leaf b = Stem b
|
||||
applyGlobalStep (Stem a) b = Fork a b
|
||||
|
||||
runApplyGlobalCounted :: Int -> Int -> T -> T -> IO (T, ApplyStats)
|
||||
runApplyGlobalCounted !interval !progress !f !x = do
|
||||
resetGlobalStats interval progress
|
||||
let !result = applyGlobalCounted f x
|
||||
!stats <- readGlobalStats
|
||||
pure (result, stats)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Printing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
printApplyStats :: ApplyStats -> IO ()
|
||||
printApplyStats st = do
|
||||
let !total = totalApplyCalls st
|
||||
!uniq = M.size (uniqueApps st)
|
||||
!ratio =
|
||||
if uniq == 0
|
||||
then 0 :: Double
|
||||
else fromIntegral total / fromIntegral uniq
|
||||
|
||||
counts =
|
||||
reverse
|
||||
. L.sortBy (comparing snd)
|
||||
. M.toList
|
||||
$ uniqueApps st
|
||||
|
||||
repeated =
|
||||
filter ((> 1) . snd) counts
|
||||
|
||||
top20 = take 20 repeated
|
||||
|
||||
putStrLn $ "total apply calls: " ++ show total
|
||||
putStrLn $ "unique application patterns: " ++ show uniq
|
||||
putStrLn $ "duplication ratio total/unique: " ++ show ratio
|
||||
putStrLn $ "repeated application patterns: " ++ show (length repeated)
|
||||
|
||||
putStrLn "top repeated application counts:"
|
||||
mapM_ printTop top20
|
||||
where
|
||||
short h = T.unpack (T.take 12 h)
|
||||
|
||||
printTop ((hf, hx), n) =
|
||||
putStrLn $
|
||||
" " ++ show n
|
||||
++ "x apply "
|
||||
++ short hf
|
||||
++ " "
|
||||
++ short hx
|
||||
125
bench/Bench.hs
Normal file
125
bench/Bench.hs
Normal file
@@ -0,0 +1,125 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Main where
|
||||
|
||||
import Criterion.Main
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import ApplyStats (runApplyCounted, runApplyGlobalCounted, printApplyStats)
|
||||
import Eval
|
||||
import FileEval
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
-- | Pre-process a demo file and return its AST.
|
||||
loadDemo :: FilePath -> IO [TricuAST]
|
||||
loadDemo = preprocessFile
|
||||
|
||||
-- | Evaluate a pre-processed demo to its result term.
|
||||
runDemo :: [TricuAST] -> T
|
||||
runDemo ast = result (evalTricu Map.empty ast)
|
||||
|
||||
-- | Build an environment from a library file.
|
||||
loadLib :: FilePath -> IO Env
|
||||
loadLib = evaluateFile
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
!equalityAst <- loadDemo "demos/equality.tri"
|
||||
!sizeAst <- loadDemo "demos/size.tri"
|
||||
!toSourceAst <- loadDemo "demos/toSource.tri"
|
||||
!levelOrderAst <- loadDemo "demos/levelOrderTraversal.tri"
|
||||
!patternAst <- loadDemo "demos/patternMatching.tri"
|
||||
!listLib <- loadLib "lib/list.tri"
|
||||
|
||||
-- Stress benchmark environment: Arboricx parser + size + toSource
|
||||
!arboricxLib <- loadLib "lib/arboricx/dispatch.tri"
|
||||
!sizeEnv <- evaluateFileWithContext arboricxLib "demos/size.tri"
|
||||
!toSourceEnv <- evaluateFileWithContext sizeEnv "demos/toSource.tri"
|
||||
|
||||
-- Print apply stats for toSource not?
|
||||
let Just toSource = Map.lookup "toSource" toSourceEnv
|
||||
Just notTerm = Map.lookup "not?" toSourceEnv
|
||||
(_result, stats) = runApplyCounted toSource notTerm
|
||||
printApplyStats stats
|
||||
|
||||
-- Print apply stats for readArboricxContainer against id.arboricx
|
||||
!idBundleBytes <- BS.readFile "test/fixtures/id.arboricx"
|
||||
let Just readContainer = Map.lookup "readArboricxContainer" sizeEnv
|
||||
bundleTree = ofBytes idBundleBytes
|
||||
(_result2, stats2) <- runApplyGlobalCounted 100000 1000000 readContainer bundleTree
|
||||
printApplyStats stats2
|
||||
|
||||
defaultMain
|
||||
[ bgroup "demos"
|
||||
[ bench "equality" $ whnf runDemo equalityAst
|
||||
, bench "size" $ whnf runDemo sizeAst
|
||||
, bench "toSource" $ whnf runDemo toSourceAst
|
||||
, bench "levelOrderTraversal" $ whnf runDemo levelOrderAst
|
||||
, bench "patternMatching" $ whnf runDemo patternAst
|
||||
]
|
||||
|
||||
, bgroup "lib/list.tri"
|
||||
[ bench "append strings" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"append \"Hello, \" \"world!\""
|
||||
, bench "map over 3 elements" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"head (tail (map (a : (t t t)) [(t) (t) (t)]))"
|
||||
, bench "equal? same" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"equal? (t t t) (t t t)"
|
||||
, bench "equal? different" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"equal? (t t) (t t t)"
|
||||
, bench "triage Leaf" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"test t"
|
||||
, bench "triage Stem" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"test (t t)"
|
||||
, bench "triage Fork" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"test (t t t)"
|
||||
, bench "not? true" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"not? (t t)"
|
||||
, bench "not? false" $ whnf
|
||||
(result . evalTricu listLib . parseTricu)
|
||||
"not? t"
|
||||
]
|
||||
|
||||
, bgroup "stress"
|
||||
[ bench "size runArboricxTyped" $ whnf
|
||||
(result . evalTricu sizeEnv . parseTricu)
|
||||
"size runArboricxTyped"
|
||||
, bench "equal? runArboricxTyped runArboricxTyped" $ whnf
|
||||
(result . evalTricu sizeEnv . parseTricu)
|
||||
"equal? runArboricxTyped runArboricxTyped"
|
||||
, bench "size readArboricxBundle" $ whnf
|
||||
(result . evalTricu sizeEnv . parseTricu)
|
||||
"size readArboricxBundle"
|
||||
, bench "equal? readArboricxBundle readArboricxBundle" $ whnf
|
||||
(result . evalTricu sizeEnv . parseTricu)
|
||||
"equal? readArboricxBundle readArboricxBundle"
|
||||
]
|
||||
|
||||
, bgroup "raw-apply"
|
||||
[ bench "rule-1 (Fork Leaf a) b" $ whnf
|
||||
(\n -> apply (Fork Leaf (ofNumber n)) (ofNumber 42))
|
||||
1000
|
||||
, bench "rule-2 (Fork (Stem a) b) c" $ whnf
|
||||
(\n -> apply (Fork (Stem (ofNumber n)) (ofNumber n)) (ofNumber 42))
|
||||
1000
|
||||
, bench "rule-3a (Fork (Fork a b) c) Leaf" $ whnf
|
||||
(\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) Leaf)
|
||||
1000
|
||||
, bench "rule-3b (Fork (Fork a b) c) (Stem u)" $ whnf
|
||||
(\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) (Stem Leaf))
|
||||
1000
|
||||
, bench "rule-3c (Fork (Fork a b) c) (Fork u v)" $ whnf
|
||||
(\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) (Fork Leaf Leaf))
|
||||
1000
|
||||
]
|
||||
|
||||
]
|
||||
@@ -1,5 +1,4 @@
|
||||
!import "../lib/base.tri" !Local
|
||||
!import "../lib/list.tri" !Local
|
||||
!import "../lib/prelude.tri" !Local
|
||||
|
||||
main = lambdaEqualsTC
|
||||
|
||||
|
||||
57
demos/interactionTrees.tri
Normal file
57
demos/interactionTrees.tri
Normal file
@@ -0,0 +1,57 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "../lib/io.tri" !Local
|
||||
|
||||
-- Interaction Tree Effect Runtime
|
||||
--
|
||||
-- The IO system is an interaction-tree effect runtime interpreted by a
|
||||
-- small-step machine with a cooperative scheduler. Primitive actions
|
||||
-- (putStr, readFile, writeFile, ...) are tagged nodes in an interaction
|
||||
-- tree. Sequencing is performed by the single generic `bind` constructor.
|
||||
--
|
||||
-- pure x -- lift a pure value into IO
|
||||
-- bind action k -- run action, then apply k to its result
|
||||
-- thenIO a b -- run a, discard its result, then run b
|
||||
-- mapIO action f -- run action, then apply f to its result inside pure
|
||||
--
|
||||
-- The runtime supports several effects beyond basic IO:
|
||||
-- ask -- read the current environment
|
||||
-- local f action -- run action with environment transformed by f
|
||||
-- get -- read the current mutable state
|
||||
-- put s -- replace the mutable state
|
||||
-- fork action -- spawn a concurrent task, returning a handle
|
||||
-- await handle -- wait for a forked task to complete
|
||||
-- yield -- yield control to the scheduler
|
||||
-- sleep ms -- suspend current task for N milliseconds
|
||||
--
|
||||
-- File operations return a Result tree (see lib/base.tri):
|
||||
-- ok value -- pair true (pair value t)
|
||||
-- err msg -- pair false (pair msg t)
|
||||
--
|
||||
-- Use onReadFile / onWriteFile for convenient branching.
|
||||
--
|
||||
-- See demos/interactionTrees/ for smaller focused examples.
|
||||
|
||||
-- Cooperative async demo.
|
||||
-- fork runs an action in the background.
|
||||
-- sleep suspends the current task for N milliseconds.
|
||||
-- await waits for a forked task and returns its value.
|
||||
--
|
||||
-- Here the child sleeps for 2 s while the parent prints immediately.
|
||||
-- The parent's message appears first, proving interleaving.
|
||||
|
||||
asyncDemo = (
|
||||
bind (fork
|
||||
(bind (sleep 2000) (_ :
|
||||
bind (putStrLn "2000ms done sleeping!") (_ :
|
||||
pure "child2000 done"))))
|
||||
(handle2000 :
|
||||
bind (fork
|
||||
(bind (sleep 5000) (_ :
|
||||
bind (putStrLn "5000ms done sleeping!") (_ :
|
||||
pure "child5000 done"))))
|
||||
(handle5000 :
|
||||
bind (putStrLn "Parent first!") (_ :
|
||||
bind (await handle5000) (_ :
|
||||
await handle2000)))))
|
||||
|
||||
main = io asyncDemo
|
||||
21
demos/interactionTrees/arboricx-server.tri
Normal file
21
demos/interactionTrees/arboricx-server.tri
Normal file
@@ -0,0 +1,21 @@
|
||||
!import "../../lib/io.tri" !Local
|
||||
!import "../../lib/arboricx/server.tri" !Local
|
||||
|
||||
-- Arboricx HTTP registry server demo.
|
||||
-- Run with --allow-write ./store --allow-read ./store
|
||||
--
|
||||
-- Endpoints:
|
||||
-- GET /_arboricx/health -> "OK"
|
||||
-- POST /_arboricx/bundles -> upload bundle, returns hash
|
||||
-- GET /_arboricx/bundle/hash/:h -> download bundle by hash
|
||||
--
|
||||
-- Example usage:
|
||||
-- curl http://localhost:9050/_arboricx/health
|
||||
-- curl -X POST --data-binary @mybundle.arboricx http://localhost:9050/_arboricx/bundles
|
||||
-- curl http://localhost:9050/_arboricx/bundle/hash/<hash>
|
||||
|
||||
main = io (thenIO
|
||||
(putStrLn "Starting Arboricx server on 127.0.0.1:9050")
|
||||
(thenIO
|
||||
(void (ensureStore "/tmp/store"))
|
||||
(arboricxServer "/tmp/store" "127.0.0.1" 9050)))
|
||||
28
demos/interactionTrees/echoServer.tri
Normal file
28
demos/interactionTrees/echoServer.tri
Normal file
@@ -0,0 +1,28 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
!import "../../lib/socket.tri" !Local
|
||||
|
||||
-- Main accept+echo loop. Recursion via y.
|
||||
echoLoop = y (self : server :
|
||||
withAccepted_ server
|
||||
(err :
|
||||
bind (putStrLn (append "accept error: " err)) (_ :
|
||||
self server))
|
||||
(clientSock addr :
|
||||
bind (putStrLn (append "client from " addr)) (_ :
|
||||
onResult_ (recv clientSock 4096)
|
||||
(err :
|
||||
bind (closeSocket clientSock) (_ :
|
||||
self server))
|
||||
(msg :
|
||||
bind (send clientSock msg) (_ :
|
||||
bind (closeSocket clientSock) (_ :
|
||||
self server))))))
|
||||
|
||||
main = io (
|
||||
onOk_ socket (server :
|
||||
onOk_ (bindSocket server "127.0.0.1" 0) (_ :
|
||||
onOk_ (listen server 5) (_ :
|
||||
onOk_ (getSocketName server) (port :
|
||||
bind (putStrLn (append "Echo server listening on port " (showNumber port))) (_ :
|
||||
echoLoop server))))))
|
||||
20
demos/interactionTrees/environment.tri
Normal file
20
demos/interactionTrees/environment.tri
Normal file
@@ -0,0 +1,20 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Environment effects: ask and local.
|
||||
-- ask reads the current environment value.
|
||||
-- local f action runs action with the env transformed by f.
|
||||
--
|
||||
-- The CLI starts with an empty (Leaf) environment. This demo uses
|
||||
-- local to inject a real string so that ask returns something readable.
|
||||
|
||||
main = io <|
|
||||
(bind
|
||||
local (_ : "sandbox")
|
||||
(bind ask (env :
|
||||
bind (putStrLn (append "working in env: " env)) (_ :
|
||||
pure "inside-done"))))
|
||||
(outside :
|
||||
bind (putStrLn (append "local returned: " outside)) (_ :
|
||||
pure t))
|
||||
18
demos/interactionTrees/forkAwait.tri
Normal file
18
demos/interactionTrees/forkAwait.tri
Normal file
@@ -0,0 +1,18 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Basic fork and await.
|
||||
-- fork spawns a concurrent task and returns a handle.
|
||||
-- await blocks until the task completes and returns its value.
|
||||
|
||||
worker = msg :
|
||||
bind (putStrLn (append "working: " msg)) (_ :
|
||||
pure (append msg "-result"))
|
||||
|
||||
main = io <|
|
||||
(bind (fork (worker "job1")) (h1 :
|
||||
bind (fork (worker "job2")) (h2 :
|
||||
bind (await h1) (r1 :
|
||||
bind (await h2) (r2 :
|
||||
putStrLn (append "Got " (append r1 (append " and " r2))))))))
|
||||
25
demos/interactionTrees/getLineAsync.tri
Normal file
25
demos/interactionTrees/getLineAsync.tri
Normal file
@@ -0,0 +1,25 @@
|
||||
-- Manual test for async getLine
|
||||
--
|
||||
-- Run with:
|
||||
-- nix run .# -- eval -f demos/async-getline-test.tri --io
|
||||
--
|
||||
-- Expected behaviour:
|
||||
-- 1. You immediately see:
|
||||
-- Please enter your first name:
|
||||
-- (this printed before you typed anything)
|
||||
-- (this second line also printed before you typed anything)
|
||||
-- 2. You type your name and press Enter.
|
||||
-- 3. You see:
|
||||
-- Hello, <name>!
|
||||
|
||||
!import "../lib/io.tri" !Local
|
||||
|
||||
main = io <|
|
||||
bind (fork getLine) (h :
|
||||
bind (putStr "Please enter your first name: ") (_ :
|
||||
bind (putStr "\n(this printed before you typed anything)\n") (_ :
|
||||
bind (putStr "\n(this second line also printed before you typed anything)\n") (_ :
|
||||
bind (await h) (name :
|
||||
bind (putStr "Hello, ") (_ :
|
||||
bind (putStr name) (_ :
|
||||
putStr "!\n")))))))
|
||||
10
demos/interactionTrees/greet.tri
Normal file
10
demos/interactionTrees/greet.tri
Normal file
@@ -0,0 +1,10 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Greet and return a pure value.
|
||||
-- putStrLn writes to stdout; pure lifts "done" into IO.
|
||||
|
||||
main = io <|
|
||||
bind (putStrLn (append "Hello, " "tricu"))
|
||||
(_ : pure "")
|
||||
16
demos/interactionTrees/httpServer.tri
Normal file
16
demos/interactionTrees/httpServer.tri
Normal file
@@ -0,0 +1,16 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "../lib/io.tri" !Local
|
||||
!import "../lib/socket.tri" !Local
|
||||
!import "../lib/http.tri" !Local
|
||||
|
||||
myRouter = (method path headers body :
|
||||
matchBool
|
||||
(okResponse (append "Hello from " (append path "\n")))
|
||||
(methodNotAllowedResponse)
|
||||
(strEq? method "GET"))
|
||||
|
||||
main = io (
|
||||
onOk_ socket (server :
|
||||
onOk_ (bindSocket server "127.0.0.1" 9050) (_ :
|
||||
onOk_ (listen server 5) (_ :
|
||||
serveForever server (httpHandler myRouter)))))
|
||||
16
demos/interactionTrees/safeRead.tri
Normal file
16
demos/interactionTrees/safeRead.tri
Normal file
@@ -0,0 +1,16 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- readFile returns a Result. matchResult branches on ok / err.
|
||||
-- Run with --allow-read PATH or --unsafe-io.
|
||||
|
||||
safeRead = (path :
|
||||
bind (readFile path)
|
||||
(result :
|
||||
matchResult
|
||||
(err rest : pure "ERROR: Unable to read file")
|
||||
(contents rest : pure contents)
|
||||
result))
|
||||
|
||||
main = io (safeRead "demos/interactionTrees/greet.tri")
|
||||
23
demos/interactionTrees/shout.tri
Normal file
23
demos/interactionTrees/shout.tri
Normal file
@@ -0,0 +1,23 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Transform an IO result.
|
||||
-- mapIO applies a pure function to the value produced by an action.
|
||||
-- Run with --allow-read PATH or --unsafe-io.
|
||||
|
||||
safeRead = (path :
|
||||
bind (readFile path)
|
||||
(result :
|
||||
matchResult
|
||||
(err rest : pure "missing")
|
||||
(contents rest : pure contents)
|
||||
result))
|
||||
|
||||
shout = (path :
|
||||
mapIO (safeRead path)
|
||||
(text : append text "!!!"))
|
||||
|
||||
main = io (bind
|
||||
(shout "demos/interactionTrees/greet.tri")
|
||||
(text : putStrLn text))
|
||||
22
demos/interactionTrees/state.tri
Normal file
22
demos/interactionTrees/state.tri
Normal file
@@ -0,0 +1,22 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Mutable state via get and put.
|
||||
-- get reads the current state.
|
||||
-- put replaces the state.
|
||||
--
|
||||
-- The CLI starts with an empty (Leaf) state. This demo puts
|
||||
-- readable strings and prints them back out.
|
||||
|
||||
main = io <|
|
||||
bind (put "idle") (_ :
|
||||
bind get (s1 :
|
||||
bind (putStrLn (append "state: " s1)) (_ :
|
||||
bind (put "running") (_ :
|
||||
bind get (s2 :
|
||||
bind (putStrLn (append "state: " s2)) (_ :
|
||||
bind (put "done") (_ :
|
||||
bind get (s3 :
|
||||
bind (putStrLn (append "state: " s3)) (_ :
|
||||
pure t)))))))))
|
||||
20
demos/interactionTrees/writeThenRead.tri
Normal file
20
demos/interactionTrees/writeThenRead.tri
Normal file
@@ -0,0 +1,20 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Write a file, then read it back.
|
||||
-- thenIO discards the writeFile Result and continues.
|
||||
-- Run with --unsafe-io (needs both read and write permissions).
|
||||
|
||||
writeThenRead = (path text :
|
||||
thenIO
|
||||
(writeFile path text)
|
||||
(readFile path))
|
||||
|
||||
main = io <|
|
||||
(bind (writeThenRead "/tmp/tricu-demo.txt" "hello from tricu")
|
||||
(result :
|
||||
matchResult
|
||||
(err rest : putStrLn "error")
|
||||
(contents rest : putStrLn contents)
|
||||
result))
|
||||
33
demos/interactionTrees/yield.tri
Normal file
33
demos/interactionTrees/yield.tri
Normal file
@@ -0,0 +1,33 @@
|
||||
!import "../../lib/base.tri" !Local
|
||||
!import "../../lib/list.tri" !Local
|
||||
!import "../../lib/io.tri" !Local
|
||||
|
||||
-- Cooperative scheduling with yield.
|
||||
-- yield returns control to the scheduler so other tasks can run.
|
||||
--
|
||||
-- Two tasks print alternately because each yields after every line.
|
||||
|
||||
--chatter = (name n :
|
||||
-- bind (putStrLn (append name " says 1")) (_ :
|
||||
-- bind yield (_ :
|
||||
-- bind (putStrLn (append name " says 2")) (_ :
|
||||
-- bind yield (_ :
|
||||
-- bind (putStrLn (append name " says 3")) (_ :
|
||||
-- pure n))))))
|
||||
|
||||
chatter = name n : bind <|
|
||||
putStrLn (append name " says 1") (_ :
|
||||
bind yield (_ :
|
||||
bind (putStrLn (append name " says 2")) (_ :
|
||||
bind yield (_ :
|
||||
bind (putStrLn (append name " says 3")) (_ :
|
||||
pure n)))))
|
||||
|
||||
|
||||
main = io <|
|
||||
bind (fork (chatter "A" "doneA")) (ha :
|
||||
bind (fork (chatter "B" "doneB")) (hb :
|
||||
bind yield (_ :
|
||||
bind (await ha) (a :
|
||||
bind (await hb) (b :
|
||||
putStrLn (append "Finished: " (append a (append " " b))))))))
|
||||
@@ -1,5 +1,4 @@
|
||||
!import "../lib/base.tri" Lib
|
||||
!import "../lib/list.tri" !Local
|
||||
!import "../lib/prelude.tri" !Local
|
||||
|
||||
main = exampleTwo
|
||||
-- Level Order Traversal of a labelled binary tree
|
||||
|
||||
25
demos/runArboricxBundle.tri
Normal file
25
demos/runArboricxBundle.tri
Normal file
@@ -0,0 +1,25 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "../lib/io.tri" !Local
|
||||
!import "../lib/arboricx/arboricx.tri" !Local
|
||||
|
||||
-- Read an Arboricx bundle from disk and execute it.
|
||||
-- This demo loads test/fixtures/id.arboricx and applies the
|
||||
-- default export to the string "hi". The id bundle simply
|
||||
-- returns its argument, so the expected output is:
|
||||
-- hi
|
||||
--
|
||||
-- Run with --allow-read test/fixtures/id.arboricx or --unsafe-io.
|
||||
|
||||
runBundle = (path arg :
|
||||
bind (readFile path)
|
||||
(result :
|
||||
matchResult
|
||||
(err rest : putStrLn "ERROR: Could not read bundle file")
|
||||
(bundleBytes rest :
|
||||
matchResult
|
||||
(err rest : putStrLn "ERROR: Could not execute bundle")
|
||||
(value rest : putStrLn value)
|
||||
(runArboricx bundleBytes arg))
|
||||
result))
|
||||
|
||||
main = io (runBundle "test/fixtures/id.arboricx" "hi")
|
||||
@@ -1,5 +1,4 @@
|
||||
!import "../lib/base.tri" !Local
|
||||
!import "../lib/list.tri" !Local
|
||||
!import "../lib/prelude.tri" !Local
|
||||
|
||||
main = size size
|
||||
|
||||
|
||||
@@ -1,5 +1,4 @@
|
||||
!import "../lib/base.tri" !Local
|
||||
!import "../lib/list.tri" !Local
|
||||
!import "../lib/prelude.tri" !Local
|
||||
|
||||
main = toSource not?
|
||||
-- Thanks to intensionality, we can inspect the structure of a given value
|
||||
|
||||
364
docs/arboricx-bundle-format.md
Normal file
364
docs/arboricx-bundle-format.md
Normal file
@@ -0,0 +1,364 @@
|
||||
# Arboricx Portable Bundle Format Specification
|
||||
|
||||
**Version:** 1.1 (Indexed)
|
||||
|
||||
**Status:** Stable
|
||||
|
||||
**Author:** Slopmachines guided by James Eversole
|
||||
|
||||
The Arboricx Portable Bundle is a self-contained binary format for distributing Tree Calculus programs. It uses topological indexing instead of cryptographic hashing for node identity, making it writable from pure Tree Calculus and verifiable via structural inspection.
|
||||
|
||||
## Table of Contents
|
||||
|
||||
1. [Design Principles](#1-design-principles)
|
||||
2. [Top-Level Container Layout](#2-top-level-container-layout)
|
||||
3. [Header](#3-header)
|
||||
4. [Section Directory](#4-section-directory)
|
||||
5. [Section: Manifest (type 1)](#5-section-manifest-type-1)
|
||||
6. [Section: Nodes (type 2)](#6-section-nodes-type-2)
|
||||
7. [Node Payload Format](#7-node-payload-format)
|
||||
8. [Tree Calculus Reduction Semantics](#8-tree-calculus-reduction-semantics)
|
||||
9. [Binary Primitives](#9-binary-primitives)
|
||||
10. [Bundle Verification](#10-bundle-verification)
|
||||
11. [Canonicalization](#11-canonicalization)
|
||||
12. [Known Section Types](#12-known-section-types)
|
||||
|
||||
---
|
||||
|
||||
## 1. Design Principles
|
||||
|
||||
- **No cryptographic primitives required.** Node identity is topological (array index), not a SHA-256 hash.
|
||||
- **Self-contained.** A bundle includes all nodes reachable from its exports. No external references.
|
||||
- **Deterministic.** Canonical bundles produce byte-identical output for identical input terms.
|
||||
- **Small.** ~5 bytes per node entry (length + payload) versus ~36 bytes in hash-based formats.
|
||||
- **Verifiable via structure.** Bounds checking and acyclicity verification replace hash recomputation.
|
||||
|
||||
Global artifact identity (for registries, lockfiles, or content-addressed caches) is achieved by hashing the complete canonical bundle file externally. The bundle format itself knows nothing about this hash.
|
||||
|
||||
---
|
||||
|
||||
## 2. Top-Level Container Layout
|
||||
|
||||
```
|
||||
+------------------+------------------+------------------+------------------+
|
||||
| Header | Section Directory| Manifest Section | Nodes Section |
|
||||
| (32 bytes) | (N × 32 bytes) | (variable) | (variable) |
|
||||
+------------------+------------------+------------------+------------------+
|
||||
```
|
||||
|
||||
Total bundle size = 32 + (sectionCount × 32) + manifestSize + nodesSize
|
||||
|
||||
All multi-byte integers use **big-endian** byte order.
|
||||
|
||||
---
|
||||
|
||||
## 3. Header
|
||||
|
||||
| Offset | Size | Field | Description |
|
||||
|--------|------|-------|-------------|
|
||||
| 0 | 8 bytes | Magic | ASCII `"ARBORICX"` |
|
||||
| 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 to the section directory (always `32`) |
|
||||
|
||||
---
|
||||
|
||||
## 4. Section Directory
|
||||
|
||||
Array of `N` entries, each exactly **32 bytes**.
|
||||
|
||||
| Offset (within entry) | Size | Field | Description |
|
||||
|----------------------|------|-------|-------------|
|
||||
| 0 | 4 bytes | Type | `u32` BE. Section type identifier |
|
||||
| 4 | 2 bytes | Version | `u16` BE. Section-specific version |
|
||||
| 6 | 2 bytes | Flags | `u16` BE. Bit 0 (`0x0001`) = critical section |
|
||||
| 8 | 2 bytes | Compression | `u16` BE. `0` = none (currently the only value) |
|
||||
| 10 | 2 bytes | Reserved | `u16` BE. Padding; must be zero |
|
||||
| 12 | 8 bytes | Offset | `u64` BE. Byte offset from bundle start to section data |
|
||||
| 20 | 8 bytes | Length | `u64` BE. Length of section data in bytes |
|
||||
| 28 | 4 bytes | Reserved | Padding; must be zero |
|
||||
|
||||
**Verification:**
|
||||
- Unknown critical sections are rejected.
|
||||
- Compression must be `0` (none).
|
||||
- Reserved fields must be zero.
|
||||
|
||||
**Note:** No per-section digest is stored. Integrity is verified at the distribution layer (e.g. SHA-256 of the complete bundle file) rather than inside the container.
|
||||
|
||||
---
|
||||
|
||||
## 5. Section: Manifest (type 1)
|
||||
|
||||
Binary encoding of bundle metadata. Fixed-order core layout followed by optional TLV tail.
|
||||
|
||||
```
|
||||
Manifest =
|
||||
magic 8 bytes "ARBMNFST"
|
||||
major u16 BE Manifest major version (1)
|
||||
minor u16 BE Manifest minor version (1)
|
||||
|
||||
schema string "arboricx.bundle.manifest.v1"
|
||||
bundleType string "tree-calculus-executable-object"
|
||||
|
||||
treeCalculus string "tree-calculus.v1"
|
||||
treeHashAlgorithm string "indexed"
|
||||
treeHashDomain string "arboricx.indexed.node.v1"
|
||||
treeNodePayload string "arboricx.indexed.payload.v1"
|
||||
|
||||
runtimeSemantics string "tree-calculus.v1"
|
||||
runtimeEvaluation string "normal-order"
|
||||
runtimeAbi string "arboricx.abi.tree.v1"
|
||||
capabilityCount u32 BE Number of capability strings (currently 0)
|
||||
capabilities string[] Array of length-prefixed UTF-8 strings
|
||||
|
||||
closure u8 0 = complete
|
||||
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 (currently 0)
|
||||
extensionFields TLV[] Extension entries (skipped by parsers)
|
||||
```
|
||||
|
||||
### String Format
|
||||
|
||||
```
|
||||
string =
|
||||
length u32 BE Number of UTF-8 bytes
|
||||
bytes byte[length] UTF-8 content
|
||||
```
|
||||
|
||||
### Root Entry
|
||||
|
||||
```
|
||||
Root =
|
||||
index u32 BE Node index into the nodes section
|
||||
role string Length-prefixed UTF-8 ("default" for first root, "root" for others)
|
||||
```
|
||||
|
||||
### Export Entry
|
||||
|
||||
```
|
||||
Export =
|
||||
name string Length-prefixed UTF-8 export identifier
|
||||
root u32 BE Node index into the nodes section
|
||||
kind string Length-prefixed UTF-8 (currently "term")
|
||||
abi string Length-prefixed UTF-8 ABI string
|
||||
```
|
||||
|
||||
### TLV Entry
|
||||
|
||||
```
|
||||
TLV =
|
||||
tag u16 BE Tag identifier
|
||||
length u32 BE Value length in bytes
|
||||
value byte[length]
|
||||
```
|
||||
|
||||
### Metadata Tags
|
||||
|
||||
| Tag | Name | Value |
|
||||
|-----|------|-------|
|
||||
| 1 | package | UTF-8 text |
|
||||
| 2 | version | UTF-8 text |
|
||||
| 3 | description | UTF-8 text |
|
||||
| 4 | license | UTF-8 text |
|
||||
| 5 | createdBy | UTF-8 text |
|
||||
|
||||
Unknown metadata tags are ignored. Unknown extension tags are skipped by length.
|
||||
|
||||
### Semantic Constraints
|
||||
|
||||
| Constraint | Value |
|
||||
|-----------|-------|
|
||||
| `schema` | `"arboricx.bundle.manifest.v1"` |
|
||||
| `bundleType` | `"tree-calculus-executable-object"` |
|
||||
| `treeCalculus` | `"tree-calculus.v1"` |
|
||||
| `treeHashAlgorithm` | `"indexed"` |
|
||||
| `treeHashDomain` | `"arboricx.indexed.node.v1"` |
|
||||
| `treeNodePayload` | `"arboricx.indexed.payload.v1"` |
|
||||
| `runtimeSemantics` | `"tree-calculus.v1"` |
|
||||
| `runtimeAbi` | `"arboricx.abi.tree.v1"` |
|
||||
| `closure` | `0` (complete) |
|
||||
| `rootCount` | At least 1 |
|
||||
| `exportCount` | At least 1 |
|
||||
|
||||
---
|
||||
|
||||
## 6. Section: Nodes (type 2)
|
||||
|
||||
```
|
||||
NodesSection =
|
||||
nodeCount u64 BE Total number of node entries
|
||||
entries NodeEntry[]
|
||||
```
|
||||
|
||||
### Node Entry
|
||||
|
||||
```
|
||||
NodeEntry =
|
||||
payloadLen u32 BE Length of payload in bytes
|
||||
payload byte[payloadLen]
|
||||
```
|
||||
|
||||
There is **no hash field**. The node is identified solely by its position in the array.
|
||||
|
||||
---
|
||||
|
||||
## 7. Node Payload Format
|
||||
|
||||
Child references are `u32` big-endian indices into the node array. The array **must** be topologically sorted: every child index must be strictly less than the entry's own position.
|
||||
|
||||
### Leaf
|
||||
|
||||
```
|
||||
Payload = 0x00
|
||||
```
|
||||
|
||||
Exactly 1 byte.
|
||||
|
||||
### Stem
|
||||
|
||||
```
|
||||
Payload = 0x01 || child_index (u32 BE)
|
||||
```
|
||||
|
||||
Exactly 5 bytes.
|
||||
|
||||
### Fork
|
||||
|
||||
```
|
||||
Payload = 0x02 || left_index (u32 BE) || right_index (u32 BE)
|
||||
```
|
||||
|
||||
Exactly 9 bytes.
|
||||
|
||||
---
|
||||
|
||||
## 8. Tree Calculus Reduction Semantics
|
||||
|
||||
The bundle represents a **Tree Calculus** term. The reduction rules are:
|
||||
|
||||
```
|
||||
The t operator is left associative.
|
||||
1. t t a b -> a
|
||||
2. t (t a) b c -> a c (b c)
|
||||
3a. t (t a b) c t -> a
|
||||
3b. t (t a b) c (t u) -> b u
|
||||
3c. t (t a b) c (t u v) -> c u v
|
||||
```
|
||||
|
||||
**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
|
||||
|
||||
### u8
|
||||
|
||||
Single byte, value `0-255`.
|
||||
|
||||
### u16 (2 bytes)
|
||||
|
||||
```
|
||||
value = (byte[0] << 8) | byte[1]
|
||||
```
|
||||
|
||||
### u32 (4 bytes)
|
||||
|
||||
```
|
||||
value = (byte[0] << 24) | (byte[1] << 16) | (byte[2] << 8) | byte[3]
|
||||
```
|
||||
|
||||
### u64 (8 bytes)
|
||||
|
||||
```
|
||||
value = (byte[0] << 56) | ... | byte[7]
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## 10. Bundle Verification
|
||||
|
||||
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. Verify reserved fields are zero.
|
||||
4. **Manifest parsing:** Decode fixed-order manifest; validate semantic constraints.
|
||||
5. **Nodes section:** Parse all entries.
|
||||
6. **Bounds checking:**
|
||||
- Every root index `< nodeCount`
|
||||
- Every export index `< nodeCount`
|
||||
- In every Stem payload, `child_index < entry_position` and `child_index < nodeCount`
|
||||
- In every Fork payload, both indices `< entry_position` and `< nodeCount`
|
||||
7. **Acyclicity:** Guaranteed by the `child < parent` rule above.
|
||||
8. **Closure:** Traverse from all root/export indices; confirm every reached index is valid.
|
||||
|
||||
No hash computation is required.
|
||||
|
||||
---
|
||||
|
||||
## 11. Canonicalization
|
||||
|
||||
A bundle is **canonical** iff:
|
||||
|
||||
1. **Maximal deduplication.** No two entries represent structurally identical subtrees.
|
||||
2. **Topological order.** Children precede parents.
|
||||
3. **Deterministic post-order traversal.** Nodes are emitted in the order discovered by a left-to-right recursive post-order walk.
|
||||
4. **No trailing bytes** in any section.
|
||||
5. **Reserved fields are zero.**
|
||||
|
||||
Canonical bundles produce deterministic bytes and can be file-level hashed for global identity.
|
||||
|
||||
---
|
||||
|
||||
## 12. Known Section Types
|
||||
|
||||
| Type | Name | Required | Version | Description |
|
||||
|------|------|----------|---------|-------------|
|
||||
| 1 | Manifest | Yes | 1 | Bundle metadata |
|
||||
| 2 | Nodes | Yes | 1 | Topological DAG node entries |
|
||||
|
||||
Unknown section types are permitted if not marked critical.
|
||||
|
||||
---
|
||||
|
||||
## Appendix A: Complete Example Layout
|
||||
|
||||
A minimal bundle for `Stem(Leaf)` (the Tree Calculus encoding of `t t`):
|
||||
|
||||
```
|
||||
+---------------------------------------------------+
|
||||
| Header (32 bytes) |
|
||||
| Magic: "ARBORICX" |
|
||||
| Major: 1, Minor: 0 |
|
||||
| Section count: 2 |
|
||||
| Flags: 0 |
|
||||
| Dir offset: 32 |
|
||||
+---------------------------------------------------+
|
||||
| Section Directory (64 bytes = 2 × 32) |
|
||||
| Entry 0: type=1 (manifest), offset=96, len=~200 |
|
||||
| Entry 1: type=2 (nodes), offset=~296, len=10 |
|
||||
+---------------------------------------------------+
|
||||
| Manifest Section (~200 bytes) |
|
||||
| Magic: "ARBMNFST", Version: 1.1 |
|
||||
| Schema, bundleType, tree spec, runtime spec |
|
||||
| Closure: 0, Roots: [1], Exports: ["main" -> 1] |
|
||||
| Metadata TLVs, zero extension fields |
|
||||
+---------------------------------------------------+
|
||||
| Nodes Section (10 bytes) |
|
||||
| Node count: 2 |
|
||||
| Entry 0: payloadLen=1, payload=[0x00] |
|
||||
| Entry 1: payloadLen=5, payload=[0x01, 0,0,0,0] |
|
||||
+---------------------------------------------------+
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## Appendix B: File Extension
|
||||
|
||||
Bundles use the `.arboricx` file extension. Plain source files use `.tri`.
|
||||
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.
|
||||
1
ext/js/.gitignore
vendored
Normal file
1
ext/js/.gitignore
vendored
Normal file
@@ -0,0 +1 @@
|
||||
node_modules
|
||||
29
ext/js/package-lock.json
generated
Normal file
29
ext/js/package-lock.json
generated
Normal file
@@ -0,0 +1,29 @@
|
||||
{
|
||||
"name": "arboricx-runtime",
|
||||
"version": "0.1.0",
|
||||
"lockfileVersion": 3,
|
||||
"requires": true,
|
||||
"packages": {
|
||||
"": {
|
||||
"name": "arboricx-runtime",
|
||||
"version": "0.1.0",
|
||||
"license": "MIT",
|
||||
"dependencies": {
|
||||
"koffi": "^2.16.2"
|
||||
},
|
||||
"bin": {
|
||||
"arboricx-run": "src/cli.js"
|
||||
}
|
||||
},
|
||||
"node_modules/koffi": {
|
||||
"version": "2.16.2",
|
||||
"resolved": "https://registry.npmjs.org/koffi/-/koffi-2.16.2.tgz",
|
||||
"integrity": "sha512-owU0MRwv6xkrVqCd+33uw6BaYppkTRXbO/rVdJNI2dvZG0gzyRhYwW25eWtc5pauwK8TGh3AbkFONSezdykfSA==",
|
||||
"hasInstallScript": true,
|
||||
"license": "MIT",
|
||||
"funding": {
|
||||
"url": "https://liberapay.com/Koromix"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
20
ext/js/package.json
Normal file
20
ext/js/package.json
Normal file
@@ -0,0 +1,20 @@
|
||||
{
|
||||
"name": "arboricx-runtime",
|
||||
"version": "0.1.0",
|
||||
"description": "Arboricx portable bundle runtime — JavaScript host via libarboricx FFI",
|
||||
"type": "module",
|
||||
"main": "src/lib.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"
|
||||
},
|
||||
"dependencies": {
|
||||
"koffi": "^2.16.0"
|
||||
},
|
||||
"keywords": ["arboricx", "tree-calculus", "trie", "runtime", "ffi"],
|
||||
"license": "MIT"
|
||||
}
|
||||
104
ext/js/src/cli.js
Normal file
104
ext/js/src/cli.js
Normal file
@@ -0,0 +1,104 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* cli.js — Arboricx JS host shell via libarboricx C ABI.
|
||||
*
|
||||
* Usage:
|
||||
* node cli.js inspect <bundle.arboricx>
|
||||
* node cli.js run <bundle.arboricx> [args...]
|
||||
*/
|
||||
|
||||
import { readFileSync } from 'node:fs';
|
||||
import {
|
||||
init,
|
||||
free,
|
||||
loadBundleDefault,
|
||||
reduce,
|
||||
app,
|
||||
ofNumber,
|
||||
ofString,
|
||||
decode,
|
||||
decodeType,
|
||||
findLib,
|
||||
} from './lib.js';
|
||||
|
||||
// ── Commands ─────────────────────────────────────────────────────────────────
|
||||
|
||||
function cmdInspect(bundlePath) {
|
||||
const ctx = init();
|
||||
try {
|
||||
const bundle = readFileSync(bundlePath);
|
||||
console.log(`Bundle: ${bundlePath}`);
|
||||
console.log(`Size: ${bundle.length} bytes\n`);
|
||||
|
||||
const term = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, term);
|
||||
|
||||
const type = decodeType(ctx, result);
|
||||
let value;
|
||||
try {
|
||||
value = decode(ctx, result);
|
||||
} catch {
|
||||
value = '(raw tree)';
|
||||
}
|
||||
|
||||
console.log(`Type: ${type}`);
|
||||
console.log(`Value: ${value}`);
|
||||
} catch (e) {
|
||||
console.error(`Error: ${e.message}`);
|
||||
process.exit(1);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
}
|
||||
|
||||
function cmdRun(bundlePath, args) {
|
||||
const ctx = init();
|
||||
try {
|
||||
const bundle = readFileSync(bundlePath);
|
||||
let term = loadBundleDefault(ctx, bundle);
|
||||
|
||||
for (const arg of args) {
|
||||
const argTree = /^\d+$/.test(arg) ? ofNumber(ctx, BigInt(arg)) : ofString(ctx, arg);
|
||||
term = app(ctx, term, argTree);
|
||||
}
|
||||
|
||||
const result = reduce(ctx, term);
|
||||
console.log(decode(ctx, result));
|
||||
} catch (e) {
|
||||
console.error(`Error: ${e.message}`);
|
||||
process.exit(1);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
}
|
||||
|
||||
// ── 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.arboricx>');
|
||||
process.exit(1);
|
||||
}
|
||||
cmdInspect(args[1]);
|
||||
break;
|
||||
}
|
||||
case 'run': {
|
||||
if (args.length < 2) {
|
||||
console.error('Usage: node cli.js run <bundle.arboricx> [args...]');
|
||||
process.exit(1);
|
||||
}
|
||||
cmdRun(args[1], args.slice(2));
|
||||
break;
|
||||
}
|
||||
default:
|
||||
console.log('Arboricx JS Host (via libarboricx FFI)');
|
||||
console.log('');
|
||||
console.log('Usage:');
|
||||
console.log(' node cli.js inspect <bundle.arboricx>');
|
||||
console.log(' node cli.js run <bundle.arboricx> [args...]');
|
||||
break;
|
||||
}
|
||||
224
ext/js/src/lib.js
Normal file
224
ext/js/src/lib.js
Normal file
@@ -0,0 +1,224 @@
|
||||
/**
|
||||
* lib.js — FFI wrapper around libarboricx.so via koffi.
|
||||
*
|
||||
* Exports low-level C ABI bindings and high-level helpers.
|
||||
*/
|
||||
|
||||
import { existsSync } from 'node:fs';
|
||||
import { dirname, join, resolve } from 'node:path';
|
||||
import { fileURLToPath } from 'node:url';
|
||||
import koffi from 'koffi';
|
||||
|
||||
const __dirname = dirname(fileURLToPath(import.meta.url));
|
||||
|
||||
koffi.opaque('arb_ctx_t');
|
||||
|
||||
// ── Library discovery ───────────────────────────────────────────────────────
|
||||
|
||||
export function findLib() {
|
||||
const env = process.env.ARBORICX_LIB;
|
||||
if (env) {
|
||||
if (existsSync(env)) return env;
|
||||
throw new Error(`ARBORICX_LIB set but file not found: ${env}`);
|
||||
}
|
||||
|
||||
const candidates = [
|
||||
resolve(__dirname, 'libarboricx.so'),
|
||||
'libarboricx.so',
|
||||
'./libarboricx.so',
|
||||
'/usr/local/lib/libarboricx.so',
|
||||
'/usr/lib/libarboricx.so',
|
||||
];
|
||||
|
||||
for (const p of candidates) {
|
||||
if (existsSync(p)) return p;
|
||||
}
|
||||
|
||||
throw new Error('libarboricx.so not found. Set ARBORICX_LIB to its full path.');
|
||||
}
|
||||
|
||||
// ── FFI setup ───────────────────────────────────────────────────────────────
|
||||
|
||||
let _lib = null;
|
||||
let _libPath = null;
|
||||
|
||||
function ensureLib() {
|
||||
if (_lib) return _lib;
|
||||
const path = findLib();
|
||||
_lib = koffi.load(path);
|
||||
_libPath = path;
|
||||
return _lib;
|
||||
}
|
||||
|
||||
export function loadLib(path) {
|
||||
if (_lib && _libPath === path) return;
|
||||
_lib = koffi.load(path);
|
||||
_libPath = path;
|
||||
}
|
||||
|
||||
function getLib() {
|
||||
if (_lib) return _lib;
|
||||
return ensureLib();
|
||||
}
|
||||
|
||||
// ── Context lifecycle ───────────────────────────────────────────────────────
|
||||
|
||||
export function init(libPath) {
|
||||
if (libPath) loadLib(libPath);
|
||||
const lib = getLib();
|
||||
const ctx = lib.func('arb_ctx_t *arboricx_init(void)')();
|
||||
if (!ctx) throw new Error('arboricx_init failed');
|
||||
return ctx;
|
||||
}
|
||||
|
||||
export function free(ctx) {
|
||||
getLib().func('void arboricx_free(arb_ctx_t *ctx)')(ctx);
|
||||
}
|
||||
|
||||
// ── Bundle loading ──────────────────────────────────────────────────────────
|
||||
|
||||
export function loadBundle(ctx, bytes, name) {
|
||||
const result = getLib().func('uint32_t arb_load_bundle(arb_ctx_t *ctx, _In_ uint8_t *bytes, size_t len, const char *name)')(ctx, bytes, bytes.length, name);
|
||||
if (result === 0) throw new Error(`arb_load_bundle failed for export "${name}"`);
|
||||
return result;
|
||||
}
|
||||
|
||||
export function loadBundleDefault(ctx, bytes) {
|
||||
const result = getLib().func('uint32_t arb_load_bundle_default(arb_ctx_t *ctx, _In_ uint8_t *bytes, size_t len)')(ctx, bytes, bytes.length);
|
||||
if (result === 0) throw new Error('arb_load_bundle_default failed');
|
||||
return result;
|
||||
}
|
||||
|
||||
// ── Reduction ───────────────────────────────────────────────────────────────
|
||||
|
||||
export function reduce(ctx, root, fuel = 1_000_000_000n) {
|
||||
const f = getLib().func('uint32_t arb_reduce(arb_ctx_t *ctx, uint32_t root, uint64_t fuel)');
|
||||
return f(ctx, root, typeof fuel === 'bigint' ? fuel : BigInt(fuel));
|
||||
}
|
||||
|
||||
// ── Tree construction ───────────────────────────────────────────────────────
|
||||
|
||||
export function leaf(ctx) {
|
||||
return getLib().func('uint32_t arb_leaf(arb_ctx_t *ctx)')(ctx);
|
||||
}
|
||||
|
||||
export function stem(ctx, child) {
|
||||
return getLib().func('uint32_t arb_stem(arb_ctx_t *ctx, uint32_t child)')(ctx, child);
|
||||
}
|
||||
|
||||
export function fork(ctx, left, right) {
|
||||
return getLib().func('uint32_t arb_fork(arb_ctx_t *ctx, uint32_t left, uint32_t right)')(ctx, left, right);
|
||||
}
|
||||
|
||||
export function app(ctx, func, arg) {
|
||||
return getLib().func('uint32_t arb_app(arb_ctx_t *ctx, uint32_t func, uint32_t arg)')(ctx, func, arg);
|
||||
}
|
||||
|
||||
// ── Codec constructors ──────────────────────────────────────────────────────
|
||||
|
||||
export function ofNumber(ctx, n) {
|
||||
const big = typeof n === 'bigint' ? n : BigInt(n);
|
||||
return getLib().func('uint32_t arb_of_number(arb_ctx_t *ctx, uint64_t n)')(ctx, big);
|
||||
}
|
||||
|
||||
export function ofString(ctx, s) {
|
||||
return getLib().func('uint32_t arb_of_string(arb_ctx_t *ctx, const char *s)')(ctx, s);
|
||||
}
|
||||
|
||||
export function ofBytes(ctx, bytes) {
|
||||
return getLib().func('uint32_t arb_of_bytes(arb_ctx_t *ctx, _In_ uint8_t *bytes, size_t len)')(ctx, bytes, bytes.length);
|
||||
}
|
||||
|
||||
export function ofList(ctx, items) {
|
||||
const arr = new Uint32Array(items);
|
||||
return getLib().func('uint32_t arb_of_list(arb_ctx_t *ctx, _In_ uint32_t *items, size_t len)')(ctx, arr, arr.length);
|
||||
}
|
||||
|
||||
// ── Codec destructors ───────────────────────────────────────────────────────
|
||||
|
||||
export function toNumber(ctx, root) {
|
||||
const out = [0];
|
||||
const ok = getLib().func('int arb_to_number(arb_ctx_t *ctx, uint32_t root, _Out_ uint64_t *out)')(ctx, root, out);
|
||||
if (!ok) throw new Error('arb_to_number failed');
|
||||
return typeof out[0] === 'bigint' ? Number(out[0]) : out[0];
|
||||
}
|
||||
|
||||
export function toString(ctx, root) {
|
||||
const ptrOut = [null];
|
||||
const lenOut = [0];
|
||||
const ok = getLib().func('int arb_to_string(arb_ctx_t *ctx, uint32_t root, _Out_ uint8_t **out_ptr, _Out_ size_t *out_len)')(ctx, root, ptrOut, lenOut);
|
||||
if (!ok) throw new Error('arb_to_string failed');
|
||||
|
||||
const bytes = koffi.decode(ptrOut[0], 'uint8_t', lenOut[0]);
|
||||
const str = Buffer.from(bytes).toString('utf-8');
|
||||
getLib().func('void arboricx_free_buf(arb_ctx_t *ctx, uint8_t *ptr, size_t len)')(ctx, ptrOut[0], lenOut[0]);
|
||||
return str;
|
||||
}
|
||||
|
||||
export function toBytes(ctx, root) {
|
||||
const ptrOut = [null];
|
||||
const lenOut = [0];
|
||||
const ok = getLib().func('int arb_to_bytes(arb_ctx_t *ctx, uint32_t root, _Out_ uint8_t **out_ptr, _Out_ size_t *out_len)')(ctx, root, ptrOut, lenOut);
|
||||
if (!ok) throw new Error('arb_to_bytes failed');
|
||||
|
||||
const bytes = Buffer.from(koffi.decode(ptrOut[0], 'uint8_t', lenOut[0]));
|
||||
getLib().func('void arboricx_free_buf(arb_ctx_t *ctx, uint8_t *ptr, size_t len)')(ctx, ptrOut[0], lenOut[0]);
|
||||
return bytes;
|
||||
}
|
||||
|
||||
export function toBool(ctx, root) {
|
||||
const out = [0];
|
||||
const ok = getLib().func('int arb_to_bool(arb_ctx_t *ctx, uint32_t root, _Out_ int *out)')(ctx, root, out);
|
||||
if (!ok) throw new Error('arb_to_bool failed');
|
||||
return out[0] !== 0;
|
||||
}
|
||||
|
||||
// ── Result unwrapping ───────────────────────────────────────────────────────
|
||||
|
||||
export function unwrapResult(ctx, root) {
|
||||
const outOk = [0];
|
||||
const outValue = [0];
|
||||
const outRest = [0];
|
||||
const ok = getLib().func('int arb_unwrap_result(arb_ctx_t *ctx, uint32_t root, _Out_ int *out_ok, _Out_ uint32_t *out_value, _Out_ uint32_t *out_rest)')(ctx, root, outOk, outValue, outRest);
|
||||
if (!ok) throw new Error('arb_unwrap_result failed');
|
||||
return { ok: outOk[0] !== 0, value: outValue[0], rest: outRest[0] };
|
||||
}
|
||||
|
||||
export function unwrapHostValue(ctx, root) {
|
||||
const outTag = [0n];
|
||||
const outPayload = [0];
|
||||
const ok = getLib().func('int arb_unwrap_host_value(arb_ctx_t *ctx, uint32_t root, _Out_ uint64_t *out_tag, _Out_ uint32_t *out_payload)')(ctx, root, outTag, outPayload);
|
||||
if (!ok) throw new Error('arb_unwrap_host_value failed');
|
||||
return { tag: outTag[0], payload: outPayload[0] };
|
||||
}
|
||||
|
||||
// ── Kernel ──────────────────────────────────────────────────────────────────
|
||||
|
||||
export function kernelRoot(ctx) {
|
||||
return getLib().func('uint32_t arb_kernel_root(arb_ctx_t *ctx)')(ctx);
|
||||
}
|
||||
|
||||
// ── High-level helpers ──────────────────────────────────────────────────────
|
||||
|
||||
export function decode(ctx, root) {
|
||||
try {
|
||||
return toBool(ctx, root) ? 'true' : 'false';
|
||||
} catch {
|
||||
try {
|
||||
return toString(ctx, root);
|
||||
} catch {
|
||||
try {
|
||||
return String(toNumber(ctx, root));
|
||||
} catch {
|
||||
throw new Error('could not decode result');
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
export function decodeType(ctx, root) {
|
||||
try { toBool(ctx, root); return 'bool'; } catch {}
|
||||
try { toString(ctx, root); return 'string'; } catch {}
|
||||
try { toNumber(ctx, root); return 'number'; } catch {}
|
||||
return 'unknown (raw tree)';
|
||||
}
|
||||
93
ext/js/test/bundle.test.js
Normal file
93
ext/js/test/bundle.test.js
Normal file
@@ -0,0 +1,93 @@
|
||||
import { readFileSync } from 'node:fs';
|
||||
import { strictEqual, ok, throws } from 'node:assert';
|
||||
import { describe, it } from 'node:test';
|
||||
import {
|
||||
findLib,
|
||||
init,
|
||||
free,
|
||||
loadBundle,
|
||||
loadBundleDefault,
|
||||
kernelRoot,
|
||||
} from '../src/lib.js';
|
||||
|
||||
const fixtureDir = '../../test/fixtures';
|
||||
const libPath = findLib();
|
||||
|
||||
describe('library discovery', () => {
|
||||
it('findLib returns an existing .so path', () => {
|
||||
ok(libPath.endsWith('.so') || libPath.endsWith('.dylib') || libPath.endsWith('.dll'));
|
||||
ok(readFileSync(libPath));
|
||||
});
|
||||
});
|
||||
|
||||
describe('context lifecycle', () => {
|
||||
it('init creates a valid context', () => {
|
||||
const ctx = init(libPath);
|
||||
ok(ctx);
|
||||
free(ctx);
|
||||
});
|
||||
|
||||
it('kernel root is available', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const root = kernelRoot(ctx);
|
||||
ok(root > 0, 'kernel root should be a positive index');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('bundle loading', () => {
|
||||
it('loadBundleDefault loads id.arboricx', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
ok(root > 0, 'loaded root should be a positive index');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('loadBundleDefault loads true.arboricx', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/true.arboricx`);
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
ok(root > 0);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('loadBundle loads named export from id.arboricx', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const root = loadBundle(ctx, bundle, 'id');
|
||||
ok(root > 0);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('loadBundle fails for missing export name', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
throws(() => loadBundle(ctx, bundle, 'nonexistent'), /failed/);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('loadBundleDefault fails for invalid bytes', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
throws(() => loadBundleDefault(ctx, Buffer.from('not a bundle')), /failed/);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
113
ext/js/test/reduce.test.js
Normal file
113
ext/js/test/reduce.test.js
Normal file
@@ -0,0 +1,113 @@
|
||||
import { readFileSync } from 'node:fs';
|
||||
import { strictEqual, ok } from 'node:assert';
|
||||
import { describe, it } from 'node:test';
|
||||
import {
|
||||
findLib,
|
||||
init,
|
||||
free,
|
||||
leaf,
|
||||
stem,
|
||||
fork,
|
||||
app,
|
||||
reduce,
|
||||
toBool,
|
||||
toString,
|
||||
toNumber,
|
||||
loadBundleDefault,
|
||||
ofString,
|
||||
ofNumber,
|
||||
} from '../src/lib.js';
|
||||
|
||||
const libPath = findLib();
|
||||
|
||||
describe('tree construction', () => {
|
||||
it('leaf returns a positive index', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const idx = leaf(ctx);
|
||||
ok(idx > 0);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('stem wraps a child', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const l = leaf(ctx);
|
||||
const s = stem(ctx, l);
|
||||
ok(s > 0);
|
||||
ok(s !== l);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('fork combines left and right', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const a = leaf(ctx);
|
||||
const b = leaf(ctx);
|
||||
const f = fork(ctx, a, b);
|
||||
ok(f > 0);
|
||||
ok(f !== a && f !== b);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('reduction — booleans', () => {
|
||||
it('true.arboricx reduces to boolean true', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync('../../test/fixtures/true.arboricx');
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, root, 1_000_000n);
|
||||
strictEqual(toBool(ctx, result), true);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('false.arboricx reduces to boolean false', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync('../../test/fixtures/false.arboricx');
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, root, 1_000_000n);
|
||||
strictEqual(toBool(ctx, result), false);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('reduction — id', () => {
|
||||
it('id applied to string returns the string', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync('../../test/fixtures/id.arboricx');
|
||||
const idRoot = loadBundleDefault(ctx, bundle);
|
||||
const arg = ofString(ctx, 'hello');
|
||||
const applied = app(ctx, idRoot, arg);
|
||||
const result = reduce(ctx, applied, 1_000_000n);
|
||||
strictEqual(toString(ctx, result), 'hello');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('reduction — numbers', () => {
|
||||
it('ofNumber round-trips through toNumber', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const num = ofNumber(ctx, 42);
|
||||
strictEqual(toNumber(ctx, num), 42);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
125
ext/js/test/run-bundle.test.js
Normal file
125
ext/js/test/run-bundle.test.js
Normal file
@@ -0,0 +1,125 @@
|
||||
import { readFileSync } from 'node:fs';
|
||||
import { strictEqual, ok, throws } from 'node:assert';
|
||||
import { describe, it } from 'node:test';
|
||||
import {
|
||||
findLib,
|
||||
init,
|
||||
free,
|
||||
loadBundleDefault,
|
||||
loadBundle,
|
||||
reduce,
|
||||
app,
|
||||
ofString,
|
||||
ofNumber,
|
||||
toBool,
|
||||
toString,
|
||||
decode,
|
||||
decodeType,
|
||||
} from '../src/lib.js';
|
||||
|
||||
const fixtureDir = '../../test/fixtures';
|
||||
const libPath = findLib();
|
||||
|
||||
describe('run bundle — booleans', () => {
|
||||
it('true.arboricx evaluates to true', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/true.arboricx`);
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, root);
|
||||
strictEqual(toBool(ctx, result), true);
|
||||
strictEqual(decodeType(ctx, result), 'bool');
|
||||
strictEqual(decode(ctx, result), 'true');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('false.arboricx evaluates to false', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/false.arboricx`);
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, root);
|
||||
strictEqual(toBool(ctx, result), false);
|
||||
strictEqual(decodeType(ctx, result), 'bool');
|
||||
strictEqual(decode(ctx, result), 'false');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('run bundle — id', () => {
|
||||
it('id applied to string returns the string', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const idRoot = loadBundleDefault(ctx, bundle);
|
||||
const arg = ofString(ctx, 'hello');
|
||||
const applied = app(ctx, idRoot, arg);
|
||||
const result = reduce(ctx, applied);
|
||||
strictEqual(toString(ctx, result), 'hello');
|
||||
strictEqual(decodeType(ctx, result), 'string');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('run bundle — append', () => {
|
||||
it('append "hello " "world" = "hello world"', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/append.arboricx`);
|
||||
let term = loadBundleDefault(ctx, bundle);
|
||||
term = app(ctx, term, ofString(ctx, 'hello '));
|
||||
term = app(ctx, term, ofString(ctx, 'world'));
|
||||
const result = reduce(ctx, term);
|
||||
strictEqual(toString(ctx, result), 'hello world');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('run bundle — notQ', () => {
|
||||
it('notQ loads and reduces without error', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/notQ.arboricx`);
|
||||
const root = loadBundleDefault(ctx, bundle);
|
||||
const result = reduce(ctx, root);
|
||||
ok(result > 0);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
describe('run bundle — named export', () => {
|
||||
it('loadBundle selects named export', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
const root = loadBundle(ctx, bundle, 'id');
|
||||
ok(root > 0);
|
||||
// id is a function; apply it before reducing
|
||||
const applied = app(ctx, root, ofString(ctx, 'test'));
|
||||
const result = reduce(ctx, applied);
|
||||
strictEqual(toString(ctx, result), 'test');
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
|
||||
it('missing export throws', () => {
|
||||
const ctx = init(libPath);
|
||||
try {
|
||||
const bundle = readFileSync(`${fixtureDir}/id.arboricx`);
|
||||
throws(() => loadBundle(ctx, bundle, 'nonexistent'), /failed/);
|
||||
} finally {
|
||||
free(ctx);
|
||||
}
|
||||
});
|
||||
});
|
||||
53
ext/php/public/eval.php
Normal file
53
ext/php/public/eval.php
Normal file
@@ -0,0 +1,53 @@
|
||||
<?php
|
||||
|
||||
declare(strict_types=1);
|
||||
|
||||
error_reporting(E_ALL);
|
||||
ini_set('display_errors', '1');
|
||||
|
||||
if (!extension_loaded('ffi')) {
|
||||
http_response_code(500);
|
||||
echo "Error: PHP FFI extension is not loaded.\n";
|
||||
echo "If you are using the Nix build, run the included server script:\n";
|
||||
echo " ./result/bin/tricu-php-server\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
require __DIR__ . '/../src/common.php';
|
||||
|
||||
use function Arboricx\{ctx_init, ctx_free, loadBundleDefault, ofNumber, ofString, app, reduce, decode, findLib, readBundle};
|
||||
|
||||
header('Content-Type: text/plain; charset=utf-8');
|
||||
|
||||
try {
|
||||
if (!isset($_FILES['bundle']) || $_FILES['bundle']['error'] !== UPLOAD_ERR_OK) {
|
||||
throw new \RuntimeException('Bundle upload failed.');
|
||||
}
|
||||
|
||||
$args = [];
|
||||
for ($i = 0; $i < 5; $i++) {
|
||||
$v = $_POST["arg$i"] ?? '';
|
||||
if ($v !== '') {
|
||||
$args[] = $v;
|
||||
}
|
||||
}
|
||||
|
||||
$libPath = findLib();
|
||||
$ctx = ctx_init($libPath);
|
||||
try {
|
||||
$term = loadBundleDefault($ctx, readBundle($_FILES['bundle']['tmp_name']));
|
||||
|
||||
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);
|
||||
} finally {
|
||||
ctx_free($ctx);
|
||||
}
|
||||
} catch (\Throwable $e) {
|
||||
http_response_code(500);
|
||||
echo 'Error: ' . $e->getMessage();
|
||||
}
|
||||
30
ext/php/public/index.php
Normal file
30
ext/php/public/index.php
Normal file
@@ -0,0 +1,30 @@
|
||||
<?php
|
||||
declare(strict_types=1);
|
||||
?>
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<title>Arboricx Web</title>
|
||||
<script src="https://unpkg.com/htmx.org@2.0.4"></script>
|
||||
</head>
|
||||
<body>
|
||||
<h1>Arboricx Bundle Runner</h1>
|
||||
<form hx-post="eval.php" hx-target="#result" enctype="multipart/form-data">
|
||||
<p>
|
||||
<label>Bundle (.arboricx)<br>
|
||||
<input type="file" name="bundle" accept=".arboricx" required></label>
|
||||
</p>
|
||||
<?php for ($i = 0; $i < 5; $i++): ?>
|
||||
<p>
|
||||
<label>Arg <?= $i + 1 ?> <small>(ignored if empty)</small><br>
|
||||
<input type="text" name="arg<?= $i ?>"></label>
|
||||
</p>
|
||||
<?php endfor; ?>
|
||||
<p>
|
||||
<button type="submit">Run</button>
|
||||
</p>
|
||||
</form>
|
||||
<pre id="result"></pre>
|
||||
</body>
|
||||
</html>
|
||||
103
ext/php/run.php
Normal file
103
ext/php/run.php
Normal file
@@ -0,0 +1,103 @@
|
||||
#!/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/common.php';
|
||||
|
||||
use function Arboricx\{ctx_init, ctx_free, loadBundleDefault, ofNumber, ofString, app, reduce, toString, toBool, toNumber, findLib, decode, decodeType, readBundle};
|
||||
|
||||
// ── Commands ─────────────────────────────────────────────────────────────────
|
||||
|
||||
function bail(string $msg): void
|
||||
{
|
||||
fwrite(STDERR, "Error: $msg\n");
|
||||
exit(1);
|
||||
}
|
||||
|
||||
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";
|
||||
} catch (\Throwable $e) {
|
||||
bail($e->getMessage());
|
||||
} 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";
|
||||
} catch (\Throwable $e) {
|
||||
bail($e->getMessage());
|
||||
} 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);
|
||||
}
|
||||
81
ext/php/src/common.php
Normal file
81
ext/php/src/common.php
Normal file
@@ -0,0 +1,81 @@
|
||||
<?php
|
||||
|
||||
declare(strict_types=1);
|
||||
|
||||
namespace Arboricx;
|
||||
|
||||
require __DIR__ . '/ffi.php';
|
||||
|
||||
use function Arboricx\{ctx_init, ctx_free, loadBundleDefault, ofNumber, ofString, app, reduce, toString, toBool, toNumber};
|
||||
|
||||
function findLib(): string
|
||||
{
|
||||
$env = getenv('ARBORICX_LIB');
|
||||
if ($env !== false && file_exists($env)) {
|
||||
return $env;
|
||||
}
|
||||
|
||||
$paths = [
|
||||
__DIR__ . '/../../zig/zig-out/lib/libarboricx.so',
|
||||
__DIR__ . '/../libarboricx.so',
|
||||
'/usr/local/lib/libarboricx.so',
|
||||
'/usr/lib/libarboricx.so',
|
||||
'./libarboricx.so',
|
||||
];
|
||||
foreach ($paths as $p) {
|
||||
if (file_exists($p)) {
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
|
||||
throw new \RuntimeException('libarboricx.so not found. Set ARBORICX_LIB to its full path.');
|
||||
}
|
||||
|
||||
function decode(\FFI\CData $ctx, int $root): string
|
||||
{
|
||||
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)';
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
function readBundle(string $path): string
|
||||
{
|
||||
if (!file_exists($path)) {
|
||||
throw new \RuntimeException("bundle not found: $path");
|
||||
}
|
||||
$bytes = file_get_contents($path);
|
||||
if ($bytes === false) {
|
||||
throw new \RuntimeException("could not read bundle: $path");
|
||||
}
|
||||
return $bytes;
|
||||
}
|
||||
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
|
||||
71
ext/zig/build.zig
Normal file
71
ext/zig/build.zig
Normal file
@@ -0,0 +1,71 @@
|
||||
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);
|
||||
exe_mod.link_libc = true;
|
||||
exe_mod.linkSystemLibrary("uv", .{});
|
||||
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);
|
||||
lib_mod.link_libc = true;
|
||||
lib_mod.linkSystemLibrary("uv", .{});
|
||||
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",
|
||||
},
|
||||
}
|
||||
73
ext/zig/include/arboricx.h
Normal file
73
ext/zig/include/arboricx.h
Normal file
@@ -0,0 +1,73 @@
|
||||
#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);
|
||||
|
||||
/* Tree inspection (Layer 1 — for custom IO drivers and non-POSIX hosts) */
|
||||
int arb_is_leaf(arb_ctx_t* ctx, uint32_t root);
|
||||
int arb_is_stem(arb_ctx_t* ctx, uint32_t root);
|
||||
int arb_is_fork(arb_ctx_t* ctx, uint32_t root);
|
||||
int arb_is_app(arb_ctx_t* ctx, uint32_t root);
|
||||
int arb_get_stem_child(arb_ctx_t* ctx, uint32_t root, uint32_t* out);
|
||||
int arb_get_fork_children(arb_ctx_t* ctx, uint32_t root,
|
||||
uint32_t* out_left, uint32_t* out_right);
|
||||
int arb_get_app_func_arg(arb_ctx_t* ctx, uint32_t root,
|
||||
uint32_t* out_func, uint32_t* out_arg);
|
||||
|
||||
/* IO driver (Layer 2 — POSIX interaction-tree runtime) */
|
||||
typedef struct {
|
||||
int allow_read_all;
|
||||
int allow_write_all;
|
||||
} arb_io_perms_t;
|
||||
|
||||
uint32_t arb_run_io(arb_ctx_t* ctx, uint32_t program, const arb_io_perms_t* perms);
|
||||
|
||||
/* 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 */
|
||||
2578
ext/zig/kernel_run_arboricx_typed.dag
Normal file
2578
ext/zig/kernel_run_arboricx_typed.dag
Normal file
File diff suppressed because it is too large
Load Diff
1
ext/zig/result
Symbolic link
1
ext/zig/result
Symbolic link
@@ -0,0 +1 @@
|
||||
/nix/store/2sg31y0vamz5bz19aakxagi702glwh24-tricu-zig-0.1.0
|
||||
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);
|
||||
}
|
||||
};
|
||||
363
ext/zig/src/bundle.zig
Normal file
363
ext/zig/src/bundle.zig
Normal file
@@ -0,0 +1,363 @@
|
||||
const std = @import("std");
|
||||
const tree = @import("tree.zig");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
|
||||
pub const Error = error{
|
||||
InvalidMagic,
|
||||
InvalidVersion,
|
||||
Truncated,
|
||||
InvalidManifest,
|
||||
InvalidNodePayload,
|
||||
ExportNotFound,
|
||||
MissingChild,
|
||||
UnexpectedFormat,
|
||||
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 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,
|
||||
};
|
||||
|
||||
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();
|
||||
_ = try p.readU16(); // reserved (was digest_alg)
|
||||
entry.offset = try p.readU64();
|
||||
entry.length = try p.readU64();
|
||||
_ = try p.readU32(); // reserved padding
|
||||
|
||||
if (compression != 0) return error.UnexpectedFormat;
|
||||
}
|
||||
return entries;
|
||||
}
|
||||
|
||||
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, "indexed")) return error.UnexpectedFormat;
|
||||
|
||||
const hash_domain = try p.readLengthPrefixedBytes(allocator);
|
||||
defer allocator.free(hash_domain);
|
||||
if (!std.mem.eql(u8, hash_domain, "arboricx.indexed.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.indexed.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.index = try p.readU32();
|
||||
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.readU32();
|
||||
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: u32,
|
||||
kind: []const u8,
|
||||
abi: []const u8,
|
||||
};
|
||||
|
||||
const Root = struct {
|
||||
index: u32,
|
||||
role: []const u8,
|
||||
};
|
||||
|
||||
/// Parse the node section and build nodes directly into the arena.
|
||||
/// Returns a slice mapping node-section index -> arena index.
|
||||
/// The caller owns the returned slice and must free it with the arena's allocator.
|
||||
fn parseNodeSection(p: *Parser, arena: *Arena) Error![]u32 {
|
||||
const node_count = try p.readU64();
|
||||
const indices = try arena.allocator.alloc(u32, node_count);
|
||||
errdefer arena.allocator.free(indices);
|
||||
|
||||
var i: u64 = 0;
|
||||
while (i < node_count) : (i += 1) {
|
||||
const plen = try p.readU32();
|
||||
const payload = try p.expect(plen);
|
||||
|
||||
if (payload.len == 0) return error.InvalidNodePayload;
|
||||
|
||||
const idx: u32 = switch (payload[0]) {
|
||||
0x00 => blk: {
|
||||
if (plen != 1) return error.InvalidNodePayload;
|
||||
break :blk try arena.alloc(.leaf);
|
||||
},
|
||||
0x01 => blk: {
|
||||
if (plen != 5) return error.InvalidNodePayload;
|
||||
const child_idx = std.mem.readInt(u32, payload[1..5], .big);
|
||||
if (child_idx >= i) return error.InvalidNodePayload;
|
||||
break :blk try arena.alloc(.{ .stem = .{ .child = indices[child_idx] } });
|
||||
},
|
||||
0x02 => blk: {
|
||||
if (plen != 9) return error.InvalidNodePayload;
|
||||
const left_idx = std.mem.readInt(u32, payload[1..5], .big);
|
||||
const right_idx = std.mem.readInt(u32, payload[5..9], .big);
|
||||
if (left_idx >= i or right_idx >= i) return error.InvalidNodePayload;
|
||||
break :blk try arena.alloc(.{ .fork = .{ .left = indices[left_idx], .right = indices[right_idx] } });
|
||||
},
|
||||
else => return error.InvalidNodePayload,
|
||||
};
|
||||
indices[i] = idx;
|
||||
}
|
||||
|
||||
return indices;
|
||||
}
|
||||
|
||||
fn findSection(entries: []SectionEntry, section_type: u32) ?SectionEntry {
|
||||
for (entries) |entry| {
|
||||
if (entry.section_type == section_type) return entry;
|
||||
}
|
||||
return null;
|
||||
}
|
||||
|
||||
/// 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);
|
||||
|
||||
const manifest_section = findSection(entries, 1) orelse return error.InvalidManifest;
|
||||
const nodes_section = findSection(entries, 2) orelse return error.InvalidNodePayload;
|
||||
|
||||
const manifest_bytes = bundle_bytes[@intCast(manifest_section.offset)..@intCast(manifest_section.offset + manifest_section.length)];
|
||||
const nodes_bytes = bundle_bytes[@intCast(nodes_section.offset)..@intCast(nodes_section.offset + nodes_section.length)];
|
||||
|
||||
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_root: ?u32 = null;
|
||||
for (manifest.exports) |e| {
|
||||
if (std.mem.eql(u8, e.name, export_name)) {
|
||||
export_root = e.root;
|
||||
break;
|
||||
}
|
||||
}
|
||||
const root_index = export_root orelse return error.ExportNotFound;
|
||||
|
||||
var np = Parser.init(nodes_bytes);
|
||||
const node_indices = try parseNodeSection(&np, arena);
|
||||
defer allocator.free(node_indices);
|
||||
|
||||
if (root_index >= node_indices.len) return error.InvalidNodePayload;
|
||||
return node_indices[root_index];
|
||||
}
|
||||
|
||||
/// 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);
|
||||
|
||||
const manifest_section = findSection(entries, 1) orelse return error.InvalidManifest;
|
||||
const nodes_section = findSection(entries, 2) orelse return error.InvalidNodePayload;
|
||||
|
||||
const manifest_bytes = bundle_bytes[@intCast(manifest_section.offset)..@intCast(manifest_section.offset + manifest_section.length)];
|
||||
const nodes_bytes = bundle_bytes[@intCast(nodes_section.offset)..@intCast(nodes_section.offset + nodes_section.length)];
|
||||
|
||||
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_index = manifest.roots[0].index;
|
||||
|
||||
var np = Parser.init(nodes_bytes);
|
||||
const node_indices = try parseNodeSection(&np, arena);
|
||||
defer allocator.free(node_indices);
|
||||
|
||||
if (root_index >= node_indices.len) return error.InvalidNodePayload;
|
||||
return node_indices[root_index];
|
||||
}
|
||||
252
ext/zig/src/c_abi.zig
Normal file
252
ext/zig/src/c_abi.zig
Normal file
@@ -0,0 +1,252 @@
|
||||
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");
|
||||
const io_driver = @import("io_driver.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;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Tree inspection (Layer 1 — for custom IO drivers and non-POSIX hosts)
|
||||
// All return 1 on success / true, 0 on failure / false.
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
export fn arb_is_leaf(ctx: *ArbCtx, root: u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
return if (ctx.arena.nodes.items[root] == .leaf) 1 else 0;
|
||||
}
|
||||
|
||||
export fn arb_is_stem(ctx: *ArbCtx, root: u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
return if (ctx.arena.nodes.items[root] == .stem) 1 else 0;
|
||||
}
|
||||
|
||||
export fn arb_is_fork(ctx: *ArbCtx, root: u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
return if (ctx.arena.nodes.items[root] == .fork) 1 else 0;
|
||||
}
|
||||
|
||||
export fn arb_is_app(ctx: *ArbCtx, root: u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
return if (ctx.arena.nodes.items[root] == .app) 1 else 0;
|
||||
}
|
||||
|
||||
export fn arb_get_stem_child(ctx: *ArbCtx, root: u32, out: *u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
const node = ctx.arena.nodes.items[root];
|
||||
if (node != .stem) return 0;
|
||||
out.* = node.stem.child;
|
||||
return 1;
|
||||
}
|
||||
|
||||
export fn arb_get_fork_children(ctx: *ArbCtx, root: u32, out_left: *u32, out_right: *u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
const node = ctx.arena.nodes.items[root];
|
||||
if (node != .fork) return 0;
|
||||
out_left.* = node.fork.left;
|
||||
out_right.* = node.fork.right;
|
||||
return 1;
|
||||
}
|
||||
|
||||
export fn arb_get_app_func_arg(ctx: *ArbCtx, root: u32, out_func: *u32, out_arg: *u32) c_int {
|
||||
if (root >= ctx.arena.len()) return 0;
|
||||
const node = ctx.arena.nodes.items[root];
|
||||
if (node != .app) return 0;
|
||||
out_func.* = node.app.func;
|
||||
out_arg.* = node.app.arg;
|
||||
return 1;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// 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;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// IO driver (Layer 2 — POSIX interaction-tree runtime)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const arb_io_perms_t = extern struct {
|
||||
allow_read_all: c_int,
|
||||
allow_write_all: c_int,
|
||||
};
|
||||
|
||||
export fn arb_run_io(ctx: *ArbCtx, program: u32, perms: ?*const arb_io_perms_t) u32 {
|
||||
const zig_perms = if (perms) |p| io_driver.IOPerms{
|
||||
.allow_read_all = p.allow_read_all != 0,
|
||||
.allow_write_all = p.allow_write_all != 0,
|
||||
} else io_driver.IOPerms{};
|
||||
return io_driver.runIO(ctx.gpa, &ctx.arena, program, zig_perms) catch 0;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// 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;
|
||||
845
ext/zig/src/io_driver.zig
Normal file
845
ext/zig/src/io_driver.zig
Normal file
@@ -0,0 +1,845 @@
|
||||
const std = @import("std");
|
||||
const Arena = @import("arena.zig").Arena;
|
||||
const codecs = @import("codecs.zig");
|
||||
const reduce = @import("reduce.zig");
|
||||
const tree = @import("tree.zig");
|
||||
|
||||
const c = @cImport({
|
||||
@cInclude("uv.h");
|
||||
});
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Action tag constants (must match lib/io.tri and IODriver.hs)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const ActionTag = enum(u8) {
|
||||
pure = 0,
|
||||
bind = 1,
|
||||
putStr = 10,
|
||||
getLine = 11,
|
||||
readFile = 20,
|
||||
writeFile = 21,
|
||||
ask = 30,
|
||||
local = 31,
|
||||
get = 40,
|
||||
put = 41,
|
||||
fork = 60,
|
||||
await = 61,
|
||||
yield = 62,
|
||||
sleep = 63,
|
||||
};
|
||||
|
||||
pub const Action = union(ActionTag) {
|
||||
pure: u32,
|
||||
bind: struct { left: u32, k: u32 },
|
||||
putStr: u32,
|
||||
getLine,
|
||||
readFile: u32,
|
||||
writeFile: struct { path: u32, contents: u32 },
|
||||
ask,
|
||||
local: struct { f: u32, action: u32 },
|
||||
get,
|
||||
put: u32,
|
||||
fork: u32,
|
||||
await: u32,
|
||||
yield,
|
||||
sleep: u32,
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Error codes (must match IODriver.hs)
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const ERR_DOES_NOT_EXIST: u64 = 1;
|
||||
const ERR_PERMISSION: u64 = 2;
|
||||
const ERR_ALREADY_EXISTS: u64 = 3;
|
||||
const ERR_IO_OTHER: u64 = 4;
|
||||
const ERR_POLICY_DENY: u64 = 20;
|
||||
const ERR_INVALID_ACTION: u64 = 40;
|
||||
const ERR_INVALID_STRING: u64 = 41;
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Permissions
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub const IOPerms = struct {
|
||||
allow_read_all: bool = false,
|
||||
allow_write_all: bool = false,
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// IO sentinel detection
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn isIOSentinel(arena: *Arena, root: u32) !?u32 {
|
||||
const node = arena.get(root);
|
||||
if (node.* != .fork) return null;
|
||||
|
||||
const sentinel = node.fork.left;
|
||||
const rest = node.fork.right;
|
||||
|
||||
const sentinel_str = try codecs.toString(arena, sentinel);
|
||||
defer {
|
||||
if (sentinel_str) |s| {
|
||||
arena.allocator.free(s);
|
||||
}
|
||||
}
|
||||
if (sentinel_str == null) return null;
|
||||
if (!std.mem.eql(u8, sentinel_str.?, "tricuIO")) return null;
|
||||
|
||||
const rest_node = arena.get(rest);
|
||||
if (rest_node.* != .fork) return null;
|
||||
|
||||
const version_num = try codecs.toNumber(arena, rest_node.fork.left);
|
||||
if (version_num == null or version_num.? != 1) return null;
|
||||
|
||||
return rest_node.fork.right;
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Action decoding
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn decodeAction(arena: *Arena, root: u32) !?Action {
|
||||
const node = arena.get(root);
|
||||
if (node.* != .fork) return null;
|
||||
|
||||
const tag_num = try codecs.toNumber(arena, node.fork.left);
|
||||
if (tag_num == null) return null;
|
||||
|
||||
const tag: ActionTag = switch (tag_num.?) {
|
||||
0 => .pure,
|
||||
1 => .bind,
|
||||
10 => .putStr,
|
||||
11 => .getLine,
|
||||
20 => .readFile,
|
||||
21 => .writeFile,
|
||||
30 => .ask,
|
||||
31 => .local,
|
||||
40 => .get,
|
||||
41 => .put,
|
||||
60 => .fork,
|
||||
61 => .await,
|
||||
62 => .yield,
|
||||
63 => .sleep,
|
||||
else => return null,
|
||||
};
|
||||
|
||||
const payload = node.fork.right;
|
||||
|
||||
return switch (tag) {
|
||||
.pure => Action{ .pure = payload },
|
||||
.bind => blk: {
|
||||
const payload_node = arena.get(payload);
|
||||
if (payload_node.* != .fork) return null;
|
||||
break :blk Action{ .bind = .{ .left = payload_node.fork.left, .k = payload_node.fork.right } };
|
||||
},
|
||||
.putStr => Action{ .putStr = payload },
|
||||
.getLine => Action.getLine,
|
||||
.readFile => Action{ .readFile = payload },
|
||||
.writeFile => blk: {
|
||||
const payload_node = arena.get(payload);
|
||||
if (payload_node.* != .fork) return null;
|
||||
break :blk Action{ .writeFile = .{ .path = payload_node.fork.left, .contents = payload_node.fork.right } };
|
||||
},
|
||||
.ask => Action.ask,
|
||||
.local => blk: {
|
||||
const payload_node = arena.get(payload);
|
||||
if (payload_node.* != .fork) return null;
|
||||
break :blk Action{ .local = .{ .f = payload_node.fork.left, .action = payload_node.fork.right } };
|
||||
},
|
||||
.get => Action.get,
|
||||
.put => Action{ .put = payload },
|
||||
.fork => Action{ .fork = payload },
|
||||
.await => Action{ .await = payload },
|
||||
.yield => Action.yield,
|
||||
.sleep => Action{ .sleep = payload },
|
||||
};
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Response tree constructors
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn makePure(arena: *Arena, val: u32) !u32 {
|
||||
const tag = try codecs.ofNumber(arena, 0);
|
||||
return try arena.alloc(.{ .fork = .{ .left = tag, .right = val } });
|
||||
}
|
||||
|
||||
pub fn makeOkResult(arena: *Arena, val: u32) !u32 {
|
||||
const ok_tag = try arena.alloc(.{ .stem = .{ .child = try arena.alloc(.leaf) } });
|
||||
const val_pair = try arena.alloc(.{ .fork = .{ .left = val, .right = try arena.alloc(.leaf) } });
|
||||
return try arena.alloc(.{ .fork = .{ .left = ok_tag, .right = val_pair } });
|
||||
}
|
||||
|
||||
pub fn makeErrResult(arena: *Arena, code: u64) !u32 {
|
||||
const code_tree = try codecs.ofNumber(arena, code);
|
||||
const code_pair = try arena.alloc(.{ .fork = .{ .left = code_tree, .right = try arena.alloc(.leaf) } });
|
||||
return try arena.alloc(.{ .fork = .{ .left = try arena.alloc(.leaf), .right = code_pair } });
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Frame stack and runtime
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const Frame = union(enum) {
|
||||
bind: u32, // continuation k
|
||||
local: u32, // old env
|
||||
};
|
||||
|
||||
const Runtime = struct {
|
||||
env: u32,
|
||||
state: u32,
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Helper: reduce a term in a scratch arena and copy the result back
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
fn reduceInScratch(gpa: std.mem.Allocator, arena: *Arena, term: u32) !u32 {
|
||||
var scratch = Arena.init(gpa);
|
||||
defer scratch.deinit();
|
||||
const scratch_root = try tree.copyTree(arena.nodes.items, &scratch, term);
|
||||
const scratch_result = try reduce.reduce(scratch_root, &scratch, std.math.maxInt(u64));
|
||||
return try tree.copyTree(scratch.nodes.items, arena, scratch_result);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Task
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const Task = struct {
|
||||
id: u64,
|
||||
parent: ?*Task,
|
||||
frames: std.ArrayList(Frame),
|
||||
runtime: Runtime,
|
||||
current: u32,
|
||||
status: enum { runnable, blocked, completed },
|
||||
result: ?u32,
|
||||
waiting_for: ?u64,
|
||||
|
||||
fn init(gpa: std.mem.Allocator, id: u64, parent: ?*Task, env: u32, state: u32, current: u32) !*Task {
|
||||
const task = try gpa.create(Task);
|
||||
task.* = .{
|
||||
.id = id,
|
||||
.parent = parent,
|
||||
.frames = std.ArrayList(Frame).empty,
|
||||
.runtime = .{ .env = env, .state = state },
|
||||
.current = current,
|
||||
.status = .runnable,
|
||||
.result = null,
|
||||
.waiting_for = null,
|
||||
};
|
||||
return task;
|
||||
}
|
||||
|
||||
fn deinit(self: *Task, gpa: std.mem.Allocator) void {
|
||||
self.frames.deinit(gpa);
|
||||
gpa.destroy(self);
|
||||
}
|
||||
|
||||
// finishValue processes a value through the frame stack.
|
||||
// Returns true if the task has completed (no more frames).
|
||||
fn finishValue(self: *Task, arena: *Arena, value: u32) !bool {
|
||||
if (self.frames.pop()) |frame| {
|
||||
switch (frame) {
|
||||
.bind => |k| {
|
||||
self.current = try arena.alloc(.{ .app = .{ .func = k, .arg = value } });
|
||||
return false;
|
||||
},
|
||||
.local => |old_env| {
|
||||
self.runtime.env = old_env;
|
||||
self.current = try makePure(arena, value);
|
||||
return false;
|
||||
},
|
||||
}
|
||||
} else {
|
||||
self.current = value;
|
||||
return true;
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Scheduler
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const Scheduler = struct {
|
||||
gpa: std.mem.Allocator,
|
||||
loop: *c.uv_loop_t,
|
||||
arena: *Arena,
|
||||
tasks: std.ArrayList(*Task),
|
||||
runnable: std.ArrayList(*Task),
|
||||
next_id: u64,
|
||||
perms: IOPerms,
|
||||
|
||||
fn init(gpa: std.mem.Allocator, loop: *c.uv_loop_t, arena: *Arena, perms: IOPerms) !Scheduler {
|
||||
const sched = Scheduler{
|
||||
.gpa = gpa,
|
||||
.loop = loop,
|
||||
.arena = arena,
|
||||
.tasks = std.ArrayList(*Task).empty,
|
||||
.runnable = std.ArrayList(*Task).empty,
|
||||
.next_id = 1,
|
||||
.perms = perms,
|
||||
};
|
||||
return sched;
|
||||
}
|
||||
|
||||
fn deinit(self: *Scheduler) void {
|
||||
for (self.tasks.items) |task| {
|
||||
task.deinit(self.gpa);
|
||||
}
|
||||
self.tasks.deinit(self.gpa);
|
||||
self.runnable.deinit(self.gpa);
|
||||
}
|
||||
|
||||
fn createTask(self: *Scheduler, parent: ?*Task, env: u32, state: u32, current: u32) !*Task {
|
||||
const id = self.next_id;
|
||||
self.next_id += 1;
|
||||
const task = try Task.init(self.gpa, id, parent, env, state, current);
|
||||
try self.tasks.append(self.gpa, task);
|
||||
return task;
|
||||
}
|
||||
|
||||
fn run(self: *Scheduler) !void {
|
||||
while (true) {
|
||||
if (self.runnable.items.len > 0) {
|
||||
const task = self.runnable.orderedRemove(0);
|
||||
try self.stepTask(task);
|
||||
} else if (self.hasPendingHandles()) {
|
||||
_ = c.uv_run(self.loop, c.UV_RUN_ONCE);
|
||||
} else {
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
fn hasPendingHandles(self: *Scheduler) bool {
|
||||
return c.uv_loop_alive(self.loop) != 0;
|
||||
}
|
||||
|
||||
fn completeTask(self: *Scheduler, task: *Task) !void {
|
||||
task.status = .completed;
|
||||
task.result = task.current;
|
||||
// Unblock any tasks waiting for this one
|
||||
for (self.tasks.items) |t| {
|
||||
if (t.status == .blocked and t.waiting_for == task.id) {
|
||||
t.status = .runnable;
|
||||
t.waiting_for = null;
|
||||
t.current = try makePure(self.arena, task.result.?);
|
||||
try self.runnable.append(self.gpa, t);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
fn stepTask(self: *Scheduler, task: *Task) !void {
|
||||
const reduced = try reduceInScratch(self.gpa, self.arena, task.current);
|
||||
|
||||
const decoded = try decodeAction(self.arena, reduced);
|
||||
if (decoded == null) {
|
||||
// Not a recognized action — if no frames, it's the final result.
|
||||
// Otherwise treat as invalid.
|
||||
if (task.frames.items.len == 0) {
|
||||
task.current = reduced;
|
||||
try self.completeTask(task);
|
||||
return;
|
||||
}
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_ACTION);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
switch (decoded.?) {
|
||||
.pure => |val| {
|
||||
if (try task.finishValue(self.arena, val)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.bind => |b| {
|
||||
try task.frames.append(self.gpa, .{ .bind = b.k });
|
||||
task.current = b.left;
|
||||
try self.runnable.append(self.gpa, task);
|
||||
},
|
||||
|
||||
.putStr => |str_tree| {
|
||||
const str = try codecs.toString(self.arena, str_tree) orelse {
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_STRING);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
};
|
||||
defer self.gpa.free(str);
|
||||
_ = std.c.write(1, str.ptr, str.len);
|
||||
const leaf = try self.arena.alloc(.leaf);
|
||||
if (try task.finishValue(self.arena, leaf)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.getLine => {
|
||||
var buf: [4096]u8 = undefined;
|
||||
var len: usize = 0;
|
||||
while (len < buf.len) {
|
||||
const n = std.c.read(0, buf[len..].ptr, 1);
|
||||
if (n <= 0) break;
|
||||
if (buf[len] == '\n') break;
|
||||
len += 1;
|
||||
}
|
||||
const line = buf[0..len];
|
||||
const str_tree = try codecs.ofString(self.arena, line);
|
||||
if (try task.finishValue(self.arena, str_tree)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.readFile => |path_tree| {
|
||||
const path = try codecs.toString(self.arena, path_tree) orelse {
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_STRING);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
};
|
||||
|
||||
if (!self.perms.allow_read_all) {
|
||||
self.arena.allocator.free(path);
|
||||
const err = try makeErrResult(self.arena, ERR_POLICY_DENY);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
const ctx = try self.gpa.create(FileReadCtx);
|
||||
ctx.* = .{
|
||||
.scheduler = self,
|
||||
.task = task,
|
||||
.arena = self.arena,
|
||||
.gpa = self.gpa,
|
||||
.fd = -1,
|
||||
.buf = std.ArrayList(u8).empty,
|
||||
.path = path,
|
||||
.req = undefined,
|
||||
.read_buf = null,
|
||||
};
|
||||
ctx.req.data = ctx;
|
||||
_ = c.uv_fs_open(self.loop, &ctx.req, ctx.path.ptr, c.O_RDONLY, 0, file_open_cb);
|
||||
},
|
||||
|
||||
.writeFile => |wf| {
|
||||
const path = try codecs.toString(self.arena, wf.path) orelse {
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_STRING);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
};
|
||||
|
||||
const contents = try codecs.toString(self.arena, wf.contents) orelse {
|
||||
self.arena.allocator.free(path);
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_STRING);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
};
|
||||
|
||||
if (!self.perms.allow_write_all) {
|
||||
self.arena.allocator.free(path);
|
||||
self.arena.allocator.free(contents);
|
||||
const err = try makeErrResult(self.arena, ERR_POLICY_DENY);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
const ctx = try self.gpa.create(FileWriteCtx);
|
||||
ctx.* = .{
|
||||
.scheduler = self,
|
||||
.task = task,
|
||||
.arena = self.arena,
|
||||
.gpa = self.gpa,
|
||||
.fd = -1,
|
||||
.path = path,
|
||||
.contents = contents,
|
||||
.written = false,
|
||||
.req = undefined,
|
||||
};
|
||||
ctx.req.data = ctx;
|
||||
const flags = c.O_WRONLY | c.O_CREAT | c.O_TRUNC;
|
||||
_ = c.uv_fs_open(self.loop, &ctx.req, ctx.path.ptr, flags, 0o644, file_write_open_cb);
|
||||
},
|
||||
|
||||
.ask => {
|
||||
if (try task.finishValue(self.arena, task.runtime.env)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.local => |loc| {
|
||||
const new_env = try reduceInScratch(self.gpa, self.arena, try self.arena.alloc(.{ .app = .{ .func = loc.f, .arg = task.runtime.env } }));
|
||||
try task.frames.append(self.gpa, .{ .local = task.runtime.env });
|
||||
task.runtime.env = new_env;
|
||||
task.current = loc.action;
|
||||
try self.runnable.append(self.gpa, task);
|
||||
},
|
||||
|
||||
.get => {
|
||||
if (try task.finishValue(self.arena, task.runtime.state)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.put => |new_state| {
|
||||
task.runtime.state = new_state;
|
||||
const leaf = try self.arena.alloc(.leaf);
|
||||
if (try task.finishValue(self.arena, leaf)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.fork => |action| {
|
||||
const child = try self.createTask(task, task.runtime.env, task.runtime.state, action);
|
||||
try self.runnable.append(self.gpa, child);
|
||||
const handle = try codecs.ofNumber(self.arena, child.id);
|
||||
if (try task.finishValue(self.arena, handle)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.await => |handle_tree| {
|
||||
const handle = try codecs.toNumber(self.arena, handle_tree) orelse {
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_ACTION);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
};
|
||||
var found: ?*Task = null;
|
||||
for (self.tasks.items) |t| {
|
||||
if (t.id == handle) {
|
||||
found = t;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (found == null) {
|
||||
const err = try makeErrResult(self.arena, ERR_INVALID_ACTION);
|
||||
if (try task.finishValue(self.arena, err)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (found.?.status == .completed) {
|
||||
const result = found.?.result.?;
|
||||
if (try task.finishValue(self.arena, result)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
} else {
|
||||
task.status = .blocked;
|
||||
task.waiting_for = handle;
|
||||
// Task remains out of runnable until child completes
|
||||
}
|
||||
},
|
||||
|
||||
.yield => {
|
||||
const leaf = try self.arena.alloc(.leaf);
|
||||
if (try task.finishValue(self.arena, leaf)) {
|
||||
try self.completeTask(task);
|
||||
} else {
|
||||
try self.runnable.append(self.gpa, task);
|
||||
}
|
||||
},
|
||||
|
||||
.sleep => |ms_tree| {
|
||||
const ms = try codecs.toNumber(self.arena, ms_tree) orelse 0;
|
||||
const ctx = try self.gpa.create(SleepCtx);
|
||||
ctx.* = .{
|
||||
.scheduler = self,
|
||||
.task = task,
|
||||
.arena = self.arena,
|
||||
.timer = undefined,
|
||||
};
|
||||
ctx.timer.data = ctx;
|
||||
_ = c.uv_timer_init(self.loop, &ctx.timer);
|
||||
_ = c.uv_timer_start(&ctx.timer, sleep_cb, @intCast(ms), 0);
|
||||
},
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Async file read
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const FileReadCtx = struct {
|
||||
scheduler: *Scheduler,
|
||||
task: *Task,
|
||||
arena: *Arena,
|
||||
gpa: std.mem.Allocator,
|
||||
fd: c_int,
|
||||
buf: std.ArrayList(u8),
|
||||
path: []const u8,
|
||||
req: c.uv_fs_t,
|
||||
read_buf: ?[]u8,
|
||||
};
|
||||
|
||||
fn mapUvErr(uv_err: c_int) u64 {
|
||||
return switch (uv_err) {
|
||||
c.UV_ENOENT => ERR_DOES_NOT_EXIST,
|
||||
c.UV_EACCES => ERR_PERMISSION,
|
||||
c.UV_EEXIST => ERR_ALREADY_EXISTS,
|
||||
else => ERR_IO_OTHER,
|
||||
};
|
||||
}
|
||||
|
||||
fn file_open_cb(req: [*c]c.uv_fs_t) callconv(.c) void {
|
||||
const ctx = @as(*FileReadCtx, @ptrCast(@alignCast(req.*.data)));
|
||||
const result = req.*.result;
|
||||
c.uv_fs_req_cleanup(req);
|
||||
if (result < 0) {
|
||||
const err = makeErrResult(ctx.arena, mapUvErr(@intCast(-result))) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, err) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
ctx.buf.deinit(ctx.gpa);
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
}
|
||||
ctx.fd = @intCast(result);
|
||||
const read_buf = ctx.gpa.alloc(u8, 4096) catch unreachable;
|
||||
ctx.read_buf = read_buf;
|
||||
var uv_buf = c.uv_buf_init(@ptrCast(read_buf.ptr), @intCast(read_buf.len));
|
||||
_ = c.uv_fs_read(ctx.scheduler.loop, req, ctx.fd, &uv_buf, 1, -1, file_read_cb);
|
||||
}
|
||||
|
||||
fn file_read_cb(req: [*c]c.uv_fs_t) callconv(.c) void {
|
||||
const ctx = @as(*FileReadCtx, @ptrCast(@alignCast(req.*.data)));
|
||||
const nread = req.*.result;
|
||||
c.uv_fs_req_cleanup(req);
|
||||
if (nread < 0) {
|
||||
_ = c.uv_fs_close(ctx.scheduler.loop, req, ctx.fd, null);
|
||||
const err = makeErrResult(ctx.arena, mapUvErr(@intCast(-nread))) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, err) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
if (ctx.read_buf) |b| ctx.gpa.free(b);
|
||||
ctx.buf.deinit(ctx.gpa);
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
}
|
||||
if (nread == 0) {
|
||||
// EOF
|
||||
_ = c.uv_fs_close(ctx.scheduler.loop, req, ctx.fd, null);
|
||||
const bytes_tree = codecs.ofBytes(ctx.arena, ctx.buf.items) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
const ok = makeOkResult(ctx.arena, bytes_tree) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, ok) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
if (ctx.read_buf) |b| ctx.gpa.free(b);
|
||||
ctx.buf.deinit(ctx.gpa);
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
}
|
||||
const data = ctx.read_buf.?[0..@intCast(nread)];
|
||||
ctx.buf.appendSlice(ctx.gpa, data) catch unreachable;
|
||||
const read_buf = ctx.gpa.alloc(u8, 4096) catch unreachable;
|
||||
ctx.read_buf = read_buf;
|
||||
var uv_buf = c.uv_buf_init(@ptrCast(read_buf.ptr), @intCast(read_buf.len));
|
||||
_ = c.uv_fs_read(ctx.scheduler.loop, req, ctx.fd, &uv_buf, 1, -1, file_read_cb);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Async file write
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const FileWriteCtx = struct {
|
||||
scheduler: *Scheduler,
|
||||
task: *Task,
|
||||
arena: *Arena,
|
||||
gpa: std.mem.Allocator,
|
||||
fd: c_int,
|
||||
path: []const u8,
|
||||
contents: []const u8,
|
||||
written: bool,
|
||||
req: c.uv_fs_t,
|
||||
};
|
||||
|
||||
fn file_write_open_cb(req: [*c]c.uv_fs_t) callconv(.c) void {
|
||||
const ctx = @as(*FileWriteCtx, @ptrCast(@alignCast(req.*.data)));
|
||||
const result = req.*.result;
|
||||
c.uv_fs_req_cleanup(req);
|
||||
if (result < 0) {
|
||||
const err = makeErrResult(ctx.arena, mapUvErr(@intCast(-result))) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, err) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.free(ctx.contents);
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
}
|
||||
ctx.fd = @intCast(result);
|
||||
var uv_buf = c.uv_buf_init(@ptrCast(@constCast(ctx.contents.ptr)), @intCast(ctx.contents.len));
|
||||
_ = c.uv_fs_write(ctx.scheduler.loop, req, ctx.fd, &uv_buf, 1, 0, file_write_cb);
|
||||
}
|
||||
|
||||
fn file_write_cb(req: [*c]c.uv_fs_t) callconv(.c) void {
|
||||
const ctx = @as(*FileWriteCtx, @ptrCast(@alignCast(req.*.data)));
|
||||
const nwrite = req.*.result;
|
||||
c.uv_fs_req_cleanup(req);
|
||||
if (nwrite < 0) {
|
||||
_ = c.uv_fs_close(ctx.scheduler.loop, req, ctx.fd, null);
|
||||
const err = makeErrResult(ctx.arena, mapUvErr(@intCast(-nwrite))) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, err) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.free(ctx.contents);
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
}
|
||||
_ = c.uv_fs_close(ctx.scheduler.loop, req, ctx.fd, file_write_close_cb);
|
||||
}
|
||||
|
||||
fn file_write_close_cb(req: [*c]c.uv_fs_t) callconv(.c) void {
|
||||
const ctx = @as(*FileWriteCtx, @ptrCast(@alignCast(req.*.data)));
|
||||
c.uv_fs_req_cleanup(req);
|
||||
const leaf = ctx.arena.alloc(.leaf) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
const ok = makeOkResult(ctx.arena, leaf) catch {
|
||||
ctx.gpa.destroy(ctx);
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, ok) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
ctx.gpa.free(ctx.path);
|
||||
ctx.gpa.free(ctx.contents);
|
||||
ctx.gpa.destroy(ctx);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Async sleep
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const SleepCtx = struct {
|
||||
scheduler: *Scheduler,
|
||||
task: *Task,
|
||||
arena: *Arena,
|
||||
timer: c.uv_timer_t,
|
||||
};
|
||||
|
||||
fn sleep_cb(handle: [*c]c.uv_timer_t) callconv(.c) void {
|
||||
const ctx = @as(*SleepCtx, @ptrCast(@alignCast(handle.*.data)));
|
||||
defer ctx.scheduler.gpa.destroy(ctx);
|
||||
const leaf = ctx.arena.alloc(.leaf) catch {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
return;
|
||||
};
|
||||
if (ctx.task.finishValue(ctx.arena, leaf) catch false) {
|
||||
ctx.scheduler.completeTask(ctx.task) catch {};
|
||||
} else {
|
||||
ctx.scheduler.runnable.append(ctx.scheduler.gpa, ctx.task) catch {};
|
||||
}
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Public entry point
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
pub fn runIO(gpa: std.mem.Allocator, arena: *Arena, program: u32, perms: IOPerms) !u32 {
|
||||
const action_tree = try isIOSentinel(arena, program) orelse {
|
||||
return error.InvalidIOSentinel;
|
||||
};
|
||||
|
||||
var loop: c.uv_loop_t = undefined;
|
||||
const rc = c.uv_loop_init(&loop);
|
||||
if (rc != 0) return error.LoopInitFailed;
|
||||
defer _ = c.uv_loop_close(&loop);
|
||||
|
||||
var scheduler = try Scheduler.init(gpa, &loop, arena, perms);
|
||||
defer scheduler.deinit();
|
||||
|
||||
const main_task = try scheduler.createTask(null, try arena.alloc(.leaf), try arena.alloc(.leaf), action_tree);
|
||||
try scheduler.runnable.append(gpa, main_task);
|
||||
|
||||
try scheduler.run();
|
||||
|
||||
// Return the main task's result
|
||||
return main_task.result orelse program;
|
||||
}
|
||||
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];
|
||||
}
|
||||
261
ext/zig/src/main.zig
Normal file
261
ext/zig/src/main.zig
Normal file
@@ -0,0 +1,261 @@
|
||||
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");
|
||||
const io_driver = @import("io_driver.zig");
|
||||
|
||||
fn printNode(arena: *Arena, tag: u64, node: u32, io: std.Io) !void {
|
||||
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, node) 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, node) orelse 0;
|
||||
try stdout.interface.print("{d}\n", .{n});
|
||||
},
|
||||
codecs.HOST_BOOL_TAG => {
|
||||
const b = try codecs.toBool(arena, node) 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, node, 0);
|
||||
try stdout.interface.writeAll("\n");
|
||||
},
|
||||
else => {
|
||||
try stdout.interface.print("(tag={d}, payload=", .{tag});
|
||||
try tree.formatTree(&stdout.interface, arena, node, 0);
|
||||
try stdout.interface.writeAll(")\n");
|
||||
},
|
||||
}
|
||||
try stdout.flush();
|
||||
}
|
||||
|
||||
fn runNative(arena: *Arena, tag: u64, bundle_bytes: []const u8, args_raw: []const []const u8, fuel: u64, 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, io, arg);
|
||||
current = try arena.alloc(.{ .app = .{ .func = current, .arg = arg_tree } });
|
||||
}
|
||||
|
||||
const result = try reduce.reduce(current, arena, fuel);
|
||||
try printNode(arena, tag, result, io);
|
||||
}
|
||||
|
||||
fn runIO(arena: *Arena, tag: u64, bundle_bytes: []const u8, args_raw: []const []const u8, fuel: u64, perms: io_driver.IOPerms, 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, io, arg);
|
||||
current = try arena.alloc(.{ .app = .{ .func = current, .arg = arg_tree } });
|
||||
}
|
||||
|
||||
const reduced = try reduce.reduce(current, arena, fuel);
|
||||
|
||||
if (try io_driver.isIOSentinel(arena, reduced) == null) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Error: reduced term is not a valid IO program\n");
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
}
|
||||
|
||||
const result = try io_driver.runIO(arena.allocator, arena, reduced, perms);
|
||||
try printNode(arena, tag, result, io);
|
||||
}
|
||||
|
||||
fn runBundle(arena: *Arena, tag: u64, bundle_bytes: []const u8, args_raw: []const []const u8, fuel: u64, 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, io, 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, fuel);
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
try printNode(arena, hv.tag, hv.payload, io);
|
||||
}
|
||||
|
||||
fn parseArg(arena: *Arena, io: std.Io, s: []const u8) !u32 {
|
||||
if (std.mem.endsWith(u8, s, ".arboricx")) {
|
||||
const bundle_bytes = try std.Io.Dir.cwd().readFileAlloc(io, s, arena.allocator, .limited(10 * 1024 * 1024));
|
||||
defer arena.allocator.free(bundle_bytes);
|
||||
return try bundle.loadBundleDefaultRoot(arena, bundle_bytes);
|
||||
}
|
||||
|
||||
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] [--io] [--unsafe-io] [--fuel N] <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 use_io = false;
|
||||
var io_perms = io_driver.IOPerms{};
|
||||
var fuel: u64 = std.math.maxInt(u64);
|
||||
|
||||
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> [--io] [--unsafe-io] [--fuel N] <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 if (std.mem.eql(u8, args[i], "--io")) {
|
||||
use_io = true;
|
||||
} else if (std.mem.eql(u8, args[i], "--unsafe-io")) {
|
||||
io_perms.allow_read_all = true;
|
||||
io_perms.allow_write_all = true;
|
||||
} else if (std.mem.eql(u8, args[i], "--fuel")) {
|
||||
if (i + 1 >= args.len) {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.writeAll("Usage: tricu-zig --fuel <N> [--io] [--unsafe-io] <bundle> [args...]\n");
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
}
|
||||
const n = std.fmt.parseInt(u64, args[i + 1], 10) catch {
|
||||
var stderr = std.Io.File.stderr().writer(io, &[_]u8{});
|
||||
try stderr.interface.print("Invalid fuel: {s}\n", .{args[i + 1]});
|
||||
try stderr.flush();
|
||||
std.process.exit(1);
|
||||
};
|
||||
fuel = std.math.mul(u64, n, 1_000_000) catch std.math.maxInt(u64);
|
||||
i += 1;
|
||||
} 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] [--io] [--unsafe-io] [--fuel N] <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_io) {
|
||||
runIO(&arena, tag, bundle_bytes, call_args, fuel, io_perms, 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 if (use_kernel) {
|
||||
runBundle(&arena, tag, bundle_bytes, call_args, fuel, 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, fuel, 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);
|
||||
};
|
||||
}
|
||||
}
|
||||
114
ext/zig/src/reduce.zig
Normal file
114
ext/zig/src/reduce.zig
Normal file
@@ -0,0 +1,114 @@
|
||||
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 {
|
||||
var current = term;
|
||||
|
||||
while (true) {
|
||||
switch (arena.get(current).*) {
|
||||
.leaf, .stem, .fork => return current,
|
||||
.app => |app| {
|
||||
if (fuel.* == 0) return error.FuelExhausted;
|
||||
fuel.* -= 1;
|
||||
|
||||
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);
|
||||
|
||||
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);
|
||||
|
||||
switch (arena.get(left).*) {
|
||||
// apply (Fork Leaf a) _ = a
|
||||
.leaf => {
|
||||
const result = try whnf(right_idx, arena, fuel);
|
||||
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;
|
||||
continue;
|
||||
},
|
||||
.fork => {
|
||||
// Reduce argument
|
||||
const arg = try whnf(arg_idx, arena, fuel);
|
||||
|
||||
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 (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;
|
||||
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;
|
||||
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;
|
||||
}
|
||||
119
ext/zig/tests/c_abi_test.c
Normal file
119
ext/zig/tests/c_abi_test.c
Normal file
@@ -0,0 +1,119 @@
|
||||
#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);
|
||||
|
||||
/* Test: tree inspection primitives */
|
||||
uint32_t l = arb_leaf(ctx);
|
||||
uint32_t s = arb_stem(ctx, l);
|
||||
uint32_t f = arb_fork(ctx, s, l);
|
||||
uint32_t a = arb_app(ctx, f, s);
|
||||
|
||||
if (!arb_is_leaf(ctx, l)) {
|
||||
fprintf(stderr, "FAIL: is_leaf on leaf\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
if (arb_is_leaf(ctx, s)) {
|
||||
fprintf(stderr, "FAIL: is_leaf on stem should be false\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
if (!arb_is_stem(ctx, s)) {
|
||||
fprintf(stderr, "FAIL: is_stem on stem\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
if (!arb_is_fork(ctx, f)) {
|
||||
fprintf(stderr, "FAIL: is_fork on fork\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
if (!arb_is_app(ctx, a)) {
|
||||
fprintf(stderr, "FAIL: is_app on app\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t child;
|
||||
if (!arb_get_stem_child(ctx, s, &child) || child != l) {
|
||||
fprintf(stderr, "FAIL: get_stem_child\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t left, right;
|
||||
if (!arb_get_fork_children(ctx, f, &left, &right) || left != s || right != l) {
|
||||
fprintf(stderr, "FAIL: get_fork_children\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t func, arg;
|
||||
if (!arb_get_app_func_arg(ctx, a, &func, &arg) || func != f || arg != s) {
|
||||
fprintf(stderr, "FAIL: get_app_func_arg\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Invalid index should return 0 */
|
||||
if (arb_is_leaf(ctx, 999999)) {
|
||||
fprintf(stderr, "FAIL: is_leaf on invalid index should be false\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
printf("PASS: tree inspection primitives\n");
|
||||
|
||||
arboricx_free(ctx);
|
||||
printf("\nAll C ABI tests passed.\n");
|
||||
return 0;
|
||||
}
|
||||
223
ext/zig/tests/io_protocol_test.c
Normal file
223
ext/zig/tests/io_protocol_test.c
Normal file
@@ -0,0 +1,223 @@
|
||||
#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: construct and verify pure action = Fork 0 Leaf */
|
||||
uint32_t leaf = arb_leaf(ctx);
|
||||
uint32_t zero = arb_of_number(ctx, 0);
|
||||
uint32_t pure_action = arb_fork(ctx, zero, leaf);
|
||||
|
||||
if (!arb_is_fork(ctx, pure_action)) {
|
||||
fprintf(stderr, "FAIL: pure action should be fork\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t tag, payload;
|
||||
if (!arb_get_fork_children(ctx, pure_action, &tag, &payload) ||
|
||||
tag != zero || payload != leaf) {
|
||||
fprintf(stderr, "FAIL: pure action children mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint64_t tag_num;
|
||||
if (!arb_to_number(ctx, tag, &tag_num) || tag_num != 0) {
|
||||
fprintf(stderr, "FAIL: pure action tag should be 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: pure action shape\n");
|
||||
|
||||
/* Test: construct and verify bind action = Fork 1 (Fork left k) */
|
||||
uint32_t one = arb_of_number(ctx, 1);
|
||||
uint32_t left = arb_fork(ctx, zero, leaf); /* pure Leaf */
|
||||
uint32_t k = arb_fork(ctx, leaf, leaf); /* identity as Fork Leaf Leaf */
|
||||
uint32_t bind_pair = arb_fork(ctx, left, k);
|
||||
uint32_t bind_action = arb_fork(ctx, one, bind_pair);
|
||||
|
||||
if (!arb_get_fork_children(ctx, bind_action, &tag, &payload) ||
|
||||
!arb_to_number(ctx, tag, &tag_num) || tag_num != 1) {
|
||||
fprintf(stderr, "FAIL: bind action tag should be 1\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t bind_left, bind_k;
|
||||
if (!arb_get_fork_children(ctx, payload, &bind_left, &bind_k) ||
|
||||
bind_left != left || bind_k != k) {
|
||||
fprintf(stderr, "FAIL: bind payload should be Fork left k\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: bind action shape\n");
|
||||
|
||||
/* Test: construct and verify IO sentinel = Fork "tricuIO" (Fork 1 action) */
|
||||
uint32_t sentinel_str = arb_of_string(ctx, "tricuIO");
|
||||
uint32_t version = arb_of_number(ctx, 1);
|
||||
uint32_t version_action_pair = arb_fork(ctx, version, pure_action);
|
||||
uint32_t io_sentinel = arb_fork(ctx, sentinel_str, version_action_pair);
|
||||
|
||||
if (!arb_is_fork(ctx, io_sentinel)) {
|
||||
fprintf(stderr, "FAIL: IO sentinel should be fork\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t sent_left, sent_right;
|
||||
if (!arb_get_fork_children(ctx, io_sentinel, &sent_left, &sent_right)) {
|
||||
fprintf(stderr, "FAIL: get_fork_children on IO sentinel\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Verify sentinel string */
|
||||
uint8_t* decoded_sentinel;
|
||||
size_t decoded_len;
|
||||
if (!arb_to_string(ctx, sent_left, &decoded_sentinel, &decoded_len) ||
|
||||
decoded_len != 7 || memcmp(decoded_sentinel, "tricuIO", 7) != 0) {
|
||||
fprintf(stderr, "FAIL: IO sentinel string mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
arboricx_free_buf(ctx, decoded_sentinel, decoded_len);
|
||||
|
||||
/* Verify version = 1 and action = pure */
|
||||
uint32_t ver, act;
|
||||
if (!arb_get_fork_children(ctx, sent_right, &ver, &act) ||
|
||||
!arb_to_number(ctx, ver, &tag_num) || tag_num != 1 ||
|
||||
act != pure_action) {
|
||||
fprintf(stderr, "FAIL: IO sentinel version/action mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: IO sentinel shape\n");
|
||||
|
||||
/* Test: putStr action = Fork 10 string */
|
||||
uint32_t ten = arb_of_number(ctx, 10);
|
||||
uint32_t msg = arb_of_string(ctx, "hello");
|
||||
uint32_t putStr_action = arb_fork(ctx, ten, msg);
|
||||
|
||||
if (!arb_get_fork_children(ctx, putStr_action, &tag, &payload) ||
|
||||
!arb_to_number(ctx, tag, &tag_num) || tag_num != 10) {
|
||||
fprintf(stderr, "FAIL: putStr tag should be 10\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: putStr action shape\n");
|
||||
|
||||
/* Test: getLine action = Fork 11 Leaf */
|
||||
uint32_t eleven = arb_of_number(ctx, 11);
|
||||
uint32_t getLine_action = arb_fork(ctx, eleven, leaf);
|
||||
|
||||
if (!arb_get_fork_children(ctx, getLine_action, &tag, &payload) ||
|
||||
!arb_to_number(ctx, tag, &tag_num) || tag_num != 11 ||
|
||||
payload != leaf) {
|
||||
fprintf(stderr, "FAIL: getLine tag should be 11 with Leaf payload\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: getLine action shape\n");
|
||||
|
||||
/* Test: readFile action = Fork 20 path */
|
||||
uint32_t twenty = arb_of_number(ctx, 20);
|
||||
uint32_t path = arb_of_string(ctx, "/tmp/test.txt");
|
||||
uint32_t readFile_action = arb_fork(ctx, twenty, path);
|
||||
|
||||
if (!arb_get_fork_children(ctx, readFile_action, &tag, &payload) ||
|
||||
!arb_to_number(ctx, tag, &tag_num) || tag_num != 20) {
|
||||
fprintf(stderr, "FAIL: readFile tag should be 20\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: readFile action shape\n");
|
||||
|
||||
/* Test: writeFile action = Fork 21 (Fork path contents) */
|
||||
uint32_t twenty_one = arb_of_number(ctx, 21);
|
||||
uint32_t contents = arb_of_string(ctx, "data");
|
||||
uint32_t write_pair = arb_fork(ctx, path, contents);
|
||||
uint32_t writeFile_action = arb_fork(ctx, twenty_one, write_pair);
|
||||
|
||||
if (!arb_get_fork_children(ctx, writeFile_action, &tag, &payload) ||
|
||||
!arb_to_number(ctx, tag, &tag_num) || tag_num != 21) {
|
||||
fprintf(stderr, "FAIL: writeFile tag should be 21\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t wf_path, wf_contents;
|
||||
if (!arb_get_fork_children(ctx, payload, &wf_path, &wf_contents) ||
|
||||
wf_path != path || wf_contents != contents) {
|
||||
fprintf(stderr, "FAIL: writeFile payload should be Fork path contents\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: writeFile action shape\n");
|
||||
|
||||
/* Test: ok result = Fork (Stem Leaf) (Fork val Leaf) */
|
||||
uint32_t stem_leaf = arb_stem(ctx, leaf);
|
||||
uint32_t val_pair = arb_fork(ctx, msg, leaf);
|
||||
uint32_t ok_result = arb_fork(ctx, stem_leaf, val_pair);
|
||||
|
||||
if (!arb_is_fork(ctx, ok_result)) {
|
||||
fprintf(stderr, "FAIL: ok result should be fork\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t ok_tag, ok_rest;
|
||||
if (!arb_get_fork_children(ctx, ok_result, &ok_tag, &ok_rest) ||
|
||||
!arb_is_stem(ctx, ok_tag)) {
|
||||
fprintf(stderr, "FAIL: ok result left should be stem\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t ok_val, ok_leaf;
|
||||
if (!arb_get_fork_children(ctx, ok_rest, &ok_val, &ok_leaf) ||
|
||||
ok_val != msg || ok_leaf != leaf) {
|
||||
fprintf(stderr, "FAIL: ok result right should be Fork val Leaf\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: ok result shape\n");
|
||||
|
||||
/* Test: err result = Fork Leaf (Fork code Leaf) */
|
||||
uint32_t err_code = arb_of_number(ctx, 42);
|
||||
uint32_t err_pair = arb_fork(ctx, err_code, leaf);
|
||||
uint32_t err_result = arb_fork(ctx, leaf, err_pair);
|
||||
|
||||
if (!arb_is_fork(ctx, err_result)) {
|
||||
fprintf(stderr, "FAIL: err result should be fork\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t err_tag, err_rest;
|
||||
if (!arb_get_fork_children(ctx, err_result, &err_tag, &err_rest) ||
|
||||
!arb_is_leaf(ctx, err_tag)) {
|
||||
fprintf(stderr, "FAIL: err result left should be leaf\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t err_c, err_l;
|
||||
if (!arb_get_fork_children(ctx, err_rest, &err_c, &err_l) ||
|
||||
err_c != err_code || err_l != leaf) {
|
||||
fprintf(stderr, "FAIL: err result right should be Fork code Leaf\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: err result shape\n");
|
||||
|
||||
arboricx_free(ctx);
|
||||
printf("\nAll IO protocol tests passed.\n");
|
||||
return 0;
|
||||
}
|
||||
217
ext/zig/tests/io_run_test.c
Normal file
217
ext/zig/tests/io_run_test.c
Normal file
@@ -0,0 +1,217 @@
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include "arboricx.h"
|
||||
|
||||
static uint32_t make_pure(arb_ctx_t* ctx, uint32_t val) {
|
||||
uint32_t zero = arb_of_number(ctx, 0);
|
||||
return arb_fork(ctx, zero, val);
|
||||
}
|
||||
|
||||
static uint32_t make_io_sentinel(arb_ctx_t* ctx, uint32_t action) {
|
||||
uint32_t sentinel = arb_of_string(ctx, "tricuIO");
|
||||
uint32_t version = arb_of_number(ctx, 1);
|
||||
uint32_t version_action = arb_fork(ctx, version, action);
|
||||
return arb_fork(ctx, sentinel, version_action);
|
||||
}
|
||||
|
||||
int main(void) {
|
||||
arb_ctx_t* ctx = arboricx_init();
|
||||
if (!ctx) {
|
||||
fprintf(stderr, "Failed to initialize Arboricx context\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
arb_io_perms_t perms = { 0, 0 };
|
||||
|
||||
/* Test 1: pure "hello" wrapped in IO sentinel */
|
||||
{
|
||||
uint32_t hello = arb_of_string(ctx, "hello");
|
||||
uint32_t pure_hello = make_pure(ctx, hello);
|
||||
uint32_t program = make_io_sentinel(ctx, pure_hello);
|
||||
|
||||
uint32_t result = arb_run_io(ctx, program, &perms);
|
||||
if (result == 0) {
|
||||
fprintf(stderr, "FAIL: pure hello returned 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint8_t* decoded;
|
||||
size_t decoded_len;
|
||||
if (!arb_to_string(ctx, result, &decoded, &decoded_len) ||
|
||||
decoded_len != 5 || memcmp(decoded, "hello", 5) != 0) {
|
||||
fprintf(stderr, "FAIL: pure hello result mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
arboricx_free_buf(ctx, decoded, decoded_len);
|
||||
printf("PASS: pure hello\n");
|
||||
}
|
||||
|
||||
/* Test 2: bind (pure "a") (\_ : pure "done") */
|
||||
{
|
||||
uint32_t a = arb_of_string(ctx, "a");
|
||||
uint32_t done = arb_of_string(ctx, "done");
|
||||
uint32_t pure_a = make_pure(ctx, a);
|
||||
uint32_t pure_done = make_pure(ctx, done);
|
||||
|
||||
/* K pure_done = Fork Leaf pure_done */
|
||||
uint32_t k = arb_fork(ctx, arb_leaf(ctx), pure_done);
|
||||
uint32_t bind_pair = arb_fork(ctx, pure_a, k);
|
||||
uint32_t one = arb_of_number(ctx, 1);
|
||||
uint32_t bind_action = arb_fork(ctx, one, bind_pair);
|
||||
uint32_t program = make_io_sentinel(ctx, bind_action);
|
||||
|
||||
uint32_t result = arb_run_io(ctx, program, &perms);
|
||||
if (result == 0) {
|
||||
fprintf(stderr, "FAIL: bind returned 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint8_t* decoded;
|
||||
size_t decoded_len;
|
||||
if (!arb_to_string(ctx, result, &decoded, &decoded_len) ||
|
||||
decoded_len != 4 || memcmp(decoded, "done", 4) != 0) {
|
||||
fprintf(stderr, "FAIL: bind result mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
arboricx_free_buf(ctx, decoded, decoded_len);
|
||||
printf("PASS: bind pure\n");
|
||||
}
|
||||
|
||||
/* Test 3: putStr "test" (no permissions needed) */
|
||||
{
|
||||
uint32_t test = arb_of_string(ctx, "test");
|
||||
uint32_t ten = arb_of_number(ctx, 10);
|
||||
uint32_t putStr_action = arb_fork(ctx, ten, test);
|
||||
uint32_t program = make_io_sentinel(ctx, putStr_action);
|
||||
|
||||
printf("EXPECT: test\n");
|
||||
uint32_t result = arb_run_io(ctx, program, &perms);
|
||||
if (result == 0) {
|
||||
fprintf(stderr, "FAIL: putStr returned 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
if (!arb_is_leaf(ctx, result)) {
|
||||
fprintf(stderr, "FAIL: putStr should return Leaf\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: putStr\n");
|
||||
}
|
||||
|
||||
/* Test 4: readFile without permission returns err */
|
||||
{
|
||||
uint32_t path = arb_of_string(ctx, "/etc/passwd");
|
||||
uint32_t twenty = arb_of_number(ctx, 20);
|
||||
uint32_t readFile_action = arb_fork(ctx, twenty, path);
|
||||
uint32_t program = make_io_sentinel(ctx, readFile_action);
|
||||
|
||||
uint32_t result = arb_run_io(ctx, program, &perms);
|
||||
if (result == 0) {
|
||||
fprintf(stderr, "FAIL: readFile denied returned 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Should be an err result: Fork Leaf (Fork code Leaf) */
|
||||
uint32_t left, right;
|
||||
if (!arb_get_fork_children(ctx, result, &left, &right) ||
|
||||
!arb_is_leaf(ctx, left)) {
|
||||
fprintf(stderr, "FAIL: readFile denied should be err result\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t code, rest;
|
||||
if (!arb_get_fork_children(ctx, right, &code, &rest) ||
|
||||
!arb_is_leaf(ctx, rest)) {
|
||||
fprintf(stderr, "FAIL: readFile denied err shape mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint64_t code_num;
|
||||
if (!arb_to_number(ctx, code, &code_num) || code_num != 20) {
|
||||
fprintf(stderr, "FAIL: readFile denied code should be 20, got %llu\n",
|
||||
(unsigned long long)code_num);
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: readFile denied\n");
|
||||
}
|
||||
|
||||
/* Test 5: readFile with permission succeeds */
|
||||
{
|
||||
/* Create a temp file first */
|
||||
const char* tmp = "/tmp/tricu_io_test.txt";
|
||||
FILE* f = fopen(tmp, "w");
|
||||
if (!f) {
|
||||
fprintf(stderr, "FAIL: could not create temp file\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
fprintf(f, "hi");
|
||||
fclose(f);
|
||||
|
||||
arb_io_perms_t unsafe_perms = { 1, 0 };
|
||||
uint32_t path = arb_of_string(ctx, tmp);
|
||||
uint32_t twenty = arb_of_number(ctx, 20);
|
||||
uint32_t readFile_action = arb_fork(ctx, twenty, path);
|
||||
uint32_t program = make_io_sentinel(ctx, readFile_action);
|
||||
|
||||
uint32_t result = arb_run_io(ctx, program, &unsafe_perms);
|
||||
if (result == 0) {
|
||||
fprintf(stderr, "FAIL: readFile allowed returned 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Should be ok result: Fork (Stem Leaf) (Fork val Leaf) */
|
||||
uint32_t ok_tag, ok_rest;
|
||||
if (!arb_get_fork_children(ctx, result, &ok_tag, &ok_rest) ||
|
||||
!arb_is_stem(ctx, ok_tag)) {
|
||||
fprintf(stderr, "FAIL: readFile allowed should be ok result\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint32_t val, leaf;
|
||||
if (!arb_get_fork_children(ctx, ok_rest, &val, &leaf) ||
|
||||
!arb_is_leaf(ctx, leaf)) {
|
||||
fprintf(stderr, "FAIL: readFile allowed ok shape mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
|
||||
uint8_t* decoded;
|
||||
size_t decoded_len;
|
||||
if (!arb_to_string(ctx, val, &decoded, &decoded_len) ||
|
||||
decoded_len != 2 || memcmp(decoded, "hi", 2) != 0) {
|
||||
fprintf(stderr, "FAIL: readFile allowed contents mismatch\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
arboricx_free_buf(ctx, decoded, decoded_len);
|
||||
printf("PASS: readFile allowed\n");
|
||||
}
|
||||
|
||||
/* Test 6: invalid sentinel returns 0 */
|
||||
{
|
||||
uint32_t bad = arb_fork(ctx, arb_leaf(ctx), arb_leaf(ctx));
|
||||
uint32_t result = arb_run_io(ctx, bad, &perms);
|
||||
if (result != 0) {
|
||||
fprintf(stderr, "FAIL: invalid sentinel should return 0\n");
|
||||
arboricx_free(ctx);
|
||||
return 1;
|
||||
}
|
||||
printf("PASS: invalid sentinel\n");
|
||||
}
|
||||
|
||||
arboricx_free(ctx);
|
||||
printf("\nAll IO run 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, "append");
|
||||
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, const char *name, 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, name);
|
||||
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", "true", 1) != 0) return 1;
|
||||
if (test_bundle(ctx, "../../test/fixtures/false.arboricx", "false", 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, "id");
|
||||
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, "append", ["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": {
|
||||
|
||||
255
flake.nix
255
flake.nix
@@ -9,27 +9,228 @@
|
||||
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 {}
|
||||
);
|
||||
|
||||
tricuBench =
|
||||
hsLib.overrideCabal
|
||||
(hsLib.doBenchmark (
|
||||
haskellPackages.callCabal2nix packageName self {}
|
||||
))
|
||||
(oldAttrs: {
|
||||
postInstall = (oldAttrs.postInstall or "") + ''
|
||||
mkdir -p $out/bin
|
||||
cp dist/build/tricu-bench/tricu-bench $out/bin/
|
||||
'';
|
||||
});
|
||||
|
||||
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 pkgs.pkg-config ];
|
||||
buildInputs = [ pkgs.libuv ];
|
||||
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 ];
|
||||
buildInputs = [ pkgs.libuv ];
|
||||
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
|
||||
|
||||
# IO protocol shape test
|
||||
gcc -o /tmp/io_protocol_test tests/io_protocol_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/io_protocol_test
|
||||
|
||||
# IO run test (synchronous driver)
|
||||
gcc -o /tmp/io_run_test tests/io_run_test.c \
|
||||
-I ${tricuZig}/include -L ${tricuZig}/lib -larboricx \
|
||||
-Wl,-rpath,${tricuZig}/lib
|
||||
/tmp/io_run_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 public 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"
|
||||
'';
|
||||
};
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# JS FFI host
|
||||
# ------------------------------------------------------------------
|
||||
tricuJs = pkgs.buildNpmPackage {
|
||||
pname = "tricu-js";
|
||||
version = "0.1.0";
|
||||
src = ./ext/js;
|
||||
npmDepsHash = "sha256-81C7tsNcbyZVhm3uqiWdDQxp5LAXXO9aueHdMDztCfM=";
|
||||
nativeBuildInputs = [ pkgs.nodejs tricuZig ];
|
||||
dontNpmBuild = true;
|
||||
installPhase = ''
|
||||
mkdir -p $out/lib/
|
||||
cp -r . $out/lib/
|
||||
cp ${tricuZig}/lib/libarboricx.so $out/lib/src
|
||||
'';
|
||||
};
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# JS FFI host tests (separate target)
|
||||
# ------------------------------------------------------------------
|
||||
tricuJsTests = pkgs.stdenv.mkDerivation {
|
||||
pname = "tricu-js-tests";
|
||||
version = "0.1.0";
|
||||
src = ./.;
|
||||
nativeBuildInputs = [ pkgs.nodejs tricuZig ];
|
||||
buildPhase = "true";
|
||||
doCheck = true;
|
||||
checkPhase = ''
|
||||
export ARBORICX_LIB=${tricuZig}/lib/libarboricx.so
|
||||
export LD_LIBRARY_PATH=${tricuZig}/lib:$LD_LIBRARY_PATH
|
||||
ulimit -s 32768
|
||||
|
||||
cd ext/js
|
||||
# node_modules are pre-fetched by buildNpmPackage; copy them in
|
||||
cp -r ${tricuJs}/lib/tricu-js/node_modules .
|
||||
npm test
|
||||
|
||||
mkdir -p $out
|
||||
echo "All JS tests passed" > $out/result
|
||||
'';
|
||||
};
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# 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-bench = tricuBench;
|
||||
packages.tricu-zig = tricuZig;
|
||||
packages.tricu-zig-tests = tricuZigTests;
|
||||
packages.tricu-php = tricuPhp;
|
||||
packages.tricu-php-tests = tricuPhpTests;
|
||||
packages.tricu-js = tricuJs;
|
||||
packages.tricu-js-tests = tricuJsTests;
|
||||
|
||||
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 +239,34 @@
|
||||
haskellPackages.ghcid
|
||||
customGHC
|
||||
upx
|
||||
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"
|
||||
];
|
||||
WorkingDir = "/app";
|
||||
extraCommands = ''
|
||||
'';
|
||||
};
|
||||
};
|
||||
});
|
||||
}
|
||||
|
||||
155
lib/arboricx/arboricx.tri
Normal file
155
lib/arboricx/arboricx.tri
Normal file
@@ -0,0 +1,155 @@
|
||||
!import "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 _ :
|
||||
readArboricxTreeFromIndex (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))
|
||||
|
||||
wrapHostValueByTag = (tag value rest :
|
||||
matchBool
|
||||
(ok (hostTree value) rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostString? hostString value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostNumber? hostNumber value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostBool? hostBool value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostList? hostList value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostBytes? hostBytes value rest)
|
||||
(err errHostCodecFailed value)
|
||||
(equal? tag hostBytesTag))
|
||||
(equal? tag hostListTag))
|
||||
(equal? tag hostBoolTag))
|
||||
(equal? tag hostNumberTag))
|
||||
(equal? tag hostStringTag))
|
||||
(equal? tag hostTreeTag))
|
||||
|
||||
runArboricxByNameToTyped = (tag nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValueByTag tag value rest))
|
||||
|
||||
runArboricxByNameToTree = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostTreeTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToString = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostStringTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToNumber = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostNumberTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToBool = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostBoolTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToList = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostListTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToBytes = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostBytesTag nameBytes bs args)
|
||||
|
||||
runArboricxToTree = (bs args : runArboricxByNameToTyped hostTreeTag [] bs args)
|
||||
runArboricxToString = (bs args : runArboricxByNameToTyped hostStringTag [] bs args)
|
||||
runArboricxToNumber = (bs args : runArboricxByNameToTyped hostNumberTag [] bs args)
|
||||
runArboricxToBool = (bs args : runArboricxByNameToTyped hostBoolTag [] bs args)
|
||||
runArboricxToList = (bs args : runArboricxByNameToTyped hostListTag [] bs args)
|
||||
runArboricxToBytes = (bs args : runArboricxByNameToTyped hostBytesTag [] bs args)
|
||||
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)
|
||||
(reserved1 afterReserved1 :
|
||||
bindResult (readBytes 8 afterReserved1)
|
||||
(offset afterOffset :
|
||||
bindResult (readBytes 8 afterOffset)
|
||||
(length afterLength :
|
||||
bindResult (readBytes 4 afterLength)
|
||||
(reserved2 afterReserved2 :
|
||||
ok
|
||||
(pair sectionId
|
||||
(pair sectionVersion
|
||||
(pair sectionFlags
|
||||
(pair compression
|
||||
(pair reserved1
|
||||
(pair offset
|
||||
(pair length reserved2)))))))
|
||||
afterReserved2)))))))))
|
||||
|
||||
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)
|
||||
|
||||
sectionRecordReserved1 = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(reserved1 _ : reserved1)
|
||||
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)
|
||||
|
||||
sectionRecordReserved2 = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(_ payload6 :
|
||||
matchPair
|
||||
(_ reserved2 : reserved2)
|
||||
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))
|
||||
6
lib/arboricx/dispatch.tri
Normal file
6
lib/arboricx/dispatch.tri
Normal file
@@ -0,0 +1,6 @@
|
||||
!import "arboricx.tri" !Local
|
||||
|
||||
-- Multi-purpose kernel dispatch.
|
||||
-- runArboricxTyped tag bundleBytes args
|
||||
runArboricxTyped = (tag bs args :
|
||||
runArboricxByNameToTyped tag [] bs args)
|
||||
343
lib/arboricx/manifest.tri
Normal file
343
lib/arboricx/manifest.tri
Normal file
@@ -0,0 +1,343 @@
|
||||
!import "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 (4-byte u32 BE index + length-prefixed role)
|
||||
readRootEntry = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(indexRaw afterIndex :
|
||||
bindResult (readLengthPrefixedString afterIndex)
|
||||
(role afterRole :
|
||||
ok (pair indexRaw 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 4 afterName)
|
||||
(rootIndexRaw afterRootIndex :
|
||||
bindResult (readLengthPrefixedString afterRootIndex)
|
||||
(kind afterKind :
|
||||
bindResult (readLengthPrefixedString afterKind)
|
||||
(abi afterAbi :
|
||||
ok (pair name (pair rootIndexRaw (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 rootIndex (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 = "indexed"
|
||||
expectedTreeHashDomain = "arboricx.indexed.node.v1"
|
||||
expectedTreeNodePayload = "arboricx.indexed.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)))))))))))))))
|
||||
208
lib/arboricx/nodes.tri
Normal file
208
lib/arboricx/nodes.tri
Normal file
@@ -0,0 +1,208 @@
|
||||
!import "common.tri" !Local
|
||||
|
||||
-- Indexed Arboricx node section reader.
|
||||
--
|
||||
-- Node records in the indexed format are just length-prefixed payloads:
|
||||
-- u32 payloadLength || payload
|
||||
-- A payload is one of:
|
||||
-- 0x00
|
||||
-- 0x01 || childIndex:u32be
|
||||
-- 0x02 || leftIndex:u32be || rightIndex:u32be
|
||||
-- Child indices must point strictly backward in the node array.
|
||||
|
||||
readNodeRecord = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(payloadLength afterPayloadLength :
|
||||
bindResult (readBytes (u32BEBytesToNat payloadLength) afterPayloadLength)
|
||||
(payload afterPayload :
|
||||
ok payload afterPayload)))
|
||||
|
||||
nodePayloadKind = (nodePayload : bytesHead nodePayload)
|
||||
|
||||
nodePayloadHasTag? = (tag nodePayload :
|
||||
triage
|
||||
false
|
||||
(actualTag : equal? actualTag tag)
|
||||
(_ _ : false)
|
||||
(nodePayloadKind nodePayload))
|
||||
|
||||
nodePayloadLeaf? = (nodePayload :
|
||||
bytesEq? [(0)] nodePayload)
|
||||
|
||||
nodePayloadStem? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadStemTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 5))
|
||||
|
||||
nodePayloadFork? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadForkTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 9))
|
||||
|
||||
nodePayloadValid? = (nodePayload :
|
||||
or?
|
||||
(nodePayloadLeaf? nodePayload)
|
||||
(or?
|
||||
(nodePayloadStem? nodePayload)
|
||||
(nodePayloadFork? nodePayload)))
|
||||
|
||||
nodePayloadStemChildIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
|
||||
nodePayloadForkLeftIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
|
||||
nodePayloadForkRightIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 5 nodePayload)))
|
||||
|
||||
nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
|
||||
matchList
|
||||
false
|
||||
(nodePayload rest :
|
||||
or?
|
||||
(not? (nodePayloadValid? nodePayload))
|
||||
(self rest))
|
||||
nodeRecords)
|
||||
|
||||
nodePayloadChildIndices = (nodePayload :
|
||||
matchBool
|
||||
t
|
||||
(matchBool
|
||||
(pair (nodePayloadStemChildIndex nodePayload) t)
|
||||
(pair (nodePayloadForkLeftIndex nodePayload)
|
||||
(pair (nodePayloadForkRightIndex nodePayload) t))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
|
||||
-- True iff index n names an element before limit in records.
|
||||
-- For topologically sorted indexed bundles, every child of record i must
|
||||
-- satisfy childIndex < i, so searching only the prefix [0, i) validates both
|
||||
-- bounds and acyclicity.
|
||||
nodeIndexInPrefix? = y (self n records i limit :
|
||||
matchBool
|
||||
false
|
||||
(matchList
|
||||
false
|
||||
(_ rest :
|
||||
matchBool
|
||||
true
|
||||
(self n rest (succ i) limit)
|
||||
(equal? i n))
|
||||
records)
|
||||
(equal? i limit))
|
||||
|
||||
nodeChildIndicesInPrefix? = y (self childIndices records limit :
|
||||
matchList
|
||||
true
|
||||
(childIndex rest :
|
||||
matchBool
|
||||
(self rest records limit)
|
||||
false
|
||||
(nodeIndexInPrefix? childIndex records 0 limit))
|
||||
childIndices)
|
||||
|
||||
nodePayloadIndicesValid? = (nodePayload i records :
|
||||
nodeChildIndicesInPrefix?
|
||||
(nodePayloadChildIndices nodePayload)
|
||||
records
|
||||
i)
|
||||
|
||||
nodeRecordsValidIndicesFrom? = y (self allRecords remainingRecords i :
|
||||
matchList
|
||||
true
|
||||
(nodePayload rest :
|
||||
matchBool
|
||||
(self allRecords rest (succ i))
|
||||
false
|
||||
(nodePayloadIndicesValid? nodePayload i allRecords))
|
||||
remainingRecords)
|
||||
|
||||
nodeRecordsValidIndices? = (nodeRecords i :
|
||||
nodeRecordsValidIndicesFrom? nodeRecords nodeRecords i)
|
||||
|
||||
validateNodeRecords = (nodeRecords rest :
|
||||
matchBool
|
||||
(err errInvalidNodePayload rest)
|
||||
(matchBool
|
||||
(ok nodeRecords rest)
|
||||
(err errMissingNode rest)
|
||||
(nodeRecordsValidIndices? nodeRecords 0))
|
||||
(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)
|
||||
|
||||
nodePayloadToTreeWith = (self nodeRecords nodePayload :
|
||||
matchBool
|
||||
(ok t t)
|
||||
(matchBool
|
||||
(bindResult (self (nodePayloadStemChildIndex nodePayload) nodeRecords)
|
||||
(child _ : ok (t child) t))
|
||||
(bindResult (self (nodePayloadForkLeftIndex nodePayload) nodeRecords)
|
||||
(left _ :
|
||||
bindResult (self (nodePayloadForkRightIndex nodePayload) nodeRecords)
|
||||
(right _ : ok (pair left right) t)))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
|
||||
nodeIndexToTree = y (self nodeIndex nodeRecords :
|
||||
(nodePayload :
|
||||
matchBool
|
||||
(nodePayloadToTreeWith self nodeRecords nodePayload)
|
||||
(err errMissingNode t)
|
||||
(not? (equal? nodePayload t)))
|
||||
(nth nodeIndex nodeRecords))
|
||||
|
||||
readArboricxTreeFromIndex = (rootIndexBytes bs :
|
||||
bindResult (readArboricxNodesSection bs)
|
||||
(nodesSection afterContainer :
|
||||
bindResult (nodeIndexToTree (u32BEBytesToNat rootIndexBytes) (nodesSectionRecords nodesSection))
|
||||
(tree _ : ok tree afterContainer)))
|
||||
|
||||
readArboricxExecutableFromIndex = readArboricxTreeFromIndex
|
||||
143
lib/arboricx/server.tri
Normal file
143
lib/arboricx/server.tri
Normal file
@@ -0,0 +1,143 @@
|
||||
!import "../io.tri" !Local
|
||||
!import "../http.tri" !Local
|
||||
!import "../socket.tri" !Local
|
||||
!import "arboricx.tri" !Local
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Store layout helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
pathJoin = a b : append a (append "/" b)
|
||||
|
||||
objectDir = root shard : pathJoin (pathJoin root "objects") shard
|
||||
|
||||
bundleObjectPath = (root hash :
|
||||
((shard : pathJoin (objectDir root shard) (append hash ".arboricx"))
|
||||
(take 3 hash)))
|
||||
|
||||
--bundleTmpPath = (root hash time :
|
||||
-- pathJoin (pathJoin root "tmp") (append hash (append "." (append (showNumber time) ".tmp"))))
|
||||
|
||||
bundleTmpPath = (root hash time :
|
||||
pathJoin (pathJoin root "tmp") (append hash ".tmp"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Store initialization
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
ensureDir = path : void (createDirectory path)
|
||||
|
||||
ensureStore = (root :
|
||||
foldl
|
||||
thenIO
|
||||
(pure (ok t t))
|
||||
[(ensureDir root)
|
||||
(ensureDir (pathJoin root "tmp"))
|
||||
(ensureDir (pathJoin root "objects"))
|
||||
(ensureDir (pathJoin root "aliases"))
|
||||
(ensureDir (pathJoin (pathJoin root "aliases") "names"))
|
||||
(ensureDir (pathJoin (pathJoin root "aliases") "packages"))
|
||||
(ensureDir (pathJoin root "manifests"))])
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle object write
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
putBundleWrite = (root bundleBytes hash shard tmpPath finalPath :
|
||||
onResult_ (createDirectory (objectDir root shard))
|
||||
(e : pure (err (append "createDirectory: " e) t))
|
||||
(_ :
|
||||
onResult_ (writeBytes tmpPath bundleBytes)
|
||||
(e : pure (err (append "writeBytes: " e) t))
|
||||
(_ :
|
||||
onResult_ (renameFile tmpPath finalPath)
|
||||
(e : pure (err (append "renameFile: " e) t))
|
||||
(_ : pure (ok hash t)))))
|
||||
|
||||
putBundleWithHash = (root bundleBytes time hash :
|
||||
putBundleWrite
|
||||
root
|
||||
bundleBytes
|
||||
hash
|
||||
(take 3 hash)
|
||||
(bundleTmpPath root hash time)
|
||||
(bundleObjectPath root hash))
|
||||
|
||||
putBundle = (root bundleBytes :
|
||||
onResult_ currentTime
|
||||
(e : pure (err (append "currentTime: " e) t))
|
||||
(time :
|
||||
onResult_ (sha256Hex bundleBytes)
|
||||
(e : pure (err (append "sha256Hex: " e) t))
|
||||
(hash :
|
||||
bind (putBundleWithHash root bundleBytes time hash) (r :
|
||||
matchResult
|
||||
(e _ : pure (err (append "withHash: " e) t))
|
||||
(v _ : pure (ok v t))
|
||||
r))))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle object fetch
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
getBundleByHash = (root hash :
|
||||
onResult_ (readFile (bundleObjectPath root hash))
|
||||
(errMsg : pure (err errMsg t))
|
||||
(bytes : pure (ok bytes t)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Registry routes
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
healthRoute = (method target :
|
||||
matchBool
|
||||
(pure (okResponse "OK\n"))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
|
||||
|
||||
putBundleRoute = (root method target body :
|
||||
matchBool
|
||||
(bind (putBundle root body) (result :
|
||||
matchResult
|
||||
(err _ : pure (badRequestResponse (append "Upload failed: " err)))
|
||||
(hash _ : pure (createdResponse hash))
|
||||
result))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
|
||||
|
||||
getBundleRoute = (root method target :
|
||||
matchBool
|
||||
((hash :
|
||||
bind (getBundleByHash root hash) (result :
|
||||
matchResult
|
||||
(errMsg _ : pure (errorResponse 404 errMsg))
|
||||
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
|
||||
result))
|
||||
(drop 23 target))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))
|
||||
|
||||
arboricxRouter = (root method target headers body :
|
||||
matchBool
|
||||
(getBundleRoute root method target)
|
||||
(matchBool
|
||||
(putBundleRoute root method target body)
|
||||
(matchBool
|
||||
(healthRoute method target)
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
|
||||
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
|
||||
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Server entrypoint
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
arboricxHandler = (root client peer :
|
||||
httpHandlerIO (arboricxRouter root) client peer)
|
||||
|
||||
arboricxServer = (root addr port :
|
||||
onResult_ (listenSocket addr port 128)
|
||||
(errMsg : pure (err errMsg t))
|
||||
(server :
|
||||
serveForever server (arboricxHandler root)))
|
||||
143
lib/base.tri
143
lib/base.tri
@@ -33,6 +33,15 @@ lOr = (triage
|
||||
|
||||
matchPair = a : triage _ _ a
|
||||
|
||||
fst = p : matchPair (a b : a) p
|
||||
snd = p : matchPair (a b : b) p
|
||||
|
||||
resultIsOk = result :
|
||||
matchResult (err rest : false) (val rest : true) result
|
||||
|
||||
resultIsErr = result :
|
||||
matchResult (err rest : true) (val rest : false) result
|
||||
|
||||
not? = matchBool false true
|
||||
and? = matchBool id (_ : false)
|
||||
|
||||
@@ -72,3 +81,137 @@ succ = y (self :
|
||||
(t (t t))
|
||||
(_ tail : t t (self tail))
|
||||
t))
|
||||
|
||||
ok = value rest : pair true (pair value rest)
|
||||
err = msg rest : pair false (pair msg rest)
|
||||
|
||||
matchResult = (errCase okCase result :
|
||||
matchPair
|
||||
(tag payload :
|
||||
matchPair
|
||||
(value rest :
|
||||
matchBool
|
||||
(okCase value rest)
|
||||
(errCase value rest)
|
||||
tag)
|
||||
payload)
|
||||
result)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Maybe / Option type
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
nothing = t
|
||||
just = x : t x
|
||||
|
||||
matchMaybe = (nothingCase justCase maybe :
|
||||
triage
|
||||
nothingCase
|
||||
justCase
|
||||
(_ _ : nothingCase)
|
||||
maybe)
|
||||
|
||||
maybe = default f m : matchMaybe default f m
|
||||
maybeMap = f m : matchMaybe nothing (x : just (f x)) m
|
||||
maybeBind = m f : matchMaybe nothing f m
|
||||
maybeOr = default m : matchMaybe default id m
|
||||
maybe? = matchMaybe false (_ : true)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Basic arithmetic
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
ifLazy = (cond thenK elseK :
|
||||
matchBool
|
||||
(thenK t)
|
||||
(elseK t)
|
||||
cond)
|
||||
|
||||
andLazy? = (a bK :
|
||||
ifLazy
|
||||
a
|
||||
bK
|
||||
(_ : false))
|
||||
|
||||
pred = y (self : triage
|
||||
0
|
||||
(_ : 0)
|
||||
(bit rest :
|
||||
matchBool
|
||||
(matchBool
|
||||
0
|
||||
(pair 0 rest)
|
||||
(equal? rest 0))
|
||||
(matchBool
|
||||
0
|
||||
(pair 1 (self rest))
|
||||
(equal? rest 0))
|
||||
bit))
|
||||
|
||||
isZero? = triage true (_ : false) (_ _ : false)
|
||||
|
||||
add = y (self x y :
|
||||
triage
|
||||
y
|
||||
(_ : succ y)
|
||||
(_ _ : succ (self (pred x) y))
|
||||
x)
|
||||
|
||||
sub = y (self a b :
|
||||
ifLazy
|
||||
(isZero? b)
|
||||
(_ : a)
|
||||
(_ : self (pred a) (pred b)))
|
||||
|
||||
lte? = y (self a b :
|
||||
ifLazy
|
||||
(isZero? a)
|
||||
(_ : true)
|
||||
(_ :
|
||||
ifLazy
|
||||
(isZero? b)
|
||||
(_ : false)
|
||||
(_ : self (pred a) (pred b))))
|
||||
|
||||
gte? = a b :
|
||||
lte? b a
|
||||
|
||||
lt? = a b :
|
||||
and? (lte? a b) (not? (equal? a b))
|
||||
|
||||
gt? = a b :
|
||||
lt? b a
|
||||
|
||||
mul = y (self a b :
|
||||
ifLazy
|
||||
(isZero? b)
|
||||
(_ : 0)
|
||||
(_ : add a (self a (pred b))))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Result combinators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
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)
|
||||
|
||||
resultOr = (default result :
|
||||
matchResult
|
||||
(_ _ : default)
|
||||
(value _ : value)
|
||||
result)
|
||||
|
||||
resultMapErr = (f result :
|
||||
matchResult
|
||||
(code rest : err (f code) rest)
|
||||
(value rest : ok value rest)
|
||||
result)
|
||||
|
||||
118
lib/binary.tri
Normal file
118
lib/binary.tri
Normal file
@@ -0,0 +1,118 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "bytes.tri" !Local
|
||||
|
||||
errUnexpectedEof = 1
|
||||
errUnexpectedBytes = 2
|
||||
errUnexpectedByte = 3
|
||||
|
||||
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)
|
||||
(equal? 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)
|
||||
(equal? actual expected))
|
||||
(readU8 bs))
|
||||
|
||||
read2 = (bs : readBytes 2 bs)
|
||||
read4 = (bs : readBytes 4 bs)
|
||||
readU16BEBytes = (bs : read2 bs)
|
||||
readU32BEBytes = (bs : read4 bs)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Parser combinators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
pureParser = value bs : ok value bs
|
||||
failParser = code bs : err code bs
|
||||
|
||||
mapParser = f p bs : mapResult f (p bs)
|
||||
bindParser = p f bs : bindResult (p bs) f
|
||||
thenParser = p q bs : bindResult (p bs) (_ : q)
|
||||
|
||||
orParser = (p q bs :
|
||||
matchResult
|
||||
(_ _ : q bs)
|
||||
(value rest : ok value rest)
|
||||
(p bs))
|
||||
|
||||
readWhile_ = y (self pred bs acc :
|
||||
matchResult
|
||||
(code rest : ok (reverse acc) bs)
|
||||
(value rest :
|
||||
matchBool
|
||||
(self pred rest (pair value acc))
|
||||
(ok (reverse acc) (pair value rest))
|
||||
(pred value))
|
||||
(readU8 bs))
|
||||
|
||||
readWhile = pred bs : readWhile_ pred bs t
|
||||
|
||||
readUntil = pred : readWhile (x : not? (pred x))
|
||||
|
||||
readRemaining = bs : ok bs t
|
||||
|
||||
peekU8 = (bs :
|
||||
matchResult
|
||||
(code rest : err code bs)
|
||||
(value rest : ok value bs)
|
||||
(readU8 bs))
|
||||
|
||||
eof? = (bs :
|
||||
matchBool
|
||||
(ok t bs)
|
||||
(err errUnexpectedEof bs)
|
||||
(emptyList? bs))
|
||||
|
||||
expectAscii = expectBytes
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Endian / int conversion helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
u16BE = bytes : add (mul 256 (head bytes)) (head (tail bytes))
|
||||
|
||||
u16LE = bytes : add (mul 256 (head (tail bytes))) (head bytes)
|
||||
|
||||
readU16BE = bs : bindParser read2 (bytes rest : ok (u16BE bytes) rest) bs
|
||||
readU16LE = bs : bindParser read2 (bytes rest : ok (u16LE bytes) rest) bs
|
||||
15
lib/bytes.tri
Normal file
15
lib/bytes.tri
Normal file
@@ -0,0 +1,15 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
|
||||
bytesNil? = emptyList?
|
||||
|
||||
bytesHead = matchList nothing (h _ : just h)
|
||||
|
||||
bytesTail = matchList nothing (_ r : just r)
|
||||
|
||||
bytesLength = length
|
||||
bytesAppend = append
|
||||
bytesTake = take
|
||||
bytesDrop = drop
|
||||
bytesSplitAt = splitAt
|
||||
bytesEq? = equal?
|
||||
22
lib/conversions.tri
Normal file
22
lib/conversions.tri
Normal file
@@ -0,0 +1,22 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
|
||||
incDecRev = y (self : matchList
|
||||
"1"
|
||||
(digit rest :
|
||||
matchBool
|
||||
(pair 48 (self rest))
|
||||
(pair (succ digit) rest)
|
||||
(equal? digit 57)))
|
||||
|
||||
showNumberRev_ = y (self n acc :
|
||||
matchBool
|
||||
acc
|
||||
(self (pred n) (incDecRev acc))
|
||||
(equal? n 0))
|
||||
|
||||
showNumber = (n :
|
||||
matchBool
|
||||
"0"
|
||||
(reverse (showNumberRev_ n t))
|
||||
(equal? n 0))
|
||||
755
lib/http.tri
Normal file
755
lib/http.tri
Normal file
@@ -0,0 +1,755 @@
|
||||
!import "prelude.tri" !Local
|
||||
!import "io.tri" !Local
|
||||
!import "socket.tri" !Local
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 1. Constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
maxHeaderBytes = 65536
|
||||
maxBodyBytes = 1048576
|
||||
maxUriBytes = 8192
|
||||
|
||||
crlf = pair 13 (pair 10 t)
|
||||
crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 2. Lazy eliminators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
lazyBool = (thenK elseK cond :
|
||||
((chosen : chosen t)
|
||||
(matchBool
|
||||
thenK
|
||||
elseK
|
||||
cond)))
|
||||
|
||||
lazyList = (nilK consK xs :
|
||||
((chosen : chosen t)
|
||||
(matchList
|
||||
nilK
|
||||
(h r : (_ : consK h r))
|
||||
xs)))
|
||||
|
||||
lazyMaybe = (noneK someK m :
|
||||
((chosen : chosen t)
|
||||
(matchMaybe
|
||||
noneK
|
||||
(x : (_ : someK x))
|
||||
m)))
|
||||
|
||||
lazyResult = (errK okK result :
|
||||
((chosen : chosen t)
|
||||
(matchResult
|
||||
(code rest : (_ : errK code rest))
|
||||
(value rest : (_ : okK value rest))
|
||||
result)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 3. Small byte/list helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
chomp = (xs :
|
||||
lazyList
|
||||
(_ : t)
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ : reverse r)
|
||||
(_ : xs)
|
||||
(equal? h 13))
|
||||
(reverse xs))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 4. Response construction
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
statusPhrase = (code :
|
||||
lazyBool
|
||||
(_ : "OK")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Created")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "No Content")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Bad Request")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Not Found")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Method Not Allowed")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Request Header Fields Too Large")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Not Implemented")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "HTTP Version Not Supported")
|
||||
(_ : "Internal Server Error")
|
||||
(equal? code 505))
|
||||
(equal? code 501))
|
||||
(equal? code 431))
|
||||
(equal? code 405))
|
||||
(equal? code 404))
|
||||
(equal? code 400))
|
||||
(equal? code 204))
|
||||
(equal? code 201))
|
||||
(equal? code 200))
|
||||
|
||||
statusLine = (code phrase :
|
||||
append "HTTP/1.1 " (append (showNumber code) (append " " (append phrase "\r\n"))))
|
||||
|
||||
headerLine = (key value :
|
||||
append key (append ": " (append value "\r\n")))
|
||||
|
||||
buildResponse = (status headers body :
|
||||
append
|
||||
(statusLine status (statusPhrase status))
|
||||
(append
|
||||
(foldl (acc h : append acc (headerLine (fst h) (snd h))) "" headers)
|
||||
(append "\r\n" body)))
|
||||
|
||||
response = (status contentType body :
|
||||
buildResponse status
|
||||
[(pair "Content-Type" contentType)
|
||||
(pair "Content-Length" (showNumber (length body)))
|
||||
(pair "Connection" "close")]
|
||||
body)
|
||||
|
||||
emptyResponse = (status :
|
||||
buildResponse status
|
||||
[(pair "Content-Length" "0")
|
||||
(pair "Connection" "close")]
|
||||
"")
|
||||
|
||||
okResponse = (body :
|
||||
response 200 "text/plain; charset=utf-8" body)
|
||||
|
||||
textResponse = (body :
|
||||
response 200 "text/plain; charset=utf-8" body)
|
||||
|
||||
jsonResponse = (body :
|
||||
response 200 "application/json" body)
|
||||
|
||||
createdResponse = (body :
|
||||
response 201 "text/plain; charset=utf-8" body)
|
||||
|
||||
notFoundResponse = (
|
||||
response 404 "text/plain; charset=utf-8" "Not found\n")
|
||||
|
||||
badRequestResponse = (msg :
|
||||
response 400 "text/plain; charset=utf-8" msg)
|
||||
|
||||
errorResponse = (status msg :
|
||||
response status "text/plain; charset=utf-8" msg)
|
||||
|
||||
headersOnly_ = (y (self bs s1 s2 s3 acc :
|
||||
lazyList
|
||||
(_ : reverse acc)
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : reverse (pair 10 (pair 13 (pair 10 (pair 13 acc)))))
|
||||
(_ : self r true false false (pair h acc))
|
||||
(equal? h 10))
|
||||
(_ : self r false false false (pair h acc))
|
||||
s3)
|
||||
(_ : self r false true false (pair h acc))
|
||||
(and? s2 (equal? h 13)))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r false false true (pair h acc))
|
||||
(_ : self r false false false (pair h acc))
|
||||
(and? s1 (equal? h 10)))
|
||||
(equal? h 13))
|
||||
bs))
|
||||
|
||||
headersOnly = (response :
|
||||
headersOnly_ response false false false t)
|
||||
|
||||
responseForMethod = (method resp :
|
||||
lazyBool
|
||||
(_ : headersOnly resp)
|
||||
(_ : resp)
|
||||
(equal? method "HEAD"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 5. Header receive / framing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
|
||||
onResult_ (recv sock 4096)
|
||||
(err :
|
||||
pure (err 400 acc))
|
||||
(chunk :
|
||||
lazyBool
|
||||
(_ : pure (err 400 acc))
|
||||
(_ :
|
||||
((chunkLen :
|
||||
((nextLen :
|
||||
((next :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : pure (ok next t))
|
||||
(_ : self sock pattern maxBytes next nextLen)
|
||||
(contains? pattern next))
|
||||
(_ : pure (err 431 next))
|
||||
(lte? nextLen maxBytes))
|
||||
(append acc chunk)))
|
||||
(add accLen chunkLen)))
|
||||
(length chunk)))
|
||||
(emptyList? chunk))))
|
||||
|
||||
recvUntilMax = (sock pattern maxBytes :
|
||||
recvUntilMax_ sock pattern maxBytes t 0)
|
||||
|
||||
recvUntil = (sock pattern :
|
||||
recvUntilMax sock pattern maxHeaderBytes)
|
||||
|
||||
recvHeaders = (sock :
|
||||
recvUntilMax sock crlfcrlf maxHeaderBytes)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 6. Request line parsing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
readLineBytes_ = (y (self bs acc :
|
||||
lazyList
|
||||
(_ : pair (reverse acc) t)
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ : pair (reverse acc) r)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r acc)
|
||||
(_ : self r (pair h acc))
|
||||
(equal? h 13))
|
||||
(equal? h 10))
|
||||
bs))
|
||||
|
||||
readLineBytes = (bs :
|
||||
((result :
|
||||
pair (chomp (fst result)) (snd result))
|
||||
(readLineBytes_ bs t)))
|
||||
|
||||
parseThreeWords_ = (y (self bs phase acc w1 w2 :
|
||||
lazyList
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : ok (pair w1 (pair w2 (reverse acc))) t)
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(equal? phase 2))
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r 1 t (reverse acc) w2)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r 2 t w1 (reverse acc))
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(equal? phase 1))
|
||||
(equal? phase 0))
|
||||
(_ : self r phase (pair h acc) w1 w2)
|
||||
(equal? h 32))
|
||||
bs))
|
||||
|
||||
parseThreeWords = (bs :
|
||||
parseThreeWords_ bs 0 t t t)
|
||||
|
||||
parseRequestLine = (bs :
|
||||
((lineRest :
|
||||
lazyResult
|
||||
(code bad : err 400 "Bad Request\n")
|
||||
(req ignored : ok req (snd lineRest))
|
||||
(parseThreeWords (fst lineRest)))
|
||||
(readLineBytes bs)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 7. Header parsing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
|
||||
-- ASCII byte helpers below are structural on the Tree Calculus numeral
|
||||
-- spine. Do not replace them with lte?/sub based checks: these names are
|
||||
-- normalized at import time under abstract byte inputs.
|
||||
boolNot? = (b :
|
||||
matchBool false true b)
|
||||
|
||||
boolOr? = (a b :
|
||||
matchBool true b a)
|
||||
|
||||
boolAnd? = (a b :
|
||||
matchBool b false a)
|
||||
|
||||
low5NonZero? = (b0 b1 b2 b3 b4 :
|
||||
boolOr?
|
||||
(bit1? b0)
|
||||
(boolOr?
|
||||
(bit1? b1)
|
||||
(boolOr?
|
||||
(bit1? b2)
|
||||
(boolOr?
|
||||
(bit1? b3)
|
||||
(bit1? b4)))))
|
||||
|
||||
low5TooHighForUpper? = (b0 b1 b2 b3 b4 :
|
||||
boolAnd?
|
||||
(bit1? b4)
|
||||
(boolAnd?
|
||||
(bit1? b3)
|
||||
(boolOr?
|
||||
(bit1? b2)
|
||||
(boolAnd?
|
||||
(bit1? b1)
|
||||
(bit1? b0)))))
|
||||
|
||||
upperLow5? = (b0 b1 b2 b3 b4 :
|
||||
boolAnd?
|
||||
(low5NonZero? b0 b1 b2 b3 b4)
|
||||
(boolNot?
|
||||
(low5TooHighForUpper? b0 b1 b2 b3 b4)))
|
||||
|
||||
lowerAsciiBits = (b0 b1 b2 b3 b4 :
|
||||
pair b0
|
||||
(pair b1
|
||||
(pair b2
|
||||
(pair b3
|
||||
(pair b4
|
||||
(pair true
|
||||
(pair true 0)))))))
|
||||
|
||||
toLowerAsciiByte = (c :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b0 r0 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b1 r1 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b2 r2 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b3 r3 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b4 r4 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b5 r5 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b6 r6 :
|
||||
matchBool
|
||||
(lowerAsciiBits b0 b1 b2 b3 b4)
|
||||
c
|
||||
(boolAnd?
|
||||
(isZero? r6)
|
||||
(boolAnd?
|
||||
(bit1? b6)
|
||||
(boolAnd?
|
||||
(bit0? b5)
|
||||
(upperLow5? b0 b1 b2 b3 b4)))))
|
||||
r5)
|
||||
r4)
|
||||
r3)
|
||||
r2)
|
||||
r1)
|
||||
r0)
|
||||
c)
|
||||
|
||||
finishHeaderLine = (self r headers key value seenColon :
|
||||
matchBool
|
||||
(matchBool
|
||||
(err 400 "Bad Request\n")
|
||||
(ok (reverse headers) r)
|
||||
seenColon)
|
||||
(matchBool
|
||||
(self r
|
||||
(pair (pair (reverse key) (reverse value)) headers)
|
||||
t
|
||||
t
|
||||
false
|
||||
true)
|
||||
(err 400 "Bad Request\n")
|
||||
seenColon)
|
||||
(emptyList? key))
|
||||
|
||||
finishHeaderEOF = (headers key value seenColon :
|
||||
matchBool
|
||||
(ok (reverse headers) t)
|
||||
(matchBool
|
||||
(ok (reverse (pair (pair (reverse key) (reverse value)) headers)) t)
|
||||
(err 400 "Bad Request\n")
|
||||
seenColon)
|
||||
(emptyList? key))
|
||||
|
||||
parseHeaders_ = (self bs headers key value seenColon trimValue :
|
||||
matchList
|
||||
(finishHeaderEOF headers key value seenColon)
|
||||
(h r :
|
||||
matchBool
|
||||
(finishHeaderLine self r headers key value seenColon)
|
||||
(matchBool
|
||||
(self r headers key value seenColon trimValue)
|
||||
(matchBool
|
||||
(matchBool
|
||||
(self r headers key value true true)
|
||||
(self r headers key (pair h value) true false)
|
||||
(boolAnd? trimValue (equal? h 32)))
|
||||
(matchBool
|
||||
(self r headers key value true true)
|
||||
(self r headers (pair (toLowerAsciiByte h) key) value false true)
|
||||
(equal? h 58))
|
||||
seenColon)
|
||||
(equal? h 13))
|
||||
(equal? h 10))
|
||||
bs)
|
||||
|
||||
parseHeaders = (bs :
|
||||
y parseHeaders_ bs t t t false true)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 8. Content-Length parsing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
bit0? = (x :
|
||||
isZero? x)
|
||||
|
||||
bit1? = (x :
|
||||
triage
|
||||
false
|
||||
(a : isZero? a)
|
||||
(_ _ : false)
|
||||
x)
|
||||
|
||||
low3 = (b0 b1 b2 :
|
||||
matchBool
|
||||
(matchBool
|
||||
(matchBool 7 6 (bit1? b0))
|
||||
(matchBool 5 4 (bit1? b0))
|
||||
(bit1? b1))
|
||||
(matchBool
|
||||
(matchBool 3 2 (bit1? b0))
|
||||
(matchBool 1 0 (bit1? b0))
|
||||
(bit1? b1))
|
||||
(bit1? b2))
|
||||
|
||||
decimalDigit = (c :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b0 r0 :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b1 r1 :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b2 r2 :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b3 r3 :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b4 r4 :
|
||||
triage
|
||||
nothing
|
||||
(_ : nothing)
|
||||
(b5 r5 :
|
||||
matchBool
|
||||
(matchBool
|
||||
(matchBool
|
||||
(matchBool
|
||||
(matchBool
|
||||
(just (low3 b0 b1 b2))
|
||||
(matchBool
|
||||
(matchBool
|
||||
(just (matchBool 9 8 (bit1? b0)))
|
||||
nothing
|
||||
(bit0? b2))
|
||||
nothing
|
||||
(bit0? b1))
|
||||
(bit0? b3))
|
||||
nothing
|
||||
(bit1? b5))
|
||||
nothing
|
||||
(bit1? b4))
|
||||
nothing
|
||||
(isZero? r5))
|
||||
nothing
|
||||
true)
|
||||
r4)
|
||||
r3)
|
||||
r2)
|
||||
r1)
|
||||
r0)
|
||||
c)
|
||||
|
||||
readDecimal_ = (self bytes acc :
|
||||
matchList
|
||||
(just acc)
|
||||
(h r :
|
||||
matchMaybe
|
||||
nothing
|
||||
(d : self r (add (mul acc 10) d))
|
||||
(decimalDigit h))
|
||||
bytes)
|
||||
|
||||
readDecimal = (bytes :
|
||||
matchBool
|
||||
nothing
|
||||
(y readDecimal_ bytes 0)
|
||||
(emptyList? bytes))
|
||||
|
||||
parseContentLengthValue = (raw :
|
||||
matchMaybe
|
||||
(err 400 "Bad Request\n")
|
||||
(n : ok (just n) t)
|
||||
(readDecimal raw))
|
||||
|
||||
contentLength_ = (self headers :
|
||||
matchList
|
||||
(ok nothing t)
|
||||
(h r :
|
||||
matchBool
|
||||
(parseContentLengthValue (snd h))
|
||||
(self r)
|
||||
(equal? "content-length" (fst h)))
|
||||
headers)
|
||||
|
||||
contentLength = (headers :
|
||||
y contentLength_ headers)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 9. Body reading
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
consumeAvailable_ = (y (self bytes remaining acc :
|
||||
lazyList
|
||||
(_ : pair (reverse acc) (pair remaining t))
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ : pair (reverse acc) (pair 0 r))
|
||||
(_ : self r (pred remaining) (pair h acc))
|
||||
(isZero? remaining))
|
||||
bytes))
|
||||
|
||||
consumeAvailable = (bytes n :
|
||||
consumeAvailable_ bytes n t)
|
||||
|
||||
readBodyN_ = (y (self sock remaining acc :
|
||||
lazyBool
|
||||
(_ : pure (ok acc t))
|
||||
(_ :
|
||||
onResult_ (recv sock remaining)
|
||||
(err :
|
||||
pure (err 400 acc))
|
||||
(chunk :
|
||||
((got :
|
||||
lazyBool
|
||||
(_ : pure (err 400 acc))
|
||||
(_ : self sock (sub remaining got) (append acc chunk))
|
||||
(equal? got 0))
|
||||
(length chunk))))
|
||||
(isZero? remaining)))
|
||||
|
||||
readBodyN = (sock n acc :
|
||||
readBodyN_ sock n acc)
|
||||
|
||||
readBody = (sock headers initialBytes :
|
||||
matchResult
|
||||
(status msg :
|
||||
pure (err status "Bad Request\n"))
|
||||
(maybeLen rest :
|
||||
lazyMaybe
|
||||
(_ : pure (ok t initialBytes))
|
||||
(n :
|
||||
((consumed :
|
||||
((body0 :
|
||||
((remaining :
|
||||
lazyBool
|
||||
(_ : pure (ok body0 t))
|
||||
(_ :
|
||||
onOk (readBodyN sock remaining body0)
|
||||
(body rest : pure (ok body t)))
|
||||
(isZero? remaining))
|
||||
(fst (snd consumed))))
|
||||
(fst consumed)))
|
||||
(consumeAvailable initialBytes n)))
|
||||
maybeLen)
|
||||
(contentLength headers))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 10. Request validation
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
validMethod? = (method :
|
||||
lazyBool
|
||||
(_ : true)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : true)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : true)
|
||||
(_ : false)
|
||||
(equal? method "HEAD"))
|
||||
(equal? method "POST"))
|
||||
(equal? method "GET"))
|
||||
|
||||
validVersion? = (version :
|
||||
lazyBool
|
||||
(_ : true)
|
||||
(_ : equal? version "HTTP/1.0")
|
||||
(equal? version "HTTP/1.1"))
|
||||
|
||||
validTarget? = (target :
|
||||
startsWith? "/" target)
|
||||
|
||||
validateRequest = (method target version headers :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : ok t t)
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(validTarget? target))
|
||||
(_ : err 505 "HTTP Version Not Supported\n")
|
||||
(validVersion? version))
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(validMethod? method))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 11. Handler pipeline
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
routerMethod = (method :
|
||||
lazyBool
|
||||
(_ : "GET")
|
||||
(_ : method)
|
||||
(equal? method "HEAD"))
|
||||
|
||||
respondAndClose = (sock resp :
|
||||
onOk_ (finally (send sock resp) (closeSocket_ sock)) (_ :
|
||||
pure (ok t t)))
|
||||
|
||||
handleReadableRequest = (router client method target headers rest3 :
|
||||
onResult_ (readBody client headers rest3)
|
||||
(status :
|
||||
respondAndClose client
|
||||
(responseForMethod method
|
||||
(badRequestResponse "Bad Request\n")))
|
||||
(body :
|
||||
respondAndClose client
|
||||
(responseForMethod method
|
||||
(router (routerMethod method) target headers body))))
|
||||
|
||||
handleParsedHeaders = (router client method target version rest2 :
|
||||
matchResult
|
||||
(code bad :
|
||||
respondAndClose client (badRequestResponse "Bad Request\n"))
|
||||
(headers rest3 :
|
||||
matchResult
|
||||
(status msg :
|
||||
respondAndClose client
|
||||
(responseForMethod method (errorResponse status msg)))
|
||||
(ignored rest :
|
||||
handleReadableRequest router client method target headers rest3)
|
||||
(validateRequest method target version headers))
|
||||
(parseHeaders rest2))
|
||||
|
||||
handleParsedRequest = (router client req rest2 :
|
||||
((method :
|
||||
((target :
|
||||
((version :
|
||||
handleParsedHeaders router client method target version rest2)
|
||||
(snd (snd req))))
|
||||
(fst (snd req))))
|
||||
(fst req)))
|
||||
|
||||
httpHandler = (router client peer :
|
||||
onResult_ (recvHeaders client)
|
||||
(status :
|
||||
respondAndClose client
|
||||
(badRequestResponse "Bad Request\n"))
|
||||
(raw :
|
||||
matchResult
|
||||
(code bad :
|
||||
respondAndClose client (badRequestResponse "Bad Request\n"))
|
||||
(req rest2 :
|
||||
handleParsedRequest router client req rest2)
|
||||
(parseRequestLine raw)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 12. IO-aware handler pipeline
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
handleReadableRequestIO = (routerIO client method target headers rest3 :
|
||||
onResult_ (readBody client headers rest3)
|
||||
(status :
|
||||
respondAndClose client
|
||||
(responseForMethod method
|
||||
(badRequestResponse "Bad Request\n")))
|
||||
(body :
|
||||
bind (routerIO (routerMethod method) target headers body) (resp :
|
||||
respondAndClose client (responseForMethod method resp))))
|
||||
|
||||
handleParsedHeadersIO = (routerIO client method target version rest2 :
|
||||
matchResult
|
||||
(code bad :
|
||||
respondAndClose client (badRequestResponse "Bad Request\n"))
|
||||
(headers rest3 :
|
||||
matchResult
|
||||
(status msg :
|
||||
respondAndClose client
|
||||
(responseForMethod method (errorResponse status msg)))
|
||||
(ignored rest :
|
||||
handleReadableRequestIO routerIO client method target headers rest3)
|
||||
(validateRequest method target version headers))
|
||||
(parseHeaders rest2))
|
||||
|
||||
handleParsedRequestIO = (routerIO client req rest2 :
|
||||
((method :
|
||||
((target :
|
||||
((version :
|
||||
handleParsedHeadersIO routerIO client method target version rest2)
|
||||
(snd (snd req))))
|
||||
(fst (snd req))))
|
||||
(fst req)))
|
||||
|
||||
httpHandlerIO = (routerIO client peer :
|
||||
onResult_ (recvHeaders client)
|
||||
(status :
|
||||
respondAndClose client
|
||||
(badRequestResponse "Bad Request\n"))
|
||||
(raw :
|
||||
matchResult
|
||||
(code bad :
|
||||
respondAndClose client (badRequestResponse "Bad Request\n"))
|
||||
(req rest2 :
|
||||
handleParsedRequestIO routerIO client req rest2)
|
||||
(parseRequestLine raw)))
|
||||
157
lib/io.tri
Normal file
157
lib/io.tri
Normal file
@@ -0,0 +1,157 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "conversions.tri" !Local
|
||||
|
||||
-- IO constructors for host-interpreted interaction trees.
|
||||
-- Free-monad style: Bind is the single sequencing mechanism.
|
||||
|
||||
version = 1
|
||||
|
||||
io = action : pair "tricuIO" (pair version action)
|
||||
|
||||
pure = x : pair 0 x
|
||||
bind = action k : pair 1 (pair action k)
|
||||
|
||||
putStr = s : pair 10 s
|
||||
getLine = pair 11 t
|
||||
|
||||
readFile = p : pair 20 p
|
||||
writeFile = p c : pair 21 (pair p c)
|
||||
putBytes = bs : pair 12 bs
|
||||
writeBytes = p c : pair 22 (pair p c)
|
||||
|
||||
listDirectory = p : pair 23 p
|
||||
renameFile = old new : pair 24 (pair old new)
|
||||
createDirectory = p : pair 25 p
|
||||
deleteFile = p : pair 26 p
|
||||
fileExists = p : pair 27 p
|
||||
|
||||
sha256Hex = bs : pair 28 bs
|
||||
currentTime = pair 29 t
|
||||
|
||||
ask = pair 30 t
|
||||
local = f action : pair 31 (pair f action)
|
||||
|
||||
get = pair 40 t
|
||||
put = s : pair 41 s
|
||||
|
||||
fork = action : pair 60 action
|
||||
await = handle : pair 61 handle
|
||||
yield = pair 62 t
|
||||
sleep = ms : pair 63 ms
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Generic sequencing combinators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
thenIO = a b : bind a (_ : b)
|
||||
mapIO = action f : bind action (x : pure (f x))
|
||||
void = action : bind action (_ : pure t)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Conditional execution
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
when = cond action : matchBool action (pure t) cond
|
||||
unless = cond action : matchBool (pure t) action cond
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Infinite loop
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
forever = y (self : action :
|
||||
bind action (_ :
|
||||
self action))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Result-aware combinators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- Propagate driver Result on error; run okCase on success.
|
||||
onOk = action okCase :
|
||||
bind action (result :
|
||||
matchResult
|
||||
(err rest : pure result)
|
||||
okCase
|
||||
result)
|
||||
|
||||
-- Same as onOk, but the okCase only receives the value (rest is dropped).
|
||||
onOk_ = action okCase :
|
||||
bind action (result :
|
||||
matchResult
|
||||
(err rest : pure result)
|
||||
(val _ : okCase val)
|
||||
result)
|
||||
|
||||
-- Generalized Result handler with explicit branches.
|
||||
onResult = action errCase okCase :
|
||||
bind action (result :
|
||||
matchResult errCase okCase result)
|
||||
|
||||
-- Same as onResult, but handlers only receive the value/msg (rest is dropped).
|
||||
onResult_ = action errCase okCase :
|
||||
bind action (result :
|
||||
matchResult
|
||||
(err _ : errCase err)
|
||||
(val _ : okCase val)
|
||||
result)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Convenience helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
print = s : void (putStr s)
|
||||
putStrLn = s : void (putStr (append s "\n"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Result-aware file helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
onReadFile = path : onResult (readFile path)
|
||||
|
||||
onWriteFile = path contents : onResult (writeFile path contents)
|
||||
|
||||
onListDirectory = path : onResult (listDirectory path)
|
||||
onRenameFile = old new : onResult (renameFile old new)
|
||||
onCreateDirectory = path : onResult (createDirectory path)
|
||||
onDeleteFile = path : onResult (deleteFile path)
|
||||
onFileExists = path : onResult (fileExists path)
|
||||
onSha256Hex = bs : onResult (sha256Hex bs)
|
||||
onCurrentTime = onResult currentTime
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Convenience helpers for the common cases
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
readFileOrPrintError = (path okCase :
|
||||
onReadFile path
|
||||
(err rest : putStrLn (append "Read failed: " err))
|
||||
okCase)
|
||||
|
||||
writeFileOrPrintError = (path contents okCase :
|
||||
onWriteFile path contents
|
||||
(err rest : putStrLn (append "Write failed: " err))
|
||||
okCase)
|
||||
|
||||
copyFile = (src dst :
|
||||
onResult (readFile src)
|
||||
(err rest : putStrLn (append "Read failed: " err))
|
||||
(contents rest :
|
||||
onResult (writeFile dst contents)
|
||||
(err rest : putStrLn (append "Write failed: " err))
|
||||
(_ _ : pure t)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Resource-safe combinators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
finally = action cleanup :
|
||||
bind action (result :
|
||||
bind cleanup (_ :
|
||||
pure result))
|
||||
|
||||
bracket = acquire release use :
|
||||
bind acquire (resource :
|
||||
bind (use resource) (result :
|
||||
bind (release resource) (_ :
|
||||
pure result)))
|
||||
194
lib/list.tri
194
lib/list.tri
@@ -27,19 +27,23 @@ 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
|
||||
(_ tail : succ (self tail)))
|
||||
|
||||
reverse = y (self : matchList
|
||||
t
|
||||
(head tail : append (self tail) (pair head t)))
|
||||
reverse_ = y (self xs acc :
|
||||
matchList
|
||||
acc
|
||||
(h r : self r (pair h acc))
|
||||
xs)
|
||||
|
||||
reverse = xs : reverse_ xs t
|
||||
|
||||
snoc = y (self x : matchList
|
||||
(pair x t)
|
||||
@@ -68,3 +72,179 @@ any? = y (self pred : matchList
|
||||
(h z : or? (pred h) (self pred z)))
|
||||
|
||||
intersect = xs ys : filter (x : lExist? x ys) xs
|
||||
|
||||
nth_ = y (self n xs i :
|
||||
matchList
|
||||
t
|
||||
(h r :
|
||||
matchBool
|
||||
h
|
||||
(self n r (succ i))
|
||||
(equal? i n))
|
||||
xs)
|
||||
|
||||
nth = n xs : nth_ n xs 0
|
||||
|
||||
headMaybe = matchList nothing (h _ : just h)
|
||||
|
||||
lastMaybe = y (self : matchList
|
||||
nothing
|
||||
(hd tl : matchBool
|
||||
(just hd)
|
||||
(self tl)
|
||||
(emptyList? tl)))
|
||||
|
||||
nthMaybe_ = y (self n xs i :
|
||||
matchList
|
||||
nothing
|
||||
(h r :
|
||||
matchBool
|
||||
(just h)
|
||||
(self n r (succ i))
|
||||
(equal? i n))
|
||||
xs)
|
||||
|
||||
nthMaybe = n xs : nthMaybe_ n xs 0
|
||||
|
||||
take_ = y (self n xs i :
|
||||
matchList
|
||||
t
|
||||
(h r :
|
||||
matchBool
|
||||
t
|
||||
(pair h (self n r (succ i)))
|
||||
(equal? i n))
|
||||
xs)
|
||||
|
||||
take = n xs : take_ n xs 0
|
||||
|
||||
drop_ = y (self n xs i :
|
||||
matchBool
|
||||
xs
|
||||
(matchList
|
||||
t
|
||||
(_ r : self n r (succ i))
|
||||
xs)
|
||||
(equal? i n))
|
||||
|
||||
drop = n xs : drop_ n xs 0
|
||||
|
||||
splitAt = n xs : pair (take n xs) (drop n xs)
|
||||
|
||||
concatMap_ = y (self f xs :
|
||||
matchList
|
||||
t
|
||||
(h r : append (f h) (self f r))
|
||||
xs)
|
||||
|
||||
concatMap = f xs : concatMap_ f xs
|
||||
|
||||
find = y (self pred xs :
|
||||
matchList
|
||||
nothing
|
||||
(h r : matchBool (just h) (self pred r) (pred h))
|
||||
xs)
|
||||
|
||||
partition_ = y (self pred xs trues falses :
|
||||
matchList
|
||||
(pair (reverse trues) (reverse falses))
|
||||
(h r :
|
||||
matchBool
|
||||
(self pred r (pair h trues) falses)
|
||||
(self pred r trues (pair h falses))
|
||||
(pred h))
|
||||
xs)
|
||||
|
||||
partition = pred xs : partition_ pred xs t t
|
||||
|
||||
strLength = length
|
||||
strAppend = append
|
||||
strEq? = equal?
|
||||
strEmpty? = emptyList?
|
||||
|
||||
startsWith? = (prefix input :
|
||||
((go :
|
||||
go prefix input)
|
||||
(y (self p s :
|
||||
matchList
|
||||
true
|
||||
(ph pr :
|
||||
matchList
|
||||
false
|
||||
(sh sr :
|
||||
matchBool
|
||||
(self pr sr)
|
||||
false
|
||||
(equal? ph sh))
|
||||
s)
|
||||
p))))
|
||||
|
||||
endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
|
||||
|
||||
contains? = y (self needle haystack :
|
||||
matchBool
|
||||
true
|
||||
(matchList
|
||||
false
|
||||
(_ r : self needle r)
|
||||
haystack)
|
||||
(startsWith? needle haystack))
|
||||
|
||||
lines_ = y (self str :
|
||||
matchList
|
||||
(acc current : snoc (reverse current) acc)
|
||||
(h r :
|
||||
acc current :
|
||||
matchBool
|
||||
(self r (snoc (reverse current) acc) t)
|
||||
(self r acc (pair h current))
|
||||
(equal? h 10))
|
||||
str)
|
||||
|
||||
lines = str : lines_ str t t
|
||||
|
||||
unlines = y (self lines :
|
||||
matchList
|
||||
""
|
||||
(h r : append h (append "\n" (self r)))
|
||||
lines)
|
||||
|
||||
words_ = y (self str :
|
||||
matchList
|
||||
(acc current :
|
||||
matchBool
|
||||
acc
|
||||
(snoc (reverse current) acc)
|
||||
(emptyList? current))
|
||||
(h r :
|
||||
acc current :
|
||||
matchBool
|
||||
(matchBool
|
||||
(self r acc current)
|
||||
(self r (snoc (reverse current) acc) t)
|
||||
(emptyList? current))
|
||||
(self r acc (pair h current))
|
||||
(equal? h 32))
|
||||
str)
|
||||
|
||||
words = str : words_ str t t
|
||||
|
||||
unwords = y (self words :
|
||||
matchList
|
||||
""
|
||||
(h r :
|
||||
matchBool
|
||||
h
|
||||
(append h (append " " (self r)))
|
||||
(emptyList? r))
|
||||
words)
|
||||
|
||||
zipWith = y (self f xs ys :
|
||||
matchList
|
||||
t
|
||||
(xh xt :
|
||||
matchList
|
||||
t
|
||||
(yh yt : pair (f xh yh) (self f xt yt))
|
||||
ys)
|
||||
xs)
|
||||
|
||||
6
lib/prelude.tri
Normal file
6
lib/prelude.tri
Normal file
@@ -0,0 +1,6 @@
|
||||
-- Standard tricu prelude.
|
||||
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "bytes.tri" !Local
|
||||
!import "conversions.tri" !Local
|
||||
82
lib/socket.tri
Normal file
82
lib/socket.tri
Normal file
@@ -0,0 +1,82 @@
|
||||
!import "base.tri" !Local
|
||||
!import "io.tri" !Local
|
||||
|
||||
-- Socket primitives for the IO driver.
|
||||
-- ok value t -- pair true (pair value t)
|
||||
-- err msg t -- pair false (pair msg t)
|
||||
|
||||
socket = pair 70 t
|
||||
closeSocket = sock : pair 71 sock
|
||||
bindSocket = sock addr port : pair 72 (pair sock (pair addr port))
|
||||
listen = sock backlog : pair 73 (pair sock backlog)
|
||||
accept = sock : pair 74 sock
|
||||
connect = sock addr port : pair 75 (pair sock (pair addr port))
|
||||
recv = sock maxBytes : pair 76 (pair sock maxBytes)
|
||||
send = sock bytes : pair 77 (pair sock bytes)
|
||||
getSocketName = sock : pair 78 sock
|
||||
|
||||
-- Result-aware wrappers over raw socket actions
|
||||
onSocket = onResult socket
|
||||
onBindSocket = sock addr port : onResult (bindSocket sock addr port)
|
||||
onListen = sock backlog : onResult (listen sock backlog)
|
||||
onAccept = sock : onResult (accept sock)
|
||||
onConnect = sock addr port : onResult (connect sock addr port)
|
||||
onRecv = sock maxBytes : onResult (recv sock maxBytes)
|
||||
onSend = sock bytes : onResult (send sock bytes)
|
||||
onGetSocketName = sock : onResult (getSocketName sock)
|
||||
|
||||
-- Result-aware wrappers that drop the 'rest' parameter
|
||||
onSocket_ = onResult_ socket
|
||||
onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port)
|
||||
onListen_ = sock backlog : onResult_ (listen sock backlog)
|
||||
onAccept_ = sock : onResult_ (accept sock)
|
||||
onConnect_ = sock addr port : onResult_ (connect sock addr port)
|
||||
onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes)
|
||||
onSend_ = sock bytes : onResult_ (send sock bytes)
|
||||
onGetSocketName_ = sock : onResult_ (getSocketName sock)
|
||||
|
||||
-- Close a socket, ignoring errors.
|
||||
closeSocket_ = sock : void (closeSocket sock)
|
||||
|
||||
-- Create a listening socket bound to an address and port.
|
||||
-- Returns ok listenSocket or err message.
|
||||
listenSocket = addr port backlog :
|
||||
onOk_ socket (server :
|
||||
onOk_ (bindSocket server addr port) (_ :
|
||||
onOk_ (listen server backlog) (_ :
|
||||
pure (ok server t))))
|
||||
|
||||
-- Accept a connection with explicit error and ok branches.
|
||||
-- okHandler receives (clientSocket, peerAddr).
|
||||
withAccepted = (server errHandler okHandler :
|
||||
onResult (accept server)
|
||||
errHandler
|
||||
(accepted rest :
|
||||
okHandler (fst accepted) (snd accepted)))
|
||||
|
||||
-- Same as withAccepted, but handlers drop the useless 'rest' parameter.
|
||||
withAccepted_ = (server errHandler okHandler :
|
||||
onResult_ (accept server)
|
||||
errHandler
|
||||
(accepted :
|
||||
okHandler (fst accepted) (snd accepted)))
|
||||
|
||||
serveOnce = (server handler :
|
||||
withAccepted_ server
|
||||
(err : pure t)
|
||||
(client peer :
|
||||
handler client peer))
|
||||
|
||||
serveForkingOnce = (server handler :
|
||||
withAccepted_ server
|
||||
(err : pure t)
|
||||
(client peer :
|
||||
fork (handler client peer)))
|
||||
|
||||
serveForever = (server handler :
|
||||
forever (serveForkingOnce server handler))
|
||||
|
||||
connectTo = (addr port :
|
||||
onOk socket (client rest :
|
||||
onOk (connect client addr port) (_ rest :
|
||||
pure (ok client rest))))
|
||||
18
notes/php-cli-run-flags.md
Normal file
18
notes/php-cli-run-flags.md
Normal file
@@ -0,0 +1,18 @@
|
||||
# PHP Recommended Run Flags
|
||||
|
||||
```php
|
||||
php -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
|
||||
```
|
||||
|
||||
For bundle execution test server:
|
||||
|
||||
```php
|
||||
nix build .#tricu-php
|
||||
ARBORICX_LIB=../../../lib/libarboricx.so php \
|
||||
-S localhost:8081 \
|
||||
-t ./result/share/tricu-php/public \
|
||||
-d ffi.enable=true
|
||||
```
|
||||
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 in `tricu` code.
|
||||
|
||||
*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`.
|
||||
@@ -1,19 +1,19 @@
|
||||
module ContentStore where
|
||||
|
||||
import Research
|
||||
import Parser
|
||||
|
||||
import Control.Monad (foldM, forM)
|
||||
import Control.Monad (foldM, forM_, void)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Char (isHexDigit)
|
||||
import Data.List (nub, sort)
|
||||
import Data.Maybe (catMaybes, fromJust)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Database.SQLite.Simple
|
||||
import Database.SQLite.Simple.FromRow (FromRow(..), field)
|
||||
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (die)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
@@ -40,14 +40,27 @@ serializeNameList :: [Text] -> Text
|
||||
serializeNameList = T.intercalate "," . nub . sort
|
||||
|
||||
initContentStore :: IO Connection
|
||||
initContentStore = do
|
||||
dbPath <- getContentStorePath
|
||||
initContentStore = initContentStoreWithPath Nothing
|
||||
|
||||
-- | Initialise a content store with an explicit path, or fall back
|
||||
-- to the environment variable / default location.
|
||||
initContentStoreWithPath :: Maybe FilePath -> IO Connection
|
||||
initContentStoreWithPath mPath = do
|
||||
dbPath <- case mPath of
|
||||
Just p -> return p
|
||||
Nothing -> 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, \
|
||||
\term_data BLOB, \
|
||||
\metadata TEXT, \
|
||||
\created_at INTEGER DEFAULT (strftime('%s','now')), \
|
||||
\tags TEXT DEFAULT '')"
|
||||
@@ -56,12 +69,24 @@ initContentStore = do
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
|
||||
\hash TEXT PRIMARY KEY, \
|
||||
\node_data BLOB NOT NULL)"
|
||||
return conn
|
||||
-- Seed canonical Leaf node payload (0x00)
|
||||
putMerkleNode conn NLeaf
|
||||
|
||||
-- | Create an in-memory ContentStore connection (for tests).
|
||||
newContentStore :: IO Connection
|
||||
newContentStore = do
|
||||
conn <- open ":memory:"
|
||||
setupDatabase conn
|
||||
return conn
|
||||
|
||||
getContentStorePath :: IO FilePath
|
||||
getContentStorePath = do
|
||||
dataDir <- getXdgDirectory XdgData "tricu"
|
||||
return $ dataDir </> "content-store.db"
|
||||
maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
|
||||
case maybeLocalPath of
|
||||
Just p -> return p
|
||||
Nothing -> do
|
||||
dataDir <- getXdgDirectory XdgData "tricu"
|
||||
return $ dataDir </> "content-store.db"
|
||||
|
||||
|
||||
|
||||
@@ -83,8 +108,8 @@ storeTerm conn newNamesStrList term = do
|
||||
[] -> do
|
||||
let allNamesToStore = serializeNameList newNamesTextList
|
||||
execute conn
|
||||
"INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)"
|
||||
(termHashText, allNamesToStore, BS.pack [], metadataText, T.pack "")
|
||||
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
|
||||
(termHashText, allNamesToStore, metadataText, T.pack "")
|
||||
[(Only currentNamesText)] -> do
|
||||
let currentNamesList = parseNameList currentNamesText
|
||||
let combinedNamesList = currentNamesList ++ newNamesTextList
|
||||
@@ -92,33 +117,35 @@ storeTerm conn newNamesStrList term = do
|
||||
execute conn
|
||||
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
||||
(allNamesToStore, metadataText, termHashText)
|
||||
_ -> error $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
|
||||
_ -> 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 conn h
|
||||
| h == nodeHash NLeaf = return (Just Leaf) -- NLeaf is implicit, not stored
|
||||
| otherwise = do
|
||||
maybeNode <- getNodeMerkle conn h
|
||||
case maybeNode of
|
||||
Nothing -> return Nothing
|
||||
Just node -> Just <$> buildTree node
|
||||
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 <- fromJust <$> loadTree conn childHash
|
||||
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
|
||||
return (Stem child)
|
||||
buildTree (NFork lHash rHash) = do
|
||||
left <- fromJust <$> loadTree conn lHash
|
||||
right <- fromJust <$> loadTree conn rHash
|
||||
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 _ Leaf = return $ nodeHash NLeaf
|
||||
storeMerkleNodes conn Leaf = do
|
||||
putMerkleNode conn NLeaf
|
||||
return $ nodeHash NLeaf
|
||||
storeMerkleNodes conn (Stem t) = do
|
||||
childHash <- storeMerkleNodes conn t
|
||||
let thisNode = NStem childHash
|
||||
@@ -161,14 +188,14 @@ listStoredTerms :: Connection -> IO [StoredTerm]
|
||||
listStoredTerms conn =
|
||||
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
|
||||
|
||||
storeEnvironment :: Connection -> Env -> IO [(String, Text)]
|
||||
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) -> do
|
||||
hashVal <- storeTerm conn namesList term
|
||||
return (head namesList, hashVal)
|
||||
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
|
||||
@@ -254,3 +281,36 @@ queryMaybeOne conn qry params = do
|
||||
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
|
||||
|
||||
483
src/Eval.hs
483
src/Eval.hs
@@ -4,27 +4,44 @@ import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (forM_, foldM)
|
||||
import Data.List (partition, (\\))
|
||||
import Data.Map (Map)
|
||||
import Control.Monad (foldM)
|
||||
import Data.List (partition, (\\), elemIndex, foldl')
|
||||
import Data.Map ()
|
||||
import Data.Set (Set)
|
||||
import Database.SQLite.Simple
|
||||
|
||||
import qualified Data.Foldable as F ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Data.List (foldl')
|
||||
|
||||
data DB
|
||||
= BVar Int
|
||||
| BFree String
|
||||
| BLam DB
|
||||
| BApp DB DB
|
||||
| BLeaf
|
||||
| BStem DB
|
||||
| BFork DB DB
|
||||
| BStr String
|
||||
| BInt Integer
|
||||
| BList [DB]
|
||||
| BEmpty
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Uses = [Bool]
|
||||
|
||||
evalSingle :: Env -> TricuAST -> Env
|
||||
evalSingle env term
|
||||
| SDef name [] body <- term
|
||||
= case Map.lookup name env of
|
||||
Just existingValue
|
||||
| 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)
|
||||
| SDef name params body <- term
|
||||
= let res = evalASTSync env (if null params then body else SLambda params body)
|
||||
in case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> env
|
||||
| otherwise
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
@@ -39,14 +56,14 @@ evalSingle env term
|
||||
in Map.insert "!result" res env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env x = go env (reorderDefs env x)
|
||||
evalTricu env x = go env (reorderDefs env (map recoverParams 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
|
||||
|
||||
evalASTSync :: Env -> TricuAST -> T
|
||||
evalASTSync env term = case term of
|
||||
@@ -75,6 +92,43 @@ evalAST mconn selectedVersions ast = do
|
||||
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
-- | Evaluate a single AST term using a local environment augmented by
|
||||
-- lazily-resolved store terms.
|
||||
evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
|
||||
evalASTWithEnv mconn localEnv ast = do
|
||||
let varNames = collectVarNames ast
|
||||
storeEnv <- resolveTermsFromStore mconn Map.empty varNames
|
||||
let combinedEnv = Map.union localEnv storeEnv
|
||||
return $ evalASTSync combinedEnv ast
|
||||
|
||||
evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
|
||||
evalSingleWithStore mconn env term
|
||||
| SDef name params body <- term = do
|
||||
res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
|
||||
case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> return env
|
||||
| otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
| otherwise = do
|
||||
res <- evalASTWithEnv mconn env term
|
||||
return $ Map.insert "!result" res env
|
||||
|
||||
evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
|
||||
evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
|
||||
where
|
||||
go env' [] = return env'
|
||||
go env' [def] = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
return $ Map.insert "!result" (result updatedEnv) updatedEnv
|
||||
go env' (def:xs) = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
evalTricuWithStore mconn updatedEnv xs
|
||||
|
||||
recoverParams :: TricuAST -> TricuAST
|
||||
recoverParams (SDef name [] (SLambda params body)) = SDef name params body
|
||||
recoverParams term = term
|
||||
|
||||
collectVarNames :: TricuAST -> [(String, Maybe String)]
|
||||
collectVarNames = go []
|
||||
where
|
||||
@@ -111,7 +165,7 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
case matchingVersions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return Nothing -- Ambiguous or too many matches
|
||||
_ -> return Nothing
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> loadTree conn hash
|
||||
Nothing -> do
|
||||
@@ -119,78 +173,97 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just $ (\(_, t, _) -> t) $ head versions
|
||||
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
where
|
||||
go term
|
||||
| etaReduction term = elimLambda $ etaReduceResult term
|
||||
| etaReduction term = go (etaReduceResult term)
|
||||
| triagePattern term = _TRI
|
||||
| composePattern term = _B
|
||||
| lambdaList term = elimLambda $ lambdaListResult term
|
||||
| lambdaList term = go (lambdaListResult term)
|
||||
| nestedLambda term = nestedLambdaResult term
|
||||
| application term = applicationResult term
|
||||
| isSList term = slistTransform term
|
||||
| otherwise = term
|
||||
|
||||
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f)
|
||||
etaReduction (SLambda [v] (SVar x Nothing)) = v == x
|
||||
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
|
||||
etaReduction _ = False
|
||||
etaReduceResult (SLambda [_] (SApp f _)) = f
|
||||
|
||||
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) = body == triageBody a b c
|
||||
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
|
||||
toDB [c,b,a] body == triageBodyDB
|
||||
triagePattern _ = False
|
||||
|
||||
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) = body == composeBody f g x
|
||||
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
|
||||
toDB [x,g,f] body == composeBodyDB
|
||||
composePattern _ = False
|
||||
|
||||
lambdaList (SLambda [_] (SList _)) = True
|
||||
lambdaList _ = False
|
||||
lambdaListResult (SLambda [v] (SList xs)) = SLambda [v] (foldr wrapTLeaf TLeaf xs)
|
||||
wrapTLeaf m r = SApp (SApp TLeaf m) r
|
||||
|
||||
nestedLambda (SLambda (_:_) _) = True
|
||||
nestedLambda _ = False
|
||||
nestedLambdaResult (SLambda (v:vs) body)
|
||||
| null vs = toSKI v (go body) -- Changed elimLambda to go
|
||||
| otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go
|
||||
|
||||
application (SApp _ _) = True
|
||||
application _ = False
|
||||
applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go
|
||||
|
||||
etaReduceResult (SLambda [_] (SVar _ Nothing)) = _I
|
||||
etaReduceResult (SLambda [_] (SApp f _)) = f
|
||||
etaReduceResult _ = error "etaReduceResult: unexpected shape"
|
||||
|
||||
lambdaListResult (SLambda [v] (SList xs)) =
|
||||
SLambda [v] (foldr wrapTLeaf TLeaf xs)
|
||||
where
|
||||
wrapTLeaf m r = SApp (SApp TLeaf m) r
|
||||
lambdaListResult _ = error "lambdaListResult: expected SLambda [v] (SList xs)"
|
||||
|
||||
nestedLambdaResult (SLambda (v:vs) body)
|
||||
| null vs =
|
||||
let body' = go body
|
||||
db = toDB [v] body'
|
||||
in toSKIKiselyov db
|
||||
| otherwise = go (SLambda [v] (SLambda vs body))
|
||||
nestedLambdaResult _ = error "nestedLambdaResult: expected SLambda (_:_) _"
|
||||
|
||||
applicationResult (SApp f g) = SApp (go f) (go g)
|
||||
applicationResult _ = error "applicationResult: expected SApp _ _"
|
||||
|
||||
isSList (SList _) = True
|
||||
isSList _ = 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 if isSList is the guard
|
||||
slistTransform ast = ast -- Should not be reached
|
||||
|
||||
toSKI x (SVar y Nothing)
|
||||
| x == y = _I
|
||||
| otherwise = SApp _K (SVar y Nothing)
|
||||
toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n)
|
||||
toSKI x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first
|
||||
toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly
|
||||
toSKI _ term = SApp _K term
|
||||
_S, _K, _I, _R, _C, _B, _T, _TRI :: TricuAST
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "t t"
|
||||
_I = parseSingle "t (t (t t)) t"
|
||||
_R = parseSingle "(t (t (t t (t (t (t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t))))))) (t t))"
|
||||
_C = parseSingle "(t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t)))"
|
||||
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||
_T = SApp _C _I
|
||||
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
|
||||
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "t t"
|
||||
_I = parseSingle "t (t (t t)) t"
|
||||
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
|
||||
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
||||
composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x)
|
||||
triageBody :: String -> String -> String -> TricuAST
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
||||
composeBody :: String -> String -> String -> TricuAST
|
||||
composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
|
||||
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x = Set.member x . freeVars
|
||||
isFree x t = Set.member x (freeVars t)
|
||||
|
||||
freeVars :: TricuAST -> Set.Set String
|
||||
freeVars :: TricuAST -> Set String
|
||||
freeVars (SVar v Nothing) = Set.singleton v
|
||||
freeVars (SVar v (Just _)) = Set.singleton v
|
||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
|
||||
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]
|
||||
@@ -203,7 +276,7 @@ reorderDefs env defs
|
||||
(defsOnly, others) = partition isDef defs
|
||||
defNames = [ name | SDef name _ _ <- defsOnly ]
|
||||
|
||||
defsWithFreeVars = [(def, freeVars body) | def@(SDef _ _ body) <- defsOnly]
|
||||
defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
|
||||
|
||||
graph = buildDepGraph defsOnly
|
||||
sortedDefs = sortDeps graph
|
||||
@@ -226,8 +299,8 @@ buildDepGraph topDefs
|
||||
"Conflicting definitions detected: " ++ show conflictingDefs
|
||||
| otherwise =
|
||||
Map.fromList
|
||||
[ (name, depends topDefs (SDef name [] body))
|
||||
| SDef name _ body <- topDefs]
|
||||
[ (name, depends topDefs def)
|
||||
| def@(SDef name _ _) <- topDefs]
|
||||
where
|
||||
defsMap = Map.fromListWith (++)
|
||||
[(name, [(name, body)]) | SDef name _ body <- topDefs]
|
||||
@@ -242,7 +315,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
|
||||
@@ -257,10 +330,10 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||
notReady
|
||||
|
||||
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||
depends topDefs (SDef _ _ body) =
|
||||
depends topDefs def@(SDef _ _ _) =
|
||||
Set.intersection
|
||||
(Set.fromList [n | SDef n _ _ <- topDefs])
|
||||
(freeVars body)
|
||||
(freeVars def)
|
||||
depends _ _ = Set.empty
|
||||
|
||||
result :: Env -> T
|
||||
@@ -273,22 +346,6 @@ mainResult r = case Map.lookup "main" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
||||
|
||||
evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalWithEnv env mconn selectedVersions ast = do
|
||||
let varNames = findVarNames ast
|
||||
resolvedEnv <- case mconn of
|
||||
Just conn -> foldM (\e name ->
|
||||
if Map.member name e
|
||||
then return e
|
||||
else do
|
||||
mterm <- resolveTermFromStore conn selectedVersions name Nothing
|
||||
case mterm of
|
||||
Just term -> return $ Map.insert name term e
|
||||
Nothing -> return e
|
||||
) env varNames
|
||||
Nothing -> return env
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
findVarNames :: TricuAST -> [String]
|
||||
findVarNames ast = case ast of
|
||||
SVar name _ -> [name]
|
||||
@@ -296,3 +353,281 @@ findVarNames ast = case ast of
|
||||
SLambda args body -> findVarNames body \\ args
|
||||
SDef name args body -> name : (findVarNames body \\ args)
|
||||
_ -> []
|
||||
|
||||
-- Convert named TricuAST to De Bruijn form
|
||||
toDB :: [String] -> TricuAST -> DB
|
||||
toDB env = \case
|
||||
SVar v _ -> maybe (BFree v) BVar (elemIndex v env)
|
||||
SLambda vs b ->
|
||||
let env' = reverse vs ++ env
|
||||
body = toDB env' b
|
||||
in foldr (\_ acc -> BLam acc) body vs
|
||||
SApp f a -> BApp (toDB env f) (toDB env a)
|
||||
TLeaf -> BLeaf
|
||||
TStem t -> BStem (toDB env t)
|
||||
TFork l r -> BFork (toDB env l) (toDB env r)
|
||||
SStr s -> BStr s
|
||||
SInt n -> BInt n
|
||||
SList xs -> BList (map (toDB env) xs)
|
||||
SEmpty -> BEmpty
|
||||
SDef{} -> error "toDB: unexpected SDef at this stage"
|
||||
SImport _ _ -> BEmpty
|
||||
|
||||
-- Does a term depend on the current binder (level 0)?
|
||||
dependsOnLevel :: Int -> DB -> Bool
|
||||
dependsOnLevel lvl = \case
|
||||
BVar k -> k == lvl
|
||||
BLam t -> dependsOnLevel (lvl + 1) t
|
||||
BApp f a -> dependsOnLevel lvl f || dependsOnLevel lvl a
|
||||
BStem t -> dependsOnLevel lvl t
|
||||
BFork l r -> dependsOnLevel lvl l || dependsOnLevel lvl r
|
||||
BList xs -> any (dependsOnLevel lvl) xs
|
||||
_ -> False
|
||||
|
||||
-- Collect free *global* names (i.e., unbound)
|
||||
freeDBNames :: DB -> Set String
|
||||
freeDBNames = \case
|
||||
BFree s -> Set.singleton s
|
||||
BVar _ -> mempty
|
||||
BLam t -> freeDBNames t
|
||||
BApp f a -> freeDBNames f <> freeDBNames a
|
||||
BLeaf -> mempty
|
||||
BStem t -> freeDBNames t
|
||||
BFork l r -> freeDBNames l <> freeDBNames r
|
||||
BStr _ -> mempty
|
||||
BInt _ -> mempty
|
||||
BList xs -> foldMap freeDBNames xs
|
||||
BEmpty -> mempty
|
||||
|
||||
-- Helper: "is the binder named v used in body?"
|
||||
usesBinder :: String -> TricuAST -> Bool
|
||||
usesBinder v body = dependsOnLevel 0 (toDB [v] body)
|
||||
|
||||
-- Expected DB bodies for the named special patterns (under env [a,b,c] -> indices 2,1,0)
|
||||
triageBodyDB :: DB
|
||||
triageBodyDB =
|
||||
BApp (BApp BLeaf (BApp (BApp BLeaf (BVar 2)) (BVar 1))) (BVar 0)
|
||||
|
||||
composeBodyDB :: DB
|
||||
composeBodyDB =
|
||||
BApp (BVar 2) (BApp (BVar 1) (BVar 0))
|
||||
|
||||
-- Convert DB -> TricuAST for subterms that contain NO binders (no BLam, no BVar)
|
||||
fromDBClosed :: DB -> TricuAST
|
||||
fromDBClosed = \case
|
||||
BFree s -> SVar s Nothing
|
||||
BApp f a -> SApp (fromDBClosed f) (fromDBClosed a)
|
||||
BLeaf -> TLeaf
|
||||
BStem t -> TStem (fromDBClosed t)
|
||||
BFork l r -> TFork (fromDBClosed l) (fromDBClosed r)
|
||||
BStr s -> SStr s
|
||||
BInt n -> SInt n
|
||||
BList xs -> SList (map fromDBClosed xs)
|
||||
BEmpty -> SEmpty
|
||||
-- Anything bound would be a logic error if we call this correctly.
|
||||
BLam _ -> error "fromDBClosed: unexpected BLam"
|
||||
BVar _ -> error "fromDBClosed: unexpected bound variable"
|
||||
|
||||
-- DB-native bracket abstraction over the innermost binder (level 0).
|
||||
-- This mirrors your old toSKI, but is purely index-driven.
|
||||
toSKIDB :: DB -> TricuAST
|
||||
toSKIDB t
|
||||
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
|
||||
toSKIDB (BVar 0) = _I
|
||||
toSKIDB (BApp n u) = SApp (SApp _S (toSKIDB n)) (toSKIDB u)
|
||||
toSKIDB (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
|
||||
|
||||
app3 :: TricuAST -> TricuAST -> TricuAST -> TricuAST
|
||||
app3 f x y = SApp (SApp f x) y
|
||||
|
||||
-- Core converter that *does not* perform the λ-step; it just returns (Γ, d).
|
||||
-- Supported shapes: variables, applications, closed literals (Leaf/Int/Str/Empty),
|
||||
-- closed lists. For anything where the binder occurs under structural nodes
|
||||
-- (Stem/Fork/List-with-use), we deliberately bail so the caller can fall back.
|
||||
kisConv :: DB -> Either String (Uses, TricuAST)
|
||||
kisConv = \case
|
||||
BVar 0 -> Right ([True], _I)
|
||||
BVar n | n > 0 -> do
|
||||
(g,d) <- kisConv (BVar (n - 1))
|
||||
Right (False:g, d)
|
||||
BVar n -> Right ([], SVar ("BVar" ++ show n) Nothing)
|
||||
BFree s -> Right ([], SVar s Nothing)
|
||||
BApp e1 e2 -> do
|
||||
(g1,d1) <- kisConv e1
|
||||
(g2,d2) <- kisConv e2
|
||||
let g = zipWithDefault False (||) g1 g2 -- <- propagate Γ outside (#)
|
||||
d = kisHash (g1,d1) (g2,d2) -- <- (#) yields only the term
|
||||
Right (g, d)
|
||||
-- Treat closed constants as free 'combinator leaves' (no binder use).
|
||||
BLeaf -> Right ([], TLeaf)
|
||||
BStr s -> Right ([], SStr s)
|
||||
BInt n -> Right ([], SInt n)
|
||||
BEmpty -> Right ([], SEmpty)
|
||||
-- Closed list: allowed. If binder is used anywhere, we punt to fallback.
|
||||
BList xs
|
||||
| any (dependsOnLevel 0) xs -> Left "List with binder use: fallback"
|
||||
| otherwise -> Right ([], SList (map fromDBClosed xs))
|
||||
-- For structural nodes, only allow if *closed* wrt the binder.
|
||||
BStem t
|
||||
| dependsOnLevel 0 t -> Left "Stem with binder use: fallback"
|
||||
| otherwise -> Right ([], TStem (fromDBClosed t))
|
||||
BFork l r
|
||||
| dependsOnLevel 0 l || dependsOnLevel 0 r -> Left "Fork with binder use: fallback"
|
||||
| otherwise -> Right ([], TFork (fromDBClosed l) (fromDBClosed r))
|
||||
-- We shouldn't see BLam under elim; treat as unsupported so we fallback.
|
||||
BLam _ -> Left "Nested lambda under body: fallback"
|
||||
|
||||
-- Application combiner with K-optimization (lazy weakening).
|
||||
-- Mirrors Lynn's 'optK' rules: choose among S, B, C, R based on leading flags.
|
||||
-- η-aware (#) with K-optimization (adapted from TS kiselyov_eta)
|
||||
kisHash :: (Uses, TricuAST) -> (Uses, TricuAST) -> TricuAST
|
||||
kisHash (g1, d1) (g2, d2) =
|
||||
case g1 of
|
||||
[] -> case g2 of
|
||||
[] -> SApp d1 d2
|
||||
True:gs2 -> if isId2 (g2, d2)
|
||||
then d1
|
||||
else kisHash ([], SApp _B d1) (gs2, d2)
|
||||
False:gs2 -> kisHash ([], d1) (gs2, d2)
|
||||
|
||||
True:gs1 -> case g2 of
|
||||
[] -> if isId2 (g1, d1)
|
||||
then SApp _T d2
|
||||
else kisHash ([], SApp _R d2) (gs1, d1)
|
||||
_ ->
|
||||
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
|
||||
then kisHash ([], _T) (drop1 g2, d2)
|
||||
else
|
||||
-- NEW: coalesce the longest run of identical head pairs and apply bulk op once
|
||||
let ((h1, h2), count) = headPairRun g1 g2
|
||||
g1' = drop count g1
|
||||
g2' = drop count g2
|
||||
in case (h1, h2) of
|
||||
(False, False) ->
|
||||
kisHash (g1', d1) (g2', d2)
|
||||
(False, True) ->
|
||||
let d1' = kisHash ([], bulkB count) (g1', d1)
|
||||
in kisHash (g1', d1') (g2', d2)
|
||||
(True, False) ->
|
||||
let d1' = kisHash ([], bulkC count) (g1', d1)
|
||||
in kisHash (g1', d1') (g2', d2)
|
||||
(True, True) ->
|
||||
let d1' = kisHash ([], bulkS count) (g1', d1)
|
||||
in kisHash (g1', d1') (g2', d2)
|
||||
|
||||
False:gs1 -> case g2 of
|
||||
[] -> kisHash (gs1, d1) ([], d2)
|
||||
_ ->
|
||||
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
|
||||
then kisHash ([], _T) (drop1 g2, d2)
|
||||
else case g2 of
|
||||
True:gs2 ->
|
||||
let d1' = kisHash ([], _B) (gs1, d1)
|
||||
in kisHash (gs1, d1') (gs2, d2)
|
||||
False:gs2 ->
|
||||
kisHash (gs1, d1) (gs2, d2)
|
||||
where
|
||||
drop1 (_:xs) = xs
|
||||
drop1 [] = []
|
||||
|
||||
|
||||
toSKIKiselyov :: DB -> TricuAST
|
||||
toSKIKiselyov body =
|
||||
case kisConv body of
|
||||
Right ([], d) -> SApp _K d
|
||||
Right (True:_ , d) -> d
|
||||
Right (False:g, d) -> kisHash ([], _K) (g, d) -- no snd
|
||||
Left _ -> starSKIBCOpEtaDB body -- was: toSKIDB body
|
||||
|
||||
zipWithDefault :: a -> (a -> a -> a) -> [a] -> [a] -> [a]
|
||||
zipWithDefault d f [] ys = map (f d) ys
|
||||
zipWithDefault d f xs [] = map (\x -> f x d) xs
|
||||
zipWithDefault d f (x:xs) (y:ys) = f x y : zipWithDefault d f xs ys
|
||||
|
||||
isNode :: TricuAST -> Bool
|
||||
isNode t = case t of
|
||||
TLeaf -> True
|
||||
_ -> False
|
||||
|
||||
isApp2 :: TricuAST -> Maybe (TricuAST, TricuAST)
|
||||
isApp2 (SApp a b) = Just (a, b)
|
||||
isApp2 _ = Nothing
|
||||
|
||||
isKop :: TricuAST -> Bool
|
||||
isKop t = case isApp2 t of
|
||||
Just (a,b) -> isNode a && isNode b
|
||||
_ -> False
|
||||
|
||||
-- detects the two canonical I-shapes in the tree calculus:
|
||||
-- △ (△ (△ △)) x OR △ (△ △ △) △
|
||||
isId :: TricuAST -> Bool
|
||||
isId t = case isApp2 t of
|
||||
Just (ab, c) -> case isApp2 ab of
|
||||
Just (a, b) | isNode a ->
|
||||
case isApp2 b of
|
||||
Just (b1, b2) ->
|
||||
(isNode b1 && isKop b2) ||
|
||||
(isKop b1 && isNode b2 && isNode c)
|
||||
_ -> False
|
||||
_ -> False
|
||||
_ -> False
|
||||
|
||||
-- head-True only, tail empty, and term is identity
|
||||
isId2 :: (Uses, TricuAST) -> Bool
|
||||
isId2 (True:[], t) = isId t
|
||||
isId2 _ = False
|
||||
|
||||
-- Bulk helpers built from SKI (no new primitives)
|
||||
bPrime :: TricuAST
|
||||
bPrime = SApp _B _B -- B' = B B
|
||||
|
||||
cPrime :: TricuAST
|
||||
cPrime = SApp (SApp _B (SApp _B _C)) _B -- C' = B (B C) B
|
||||
|
||||
sPrime :: TricuAST
|
||||
sPrime = SApp (SApp _B (SApp _B _S)) _B -- S' = B (B S) B
|
||||
|
||||
bulkB :: Int -> TricuAST
|
||||
bulkB n | n <= 1 = _B
|
||||
| otherwise = SApp bPrime (bulkB (n - 1))
|
||||
|
||||
bulkC :: Int -> TricuAST
|
||||
bulkC n | n <= 1 = _C
|
||||
| otherwise = SApp cPrime (bulkC (n - 1))
|
||||
|
||||
bulkS :: Int -> TricuAST
|
||||
bulkS n | n <= 1 = _S
|
||||
| otherwise = SApp sPrime (bulkS (n - 1))
|
||||
|
||||
headPairRun :: [Bool] -> [Bool] -> ((Bool, Bool), Int)
|
||||
headPairRun g1 g2 =
|
||||
case zip g1 g2 of
|
||||
[] -> ((False, False), 0)
|
||||
(h:rest) -> (h, 1 + length (takeWhile (== h) rest))
|
||||
|
||||
-- DB-native star_skibc_op_eta (adapted from strategies.mts), binder = level 0
|
||||
starSKIBCOpEtaDB :: DB -> TricuAST
|
||||
starSKIBCOpEtaDB t
|
||||
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
|
||||
starSKIBCOpEtaDB (BVar 0) = _I
|
||||
starSKIBCOpEtaDB (BApp e1 e2)
|
||||
-- if binder not in right: use C
|
||||
| not (dependsOnLevel 0 e2)
|
||||
= SApp (SApp _C (starSKIBCOpEtaDB e1)) (fromDBClosed e2)
|
||||
-- if binder not in left:
|
||||
| not (dependsOnLevel 0 e1)
|
||||
= case e2 of
|
||||
-- η case: \x. f x ==> f
|
||||
BVar 0 -> fromDBClosed e1
|
||||
_ -> SApp (SApp _B (fromDBClosed e1)) (starSKIBCOpEtaDB e2)
|
||||
-- otherwise: S
|
||||
| otherwise
|
||||
= SApp (SApp _S (starSKIBCOpEtaDB e1)) (starSKIBCOpEtaDB e2)
|
||||
-- Structural nodes with binder underneath: fall back to plain SKI (rare)
|
||||
starSKIBCOpEtaDB other = toSKIDB other
|
||||
|
||||
@@ -1,28 +1,40 @@
|
||||
module FileEval where
|
||||
module FileEval
|
||||
( preprocessFile
|
||||
, evaluateFile
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithStore
|
||||
, evaluateFileResult
|
||||
, compileFile
|
||||
) where
|
||||
|
||||
import Eval
|
||||
import Eval (evalTricu, evalTricuWithStore)
|
||||
import Lexer
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
|
||||
import Database.SQLite.Simple (Connection)
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Control.Monad (foldM)
|
||||
import System.IO
|
||||
import System.FilePath (takeDirectory, normalise, (</>))
|
||||
import System.Exit (die)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
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
|
||||
@@ -39,12 +51,12 @@ evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
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
|
||||
@@ -52,8 +64,8 @@ evaluateFile filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu Map.empty ast
|
||||
|
||||
@@ -62,11 +74,23 @@ evaluateFileWithContext env filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> do
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu env ast
|
||||
|
||||
-- | File evaluation that lazily resolves missing names from the
|
||||
-- content store instead of pre-loading the entire store into memory.
|
||||
evaluateFileWithStore :: Maybe Connection -> Env -> FilePath -> IO Env
|
||||
evaluateFileWithStore mconn env filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
evalTricuWithStore mconn env ast
|
||||
|
||||
preprocessFile :: FilePath -> IO [TricuAST]
|
||||
preprocessFile p = preprocessFile' Set.empty p p
|
||||
|
||||
@@ -75,7 +99,7 @@ preprocessFile' seen base currentPath = do
|
||||
contents <- readFile currentPath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right ast ->
|
||||
case processImports seen base currentPath ast of
|
||||
Left err -> errorWithoutStackTrace err
|
||||
@@ -84,8 +108,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 +120,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)
|
||||
@@ -152,3 +173,29 @@ 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.
|
||||
-- Emits a canonical indexed bundle with no SHA-256 hashing.
|
||||
compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
|
||||
compileFile inputPath outputPath maybeNames = do
|
||||
env <- evaluateFile inputPath
|
||||
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 (T.pack n, t)) wantedNamesUnpacked
|
||||
let bundle = buildBundle compiledTerms
|
||||
bundleData = encodeBundle bundle
|
||||
nodeCount = Seq.length (bundleNodes bundle)
|
||||
bundleSize = BS.length bundleData
|
||||
BL.writeFile outputPath (BL.fromStrict bundleData)
|
||||
putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
|
||||
putStrLn $ " exports: " ++ T.unpack (T.intercalate ", " (map fst compiledTerms))
|
||||
putStrLn $ " nodes: " ++ show nodeCount
|
||||
putStrLn $ " size: " ++ show bundleSize ++ " bytes"
|
||||
case decodeBundle bundleData of
|
||||
Left err -> putStrLn $ " round-trip decode failed: " ++ err
|
||||
Right decoded -> case verifyBundle decoded of
|
||||
Left err -> putStrLn $ " round-trip verify failed: " ++ err
|
||||
Right () -> putStrLn $ " round-trip: OK"
|
||||
|
||||
1352
src/IODriver.hs
Normal file
1352
src/IODriver.hs
Normal file
File diff suppressed because it is too large
Load Diff
24
src/Lexer.hs
24
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,13 +22,13 @@ 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
|
||||
@@ -46,12 +45,14 @@ tricuLexer = do
|
||||
, closeParen
|
||||
, openBracket
|
||||
, closeBracket
|
||||
, try arrowLeft
|
||||
, try arrowRight
|
||||
]
|
||||
|
||||
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
|
||||
@@ -63,6 +64,7 @@ identifierWithHash = do
|
||||
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)"
|
||||
@@ -84,6 +86,7 @@ identifier = do
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> 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"
|
||||
@@ -127,6 +130,12 @@ openBracket = char '[' $> LOpenBracket
|
||||
closeBracket :: Lexer LToken
|
||||
closeBracket = char ']' $> LCloseBracket
|
||||
|
||||
arrowLeft :: Lexer LToken
|
||||
arrowLeft = string "<|" $> LArrowLeft
|
||||
|
||||
arrowRight :: Lexer LToken
|
||||
arrowRight = string "|>" $> LArrowRight
|
||||
|
||||
lnewline :: Lexer LToken
|
||||
lnewline = char '\n' $> LNewline
|
||||
|
||||
@@ -143,8 +152,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
|
||||
@@ -163,3 +172,4 @@ charLiteral = escapedChar <|> normalChar
|
||||
'\\' -> '\\'
|
||||
'"' -> '"'
|
||||
'\'' -> '\''
|
||||
_ -> c
|
||||
|
||||
466
src/Main.hs
466
src/Main.hs
@@ -1,126 +1,388 @@
|
||||
module Main where
|
||||
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
import Parser (parseTricu)
|
||||
import REPL
|
||||
import Research
|
||||
import ContentStore
|
||||
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
|
||||
import System.Exit (die)
|
||||
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
|
||||
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
|
||||
import IODriver (IOPermissions(..), runIO)
|
||||
import Parser (parseTricu)
|
||||
import REPL (repl)
|
||||
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
|
||||
import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Version (showVersion)
|
||||
import Text.Megaparsec (runParser)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.CmdArgs
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Data.Text (unpack, pack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Version (showVersion)
|
||||
import Paths_tricu (version)
|
||||
import Options.Applicative
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Sequence as Seq
|
||||
import Database.SQLite.Simple (Connection, close)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import System.Environment (lookupEnv)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- CLI argument types
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||
| TDecode { file :: [FilePath] }
|
||||
deriving (Show, Data, Typeable)
|
||||
| Eval
|
||||
{ evalFiles :: [FilePath]
|
||||
, evalFormat :: EvaluatedForm
|
||||
, evalOutput :: FilePath
|
||||
, evalDb :: Maybe FilePath
|
||||
, evalIo :: Bool
|
||||
, evalAllowRead :: [FilePath]
|
||||
, evalAllowWrite :: [FilePath]
|
||||
, evalAllowReadAll :: Bool
|
||||
, evalAllowWriteAll :: Bool
|
||||
, evalUnsafeIo :: Bool
|
||||
}
|
||||
| ArboricxCompile
|
||||
{ compileInput :: FilePath
|
||||
, compileOutput :: FilePath
|
||||
, compileNames :: [String]
|
||||
, compileDb :: Maybe FilePath
|
||||
}
|
||||
| ArboricxImport
|
||||
{ importFile :: FilePath
|
||||
, importDb :: Maybe FilePath
|
||||
}
|
||||
| ArboricxExport
|
||||
{ exportTargets :: [String]
|
||||
, exportOutput :: FilePath
|
||||
, exportNames :: [String]
|
||||
, exportDb :: Maybe FilePath
|
||||
, dag :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
replMode :: TricuArgs
|
||||
replMode = Repl
|
||||
&= help "Start interactive REPL"
|
||||
&= auto
|
||||
&= name "repl"
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- optparse-applicative parsers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
evaluateMode :: TricuArgs
|
||||
evaluateMode = Evaluate
|
||||
{ file = def &= help "Input file path(s) for evaluation.\n \
|
||||
\ Defaults to stdin."
|
||||
&= name "f" &= typ "FILE"
|
||||
, form = TreeCalculus &= typ "FORM"
|
||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
|
||||
\ Defaults to tricu-compatible `t` tree form."
|
||||
&= name "t"
|
||||
}
|
||||
&= help "Evaluate tricu and return the result of the final expression."
|
||||
&= explicit
|
||||
&= name "eval"
|
||||
readEvaluatedForm :: ReadM EvaluatedForm
|
||||
readEvaluatedForm = eitherReader $ \s -> case s of
|
||||
"tree" -> Right Tree
|
||||
"fsl" -> Right FSL
|
||||
"ast" -> Right AST
|
||||
"ternary" -> Right Ternary
|
||||
"ascii" -> Right Ascii
|
||||
"decode" -> Right Decode
|
||||
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode"
|
||||
|
||||
decodeMode :: TricuArgs
|
||||
decodeMode = TDecode
|
||||
{ file = def
|
||||
&= help "Optional input file path to attempt decoding.\n \
|
||||
\ Defaults to stdin."
|
||||
&= name "f" &= typ "FILE"
|
||||
}
|
||||
&= help "Decode a Tree Calculus value into a string representation."
|
||||
&= explicit
|
||||
&= name "decode"
|
||||
evalParser :: Parser TricuArgs
|
||||
evalParser = Eval
|
||||
<$> many (argument str (metavar "FILE..."))
|
||||
<*> option readEvaluatedForm
|
||||
( long "format"
|
||||
<> short 'f'
|
||||
<> metavar "FORM"
|
||||
<> value Tree
|
||||
<> help "Output format: tree, fsl, ast, ternary, ascii, decode"
|
||||
)
|
||||
<*> option str
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
<> metavar "FILE"
|
||||
<> value ""
|
||||
<> help "Write output to file instead of stdout"
|
||||
)
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
<*> switch
|
||||
( long "io"
|
||||
<> help "Interpret the result as an IO action tree and execute it"
|
||||
)
|
||||
<*> many (option str
|
||||
( long "allow-read"
|
||||
<> metavar "PATH"
|
||||
<> help "Allow reading from PATH prefix (repeatable)"
|
||||
))
|
||||
<*> many (option str
|
||||
( long "allow-write"
|
||||
<> metavar "PATH"
|
||||
<> help "Allow writing to PATH prefix (repeatable)"
|
||||
))
|
||||
<*> switch
|
||||
( long "allow-read-all"
|
||||
<> help "Allow reading from any path"
|
||||
)
|
||||
<*> switch
|
||||
( long "allow-write-all"
|
||||
<> help "Allow writing to any path"
|
||||
)
|
||||
<*> switch
|
||||
( long "unsafe-io"
|
||||
<> help "Allow unrestricted read and write access"
|
||||
)
|
||||
|
||||
compileParser :: Parser TricuArgs
|
||||
compileParser = ArboricxCompile
|
||||
<$> option str
|
||||
( long "file"
|
||||
<> short 'f'
|
||||
<> metavar "FILE"
|
||||
<> value ""
|
||||
<> help "Input .tri source file"
|
||||
)
|
||||
<*> option str
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
<> metavar "FILE"
|
||||
<> value ""
|
||||
<> help "Output bundle file path (required)"
|
||||
)
|
||||
<*> many (option str
|
||||
( long "name"
|
||||
<> short 'n'
|
||||
<> metavar "NAME"
|
||||
<> help "Definition name(s) to export as bundle roots (repeatable)"
|
||||
))
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
|
||||
importParser :: Parser TricuArgs
|
||||
importParser = ArboricxImport
|
||||
<$> option str
|
||||
( long "file"
|
||||
<> short 'f'
|
||||
<> metavar "FILE"
|
||||
<> value ""
|
||||
<> help "Bundle file to import"
|
||||
)
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
|
||||
exportParser :: Parser TricuArgs
|
||||
exportParser = ArboricxExport
|
||||
<$> many (option str
|
||||
( long "target"
|
||||
<> short 't'
|
||||
<> metavar "TARGET"
|
||||
<> help "Target hash or name (repeatable)"
|
||||
))
|
||||
<*> option str
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
<> metavar "FILE"
|
||||
<> value ""
|
||||
<> help "Output file path (required for bundle export)"
|
||||
)
|
||||
<*> many (option str
|
||||
( long "name"
|
||||
<> short 'n'
|
||||
<> metavar "NAME"
|
||||
<> help "Export name(s) for the bundle manifest (repeatable)"
|
||||
))
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
<*> switch
|
||||
( long "dag"
|
||||
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
|
||||
)
|
||||
|
||||
versionStr :: String
|
||||
versionStr = "tricu " ++ showVersion version
|
||||
|
||||
tricuParser :: Parser TricuArgs
|
||||
tricuParser = (subparser topCommands <|> pure Repl)
|
||||
<**> infoOption versionStr (long "version" <> help "Show version")
|
||||
where
|
||||
topCommands = mconcat
|
||||
[ command "eval" (info (evalParser <**> helper)
|
||||
(progDesc "Evaluate tricu source and print the result of the final expression"))
|
||||
, command "arboricx" (info (arboricxParser <**> helper)
|
||||
(progDesc "Arboricx bundle operations"))
|
||||
]
|
||||
|
||||
arboricxParser :: Parser TricuArgs
|
||||
arboricxParser = subparser $ mconcat
|
||||
[ command "compile" (info (compileParser <**> helper)
|
||||
(progDesc "Compile a .tri file into a standalone Arboricx bundle"))
|
||||
, command "import" (info (importParser <**> helper)
|
||||
(progDesc "Import an Arboricx bundle into the content store"))
|
||||
, command "export" (info (exportParser <**> helper)
|
||||
(progDesc "Export one or more terms from the content store"))
|
||||
]
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Entry point
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
||||
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
||||
&= help "tricu: Exploring Tree Calculus"
|
||||
&= program "tricu"
|
||||
&= summary versionStr
|
||||
&= versionArg [explicit, name "version", summary versionStr]
|
||||
args <- execParser $ info (tricuParser <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Exploring Tree Calculus"
|
||||
<> header versionStr
|
||||
)
|
||||
case args of
|
||||
Repl -> do
|
||||
putStrLn "Welcome to the tricu REPL"
|
||||
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||
repl
|
||||
Evaluate { file = filePaths, form = form } -> do
|
||||
result <- case filePaths of
|
||||
[] -> runTricuT <$> getContents
|
||||
(filePath:restFilePaths) -> do
|
||||
initialEnv <- evaluateFile filePath
|
||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||
pure $ mainResult finalEnv
|
||||
let fRes = formatT form result
|
||||
putStr fRes
|
||||
TDecode { file = filePaths } -> do
|
||||
value <- case filePaths of
|
||||
[] -> getContents
|
||||
(filePath:_) -> readFile filePath
|
||||
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
||||
Repl -> runRepl
|
||||
Eval {} -> runEval args
|
||||
ArboricxCompile {} -> runCompile args
|
||||
ArboricxImport {} -> runImport args
|
||||
ArboricxExport {} -> runExport args
|
||||
|
||||
runTricu :: String -> String
|
||||
runTricu = formatT TreeCalculus . runTricuT
|
||||
|
||||
runTricuT :: String -> T
|
||||
runTricuT input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu Map.empty asts
|
||||
in result finalEnv
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Command runners
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
runTricuEnv :: Env -> String -> String
|
||||
runTricuEnv env = formatT TreeCalculus . runTricuTEnv env
|
||||
runRepl :: IO ()
|
||||
runRepl = do
|
||||
putStrLn "Welcome to the tricu REPL"
|
||||
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||
repl
|
||||
|
||||
runEval :: TricuArgs -> IO ()
|
||||
runEval opts = do
|
||||
let files = evalFiles opts
|
||||
form = evalFormat opts
|
||||
out = evalOutput opts
|
||||
mconn <- case evalDb opts of
|
||||
Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath)
|
||||
Nothing -> do
|
||||
mDbPath <- lookupEnv "TRICU_DB_PATH"
|
||||
case mDbPath of
|
||||
Just _ -> Just <$> initContentStoreWithPath Nothing
|
||||
Nothing -> return Nothing
|
||||
resultT <- case files of
|
||||
[] -> do
|
||||
input <- getContents
|
||||
env <- evalTricuWithStore mconn Map.empty (parseTricu input)
|
||||
return $ result env
|
||||
_ -> do
|
||||
finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
|
||||
return $ mainResult finalEnv
|
||||
finalT <- if evalIo opts
|
||||
then do
|
||||
let perms = IOPermissions
|
||||
{ allowRead = evalAllowRead opts
|
||||
, allowWrite = evalAllowWrite opts
|
||||
, allowReadAll = evalUnsafeIo opts || evalAllowReadAll opts
|
||||
, allowWriteAll = evalUnsafeIo opts || evalAllowWriteAll opts
|
||||
}
|
||||
result <- runIO perms resultT
|
||||
case result of
|
||||
Left err -> die $ "IO error: " ++ err
|
||||
Right val -> pure val
|
||||
else return resultT
|
||||
case mconn of
|
||||
Just conn -> close conn
|
||||
Nothing -> return ()
|
||||
writeOutput out (formatT form finalT)
|
||||
|
||||
runCompile :: TricuArgs -> IO ()
|
||||
runCompile opts = do
|
||||
let input = compileInput opts
|
||||
out = compileOutput opts
|
||||
names = compileNames opts
|
||||
when (null out) $ die "tricu arboricx compile: --output is required"
|
||||
when (null input) $ die "tricu arboricx compile: input file is required"
|
||||
let nameTexts = if null names then [] else map T.pack names
|
||||
compileFile input out nameTexts
|
||||
|
||||
runImport :: TricuArgs -> IO ()
|
||||
runImport opts = do
|
||||
let file = importFile opts
|
||||
when (null file) $ die "tricu arboricx import: input file is required"
|
||||
withContentStore (importDb opts) $ \conn -> do
|
||||
bundleData <- BL.readFile file
|
||||
roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
|
||||
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\r -> putStrLn $ " " ++ r) roots
|
||||
|
||||
runExport :: TricuArgs -> IO ()
|
||||
runExport opts =
|
||||
if dag opts
|
||||
then runExportDag opts
|
||||
else runExportBundle opts
|
||||
|
||||
runExportBundle :: TricuArgs -> IO ()
|
||||
runExportBundle opts = do
|
||||
let targets = exportTargets opts
|
||||
out = exportOutput opts
|
||||
names = exportNames opts
|
||||
when (null out) $ die "tricu arboricx export: --output is required"
|
||||
when (null targets) $ die "tricu arboricx export: at least one --target is required"
|
||||
withContentStore (exportDb opts) $ \conn -> do
|
||||
terms <- mapM (\t -> do
|
||||
(h, _) <- resolveExportTarget conn t
|
||||
maybeTree <- loadTree conn h
|
||||
case maybeTree of
|
||||
Nothing -> die $ "Term not found in store: " ++ t
|
||||
Just tree -> return tree) targets
|
||||
let expNames = if null names
|
||||
then defaultExportNames (length terms)
|
||||
else map T.pack names
|
||||
when (length expNames /= length terms) $
|
||||
die "tricu arboricx export: number of --name values must match number of TARGETs"
|
||||
let namedTerms = zip expNames terms
|
||||
bundle = buildBundle namedTerms
|
||||
bundleData = encodeBundle bundle
|
||||
BL.writeFile out (BL.fromStrict bundleData)
|
||||
putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out
|
||||
putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
|
||||
putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
|
||||
|
||||
runExportDag :: TricuArgs -> IO ()
|
||||
runExportDag opts = do
|
||||
let targets = exportTargets opts
|
||||
out = exportOutput opts
|
||||
case targets of
|
||||
[target] -> withContentStore (exportDb opts) $ \conn -> do
|
||||
maybeTerm <- loadTerm conn target
|
||||
case maybeTerm of
|
||||
Nothing -> die $ "Term not found: " ++ target
|
||||
Just term -> do
|
||||
let (rootIdx, nodes) = Research.exportDag term
|
||||
output = unlines $
|
||||
show rootIdx :
|
||||
map (\(tag, refs) -> unwords (tag : map show refs)) nodes
|
||||
writeOutput out output
|
||||
[] -> die "tricu arboricx export --dag: exactly one --target is required"
|
||||
_ -> die "tricu arboricx export --dag: exactly one --target is required"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a
|
||||
withContentStore mPath act = do
|
||||
conn <- initContentStoreWithPath mPath
|
||||
result <- act conn
|
||||
close conn
|
||||
return result
|
||||
|
||||
writeOutput :: FilePath -> String -> IO ()
|
||||
writeOutput path content
|
||||
| null path = putStr content
|
||||
| otherwise = writeFile path content
|
||||
|
||||
runTricuTEnv :: Env -> String -> T
|
||||
runTricuTEnv env input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu env asts
|
||||
in result finalEnv
|
||||
|
||||
runTricuWithEnvT :: String -> (Env, T)
|
||||
runTricuWithEnvT input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu Map.empty asts
|
||||
in (finalEnv, result finalEnv)
|
||||
|
||||
runTricuWithEnv :: String -> (Env, String)
|
||||
runTricuWithEnv input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu Map.empty asts
|
||||
res = result finalEnv
|
||||
in (finalEnv, formatT TreeCalculus res)
|
||||
|
||||
runTricuEnvWithEnvT :: Env -> String -> (Env, T)
|
||||
runTricuEnvWithEnvT env input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu env asts
|
||||
in (finalEnv, result finalEnv)
|
||||
|
||||
runTricuEnvWithEnv :: Env -> String -> (Env, String)
|
||||
runTricuEnvWithEnv env input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu env asts
|
||||
res = result finalEnv
|
||||
in (finalEnv, formatT TreeCalculus res)
|
||||
|
||||
646
src/Parser.hs
646
src/Parser.hs
@@ -3,319 +3,427 @@ module Parser where
|
||||
import Lexer
|
||||
import Research
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.State
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.Void (Void)
|
||||
import Control.Monad (void)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Set as Set
|
||||
|
||||
data PState = PState
|
||||
{ parenDepth :: Int
|
||||
, bracketDepth :: Int
|
||||
} deriving (Show)
|
||||
type TokParser = Parsec Void [LToken]
|
||||
|
||||
type ParserM = StateT PState (Parsec Void [LToken])
|
||||
data Context = Top | Nested
|
||||
deriving (Eq, Show)
|
||||
|
||||
satisfyM :: (LToken -> Bool) -> ParserM LToken
|
||||
satisfyM f = do
|
||||
token <- lift (satisfy f)
|
||||
modify' (updateDepth token)
|
||||
return token
|
||||
|
||||
updateDepth :: LToken -> PState -> PState
|
||||
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
|
||||
updateDepth LOpenBracket st = st { bracketDepth = bracketDepth st + 1 }
|
||||
updateDepth LCloseParen st = st { parenDepth = parenDepth st - 1 }
|
||||
updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 }
|
||||
updateDepth _ st = st
|
||||
|
||||
topLevelNewline :: ParserM ()
|
||||
topLevelNewline = do
|
||||
st <- get
|
||||
if parenDepth st == 0 && bracketDepth st == 0
|
||||
then void (satisfyM (== LNewline))
|
||||
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
|
||||
|
||||
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
||||
parseSingleExpr tokens =
|
||||
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
|
||||
|
||||
finalizeDepth :: ParserM ()
|
||||
finalizeDepth = do
|
||||
st <- get
|
||||
case (parenDepth st, bracketDepth st) of
|
||||
(0, 0) -> pure ()
|
||||
(p, b) -> fail $ "Unmatched tokens: " ++ show (p, b)
|
||||
reservedNames :: Set.Set String
|
||||
reservedNames = Set.fromList ["t", "!result"]
|
||||
|
||||
parseTricu :: String -> [TricuAST]
|
||||
parseTricu input =
|
||||
case lexTricu input of
|
||||
[] -> []
|
||||
toks ->
|
||||
case parseProgram toks of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right asts -> asts
|
||||
let toks = lexTricu input
|
||||
in case runParser programP "" toks of
|
||||
Left err -> errorWithoutStackTrace (handleParseError toks err)
|
||||
Right asts -> asts
|
||||
|
||||
parseSingle :: String -> TricuAST
|
||||
parseSingle input =
|
||||
case lexTricu input of
|
||||
[] -> SEmpty
|
||||
toks ->
|
||||
case parseSingleExpr toks of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right ast -> ast
|
||||
let toks = lexTricu input
|
||||
in case parseSingleExpr toks of
|
||||
Left err -> errorWithoutStackTrace (handleParseError toks err)
|
||||
Right ast -> ast
|
||||
|
||||
parseProgramM :: ParserM [TricuAST]
|
||||
parseProgramM = do
|
||||
skipMany topLevelNewline
|
||||
importNodes <- many (do
|
||||
node <- parseImportM
|
||||
skipMany topLevelNewline
|
||||
return node)
|
||||
skipMany topLevelNewline
|
||||
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
||||
skipMany topLevelNewline
|
||||
return (importNodes ++ exprs)
|
||||
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
|
||||
parseProgram = runParser programP ""
|
||||
|
||||
parseImportM :: ParserM TricuAST
|
||||
parseImportM = do
|
||||
LImport filePath moduleName <- satisfyM isImport
|
||||
pure (SImport filePath moduleName)
|
||||
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
||||
parseSingleExpr = runParser singleP ""
|
||||
|
||||
programP :: TokParser [TricuAST]
|
||||
programP = do
|
||||
skipTopNewlines
|
||||
imports <- many (importP <* skipTopNewlines)
|
||||
items <- manyItemsP
|
||||
eof
|
||||
pure (imports ++ items)
|
||||
|
||||
singleP :: TokParser TricuAST
|
||||
singleP = do
|
||||
skipTopNewlines
|
||||
item <- topItemP
|
||||
skipTopNewlines
|
||||
eof
|
||||
pure item
|
||||
|
||||
manyItemsP :: TokParser [TricuAST]
|
||||
manyItemsP = do
|
||||
skipTopNewlines
|
||||
done <- atEndP
|
||||
if done
|
||||
then pure []
|
||||
else do
|
||||
item <- topItemP
|
||||
skipTopNewlines
|
||||
rest <- manyItemsP
|
||||
pure (item : rest)
|
||||
|
||||
topItemP :: TokParser TricuAST
|
||||
topItemP = do
|
||||
toks <- getInput
|
||||
case toks of
|
||||
LIdentifier _ : LAssign : _ -> definitionP
|
||||
_ -> exprTopP
|
||||
|
||||
definitionP :: TokParser TricuAST
|
||||
definitionP = do
|
||||
name <- identifierNameP
|
||||
void (tok (== LAssign) "=")
|
||||
skipNestedNewlines
|
||||
body <- exprTopP
|
||||
pure (SDef name [] body)
|
||||
|
||||
importP :: TokParser TricuAST
|
||||
importP = do
|
||||
t <- tok isImport "import"
|
||||
case t of
|
||||
LImport path ns -> pure (SImport path ns)
|
||||
_ -> fail "internal parser error: expected import token"
|
||||
where
|
||||
isImport (LImport _ _) = True
|
||||
isImport _ = False
|
||||
|
||||
parseOneExpression :: ParserM TricuAST
|
||||
parseOneExpression = scnParserM *> parseExpressionM
|
||||
exprTopP :: TokParser TricuAST
|
||||
exprTopP = do
|
||||
toks <- getInput
|
||||
case lambdaHeadTop toks of
|
||||
Just params -> lambdaP Top params
|
||||
Nothing -> pipeTopP
|
||||
|
||||
scnParserM :: ParserM ()
|
||||
scnParserM = skipMany $ do
|
||||
t <- lookAhead anySingle
|
||||
st <- get
|
||||
if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
|
||||
void $ satisfyM (== LNewline)
|
||||
| otherwise ->
|
||||
fail "In nested context or no space token" <|> empty
|
||||
exprNestedP :: TokParser TricuAST
|
||||
exprNestedP = do
|
||||
skipNestedNewlines
|
||||
toks <- getInput
|
||||
case lambdaHeadNested toks of
|
||||
Just params -> lambdaP Nested params
|
||||
Nothing -> pipeNestedP
|
||||
|
||||
eofM :: ParserM ()
|
||||
eofM = lift eof
|
||||
lambdaP :: Context -> [String] -> TokParser TricuAST
|
||||
lambdaP ctx params = do
|
||||
consumeLambdaHead ctx params
|
||||
body <- case ctx of
|
||||
Top -> exprTopP
|
||||
Nested -> exprNestedP
|
||||
pure (foldr (\p acc -> SLambda [p] acc) body params)
|
||||
|
||||
parseExpressionM :: ParserM TricuAST
|
||||
parseExpressionM = choice
|
||||
[ try parseFunctionM
|
||||
, try parseLambdaM
|
||||
, try parseLambdaExpressionM
|
||||
, try parseListLiteralM
|
||||
, try parseApplicationM
|
||||
, try parseTreeTermM
|
||||
, parseLiteralM
|
||||
]
|
||||
lambdaHeadTop :: [LToken] -> Maybe [String]
|
||||
lambdaHeadTop toks =
|
||||
case collectIdentifiersNoNewlines toks of
|
||||
(params@(_:_), LColon : _) -> Just params
|
||||
_ -> Nothing
|
||||
|
||||
parseFunctionM :: ParserM TricuAST
|
||||
parseFunctionM = do
|
||||
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||
LIdentifier name <- satisfyM ident
|
||||
args <- many $ satisfyM ident
|
||||
_ <- satisfyM (== LAssign)
|
||||
scnParserM
|
||||
body <- parseExpressionM
|
||||
pure (SDef name (map getIdentifier args) body)
|
||||
lambdaHeadNested :: [LToken] -> Maybe [String]
|
||||
lambdaHeadNested toks =
|
||||
case collectIdentifiersWithNewlines (dropNewlines toks) of
|
||||
(params@(_:_), rest) ->
|
||||
case dropNewlines rest of
|
||||
LColon : _ -> Just params
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
parseLambdaM :: ParserM TricuAST
|
||||
parseLambdaM = do
|
||||
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||
params <- some (satisfyM ident)
|
||||
_ <- satisfyM (== LColon)
|
||||
scnParserM
|
||||
body <- parseLambdaExpressionM
|
||||
pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
|
||||
collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
|
||||
collectIdentifiersNoNewlines (LIdentifier name : rest) =
|
||||
let (names, final) = collectIdentifiersNoNewlines rest
|
||||
in (name : names, final)
|
||||
collectIdentifiersNoNewlines rest = ([], rest)
|
||||
|
||||
parseLambdaExpressionM :: ParserM TricuAST
|
||||
parseLambdaExpressionM = choice
|
||||
[ try parseLambdaApplicationM
|
||||
, parseAtomicLambdaM
|
||||
]
|
||||
collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
|
||||
collectIdentifiersWithNewlines (LIdentifier name : rest) =
|
||||
let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
|
||||
in (name : names, final)
|
||||
collectIdentifiersWithNewlines rest = ([], rest)
|
||||
|
||||
parseAtomicLambdaM :: ParserM TricuAST
|
||||
parseAtomicLambdaM = choice
|
||||
[ try parseLambdaM
|
||||
, parseVarM
|
||||
, parseTreeLeafM
|
||||
, parseLiteralM
|
||||
, parseListLiteralM
|
||||
, between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
|
||||
]
|
||||
consumeLambdaHead :: Context -> [String] -> TokParser ()
|
||||
consumeLambdaHead ctx params = do
|
||||
case ctx of
|
||||
Top -> pure ()
|
||||
Nested -> skipNestedNewlines
|
||||
|
||||
parseApplicationM :: ParserM TricuAST
|
||||
parseApplicationM = do
|
||||
func <- parseAtomicBaseM
|
||||
scnParserM
|
||||
args <- many $ do
|
||||
scnParserM
|
||||
arg <- parseAtomicM
|
||||
return arg
|
||||
return $ foldl SApp func args
|
||||
mapM_ consumeParam params
|
||||
|
||||
parseLambdaApplicationM :: ParserM TricuAST
|
||||
parseLambdaApplicationM = do
|
||||
func <- parseAtomicLambdaM
|
||||
scnParserM
|
||||
args <- many $ do
|
||||
arg <- parseAtomicLambdaM
|
||||
scnParserM
|
||||
pure arg
|
||||
pure $ foldl SApp func args
|
||||
case ctx of
|
||||
Top -> pure ()
|
||||
Nested -> skipNestedNewlines
|
||||
|
||||
parseAtomicBaseM :: ParserM TricuAST
|
||||
parseAtomicBaseM = choice
|
||||
[ parseTreeLeafM
|
||||
, parseGroupedM
|
||||
]
|
||||
|
||||
parseTreeLeafM :: ParserM TricuAST
|
||||
parseTreeLeafM = do
|
||||
let keyword = (\case LKeywordT -> True; _ -> False)
|
||||
_ <- satisfyM keyword
|
||||
notFollowedBy $ lift $ satisfy (== LAssign)
|
||||
pure TLeaf
|
||||
|
||||
parseTreeTermM :: ParserM TricuAST
|
||||
parseTreeTermM = do
|
||||
base <- parseTreeLeafOrParenthesizedM
|
||||
rest <- many parseTreeLeafOrParenthesizedM
|
||||
pure (foldl combine base rest)
|
||||
void (tok (== LColon) ":")
|
||||
skipNestedNewlines
|
||||
where
|
||||
combine acc next
|
||||
| TLeaf <- acc = TStem next
|
||||
| TStem t <- acc = TFork t next
|
||||
| TFork _ _ <- acc = TFork acc next
|
||||
consumeParam _ = do
|
||||
void identifierNameP
|
||||
case ctx of
|
||||
Top -> pure ()
|
||||
Nested -> skipNestedNewlines
|
||||
|
||||
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
|
||||
parseTreeLeafOrParenthesizedM = choice
|
||||
[ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
|
||||
, parseTreeLeafM
|
||||
]
|
||||
data PipeOp = PipeBackward | PipeForward
|
||||
deriving (Eq, Show)
|
||||
|
||||
parseAtomicM :: ParserM TricuAST
|
||||
parseAtomicM = choice
|
||||
[ try parseLambdaM
|
||||
, parseVarM
|
||||
, parseTreeLeafM
|
||||
, parseListLiteralM
|
||||
, parseGroupedM
|
||||
, parseLiteralM
|
||||
]
|
||||
applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST
|
||||
applyPipe acc (PipeBackward, rhs) =
|
||||
SApp acc rhs
|
||||
|
||||
parseGroupedM :: ParserM TricuAST
|
||||
parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
|
||||
scnParserM *> parseExpressionM <* scnParserM
|
||||
applyPipe acc (PipeForward, rhs) =
|
||||
SApp rhs acc
|
||||
|
||||
parseLiteralM :: ParserM TricuAST
|
||||
parseLiteralM = choice
|
||||
[ parseIntLiteralM
|
||||
, parseStrLiteralM
|
||||
]
|
||||
pipeTopP :: TokParser TricuAST
|
||||
pipeTopP =
|
||||
pipeChainP appTopP appNestedP
|
||||
|
||||
parseListLiteralM :: ParserM TricuAST
|
||||
parseListLiteralM = do
|
||||
_ <- satisfyM (== LOpenBracket)
|
||||
elements <- many $ do
|
||||
scnParserM
|
||||
parseListItemM
|
||||
scnParserM
|
||||
_ <- satisfyM (== LCloseBracket)
|
||||
pure (SList elements)
|
||||
pipeNestedP :: TokParser TricuAST
|
||||
pipeNestedP =
|
||||
pipeChainP appNestedP appNestedP
|
||||
|
||||
parseListItemM :: ParserM TricuAST
|
||||
parseListItemM = choice
|
||||
[ parseGroupedItemM
|
||||
, parseListLiteralM
|
||||
, parseSingleItemM
|
||||
]
|
||||
pipeChainP :: TokParser TricuAST -> TokParser TricuAST -> TokParser TricuAST
|
||||
pipeChainP parseFirst parseOperand = do
|
||||
first <- parseFirst
|
||||
rest <- many (try pipeSegmentP)
|
||||
pure (foldl applyPipe first rest)
|
||||
where
|
||||
pipeSegmentP = do
|
||||
skipNestedNewlines
|
||||
op <- pipeOpP
|
||||
skipNestedNewlines
|
||||
rhs <- parseOperand
|
||||
pure (op, rhs)
|
||||
|
||||
parseGroupedItemM :: ParserM TricuAST
|
||||
parseGroupedItemM = do
|
||||
_ <- satisfyM (== LOpenParen)
|
||||
inner <- parseExpressionM
|
||||
_ <- satisfyM (== LCloseParen)
|
||||
pure inner
|
||||
pipeOpP :: TokParser PipeOp
|
||||
pipeOpP =
|
||||
(tok (== LArrowLeft) "<|" *> pure PipeBackward)
|
||||
<|> (tok (== LArrowRight) "|>" *> pure PipeForward)
|
||||
|
||||
parseSingleItemM :: ParserM TricuAST
|
||||
parseSingleItemM = do
|
||||
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||
if | LIdentifier name <- token -> pure (SVar name Nothing)
|
||||
| token == LKeywordT -> pure TLeaf
|
||||
| otherwise -> fail "Unexpected token in list item"
|
||||
appTopP :: TokParser TricuAST
|
||||
appTopP = do
|
||||
first <- atomTopP
|
||||
appRestTopP first
|
||||
|
||||
parseVarM :: ParserM TricuAST
|
||||
parseVarM = do
|
||||
token <- satisfyM (\case
|
||||
LNamespace _ -> True
|
||||
LIdentifier _ -> True
|
||||
LIdentifierWithHash _ _ -> True
|
||||
_ -> False)
|
||||
appRestTopP :: TricuAST -> TokParser TricuAST
|
||||
appRestTopP acc = do
|
||||
mt <- peekP
|
||||
case mt of
|
||||
Just t | startsAtom t -> do
|
||||
arg <- atomTopP
|
||||
appRestTopP (SApp acc arg)
|
||||
_ -> pure acc
|
||||
|
||||
case token of
|
||||
LNamespace ns -> do
|
||||
_ <- satisfyM (== LDot)
|
||||
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
|
||||
pure $ SVar (ns ++ "." ++ name) Nothing
|
||||
appNestedP :: TokParser TricuAST
|
||||
appNestedP = do
|
||||
first <- atomNestedP
|
||||
appRestNestedP first
|
||||
|
||||
appRestNestedP :: TricuAST -> TokParser TricuAST
|
||||
appRestNestedP acc = do
|
||||
skipNestedNewlines
|
||||
mt <- peekP
|
||||
case mt of
|
||||
Just t | startsAtom t -> do
|
||||
arg <- atomNestedP
|
||||
appRestNestedP (SApp acc arg)
|
||||
_ -> pure acc
|
||||
|
||||
startsAtom :: LToken -> Bool
|
||||
startsAtom LOpenParen = True
|
||||
startsAtom LOpenBracket = True
|
||||
startsAtom (LIdentifier _) = True
|
||||
startsAtom (LIdentifierWithHash _ _) = True
|
||||
startsAtom (LNamespace _) = True
|
||||
startsAtom LKeywordT = True
|
||||
startsAtom (LIntegerLiteral _) = True
|
||||
startsAtom (LStringLiteral _) = True
|
||||
startsAtom _ = False
|
||||
|
||||
atomTopP :: TokParser TricuAST
|
||||
atomTopP = do
|
||||
toks <- getInput
|
||||
case toks of
|
||||
LOpenParen : _ -> groupedP
|
||||
LOpenBracket : _ -> listP
|
||||
LNamespace _ : LDot : _ -> namespacedVarP
|
||||
LIdentifier _ : _ -> plainVarP
|
||||
LIdentifierWithHash _ _ : _ -> plainVarP
|
||||
LKeywordT : _ -> leafP
|
||||
LIntegerLiteral _ : _ -> intP
|
||||
LStringLiteral _ : _ -> strP
|
||||
_ -> fail "expected expression atom"
|
||||
|
||||
atomNestedP :: TokParser TricuAST
|
||||
atomNestedP = skipNestedNewlines *> atomTopP
|
||||
|
||||
groupedP :: TokParser TricuAST
|
||||
groupedP = do
|
||||
void (tok (== LOpenParen) "(")
|
||||
skipNestedNewlines
|
||||
expr <- exprNestedP
|
||||
skipNestedNewlines
|
||||
void (tok (== LCloseParen) ")")
|
||||
pure expr
|
||||
|
||||
listP :: TokParser TricuAST
|
||||
listP = do
|
||||
void (tok (== LOpenBracket) "[")
|
||||
skipNestedNewlines
|
||||
xs <- listElementsP
|
||||
skipNestedNewlines
|
||||
void (tok (== LCloseBracket) "]")
|
||||
pure (SList xs)
|
||||
|
||||
listElementsP :: TokParser [TricuAST]
|
||||
listElementsP = do
|
||||
skipNestedNewlines
|
||||
mt <- peekP
|
||||
case mt of
|
||||
Just LCloseBracket -> pure []
|
||||
Just t | startsAtom t -> do
|
||||
x <- listElementP
|
||||
xs <- listElementsP
|
||||
pure (x : xs)
|
||||
_ -> pure []
|
||||
|
||||
listElementP :: TokParser TricuAST
|
||||
listElementP = do
|
||||
toks <- getInput
|
||||
case toks of
|
||||
LOpenParen : _ -> groupedP
|
||||
LOpenBracket : _ -> listP
|
||||
LNamespace _ : LDot : _ -> namespacedVarP
|
||||
LIdentifier _ : _ -> plainVarP
|
||||
LIdentifierWithHash _ _ : _ -> plainVarP
|
||||
LKeywordT : _ -> leafP
|
||||
LIntegerLiteral _ : _ -> intP
|
||||
LStringLiteral _ : _ -> strP
|
||||
_ -> fail "expected list element"
|
||||
|
||||
leafP :: TokParser TricuAST
|
||||
leafP = tok (== LKeywordT) "t" *> pure TLeaf
|
||||
|
||||
plainVarP :: TokParser TricuAST
|
||||
plainVarP = do
|
||||
t <- tok isVar "identifier"
|
||||
case t of
|
||||
LIdentifier name -> pure (SVar name Nothing)
|
||||
LIdentifierWithHash name hash -> pure (SVar name (Just hash))
|
||||
_ -> fail "internal parser error: expected identifier"
|
||||
where
|
||||
isVar (LIdentifier _) = True
|
||||
isVar (LIdentifierWithHash _ _) = True
|
||||
isVar _ = False
|
||||
|
||||
namespacedVarP :: TokParser TricuAST
|
||||
namespacedVarP = do
|
||||
nsTok <- tok isNamespace "namespace"
|
||||
void (tok (== LDot) ".")
|
||||
nameTok <- tok isVar "identifier"
|
||||
case (nsTok, nameTok) of
|
||||
(LNamespace ns, LIdentifier name) ->
|
||||
pure (SVar (ns ++ "." ++ name) Nothing)
|
||||
(LNamespace ns, LIdentifierWithHash name hash) ->
|
||||
pure (SVar (ns ++ "." ++ name) (Just hash))
|
||||
_ -> fail "internal parser error: expected namespaced identifier"
|
||||
where
|
||||
isNamespace (LNamespace _) = True
|
||||
isNamespace _ = False
|
||||
|
||||
isVar (LIdentifier _) = True
|
||||
isVar (LIdentifierWithHash _ _) = True
|
||||
isVar _ = False
|
||||
|
||||
intP :: TokParser TricuAST
|
||||
intP = do
|
||||
t <- tok isInt "integer"
|
||||
case t of
|
||||
LIntegerLiteral n -> pure (SInt (fromIntegral n))
|
||||
_ -> fail "internal parser error: expected integer"
|
||||
where
|
||||
isInt (LIntegerLiteral _) = True
|
||||
isInt _ = False
|
||||
|
||||
strP :: TokParser TricuAST
|
||||
strP = do
|
||||
t <- tok isStr "string"
|
||||
case t of
|
||||
LStringLiteral s -> pure (SStr s)
|
||||
_ -> fail "internal parser error: expected string"
|
||||
where
|
||||
isStr (LStringLiteral _) = True
|
||||
isStr _ = False
|
||||
|
||||
identifierNameP :: TokParser String
|
||||
identifierNameP = do
|
||||
t <- tok isIdentifier "identifier"
|
||||
case t of
|
||||
LIdentifier name
|
||||
| name == "t" || name == "!result" ->
|
||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
| otherwise -> pure (SVar name Nothing)
|
||||
| name `Set.member` reservedNames ->
|
||||
fail ("reserved name cannot be used as identifier: " ++ name)
|
||||
| otherwise ->
|
||||
pure name
|
||||
_ -> fail "internal parser error: expected identifier"
|
||||
where
|
||||
isIdentifier (LIdentifier _) = True
|
||||
isIdentifier _ = False
|
||||
|
||||
LIdentifierWithHash name hash ->
|
||||
if name == "t" || name == "!result"
|
||||
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
else pure (SVar name (Just hash))
|
||||
tok :: (LToken -> Bool) -> String -> TokParser LToken
|
||||
tok predicate expected = satisfy predicate <?> expected
|
||||
|
||||
_ -> fail "Unexpected token while parsing variable"
|
||||
peekP :: TokParser (Maybe LToken)
|
||||
peekP = do
|
||||
toks <- getInput
|
||||
pure $ case toks of
|
||||
[] -> Nothing
|
||||
x : _ -> Just x
|
||||
|
||||
parseIntLiteralM :: ParserM TricuAST
|
||||
parseIntLiteralM = do
|
||||
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM intL
|
||||
if | LIntegerLiteral value <- token ->
|
||||
pure (SInt (fromIntegral value))
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing integer literal"
|
||||
atEndP :: TokParser Bool
|
||||
atEndP = null <$> getInput
|
||||
|
||||
parseStrLiteralM :: ParserM TricuAST
|
||||
parseStrLiteralM = do
|
||||
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM strL
|
||||
if | LStringLiteral value <- token ->
|
||||
pure (SStr value)
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing string literal"
|
||||
skipTopNewlines :: TokParser ()
|
||||
skipTopNewlines = skipMany (tok (== LNewline) "newline")
|
||||
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
getIdentifier _ = errorWithoutStackTrace "Expected identifier"
|
||||
skipNestedNewlines :: TokParser ()
|
||||
skipNestedNewlines = skipMany (tok (== LNewline) "newline")
|
||||
|
||||
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
||||
handleParseError bundle =
|
||||
let errors = bundleErrors bundle
|
||||
formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
|
||||
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
||||
dropNewlines :: [LToken] -> [LToken]
|
||||
dropNewlines (LNewline : rest) = dropNewlines rest
|
||||
dropNewlines rest = rest
|
||||
|
||||
formatError :: ParseError [LToken] Void -> String
|
||||
formatError (TrivialError offset unexpected expected) =
|
||||
let unexpectedMsg = case unexpected of
|
||||
Just x -> "unexpected token " ++ show x
|
||||
Nothing -> "unexpected end of input"
|
||||
expectedMsg = if null expected
|
||||
then ""
|
||||
else "expected " ++ show (Set.toList expected)
|
||||
in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
|
||||
if null expectedMsg then "" else " " ++ expectedMsg
|
||||
formatError (FancyError offset _) =
|
||||
"Parse error at offset " ++ show offset ++ ": unexpected FancyError"
|
||||
handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String
|
||||
handleParseError toks bundle =
|
||||
unlines
|
||||
( "Parse error(s) encountered:"
|
||||
: map (formatError toks) (NE.toList (bundleErrors bundle))
|
||||
)
|
||||
|
||||
formatError :: [LToken] -> ParseError [LToken] Void -> String
|
||||
formatError toks err =
|
||||
case err of
|
||||
TrivialError offset unexpected expected ->
|
||||
let unexpectedMsg =
|
||||
case unexpected of
|
||||
Nothing -> "unexpected end of input"
|
||||
Just x -> "unexpected " ++ show x
|
||||
expectedMsg =
|
||||
if Set.null expected
|
||||
then ""
|
||||
else "; expected one of " ++ show (Set.toList expected)
|
||||
in
|
||||
"Parse error at token offset " ++ show offset ++ ": " ++ unexpectedMsg ++ expectedMsg
|
||||
++ "\nToken context:\n" ++ tokenContext toks offset
|
||||
|
||||
FancyError offset fancy ->
|
||||
"Parse error at token offset " ++ show offset ++ ": " ++ show (Set.toList fancy)
|
||||
++ "\nToken context:\n" ++ tokenContext toks offset
|
||||
|
||||
tokenContext :: [LToken] -> Int -> String
|
||||
tokenContext toks off =
|
||||
let start = max 0 (off - 5)
|
||||
end = min (length toks) (off + 6)
|
||||
rows = zip [start ..] (take (end - start) (drop start toks))
|
||||
in unlines (map render rows)
|
||||
where
|
||||
render (i, token)
|
||||
| i == off = ">>> " ++ show i ++ ": " ++ show token
|
||||
| otherwise = " " ++ show i ++ ": " ++ show token
|
||||
|
||||
187
src/REPL.hs
187
src/REPL.hs
@@ -1,48 +1,44 @@
|
||||
module REPL where
|
||||
|
||||
import ContentStore
|
||||
import Eval
|
||||
import FileEval
|
||||
import Lexer
|
||||
import Lexer ()
|
||||
import Parser
|
||||
import Research
|
||||
import ContentStore
|
||||
import Wire (buildBundle, encodeBundle, importBundle)
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
||||
import Control.Monad (forever, void, when, forM, forM_, foldM, unless)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (isNothing, isJust, fromJust, catMaybes)
|
||||
import Database.SQLite.Simple (Connection, Only(..), query, query_, execute, execute_, open)
|
||||
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 ()
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.ByteString ()
|
||||
import Data.Char (isSpace)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
import Data.List (dropWhileEnd, isPrefixOf, find)
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Data.Time (getCurrentTime, diffUTCTime)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||
import Data.Version (showVersion)
|
||||
import Database.SQLite.Simple (Connection, Only(..), query)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
|
||||
import System.Console.Haskeline
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
import System.FSNotify
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Control.Exception (IOException, SomeException, catch
|
||||
, displayException)
|
||||
import Control.Monad (forM_)
|
||||
import Control.Monad.Catch (handle, MonadCatch)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.Char (isSpace, isUpper)
|
||||
import Data.List ((\\), dropWhile, dropWhileEnd, isPrefixOf, nub, sortBy, groupBy, intercalate, find)
|
||||
import Data.Version (showVersion)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.Haskeline
|
||||
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..),
|
||||
Color(..), ConsoleIntensity(..), clearFromCursorToLineEnd)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.Time (UTCTime, getCurrentTime, diffUTCTime)
|
||||
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
|
||||
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import qualified Data.Text.IO as T ()
|
||||
|
||||
data REPLState = REPLState
|
||||
{ replForm :: EvaluatedForm
|
||||
@@ -80,6 +76,8 @@ repl = do
|
||||
, "!versions"
|
||||
, "!select"
|
||||
, "!tag"
|
||||
, "!export"
|
||||
, "!bundleimport"
|
||||
]
|
||||
|
||||
loop :: REPLState -> InputT IO ()
|
||||
@@ -110,6 +108,8 @@ repl = do
|
||||
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
|
||||
@@ -119,28 +119,30 @@ repl = do
|
||||
| "!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
|
||||
result <- liftIO $ catch
|
||||
evalResult <- liftIO $ catch
|
||||
(processInput state s)
|
||||
(errorHandler state)
|
||||
loop result
|
||||
loop evalResult
|
||||
|
||||
handleOutput :: REPLState -> InputT IO ()
|
||||
handleOutput state = do
|
||||
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
|
||||
let formats = [Decode, Tree, 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 state
|
||||
@@ -201,7 +203,7 @@ repl = do
|
||||
|
||||
importFile :: REPLState -> String -> InputT IO ()
|
||||
importFile state cleanFilename = do
|
||||
code <- liftIO $ readFile cleanFilename
|
||||
_code <- liftIO $ readFile cleanFilename
|
||||
case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
@@ -216,7 +218,7 @@ repl = do
|
||||
importedCount <- foldM (\count (name, term) -> do
|
||||
hash <- ContentStore.storeTerm conn [name] term
|
||||
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
return (count + 1)
|
||||
return (count + (1 :: Int))
|
||||
) 0 defs
|
||||
|
||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||
@@ -248,7 +250,7 @@ repl = do
|
||||
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
||||
|
||||
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
||||
stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do
|
||||
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
|
||||
now <- getCurrentTime
|
||||
lastProcessed <- readIORef lastProcessedRef
|
||||
when (diffUTCTime now lastProcessed > 0.5) $ do
|
||||
@@ -259,8 +261,8 @@ repl = do
|
||||
|
||||
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
|
||||
|
||||
handleUnwatch :: REPLState -> InputT IO ()
|
||||
handleUnwatch state = case replWatchedFile state of
|
||||
_handleUnwatch :: REPLState -> InputT IO ()
|
||||
_handleUnwatch state = case replWatchedFile state of
|
||||
Nothing -> do
|
||||
outputStrLn "No file is currently being watched"
|
||||
loop state
|
||||
@@ -275,7 +277,7 @@ repl = do
|
||||
Nothing -> do
|
||||
outputStrLn "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
Just _conn -> do
|
||||
outputStrLn "Environment refreshed from content store (definitions are live)"
|
||||
loop state
|
||||
|
||||
@@ -445,6 +447,81 @@ repl = do
|
||||
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
|
||||
maybeTree <- liftIO $ loadTree conn hash
|
||||
case maybeTree of
|
||||
Nothing -> do
|
||||
liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
|
||||
loop state
|
||||
Just tree -> do
|
||||
let bundle = buildBundle [(T.pack "root", tree)]
|
||||
bundleData = encodeBundle bundle
|
||||
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
|
||||
@@ -486,8 +563,8 @@ repl = do
|
||||
forM_ asts $ \ast -> do
|
||||
case ast of
|
||||
SDef name [] body -> do
|
||||
result <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] result
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
@@ -498,14 +575,14 @@ repl = do
|
||||
putStrLn ""
|
||||
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) result
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
|
||||
_ -> do
|
||||
result <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) result
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
return newState
|
||||
|
||||
@@ -531,13 +608,13 @@ repl = do
|
||||
Just conn -> do
|
||||
forM_ asts $ \ast -> case ast of
|
||||
SDef name [] body -> do
|
||||
result <- evalAST (Just conn) selectedVersions body
|
||||
hash <- ContentStore.storeTerm conn [name] result
|
||||
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 result
|
||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||
_ -> do
|
||||
result <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm result
|
||||
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||
|
||||
formatTimestamp :: Integer -> String
|
||||
@@ -552,12 +629,6 @@ repl = do
|
||||
putStr $ T.unpack rest
|
||||
setSGR [Reset]
|
||||
|
||||
coloredHashString :: T.Text -> String
|
||||
coloredHashString hash =
|
||||
"\ESC[1;36m" ++ T.unpack (T.take 16 hash) ++
|
||||
"\ESC[0;37m" ++ T.unpack (T.drop 16 hash) ++
|
||||
"\ESC[0m"
|
||||
|
||||
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
||||
withColor intensity color action = do
|
||||
setSGR [SetColor Foreground intensity color]
|
||||
|
||||
184
src/Research.hs
184
src/Research.hs
@@ -1,17 +1,17 @@
|
||||
module Research where
|
||||
|
||||
import Crypto.Hash (hash, SHA256, Digest)
|
||||
import Data.ByteArray (convert)
|
||||
import Data.Char (chr, ord)
|
||||
import Data.ByteString.Base16 (decode, encode)
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text, replace, unpack)
|
||||
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.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Crypto.Hash (hash, SHA256, Digest)
|
||||
|
||||
-- Tree Calculus Types
|
||||
data T = Leaf | Stem T | Fork T T
|
||||
@@ -19,7 +19,7 @@ data T = Leaf | Stem T | Fork T T
|
||||
|
||||
-- Abstract Syntax Tree for tricu
|
||||
data TricuAST
|
||||
= SVar String (Maybe String) -- Variable name and optional hash prefix
|
||||
= SVar String (Maybe String)
|
||||
| SInt Integer
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
@@ -49,12 +49,14 @@ data LToken
|
||||
| LCloseBracket
|
||||
| LStringLiteral String
|
||||
| LIntegerLiteral Int
|
||||
| LArrowLeft
|
||||
| LArrowRight
|
||||
| LNewline
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- Output formats
|
||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||
deriving (Show, Data, Typeable)
|
||||
data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode
|
||||
deriving (Show)
|
||||
|
||||
-- Environment containing previously evaluated TC terms
|
||||
type Env = Map.Map String T
|
||||
@@ -76,35 +78,20 @@ data Node
|
||||
-- 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] <> hexToBytes h
|
||||
serializeNode (NFork l r) = BS.pack [0x02] <> hexToBytes l <> hexToBytes r
|
||||
serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
|
||||
where go (Left _) = error "Research.serializeNode: invalid hex hash"
|
||||
go (Right bs) = bs
|
||||
serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
|
||||
where go (Left _) = error "Research.serializeNode: invalid hex hash"
|
||||
go (Right bs) = bs
|
||||
|
||||
-- | Hash a node per the Merkle content-addressing spec.
|
||||
-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
|
||||
-- hash = SHA256( "arboricx.merkle.node.v1" <> 0x00 <> node_payload )
|
||||
nodeHash :: Node -> MerkleHash
|
||||
nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node))
|
||||
nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
|
||||
where sha256WithPrefix payload =
|
||||
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
|
||||
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
|
||||
|
||||
-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte)
|
||||
hexToBytes :: Text -> BS.ByteString
|
||||
hexToBytes h = BS.pack $ map combinePair pairs
|
||||
where
|
||||
chars = unpack h
|
||||
pairs = chunkPairs chars
|
||||
chunkPairs :: String -> [(Char, Char)]
|
||||
chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest
|
||||
chunkPairs [] = []
|
||||
chunkPairs _ = error "hexToBytes: odd number of hex digits"
|
||||
combinePair :: (Char, Char) -> Word8
|
||||
combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2)
|
||||
hexDigitToInt :: Char -> Int
|
||||
hexDigitToInt c
|
||||
| '0' <= c && c <= '9' = ord c - ord '0'
|
||||
| 'a' <= c && c <= 'f' = ord c - ord 'a' + 10
|
||||
| 'A' <= c && c <= 'F' = ord c - ord 'A' + 10
|
||||
| otherwise = error $ "Invalid hex digit: " ++ show c
|
||||
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "arboricx.merkle.node.v1"
|
||||
|
||||
-- | Deserialize a Node from canonical bytes.
|
||||
deserializeNode :: BS.ByteString -> Node
|
||||
@@ -115,26 +102,69 @@ deserializeNode bs =
|
||||
|
||||
Just (0x01, rest)
|
||||
| BS.length rest == 32 ->
|
||||
NStem $ bytesToHex rest
|
||||
NStem $ decodeUtf8 (encode rest)
|
||||
|
||||
Just (0x02, rest)
|
||||
| BS.length rest == 64 ->
|
||||
let (l, r) = BS.splitAt 32 rest
|
||||
in NFork (bytesToHex l) (bytesToHex r)
|
||||
in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
|
||||
|
||||
_ -> error "invalid merkle node payload"
|
||||
_ -> errorWithoutStackTrace "invalid merkle node payload"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- ByteString / bytestream marshalling via existing Tree Calculus conventions
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Convert 32-byte ByteString back to hex Text
|
||||
bytesToHex :: BS.ByteString -> Text
|
||||
bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs
|
||||
where
|
||||
byteToHexChars :: Word8 -> String
|
||||
byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)]
|
||||
hexDigit :: Int -> Char
|
||||
hexDigit n
|
||||
| n < 10 = chr (ord '0' + n)
|
||||
| otherwise = chr (ord 'a' + n - 10)
|
||||
-- | 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
|
||||
@@ -158,9 +188,9 @@ buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
|
||||
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
|
||||
@@ -199,10 +229,18 @@ toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
|
||||
Left err -> Left err
|
||||
toNumber _ = Left "Invalid Tree Calculus number"
|
||||
|
||||
toChar :: Integer -> Either String Char
|
||||
toChar n
|
||||
| n < 0 = Left "Negative character code"
|
||||
| n > 0x10FFFF = Left "Character code out of Unicode range"
|
||||
| n >= 0xD800 && n <= 0xDFFF = Left "Surrogate character code not allowed"
|
||||
| otherwise = Right (toEnum (fromInteger n))
|
||||
|
||||
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"
|
||||
toString tc = do
|
||||
list <- toList tc
|
||||
nums <- mapM toNumber list
|
||||
mapM toChar nums
|
||||
|
||||
toList :: T -> Either String [T]
|
||||
toList Leaf = Right []
|
||||
@@ -213,7 +251,7 @@ toList _ = Left "Invalid Tree Calculus list"
|
||||
|
||||
-- Outputs
|
||||
formatT :: EvaluatedForm -> T -> String
|
||||
formatT TreeCalculus = toSimpleT . show
|
||||
formatT Tree = toSimpleT . show
|
||||
formatT FSL = show
|
||||
formatT AST = show . toAST
|
||||
formatT Ternary = toTernaryString
|
||||
@@ -259,7 +297,7 @@ decodeResult tc =
|
||||
(_, _, Right n) -> show n
|
||||
(_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
|
||||
(_, Right [], _) -> "[]"
|
||||
_ -> formatT TreeCalculus tc
|
||||
_ -> formatT Tree tc
|
||||
where
|
||||
isCommonChar c =
|
||||
let n = fromEnum c
|
||||
@@ -267,3 +305,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])
|
||||
|
||||
880
src/Wire.hs
Normal file
880
src/Wire.hs
Normal file
@@ -0,0 +1,880 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Wire
|
||||
( Bundle (..)
|
||||
, BundleManifest (..)
|
||||
, TreeSpec (..)
|
||||
, NodeHashSpec (..)
|
||||
, RuntimeSpec (..)
|
||||
, BundleRoot (..)
|
||||
, BundleExport (..)
|
||||
, BundleMetadata
|
||||
, ClosureMode (..)
|
||||
, BundleNode (..)
|
||||
, encodeBundle
|
||||
, decodeBundle
|
||||
, verifyBundle
|
||||
, buildBundle
|
||||
, importBundle
|
||||
, defaultExportNames
|
||||
) where
|
||||
|
||||
import ContentStore (storeTerm)
|
||||
import Research hiding (Node)
|
||||
|
||||
import Control.Monad (foldM, forM_, unless, when)
|
||||
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable (traverse_)
|
||||
import qualified Data.Foldable as Foldable
|
||||
import Data.List (mapAccumL)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Sequence (Seq, (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Vector.Mutable as MV
|
||||
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.Text as T
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Container constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
bundleMajorVersion :: Word16
|
||||
bundleMajorVersion = 1
|
||||
|
||||
bundleMinorVersion :: Word16
|
||||
bundleMinorVersion = 0
|
||||
|
||||
bundleMagic :: ByteString
|
||||
bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58]
|
||||
|
||||
headerLength :: Int
|
||||
headerLength = 32
|
||||
|
||||
sectionEntryLength :: Int
|
||||
sectionEntryLength = 32
|
||||
|
||||
sectionManifest, sectionNodes :: Word32
|
||||
sectionManifest = 1
|
||||
sectionNodes = 2
|
||||
|
||||
flagCritical :: Word16
|
||||
flagCritical = 0x0001
|
||||
|
||||
compressionNone :: Word16
|
||||
compressionNone = 0
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Manifest constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
manifestMagic :: ByteString
|
||||
manifestMagic = "ARBMNFST"
|
||||
|
||||
manifestMajorVersion :: Word16
|
||||
manifestMajorVersion = 1
|
||||
|
||||
manifestMinorVersion :: Word16
|
||||
manifestMinorVersion = 1
|
||||
|
||||
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
|
||||
|
||||
tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16
|
||||
tagPackage = 1
|
||||
tagVersion = 2
|
||||
tagDescription = 3
|
||||
tagLicense = 4
|
||||
tagCreatedBy = 5
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Text encoding helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
encodeLengthPrefixedText :: Text -> ByteString
|
||||
encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs
|
||||
where bs = encodeUtf8 t
|
||||
|
||||
decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString)
|
||||
decodeLengthPrefixedText bs = do
|
||||
(len, rest) <- decode32be "text_length" bs
|
||||
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"
|
||||
|
||||
encodeMetadataTLV :: Word16 -> ByteString -> ByteString
|
||||
encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Manifest encoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
encodeCapabilities :: [Text] -> ByteString
|
||||
encodeCapabilities = mconcat . map encodeLengthPrefixedText
|
||||
|
||||
encodeRoots :: [BundleRoot] -> ByteString
|
||||
encodeRoots = mconcat . map encodeRoot
|
||||
|
||||
encodeRoot :: BundleRoot -> ByteString
|
||||
encodeRoot root = encode32 (rootIndex root) <> encodeLengthPrefixedText (rootRole root)
|
||||
|
||||
encodeExports :: [BundleExport] -> ByteString
|
||||
encodeExports = mconcat . map encodeExport
|
||||
|
||||
encodeExport :: BundleExport -> ByteString
|
||||
encodeExport exp =
|
||||
encodeLengthPrefixedText (exportName exp)
|
||||
<> encode32 (exportRoot exp)
|
||||
<> encodeLengthPrefixedText (exportKind exp)
|
||||
<> encodeLengthPrefixedText (exportAbi exp)
|
||||
|
||||
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 = mconcat . map (uncurry encodeMetadataTLV)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Manifest decoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
decodeManifest :: ByteString -> Either String BundleManifest
|
||||
decodeManifest bs = do
|
||||
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
|
||||
(minor, rest'') <- decode16be "minor" rest'
|
||||
when (major /= manifestMajorVersion) $
|
||||
Left $ "unsupported manifest major version: " ++ show major
|
||||
when (minor /= manifestMinorVersion) $
|
||||
Left $ "unsupported manifest minor version: " ++ show minor
|
||||
|
||||
(schema, r1) <- decodeLengthPrefixedText rest''
|
||||
(bundleType, r2) <- decodeLengthPrefixedText r1
|
||||
(calc, r3) <- decodeLengthPrefixedText r2
|
||||
(alg, r4) <- decodeLengthPrefixedText r3
|
||||
(domain, r5) <- decodeLengthPrefixedText r4
|
||||
(payload, r6) <- decodeLengthPrefixedText r5
|
||||
(sem, r7) <- decodeLengthPrefixedText r6
|
||||
(eval, r8) <- decodeLengthPrefixedText r7
|
||||
(abi, r9) <- decodeLengthPrefixedText r8
|
||||
|
||||
(capCount, r10) <- decode32be "capability_count" r9
|
||||
(caps, r11) <- decodeCapabilities (fromIntegral capCount) r10
|
||||
|
||||
when (BS.length r11 < 1) $ Left "manifest truncated: missing closure byte"
|
||||
let (closureByte, r12) = BS.splitAt 1 r11
|
||||
closure <- closureFromByte (head $ BS.unpack closureByte)
|
||||
|
||||
(rootCount, r13) <- decode32be "root_count" r12
|
||||
(roots, r14) <- decodeRoots (fromIntegral rootCount) r13
|
||||
|
||||
(exportCount, r15) <- decode32be "export_count" r14
|
||||
(exports, r16) <- decodeExports (fromIntegral exportCount) r15
|
||||
|
||||
(metadata, _ext) <- decodeMetadataAndExtensions r16
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
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)
|
||||
|
||||
decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString)
|
||||
decodeRoots 0 bs = Right ([], bs)
|
||||
decodeRoots n bs = do
|
||||
(idx, rest1) <- decode32be "root_index" bs
|
||||
(role, rest2) <- decodeLengthPrefixedText rest1
|
||||
(restRoots, restFinal) <- decodeRoots (n - 1) rest2
|
||||
Right (BundleRoot idx role : restRoots, restFinal)
|
||||
|
||||
decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString)
|
||||
decodeExports 0 bs = Right ([], bs)
|
||||
decodeExports n bs = do
|
||||
(name, r1) <- decodeLengthPrefixedText bs
|
||||
(idx, r2) <- decode32be "export_root" r1
|
||||
(kind, r3) <- decodeLengthPrefixedText r2
|
||||
(abi, r4) <- decodeLengthPrefixedText r3
|
||||
(restExports, restFinal) <- decodeExports (n - 1) r4
|
||||
Right (BundleExport name idx kind abi : restExports, restFinal)
|
||||
|
||||
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)
|
||||
|
||||
decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString)
|
||||
decodeTLVs 0 bs = Right ([], bs)
|
||||
decodeTLVs n bs = do
|
||||
(tag, r1) <- decode16be "tlv_tag" bs
|
||||
(len, r2) <- decode32be "tlv_length" r1
|
||||
let payloadLen = fromIntegral len
|
||||
when (BS.length r2 < payloadLen) $ Left "TLV value extends beyond input"
|
||||
let (value, after) = BS.splitAt payloadLen r2
|
||||
(restTlvs, restFinal) <- decodeTLVs (n - 1) after
|
||||
Right ((tag, value) : restTlvs, restFinal)
|
||||
|
||||
decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata
|
||||
decodeMetadataTLVs tlvs = do
|
||||
pkg <- lookupText tagPackage
|
||||
ver <- lookupText tagVersion
|
||||
desc <- lookupText tagDescription
|
||||
lic <- lookupText tagLicense
|
||||
by <- lookupText 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
|
||||
lookupText 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
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
data ClosureMode = ClosureComplete | ClosurePartial
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data NodeHashSpec = NodeHashSpec
|
||||
{ nodeHashAlgorithm :: Text
|
||||
, nodeHashDomain :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data TreeSpec = TreeSpec
|
||||
{ treeCalculus :: Text
|
||||
, treeNodeHash :: NodeHashSpec
|
||||
, treeNodePayload :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data RuntimeSpec = RuntimeSpec
|
||||
{ runtimeSemantics :: Text
|
||||
, runtimeEvaluation :: Text
|
||||
, runtimeAbi :: Text
|
||||
, runtimeCapabilities :: [Text]
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data BundleRoot = BundleRoot
|
||||
{ rootIndex :: Word32
|
||||
, rootRole :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data BundleExport = BundleExport
|
||||
{ exportName :: Text
|
||||
, exportRoot :: Word32
|
||||
, exportKind :: Text
|
||||
, exportAbi :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data BundleMetadata = BundleMetadata
|
||||
{ metadataPackage :: Maybe Text
|
||||
, metadataVersion :: Maybe Text
|
||||
, metadataDescription :: Maybe Text
|
||||
, metadataLicense :: Maybe Text
|
||||
, metadataCreatedBy :: Maybe Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
data BundleManifest = BundleManifest
|
||||
{ manifestSchema :: Text
|
||||
, manifestBundleType :: Text
|
||||
, manifestTree :: TreeSpec
|
||||
, manifestRuntime :: RuntimeSpec
|
||||
, manifestClosure :: ClosureMode
|
||||
, manifestRoots :: [BundleRoot]
|
||||
, manifestExports :: [BundleExport]
|
||||
, manifestMetadata :: BundleMetadata
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
data BundleNode
|
||||
= BNLeaf
|
||||
| BNStem !Word32
|
||||
| BNFork !Word32 !Word32
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Bundle = Bundle
|
||||
{ bundleVersion :: Word16
|
||||
, bundleRoots :: [Word32]
|
||||
, bundleNodes :: Seq BundleNode
|
||||
, bundleManifest :: BundleManifest
|
||||
, bundleManifestBytes :: ByteString
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle construction
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
data NodeKey = KeyLeaf | KeyStem !Word32 | KeyFork !Word32 !Word32
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
buildBundle :: [(Text, T)] -> Bundle
|
||||
buildBundle namedTerms =
|
||||
let go :: T -> (Seq BundleNode, Map NodeKey Word32) -> (Word32, (Seq BundleNode, Map NodeKey Word32))
|
||||
go Leaf (nodes, seen) =
|
||||
case Map.lookup KeyLeaf seen of
|
||||
Just idx -> (idx, (nodes, seen))
|
||||
Nothing ->
|
||||
let idx = fromIntegral (Seq.length nodes)
|
||||
in (idx, (nodes |> BNLeaf, Map.insert KeyLeaf idx seen))
|
||||
go (Stem child) (nodes, seen) =
|
||||
let (childIdx, state1) = go child (nodes, seen)
|
||||
(nodes1, seen1) = state1
|
||||
in case Map.lookup (KeyStem childIdx) seen1 of
|
||||
Just idx -> (idx, state1)
|
||||
Nothing ->
|
||||
let idx = fromIntegral (Seq.length nodes1)
|
||||
in (idx, (nodes1 |> BNStem childIdx, Map.insert (KeyStem childIdx) idx seen1))
|
||||
go (Fork left right) (nodes, seen) =
|
||||
let (leftIdx, state1) = go left (nodes, seen)
|
||||
(rightIdx, state2) = go right state1
|
||||
(nodes2, seen2) = state2
|
||||
in case Map.lookup (KeyFork leftIdx rightIdx) seen2 of
|
||||
Just idx -> (idx, state2)
|
||||
Nothing ->
|
||||
let idx = fromIntegral (Seq.length nodes2)
|
||||
in (idx, (nodes2 |> BNFork leftIdx rightIdx, Map.insert (KeyFork leftIdx rightIdx) idx seen2))
|
||||
|
||||
processExport state (_, t) = let (idx, newState) = go t state in (newState, idx)
|
||||
((finalNodes, _), rootIndices) = mapAccumL processExport (Seq.empty, Map.empty) namedTerms
|
||||
|
||||
roots = zipWith mkRoot [0 :: Int ..] rootIndices
|
||||
exports = zipWith mkExport namedTerms rootIndices
|
||||
manifest = makeManifest roots exports
|
||||
manifestBytes = encodeManifest manifest
|
||||
in Bundle
|
||||
{ bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion
|
||||
, bundleRoots = rootIndices
|
||||
, bundleNodes = finalNodes
|
||||
, bundleManifest = manifest
|
||||
, bundleManifestBytes = manifestBytes
|
||||
}
|
||||
where
|
||||
mkRoot 0 idx = BundleRoot idx "default"
|
||||
mkRoot _ idx = BundleRoot idx "root"
|
||||
mkExport (name, _) idx = BundleExport name idx "term" "arboricx.abi.tree.v1"
|
||||
|
||||
makeManifest :: [BundleRoot] -> [BundleExport] -> BundleManifest
|
||||
makeManifest roots exports = BundleManifest
|
||||
{ manifestSchema = "arboricx.bundle.manifest.v1"
|
||||
, manifestBundleType = "tree-calculus-executable-object"
|
||||
, manifestTree = TreeSpec
|
||||
{ treeCalculus = "tree-calculus.v1"
|
||||
, treeNodeHash = NodeHashSpec
|
||||
{ nodeHashAlgorithm = "indexed"
|
||||
, nodeHashDomain = "arboricx.indexed.node.v1"
|
||||
}
|
||||
, treeNodePayload = "arboricx.indexed.payload.v1"
|
||||
}
|
||||
, manifestRuntime = RuntimeSpec
|
||||
{ runtimeSemantics = "tree-calculus.v1"
|
||||
, runtimeEvaluation = "normal-order"
|
||||
, runtimeAbi = "arboricx.abi.tree.v1"
|
||||
, runtimeCapabilities = []
|
||||
}
|
||||
, manifestClosure = ClosureComplete
|
||||
, manifestRoots = roots
|
||||
, manifestExports = exports
|
||||
, manifestMetadata = BundleMetadata
|
||||
{ metadataPackage = Nothing
|
||||
, metadataVersion = Nothing
|
||||
, metadataDescription = Nothing
|
||||
, metadataLicense = Nothing
|
||||
, metadataCreatedBy = Just "arboricx"
|
||||
}
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle encoding / decoding
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
encodeBundle :: Bundle -> ByteString
|
||||
encodeBundle bundle =
|
||||
let nodeSection = encodeNodeSection (bundleNodes bundle)
|
||||
manifestBytes = 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)
|
||||
nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone
|
||||
nodesOffset (fromIntegral $ BS.length nodeSection)
|
||||
header = encodeHeader bundleMajorVersion bundleMinorVersion
|
||||
(fromIntegral sectionCount) 0 dirOffset
|
||||
in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection
|
||||
|
||||
decodeBundle :: ByteString -> Either String Bundle
|
||||
decodeBundle bs
|
||||
| BS.take (BS.length bundleMagic) bs /= bundleMagic = Left "invalid magic"
|
||||
| otherwise = 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
|
||||
when (treeNodePayload (manifestTree manifest) /= "arboricx.indexed.payload.v1") $
|
||||
Left "manifest does not use indexed payload"
|
||||
nodes <- decodeNodeSection nodesBytes
|
||||
let rootIndices = map rootIndex (manifestRoots manifest)
|
||||
return Bundle
|
||||
{ bundleVersion = major * 1000 + minor
|
||||
, bundleRoots = rootIndices
|
||||
, bundleNodes = nodes
|
||||
, bundleManifest = manifest
|
||||
, bundleManifestBytes = manifestBytes
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Container encoding / decoding
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
data SectionEntry = SectionEntry
|
||||
{ seType :: Word32
|
||||
, seVersion :: Word16
|
||||
, seFlags :: Word16
|
||||
, seCompression :: Word16
|
||||
, seOffset :: Word64
|
||||
, seLength :: Word64
|
||||
} 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
|
||||
encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes =
|
||||
encode32 sectionType
|
||||
<> encode16 sectionVersion
|
||||
<> encode16 sectionFlags
|
||||
<> encode16 compression
|
||||
<> encode16 0 -- reserved
|
||||
<> encode64 offset
|
||||
<> encode64 lengthBytes
|
||||
<> encode32 0 -- reserved padding
|
||||
|
||||
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
|
||||
(_reserved, r5) <- decode16be "reserved" r4
|
||||
(offset, r6) <- decode64be "section_offset" r5
|
||||
(len, r7) <- decode64be "section_length" r6
|
||||
(_reserved2, rest) <- decode32be "reserved" r7
|
||||
let entry = SectionEntry sectionType sectionVersion sectionFlags compression offset len
|
||||
go (n - 1) rest (entry : acc)
|
||||
|
||||
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)
|
||||
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)
|
||||
Right $ BS.take len $ BS.drop offset bs
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Node section encoding / decoding
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
serializeBundleNode :: BundleNode -> ByteString
|
||||
serializeBundleNode BNLeaf = BS.pack [0x00]
|
||||
serializeBundleNode (BNStem child) = BS.pack [0x01] <> encode32 child
|
||||
serializeBundleNode (BNFork left right) = BS.pack [0x02] <> encode32 left <> encode32 right
|
||||
|
||||
encodeNodeSection :: Seq BundleNode -> ByteString
|
||||
encodeNodeSection nodes =
|
||||
encode64 (fromIntegral $ Seq.length nodes)
|
||||
<> foldMap encodeNodeEntry nodes
|
||||
where
|
||||
encodeNodeEntry node =
|
||||
let payload = serializeBundleNode node
|
||||
in encode32 (fromIntegral $ BS.length payload) <> payload
|
||||
|
||||
decodeNodeSection :: ByteString -> Either String (Seq BundleNode)
|
||||
decodeNodeSection bs = do
|
||||
(nodeCount, rest) <- decode64be "node_count" bs
|
||||
decodeNodeEntries nodeCount rest
|
||||
|
||||
decodeNodeEntries :: Word64 -> ByteString -> Either String (Seq BundleNode)
|
||||
decodeNodeEntries count bs = go count bs Seq.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 < 4 =
|
||||
Left "not enough bytes for node entry length"
|
||||
| otherwise = do
|
||||
(plen, rest) <- decode32be "payload_len" bytes
|
||||
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
|
||||
node <- deserializeBundleNode payload
|
||||
go (n - 1) after (acc |> node)
|
||||
|
||||
deserializeBundleNode :: ByteString -> Either String BundleNode
|
||||
deserializeBundleNode payload =
|
||||
case BS.uncons payload of
|
||||
Just (0x00, rest)
|
||||
| BS.null rest -> Right BNLeaf
|
||||
| otherwise -> Left "invalid leaf payload length"
|
||||
Just (0x01, rest)
|
||||
| BS.length rest == 4 -> Right $ BNStem (decodeU32 rest)
|
||||
| otherwise -> Left "invalid stem payload length"
|
||||
Just (0x02, rest)
|
||||
| BS.length rest == 8 ->
|
||||
let (leftBytes, rightBytes) = BS.splitAt 4 rest
|
||||
in Right $ BNFork (decodeU32 leftBytes) (decodeU32 rightBytes)
|
||||
| otherwise -> Left "invalid fork payload length"
|
||||
_ -> Left "invalid node payload"
|
||||
|
||||
decodeU32 :: ByteString -> Word32
|
||||
decodeU32 bs =
|
||||
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
|
||||
in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle verification
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
verifyBundle :: Bundle -> Either String ()
|
||||
verifyBundle bundle
|
||||
| bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle)
|
||||
| Seq.null (bundleNodes bundle) = Left "bundle has no nodes"
|
||||
verifyBundle bundle = do
|
||||
verifyManifestConstraints (bundleManifest bundle)
|
||||
let nodeCount = fromIntegral $ Seq.length (bundleNodes bundle)
|
||||
traverse_ (\idx -> when (idx >= nodeCount) $ Left $ "root index out of bounds: " ++ show idx)
|
||||
(bundleRoots bundle)
|
||||
traverse_ (\exp -> when (exportRoot exp >= nodeCount) $ Left $ "export index out of bounds: " ++ show (exportRoot exp))
|
||||
(manifestExports $ bundleManifest bundle)
|
||||
|
||||
let verifyNode i node = case node of
|
||||
BNLeaf -> Right ()
|
||||
BNStem child -> do
|
||||
when (child >= i) $ Left $ "stem at index " ++ show i ++ " references child " ++ show child
|
||||
when (child >= nodeCount) $ Left $ "stem at index " ++ show i ++ " references child out of bounds"
|
||||
Right ()
|
||||
BNFork left right -> do
|
||||
when (left >= i) $ Left $ "fork at index " ++ show i ++ " references left " ++ show left
|
||||
when (right >= i) $ Left $ "fork at index " ++ show i ++ " references right " ++ show right
|
||||
when (left >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references left out of bounds"
|
||||
when (right >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references right out of bounds"
|
||||
Right ()
|
||||
|
||||
mapM_ (\i -> case Seq.lookup (fromIntegral i) (bundleNodes bundle) of
|
||||
Nothing -> Left $ "internal error: node " ++ show i ++ " not found"
|
||||
Just node -> verifyNode i node) [0 :: Word32 .. nodeCount - 1]
|
||||
|
||||
let dupCheck = foldM (\seen (i, node) -> case node of
|
||||
BNLeaf -> if Set.member (0 :: Word8, 0 :: Word32, 0 :: Word32) seen
|
||||
then Left $ "duplicate leaf at index " ++ show i
|
||||
else Right $ Set.insert (0, 0, 0) seen
|
||||
BNStem child -> if Set.member (1, child, 0) seen
|
||||
then Left $ "duplicate stem at index " ++ show i
|
||||
else Right $ Set.insert (1, child, 0) seen
|
||||
BNFork left right -> if Set.member (2, left, right) seen
|
||||
then Left $ "duplicate fork at index " ++ show i
|
||||
else Right $ Set.insert (2, left, right) seen) Set.empty (zip [0 :: Word32 ..] (Foldable.toList $ bundleNodes bundle))
|
||||
_ <- dupCheck
|
||||
Right ()
|
||||
|
||||
verifyManifestConstraints :: BundleManifest -> Either String ()
|
||||
verifyManifestConstraints 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 /= "indexed") $
|
||||
Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec)
|
||||
when (nodeHashDomain hashSpec /= "arboricx.indexed.node.v1") $
|
||||
Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
|
||||
when (treeNodePayload treeSpec /= "arboricx.indexed.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 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"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Import into content store
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
reconstructTerms :: Seq BundleNode -> Vector T
|
||||
reconstructTerms nodes = V.create $ do
|
||||
let n = Seq.length nodes
|
||||
vec <- MV.new n
|
||||
forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do
|
||||
t <- case node of
|
||||
BNLeaf -> return Leaf
|
||||
BNStem child -> Stem <$> MV.read vec (fromIntegral child)
|
||||
BNFork left right -> do
|
||||
l <- MV.read vec (fromIntegral left)
|
||||
r <- MV.read vec (fromIntegral right)
|
||||
return $ Fork l r
|
||||
MV.write vec i t
|
||||
return vec
|
||||
|
||||
importBundle :: Connection -> ByteString -> IO [Text]
|
||||
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
|
||||
let terms = reconstructTerms (bundleNodes bundle)
|
||||
forM_ (manifestExports $ bundleManifest bundle) $ \exp -> do
|
||||
let term = terms V.! fromIntegral (exportRoot exp)
|
||||
_ <- storeTerm conn [T.unpack $ exportName exp] term
|
||||
return ()
|
||||
return $ map exportName $ manifestExports $ bundleManifest bundle
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 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)
|
||||
|
||||
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
|
||||
in Right ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3, 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 b0 = fromIntegral (BS.index bs 0) :: Word64
|
||||
b1 = fromIntegral (BS.index bs 1) :: Word64
|
||||
b2 = fromIntegral (BS.index bs 2) :: Word64
|
||||
b3 = fromIntegral (BS.index bs 3) :: Word64
|
||||
b4 = fromIntegral (BS.index bs 4) :: Word64
|
||||
b5 = fromIntegral (BS.index bs 5) :: Word64
|
||||
b6 = fromIntegral (BS.index bs 6) :: Word64
|
||||
b7 = fromIntegral (BS.index bs 7) :: Word64
|
||||
in Right ((b0 `shiftL` 56) .|. (b1 `shiftL` 48) .|. (b2 `shiftL` 40) .|. (b3 `shiftL` 32)
|
||||
.|. (b4 `shiftL` 24) .|. (b5 `shiftL` 16) .|. (b6 `shiftL` 8) .|. b7, BS.drop 8 bs)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
defaultExportNames :: Int -> [Text]
|
||||
defaultExportNames n =
|
||||
case n of
|
||||
0 -> []
|
||||
1 -> ["root"]
|
||||
_ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]
|
||||
3015
test/Spec.hs
3015
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/greet-io.aboricx
vendored
Normal file
BIN
test/fixtures/greet-io.aboricx
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.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user