82 Commits
0.16.0 ... main

Author SHA1 Message Date
18da2923e0 Fix interaction tree demos and HTTP recv 4096 2026-09-08 15:51:28 -05:00
d54ad558a8 Runtime contract guard kernel 2026-09-02 13:08:54 -05:00
b822e7e713 Nat fixes 2026-09-01 12:54:26 -05:00
e595763f91 Attach contracts to definitions
Contracts now live directly on definitions via @ / =@ annotations and
travel automatically with exported values.

- Remove !export from lexer/parser/AST/evaluator/manifest/resolver and CLI.
- Simplify workspace module export logic: export all top-level local
  definitions by default.
- Update Frontend.ContractDesugar:
  - Named binder annotations (x@nat?) expand to per-argument withContract.
  - Phantom annotations (@nat?) expand to a local raw helper plus a wrapper,
    keeping fixed points shared and only depending on withContract.
- Merge lib/guardedBase.tri into lib/base.tri and annotate partial/sensitive
  base functions: head, tail, last, add, sub, mul, div, mod, pow, min,
  max, length, sum, product.
- Add check contract helper to lib/base.tri.
- Update demos/contractBasics.tri and README to reflect @/=@-only design.
- Update test suite: remove guardedBase import, replace explicit !export
  test with a test verifying that contract annotations on an exported
  definition are enforced on import.
- Fix remaining base.tri definitions (div/mod/pow) to stay point-free.
2026-09-01 12:08:40 -05:00
229ba34af4 Combine base,list,contracts 2026-09-01 08:50:18 -05:00
d9a69513d7 Begin removing view related code and docs 2026-09-01 07:53:29 -05:00
c6e4a43178 Back out the worst of the unsound nonsense 2026-07-10 18:26:38 -05:00
34aee3bf93 Explicit local bindings for let/where 2026-07-08 10:27:42 -05:00
c6c1ef1fe1 Some REPL niceties 2026-06-22 17:26:21 -05:00
a4fcc1cb36 Useful but limited polymorphism 2026-05-25 18:17:16 -05:00
fdebb6c13d Tricu 2.0.0
Sorry for squashing all of this but 🤷
2026-05-25 12:44:24 -05:00
2e2db07bd6 Ergonomic language features and lib cleanup
+ let bindings
+ where bindings
+ do notation

I explored enough of the alternative language design space and decided
that we should commit fully to Lambda style. That means no more highly
tacit/concatenative point-free/partial programs as default. We'll keep
taking advantage of those capabilities when it makes sense, but the
library will continue to see massive overhauls.
2026-05-23 18:28:02 -05:00
7cea3d1559 Fix HTTP body framing and eliminate request over-read 2026-05-21 17:09:43 -05:00
ac90d23b46 Packaging: Fully static Haskell builds and webapp 2026-05-21 15:25:26 -05:00
4bf2ce56dd Fully normalized top-level definitions 2026-05-21 13:35:53 -05:00
bf30d5945e (: Aiche Tee Tee Pee :)
Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell
IO runtime... but we're managing all of the actual webserver semantics in tricu!

This includes a demo Arboricx application server that is capable of storing
and serving bundles.
2026-05-21 09:05:12 -05:00
7ae3fc33f4 Prelude and demo import cleanup 2026-05-19 20:24:44 -05:00
1c17d4c94a A bit of library clean-up 2026-05-19 20:06:54 -05:00
e2a1744508 Helpful library updates 2026-05-19 19:50:38 -05:00
020fa769a9 Event loop! 2026-05-19 17:00:36 -05:00
2e13583de3 Strings for IO driver errors 2026-05-18 19:12:42 -05:00
593aa96193 Sane parser rewrite 2026-05-16 14:59:52 -05:00
e2d035286d Several subtle IODriver bug fixes 2026-05-16 09:33:14 -05:00
8d5e76db1c Interaction Trees in Zig and simple benchmarks 2026-05-15 21:41:19 -05:00
e3dcf5edd7 Update demos and adds <| 2026-05-13 19:44:46 -05:00
8f7684a1bb CPS IO -> Async Interaction Tree Effect Runtime
I'm deeply satisfied to be building an interaction tree runtime where
the interaction trees are themselves computed via and represented by
trees. It's trees all the way down.
2026-05-13 16:33:30 -05:00
983a0cc5a7 Explicit filesystem permissions required 2026-05-12 19:02:51 -05:00
d6df01105c feat(haskell): Interaction Tree IO
oops, now we have purely modelled IO 🤷
2026-05-12 18:47:38 -05:00
31bf7094f4 Arboricx bundle format 1.1
We don't need SHA verification or Merkle dags in our transport bundle. Content
stores can handle both bundle and term verification and hashing.
2026-05-12 15:18:29 -05:00
e0b1e95729 feat(haskell): CLI rewrite 2026-05-11 15:29:12 -05:00
ea748b2e5e feat(php): Simple web demo 2026-05-11 13:07:35 -05:00
d37d443021 feat(php): use new FFI for Arboricx 2026-05-11 09:18:47 -05:00
d7a7a8134c feat(zig): native Arboricx bundle parser and C ABI 2026-05-11 08:40:00 -05:00
8a673e282d Fixes space leak by switching to objects
The integer-arena approach (parallel global arrays) never freed nodes,
causing 6GB+ memory usage when running the self-hosted kernel. PHP
arrays don't shrink and we have no GC for them.

- Replace int-arena with plain Node objects so PHP's refcounting GC
  reclaims unreachable subtrees automatically.
- Hash-cons Stem/Fork nodes to collapse duplicate immutable subtrees.
- Cache ofNumber(0..255) to avoid re-creating byte trees.
- Eliminate indirection (tag 4) nodes entirely; projection rules now
  eagerly reduce and copy tag/a/b into the original App node.
- Remove all deref() loops — every node is exactly what it says.

Memory: 6GB+ → 24MB for `id "hello"` with runArboricxToString kernel
2026-05-10 16:56:00 -05:00
1885c9b4ba PHP host shell cleanup and docs 2026-05-10 14:52:24 -05:00
fa58f4ef3a Fix fuel implementation in PHP 2026-05-10 09:10:27 -05:00
e9eb2daaf2 Initial PHP host implementation 2026-05-09 20:22:58 -05:00
1f72a6969d Tiny README update 2026-05-09 18:36:39 -05:00
2e8a0a4c46 Host ABI definition and ergonomics in TC 2026-05-09 18:33:03 -05:00
d0886ad886 Small host execution ergos 2026-05-09 18:18:25 -05:00
2773109b87 Full Arboricx parsing in tricu 2026-05-09 17:43:45 -05:00
6dd4c3e607 Drop CBOR for simple custom manifest 2026-05-09 12:31:34 -05:00
343ecbf4c4 Arborix -> Arboricx rename 2026-05-08 09:12:20 -05:00
e3117e3ac8 Switch manifest serialization to CBOR
Replace JSON-based bundle manifest with a CBOR-encoded format. The manifest
is now a canonical CBOR map with order-strict key decoding, raw 32-byte hash
payloads (instead of hex-encoded JSON), and compact binary representation.
2026-05-07 21:41:50 -05:00
d9f25a2b5a Add Arborix bundle parsing and reconstruction
Implement portable Arborix container, section directory, nodes section, and
Merkle DAG reconstruction utilities in tricu libraries. Add byte/list helper
fixes needed for data-first recursion, validate node payloads, duplicate hashes,
and closed child references, and expose executable loading from a root hash.

Expand binary reader coverage with portable header/section tests, nodes-section
parsing, fixture bundle parsing, and execution checks for reconstructed
id/not?/map roots. Refresh fixture bundles and remove obsolete fixtures.
2026-05-07 14:21:24 -05:00
a002365651 Add Arborix section directory byte readers 2026-05-07 12:28:14 -05:00
1d84bf7cfa fix: freeVars, toSKIDB
freeVars did not descend into TStem, TFork, or SList, so dependency analysis
under structural nodes and lists was silently missed.

toSKIDB's _other = _K `SApp` TLeaf fallback returned a constant leaf when the
binder occurred under a structural node, losing the abstraction entirely.
Replace with explicit lowering: BStem/BFork/BList are converted to application
form before SKI abstraction, and any other unsupported DB term errors explicitly
2026-05-07 11:04:29 -05:00
e8ab61dbaa Data-first recursive consumers in readBytes
Reorder recursive byte-stream consumers so the consumed input is inspected
before loop-control arguments can drive evaluation. Previously, partially
applying `readBytes` to a known count, such as `readBytes 2`, allowed the
evaluator to specialize the recursive worker using known counter values
while the byte stream was still abstract. This caused symbolic recursion
over unknown input and produced an enormous normal form.

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

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

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

Also adds `tricu server` (aka `--serve`) CLI mode, move `resolveExportTarget` /
 `namesForHash` / `looksLikeHash` out of `Main.hs` into `ContentStore.hs`,
and cleans up unused exports and imports across `FileEval.hs` and `Wire.hs`.
2026-05-06 14:22:36 -05:00
0cd849447f Initial JS runtime and Arborix Implementation 2026-05-06 11:50:44 -05:00
fe453b9b96 Wire prepped and basics tested 2026-05-06 08:25:07 -05:00
fb09b4666e Seeded root leaf prep for wire 2026-05-05 19:16:16 -05:00
efbe9350ed Zero Warnings Plan
Zero GHC warnings with new opts. General cleanup and updates.
2026-05-05 18:32:11 -05:00
2627627493 Picking development back up
Merge Kiselyov optimizations and De Bruijn indices
General clean up
2026-05-05 15:56:23 -05:00
c008126b14 Merge branch 'contentstore' 2026-05-05 14:09:42 -05:00
6b97b210ca Full Merkle tree resolution 2026-05-05 14:08:50 -05:00
James Eversole
71653311ce Documentation updates 2026-05-05 10:03:15 -05:00
0cdc0bfc34 "size" function nodes down from 454 to 321 2025-08-07 20:08:59 -05:00
c36d963640 Update README to reflect completion of experiment 2025-05-29 13:39:44 -05:00
72e5810ca9 Update README to reflect completion of experiment 2025-05-29 13:31:21 -05:00
b96a3f2ef0 Fixes list and name lookup bugs 2025-05-26 17:56:07 -05:00
6780b242b1 Use exact name matches in nameToTerm 2025-05-26 09:04:03 -05:00
94514f7dd0 Update README and !help REPL command 2025-05-22 16:52:37 -05:00
43e83be9a4 Merge content store 2025-05-22 16:46:30 -05:00
3717942589 Clean up and list SKI conversion fix 2025-04-24 12:14:38 -05:00
b8e2743103 Updates to demos 2025-04-16 14:23:53 -05:00
25bfe139e8 String escaping using backslash 2025-04-15 10:52:53 -05:00
f2beb86d8a Drop backslash from lambda definitions 2025-04-15 10:34:38 -05:00
5024a2be4c Revert flake.nix 2025-02-08 10:24:14 -06:00
fccee3e61c Static linking part 2
Some checks failed
Test, Build, and Release / test (push) Failing after 3h6m55s
Test, Build, and Release / build (push) Has been cancelled
2025-02-07 19:22:31 -06:00
ad1918aa6f Statically link binaries
Some checks failed
Test, Build, and Release / test (push) Failing after 50s
Test, Build, and Release / build (push) Has been skipped
2025-02-07 18:32:09 -06:00
0a505172b4 Adds several new REPL utilities
Also removes some broken list library functions
2025-02-07 18:25:11 -06:00
e6e18239a7 Smarter decoding of terms
This update includes an update to `decodeResult` that makes string
decoding far less aggressive. This also replaces the `!decode` REPL
command with `!output` to allow users to switch output format on the
fly. New tests are included for verifying decoding behavior; this group
needs to be fleshed out further.
2025-02-07 15:06:25 -06:00
871245b567 Lint cleanup and README updates 2025-02-07 12:37:27 -06:00
30b9505d5f Clearer definition for apply 2025-02-06 08:32:17 -06:00
148 changed files with 25069 additions and 1252 deletions

View File

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

2
.gitignore vendored
View File

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

77
AGENTS.md Normal file
View File

@@ -0,0 +1,77 @@
# AGENTS.md - tricu Project Guide
> For AI agents and contributors working in this repository.
## Build & Test
```bash
# Tests
nix flake check
# Build tricu executable
nix build .#
```
### Never call `cabal` directly
> **Rule of thumb:** if it builds, links, or tests, it goes through `nix`.
### Write and test, don't mentally trace
`nix flake check` finishes quickly. Use it.
tricu's minimalism makes it easy to build a confident-sounding but wrong
mental model of evaluation order, branch selection (`matchBool` arg order),
or number encoding. A quick test replaces many minutes of uncertain reasoning.
Prefer:
1. Write a candidate implementation.
2. Run the tests or a probe.
3. Fix what's wrong.
Over:
1. Reason about semantics across multiple files.
2. Build up a chain of inference.
3. Write code that assumes the chain was correct.
## Project Overview
**tricu** (pronounced "tree-shoe") is a programming-language experiment written primarily in Haskell.
Core types are in `src/Research.hs`.
### 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)
### Haskell tests
Tests live in `test/Spec.hs` and use **Tasty** + **HUnit**.
```bash
nix flake check
```
## 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 `tricu` `.tri` files ***YOU MUST REVIEW notes/tricu-normalization-rules.md***

View File

@@ -2,39 +2,36 @@
## Introduction
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
*tricu is under active development and you should expect breaking changes with every commit.*
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 refer to this "family" of calculi as TC below.
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
## Features
In the `ext/` directory there are implementations of TC evaluators and tooling in other languages. Here be dragons; beware.
- Tree Calculus operator: `t`
- Assignments: `x = t t`
- Immutable definitions
- Lambda abstraction syntax: `id = (\a : a)`
- List, Number, and String literals: `[(2) ("Hello")]`
- Function application: `not (not false)`
- Higher order/first-class functions: `map (\a : append a "!") [("Hello")]`
- Intensionality blurs the distinction between functions and data (see REPL examples)
- Simple module system for code organization
While my original implementation was hand-written, I have since fully embraced the slopmachine 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. The `main` branch will see my latest thoughts and experiments. Emphasis on "AUTHOR DISCLAIMS ALL WARRANTIES" from the LICENSE.
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.
## REPL examples
```
tricu < -- Anything after `--` on a single line is a comment
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
tricu < head (map (\i : append i " world!") [("Hello, ")])
tricu < id = (a : a) -- Lambda abstraction is eliminated to tree calculus terms
tricu < head (map (i : append i " world!") [("Hello, ")])
tricu > "Hello, world!"
tricu < id (head (map (\i : append i " world!") [("Hello, ")]))
tricu < id (head (map (i : append i " world!") [("Hello, ")]))
tricu > "Hello, world!"
tricu < -- Intensionality! We can inspect the structure of a function or data.
tricu < triage = (\a b c : t (t a b) c)
tricu < test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
tricu < triage = (a b c : t (t a b) c)
tricu < test = triage "Leaf" (z : "Stem") (a b : "Fork")
tricu < test (t t)
tricu > "Stem"
tricu < -- We can even convert a term back to source code (/demos/toSource.tri)
tricu < toSource not?
tricu > "(t (t (t t) (t t t)) (t t (t t t)))"
@@ -45,9 +42,7 @@ tricu > 12
## Installation and Use
[Releases are available for Linux.](https://git.eversole.co/James/tricu/releases)
Or you can easily build and run this project using [Nix](https://nixos.org/download/).
You can easily build and run this project using [Nix](https://nixos.org/download/).
- Quick Start (REPL):
- `nix run git+https://git.eversole.co/James/tricu`
@@ -56,36 +51,39 @@ Or you can easily build and run this project using [Nix](https://nixos.org/downl
`./result/bin/tricu --help`
```
tricu Evaluator and REPL
## Usage
tricu [COMMAND] ... [OPTIONS]
tricu: Exploring Tree Calculus
### CLI
Common flags:
-? --help Display help message
-V --version Print version information
Evaluate one or more files:
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.
```sh
tricu eval program.tri
tricu eval --format decode program.tri
tricu eval --output result.txt program.tri
```
## Acknowledgements
Compile/import/export Arboricx bundles:
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
```sh
tricu arboricx compile --file program.tri --output program.arboricx
tricu arboricx import --file program.arboricx --module program
tricu arboricx export --module prelude --output prelude.arboricx
```
[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus.
### REPL
Running `tricu` with no subcommand starts the REPL. The REPL uses the same
filesystem content store and workspace module loader as the CLI.
Useful commands:
```text
!load FILE load/evaluate a .tri file without printing a result
!store [PATH] show or set the content-addressed store
!format decode set output format by name
!env list current in-memory bindings
```
`!load` supports filename tab completion. Normal REPL input also supports tab
completion for names currently in the REPL environment.

240
bench/ApplyStats.hs Normal file
View 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

64
bench/Bench.hs Normal file
View File

@@ -0,0 +1,64 @@
{-# LANGUAGE BangPatterns #-}
module Main where
import Criterion.Main
import qualified Data.Map as Map
import Eval
import FileEval
import Parser
import Research
-- | Build an environment from a library file.
loadLib :: FilePath -> IO Env
loadLib = evaluateFile
main :: IO ()
main = do
!baseLib <- loadLib "lib/base.tri"
!listLib <- loadLib "lib/list.tri"
!contractsLib <- loadLib "lib/contracts.tri"
!intLib <- loadLib "lib/intensionalContracts.tri"
!guardedLib <- loadLib "lib/guardedBase.tri"
let !env = Map.unions [baseLib, listLib, contractsLib, intLib, guardedLib]
defaultMain
[ bgroup "contracts"
[ bench "raw head" $ whnf
(result . evalTricu env . parseTricu)
"head [1 2 3 4 5]"
, bench "safeHead (checked)" $ whnf
(result . evalTricu env . parseTricu)
"safeHead [1 2 3 4 5]"
, bench "raw div" $ whnf
(result . evalTricu env . parseTricu)
"div 10 2"
, bench "safeDiv (checked)" $ whnf
(result . evalTricu env . parseTricu)
"safeDiv 10 2"
, bench "safeDiv failure (div by zero)" $ whnf
(result . evalTricu env . parseTricu)
"safeDiv 10 0"
, bench "sortedMax on sorted list" $ whnf
(result . evalTricu env . parseTricu)
"sortedMax [1 2 3 4 5]"
, bench "safeHalf (even check)" $ whnf
(result . evalTricu env . parseTricu)
"safeHalf 8"
, bench "sortedList? success" $ whnf
(result . evalTricu env . parseTricu)
"withContract (sortedList? nat?) [1 2 3 4 5] (xs : sum xs) (msg : 0)"
, bench "sortedList? failure" $ whnf
(result . evalTricu env . parseTricu)
"withContract (sortedList? nat?) [5 1 3] (xs : sum xs) (msg : 0)"
, bench "listOf nat? success" $ whnf
(result . evalTricu env . parseTricu)
"withContract (listOf nat?) [1 2 3 4 5] (xs : sum xs) (msg : 0)"
, bench "fn2 apply add" $ whnf
(result . evalTricu env . parseTricu)
"(fn2 nat? nat? nat? add) 3 5"
, bench "fnContract apply identity" $ whnf
(result . evalTricu env . parseTricu)
"(fnContract nat? nat? (x : x)) 7"
]
]

25
demos/contractBasics.tri Normal file
View File

@@ -0,0 +1,25 @@
!import "prelude" !Local
-- Custom contract combinators built directly on matchResult.
myAndC = (c1 c2 value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : c2 v rest)
(c1 value rest))
-- Plain predicates lifted into contracts with a diagnostic message.
natural? = guardC "natural" isNat?
nonZero? = guardC "non-zero" (n : and? (isNat? n) (not? (isZero_? n)))
-- Phantom annotations let point-free definitions carry their own contracts.
-- The base library now uses the same syntax, so head/tail/div etc. are
-- guarded by default.
myHead @(nonEmptyListOf anyC) =@anyC head
myTail @(listOf anyC) =@(listOf anyC) tail
myDiv @natural? @(myAndC natural? nonZero?) =@natural? div
-- The `check` helper applies a contract to any value and returns the
-- checked value (or the diagnostic message on failure).
checkedSuccessor = check natural? (add 1 2)
main = pair checkedSuccessor (myDiv 10 2)

64
demos/contractEffects.tri Normal file
View File

@@ -0,0 +1,64 @@
!import "prelude" !Local
-- ---------------------------------------------------------------------------
-- Contracts + interaction trees with `do` notation
--
-- The `do` keyword takes a monadic bind operator. Here we use `bindM` from
-- `lib/contracts.tri` to sequence pure, contract-checked computations.
--
-- checkM contract value -- lift a contract failure into the tree
-- exceptE tag value k -- a resumable failure carrying a continuation
-- handleM tag handler tree -- rewrite matching exceptions
-- runM tree -- interpret the tree into a Result
--
-- A handler receives the exception value and the resumption continuation `k`.
-- It may resume by calling `k value`, or it may replace the failing action with
-- a new tree of its own.
-- ---------------------------------------------------------------------------
positive? = guardC "expected positive integer" (n : gte? n 1)
nonEmpty? = guardC "expected non-empty list" (xs : not? (emptyList? xs))
-- Average a list. Fails with a contract exception if the list is empty.
average = (xs :
do bindM
_ <- checkM nonEmpty? xs
n <- pureM (length xs)
_ <- checkM positive? n
total <- pureM (sum xs)
pureM (div total n))
-- A resumable config lookup. When the key is missing, callers can supply a
-- value by handling the "missing" exception.
lookupConfig = (key defaultValue :
exceptE "missing" key (resume : pureM defaultValue))
-- A pipeline that averages a list and divides by a configured divisor.
pipeline = (xs :
do bindM
divisor <- lookupConfig "divisor" 1
avg <- average xs
scaled <- liftM (x : div x divisor) avg
pureM scaled)
-- Without a handler the missing-key exception reaches runM.
unhandled = runM (pipeline [10 20 30])
-- < unhandled
-- > [t, "divisor"]
-- With a handler we replace the missing divisor with 2, so 20 / 2 = 10.
withHandler = runM (handleM "missing" (key k : pureM 2) (pipeline [10 20 30]))
-- < withHandler
-- > [t t, 10]
-- Handler can also use the original default by calling the resumption.
withResume = runM (handleM "missing" (key k : k 2) (pipeline [10 20 30]))
-- < withResume
-- > [t t, 20]
-- Contract failures still propagate through handlers for other tags.
bothFail = runM (handleM "missing" (key k : pureM 2) (pipeline []))
-- < bothFail
-- > [t, "expected non-empty list"]
main = withHandler

View File

@@ -1,5 +1,4 @@
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
!import "prelude" !Local
main = lambdaEqualsTC
@@ -11,20 +10,17 @@ demo_true = t t
not_TC? = t (t (t t) (t t t)) (t t (t t t))
-- /demos/toSource.tri contains an explanation of `triage`
demo_triage = \a b c : t (t a b) c
demo_matchBool = (\ot of : demo_triage
of
(\_ : ot)
(\_ _ : ot)
)
demo_triage = a b c : t (t a b) c
demo_matchBool = a b : demo_triage b (_ : a) (_ _ : a)
-- Lambda representation of the Boolean `not` function
not_Lambda? = demo_matchBool demo_false demo_true
-- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many
-- As tricu eliminates Lambda terms to SKI combinators, the tree form of many
-- functions defined via Lambda terms are larger than the most efficient TC
-- representation. Between different languages that evaluate to tree calculus
-- terms, the exact implementation of Lambda elimination may differ and lead
-- to different tree representations even if they share extensional behavior.
-- representation possible. Between different languages that evaluate to tree
-- calculus terms, the exact implementation of Lambda elimination may differ
-- and lead to different trees even if they share extensional behavior.
-- Let's see if these are the same:
lambdaEqualsTC = equal? not_TC? not_Lambda?

View File

@@ -0,0 +1,57 @@
!import "prelude" !Local
!import "io" !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

View File

@@ -0,0 +1,22 @@
!import "prelude" !Local
!import "io" !Local
!import "arboricx.server" !Local
-- Arboricx HTTP registry server demo.
-- Run with --allow-write ./store --allow-read ./store
--
-- Endpoints:
-- GET /_arboricx/health -> "OK"
-- POST /_arboricx/bundle -> 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)))

View File

@@ -0,0 +1,28 @@
!import "prelude" !Local
!import "io" !Local
!import "socket" !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))))))

View File

@@ -0,0 +1,19 @@
!import "prelude" !Local
!import "io" !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))

View File

@@ -0,0 +1,17 @@
!import "prelude" !Local
!import "io" !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))))))))

View File

@@ -0,0 +1,26 @@
-- 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 "prelude" !Local
!import "io" !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")))))))

View File

@@ -0,0 +1,9 @@
!import "prelude" !Local
!import "io" !Local
-- Greet and return a pure value.
-- putStrLn writes to stdout; pure lifts "done" into IO.
main = io <|
bind (putStrLn (append "Hello, " "tricu"))
(_ : pure "")

View File

@@ -0,0 +1,16 @@
!import "prelude" !Local
!import "io" !Local
!import "socket" !Local
!import "http" !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)))))

View File

@@ -0,0 +1,15 @@
!import "prelude" !Local
!import "io" !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")

View File

@@ -0,0 +1,22 @@
!import "prelude" !Local
!import "io" !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))

View File

@@ -0,0 +1,21 @@
!import "prelude" !Local
!import "io" !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)))))))))

View File

@@ -0,0 +1,19 @@
!import "prelude" !Local
!import "io" !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))

View File

@@ -0,0 +1,32 @@
!import "prelude" !Local
!import "io" !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))))))))

View File

@@ -1,5 +1,4 @@
!import "../lib/base.tri" Lib
!import "../lib/list.tri" !Local
!import "prelude" !Local
main = exampleTwo
-- Level Order Traversal of a labelled binary tree
@@ -18,47 +17,47 @@ main = exampleTwo
-- / / \
-- 4 5 6
label = \node : head node
label = node : head node
left = (\node : if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
left = node : (if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
(head (tail node))))
right = (\node : if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
(if (emptyList? (tail (tail node)))
[]
right = node : (if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
(if (emptyList? (tail (tail node)))
[]
(head (tail (tail node))))))
processLevel = y (\self queue : if (emptyList? queue)
[]
(pair (map label queue) (self (filter
(\node : not? (emptyList? node))
processLevel = y (self queue : if (emptyList? queue)
[]
(pair (map label queue) (self (filter
(node : not? (emptyList? node))
(append (map left queue) (map right queue))))))
levelOrderTraversal_ = \a : processLevel (t a t)
levelOrderTraversal_ = a : processLevel (t a t)
toLineString = y (\self levels : if (emptyList? levels)
""
(append
(append (map (\x : append x " ") (head levels)) "")
toLineString = y (self levels : if (emptyList? levels)
""
(append
(append (map (x : append x " ") (head levels)) "")
(if (emptyList? (tail levels)) "" (append (t (t 10 t) t) (self (tail levels))))))
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
levelOrderToString = s : toLineString (levelOrderTraversal_ s)
flatten = foldl (\acc x : append acc x) ""
flatten = foldl (acc x : append acc x) ""
levelOrderTraversal = \s : append (t 10 t) (flatten (levelOrderToString s))
levelOrderTraversal = s : append (t 10 t) (flatten (levelOrderToString s))
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]
[("3") [("5") t t] [("6") t t]]]
exampleTwo = levelOrderTraversal [("1")
[("2") [("4") [("8") t t] [("9") t t]]
[("6") [("10") t t] [("12") t t]]]
exampleTwo = levelOrderTraversal [("1")
[("2") [("4") [("8") t t] [("9") t t]]
[("6") [("10") t t] [("12") t t]]]
[("3") [("5") [("11") t t] t] [("7") t t]]]

37
demos/patternMatching.tri Normal file
View File

@@ -0,0 +1,37 @@
!import "patterns" !Local
-- We can do conditional pattern matching by providing a list of lists, where
-- each sublist contains a boolean expression and a function to return if said
-- boolean expression evaluates to true.
value = 42
main = match value [[(equal? "Hello") (_ : ", world!")] [(equal? 42) (_ : "The answer.")]]
-- < main
-- > "The answer."
matchExample = (x : match x
[[(equal? 1) (_ : "one")]
[(equal? 2) (_ : "two")]
[(equal? 3) (_ : "three")]
[(equal? 4) (_ : "four")]
[(equal? 5) (_ : "five")]
[(equal? 6) (_ : "six")]
[(equal? 7) (_ : "seven")]
[(equal? 8) (_ : "eight")]
[(equal? 9) (_ : "nine")]
[(equal? 10) (_ : "ten")]
[ otherwise (_ : "I ran out of fingers!")]])
-- < matchExample 3
-- > "three"
-- < matchExample 5
-- > "five"
-- < matchExample 9
-- > "nine"
-- < matchExample 11
-- > "I ran out of fingers!"
-- < matchExample "three"
-- > "I ran out of fingers!"
-- < matchExample [("hello") ("world")]
-- > "I ran out of fingers!"

View File

@@ -0,0 +1,25 @@
!import "prelude" !Local
!import "io" !Local
!import "arboricx" !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")

View File

@@ -1,13 +1,10 @@
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
!import "prelude" !Local
main = size size
size = (\x :
(y (\self x :
compose succ
(triage
(\x : x)
self
(\x y : compose (self x) (self y))
x)) x 0))
size = x : y (self x : compose succ (triage
id
self
(x y : compose (self x) (self y))
x)
) x 0

View File

@@ -1,5 +1,4 @@
!import "../lib/base.tri" !Local
!import "../lib/list.tri" !Local
!import "prelude" !Local
main = toSource not?
-- Thanks to intensionality, we can inspect the structure of a given value
@@ -18,25 +17,25 @@ main = toSource not?
sourceLeaf = t (head "t")
-- Stem case
sourceStem = (\convert : (\a rest :
sourceStem = convert : (a rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the argument.
(t (head ")") rest)))))) -- Close with ")" and append the rest.
(t (head ")") rest))))) -- Close with ")" and append the rest.
-- Fork case
sourceFork = (\convert : (\a b rest :
sourceFork = convert : (a b rest :
t (head "(") -- Start with a left parenthesis "(".
(t (head "t") -- Add a "t"
(t (head " ") -- Add a space.
(convert a -- Recursively convert the first arg.
(t (head " ") -- Add another space.
(convert b -- Recursively convert the second arg.
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
(t (head ")") rest))))))) -- Close with ")" and append the rest.
-- Wrapper around triage
toSource_ = y (\self arg :
toSource_ = y (self arg :
triage
sourceLeaf -- `triage` "a" case, Leaf
(sourceStem self) -- `triage` "b" case, Stem
@@ -44,7 +43,7 @@ toSource_ = y (\self arg :
arg) -- The term to be inspected
-- toSource takes a single TC term and returns a String
toSource = \v : toSource_ v ""
toSource = v : toSource_ v ""
exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

View 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`.

View File

@@ -0,0 +1,549 @@
# Content Store and Module Format Design
Status: concrete design draft.
This document narrows the higher-level module-system direction into concrete
format and storage decisions. It intentionally avoids source/provenance details:
modules export usable portable artifacts, not edit history.
Related design overview: `docs/module-system-design.md`.
## 1. Scope
This document specifies the first target shape for:
- a neutral filesystem-backed content-addressed store;
- Arboricx Merkle node persistence;
- indexed Arboricx bundle import/export as transport;
- module manifests as immutable export maps;
- workspace aliases as mutable human-facing references;
- Contract artifact attachment to module exports.
It does not specify:
- package manager semantics;
- dependency solving;
- source-level rebuild/provenance metadata;
- final import syntax;
- garbage collection;
- registry/sync protocol.
## 2. Non-Negotiable Boundaries
The content store is not `tricu`-specific and is not Haskell-specific.
The store may contain objects produced by `tricu`, Haskell, Tree Calculus tools,
Arboricx tooling, or future frontends. The store core only knows object bytes,
object kinds, hashes, aliases, and optionally structural references for known
portable formats.
Contracts may be first-class artifact references because they are portable
Tree Calculus data checked by pure Tree Calculus code. They are not
Haskell-private semantics.
Source and build provenance are intentionally excluded from the first module
manifest format. A module manifest answers:
```text
What portable artifacts does this module export, and what portable contracts are
paired with them?
```
It does not answer:
```text
Which source file, parser, frontend, or build command produced these artifacts?
```
## 3. Hashing Convention
Objects are content-addressed by SHA-256 over domain-separated canonical bytes.
General rule:
```text
hash = SHA256(domainUtf8 || 0x00 || canonicalPayloadBytes)
```
This matches the existing Merkle node convention in `Research.nodeHash`:
```text
SHA256("arboricx.merkle.node.v1" || 0x00 || nodePayload)
```
The domain string is part of the object format. It prevents identical payload
bytes in different formats from accidentally sharing identity.
Hashes are represented externally as 64 lowercase hexadecimal characters.
## 4. Filesystem Store Layout
The canonical filesystem store layout is:
```text
store/
objects/
abc/
abc123... -- object bytes, sharded by first 3 hex chars
aliases/
names/
modules/
packages/
manifests/
tmp/
```
The three-character shard follows the existing `lib/arboricx/server.tri`
convention.
### 4.1 Object paths
For object hash:
```text
abc123...
```
object bytes live at:
```text
store/objects/abc/abc123...
```
The object filename is the full hash. The shard directory is the first three hex
characters.
### 4.2 Atomic writes
Writers should use:
```text
store/tmp/<hash>.<nonce>.tmp
```
then atomically rename into:
```text
store/objects/<shard>/<hash>
```
Writing an existing object is idempotent if the existing bytes match the hash.
### 4.3 Store core metadata
The minimal filesystem store does not require sidecar metadata for every object.
Object kind can be known by context or by manifest references.
A later index may cache:
```text
hash -> kind
hash -> size
hash -> references
hash -> createdAt
```
but this index is not semantic identity.
## 5. Arboricx Merkle Node Object Format
The persistent Tree Calculus representation is a Merkle DAG of node objects.
Domain:
```text
arboricx.merkle.node.v1
```
Canonical payloads:
```text
Leaf = 0x00
Stem child = 0x01 || childHashRaw32
Fork left right
= 0x02 || leftHashRaw32 || rightHashRaw32
```
Where `childHashRaw32`, `leftHashRaw32`, and `rightHashRaw32` are the raw 32-byte
SHA-256 digests corresponding to child node hashes.
This is already implemented conceptually by:
```text
Research.Node
Research.serializeNode
Research.deserializeNode
Research.nodeHash
```
The filesystem CAS should use this payload/hash convention directly.
## 6. Tree Roots
A Tree Calculus value stored in the CAS is identified by the hash of its root
Merkle node.
```text
treeRootHash = hash(rootNodePayload)
```
The complete tree is reconstructed by recursively loading node objects reachable
from the root.
Hydration is an interpretation step, not part of object identity. A client may
hydrate a root as a plain tree, a graph with explicit sharing, or another runtime
representation as long as the observable Tree Calculus value is the same. The
filesystem CAS provides structural dedupe and portable identity; it does not by
itself guarantee that a hydrated runtime value is the cheapest representation for
all workloads.
Merkle nodes are useful for explicit DAG-oriented tooling, audit, and bundle
packing. They are not the default representation for module executable exports:
storing every subtree as a separate filesystem object is pathologically slow for
large normal forms.
For module-backed evaluation and imports, a complete normalized named term is
stored as one canonical object:
```text
kind: arboricx.tree-term.v1
hash: <whole-term object hash>
abi: arboricx.abi.tree.v1
```
The `arboricx.tree-term.v1` payload is a prefix encoding:
```text
Leaf = 0x00
Stem t = 0x01 Tree
Fork l r = 0x02 Tree Tree
```
## 7. Arboricx Indexed Bundles
Indexed `.arboricx` bundles remain the transport/execution format.
They are:
- compact;
- self-contained;
- deterministic;
- suitable for restricted runtimes;
- suitable for HTTP serving and deployment.
They are not the canonical long-lived deduplicated store representation.
### 7.1 Pack
Packing converts one or more CAS tree roots into an indexed bundle:
```text
CAS tree roots -> indexed Arboricx bundle
```
The packer traverses reachable Merkle nodes, emits a compact indexed node table,
and writes a bundle manifest with export names and root indices.
### 7.3 Unpack
Unpacking converts a bundle into CAS nodes:
```text
indexed Arboricx bundle -> CAS tree roots
```
The unpacker verifies the bundle structure, reconstructs each exported tree, and
stores the corresponding Merkle nodes. It returns the tree root hash for each
bundle export.
## 8. Module Manifest v1
A module is an immutable manifest object. The module identity is the hash of its
canonical manifest bytes.
A module name is not identity. It is a workspace alias to a module manifest hash.
### 8.1 Domain
Proposed domain:
```text
arboricx.module-manifest.v1
```
### 8.2 Purpose
A module manifest pairs human-facing export names with portable content objects
and optional portable contracts.
It exists to support:
- reproducible import resolution;
- executable export discovery;
- Contract lookup for imported symbols;
- module-to-module reference tracking;
- transport/store interop.
It does not describe source provenance.
### 8.3 Conceptual shape
```text
moduleManifestV1:
imports:
- alias: <text>
kind: <object kind>
hash: <object hash>
exports:
- name: <text>
object:
kind: <object kind>
hash: <object hash>
abi: <abi identifier>
contract: optional
kind: arboricx.tree-term.v1
hash: <contract term hash>
metadata: optional human-facing fields
```
### 8.4 Imports/references
The `imports` section is a manifest reference graph, not a store-level language
dependency graph.
Each entry records direct content-addressed references used by the module:
```text
alias: Prelude
kind: arboricx.module-manifest.v1
hash: <module hash>
```
This supports reproducibility, partial fetch, and audit. The content store core
stores this object but does not need to understand `Prelude` or import
semantics.
### 8.5 Exports
Each export is a record, not a single hash. This is required so executable
objects and advertised contracts cannot drift apart.
Minimal executable export:
```text
name: "id"
object:
kind: arboricx.tree-term.v1
hash: <whole-term hash>
abi: arboricx.abi.tree.v1
```
Export with Contract:
```text
name: "map"
object:
kind: arboricx.tree-term.v1
hash: <whole-term hash>
abi: arboricx.abi.tree.v1
contract:
kind: arboricx.tree-term.v1
hash: <contract term hash>
```
The manifest preserves the pairing between exported executable and exported
contract. For workspace modules built from local source, annotated exports are
checked before the manifest is published; only exports that pass producer-side
checking receive direct contract term refs.
### 8.6 Metadata
Metadata is optional and human-facing. Initial fields may include:
```text
package
version
description
license
createdBy
```
Metadata is not source provenance and is not required for execution or checking.
## 9. Contract Artifacts
Contracts are ordinary `tricu` functions `Tree -> Result Tree Tree`. They are
stored and referenced as ordinary `arboricx.tree-term.v1` objects. There is no
separate contract object kind.
A contract object is a complete Tree Calculus term. Any implementation that can
evaluate Tree Calculus terms can apply it. The contract standard defines only the
result convention and the boundary helpers; it does not define a binary contract
grammar.
### 9.1 Export-level pairing
The module manifest pairs each export with an optional contract object:
```text
name: "map"
object:
kind: arboricx.tree-term.v1
hash: <whole-term hash>
abi: arboricx.abi.tree.v1
contract:
kind: arboricx.tree-term.v1
hash: <contract term hash>
```
This prevents the executable and its advertised contract from drifting apart.
### 9.2 Import checking
When a source file imports a contracted export, the frontend loads the contract
object and applies it at the boundary using the standard contract helpers. For
example:
```text
imported List.map has contract <tree-term hash>
```
For locally built workspace modules, advertised export contracts may be checked
before the manifest is published. For external or prebuilt manifests, the
advertised contract is a trusted boundary declaration; the consumer may insert
guard wrappers as needed.
The contract term itself is the authority. There is no separate checker binary
format and no typed-program evidence graph.
### 9.3 Execution hydration versus contract checking
Execution imports use a narrow path:
```text
module import -> selected executable exports -> hydrate selected tree-term objects
```
Contract-aware imports use a slightly broader path:
```text
module import -> selected exports -> exported contract term refs -> apply at boundary
```
Because contract objects are ordinary tree terms, they can be reused, composed,
and stored with the same tools as any other value.
## 10. Workspace Aliases
A workspace is mutable human-facing state over immutable content.
Examples:
```text
List -> module manifest hash
Prelude -> module manifest hash
map -> tree-term hash
httpServer -> bundle hash
```
Aliases should live under:
```text
store/aliases/
```
Initial categories:
```text
store/aliases/modules/<name>
store/aliases/names/<name>
store/aliases/packages/<name>
```
Alias file contents should be simple and explicit, for example:
```text
kind: arboricx.module-manifest.v1
hash: abc123...
```
Exact encoding can be decided with the first implementation. The important rule
is that aliases are mutable pointers, not content identity.
## 11. Existing Convention Alignment
This design intentionally preserves existing conventions where they already fit:
- SHA-256 domain-separated Merkle node hashing;
- `Leaf` / `Stem` / `Fork` node payload tags `0x00`, `0x01`, `0x02`;
- three-character object sharding from `lib/arboricx/server.tri`;
- indexed Arboricx bundles as compact transport objects;
- optional human-facing export names in manifests;
- Contract terms as portable Tree Calculus data.
It replaces or demotes conventions that do not fit:
- SQLite `terms.names` comma-separated aliases become workspace aliases/indexes;
- SQLite `terms.tags` comma-separated tags become optional metadata/indexes;
- file imports as AST flattening become transitional behavior;
- names cease to be semantic identity.
## 12. Implementation Sketch
A staged implementation can proceed as follows:
1. Add filesystem CAS helpers alongside the existing SQLite store.
2. Store/load Arboricx Merkle nodes using the filesystem layout.
3. Implement tree-term storage and reconstruction from filesystem CAS.
4. Implement pack from CAS tree terms/Merkle roots to indexed Arboricx bundle.
5. Implement unpack from indexed Arboricx bundle to CAS tree terms/Merkle roots.
6. Define a concrete module manifest encoding.
7. Store/load module manifests as content-addressed objects.
8. Add workspace alias read/write helpers.
9. Teach import resolution to target module manifests/exports.
10. Attach exported contract terms to module exports.
11. Gradually migrate existing `!import` users.
## 13. Deferred Decisions
These are intentionally left out of the first concrete format:
- package version solving;
- registry/remotes protocol;
- garbage collection/reachability;
- source/provenance/build-record objects;
- editor/update workflows;
- rich visibility/export rules;
- final import syntax;
- whether module manifests also need a tree-native encoding.
## 14. Summary
The concrete v1 direction is:
```text
Store:
filesystem-backed content-addressed objects
Hashing:
SHA256(domain || 0x00 || canonical payload)
Tree persistence:
Arboricx Merkle nodes
Transport:
indexed .arboricx bundles, packable from and unpackable to CAS roots
Modules:
immutable manifests pairing export names with object refs and optional
contract term refs
Workspace:
mutable aliases from human names to immutable content hashes
```
This keeps the store portable, preserves Arboricx's compact transport role,
restores Merkle DAGs as the persistence model, and gives contracts a stable
module/export attachment point without making the store `tricu`-specific.

326
docs/contracts.md Normal file
View File

@@ -0,0 +1,326 @@
# Contracts
Contracts are the portable runtime boundary-checking layer for `tricu`. A
contract is an ordinary `tricu` function that inspects a value and returns a
standard `Result`.
Contracts are not a type system. Tree Calculus is intensional: every value is a
tree and can be inspected by any function. A contract can only observe a value
and fail when it does not satisfy the advertised predicate. It cannot hide a
value's representation or prove that an opaque function behaves correctly for
all inputs.
Static typing for Tree Calculus is an area of active research. This document
describes the dynamic-contract layer that exists today and the guarantees it
can honestly claim.
## 1. The contract type
A contract is a function:
```tri
contract : Tree -> Tree -> Result Tree Tree
```
The second argument is the conventional `rest` slot. It takes a value and a rest
and returns one of the standard `Result` shapes from `lib/base.tri`:
```tri
ok value rest = pair true (pair value rest)
err msg rest = pair false (pair msg rest)
```
In contract contexts the `rest` slot is conventionally `t`. Two helpers make
this explicit:
```tri
contractOk = (value : (rest : ok value rest))
contractErr = (msg : (rest : err msg rest))
```
- On success, a contract returns the checked value. This may be the original
value or a transformed/normalized value.
- On failure, it returns a reason. The reason is an arbitrary tree, often a
string or a structured diagnostic.
Because a contract is just a tree-valued function, any Tree Calculus
implementation can apply it. No special contract object format is required.
## 2. Core boundary wrappers
### 2.1 Explicit check
`checkContract` applies a contract with the conventional `t` rest slot and
returns the raw `Result`:
```tri
checkContract = (contract value : contract value t)
```
This is the most flexible form. The caller decides what to do with failure.
### 2.2 Direct boundary abort
`withContract` applies a contract with the conventional `t` rest slot and
continues on success, or calls a failure continuation on failure:
```tri
withContract = (contract value onOk onFail :
matchResult
(msg _ : onFail msg)
(checked _ : onOk checked)
(contract value t))
```
The failure continuation is supplied by the host or by the surrounding program.
It may abort, log, return a default, or raise an effect. The core contract
standard does not prescribe the failure behavior.
### 2.3 Example: a simple contract
```tri
isZero? = n :
equal? n 0
nat? = guardC "not a natural number" (n : gte? n 0)
-- explicit check
result = checkContract nat? 5
-- boundary abort
five = withContract nat? 5 (x : x) (msg : 0)
```
Real contract predicates are usually more interesting than `isZero?`; this
illustrates only the shape.
## 3. Contract combinators
Contracts compose using ordinary `tricu` functions. A few common patterns:
```tri
andC = (c1 c2 value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : c2 v rest)
(c1 value rest))
mapC = (f c value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : contractOk (f v) rest)
(c value rest))
listOf = (c xs rest : ...) -- checks spine and element contract
pairOf = (c1 c2 p rest : ...)
```
These are library code, not core standard. A contract library can provide
`listOf`, `pairOf`, `fnContract`, and similar helpers.
## 4. Higher-order contracts
A contract for a function value returns a wrapped proxy. The proxy itself is a
contract: it checks arguments on the way in and results on the way out.
```tri
fnContract = (argC resC f rest :
contractOk
(x : (rest1 :
withContract argC x
(x' :
withContract resC (f x')
(y : contractOk y rest1)
(msg : contractErr msg rest1))
(msg : contractErr msg rest1)))
rest)
```
This does not prove that `f` is well-behaved internally; it only catches
violations at observed calls.
## 5. Interaction-tree contract effects
The core contract layer returns `Result`. For code that wants catchable,
composable contract failures without threading `Result` through every function,
contracts can be lifted into an interaction tree.
### 5.1 Interaction-tree constructors
These reuse the same `pure`/`bind` tags already used for `tricu` IO:
```tri
pureE value = pair 0 value
bindE action k = pair 1 (pair action k)
exceptE tag value k = pair 2 (pair tag (pair value k))
```
`exceptE` is resumable: `k` is the continuation. A handler may resume with
`k replacement` or abort by ignoring `k`. Contract failures usually abort; the
resumable shape is provided for generality and for richer effect handlers.
### 5.2 Lifting a contract
```tri
checkM contract value =
matchResult
(msg _ : exceptE "contract" msg (\_ : pureE t))
(checked _ : pureE checked)
(contract value t)
```
`pureM` and `bindM` are aliases for `pureE` and `bindE`:
```tri
pureM = pureE
bindM = bindE
```
### 5.3 Lifting pure functions
```tri
liftM f = (x : pureE (f x))
```
### 5.4 Example
```tri
halfM n =
bindM (checkM even? n)
(\n' : pureM (div n' 2))
use =
handleM "contract"
(\msg k : pureM 0)
(halfM 5)
```
`handleM` is a pure tree-to-tree function that interprets `exceptE` nodes,
either resuming with a replacement value or returning a failure tree.
### 5.5 Running a pure interaction tree
```tri
runM tree =
-- interprets pureE, bindE, and exceptE nodes
-- returns a Result or a residual effect tree
...
```
If the tree contains no IO or other host effects, `runM` can be written
entirely in `tricu`.
## 6. Source syntax
Source annotations are frontend sugar for inserting contract boundaries. They do
not change the runtime semantics of ordinary code; they tell the frontend where
to emit contract checks.
### 6.1 Argument and result assertions
```tri
idNat x@Nat =@Nat x
```
`x@Nat` inserts a `Nat` contract check on the argument. `=@Nat` inserts a check
on the result.
### 6.2 Compound contracts
```tri
sum xs@(List Nat) =@Nat ...
useHandler f@(Fn [(NonEmptyList String)] String) =@String ...
```
Compound annotations must be parenthesized when they contain application.
### 6.3 Phantom arguments
```tri
map @A @B =@(Fn [(Fn [A] B) (List A)] (List B)) ...
```
A phantom argument contributes a contract to the function boundary without
introducing a term binder.
### 6.4 Missing annotations
Unannotated binders in a contract-bearing head default to `Any`. A missing
return annotation defaults to `Any`.
```tri
foo x y@Bool = body -- foo : Fn [Any Bool] Any, y : Bool
```
### 6.5 Export contracts
A module export may advertise a contract:
```tri
!export factorial : Fn [Nat] Nat
```
The advertised contract travels with the export in the module manifest.
## 7. Module and content-store integration
Contracts attach to module exports as ordinary content-addressed tree terms.
There is no special contract object kind. The manifest references the contract
with the same object kind as any other tree term:
```text
name: "factorial"
object:
kind: arboricx.tree-term.v1
hash: <tree-term hash>
contract:
kind: arboricx.tree-term.v1
hash: <contract term hash>
```
The earlier `arboricx.view-contract.type.v1` object kind is removed. A
contract is just a tree term.
For locally built modules, advertised export contracts may be checked before the
manifest is published. For imported modules, the advertised contract is a
boundary assumption. The local checker may insert guard wrappers when a
contracted import is used.
See `docs/module-system-design.md` and
`docs/content-store-and-module-format.md` for the full store, manifest, and
bundle conventions.
## 8. Guarantees
The contract layer honestly claims only:
1. A contract applied to a value returns a standard `Result` shape.
2. `withContract` and `checkM` invoke the contract at the represented boundary.
3. A failed contract invokes the supplied failure continuation or `exceptE`
node.
4. Content-addressed references prevent an attached contract from silently
drifting to a different stored object.
5. Provenance labels record where a contract assertion came from.
Only the contract function itself observes the runtime value. The rest is
metadata plumbing.
## 9. Limitations
- Contracts do not establish parametricity or representation independence.
- They do not prove that opaque recursive or primitive code satisfies its
contract for every input.
- They do not remove the need for tests, careful API design, or future static
analysis.
- Higher-order contract wrapping has the usual costs and proxy-like behavior
of dynamic contract systems.
## 10. Summary
- A contract is an ordinary `tricu` function: `Tree -> Result Tree Tree`.
- `withContract` aborts at a boundary; `checkContract` returns the raw
`Result`.
- The interaction-tree layer (`checkM`, `bindM`, `handleM`) adds catchable,
composable failures on top of the same core contracts.
- Contracts attach to module exports as ordinary tree-term objects.
- Provenance labels record source and blame, but do not prove truth.

247
docs/host-abi.md Normal file
View 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.

View File

@@ -0,0 +1,500 @@
# Module System and Content Store Design
Status: design draft.
This document records the intended direction for reworking `tricu` modules,
imports, Arboricx storage/transport, and the content store. It is not an
implementation plan yet; it is a shared design target.
## 1. Problem Statement
The current module/import/content-store system is useful as a prototype, but it
is not coherent enough to build on indefinitely.
Current behavior combines several partially-overlapping systems:
- `!import "path.tri" Namespace` and `!import "path.tri" !Local` perform
filesystem-relative source preprocessing;
- imported definitions are flattened into one program;
- namespace qualification is implemented by string rewriting;
- evaluation uses a flat `Map String T` environment;
- the Haskell content store stores Tree Calculus Merkle nodes plus an ad hoc
`terms` table with comma-separated names and tags;
- the REPL can resolve names from the content store, including multiple versions;
- Arboricx bundles provide compact indexed transport objects;
- `lib/arboricx/server.tri` already sketches a filesystem-backed object store.
This works only when users and maintainers are mindful of sharp edges:
- names serve too many roles at once;
- modules are not first-class semantic objects;
- imports are closer to AST paste-and-prefix than resolution;
- `!Local` imports can create global collisions;
- content identity, human aliases, source files, and evaluated terms are not
cleanly separated;
- the SQLite schema is convenient but not a principled content-addressed store;
- Arboricx transport and long-lived storage are not clearly distinguished.
## 2. Design Principles
### 2.1 Content addressability is foundational
Immutable content should be identified by hashes. Human names should be metadata
or workspace aliases over content, not semantic identity.
This follows the core lesson from systems such as Unison: separate stable
content identity from ergonomic naming and namespace organization.
### 2.2 The content store is language-neutral
The content store must not be married to `tricu` or Haskell.
It stores a small set of portable Arboricx artifacts: module manifests,
complete tree terms, and direct Contract terms. Lower-level Merkle/bundle
formats exist for transport and DAG tooling, but the store core should treat all
objects as content-addressed bytes with formats/media types.
`tricu` and Haskell are clients/tooling. They are not the semantic owners of the
store.
### 2.3 Contracts are portable enough to integrate
The store may integrate with Contracts because a contract is itself an ordinary
Tree Calculus term. Contracts are not a Haskell-private or `tricu`-private
semantic layer.
A module manifest may reference a contract object, but the contract is evaluated
by ordinary Tree Calculus reduction, not by a special checker.
### 2.4 Modules should reflect definitions as they actually exist
The module system should conform to the reality of content-addressed immutable
artifacts and mutable human aliases. We should not contort definitions to fit a
traditional text-file module system if that fights the storage model.
### 2.5 Transport and storage are different jobs
Indexed Arboricx bundles are excellent transport/execution objects. Merkle DAGs
are better long-lived persistence objects. These should remain separate but
interoperable representations.
## 3. Conceptual Architecture
```text
Content Store
neutral content-addressed object store
Arboricx CAS / Merkle Store
Tree Calculus node/object formats suitable for persistence and dedupe
Arboricx Bundle
compact indexed transport/execution format
Contract Term
ordinary tree-valued contract function, applied by reduction
Module Manifest
immutable export map from names to content objects and optional contract terms
Workspace
mutable aliases, selected versions, package pins, and user-facing names
tricu
one frontend/toolchain that emits/consumes these portable artifacts
```
The content store stores objects. Arboricx defines important object formats.
Contracts are ordinary tree-valued functions; `tricu` produces and consumes those
formats.
### 3.1 Execution imports versus contract checking
Import resolution has two intentionally different performance profiles.
For normal execution/evaluation, resolving a module import should hydrate only
the executable exports directly demanded by the importing source. Exported Tree
Calculus values are complete normal forms: importing `foo` does not require
hydrating separate `bar` or `baz` exports that may have helped build it. This is
the fast path for `!import`, including `!Local` imports.
Contract checking is a runtime boundary check. It may load exported contract term
objects for the symbols that participate in a boundary. That slower path remains
separate from execution hydration:
```text
Haskell loads contract terms.
tricu applies them by reduction.
```
Reusable contract catalogs are ordinary `tricu` libraries/tree terms, not a separate
core CAS artifact kind.
For locally built workspace modules, advertised direct export contracts may be
checked before the manifest alias is written. Producer checking includes
advertised contracts from any imported modules used by that source, so a module
cannot publish a local annotated export that contradicts a dependency's exported
contract. If producer checking fails, the module alias is not written.
Consumer checking then resolves selected module exports and loads their exported
contract term objects. Those contracts are applied at the import boundary using
the standard contract helpers. For external or prebuilt manifests, the advertised
contract is a trusted boundary declaration; the consumer may still re-apply it at
the boundary.
## 4. Content Store Direction
### 4.1 Store core
The store core should be a content-addressed object store:
```text
hash -> object bytes
hash -> object kind / media type
hash -> optional metadata/index entries
```
The hash should be over canonical bytes with domain separation. The object kind
or media type determines how a client interprets those bytes.
Current module/check object kinds:
```text
arboricx.module-manifest.v1
arboricx.tree-term.v1
arboricx.tree-term.v1
```
Merkle nodes and indexed bundles remain lower-level Arboricx transport/DAG
formats, but they are not the module/eval storage model. typed programs and contract
catalogs are ordinary tree terms unless a future external tooling use case proves
that they need their own object kind.
The store core should not need to know what a `tricu` definition means.
### 4.2 Filesystem-backed layout
The long-term store should converge with the direction already sketched in
`lib/arboricx/server.tri`:
```text
store/
objects/
abc/
abc123...object
aliases/
names/
modules/
packages/
manifests/
tmp/
```
SQLite may remain useful as an optional index/cache, but it should not be the
canonical store model.
### 4.3 Structural references, not language dependencies
The store may understand structural content references when they are part of an
object format. For example, a Merkle node naturally references child hashes:
```text
Leaf
Stem childHash
Fork leftHash rightHash
```
This is not a `tricu` dependency graph. It is content structure.
Language/tool-level relationships such as "compiled from source", "exported by
module", or "checked with contract" can live in manifests or indexes. They
should not be required by the store core.
## 5. Arboricx Role
Arboricx should be understood as a family of portable Tree Calculus artifact
formats, not as a single storage mechanism.
### 5.1 Arboricx Bundle
The existing indexed `.arboricx` format remains the preferred transport and
execution object:
- compact;
- self-contained;
- deterministic;
- easy to parse in constrained runtimes;
- suitable for deployment and HTTP serving;
- structurally verifiable without hash recomputation per node.
It says:
```text
Here is everything you need, densely packed.
```
### 5.2 Arboricx CAS / Merkle Store
The persistent store should use content-addressed structural objects:
```text
Leaf
Stem childHash
Fork leftHash rightHash
```
This enables dedupe across definitions, modules, packages, and versions. A large
program that shares subtrees with other programs should not store those subtrees
multiple times.
It says:
```text
Here are immutable objects, addressable independently.
```
### 5.3 Pack and unpack
Transport and storage should interoperate explicitly:
```text
CAS root(s) -> pack -> indexed Arboricx bundle
Arboricx bundle -> unpack -> CAS root(s)
```
The bundle can be treated as an opaque content-addressed blob by the store, and
it can also be unpacked into Merkle nodes for dedupe and partial reuse.
## 6. Modules
### 6.1 Module identity
A module should be an immutable manifest object. Its identity is the hash of its
canonical manifest bytes.
A module name is not identity. It is a workspace alias or package-level alias to
a module hash.
### 6.2 Module contents
A module manifest should primarily be an export map:
```text
module hash
exports:
name -> content reference
metadata:
package
version
description
license
createdBy
optional:
contract artifact refs
ABI/media type info
source/provenance refs
```
The manifest should be portable and mostly format-oriented. It should not depend
on Haskell data structures or `tricu`-specific internal semantics.
### 6.3 Export entries
An export entry may eventually look conceptually like:
```text
name: "map"
object: sha256:...
kind: arboricx.tree-term.v1
abi: arboricx.abi.tree.v1
contract: sha256:... -- optional contract term
source: sha256:... -- optional source/provenance object
```
Executable module exports are complete normalized tree terms stored as one
`arboricx.tree-term.v1` object per named export. Merkle-node storage remains
available for DAG-oriented tooling, but module/eval imports should not store or
hydrate every subtree as a separate filesystem object.
### 6.4 Import behavior
Imports should resolve module aliases or content references to module manifests,
then bind selected exports into the local source scope.
Export selection has one intentional aggregator special case:
```text
module with local top-level definitions -> exports only those local definitions
module with only imports -> reexports the evaluated import env
```
This lets files such as `prelude.tri` act as explicit barrel modules without
making every ordinary module reexport its imports. A module that defines even one
local top-level name does not implicitly reexport imported names.
The future pipeline should be:
```text
parse source
resolve imports/names to module exports and content refs
lower source using resolved refs
emit a contract artifact
check evidence when requested
store/export artifacts
```
It should not be:
```text
paste imported ASTs into one file and rewrite strings
```
## 7. Workspace Layer
Mutable human-facing state belongs in a workspace layer.
Examples:
```text
List -> module hash
Http -> module hash
map -> definition/tree hash
selected List version -> module hash
package pin prelude -> package/module hash
```
The workspace is where names, selections, pins, and aliases live. Renaming should
usually mutate workspace aliases, not immutable content objects.
This gives humans stable ergonomic names without making names semantic identity.
## 8. Definition Identity
There are two useful identities and we should support both.
### 8.1 Tree identity
A Tree Calculus value has a Merkle root hash. This identifies the executable tree
itself.
This is the right identity for:
- execution;
- dedupe;
- bundle roots;
- low-level artifact sharing.
### 8.2 Module/export identity
The module manifest is the higher-level artifact boundary. It pairs each export
name with its compiled tree term and an optional contract term reference.
The content store should not require extra definition/source/provenance objects,
and fully untyped Tree Calculus code must remain valid.
## 9. Contract Integration
Contracts attach to modules/exports as ordinary tree-term objects. A contract is
a `tricu` function `Tree -> Result Tree Tree`; it is not a special artifact
kind and it does not require a separate checker binary.
A module manifest pairs each export name with its compiled tree term and an
optional contract term reference. The importer loads the contract object and
applies it at the boundary.
An imported definition can be assigned a local name while lowering source. Its
global identity remains a content hash or module export ref. The intended split
is:
```text
Local source name: "List.map"
Resolved object: sha256:...
Exported contract: sha256:...
```
There is no typed-program evidence graph and no local numeric checker symbols.
The contract term itself is the authority.
Untyped code remains valid with no contract artifact. If a boundary has no
contract information, it simply performs no runtime check. We should not pretend
that untyped functions have an implicit `Any -> Any -> ...` contract.
## 10. Import Syntax Direction
Exact syntax is future work, but the current `!import` form should be considered
a transitional mechanism.
Future imports should distinguish:
- path-based source imports for local development;
- workspace/module alias imports;
- explicit content-addressed imports;
- selected/exposed names;
- qualified versus unqualified binding.
Possible directions:
```tri
import "./list.tri" as List
import List exposing (map foldl)
import #abc123... as List
```
The syntax should be designed after the object/module model is clearer.
## 11. Migration Strategy
A plausible migration path:
1. Define the neutral object store model and filesystem layout.
2. Implement Merkle node persistence against that layout.
3. Add pack/unpack between CAS roots and indexed Arboricx bundles.
4. Replace ad hoc SQLite `terms` names/tags with workspace aliases or a clearer
index layer.
5. Define module manifest objects.
6. Teach source imports to resolve manifests/exports instead of rewriting ASTs.
7. Attach contract terms to module exports.
8. Gradually migrate existing `lib/` and `demos/` imports.
Compatibility shims may keep existing `!import` working during migration.
## 12. Open Questions
- What exact canonical byte format should store objects use?
- Should module manifests be binary, tree-encoded, or both?
- What media type/kind registry do we need first?
- How should object references be represented in source syntax?
- How should workspaces be stored and shared?
- What is the minimum useful module manifest?
- Should source files compile directly to module manifests, or should manifests
be produced by explicit package commands?
- How much Arboricx bundle metadata should reference CAS roots?
- What GC/reachability model should the store eventually use?
## 13. Summary
The desired design is:
```text
Content store:
portable CAS for immutable objects and structural references
Arboricx bundle:
compact indexed transport/execution object
Arboricx CAS:
persistent Merkle DAG/object representation for dedupe and partial reuse
Modules:
immutable manifests mapping export names to content objects and optional
contracts
Workspace:
mutable human aliases, version selections, and package/module pins
Contracts:
ordinary tree-valued functions attached to exports and applied by pure Tree
Calculus reduction at boundaries
```
The key architectural rule is that hashes provide stable identity, while names
provide human usability. The module system should be built on that separation.

View 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
View File

@@ -0,0 +1 @@
node_modules

29
ext/js/package-lock.json generated Normal file
View 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
View 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
View 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
View 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)';
}

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

View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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",
},
}

View 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 */

File diff suppressed because it is too large Load Diff

1
ext/zig/result Symbolic link
View File

@@ -0,0 +1 @@
/nix/store/2sg31y0vamz5bz19aakxagi702glwh24-tricu-zig-0.1.0

36
ext/zig/src/arena.zig Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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(")");
},
}
}

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

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

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

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

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

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

View 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
View File

@@ -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": {

294
flake.nix
View File

@@ -9,27 +9,252 @@
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;
staticPkgs = pkgs.pkgsStatic;
staticHaskellPackages = staticPkgs.haskellPackages;
staticHsLib = staticPkgs.haskell.lib;
tricuMuslStatic =
staticHsLib.justStaticExecutables (
staticHsLib.dontCheck (
staticHaskellPackages.callCabal2nix packageName self {}
)
);
tricuStatic = pkgs.runCommand "${packageName}-static-upx" {
nativeBuildInputs = [ pkgs.upx ];
} ''
mkdir -p $out/bin
cp ${tricuMuslStatic}/bin/tricu $out/bin/tricu
chmod +w $out/bin/tricu
# Good compression, slower build.
upx --best --lzma $out/bin/tricu
chmod 755 $out/bin/tricu
'';
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-static = tricuMuslStatic;
packages.tricu-static-upx = tricuStatic;
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 +263,49 @@
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";
tag = "latest";
copyToRoot = pkgs.buildEnv {
name = "image-root";
paths = [ tricuStatic ];
pathsToLink = [ "/bin" ];
};
config = {
Cmd = [ "/bin/tricu" ];
WorkingDir = "/app";
};
};
packages.arboricxServer = pkgs.dockerTools.buildImage {
name = "arboricxServer";
tag = "latest";
copyToRoot = pkgs.runCommand "arboricxServer" {} ''
mkdir -p $out/app/bin $out/app/lib $out/app/tricu-apps $out/app/store
cp ${tricuStatic}/bin/tricu $out/app/bin/
cp -r ${./lib}/* $out/app/lib/
cp ${./tricu-apps/arboricxServer.tri} $out/app/tricu-apps/arboricxServer.tri
'';
config = {
Entrypoint = [ "/app/bin/tricu" "eval" "tricu-apps/arboricxServer.tri" "--io" "--allow-read" "./store" "--allow-write" "./store" "-f" "decode" ];
WorkingDir = "/app";
ExposedPorts = { "8080/tcp" = {}; };
};
};
});
}

158
lib/arboricx/arboricx.tri Normal file
View File

@@ -0,0 +1,158 @@
!import "prelude" !Local
!import "arboricx.common" !Local
!import "arboricx.manifest" !Local
!import "arboricx.nodes" !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)

431
lib/arboricx/common.tri Normal file
View File

@@ -0,0 +1,431 @@
!import "prelude" !Local
!import "binary" !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))

View File

@@ -0,0 +1,7 @@
!import "prelude" !Local
!import "arboricx" !Local
-- Multi-purpose kernel dispatch.
-- runArboricxTyped tag bundleBytes args
runArboricxTyped = (tag bs args :
runArboricxByNameToTyped tag [] bs args)

346
lib/arboricx/manifest.tri Normal file
View File

@@ -0,0 +1,346 @@
!import "prelude" !Local
!import "binary" !Local
!import "arboricx.common" !Local
!import "arboricx.nodes" !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)))))))))))))))

374
lib/arboricx/nodes.tri Normal file
View File

@@ -0,0 +1,374 @@
!import "prelude" !Local
!import "binary" !Local
!import "arboricx.common" !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)))
nodeU32FromBytes4 = (b0 b1 b2 b3 :
u32BEBytesToNat
(pair b0
(pair b1
(pair b2
(pair b3 t)))))
withNodePayloadStemIndex = (nodePayload shortK indexK :
matchList
(shortK t)
(tag r0 :
matchList
(shortK t)
(b0 r1 :
matchList
(shortK t)
(b1 r2 :
matchList
(shortK t)
(b2 r3 :
matchList
(shortK t)
(b3 _ :
indexK (nodeU32FromBytes4 b0 b1 b2 b3))
r3) r2) r1) r0) nodePayload)
withNodePayloadForkIndices = (nodePayload shortK indicesK :
matchList
(shortK t)
(tag r0 :
matchList
(shortK t)
(l0 r1 :
matchList
(shortK t)
(l1 r2 :
matchList
(shortK t)
(l2 r3 :
matchList
(shortK t)
(l3 r4 :
matchList
(shortK t)
(r0b r5 :
matchList
(shortK t)
(r1b r6 :
matchList
(shortK t)
(r2b r7 :
matchList
(shortK t)
(r3b _ :
indicesK
(nodeU32FromBytes4 l0 l1 l2 l3)
(nodeU32FromBytes4 r0b r1b r2b r3b)) r7) r6) r5) r4) r3) r2) r1) r0) nodePayload)
nodePayloadStemChildIndex = (nodePayload :
withNodePayloadStemIndex nodePayload (_ : 0) (index : index))
nodePayloadForkLeftIndex = (nodePayload :
withNodePayloadForkIndices nodePayload (_ : 0) (left right : left))
nodePayloadForkRightIndex = (nodePayload :
withNodePayloadForkIndices nodePayload (_ : 0) (left right : right))
nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
matchList
false
(nodePayload rest :
or?
(not? (nodePayloadValid? nodePayload))
(self rest))
nodeRecords)
nodePayloadChildIndices = (nodePayload :
matchList
t
(tag rest :
lazyBool
(_ :
withNodePayloadStemIndex
nodePayload
(_ : t)
(childIndex : pair childIndex t))
(_ :
lazyBool
(_ :
withNodePayloadForkIndices
nodePayload
(_ : t)
(leftIndex rightIndex :
pair leftIndex (pair rightIndex t)))
(_ : t)
(equal? tag nodePayloadForkTag))
(equal? tag nodePayloadStemTag))
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 records n i limit :
matchList
false
(_ rest :
matchBool
false
(matchBool
true
(self rest n (succ i) limit)
(equal? i n))
(equal? i limit))
records)
nodeChildIndicesInPrefix? = y (self childIndices records limit :
matchList
true
(childIndex rest :
matchBool
(self rest records limit)
false
(nodeIndexInPrefix? records childIndex 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)
nodeBuiltTreeIndex = (entry :
matchPair
(index _ : index)
entry)
nodeBuiltTreeValue = (entry :
matchPair
(_ tree : tree)
entry)
nodeTreeByIndex_ = (self builtTrees targetIndex :
lazyList
(_ : err errMissingNode t)
(entry rest :
lazyBool
(_ : ok (nodeBuiltTreeValue entry) t)
(_ : self rest targetIndex)
(equal? (nodeBuiltTreeIndex entry) targetIndex))
builtTrees)
nodeTreeByIndex = (builtTrees targetIndex :
y nodeTreeByIndex_ builtTrees targetIndex)
nodePayloadToTreeFromBuilt = (builtTrees nodePayload :
matchList
(err errInvalidNodePayload t)
(tag rest :
lazyBool
(_ : ok t t)
(_ :
lazyBool
(_ :
withNodePayloadStemIndex
nodePayload
(_ : err errInvalidNodePayload t)
(childIndex :
lazyResult
(code after : err code after)
(child _ : ok (t child) t)
(nodeTreeByIndex builtTrees childIndex)))
(_ :
lazyBool
(_ :
withNodePayloadForkIndices
nodePayload
(_ : err errInvalidNodePayload t)
(leftIndex rightIndex :
lazyResult
(code after : err code after)
(left _ :
lazyResult
(code after : err code after)
(right _ : ok (pair left right) t)
(nodeTreeByIndex builtTrees rightIndex))
(nodeTreeByIndex builtTrees leftIndex)))
(_ : err errInvalidNodePayload t)
(equal? tag nodePayloadForkTag))
(equal? tag nodePayloadStemTag))
(equal? tag 0))
nodePayload)
nodeBuildState = (targetIndex i builtTrees :
pair targetIndex (pair i builtTrees))
nodeBuildStateTargetIndex = (state :
matchPair
(targetIndex _ : targetIndex)
state)
nodeBuildStateI = (state :
matchPair
(_ rest :
matchPair
(i _ : i)
rest)
state)
nodeBuildStateBuiltTrees = (state :
matchPair
(_ rest :
matchPair
(_ builtTrees : builtTrees)
rest)
state)
nodeIndexToTree_ = (self remainingRecords state :
((nodeIndex :
((i :
((builtTrees :
lazyList
(_ : err errMissingNode t)
(nodePayload rest :
lazyResult
(code after : err code after)
(tree _ :
lazyBool
(_ : ok tree t)
(_ :
self
rest
(nodeBuildState
nodeIndex
(succ i)
(pair (pair i tree) builtTrees)))
(equal? i nodeIndex))
(nodePayloadToTreeFromBuilt builtTrees nodePayload))
remainingRecords)
(nodeBuildStateBuiltTrees state)))
(nodeBuildStateI state)))
(nodeBuildStateTargetIndex state)))
nodeIndexToTree = (nodeRecords nodeIndex :
y nodeIndexToTree_ nodeRecords (nodeBuildState nodeIndex 0 t))
readArboricxTreeFromIndex = (rootIndexBytes bs :
bindResult (readArboricxNodesSection bs)
(nodesSection afterContainer :
bindResult (nodeIndexToTree (nodesSectionRecords nodesSection) (u32BEBytesToNat rootIndexBytes))
(tree _ : ok tree afterContainer)))
readArboricxExecutableFromIndex = readArboricxTreeFromIndex

206
lib/arboricx/server.tri Normal file
View File

@@ -0,0 +1,206 @@
!import "prelude" !Local
!import "io" !Local
!import "http" !Local
!import "socket" !Local
!import "patterns" !Local
!import "arboricx" !Local
-- ---------------------------------------------------------------------------
-- Store layout helpers
-- ---------------------------------------------------------------------------
pathJoin a b = append a (append "/" b)
objectDir root shard =
pathJoin (pathJoin root "objects") shard
hashShard hash =
matchList
t
(h0 r0 :
matchList
(pair h0 t)
(h1 r1 :
matchList
(pair h0 (pair h1 t))
(h2 _ :
pair h0 (pair h1 (pair h2 t)))
r1)
r0)
hash
bundleObjectPath root hash =
pathJoin
(objectDir root (hashShard hash))
(append hash ".arboricx")
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 =
do onOk_
_ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard))
_ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes)
_ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath)
pure (ok hash t)
putBundleWithHash root bundleBytes time hash =
let shard = hashShard hash in
let tmpPath = bundleTmpPath root hash time in
let finalPath = bundleObjectPath root hash in
putBundleWrite root bundleBytes hash shard tmpPath finalPath
putBundle root bundleBytes =
do onOk_
time <- mapErrIO "currentTime: " currentTime
hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes)
savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash)
pure (ok savedHash t)
-- ---------------------------------------------------------------------------
-- Bundle object fetch
-- ---------------------------------------------------------------------------
getBundleByHash root hash =
onResult_ (readFile (bundleObjectPath root hash))
(errMsg : pure (err errMsg t))
(bytes : pure (ok bytes t))
-- ---------------------------------------------------------------------------
-- Route prefix helper
-- ---------------------------------------------------------------------------
stripPrefix_ self input prefix =
lazyList
(_ :
lazyList
(_ : just t)
(_ _ : nothing)
prefix)
(ih ir :
lazyList
(_ : just input)
(ph pr :
lazyBool
(_ : self ir pr)
(_ : nothing)
(equal? ih ph))
prefix)
input
stripPrefix prefix input =
y stripPrefix_ input prefix
bundleHashPrefix = "/_arboricx/bundle/hash/"
bundlePath = "/_arboricx/bundle"
healthPath = "/_arboricx/health"
bundleContentType = "application/vnd.arboricx.bundle"
-- ---------------------------------------------------------------------------
-- Landing page
-- ---------------------------------------------------------------------------
-- TODO: Let's replace in-line HTML with the ability to read and serve files
-- from a public/ folder.
htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='width=device-width, initial-scale=1'><title>Arboricx Server</title></head><body><h1>Arboricx Server</h1><p>Bundle registry</p><p><a href='https://git.eversole.co/James/tricu'>Made with Love (and trees, lots of trees)</a></p></body></html>"
-- ---------------------------------------------------------------------------
-- Registry routes
-- ---------------------------------------------------------------------------
bundleResponse bytes = response 200 bundleContentType bytes
serveBundleHash root hash =
onResult_ (getBundleByHash root hash)
(errMsg : pure (errorResponse 404 errMsg))
(bytes : pure (bundleResponse bytes))
healthRoute method target =
cond
[(guard (_ : equal? method "GET") (_ : getHealth))
(guard (_ : true) (_ : pure notFoundResponse))]
where getHealth =
cond
[(guard (_ : equal? target healthPath) (_ : pure (okResponse "OK\n")))
(guard (_ : true) (_ : pure notFoundResponse))]
putBundleRoute root method target body =
cond
[(guard (_ : equal? method "POST") (_ : postBundle))
(guard (_ : true) (_ : pure notFoundResponse))]
where postBundle =
cond
[(guard (_ : equal? target bundlePath) (_ : handleUpload))
(guard (_ : true) (_ : pure notFoundResponse))]
where handleUpload =
onResult_ (putBundle root body)
(err : pure (badRequestResponse (append "Upload failed: " err)))
(hash : pure (createdResponse hash))
getBundleRoute root method target =
cond
[(guard (_ : equal? method "GET") (_ : getBundle))
(guard (_ : true) (_ : pure notFoundResponse))]
where getBundle =
lazyMaybe
(_ : pure notFoundResponse)
(hash : serveBundleHash root hash)
(stripPrefix bundleHashPrefix target)
arboricxRouter root method target headers body =
cond
[(guard (_ : equal? method "GET") (_ : getRoutes))
(guard (_ : equal? method "POST") (_ : putBundleRoute root method target body))
(guard (_ : true) (_ : pure notFoundResponse))]
where getRoutes =
cond
[(guard (_ : equal? target "/") (_ : pure (htmlResponse htmlLandingPage)))
(guard (_ : true) (_ : getBundleOrHealth))]
where getBundleOrHealth =
lazyMaybe
(_ : healthRoute method target)
(hash : serveBundleHash root hash)
(stripPrefix bundleHashPrefix target)
-- ---------------------------------------------------------------------------
-- Server entrypoint
-- ---------------------------------------------------------------------------
arboricxHandler root = (client peer :
httpHandlerIO
(method target headers body :
arboricxRouter root method target headers body)
client
peer)
arboricxServer root addr port =
onResult_ (listenSocket addr port 128)
(errMsg : pure (err errMsg t))
(server :
serveForever server (arboricxHandler root))

View File

@@ -1,74 +1,922 @@
false = t
_ = t
true = t t
id = \a : a
const = \a b : a
id a = a
const a b = a
pair = t
if = \cond then else : t (t else (t t then)) t cond
if cond then else = t (t else (t t then)) t cond
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
(\x : x x)
(\a0 a1 a2 : t (t a0) (t t a2) a1))
y = ((mut wait fun : wait mut (x : fun (wait mut x)))
(x : x x)
(a0 a1 a2 : t (t a0) (t t a2) a1))
compose = \f g x : f (g x)
compose f g x = f (g x)
triage = \leaf stem fork : t (t leaf stem) fork
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
triage leaf stem fork = t (t leaf stem) fork
test = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
matchBool = (\ot of : triage
matchBool = (ot of : triage
of
(\_ : ot)
(\_ _ : ot)
(_ : ot)
(_ _ : ot)
)
lAnd = (triage
(\_ : false)
(\_ x : x)
(\_ _ x : x))
(_ : false)
(_ x : x)
(_ _ x : x))
lOr = (triage
(\x : x)
(\_ _ : true)
(\_ _ _ : true))
(x : x)
(_ _ : true)
(_ _ _ : true))
matchPair = \a : triage _ _ a
matchPair a = triage _ _ a
fst p = matchPair takeFirst p
where takeFirst a b = a
snd p = matchPair takeSecond p
where takeSecond a b = b
resultIsOk result =
matchResult (errR rest : false) (val rest : true) result
resultIsErr result =
matchResult (errR rest : true) (val rest : false) result
not? = matchBool false true
and? = matchBool id (\_ : false)
and? = matchBool id (_ : false)
or? = (\x z :
or? = (x z :
matchBool
(matchBool true true z)
(matchBool true false z)
x)
xor? = (\x z :
xor? = (x z :
matchBool
(matchBool false true z)
(matchBool true false z)
x)
equal? = y (\self : triage
equal? = y (self : triage
(triage
true
(\_ : false)
(\_ _ : false))
(\ax :
(_ : false)
(_ _ : false))
(ax :
triage
false
(self ax)
(\_ _ : false))
(\ax ay :
(_ _ : false))
(ax ay :
triage
false
(\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
(_ : false)
(bx by : lAnd (self ax bx) (self ay by))))
succ = y (\self :
succ = y (self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
(_ 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)
-- ---------------------------------------------------------------------------
-- Lazy eliminators
--
-- A strict eliminator evaluates both branches because they are ordinary
-- arguments. Give a branch that recurses, looks something up, or builds
-- structure to one of these instead: it becomes a thunk and only the selected
-- branch is ever applied.
-- ---------------------------------------------------------------------------
lazyBool = (thenK elseK cond :
((chosen : chosen t)
(matchBool
thenK
elseK
cond)))
-- This module has no list matcher, so `triage` is used directly: a cons is a
-- Fork, which is why the cons case sits in the fork slot, exactly as in
-- `matchList` in lib/list.tri.
lazyList = (nilK consK xs :
((chosen : chosen t)
(triage
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)))
-- ---------------------------------------------------------------------------
-- 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 :
ifLazy
bit
(_ : matchBool
(t t rest)
0
rest)
(_ : t (t t) (self rest))))
pred @nat? =@nat? pred_
isZero_? = triage true (_ : false) (_ _ : false)
isZero? @nat? =@bool? isZero_?
add @nat? @nat? =@nat? (y (self x y :
triage
y
(_ : succ y)
(_ _ : succ (self (pred_ x) y))
x))
sub @nat? @nat? =@nat? 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))))
lte? @nat? @nat? =@bool? lte_?
gte_? = a b : lte_? b a
gte? @nat? @nat? =@bool? gte_?
lt_? = a b : and? (lte_? a b) (not? (equal? a b))
lt? @nat? @nat? =@bool? lt_?
gt_? = a b : lt_? b a
gt? @nat? @nat? =@bool? gt_?
mul @nat? @nat? =@nat? y (self a b :
ifLazy
(isZero_? b)
(_ : 0)
(_ : add a (self a (pred_ b))))
div @nat? @nat? =@nat? y (self a b :
ifLazy
(isZero_? b)
(_ : 0)
(_ : ifLazy
(lt_? a b)
(_ : 0)
(_ : succ (self (sub a b) b))))
mod @nat? @nat? =@nat? y (self a b :
ifLazy
(isZero_? b)
(_ : 0)
(_ : ifLazy
(lt_? a b)
(_ : a)
(_ : self (sub a b) b)))
pow @nat? @nat? =@nat? y (self a b :
ifLazy
(isZero_? b)
(_ : 1)
(_ : mul a (self a (pred_ b))))
even? n = (triage
true
(_ : false)
(bit _ : isZero_? bit)
n)
odd? = (n : not? (even? n))
min @nat? @nat? =@nat? (a b : ifLazy (lte_? a b) (_ : a) (_ : b))
max @nat? @nat? =@nat? (a b : ifLazy (lte_? a b) (_ : b) (_ : a))
-- ---------------------------------------------------------------------------
-- 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)
-- ---------------------------------------------------------------------------
-- List
-- ---------------------------------------------------------------------------
matchList = a b : triage a _ b
emptyList? = matchList true (_ _ : false)
head xs@(nonEmptyListOf anyC) =@anyC matchList t (h _ : h) xs
tail xs@(nonEmptyListOf anyC) =@(listOf anyC) matchList t (_ r : r) xs
append_ self xs ys =
matchList
ys
(h r : pair h (self r ys))
xs
append = xs ys : y append_ xs ys
lExist?_ self x xs =
matchList
false
(h r : or? (equal? x h) (self x r))
xs
lExist? = x xs : y lExist?_ x xs
map_ self l f =
matchList
t
(h r : pair (f h) (self r f))
l
map = f l : y map_ l f
filter_ self l f =
matchList
t
(h r :
matchBool
(pair h (self r f))
(self r f)
(f h))
l
filter = f l : y filter_ l f
foldl_ self l f acc =
matchList
acc
(h r : self r f (f acc h))
l
foldl = f x l : y foldl_ l f x
foldr_ self l f x =
matchList
x
(h r : f (self r f x) h)
l
foldr = f x l : y foldr_ l f x
length_ self xs =
matchList
0
(_ r : succ (self r))
xs
length @(listOf anyC) =@nat? y length_
reverse_ self xs acc =
matchList
acc
(h r : self r (pair h acc))
xs
reverse = xs : y reverse_ xs t
snoc_ self x xs =
matchList
(pair x t)
(h r : pair h (self x r))
xs
snoc = x xs : y snoc_ x xs
count_ self x xs =
matchList
0
(h r :
matchBool
(succ (self x r))
(self x r)
(equal? x h))
xs
count = x xs : y count_ x xs
last_ self xs =
matchList
t
(h r :
matchBool
h
(self r)
(emptyList? r))
xs
last @(nonEmptyListOf anyC) =@anyC y last_
all?_ self pred xs =
matchList
true
(h r : and? (pred h) (self pred r))
xs
all? = pred xs : y all?_ pred xs
any?_ self pred xs =
matchList
false
(h r : or? (pred h) (self pred r))
xs
any? = pred xs : y any?_ pred xs
intersect = xs ys : filter (x : lExist? x ys) xs
nth_ self xs n i =
matchList
t
(h r :
matchBool
h
(self r n (succ i))
(equal? i n))
xs
nth = n xs : y nth_ xs n 0
headMaybe = matchList nothing (h _ : just h)
lastMaybe_ self xs =
matchList
nothing
(h r :
matchBool
(just h)
(self r)
(emptyList? r))
xs
lastMaybe = xs : y lastMaybe_ xs
nthMaybe_ self xs n i =
matchList
nothing
(h r :
matchBool
(just h)
(self r n (succ i))
(equal? i n))
xs
nthMaybe = n xs : y nthMaybe_ xs n 0
take_ self xs n i =
matchList
t
(h r :
matchBool
t
(pair h (self r n (succ i)))
(equal? i n))
xs
take = n xs : y take_ xs n 0
drop_ self xs n i =
matchBool
xs
(matchList
t
(_ r : self r n (succ i))
xs)
(equal? i n)
drop = n xs : y drop_ xs n 0
splitAt = n xs : pair (take n xs) (drop n xs)
concatMap_ self f xs =
matchList
t
(h r : append (f h) (self f r))
xs
concatMap = f xs : y concatMap_ f xs
find_ self pred xs =
matchList
nothing
(h r :
matchBool
(just h)
(self pred r)
(pred h))
xs
find = pred xs : y find_ pred xs
partition_ 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 : y partition_ pred xs t t
strLength = length
strAppend = append
strEq? = equal?
strEmpty? = emptyList?
startsWith?_ self prefix input =
matchList
true
(ph pr :
matchList
false
(sh sr :
matchBool
(self pr sr)
false
(equal? ph sh))
input)
prefix
startsWith? = prefix input : y startsWith?_ prefix input
endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
contains?_ self needle haystack =
matchBool
true
(matchList
false
(_ r : self needle r)
haystack)
(startsWith? needle haystack)
contains? = needle haystack : y contains?_ needle haystack
sum @(listOf nat?) =@nat? foldl (acc x : add x acc) 0
product @(listOf nat?) =@nat? foldl (acc x : mul x acc) 1
-- ---------------------------------------------------------------------------
-- Generic separators
--
-- `lines`, `unlines`, `words` and `unwords` at the bottom of this section are
-- the byte-valued special cases of these primitives.
--
-- Joining takes any separator; splitting takes one byte. Separators are removed
-- rather than kept, and empty fields are preserved.
-- ---------------------------------------------------------------------------
takeWhile_ self xs f =
lazyList
(_ : t)
(h r :
lazyBool
(_ : pair h (self r f))
(_ : t)
(f h))
xs
takeWhile = f xs : y takeWhile_ xs f
dropWhile_ self xs f =
lazyList
(_ : t)
(h r :
lazyBool
(_ : self r f)
(_ : pair h r)
(f h))
xs
dropWhile = f xs : y dropWhile_ xs f
-- Byte-level whitespace only: space and horizontal tab (HTTP OWS).
spaceByte? = b : equal? b 32
tabByte? = b : equal? b 9
trimByte? = b : or? (spaceByte? b) (tabByte? b)
trim = xs : dropWhile trimByte? (reverse (dropWhile trimByte? (reverse xs)))
intercalate_ self xs sep =
lazyList
(_ : t)
(h r :
lazyBool
(_ : h)
(_ : append h (append sep (self r sep)))
(emptyList? r))
xs
intercalate = sep xs : y intercalate_ xs sep
-- Separator after every field, including the last one. Line-oriented formats
-- want this: `joinSuffix "\n" xs` terminates the final line while
-- `intercalate "\n" xs` does not.
joinSuffix_ self xs sep =
lazyList
(_ : t)
(h r : append (append h sep) (self r sep))
xs
joinSuffix = sep xs : y joinSuffix_ xs sep
-- Split on a single byte.
-- Empty fields are preserved: `splitOnByte 58 "a::b"` is ["a" "" "b"].
splitByte_ self str byte acc current =
lazyList
(_ : map reverse (reverse (pair current acc)))
(h r :
lazyBool
(_ : self r byte (pair current acc) t)
(_ : self r byte acc (pair h current))
(equal? h byte))
str
splitOnByte = byte str : y splitByte_ str byte t t
-- Every one of these keeps its arguments bound: partially applying a
-- multi-argument function at the top level leaves a fixed point exposed.
lines = str : splitOnByte 10 str
unlines = xs : joinSuffix "\n" xs
-- Runs of separators collapse: empty fields are dropped.
words = str : filter (w : not? (emptyList? w)) (splitOnByte 32 str)
unwords = xs : intercalate " " xs
zipWith_ self f xs ys =
matchList
t
(xh xt :
matchList
t
(yh yt : pair (f xh yh) (self f xt yt))
ys)
xs
zipWith = f xs ys : y zipWith_ f xs ys
-- ---------------------------------------------------------------------------
-- Core contract type
--
-- A contract is an ordinary tricu function: Tree -> Tree -> Result Tree Tree.
-- The second argument is the conventional "rest" slot. On success a contract
-- returns the checked value wrapped in the standard ok shape; on failure it
-- returns a diagnostic wrapped in the standard err shape.
--
-- The contract kernel is a globally configurable function selected by the
-- runner. It decides whether to accept the contract result, replace it, log
-- it, or transform the diagnostic. The default kernel is the identity on the
-- contract Result.
--
-- The runner may rebind 'kernel' to a different kernel before evaluating
-- user code (e.g. via --contract-kernel).
-- ---------------------------------------------------------------------------
contractOk = (value : (rest : ok value rest))
contractErr = (msg : (rest : err msg rest))
-- Default contract kernel. Return the contract Result unchanged.
defaultKernel = (contract value result :
matchResult
(msg rest : err msg rest)
(v rest : ok v rest)
result)
-- The active kernel. The runner may rebind this name to a different kernel
-- before evaluating user code (e.g. via --contract-kernel). Internally,
-- withContract dispatches through this binding, so rebinding 'kernel' changes
-- the behaviour of every contract boundary in the program.
kernel = defaultKernel
-- Skip-everything kernel. Resume with the original value on failure.
skipKernel = (contract value result :
matchResult
(msg rest : ok value rest)
(v rest : ok v rest)
result)
-- Apply a contract and pass the raw Result to the kernel.
withContract = (contract value :
kernel contract value (contract value t))
-- Apply a contract and return the checked value or the diagnostic message.
check contract value =
matchResult
(msg _ : msg)
(v _ : v)
(withContract contract value)
-- Apply a contract and return the raw Result (kernel is bypassed).
checkContract = (contract value : contract value t)
-- ---------------------------------------------------------------------------
-- Basic contracts
-- ---------------------------------------------------------------------------
-- Any value passes.
anyC = (value : contractOk value)
-- Always fails with the supplied message.
neverC = (msg : (value : contractErr msg))
-- Build a contract from a predicate that inspects only the value.
guardC = (msg predicate value rest :
lazyBool
(_ : contractOk value rest)
(_ : contractErr msg rest)
(predicate value))
-- Structural natural-number predicate.
-- A natural is either Leaf (0) or Fork bit rest where bit is Leaf (even)
-- or Stem Leaf (odd) and rest is itself a natural.
isNat? = y (self n :
triage
true
(_ : false)
(bit r :
triage
(self r)
(_ : self r)
(_ _ : false)
bit)
n)
-- Natural number contract.
nat? = guardC "not a natural number" isNat?
-- Non-zero natural number contract.
nonZero? = guardC "non-zero" (n : and? (isNat? n) (not? (isZero_? n)))
-- Boolean contract.
bool? = guardC "not a boolean" (b : or? (equal? b true) (equal? b false))
-- ---------------------------------------------------------------------------
-- Contract combinators
-- ---------------------------------------------------------------------------
andC = (c1 c2 value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : c2 v rest)
(c1 value rest))
orC = (c1 c2 value rest :
matchResult
(msg _ : c2 value rest)
(v _ : contractOk v rest)
(c1 value rest))
notC = (c value rest :
matchResult
(msg _ : contractOk value rest)
(_ _ : contractErr "notC: predicate succeeded" rest)
(c value rest))
mapC = (f c value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : contractOk (f v) rest)
(c value rest))
bindC = (c f value rest :
matchResult
(msg _ : contractErr msg rest)
(v _ : f v value rest)
(c value rest))
-- ---------------------------------------------------------------------------
-- Collection contracts
-- ---------------------------------------------------------------------------
listOf = (c value rest :
y (self orig xs :
matchList
(contractOk orig rest)
(h r :
matchResult
(msg _ : contractErr msg rest)
(_ _ : self orig r)
(c h rest))
xs) value value)
nonEmptyListOf = (c :
andC (guardC "empty list" (xs : not? (emptyList? xs))) (listOf c))
pairOf = (c1 c2 p rest :
matchPair
(a b :
matchResult
(msg _ : contractErr msg rest)
(a' _ :
matchResult
(msg _ : contractErr msg rest)
(b' _ : contractOk (pair a' b') rest)
(c2 b rest))
(c1 a rest))
p)
-- ---------------------------------------------------------------------------
-- Higher-order function contracts
--
-- These return a Result-wrapped proxy. The proxy itself is a contract: it
-- checks arguments on the way in and results on the way out.
-- ---------------------------------------------------------------------------
fnContract = (argC resC f rest :
contractOk
(x : (rest1 :
matchResult
(msg _ : contractErr msg rest1)
(x' _ :
matchResult
(msg _ : contractErr msg rest1)
(y _ : contractOk y rest1)
(withContract resC (f x')))
(withContract argC x)))
rest)
fn2 = (arg1C arg2C resC f rest :
contractOk
(x : (rest1 :
matchResult
(msg _ : contractErr msg rest1)
(x' _ :
contractOk
(y : (rest2 :
matchResult
(msg _ : contractErr msg rest2)
(y' _ :
matchResult
(msg _ : contractErr msg rest2)
(z _ : contractOk z rest2)
(withContract resC (f x' y')))
(withContract arg2C y)))
rest1)
(withContract arg1C x)))
rest)
-- ---------------------------------------------------------------------------
-- Interaction-tree effect layer
--
-- These constructors and combinators layer catchable, composable failures on
-- top of the core Result contracts. They reuse the same tags as tricu IO:
-- 0 = pureE
-- 1 = bindE
-- 2 = exceptE
-- ---------------------------------------------------------------------------
pureE = (value : pair 0 value)
bindE = (action k : pair 1 (pair action k))
exceptE = (tag value k : pair 2 (pair tag (pair value k)))
pureM = pureE
bindM = bindE
-- Lift a contract failure into an interaction tree.
checkM = (contract value :
matchResult
(msg _ : exceptE "contract" msg (_ : pureE t))
(checked _ : pureE checked)
(contract value t))
-- Lift a pure function into the interaction tree.
liftM = (f : (x : pureE (f x)))
-- Interpret a pure interaction tree into a Result.
runM = (tree :
run tree
where run =
y (self tree :
matchPair
(op payload :
matchBool
-- pureE
(contractOk (snd tree) t)
(matchBool
-- bindE
(matchPair
(action k :
matchResult
(msg _ : contractErr msg t)
(v _ : self (k v))
(self action))
payload)
-- exceptE
(matchPair
(tag pair :
matchPair
(value k :
contractErr value t)
pair)
payload)
(equal? op 1))
(equal? op 0))
tree))
-- Handle matching exceptE nodes by applying the handler to the value and the
-- resumption continuation. Non-matching exceptions are left in place.
handleM = (tag handler tree :
handle tree
where handle =
y (self tree :
matchPair
(op payload :
matchBool
-- pureE
tree
(matchBool
-- bindE
(matchPair
(action k :
bindE (self action) (v : self (k v)))
payload)
-- exceptE
(matchPair
(et pair :
matchPair
(value k :
matchBool
(self (handler value k))
tree
(equal? et tag))
pair)
payload)
(equal? op 1))
(equal? op 0))
tree))

109
lib/binary.tri Normal file
View File

@@ -0,0 +1,109 @@
!import "prelude" !Local
errUnexpectedEof = 1
errUnexpectedBytes = 2
errUnexpectedByte = 3
unit = t
readU8 = (bytes :
matchList
(err errUnexpectedEof t)
(h r : ok h r)
bytes)
readBytes_ 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 :
y readBytes_ bs n 0 bs t)
expectBytes_ 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 :
y 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)
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_ 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 :
y 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

16
lib/bytes.tri Normal file
View File

@@ -0,0 +1,16 @@
!import "base" !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?

21
lib/conversions.tri Normal file
View File

@@ -0,0 +1,21 @@
!import "base" !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))

849
lib/http.tri Normal file
View File

@@ -0,0 +1,849 @@
!import "prelude" !Local
!import "io" !Local
!import "patterns" !Local
!import "socket" !Local
-- ---------------------------------------------------------------------------
-- Constants
-- ---------------------------------------------------------------------------
maxHeaderBytes = 65536
maxBodyBytes = 1048576
maxUriBytes = 8192
crlf = pair 13 (pair 10 t)
crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t)))
-- ---------------------------------------------------------------------------
-- Small byte/list helpers
-- ---------------------------------------------------------------------------
chomp = (xs :
lazyList
(_ : t)
(h r :
lazyBool
(_ : reverse r)
(_ : xs)
(equal? h 13))
(reverse xs))
-- ---------------------------------------------------------------------------
-- Response construction
-- ---------------------------------------------------------------------------
statusPhrases =
[(pair 200 "OK")
(pair 201 "Created")
(pair 204 "No Content")
(pair 400 "Bad Request")
(pair 404 "Not Found")
(pair 405 "Method Not Allowed")
(pair 431 "Request Header Fields Too Large")
(pair 501 "Not Implemented")
(pair 505 "HTTP Version Not Supported")]
lookupStatusPhrase_ self code phrases =
lazyList
(_ : "Internal Server Error")
(h r :
lazyBool
(_ : snd h)
(_ : self code r)
(equal? code (fst h)))
phrases
statusPhrase = (code :
y lookupStatusPhrase_ code statusPhrases)
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)
htmlResponse = (body :
response 200 "text/html; charset=utf-8" 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)
headerEndState state h =
lazyBool
(_ :
lazyBool
(_ : 3)
(_ : 1)
(equal? state 2))
(_ :
lazyBool
(_ :
lazyBool
(_ : 4)
(_ : 2)
(equal? state 3))
(_ : 0)
(boolAnd?
(equal? h 10)
(boolOr? (equal? state 1) (equal? state 3))))
(equal? h 13)
headersOnly_ self bs state acc =
lazyList
(_ : reverse acc)
(h r :
let nextAcc = pair h acc in
let nextState = headerEndState state h in
lazyBool
(_ : reverse nextAcc)
(_ : self r nextState nextAcc)
(equal? nextState 4))
bs
headersOnly = (response :
y headersOnly_ response 0 t)
responseForMethod = (method resp :
lazyBool
(_ : headersOnly resp)
(_ : resp)
(equal? method "HEAD"))
-- ---------------------------------------------------------------------------
-- 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))
(_ :
let chunkLen = length chunk in
let nextLen = add accLen chunkLen in
let next = append acc chunk in
lazyBool
(_ :
lazyBool
(_ : pure (ok next t))
(_ : self sock pattern maxBytes next nextLen)
(contains? pattern next))
(_ : pure (err 431 next))
(lte? nextLen maxBytes))
(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)
-- ---------------------------------------------------------------------------
-- 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)))
-- ---------------------------------------------------------------------------
-- 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)))))))
byte7BitsOr default c k =
let noStem _ = default in
let bit6 b0 b1 b2 b3 b4 b5 b6 r6 =
k b0 b1 b2 b3 b4 b5 b6 r6 in
let bit5 b0 b1 b2 b3 b4 b5 r5 =
triage default noStem (bit6 b0 b1 b2 b3 b4 b5) r5 in
let bit4 b0 b1 b2 b3 b4 r4 =
triage default noStem (bit5 b0 b1 b2 b3 b4) r4 in
let bit3 b0 b1 b2 b3 r3 =
triage default noStem (bit4 b0 b1 b2 b3) r3 in
let bit2 b0 b1 b2 r2 =
triage default noStem (bit3 b0 b1 b2) r2 in
let bit1 b0 b1 r1 =
triage default noStem (bit2 b0 b1) r1 in
let bit0 b0 r0 =
triage default noStem (bit1 b0) r0 in
triage default noStem bit0 c
toLowerAsciiByte = (c :
byte7BitsOr c c (b0 b1 b2 b3 b4 b5 b6 rest :
lazyBool
(_ : lowerAsciiBits b0 b1 b2 b3 b4)
(_ : c)
(boolAnd?
(isZero? rest)
(boolAnd?
(bit1? b6)
(boolAnd?
(bit0? b5)
(upperLow5? b0 b1 b2 b3 b4))))))
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)
-- ---------------------------------------------------------------------------
-- 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))
maxBodyBytesDecimal = "1048576"
byte0? b = equal? b 48
digitLtMax? maxDigit digit = lt? digit maxDigit
stripLeadingZeros_ self raw =
lazyList
(_ : t)
(c r :
lazyBool
(_ : self r)
(_ : raw)
(byte0? c))
raw
decimalLengthLte_ self max raw =
lazyList
(_ : true)
(_ rest :
lazyList
(_ : false)
(_ maxRest : self maxRest rest)
max)
raw
decimalSameLength_ self max raw =
lazyList
(_ :
lazyList
(_ : true)
(_ _ : false)
max)
(_ rest :
lazyList
(_ : false)
(_ maxRest : self maxRest rest)
max)
raw
sameLengthDecimalLte_ self max raw less =
lazyList
(_ : true)
(digit rest :
lazyList
(_ : false)
(maxDigit maxRest :
lazyBool
(_ : self maxRest rest true)
(_ :
lazyBool
(_ : self maxRest rest true)
(_ :
lazyBool
(_ : self maxRest rest false)
(_ : false)
(equal? digit maxDigit))
(digitLtMax? maxDigit digit))
less)
max)
raw
decimalLengthLte? max raw = y decimalLengthLte_ max raw
decimalSameLength? max raw = y decimalSameLength_ max raw
decimalBytesLte? max raw =
let trimmed = y stripLeadingZeros_ raw in
lazyBool
(_ : y sameLengthDecimalLte_ max trimmed false)
(_ : decimalLengthLte? max trimmed)
(decimalSameLength? max trimmed)
parseContentLengthValue = (raw :
matchMaybe
(err 400 "Bad Request\n")
(n :
lazyBool
(_ : ok (just n) t)
(_ : err 413 "Request body too large\n")
(decimalBytesLte? maxBodyBytesDecimal raw))
(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)
-- ---------------------------------------------------------------------------
-- Body reading
-- ---------------------------------------------------------------------------
bodyReadState = (remaining accRev rest :
pair remaining (pair accRev rest))
bodyReadRemaining = (state :
fst state)
bodyReadAccRev = (state :
fst (snd state))
bodyReadRest = (state :
snd (snd state))
takeBodyBytes_ = (self bytes remaining accRev :
lazyBool
(_ : bodyReadState 0 accRev bytes)
(_ :
lazyList
(_ : bodyReadState remaining accRev t)
(h r :
self r (pred remaining) (pair h accRev))
bytes)
(isZero? remaining))
takeBodyBytes = (bytes remaining accRev :
y takeBodyBytes_ bytes remaining accRev)
shiftRight1 n = triage 0 (_ : 0) (_ rest : rest) n
shiftRight2 n = shiftRight1 (shiftRight1 n)
shiftRight4 n = shiftRight2 (shiftRight2 n)
shiftRight8 n = shiftRight4 (shiftRight4 n)
shiftRight12 n = shiftRight4 (shiftRight8 n)
shiftRight6 n = shiftRight2 (shiftRight4 n)
atLeast16? n = not? (isZero? (shiftRight4 n))
atLeast64? n = not? (isZero? (shiftRight6 n))
atLeast256? n = not? (isZero? (shiftRight8 n))
atLeast1024? n = not? (isZero? (shiftRight2 (shiftRight8 n)))
atLeast4096? n = not? (isZero? (shiftRight12 n))
recvChunkMax4096 remaining =
lazyBool
(_ : 4096)
(_ :
lazyBool
(_ : 1024)
(_ :
lazyBool
(_ : 256)
(_ :
lazyBool
(_ : 64)
(_ :
lazyBool
(_ : 16)
(_ : 1)
(atLeast16? remaining))
(atLeast64? remaining))
(atLeast256? remaining))
(atLeast1024? remaining))
(atLeast4096? remaining)
readBodyRecv = (self sock remaining accRev recvBytes :
onResult_ (recv sock recvBytes)
(errMsg :
pure
(err
400
(append "recv failed while reading body: " errMsg)))
(chunk :
let state = takeBodyBytes chunk remaining accRev in
let nextRemaining = bodyReadRemaining state in
let nextAccRev = bodyReadAccRev state in
lazyBool
(_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
(_ : self sock nextRemaining nextAccRev)
(isZero? nextRemaining)))
readBodyMore_ = (self sock remaining accRev :
lazyBool
(_ : pure (ok (reverse accRev) t))
(_ : readBodyRecv self sock remaining accRev (recvChunkMax4096 remaining))
(isZero? remaining))
readBodyMore = (sock remaining accRev :
y readBodyMore_ sock remaining accRev)
readBodyExact = (sock expected initialBytes :
let state = takeBodyBytes initialBytes expected t in
let remaining = bodyReadRemaining state in
let accRev = bodyReadAccRev state in
lazyBool
(_ : pure (ok (reverse accRev) (bodyReadRest state)))
(_ : readBodyMore sock remaining accRev)
(isZero? remaining))
validateBodyLength = (expected body rest :
let actual = length body in
lazyBool
(_ : pure (ok body rest))
(_ :
pure
(err
400
(append
"body length mismatch expected="
(append
(showNumber expected)
(append
" actual="
(showNumber actual))))))
(equal? actual expected))
readBody = (sock headers initialBytes :
matchResult
(status msg :
pure (err status msg))
(maybeLen rest :
lazyMaybe
(_ : pure (ok t initialBytes))
(n :
onOk (readBodyExact sock n initialBytes)
(body rest :
validateBodyLength n body rest))
maybeLen)
(contentLength headers))
-- ---------------------------------------------------------------------------
-- 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 msg :
respondAndClose client
(responseForMethod method
(errorResponse status msg)))
(body rest :
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 msg :
respondAndClose client
(responseForMethod method
(errorResponse status msg)))
(body rest :
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)))

View File

@@ -0,0 +1,53 @@
!import "prelude" !Local
-- Structural contracts that exploit Tree Calculus's intensional nature.
-- These are not simple type tags; they recursively inspect the tree shape.
-- Any value that is not Leaf.
nonEmptyTree? = guardC "empty tree" (x : not? (isZero? x))
-- Every internal node is a Fork with two children; Stems are not allowed.
fullTree? = guardC "not a full binary tree"
(y (self x :
triage
true
(_ : false)
(l r : and? (self l) (self r))
x))
-- Even and odd number contracts that inspect the LSB bit tree.
evenC? = guardC "not even" even?
oddC? = guardC "not odd" odd?
-- A power of two has exactly one '1' bit in its LSB encoding.
powerOfTwo? = guardC "not a power of two"
(y (self n :
triage
false
true
(bit rest :
matchBool
(self rest)
false
(isZero? bit))
n))
-- A string (list of numbers) where every code point is in the ASCII range.
asciiString? = listOf
(guardC "non-ascii byte" (n : and? (gte? n 0) (lte? n 127)))
-- Check that a list of numbers is sorted in ascending order.
-- The element contract parameter is applied separately by listOf.
isSorted_ = (self xs :
matchList
true
(h r :
matchBool
(self r)
false
(matchList true (h2 _ : lte? h h2) r))
xs)
isSorted = y isSorted_
sortedList? = (c : andC (listOf c) (guardC "not sorted" isSorted))

161
lib/io.tri Normal file
View File

@@ -0,0 +1,161 @@
!import "prelude" !Local
!import "patterns" !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)
mapErrIO prefix action =
onResult_ action
(e : pure (err (append prefix e) t))
(v : pure (ok v t))
-- ---------------------------------------------------------------------------
-- 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)))

View File

@@ -1,77 +0,0 @@
!import "base.tri" !Local
matchList = \a b : triage a _ b
emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
append = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
lExist? = y (\self x : matchList
false
(\h z : or? (equal? x h) (self x z)))
map_ = y (\self :
matchList
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = \f l : map_ l f
filter_ = y (\self : matchList
(\_ : t)
(\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
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
length = y (\self : matchList
0
(\_ tail : succ (self tail)))
reverse = y (\self : matchList
t
(\head tail : append (self tail) (pair head t)))
snoc = y (\self x : matchList
(pair x t)
(\h z : pair h (self x z)))
count = y (\self x : matchList
0
(\h z : matchBool
(succ (self x z))
(self x z)
(equal? x h)))
last = y (\self : matchList
t
(\hd tl : matchBool
hd
(self tl)
(emptyList? tl)))
all? = y (\self pred : matchList
true
(\h z : and? (pred h) (self pred z)))
any? = y (\self pred : matchList
false
(\h z : or? (pred h) (self pred z)))
unique_ = y (\self seen : matchList
t
(\head rest : matchBool
(self seen rest)
(pair head (self (pair head seen) rest))
(lExist? head seen)))
unique = \xs : unique_ t xs
intersect = \xs ys : filter (\x : lExist? x ys) xs
union = \xs ys : unique (append xs ys)

View File

@@ -1,35 +1,40 @@
!import "list.tri" !Local
!import "prelude" !Local
match_ = y (\self value patterns :
match_ = y (self value patterns :
triage
t
(\_ : t)
(\pattern rest :
(_ : t)
(pattern rest :
triage
t
(\_ : t)
(\test result :
(_ : t)
(test result :
if (test value)
(result value)
(self value rest))
pattern)
patterns)
match = (\value patterns :
match_ value (map (\sublist :
match = (value patterns :
match_ value (map (sublist :
pair (head sublist) (head (tail sublist)))
patterns))
otherwise = const (t t)
-- matchExample = (\x : match x [[(equal? 1) (\_ : "one")]
-- [(equal? 2) (\_ : "two")]
-- [(equal? 3) (\_ : "three")]
-- [(equal? 4) (\_ : "four")]
-- [(equal? 5) (\_ : "five")]
-- [(equal? 6) (\_ : "six")]
-- [(equal? 7) (\_ : "seven")]
-- [(equal? 8) (\_ : "eight")]
-- [(equal? 9) (\_ : "nine")]
-- [(equal? 10) (\_ : "ten")]
-- [ otherwise (\_ : "I ran out of fingers!")]])
cond_ self patterns =
lazyList
(_ : t)
(pattern rest :
matchPair
(testK actionK :
lazyBool
actionK
(_ : self rest)
(testK t))
pattern)
patterns
cond patterns = y cond_ patterns
guard testK actionK = pair testK actionK

3
lib/prelude.tri Normal file
View File

@@ -0,0 +1,3 @@
!import "base" !Local
!import "bytes" !Local
!import "conversions" !Local

82
lib/socket.tri Normal file
View File

@@ -0,0 +1,82 @@
!import "prelude" !Local
!import "io" !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))))

328
notes/contract-design.md Normal file
View File

@@ -0,0 +1,328 @@
# Contract Kernel Design
## Status
Implemented. The contract system uses a configurable kernel defined in
`lib/base.tri`. All contract logic lives in pure tree calculus.
## Goals
1. **User code stays ergonomic.** `@`/`=@` syntax remains. Calling a guarded
function looks the same as calling an unguarded one.
2. **No stringly-dynamic failures.** A contract boundary returns a structured
`Result`. The kernel decides whether to abort, resume with a replacement,
log, or otherwise transform the result.
3. **All evaluation logic in pure tree calculus.** The evaluator does not treat
contracts specially; contracts are ordinary functions and the desugarer
emits ordinary tricu code.
4. **Optional contract enforcement.** A CLI/REPL flag can disable contract
syntax entirely by stripping annotations at desugar time.
5. **Configurable failure semantics.** A global kernel, supplied by the user
via CLI/REPL, determines how contract failures are handled for the
session.
## Core idea
A contract annotation on a definition desugars into a runtime guard. The
runtime guard applies a contract predicate to a value and passes the resulting
`Result` to the current `kernel`. The `kernel` returns another `Result`, which
the wrapper inspects:
- `ok value` means the guard succeeded; continue with `value`.
- `err msg` means the guard failed; abort and propagate the error.
The default kernel is the identity on the contract `Result`. A custom kernel
can transform failures into successes, wrap diagnostics, or log failures before
aborting.
## Kernel
### Signature
```tricu
kernel contract value result -> Result
```
- `contract`: the contract predicate being checked.
- `value`: the unevaluated original value passed to the contract.
- `result`: the `Result` produced by evaluating `contract value t`.
### Default kernel
`lib/base.tri` defines both `defaultKernel` and the active `kernel`:
```tricu
defaultKernel = (contract value result :
matchResult
(msg rest : err msg rest)
(v rest : ok v rest)
result)
kernel = defaultKernel
```
The runner may rebind `kernel` to a different value before evaluating user
code (e.g. via `--contract-kernel`). Because `withContract` looks up `kernel`
dynamically at application time, rebinding it changes the behaviour of every
contract boundary.
### Skip kernel
Resume with the original value whenever a contract fails:
```tricu
skipKernel = (contract value result :
matchResult
(msg rest : ok value rest)
(v rest : ok v rest)
result)
```
### Logging kernel
Abort but also emit a log entry:
```tricu
loggingKernel = (contract value result :
matchResult
(msg rest : pair (logMsg msg) (err msg rest))
(v rest : ok v rest)
result)
```
### Resume-with-default kernel
```tricu
resumeWithZero = (contract value result :
matchResult
(msg rest : ok 0 rest)
(v rest : ok v rest)
result)
```
## Runtime guard primitive
`withContract` is the primitive emitted by the desugarer:
```tricu
withContract = (contract value :
kernel contract value (contract value t))
```
`check` is a convenience wrapper that extracts the value or the diagnostic
message:
```tricu
check contract value =
matchResult
(msg _ : msg)
(v _ : v)
(withContract contract value)
```
## Desugaring
Desugaring runs **before** import selection so that names introduced by the
desugarer (`withContract`, `matchResult`, `err`, `ok`, etc.) are included in
the selected exports of imported modules. This ensures that a module using
contract annotations imports everything it needs from `base`/`prelude`.
### Phantom annotations
```tricu
add @nat? @nat? =@nat? addRaw
```
desugars to:
```tricu
add = (x y :
matchResult
(msg _ : \_ : err msg t)
(x' _ :
matchResult
(msg _ : err msg t)
(y' _ :
matchResult
(msg _ : err msg t)
(r _ : r)
(withContract nat? (addRaw x' y')))
(withContract nat? y))
(withContract nat? x))
```
The first failure continuation is absorbing (`\_ : err msg t`) because `add`
is curried and a failure on the first argument should consume the second
argument without producing garbage.
`addRaw` is the locally-let-bound raw helper, as in the current phantom
implementation.
### Named-binder annotations
```tricu
safeDiv a@nat? b@(andC nat? nonZero?) =@nat? div a b
```
desugars to:
```tricu
safeDiv = (a b :
matchResult
(msg _ : \_ : err msg t)
(a' _ :
matchResult
(msg _ : err msg t)
(b' _ :
matchResult
(msg _ : err msg t)
(r _ : r)
(withContract nat? (div a' b')))
(withContract (andC nat? nonZero?) b))
(withContract nat? a))
```
### No return contract
```tricu
head xs@(nonEmptyListOf anyC) =@anyC headRaw
```
desugars to:
```tricu
head = (xs :
matchResult
(msg _ : err msg t)
(xs' _ :
matchResult
(msg _ : err msg t)
(r _ : r)
(withContract anyC (headRaw xs')))
(withContract (nonEmptyListOf anyC) xs))
```
### No annotations
Definitions without `@`/`=@` are emitted unchanged.
## Failure propagation
When a non-final argument contract fails, the wrapper returns a function that
absorbs the next argument and then returns the failed `Result`. This prevents
partial-application accidents like `gt? "the" 3` reducing to a garbage number.
When the final argument or result contract fails, the wrapper returns
`\msg -> err msg t`, which is the failure constructor awaiting its `rest`
slot.
## Skip-contracts flag
When the `--skip-contracts` flag is set, the desugarer strips all `@`/`=@`
annotations and emits the raw function body. This is faster than running the
skip kernel because no contract code is generated at all.
### CLI
```bash
tricu eval --skip-contracts program.tri
tricu repl --skip-contracts
```
### REPL
```tricu
> :set skip-contracts
> add 1 2
3
> :unset skip-contracts
> add "bad" 2
[t, "not a natural number"]
```
## Kernel selection
### CLI
```bash
tricu eval --contract-kernel resumeWithZero program.tri
```
### REPL
```tricu
> :set contract-kernel resumeWithZero
> add "bad" 2
2
```
### Resolution
The kernel name is resolved like any other top-level binding in the program or
its imports. The runner prepends `kernel = <name>` to the program AST (or
inserts it into the environment) after imports are resolved. If the name is
not found, evaluation fails with an undefined-variable error.
## Base library changes
1. `withContract` becomes the runtime guard primitive shown above.
2. `check` extracts the checked value or diagnostic message from the kernel
`Result`.
3. Contract predicates (`nat?`, `nonZero?`, `bool?`, etc.) remain pure
functions returning `Result`.
4. Guarded base functions (`add`, `sub`, `head`, `div`, etc.) use the new
desugaring.
5. Raw helpers (`addRaw`, `subRaw`, etc.) remain for internal use and recursion.
## Custom contracts
Users write ordinary predicates returning `Result`:
```tricu
positive? = (n rest :
ifThenElse (gte? n 1)
(ok n rest)
(err "expected positive integer" rest))
```
and use them with the same syntax:
```tricu
fact n@positive? =@nat? y (self n : ...)
```
Contract combinators (`andC`, `orC`, `guardC`) compose in the obvious way.
## Limitations
1. **Global kernel only.** There is no local kernel override. A module or
function cannot install a different kernel for part of the program.
Workarounds: split into separate evaluation sessions, or use explicit
`withContract` calls with a local handler function.
2. **Kernel must return `Result`.** A kernel that returns a plain value is a
bug. The `defaultKernel`/`skipKernel` templates show the required shape.
3. **Failures are first-class `Result` values.** A caller that ignores a
returned `err msg` and treats it as data will operate on the `Result` tree.
This is inherent to any value-level error mechanism.
4. **Function contracts are advanced.** Contracts on function arguments
(e.g. `f @ (nat? -> nat?)`) require intensional/quantified contracts. The
simple predicate model covers most use cases.
## Implementation notes
- `Frontend.ContractDesugar` emits `matchResult`/`withContract`/`err`/`ok`
instead of continuation-passing `withContract`.
- `FileEval.loadFile'` desugars before computing selected exports, so
imported modules bring in the runtime helpers needed by annotations.
- `Eval.injectKernel` is a fallback that binds `kernel` to `defaultKernel`
when `kernel` is missing from the environment.
## Open questions
1. **Should `--skip-contracts` strip annotations or just bind the skip
kernel?** Currently stripping is the intended design; not yet implemented.
2. **Should we provide a small set of built-in kernel names?** `default`,
`skip`, `strict`, `log` would cover common cases without requiring the user
to define them.
3. **How do we expose the current kernel to introspection?** A top-level
`currentContractKernel` binding might be useful for debugging.

View 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
```

View 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`.

View File

@@ -0,0 +1,248 @@
# The takeaway
Consumed data must block recursion.
Control data must not drive recursion.
Branches with work must be lazy.
Top-level fixed points must be hidden behind wrappers.
Fixed-format data should be destructured finitely, not sliced recursively.
## Rules for normalization-safe `tricu`
A top-level definition must normalize when its runtime inputs are still abstract. Therefore, avoid any shape where known control data can unfold recursion before the consumed data is available.
## 1. Put consumed data first
Recursive workers should take the structure they consume before counters, indexes, limits, accumulators, or other control state.
Avoid:
```tricu
worker index records state
```
Prefer:
```tricu
worker records index state
```
The workers first real operation should usually be a case split on the consumed value:
```tricu
worker_ = (self records state :
lazyList
nilCase
consCase
records)
```
## 2. Do not use generic recursive consumers on abstract fixed-format data
Avoid applying helpers like these to abstract values in top-level-normalized definitions:
```tricu
take n xs
drop n xs
nth n xs
length xs
startsWith? prefix xs
bytesTake n bytes
bytesDrop n bytes
```
These can be driven by known counters, indexes, lengths, or prefixes while `xs` is still abstract.
For fixed-format data, use finite destructuring helpers instead:
```tricu
withNodePayloadForkIndices payload shortK indicesK
hashShard hash
```
This keeps the recursion bounded by syntax, not by a runtime counter.
## 3. Use lazy eliminators when a branch contains work
If a branch contains recursion, IO construction, parsing, lookup, response construction, or anything that may recurse internally, do not pass it as an ordinary branch value.
Avoid:
```tricu
matchBool
resultNow
(self rest state)
cond
```
Prefer:
```tricu
lazyBool
(_ : resultNow)
(_ : self rest state)
cond
```
Same rule for result, maybe, and list elimination:
```tricu
lazyBool
lazyResult
lazyMaybe
lazyList
```
Strict eliminators are safe only when both branches are already cheap normal forms.
## 4. Do not expose top-level fixed points directly
Avoid top-level definitions like:
```tricu
foo_ = y (self input state : ...)
```
Prefer the library-style split:
```tricu
foo_ = (self input state : ...)
foo = (input state :
y foo_ input state)
```
This prevents each independently-normalized top-level definition from trying to normalize the fixed point itself.
## 5. Keep recursive self-application small and structurally progressing
Prefer recursive calls shaped like:
```tricu
self rest nextState
```
over wide calls like:
```tricu
self rest index i limit acc flags
```
Pack non-consumed state into a record/pair if needed.
The consumed argument should visibly progress:
```tricu
self rest nextState
```
not restart from the original structure:
```tricu
self originalRecords newIndex newState
```
Restarting from the original input inside recursive branches can create residual trees with no obvious structural progress.
## 6. Recursive state updates must be non-recursive
Do not call a recursive helper while constructing the next recursive state.
Avoid:
```tricu
self rest (listSnoc acc value)
```
because `listSnoc` is itself recursive.
Prefer constant-time constructors:
```tricu
self rest (pair value acc)
```
If order matters, reverse later only when the input is concrete, or store explicit indexes in an association list.
## 7. Do not rebuild from the whole input when a prefix invariant exists
If validation guarantees child references point backward, use that invariant.
Avoid:
```tricu
buildTree allRecords childIndex
```
inside the build of each node.
Prefer:
```tricu
lookup childIndex builtPrefix
```
For Arboricx nodes, this meant scanning records once left-to-right and resolving children from `builtTrees`.
## 8. Make route/path helpers consumed-data-driven
For request paths, hashes, and byte strings, avoid counter/prefix-driven recursive operations over abstract request data.
Avoid:
```tricu
take 3 hash
drop 23 target
startsWith? prefix target
```
Prefer:
```tricu
hashShard hash
stripPrefix prefix target
```
where the helper case-analyzes the consumed runtime data before recurring.
For fixed small slices like the first three hash bytes, use finite destructuring rather than `take`.
## 9. Treat top-level normalization as stricter than runtime evaluation
A function can be semantically correct at runtime and still fail import normalization.
Ask this for every top-level definition:
```text
Can this normalize while all of its arguments are unknown?
```
If the answer depends on “the branch will not be taken” or “the input will be concrete by then,” the definition is probably not normalization-safe.
## 10. When a definition hangs alphabetically, inspect reachable dependencies
The alphabetically first hanging definition is not necessarily the root cause. It may simply be the first definition that reaches a later problematic helper.
Debug by replacing reachable branches with constants:
```tricu
foo = (... : pure notFoundResponse)
```
Then add back one dependency at a time. If a constant version normalizes, the issue is in reachable branch work, not the wrapper itself.
## Compact checklist
Before adding or exporting a definition, check:
```text
1. Does every recursive worker consume unknown data first?
2. Is every recursive branch thunked with lazy eliminators?
3. Is `y` applied inside the public wrapper, not exposed as a top-level worker value?
4. Are recursive self-calls visibly progressing on consumed data?
5. Are recursive state updates constant-time?
6. Are `take`, `drop`, `nth`, `length`, `startsWith?`, or byte slicing used on abstract data?
7. Could a known counter, index, prefix, or length drive recursion?
8. Are fixed-format fields parsed with finite destructuring helpers?
9. Does any branch construct dynamic paths/responses from abstract data using recursive list helpers?
10. Can the definition normalize with all runtime arguments still unknown?
```

13
src/ContentStore.hs Normal file
View File

@@ -0,0 +1,13 @@
module ContentStore
( module ContentStore.Object
, module ContentStore.Filesystem
, module ContentStore.Arboricx
, module ContentStore.Alias
, module ContentStore.Resolver
) where
import ContentStore.Arboricx
import ContentStore.Alias
import ContentStore.Filesystem
import ContentStore.Object
import ContentStore.Resolver

81
src/ContentStore/Alias.hs Normal file
View File

@@ -0,0 +1,81 @@
module ContentStore.Alias
( AliasKind(..)
, ObjectRef(..)
, aliasKindDirectory
, writeAlias
, readAlias
, listAliases
) where
import ContentStore.Filesystem (ensureStore)
import ContentStore.Object
import Data.Text (Text)
import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory)
import System.FilePath ((</>))
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
-- | Mutable workspace alias categories. Aliases are human-facing pointers to
-- immutable content objects; they are not content identity.
data AliasKind
= NameAlias
| ModuleAlias
| PackageAlias
deriving (Eq, Ord, Show)
data ObjectRef = ObjectRef
{ objectRefKind :: Text
, objectRefHash :: ObjectHash
} deriving (Eq, Ord, Show)
aliasKindDirectory :: AliasKind -> FilePath
aliasKindDirectory NameAlias = "names"
aliasKindDirectory ModuleAlias = "modules"
aliasKindDirectory PackageAlias = "packages"
writeAlias :: StorePath -> AliasKind -> Text -> ObjectRef -> IO ()
writeAlias store@(StorePath root) kind name ref = do
ensureStore store
let dir = root </> "aliases" </> aliasKindDirectory kind
createDirectoryIfMissing True dir
TextIO.writeFile (dir </> Text.unpack name) (encodeObjectRef ref)
readAlias :: StorePath -> AliasKind -> Text -> IO (Maybe ObjectRef)
readAlias store@(StorePath root) kind name = do
ensureStore store
let path = root </> "aliases" </> aliasKindDirectory kind </> Text.unpack name
exists <- doesFileExist path
if not exists
then return Nothing
else decodeObjectRef <$> TextIO.readFile path
listAliases :: StorePath -> AliasKind -> IO [(Text, ObjectRef)]
listAliases store@(StorePath root) kind = do
ensureStore store
let dir = root </> "aliases" </> aliasKindDirectory kind
names <- listDirectory dir
fmap concat $ mapM load names
where
load name = do
mRef <- readAlias store kind (Text.pack name)
return $ maybe [] (\ref -> [(Text.pack name, ref)]) mRef
encodeObjectRef :: ObjectRef -> Text
encodeObjectRef ref = Text.unlines
[ "kind: " <> objectRefKind ref
, "hash: " <> objectRefHash ref
]
decodeObjectRef :: Text -> Maybe ObjectRef
decodeObjectRef txt = do
kind <- lookupField "kind" fields
hash <- lookupField "hash" fields
return ObjectRef { objectRefKind = kind, objectRefHash = hash }
where
fields = map parseLine (Text.lines txt)
parseLine line =
let (k, rest) = Text.breakOn ":" line
in (Text.strip k, Text.strip (Text.drop 1 rest))
lookupField key = lookup key

View File

@@ -0,0 +1,94 @@
module ContentStore.Arboricx
( merkleNodeDomain
, putNode
, getNode
, treeTermDomain
, encodeTreeTerm
, decodeTreeTerm
, putTreeTerm
, getTreeTerm
, putTree
, getTree
) where
import ContentStore.Filesystem
import ContentStore.Object
import Research
import qualified Data.ByteString as BS
merkleNodeDomain :: Domain
merkleNodeDomain = Domain "arboricx.merkle.node.v1"
treeTermDomain :: Domain
treeTermDomain = Domain "arboricx.tree-term.v1"
putNode :: StorePath -> Node -> IO ObjectHash
putNode store node = putObject store merkleNodeDomain (serializeNode node)
getNode :: StorePath -> ObjectHash -> IO (Maybe Node)
getNode store h = fmap deserializeNode <$> getObject store h
-- | Store a complete normal tree as one content object. Merkle nodes remain
-- available for DAG use cases, but module executable exports use this object
-- kind to avoid filesystem writes for every subtree of large normal forms.
encodeTreeTerm :: T -> BS.ByteString
encodeTreeTerm Leaf = BS.pack [0x00]
encodeTreeTerm (Stem t) = BS.cons 0x01 (encodeTreeTerm t)
encodeTreeTerm (Fork l r) = BS.cons 0x02 (encodeTreeTerm l <> encodeTreeTerm r)
decodeTreeTerm :: BS.ByteString -> Either String T
decodeTreeTerm payload = do
(term, rest) <- getTerm payload
if BS.null rest
then Right term
else Left "trailing bytes after tree term"
where
getTerm bs = case BS.uncons bs of
Nothing -> Left "unexpected end of tree term"
Just (0x00, rest) -> Right (Leaf, rest)
Just (0x01, rest) -> do
(child, afterChild) <- getTerm rest
Right (Stem child, afterChild)
Just (0x02, rest) -> do
(left, afterLeft) <- getTerm rest
(right, afterRight) <- getTerm afterLeft
Right (Fork left right, afterRight)
Just (tag, _) -> Left $ "unknown tree term tag: " ++ show tag
putTreeTerm :: StorePath -> T -> IO ObjectHash
putTreeTerm store = putObject store treeTermDomain . encodeTreeTerm
getTreeTerm :: StorePath -> ObjectHash -> IO (Maybe T)
getTreeTerm store h = do
mPayload <- getObject store h
case mPayload of
Nothing -> pure Nothing
Just payload -> case decodeTreeTerm payload of
Left err -> fail $ "invalid tree term " ++ show h ++ ": " ++ err
Right term -> pure (Just term)
putTree :: StorePath -> T -> IO ObjectHash
putTree store = go
where
go Leaf = putNode store NLeaf
go (Stem t) = do
child <- go t
putNode store (NStem child)
go (Fork l r) = do
left <- go l
right <- go r
putNode store (NFork left right)
getTree :: StorePath -> ObjectHash -> IO (Maybe T)
getTree store root = do
mNode <- getNode store root
case mNode of
Nothing -> return Nothing
Just node -> case node of
NLeaf -> return (Just Leaf)
NStem child -> fmap Stem <$> getTree store child
NFork left right -> do
ml <- getTree store left
mr <- getTree store right
return $ Fork <$> ml <*> mr

View File

@@ -0,0 +1,37 @@
module ContentStore.Bundle
( packBundleFromStore
, unpackBundleToStore
) where
import ContentStore.Arboricx
import ContentStore.Object
import Wire
import Control.Monad (forM)
import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Vector as V
-- | Pack named CAS tree terms into an indexed Arboricx transport bundle.
packBundleFromStore :: StorePath -> [(Text, ObjectHash)] -> IO Bundle
packBundleFromStore store exports = do
terms <- forM exports $ \(name, root) -> do
mt <- getTreeTerm store root
case mt of
Nothing -> fail $ "CAS tree term not found: " ++ show root
Just term -> return (name, term)
return (buildBundle terms)
-- | Unpack an indexed Arboricx transport bundle into CAS tree terms.
-- Returns each manifest export name paired with its stored CAS tree-term hash.
unpackBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)]
unpackBundleToStore store bs = case decodeBundle bs of
Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore decode: " ++ err
Right bundle -> case verifyBundle bundle of
Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore verify: " ++ err
Right () -> do
let terms = reconstructBundleTerms (bundleNodes bundle)
forM (manifestExports $ bundleManifest bundle) $ \exported -> do
let term = terms V.! fromIntegral (exportRoot exported)
root <- putTreeTerm store term
return (exportName exported, root)

View File

@@ -0,0 +1,60 @@
module ContentStore.Filesystem
( putObject
, getObject
, objectPath
, ensureStore
) where
import ContentStore.Object
import Control.Monad (unless, when)
import Data.Text (unpack)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
import System.FilePath ((</>))
import System.IO (hClose, openBinaryTempFile)
import qualified Data.ByteString as BS
ensureStore :: StorePath -> IO ()
ensureStore (StorePath root) = do
createDirectoryIfMissing True (root </> "objects")
createDirectoryIfMissing True (root </> "aliases" </> "names")
createDirectoryIfMissing True (root </> "aliases" </> "modules")
createDirectoryIfMissing True (root </> "aliases" </> "packages")
createDirectoryIfMissing True (root </> "manifests")
createDirectoryIfMissing True (root </> "tmp")
objectPath :: StorePath -> ObjectHash -> FilePath
objectPath (StorePath root) h = root </> "objects" </> shardForHash h </> unpack h
putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash
putObject store@(StorePath root) domain payload = do
ensureStore store
let h = hashObject domain payload
shardDir = root </> "objects" </> shardForHash h
finalPath = objectPath store h
createDirectoryIfMissing True shardDir
exists <- doesFileExist finalPath
if exists
then verifyExisting finalPath
else do
let tmpDir = root </> "tmp"
(tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp")
BS.hPut handle payload
hClose handle
raced <- doesFileExist finalPath
if raced
then removeFile tmpPath >> verifyExisting finalPath
else renameFile tmpPath finalPath
return h
where
verifyExisting path = do
existing <- BS.readFile path
when (existing /= payload) $
fail $ "content-addressed object exists with mismatched bytes: " ++ path
getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString)
getObject store h = do
let path = objectPath store h
exists <- doesFileExist path
if exists then Just <$> BS.readFile path else return Nothing

View File

@@ -0,0 +1,45 @@
module ContentStore.Object
( Domain(..)
, ObjectHash
, StorePath(..)
, hashObject
, hashToText
, textToHashBytes
, shardForHash
) where
import Crypto.Hash (Digest, SHA256, hash)
import Data.ByteArray (convert)
import Data.ByteString.Base16 (decode, encode)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.ByteString as BS
import qualified Data.Text as T
newtype Domain = Domain { unDomain :: Text }
deriving (Eq, Ord, Show)
type ObjectHash = Text
newtype StorePath = StorePath { unStorePath :: FilePath }
deriving (Eq, Ord, Show)
hashObject :: Domain -> BS.ByteString -> ObjectHash
hashObject (Domain domain) payload = hashToText digest
where
digest :: Digest SHA256
digest = hash (encodeUtf8 domain <> BS.pack [0x00] <> payload)
hashToText :: Digest SHA256 -> Text
hashToText = decodeUtf8 . encode . (convert :: Digest SHA256 -> BS.ByteString)
textToHashBytes :: Text -> Either String BS.ByteString
textToHashBytes h = case decode (encodeUtf8 h) of
Left _ -> Left "invalid hexadecimal hash"
Right raw
| BS.length raw == 32 -> Right raw
| otherwise -> Left "hash must decode to 32 bytes"
shardForHash :: ObjectHash -> FilePath
shardForHash = T.unpack . T.take 3

Some files were not shown because too many files have changed in this diff Show More