commit 5b121fb0dc45bf191f4b3becd47dacb54c9851d2
parent f4ba8988bfed4e0f6b91023fe05793d2eb17d390
Author: James Eversole <james@eversole.co>
Date: Mon, 25 May 2026 12:43:15 -0500
Tricu 2.0.0
Sorry for squashing all of this but :shrug:
Diffstat:
105 files changed, 10156 insertions(+), 1955 deletions(-)
diff --git a/README.md b/README.md
@@ -2,7 +2,7 @@
## Introduction
-tricu (pronounced "tree-shoe") is an experimental programming language written in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf). I will refer to this "family" of calculi as TC.
+tricu (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)`.
@@ -37,23 +37,6 @@ tricu > "(t (t (t t) (t t t)) (t t (t t t)))"
tricu < -- or calculate its size (/demos/size.tri)
tricu < size not?
tricu > 12
-
-tricu < !help
-tricu version 1.1.0
-Available commands:
- !exit - Exit the REPL
- !clear - Clear the screen
- !reset - Reset preferences for selected versions
- !help - Show tricu version and available commands
- !output - Change output format (tree|fsl|ast|ternary|ascii|decode)
- !definitions - List all defined terms in the content store
- !import - Import definitions from file to the content store
- !watch - Watch a file for changes, evaluate terms, and store them
- !versions - Show all versions of a term by name
- !select - Select a specific version of a term for subsequent lookups
- !tag - Add or update a tag for a term by hash or name
- !export - Export a term bundle to file (hash, file)
- !bundleimport- Import a bundle file into the content store
```
## Installation and Use
@@ -69,4 +52,67 @@ You can easily build and run this project using [Nix](https://nixos.org/download
## Usage
-I'll update this once the CLI stabilizes more.
+### CLI
+
+Evaluate one or more files:
+
+```sh
+tricu eval program.tri
+tricu eval --format decode program.tri
+tricu eval --output result.txt program.tri
+```
+
+Annotated programs run normally under `eval`; annotations are metadata, not
+runtime types. If you want evaluation to ignore View Contracts completely while
+loading workspace modules, use unchecked mode:
+
+```sh
+tricu eval --unchecked program.tri
+```
+
+Unchecked eval parses annotation syntax, discards contract metadata, skips
+producer-side View Contract checks during workspace module auto-builds, and does
+not publish unchecked View refs. Executable module exports may still be cached in
+the content store.
+
+Check View Contract annotations explicitly:
+
+```sh
+tricu check program.tri
+tricu check --store ./.tricu-store program.tri
+```
+
+Compile/import/export Arboricx bundles:
+
+```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
+```
+
+Inspect store aliases:
+
+```sh
+tricu store alias list --kind modules
+tricu store alias get --kind modules prelude
+```
+
+### 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
+!check FILE run View Contract checking for a file
+!store [PATH] show or set the content-addressed store
+!unchecked on evaluate loaded files without contract checking/publishing refs
+!unchecked off return to normal producer-checked module loading
+!format decode set output format by name
+!env list current in-memory bindings
+```
+
+`!load` and `!check` support filename tab completion. Normal REPL input also
+supports tab completion for names currently in the REPL environment.
diff --git a/demos/equality.tri b/demos/equality.tri
@@ -1,4 +1,4 @@
-!import "../lib/prelude.tri" !Local
+!import "prelude" !Local
main = lambdaEqualsTC
diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri
@@ -1,5 +1,5 @@
-!import "../lib/prelude.tri" !Local
-!import "../lib/io.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
-- Interaction Tree Effect Runtime
--
diff --git a/demos/interactionTrees/arboricxServer.tri b/demos/interactionTrees/arboricxServer.tri
@@ -1,5 +1,6 @@
-!import "../../lib/io.tri" !Local
-!import "../../lib/arboricx/server.tri" !Local
+!import "base" !Local
+!import "io" !Local
+!import "arboricx.server" !Local
-- Arboricx HTTP registry server demo.
-- Run with --allow-write ./store --allow-read ./store
diff --git a/demos/interactionTrees/echoServer.tri b/demos/interactionTrees/echoServer.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/io.tri" !Local
-!import "../../lib/socket.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
+!import "socket" !Local
-- Main accept+echo loop. Recursion via y.
echoLoop = y (self : server :
diff --git a/demos/interactionTrees/environment.tri b/demos/interactionTrees/environment.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Environment effects: ask and local.
-- ask reads the current environment value.
diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Basic fork and await.
-- fork spawns a concurrent task and returns a handle.
diff --git a/demos/interactionTrees/getLineAsync.tri b/demos/interactionTrees/getLineAsync.tri
@@ -12,7 +12,8 @@
-- 3. You see:
-- Hello, <name>!
-!import "../lib/io.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
main = io <|
bind (fork getLine) (h :
diff --git a/demos/interactionTrees/greet.tri b/demos/interactionTrees/greet.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Greet and return a pure value.
-- putStrLn writes to stdout; pure lifts "done" into IO.
diff --git a/demos/interactionTrees/httpServer.tri b/demos/interactionTrees/httpServer.tri
@@ -1,7 +1,7 @@
-!import "../lib/prelude.tri" !Local
-!import "../lib/io.tri" !Local
-!import "../lib/socket.tri" !Local
-!import "../lib/http.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
+!import "socket" !Local
+!import "http" !Local
myRouter = (method path headers body :
matchBool
diff --git a/demos/interactionTrees/safeRead.tri b/demos/interactionTrees/safeRead.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- readFile returns a Result. matchResult branches on ok / err.
-- Run with --allow-read PATH or --unsafe-io.
diff --git a/demos/interactionTrees/shout.tri b/demos/interactionTrees/shout.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Transform an IO result.
-- mapIO applies a pure function to the value produced by an action.
diff --git a/demos/interactionTrees/state.tri b/demos/interactionTrees/state.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Mutable state via get and put.
-- get reads the current state.
diff --git a/demos/interactionTrees/writeThenRead.tri b/demos/interactionTrees/writeThenRead.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Write a file, then read it back.
-- thenIO discards the writeFile Result and continues.
diff --git a/demos/interactionTrees/yield.tri b/demos/interactionTrees/yield.tri
@@ -1,6 +1,6 @@
-!import "../../lib/base.tri" !Local
-!import "../../lib/list.tri" !Local
-!import "../../lib/io.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "io" !Local
-- Cooperative scheduling with yield.
-- yield returns control to the scheduler so other tasks can run.
diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri
@@ -1,4 +1,4 @@
-!import "../lib/prelude.tri" !Local
+!import "prelude" !Local
main = exampleTwo
-- Level Order Traversal of a labelled binary tree
diff --git a/demos/patternMatching.tri b/demos/patternMatching.tri
@@ -1,4 +1,4 @@
-!import "../lib/patterns.tri" !Local
+!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
diff --git a/demos/runArboricxBundle.tri b/demos/runArboricxBundle.tri
@@ -1,6 +1,6 @@
-!import "../lib/prelude.tri" !Local
-!import "../lib/io.tri" !Local
-!import "../lib/arboricx/arboricx.tri" !Local
+!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
diff --git a/demos/size.tri b/demos/size.tri
@@ -1,4 +1,4 @@
-!import "../lib/prelude.tri" !Local
+!import "prelude" !Local
main = size size
diff --git a/demos/toSource.tri b/demos/toSource.tri
@@ -1,4 +1,4 @@
-!import "../lib/prelude.tri" !Local
+!import "prelude" !Local
main = toSource not?
-- Thanks to intensionality, we can inspect the structure of a given value
diff --git a/demos/viewContracts.tri b/demos/viewContracts.tri
@@ -0,0 +1,190 @@
+!import "prelude" !Local
+!import "view" !Local
+
+-- ============================================================================
+-- View Contracts in tricu
+-- ============================================================================
+--
+-- Verify this guide passes checking with:
+--
+-- tricu check demos/viewContracts.tri
+--
+-- Expected output:
+--
+-- ok
+--
+-- This file uses tricu syntax sugar. The lower-level portable View Tree
+-- form is shown in demos/viewContracts/complete.tri.
+
+-- ============================================================================
+-- 1. What's the problem?
+-- ============================================================================
+--
+-- Programs grow by connecting definitions. A common mistake is connecting a
+-- value with one shape to code that expects another shape:
+--
+-- a function expects Bool, but receives String
+-- a function returns String, but its caller expects Bool
+-- a list is expected to contain bytes, but contains strings
+--
+-- In a large program, those mistakes are often far away from where the bad value
+-- was first introduced. View Contracts give tricu a portable way to check those
+-- boundaries.
+
+-- ============================================================================
+-- 2. Views: useful built-in shapes
+-- ============================================================================
+--
+-- A View is a description of the shape we expect at a boundary. tricu includes
+-- built-in Views for common shapes such as:
+--
+-- Bool
+-- String
+-- Byte
+-- Unit
+-- List View
+-- Maybe View
+-- Pair View1 View2
+-- Fn [View1] View2
+--
+-- tricu has unconventional but intuitive sugar for annotations:
+--
+-- name =@View value
+-- function argument@View =@ResultView body
+--
+-- These examples are ordinary checked source definitions.
+
+message =@String "hello"
+
+names =@(List String) [("Ada") ("Grace")]
+
+chooseFirst left@String right@String =@String left
+
+stringIdentity =@(Fn [String] String) (x : x)
+
+-- Uncommenting the below definition demonstrates a plain View mismatch:
+--
+-- bad =@Bool "not a Bool"
+--
+-- `tricu check` reports that the value is known as String where Bool was
+-- required.
+
+-- ============================================================================
+-- 3. Why don't you just have Types?
+-- ============================================================================
+--
+-- tricu is built on Tree Calculus. A defining feature of Tree Calculus is
+-- intensionality: programs can inspect and construct program-shaped trees directly.
+-- That intensional power is useful, but it makes ordinary sound static typing a
+-- hard fit. A value can be both data and executable structure, and code can make
+-- decisions based on tree shape in ways a conventional type checker may not be
+-- able to predict soundly. This is an area of active research, not a settled
+-- claim that Tree Calculus languages cannot ever have useful typed variants.
+--
+-- View Contracts are not advertised as "the type system for tricu". They are
+-- a practical contract layer: portable metadata plus checker/runtime boundaries
+-- that catch many real mistakes while leaving the underlying language intact.
+
+-- For more information about sound typing for Tree Calculus:
+-- https://github.com/barry-jay-personal/typed_tree_calculus
+
+-- ============================================================================
+-- 4. What are the Contracts about, then?
+-- ============================================================================
+--
+-- `List String` tells us that every element is a String. It does not tell us the
+-- list has at least one element.
+--
+-- That matters for functions like `head`. Calling `head` on an empty list is a
+-- bug. We want to express the stronger requirement:
+--
+-- this is a List String, and it is non-empty
+--
+-- That is what a guarded View is for.
+
+-- A guard is ordinary tricu code. It receives the runtime value and returns:
+--
+-- guardOk value -- accept the value
+-- guardFail -- reject the boundary
+--
+-- The guard does not write diagnostics. The checked runner reports where the
+-- failing boundary came from.
+
+requireNonEmpty = (xs :
+ lazyBool
+ (_ : guardFail)
+ (_ : guardOk xs)
+ (emptyList? xs))
+
+-- A user-defined View can be parameterized just like an ordinary function.
+--
+-- NonEmptyList String
+--
+-- means "a List String guarded by requireNonEmpty".
+
+NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty
+
+-- ============================================================================
+-- 5. Using a custom View in normal annotations
+-- ============================================================================
+--
+-- This value satisfies the custom contract.
+
+contributors =@(NonEmptyList String) [("Ada") ("Grace")]
+
+-- This function requires NonEmptyList String before its body can run. In a
+-- library, this is the kind of contract you would put on an operation like
+-- `head`: callers must prove the list is non-empty first.
+
+acceptNames xs@(NonEmptyList String) =@String "accepted non-empty names"
+
+primaryContributor =@String acceptNames contributors
+
+-- Uncommenting this definition demonstrates a guarded View failure:
+--
+-- nobody =@(NonEmptyList String) []
+--
+-- The structure is fine (`[]` is a List String), but the runtime guard rejects
+-- it because the list is empty.
+
+-- ============================================================================
+-- 6. Contracts protect callers too
+-- ============================================================================
+--
+-- Contracts can describe function results as well as arguments. If a function
+-- promises to return `NonEmptyList String`, checked execution guards that result
+-- before callers depend on it.
+
+mkContributors name@String =@(NonEmptyList String) [(name)]
+
+fromSingleName =@String acceptNames (mkContributors "Evelyn")
+
+-- Uncommenting this version would fail because the result contract is too
+-- strong for the implementation:
+--
+-- badContributors name@String =@(NonEmptyList String) []
+
+-- ============================================================================
+-- 7. Writing your own Views and Contracts
+-- ============================================================================
+--
+-- The pattern is:
+--
+-- 1. Start with the closest structural View.
+-- 2. Write a guard for the runtime fact the structure cannot express.
+-- 3. Package them with viewGuarded.
+-- 4. Use the new View in normal annotations.
+--
+-- Examples of useful guarded Views:
+--
+-- NonEmptyList String
+-- SortedList Byte
+-- FixedLengthBytes 32
+-- ValidUserId
+-- NonEmptyString
+--
+-- Guards are intentionally runtime checks. Use plain Views for ordinary shape
+-- checking, and guarded Views when a boundary really must enforce a stronger
+-- invariant.
+
+main =@String primaryContributor
diff --git a/demos/viewContracts/README.md b/demos/viewContracts/README.md
@@ -0,0 +1,137 @@
+# View Contract Demos
+
+These demos exercise the finalized View Contract stack in `lib/view.tri`:
+portable View Trees/checkable typed-program nodes, structural View flow checks,
+runtime guarded Views, checked-exec, source annotations, and module-boundary
+View metadata.
+
+## End-user guide
+
+Start here. `demos/viewContracts.tri` is written with normal source annotation
+sugar and reads as a short guide to View Contracts: motivating structural
+mismatches, explaining plain Views, noting why this is not a full static type
+system, and building a custom `NonEmptyList` guarded View.
+
+```bash
+tricu check demos/viewContracts.tri
+```
+
+Expected output:
+
+```text
+ok
+```
+
+## Complete explicit demo
+
+`demos/viewContracts/complete.tri` shows the same layer from the portable
+View Tree/checkable-program side. It uses explicit builders such as
+`typedValue`, `typedRequire`, and `typedApply`, and demonstrates contextual guard
+diagnostics, observation composition, reachability, and malformed guard output.
+
+```bash
+tricu eval demos/viewContracts/complete.tri -f decode
+```
+
+## Portable checker self-tests
+
+Runs the checker self-test suite carried as ordinary `tricu` code.
+
+```bash
+tricu eval demos/viewContracts/selfTests.tri -f decode
+```
+
+Expected output is a list of `"ok"` strings.
+
+## Diagnostic rendering
+
+Shows a strict-mode structural View failure rendered for humans.
+
+```bash
+tricu eval demos/viewContracts/diagnostic.tri -f decode
+```
+
+Expected output:
+
+```text
+"symbol 162 expected List Bool but got List String"
+```
+
+## Stdlib-shaped contracts
+
+Checks successful higher-order contracts shaped like common stdlib APIs.
+
+```bash
+tricu eval demos/viewContracts/stdlibContracts.tri -f decode
+```
+
+Expected output:
+
+```text
+["ok", "ok", "ok", "ok", "ok"]
+```
+
+These examples are structural View checks, not runtime guarded checks.
+
+## Frontend emission layer
+
+`frontendEmission/` documents the portable artifact shape a frontend can emit
+after parsing/elaboration. The `*.source.txt` files are pseudo-source; the
+matching `*.emitted.tri` files are explicit typed-program builder output.
+
+This layer is still instructive because it shows the exact bridge between source
+syntax and portable View Tree/checkable metadata.
+
+## Source syntax sugar
+
+The `sourceSyntax/` demos use ergonomic annotations and the `tricu check`
+frontend. The frontend lowers annotations to the same typed-program nodes used by
+the explicit demos above, then executes checked-exec so guarded annotations fail
+through the portable runner.
+
+Successful check:
+
+```bash
+tricu check demos/viewContracts/sourceSyntax/success.tri
+```
+
+Expected output:
+
+```text
+ok
+```
+
+Labeled diagnostic check:
+
+```bash
+tricu check demos/viewContracts/sourceSyntax/failure.tri
+```
+
+Expected first failing diagnostic:
+
+```text
+symbol 4 (x) expected Bool but got String
+```
+
+If the first definition is fixed or removed, the later application-result
+failure demonstrates callee-aware labels:
+
+```text
+symbol 3 (g application result) expected String but got Bool
+```
+
+## Module boundary layer
+
+`modules/` shows producer-checked module export Views flowing into a consumer
+check as module-boundary evidence. During auto-build, annotated exports are
+checked before the module manifest alias is published. Consumers then use the
+manifest's View Contract metadata as assumptions, while compatibility is still
+judged by `lib/view.tri`.
+
+```bash
+tricu check demos/viewContracts/modules/success.tri
+# ok
+
+tricu check demos/viewContracts/modules/failure.tri
+# symbol 3 (Util.toString application result) expected Bool but got String
+```
diff --git a/demos/viewContracts/complete.tri b/demos/viewContracts/complete.tri
@@ -0,0 +1,119 @@
+!import "prelude" !Local
+!import "view" !Local
+
+-- Complete explicit View Contract demo.
+-- Run with: tricu eval demos/viewContracts/complete.tri -f decode
+--
+-- This file uses the low-level portable typed-program builders directly. It is
+-- useful for understanding what source annotations lower to. For the end-user
+-- guide, see demos/viewContracts.tri.
+
+requireNonEmpty = (xs :
+ lazyBool
+ (_ : guardFail)
+ (_ : guardOk xs)
+ (emptyList? xs))
+
+NonEmptyList = (elemView :
+ viewGuarded (viewList elemView) requireNonEmpty)
+
+checkedResult = (result :
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (exec env :
+ matchResult
+ (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag)
+ (value runtimeEnv : value)
+ (runChecked exec))
+ result)
+
+checkedContract = (program :
+ checkedResult (checkTypedProgramWith policyStrict program))
+
+plainViewFailure =
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (exec env : "unexpected-ok")
+ (checkTypedProgramWith
+ policyStrict
+ (typedProgram
+ 0
+ [(typedValue 0 (viewList viewString) [("Ada")])
+ (typedRequire 0 (viewList viewBool) t)]))
+
+nonEmptyRootSuccess =
+ matchBool
+ "ok"
+ "unexpected-value"
+ (equal?
+ (checkedContract
+ (typedProgram
+ 0
+ [(typedValue 0 (NonEmptyList viewString) [("Ada") ("Grace")])]))
+ [("Ada") ("Grace")])
+
+nonEmptyRootFailure =
+ checkedContract
+ (typedProgram
+ 0
+ [(typedValue 0 (viewList viewString) [])
+ (typedRequire 0 (NonEmptyList viewString) [])])
+
+firstNameSuccess =
+ checkedContract
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs))
+ (typedValue 1 (viewList viewString) [("Ada") ("Grace")])
+ (typedApply 2 0 1 "Ada")
+ (typedRequire 2 viewString "Ada")])
+
+firstNameFailure =
+ checkedContract
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs))
+ (typedValue 1 (viewList viewString) [])
+ (typedApply 2 0 1 t)
+ (typedRequire 2 viewString t)])
+
+resultGuardFailure =
+ checkedContract
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewString)] (NonEmptyList viewString)) (name : []))
+ (typedValue 1 viewString "Ada")
+ (typedApply 2 0 1 [])])
+
+observationComposition =
+ checkedContract
+ (typedProgram
+ 0
+ [(typedValue 0 viewString "Ada")
+ (typedRequire 0 (viewGuarded viewString (x : guardOk (append x " Lovelace"))) "Ada")
+ (typedRequire 0 (viewGuarded viewString (x : guardOk (append x "!"))) "Ada")])
+
+unreachableGuard =
+ checkedContract
+ (typedProgram
+ 0
+ [(typedValue 0 viewString "only the root is checked")
+ (typedValue 1 (viewList viewString) [])
+ (typedRequire 1 (NonEmptyList viewString) [])])
+
+malformedGuard =
+ checkedContract
+ (typedProgram
+ 0
+ [(typedValue 0 (viewGuarded viewString (x : record 99 t)) "bad guard")])
+
+main = [
+ (append "plain View structural failure: " plainViewFailure)
+ (append "NonEmptyList root success: " nonEmptyRootSuccess)
+ (append "NonEmptyList root failure: " nonEmptyRootFailure)
+ (append "NonEmptyList function argument success: " firstNameSuccess)
+ (append "NonEmptyList function argument failure: " firstNameFailure)
+ (append "NonEmptyList function result failure: " resultGuardFailure)
+ (append "guard observations compose: " observationComposition)
+ (append "unreachable guard does not run: " unreachableGuard)
+ (append "malformed guard result: " malformedGuard)]
diff --git a/demos/viewContracts/diagnostic.tri b/demos/viewContracts/diagnostic.tri
@@ -0,0 +1,9 @@
+!import "prelude" !Local
+!import "view" !Local
+!import "views.catalog" !Local
+
+main =
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (env rest : "ok")
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract)
diff --git a/demos/viewContracts/frontendEmission/README.md b/demos/viewContracts/frontendEmission/README.md
@@ -0,0 +1,116 @@
+# Frontend Emission Demos
+
+These examples show the layer between source-level View annotations and the
+portable View Contract checker.
+
+Each `*.source.txt` file is pseudo-source: it is not parsed by `tricu`. It shows
+the information a frontend has after parsing/elaboration.
+
+Each matching `*.emitted.tri` file shows the lowered typed-program metadata that
+a frontend can emit today. A successful check returns checked-exec; these demos
+focus on structural Views, so they report `"ok"` as soon as metadata checking
+succeeds. Guarded programs should run the returned checked-exec with
+`runChecked`, as shown in `demos/viewContracts.tri` and by `tricu check`.
+
+## Successful map use
+
+Pseudo-source:
+
+```text
+map : Fn [Fn [Bool] String, List Bool] (List String)
+f : Fn [Bool] String
+xs : List Bool
+
+partial = map f
+out = partial xs
+
+require out : List String
+```
+
+Run the emitted artifact:
+
+```bash
+tricu eval demos/viewContracts/frontendEmission/map-success.emitted.tri -f decode
+```
+
+Expected output:
+
+```text
+"ok"
+```
+
+## Wrong list argument
+
+Pseudo-source:
+
+```text
+map : Fn [Fn [Bool] String, List Bool] (List String)
+f : Fn [Bool] String
+xs : List String
+
+partial = map f
+out = partial xs
+```
+
+Run:
+
+```bash
+tricu eval demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri -f decode
+```
+
+Expected output:
+
+```text
+"symbol 162 expected List Bool but got List String"
+```
+
+## Wrong filter predicate
+
+Pseudo-source:
+
+```text
+filter : Fn [Fn [Bool] Bool, List Bool] (List Bool)
+pred : Fn [Bool] String
+xs : List Bool
+
+partial = filter pred
+out = partial xs
+```
+
+Run:
+
+```bash
+tricu eval demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri -f decode
+```
+
+Expected output:
+
+```text
+"symbol 181 expected Fn [Bool] Bool but got Fn [Bool] String"
+```
+
+## Lowering shape
+
+A frontend does not need to expose `tricu` syntax internally. It only needs to
+emit portable typed-program nodes:
+
+```text
+typedValue symbol view term
+typedApply out callee arg term
+typedRequire symbol view term
+```
+
+The source-level flow:
+
+```text
+out = map f xs
+```
+
+lowers to curried Tree Calculus application nodes:
+
+```text
+typedApply partial map f partialTerm
+typedApply out partial xs outTerm
+```
+
+Function Views drive argument checking and result inference.
diff --git a/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri b/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri
@@ -0,0 +1,17 @@
+!import "prelude" !Local
+!import "view" !Local
+!import "views.catalog" !Local
+
+-- Lowering of filter-wrong-predicate.source.txt to portable typed-program metadata.
+-- Symbols:
+-- 180 filter
+-- 181 pred
+-- 182 partial
+
+program = listFilterWrongPredicateContract
+
+main =
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (env rest : "unexpected-ok")
+ (checkTypedProgramWith policyStrict program)
diff --git a/demos/viewContracts/frontendEmission/map-success.emitted.tri b/demos/viewContracts/frontendEmission/map-success.emitted.tri
@@ -0,0 +1,20 @@
+!import "prelude" !Local
+!import "view" !Local
+!import "views.catalog" !Local
+
+-- Lowering of map-success.source.txt to portable typed-program metadata.
+-- Symbols:
+-- 100 map
+-- 101 f
+-- 102 xs
+-- 103 partial
+-- 104 out
+
+program =
+ listMapUseContract viewBool viewString 100 101 102 103 104
+
+main =
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (env rest : "ok")
+ (checkTypedProgramWith policyStrict program)
diff --git a/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri b/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri
@@ -0,0 +1,19 @@
+!import "prelude" !Local
+!import "view" !Local
+!import "views.catalog" !Local
+
+-- Lowering of map-wrong-list.source.txt to portable typed-program metadata.
+-- Symbols:
+-- 160 map
+-- 161 f
+-- 162 xs
+-- 163 partial
+-- 164 out
+
+program = listMapWrongListArgContract
+
+main =
+ matchResult
+ (diag env : renderDiagnostic diag)
+ (env rest : "unexpected-ok")
+ (checkTypedProgramWith policyStrict program)
diff --git a/demos/viewContracts/io-continuation.tri b/demos/viewContracts/io-continuation.tri
@@ -0,0 +1,30 @@
+!import "prelude" !Local
+!import "io" !Local
+!import "view" !Local
+
+-- View Contracts inside IO continuations
+-- Run with:
+--
+-- tricu eval demos/viewContracts/io-continuation.tri --io -f decode
+--
+-- Checked IO evaluation instruments continuation bodies once from source
+-- annotations. The IO runtime still executes ordinary interaction-tree actions;
+-- the returned continuations already contain the checked-exec guard boundaries.
+
+requireNonEmpty = (xs :
+ lazyBool
+ (_ : guardFail)
+ (_ : guardOk xs)
+ (emptyList? xs))
+
+NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty
+
+acceptNames xs@(NonEmptyList String) =@String "accepted"
+
+useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String
+ handler xs
+
+-- The IO action yields an empty list. The higher-order boundary requires a
+-- handler that accepts NonEmptyList String, so the continuation-internal pure
+-- call fails before returning the next IO value.
+main = io (bind (pure []) (xs : pure (useHandler acceptNames xs)))
diff --git a/demos/viewContracts/io.tri b/demos/viewContracts/io.tri
@@ -0,0 +1,51 @@
+!import "prelude" !Local
+!import "io" !Local
+!import "view" !Local
+
+-- View Contracts + IO interaction trees
+-- Run with:
+--
+-- tricu eval demos/viewContracts/io.tri --io -f decode
+--
+-- The IO runtime expects the top-level value to be an interaction tree wrapped
+-- by the `io` sentinel:
+--
+-- pair "tricuIO" (pair version action)
+--
+-- View Contracts can validate that boundary before the IO driver starts. The IO
+-- value is still just an interaction tree; this demo only checks how it was
+-- exposed.
+
+ioSentinel? = (value :
+ and?
+ (equal? (fst value) "tricuIO")
+ (equal? (fst (snd value)) 1))
+
+requireIO = (value :
+ lazyBool
+ (_ : guardOk value)
+ (_ : guardFail)
+ (ioSentinel? value))
+
+-- A first useful IO View is intentionally shallow:
+--
+-- viewAny -- accept any payload structurally
+-- requireIO sentinel -- require the top-level IO wrapper at runtime
+--
+-- This does not prove every future continuation step is well-formed. It proves
+-- the checked program exposes an IO interaction tree to the host driver.
+viewIO = viewGuarded viewAny requireIO
+
+checkedIO = (action :
+ matchResult
+ (diag env : io (pure (renderDiagnostic diag)))
+ (exec env :
+ matchResult
+ (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag)))
+ (value runtimeEnv : value)
+ (runChecked exec))
+ (checkTypedProgramWith
+ policyStrict
+ (typedProgram 0 [(typedValue 0 viewIO action)])))
+
+main = checkedIO (io (pure "checked interaction tree"))
diff --git a/demos/viewContracts/modules/README.md b/demos/viewContracts/modules/README.md
@@ -0,0 +1,17 @@
+# Module View Contract demo
+
+This demo shows producer-checked module export Views flowing into a consumer
+check as trusted View Contract evidence.
+
+```sh
+tricu check demos/viewContracts/modules/success.tri
+# ok
+
+tricu check demos/viewContracts/modules/failure.tri
+# symbol 3 (Util.toString application result) expected Bool but got String
+```
+
+`util.tri` is a local workspace module. During auto-build, its annotated exports
+are checked before the module manifest alias is published. The consumer then
+uses the manifest's View Contract metadata and View Tree export artifacts as
+module-boundary assumptions; compatibility is still judged by `lib/view.tri`.
diff --git a/demos/viewContracts/modules/failure.tri b/demos/viewContracts/modules/failure.tri
@@ -0,0 +1,3 @@
+!import "vc.demo.util" Util
+
+foo x@Bool =@Bool Util.toString x
diff --git a/demos/viewContracts/modules/success.tri b/demos/viewContracts/modules/success.tri
@@ -0,0 +1,3 @@
+!import "vc.demo.util" Util
+
+foo x@Bool =@Bool Util.id x
diff --git a/demos/viewContracts/modules/tricu.workspace b/demos/viewContracts/modules/tricu.workspace
@@ -0,0 +1 @@
+module vc.demo.util = util.tri
diff --git a/demos/viewContracts/modules/util.tri b/demos/viewContracts/modules/util.tri
@@ -0,0 +1,2 @@
+id x@Bool =@Bool x
+toString x@Bool =@String "ok"
diff --git a/demos/viewContracts/selfTests.tri b/demos/viewContracts/selfTests.tri
@@ -0,0 +1,3 @@
+!import "views.catalog" !Local
+
+main = viewCatalogSelfTests
diff --git a/demos/viewContracts/sourceSyntax/failure.tri b/demos/viewContracts/sourceSyntax/failure.tri
@@ -0,0 +1,9 @@
+-- Source-level View Contract diagnostic demo.
+-- Run with: tricu check demos/viewContracts/sourceSyntax/failure.tri
+
+makeBool x@String =@Bool x
+
+xs =@(List String) [(g "hi")]
+g y@String =@Bool y
+
+main = "if you're seeing this instead of an error, you ran the file unchecked"
diff --git a/demos/viewContracts/sourceSyntax/success.tri b/demos/viewContracts/sourceSyntax/success.tri
@@ -0,0 +1,10 @@
+-- Source-level View Contract syntax sugar demo.
+-- Run with: tricu check demos/viewContracts/sourceSyntax/success.tri
+
+message =@String "hello"
+
+boxedMessages =@(Maybe (List String)) just [(message) ("world")]
+
+chooseFirst x@String y@Byte =@String x
+
+fromLambda =@(Fn [String] String) (x : x)
diff --git a/demos/viewContracts/stdlibContracts.tri b/demos/viewContracts/stdlibContracts.tri
@@ -0,0 +1,10 @@
+!import "prelude" !Local
+!import "view" !Local
+!import "views.catalog" !Local
+
+main = [
+ (typedContractCheck listMapBoolStringContract)
+ (typedContractCheck headMaybeBoolContract)
+ (typedContractCheck listFilterBoolContract)
+ (typedContractCheck listFoldStringBoolContract)
+ (typedContractCheck listMapMaybeBoolStringContract)]
diff --git a/docs/content-store-and-module-format.md b/docs/content-store-and-module-format.md
@@ -0,0 +1,596 @@
+# 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;
+- View 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.
+
+View 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;
+- View 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>
+ view: optional
+ kind: <view artifact kind>
+ hash: <view artifact hash>
+ catalog: optional
+ kind: <view catalog kind>
+ hash: <view catalog 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 View Contract:
+
+```text
+name: "map"
+object:
+ kind: arboricx.tree-term.v1
+ hash: <whole-term hash>
+ abi: arboricx.abi.tree.v1
+view:
+ kind: arboricx.view-contract.type.v1
+ hash: <view type 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
+View Contract checking receive direct `arboricx.view-contract.type.v1` 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. View Contract Artifacts
+
+View Contract artifacts are portable Arboricx-layer data. They may be stored
+as content objects and referenced by module exports. `tricu` may emit these
+objects, but the object kind is not tricu-specific.
+
+Current artifact kind:
+
+```text
+arboricx.view-contract.type.v1
+```
+
+`arboricx.view-contract.type.v1` is the direct export-view artifact. Its
+payload is a canonical prefix binary encoding of the syntactic ViewType:
+
+```text
+Name = 0x00 u32be(byte-length) utf8-name
+Ref = 0x01 u32be(byte-length) utf8-ref
+List = 0x02 ViewType
+Maybe = 0x03 ViewType
+Pair = 0x04 ViewType ViewType
+Result = 0x05 ViewType ViewType
+Fn = 0x06 u32be(argument-count) ViewType* ViewType
+```
+
+`utf8-ref` is tagged text:
+
+```text
+i:<decimal-integer> numeric/legacy ref
+s:<text> symbolic user ref
+```
+
+Symbolic refs are the preferred user-authored form; numeric refs remain useful
+for generated code, fixtures, and old low-level examples.
+
+The object hash domain is the object kind:
+
+```text
+arboricx.view-contract.type.v1 \0 <payload>
+```
+
+### 9.1 Export-level pairing
+
+The module manifest is the canonical pairing of an executable export and its
+advertised contract:
+
+```text
+export name -> tree-term hash + optional view artifact hash
+```
+
+This avoids drift such as:
+
+```text
+map -> tree A
+map.view -> contract B
+```
+
+where aliases might be retargeted independently.
+
+### 9.2 Import checking
+
+When a source file imports a module, a frontend can resolve an imported export,
+decode its direct `arboricx.view-contract.type.v1` ref, and emit typed program
+evidence locally:
+
+```text
+imported List.map has view Fn [...]
+```
+
+For locally built workspace modules this is backed by producer-side checking
+before the module manifest alias is published, including imported view facts from
+dependencies used by the producer source. External or prebuilt manifests are
+trusted boundary declarations for now; they are not accompanied by proof objects.
+The checker still consumes only local numeric symbols and typed-program evidence.
+Global content hashes do not become checker symbols.
+
+Correct split:
+
+```text
+local checker symbol: 3
+presentation label: "List.map"
+resolved object: sha256:...
+exported view: Fn [...]
+```
+
+### 9.3 Execution hydration versus contract evidence
+
+Execution imports should use a narrow, demand-driven path:
+
+```text
+module import -> selected executable exports -> hydrate selected tree-term objects
+```
+
+This path should not compute a dependency closure over other module exports.
+Each selected executable export is already a complete Tree Calculus value.
+
+Contract-aware checking may use a broader path:
+
+```text
+module import -> selected exports -> exported view type refs -> typed-program evidence
+```
+
+That path emits portable evidence and leaves compatibility policy decisions to
+the Tree Calculus checker. typed programs and reusable catalogs do not need their
+own binary object kinds today: they are ordinary Tree Calculus data and can be
+stored as `arboricx.tree-term.v1` when persistence is useful.
+
+## 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;
+- View Contract checker evidence 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 View Contract artifacts 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 View
+ Contract 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 View Contracts a stable
+module/export attachment point without making the store `tricu`-specific.
diff --git a/docs/guard-injection.md b/docs/guard-injection.md
@@ -0,0 +1,371 @@
+# Guard Injection Semantics
+
+This document describes the runtime guard model for View Contracts.
+
+Views describe portable structural contracts. Guarded views refine those
+contracts with executable predicates while keeping ordinary value-level code free
+of `Maybe`, `Result`, sentinel, or host-language abort handling.
+
+```tri
+viewGuarded baseView guard
+```
+
+A guarded view means: when this guarded view is observed along the reachable
+checked-execution path, run `guard` against the runtime value.
+
+## Goals
+
+- Preserve ordinary value-level program shapes.
+- Keep guard failure out of user code.
+- Avoid Haskell-specific checker/runtime semantics.
+- Represent guard boundaries explicitly in portable tree data.
+- Make successful guarded execution transparent: guarded values are unwrapped
+ before ordinary code receives them.
+- Prefer correctness-by-default over avoiding repeated predicate cost.
+
+## Non-goals
+
+- Preventing user-written guards from diverging.
+- Letting guards author their own diagnostics.
+- Solving IO interaction-tree composition.
+- Finalizing long-term artifact identity policy.
+- Deduplicating or hoisting repeated guard checks.
+
+## Plain Views vs Guards
+
+Plain Views still provide concrete benefits without guards:
+
+- structural flow checking;
+- portable API metadata;
+- module/export contract metadata;
+- content-store view-tree metadata;
+- cross-frontend agreement on contract structure;
+- diagnostics for wrong-view flows.
+
+Guards are for invariants that require runtime value inspection, such as:
+
+- non-empty list;
+- sorted list;
+- byte string of exactly 32 bytes;
+- protocol payload with a valid checksum;
+- domain-specific runtime predicate.
+
+Guards are deliberately more expensive than ordinary Views. Use them when the
+runtime contract must be enforced.
+
+## Guard Result Protocol
+
+Guards return one of two standardized shapes:
+
+```tri
+guardOk value
+guardFail
+```
+
+Guards do not provide diagnostics. The checked-exec runner owns diagnostics.
+Malformed guard output is treated as a checked-runtime failure.
+
+## Checked Execution Protocol
+
+A successful typed-program check returns a checked-execution artifact, not a raw
+payload.
+
+Current constructors:
+
+```tri
+checkedPure value
+checkedFail diagnostic
+checkedGuard view guard value continuation
+checkedGuardWithContext context view guard value continuation
+checkedBind exec continuation
+```
+
+`checkedGuard` is the compatibility/default constructor. It lowers to
+`checkedGuardWithContext` with an unknown context. Checker-injected guard
+boundaries use `checkedGuardWithContext` so failures can identify where the
+boundary came from.
+
+Runner:
+
+```tri
+runChecked checkedExec
+```
+
+Semantics:
+
+```text
+runChecked (checkedPure value)
+ = checkedRuntimeOk value
+
+runChecked (checkedFail diagnostic)
+ = checkedRuntimeFail diagnostic
+
+runChecked (checkedGuardWithContext context view guard value continuation)
+ = case guard value of
+ guardOk checkedValue -> runChecked (continuation checkedValue)
+ guardFail -> checkedRuntimeFail (guardFailed context view)
+ malformed -> checkedRuntimeFail (malformedGuardResult context view malformed)
+
+runChecked (checkedGuard view guard value continuation)
+ = runChecked (checkedGuardWithContext unknownContext view guard value continuation)
+
+runChecked (checkedBind exec continuation)
+ = case runChecked exec of
+ checkedRuntimeOk value -> runChecked (continuation value)
+ checkedRuntimeFail diag -> checkedRuntimeFail diag
+```
+
+Important invariant:
+
+> Guard failure is consumed by `runChecked`. It is never passed into ordinary
+> user code.
+
+## Checker Result Shape
+
+`checkTypedProgramWith` returns checked-exec on success:
+
+```tri
+ok checkedExec env
+```
+
+Even unguarded programs return:
+
+```tri
+checkedPure rootPayload
+```
+
+Compatibility helper:
+
+```tri
+checkedProgramTree result
+```
+
+`checkedProgramTree` runs/unwraps checked-exec to preserve older raw-tree helper
+behavior.
+
+The Haskell `tricu check` path now evaluates successful checker output through
+`runChecked`, so source-level guarded annotations fail through the same portable
+checked-exec protocol.
+
+## Boundary Semantics
+
+Guard insertion follows correctness-first semantics:
+
+> Every guarded View observation on the reachable checked-execution path runs
+> its guard.
+
+Important boundary kinds:
+
+### Guarded typed value
+
+```tri
+typedValue sym (viewGuarded base guard) payload
+```
+
+This observes `sym` as a guarded value. It also supplies base-view evidence for
+flow checking.
+
+### Guarded requirement
+
+```tri
+typedRequire sym (viewGuarded base guard) payload
+```
+
+The symbol must satisfy `base`; the guarded observation is attached to `sym` and
+is enforced when `sym` is used or exposed along the reachable root path.
+
+### Guarded function argument
+
+For:
+
+```tri
+viewFn [(viewGuarded base guard)] result
+```
+
+application checking guards the argument before the callee receives it.
+
+### Guarded function result
+
+For:
+
+```tri
+viewFn [arg] (viewGuarded base guard)
+```
+
+application checking guards the application result before exposing it as the
+result value.
+
+### Guarded callee symbol
+
+If a function symbol itself has a guarded observation, that guard runs before the
+function value is applied. A successful guard may transform the function value;
+the application uses the guarded value.
+
+## Global Symbol Observations
+
+Guarded `typedValue` and `typedRequire` nodes are **global per-symbol
+observations**, not position-sensitive flow events.
+
+All guarded observations for a symbol compose in typed-node order whenever that
+symbol is used or exposed on the reachable checked-execution path.
+
+This means a later requirement still applies to an earlier syntactic use:
+
+```tri
+typedValue 1 viewString "x"
+typedApply 2 f 1 "x"
+typedRequire 1 (viewGuarded viewString guard) "x"
+```
+
+The guarded requirement is attached to symbol `1`; compiling the reachable root
+path that uses symbol `1` runs that guard.
+
+Rationale:
+
+- typed programs are declarative symbol graphs, not imperative event traces;
+- global observations are simpler and more correct-by-default;
+- producers cannot accidentally bypass a guard by ordering a requirement too
+ late;
+- staged raw/checked phases should use distinct symbols.
+
+## Reachability and Repetition
+
+Guards are not run eagerly for every guarded node in a program.
+
+Execution is root-reachable:
+
+```tri
+compileSymbol (typedProgramRoot program)
+```
+
+Only guarded observations reachable from the root checked-execution path run.
+Unreachable guarded symbols do not pay guard cost and do not fail execution.
+
+Repeated reachable uses rerun guards. There is currently no deduplication or
+hoisting. This is intentional: each guarded observation/use is a runtime contract
+boundary.
+
+Future optimization policies may add explicit deduplication or hoisting, but the
+baseline semantics are repeated, deterministic guard execution.
+
+## Function and Application Compilation
+
+Checked execution is built compositionally from typed-node dependencies:
+
+1. compile the callee symbol;
+2. compile the argument symbol;
+3. run any guarded observations attached to the argument symbol;
+4. run the guarded function-argument boundary, if present;
+5. apply the callee to the checked argument;
+6. run the guarded function-result boundary, if present;
+7. run guarded observations attached to the application result symbol.
+
+This handles nested and curried application chains because each `typedApply`
+consumes one function argument and produces a symbol whose inferred view is the
+function residual/result view.
+
+## Diagnostics
+
+Guards do not author diagnostics. The checked-exec runner renders diagnostics
+from checker-owned boundary context plus the guarded View.
+
+Checker-injected guard nodes carry portable structural context. Current context
+kinds are:
+
+- root `typedValue` exposure;
+- root `typedRequire` exposure;
+- non-root `typedValue` symbol observation;
+- non-root `typedRequire` symbol observation;
+- function argument boundary;
+- function result boundary;
+- unknown/default context for manually constructed `checkedGuard` values.
+
+Examples:
+
+```text
+guard failed at root typedValue symbol 0 for Guarded String
+guard failed at root typedRequire symbol 3 for Guarded String
+guard failed at typedRequire symbol 6 for Guarded String
+guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String
+guard failed at result of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String
+malformed guard result at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String
+```
+
+Manually constructed `checkedGuard` values use unknown context and therefore
+render without a boundary suffix:
+
+```text
+guard failed for String
+malformed guard result for String
+```
+
+The context is diagnostic-only. It does not affect guard execution, View
+compatibility, success/failure semantics, or continuation values.
+
+The context deliberately contains raw portable data such as symbols and
+application edges. It does not preserve source aliases such as `NonEmptyString`,
+and it does not rely on Haskell-side post-processing or source-name annotation.
+Named View rendering is a separate future design topic.
+
+## Why Not Abort in Haskell?
+
+A host-level abort primitive would move guard semantics into Haskell. The design
+instead encodes guard failure in portable checked-exec artifacts and interprets
+it with portable `tricu` code.
+
+Haskell may evaluate the runner, but Haskell is not the semantic source of guard
+validity or failure behavior.
+
+## Why Not Maybe / Result Everywhere?
+
+Returning `Maybe` or `Result` from every guarded boundary would infect ordinary
+APIs. A function expecting a `List Byte` would have to accept
+`Maybe (List Byte)` or `Result Error (List Byte)`, and every downstream caller
+would need defensive handling.
+
+The checked-exec runner avoids this. It unwraps successful guard results before
+continuing and stops checked execution on failure.
+
+## Known Sharp Edges
+
+### Guard divergence
+
+A user-written guard may diverge. This design handles intentional failure via
+`guardFail`; it does not solve arbitrary nontermination. Fuel or timeouts are
+separate runtime concerns.
+
+### Payload trust
+
+Typed nodes carry executable payloads. Guard injection must not expose an
+unchecked precomputed payload at a guarded boundary. Boundaries are mediated by
+checked-exec nodes.
+
+This does not make malicious producer forgery impossible; it gives honest
+frontends a portable, checkable protocol that avoids accidental bypasses.
+
+### Cyclic typed-apply graphs
+
+The current symbol compiler assumes typed programs are well-founded dependency
+graphs as emitted by the frontend/lowering path. Cyclic typed-apply graphs are a
+malformed-program validation concern, not a guard-specific semantic feature.
+
+## Current Implementation Status
+
+Implemented in `lib/view.tri` and exercised by tests:
+
+- `guardOk` / `guardFail`;
+- `checkedPure`, `checkedFail`, `checkedGuard`, `checkedGuardWithContext`, `checkedBind`;
+- `runChecked`;
+- success from `checkTypedProgramWith` returns checked-exec;
+- `checkedProgramTree` compatibility helper;
+- guarded root exposure;
+- guarded `typedValue` and `typedRequire`;
+- guarded function arguments and results;
+- guarded callee observations;
+- nested/curried application guard composition;
+- global per-symbol observations;
+- root-reachability behavior;
+- repeated reachable uses rerun guards;
+- source/Haskell `tricu check` integration;
+- imported/module `VTGuarded` lowering to portable `viewGuarded`;
+- portable guard boundary diagnostics with symbol/application context.
diff --git a/docs/module-system-design.md b/docs/module-system-design.md
@@ -0,0 +1,505 @@
+# 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 View Contract types. 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 View Contracts are portable enough to integrate
+
+The store may integrate with View Contracts because the checker and evidence
+format are pure Tree Calculus / portable tree data. View Contracts are not a
+Haskell-private or `tricu`-private semantic layer.
+
+The module resolver may emit typed-program evidence, but checker semantics remain
+unchanged:
+
+```text
+Haskell emits evidence.
+tricu judges evidence.
+```
+
+### 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
+
+View Contract Artifact
+ portable evidence/checker data over tree artifacts
+
+Module Manifest
+ immutable export map from names to content objects and optional contracts
+
+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.
+View Contracts define portable checking artifacts. `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.
+
+View Contract checking is a separate evidence-gathering path. It may load
+exported direct view types for the symbols that participate in a check. That
+slower path must remain behind the typed program boundary:
+
+```text
+Haskell emits evidence.
+tricu judges evidence.
+```
+
+Reusable view catalogs are ordinary tricu libraries/tree terms, not a separate
+core CAS artifact kind.
+
+For locally built workspace modules, advertised direct export views are
+producer-checked before the manifest alias is written. Producer checking includes
+advertised views from any imported modules used by that source, so a module
+cannot publish a local annotated export that contradicts a dependency's exported
+view. If producer checking fails, the module alias is not written.
+
+Consumer checking then resolves selected module exports, decodes their
+`arboricx.view-contract.type.v1` refs, and emits trusted `KnownView` evidence
+for the local imported symbols. Those facts are module-boundary assumptions:
+local workspace builds create them after producer-side checking, while external
+or prebuilt manifests are trusted inputs for now. In all cases, compatibility
+with local requirements is still judged by the portable checker in `lib/view.tri`.
+
+## 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.view-contract.type.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 view
+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:
+ view 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
+view: sha256:... -- optional View Contract artifact
+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 view-tree 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 optional direct View Contract type.
+
+The content store should not require extra definition/source/provenance objects,
+and fully untyped Tree Calculus code must remain valid.
+
+## 9. View Contract Integration
+
+View Contracts should attach to modules/exports as portable artifacts.
+
+An imported definition can be assigned a local numeric symbol while lowering a
+typed program. Its global identity remains a content hash or module export ref.
+
+This is the intended split:
+
+```text
+typed program local symbol: 3
+Debug label: "List.map"
+Resolved object: sha256:...
+Exported view: Fn [...]
+```
+
+De Bruijn-style integer symbols are still appropriate inside a typed program. They
+are local evidence identifiers, not global content identity.
+
+We should not make global objects depend on numeric checker symbols.
+
+Untyped code remains valid with no contract artifact. If a boundary needs to
+participate in checking but has no information, it may use `Any` or rely on
+policy. We should not pretend all untyped functions have an infinite
+`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 View Contract artifacts 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
+
+View Contracts:
+ portable evidence artifacts attached to exports and checked by pure Tree
+ Calculus code
+```
+
+The key architectural rule is that hashes provide stable identity, while names
+provide human usability. The module system should be built on that separation.
diff --git a/docs/view-contract-syntax.md b/docs/view-contract-syntax.md
@@ -0,0 +1,582 @@
+# View Contract Syntax Design
+
+## 1. Purpose
+
+This document specifies source-level syntax sugar for emitting View Contract
+metadata from annotated `tricu` definitions.
+
+The syntax is frontend sugar. It lowers to ordinary typed-program nodes consumed
+by the portable checker in `lib/view.tri` and catalog helpers in
+`lib/views/catalog.tri`.
+
+The checker remains independent of source syntax.
+
+## 2. Definition Annotations
+
+A definition may carry argument and return view annotations directly in its head.
+
+```tri
+name arg1@Type1 arg2@Type2 =@ReturnType body
+```
+
+This declares:
+
+```text
+name : Fn [Type1 Type2] ReturnType
+arg1 : Type1
+arg2 : Type2
+```
+
+and lowers to View Contract metadata:
+
+```tri
+typedDeclareFn nameSym [(Type1) (Type2)] ReturnType t
+typedValue arg1Sym Type1 t
+typedValue arg2Sym Type2 t
+```
+
+If body flow metadata is emitted, the body result is required to satisfy the
+appropriate residual view.
+
+## 3. Syntax Forms
+
+### 3.1 Binder annotation
+
+```tri
+x@Bool
+xs@(List Bool)
+f@(Fn [Bool] String)
+```
+
+A binder annotation introduces a normal term binder and contributes an argument
+view to the function contract.
+
+### 3.2 Phantom argument annotation
+
+```tri
+name @A @B =@C body
+```
+
+A phantom argument annotation contributes an argument view to the function
+contract but introduces no term binder.
+
+This is useful for point-free and combinator-heavy definitions.
+
+```tri
+name @A @B =@C body
+```
+
+declares:
+
+```text
+name : Fn [A B] C
+```
+
+The body itself must satisfy the residual function view:
+
+```text
+Fn [A B] C
+```
+
+### 3.3 Binder prefix with phantom tail
+
+Phantom annotations may appear after binder annotations:
+
+```tri
+name x@A @B =@C body
+```
+
+This declares:
+
+```text
+name : Fn [A B] C
+x : A
+```
+
+The body must satisfy:
+
+```text
+Fn [B] C
+```
+
+This allows a named binder prefix with a point-free tail.
+
+### 3.4 Return annotation
+
+```tri
+name x@A =@B body
+name =@B body
+```
+
+`=@B` contributes the result view.
+
+A definition with no arguments and a return annotation is a value contract, not a
+zero-arity function contract:
+
+```tri
+name =@Bool body
+```
+
+lowers to:
+
+```tri
+typedValue nameSym viewBool t
+```
+
+not:
+
+```tri
+typedDeclareFn nameSym [] viewBool t
+```
+
+## 4. Ordering Rule
+
+Phantom argument annotations may only appear at the end of the argument list.
+
+Valid:
+
+```tri
+foo x@A y@B =@C body
+foo @A @B =@C body
+foo x@A @B =@C body
+foo x y@B @C =@D body
+```
+
+Invalid:
+
+```tri
+foo x@A @B z@C =@D body
+foo @A x@B =@C body
+```
+
+Once a phantom `@Type` item appears, no later named binder may appear.
+
+## 5. Contract-Bearing Definitions
+
+A definition is contract-bearing if its head contains any of:
+
+```text
+binder@Type
+@Type
+=@Type
+```
+
+Ordinary unannotated definitions do not emit View Contract metadata.
+
+```tri
+foo x y = body
+```
+
+emits no contract metadata.
+
+## 6. Unannotated Binders in Contract-Bearing Heads
+
+In a contract-bearing definition, an unannotated binder contributes `Any`.
+
+```tri
+foo x y@Bool =@String body
+```
+
+means:
+
+```text
+foo : Fn [Any Bool] String
+x : Any
+y : Bool
+```
+
+This keeps mixed annotation lightweight without emitting contracts for fully
+unannotated definitions.
+
+## 7. Missing Return Annotation
+
+If a contract-bearing definition has argument annotations but no return
+annotation, the return view defaults to `Any`.
+
+```tri
+foo x@Bool = body
+```
+
+means:
+
+```text
+foo : Fn [Bool] Any
+x : Bool
+```
+
+## 8. Type Annotation Grammar
+
+Annotations are intentionally small at the attachment site.
+
+After `@` or `=@`, the parser accepts either a single atomic view expression or
+a parenthesized compound view expression.
+
+Valid:
+
+```tri
+x@Bool
+x@(List Bool)
+f@(Fn [Bool] String)
+r@(Result String Bool)
+name =@Bool body
+name =@(List Bool) body
+```
+
+These are not structural annotations:
+
+```tri
+x@List Bool
+f@Fn [Bool] String
+name =@List Bool body
+```
+
+They are parsed according to normal definition-head rules. For example,
+`x@List Bool` means binder `x` has the atomic view expression `List`, followed by
+an unannotated binder named `Bool`. Use parentheses when the annotation itself is
+an application.
+
+## 9. Type Grammar
+
+View expressions are ordinary value-level expressions in a restricted annotation
+grammar:
+
+```text
+ViewExpr
+ = name
+ | integer
+ | [ViewExpr...]
+ | ViewExpr ViewExpr
+ | (ViewExpr)
+```
+
+Built-in names lower to standard view values:
+
+```text
+Any -> viewAny
+Bool -> viewBool
+String -> viewString
+Byte -> viewByte
+Unit -> viewUnit
+```
+
+Atomic refs lower explicitly. String refs are the preferred user-facing form;
+numeric refs remain available for low-level/generated code:
+
+```text
+Ref "Nat" -> viewRef "Nat"
+Ref 10 -> viewRef 10
+```
+
+Additional named views and view constructors are ordinary `tricu` values:
+
+```tri
+Nat = viewRef "Nat"
+Box a = viewPair (viewRef "Box") a
+
+idNat x@Nat =@Nat x
+idBox x@(Box String) =@(Box String) x
+```
+
+The frontend resolves names and evaluates view expressions, but well-formedness
+is judged by the self-hosted checker (`wellFormedView?` in `lib/view.tri`).
+Malformed view values are rejected when checked or published.
+
+## 10. List Syntax in Types
+
+Function argument lists use the source type grammar:
+
+```tri
+Fn [Bool String] Unit
+Fn [(List Bool) (Maybe String)] Unit
+```
+
+The lowered typed program must still respect ordinary `tricu` list syntax, where
+each list element is parenthesized when needed:
+
+```tri
+viewFn [(viewBool) (viewString)] viewUnit
+```
+
+## 11. Residual Body View
+
+For a contract-bearing definition, the full definition view is always:
+
+```text
+Fn [allArgumentViews...] returnView
+```
+
+except for nullary value annotations, which use the return view directly.
+
+The body obligation depends on how many argument views are represented by named
+binders in the definition head.
+
+Let:
+
+```text
+argViews = [A B C]
+returnView = R
+binderCount = number of named binders before the phantom tail
+remaining = drop binderCount argViews
+```
+
+Then:
+
+```text
+bodyRequiredView = residual(remaining, returnView)
+```
+
+where:
+
+```text
+residual([], R) = R
+residual([A ...], R) = Fn [A ...] R
+```
+
+Examples:
+
+```tri
+foo x@A y@B =@C body
+```
+
+Body required view:
+
+```text
+C
+```
+
+```tri
+foo @A @B =@C body
+```
+
+Body required view:
+
+```text
+Fn [A B] C
+```
+
+```tri
+foo x@A @B =@C body
+```
+
+Body required view:
+
+```text
+Fn [B] C
+```
+
+## 12. Lowering Examples
+
+### 12.1 Fully annotated binders
+
+Source:
+
+```tri
+foo x@Bool xs@(List Bool) =@String body
+```
+
+Definition contract:
+
+```tri
+typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t
+typedValue xSym viewBool t
+typedValue xsSym (viewList viewBool) t
+```
+
+Body obligation:
+
+```tri
+typedRequire bodySym viewString t
+```
+
+### 12.2 Pure phantom signature
+
+Source:
+
+```tri
+foo @Bool @(List Bool) =@String body
+```
+
+Definition contract:
+
+```tri
+typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t
+```
+
+Body obligation:
+
+```tri
+typedRequire bodySym (viewFn [(viewBool) (viewList viewBool)] viewString) t
+```
+
+### 12.3 Binder prefix with phantom tail
+
+Source:
+
+```tri
+foo x@Bool @(List Bool) =@String body
+```
+
+Definition contract:
+
+```tri
+typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t
+typedValue xSym viewBool t
+```
+
+Body obligation:
+
+```tri
+typedRequire bodySym (viewFn [(viewList viewBool)] viewString) t
+```
+
+### 12.4 Value annotation
+
+Source:
+
+```tri
+message =@String "hello"
+```
+
+Definition contract:
+
+```tri
+typedValue messageSym viewString t
+```
+
+Body obligation:
+
+```tri
+typedRequire bodySym viewString t
+```
+
+## 13. `tricu check`
+
+`tricu check` consumes an annotated program, lowers annotations to typed program
+metadata, runs the checker, and reports either `ok` or rendered diagnostics.
+
+Initial behavior:
+
+```bash
+tricu check path/to/program.tri
+```
+
+outputs checker success or errors. Diagnostics are rendered by the portable
+checker, then annotated by the frontend with source/debug labels when available:
+
+```tri
+id x@String =@Bool x
+```
+
+reports:
+
+```text
+symbol 1 (x) expected Bool but got String
+```
+
+Application result labels include the application head when known:
+
+```tri
+xs =@(List String) [(g "hi")]
+g y@String =@Bool y
+```
+
+reports:
+
+```text
+symbol 3 (g application result) expected String but got Bool
+```
+
+These labels are presentation-only metadata. The checker still judges only the
+emitted typed-program evidence.
+
+Future behavior may include:
+
+```bash
+tricu check --out path/to/executable.arboricx path/to/program.tri
+```
+
+which checks an annotated source program and emits an executable Arboricx bundle.
+
+The checker library remains available independently of the CLI workflow.
+
+## 14. Frontend Lowering Boundaries
+
+The annotation syntax is frontend sugar. The canonical checker input remains a
+plain typed program: ordinary `typedValue`, `typedDeclareFn`,
+`typedRequire`, and `typedApply` nodes represented as portable `tricu`
+data.
+
+The frontend may emit richer evidence from source forms, but it does not decide
+semantic compatibility. In short:
+
+```text
+Haskell emits evidence.
+tricu judges evidence.
+```
+
+Current source-driven evidence includes:
+
+- literal views for strings, bytes, unit, and homogeneous list literals;
+- expected element requirements for `List T` bodies;
+- expected `Fn` requirements for lambda literals and curried application spines;
+- application argument requirements when the callee has a known `Fn` view;
+- expected constructor flow for unshadowed stdlib constructors:
+ - `pair` with expected `Pair A B`;
+ - `just` and `nothing` with expected `Maybe A`;
+ - `ok` and `err` with expected `Result E A`.
+
+Constructor lowering only applies when the constructor name is not shadowed by a
+local binder or top-level definition in the checked source. If a program defines
+its own `pair`, `just`, `nothing`, `ok`, or `err`, checking falls back to normal
+application evidence.
+
+For tooling and regression tests, the frontend exposes a lowering-only API that
+returns emitted typed program text without invoking the checker:
+
+```hs
+lowerSource :: String -> Either String String
+```
+
+It also exposes debug labels for symbols:
+
+```hs
+lowerSourceWithDebug :: String -> Either String (String, Map Integer String)
+```
+
+Debug labels are presentation metadata only. They are not part of checker
+semantics and are not consumed by `lib/view.tri`.
+
+`do` blocks have no separate View Contract semantics. The parser lowers them
+through their explicit bind operator:
+
+```tri
+do bind
+ x <- action
+ next x
+```
+
+becomes ordinary application/lambda structure. Checking then follows the known
+`Fn` view of the bind operator, including the callback argument view when it is
+available.
+
+## 15. Summary
+
+The annotation syntax is:
+
+```tri
+name arg@A arg2@B =@C body
+name @A @B =@C body
+name arg@A @B =@C body
+name =@C body
+```
+
+Core rules:
+
+1. Binder annotations introduce binders and argument views.
+2. Phantom annotations introduce argument views only.
+3. Phantom annotations may only appear after all binders.
+4. Unannotated binders in contract-bearing heads contribute `Any`.
+5. Missing return annotations in contract-bearing heads default to `Any`.
+6. Nullary `=@T` definitions are value contracts, not zero-arity functions.
+7. Compound annotation types must be parenthesized.
+8. Lowering emits ordinary typed-program nodes for the existing checker.
diff --git a/docs/view-contracts.md b/docs/view-contracts.md
@@ -0,0 +1,337 @@
+# View Contracts and View Trees
+
+## 1. Purpose
+
+View Contracts are the portable checking layer for Tree Calculus programs.
+
+The checker does not consume detached metadata about a separate executable. Its
+canonical input is a typed, checkable tree artifact: ordinary tree data that
+contains both the executable program payloads and the view/contract structure
+needed to validate and transform them.
+
+The checker consumes this artifact and returns either:
+
+```text
+checked-execution artifact
+```
+
+or:
+
+```text
+structured diagnostic
+```
+
+A checked-execution artifact is interpreted by `runChecked`. Unguarded programs
+are represented as `checkedPure rootPayload`; guarded programs contain explicit
+checked guard/bind nodes.
+
+This keeps checking independent of any particular host implementation. A typed
+artifact may be produced by any frontend, compiler, hand-written generator, or
+future self-hosted `tricu` toolchain.
+
+## 2. Design Principle
+
+The model follows the same discipline as interaction trees.
+
+Interaction trees use tagged structural envelopes with explicit executable
+payloads:
+
+```tri
+io action = pair "tricuIO" (pair version action)
+pure x = pair 0 x
+bind action k = pair 1 (pair action k)
+```
+
+The interpreter understands the outer structure, but it does not recursively
+mistake every subtree for interpreter metadata. A continuation `k` is an opaque
+executable tree until the interpreter reaches the `bind` step that applies it.
+
+View trees use the same rule:
+
+```text
+structure says how to check;
+opaque executable fields are only executed/applied by the checker at the
+appropriate step.
+```
+
+This is the key distinction that allows Views to carry guards without confusing
+ordinary program trees with View metadata.
+
+## 3. Views
+
+A View is an extrinsic contract over an ordinary Tree Calculus value. Tree
+Calculus values do not carry native runtime types; a View describes how a value
+may be treated by the checker or by a checked boundary.
+
+Core View forms:
+
+```text
+Any
+Ref ref
+Fn [argView...] resultView
+List elemView
+Maybe elemView
+Pair leftView rightView
+Result errView okView
+Guarded baseView guard
+```
+
+`Ref` supports both generated/numeric and symbolic references. Symbolic refs are
+preferred for user-authored views:
+
+```tri
+UserId = viewRef "UserId"
+```
+
+A guarded view refines a base view with an executable guard:
+
+```tri
+UserId = viewGuarded (viewRef "UserId") userIdGuard
+```
+
+The guard is ordinary program code. The View validator checks that the guarded
+view envelope is well-formed, and recursively validates the `baseView`, but it
+must treat the guard payload/reference as opaque executable data, not as another
+View.
+
+## 4. Guards
+
+Guards are ordinary `tricu` values/functions grouped with the Views they refine.
+
+Example:
+
+```tri
+userIdGuard = value :
+ -- ordinary program that validates value
+
+UserId = viewGuarded (viewRef "UserId") userIdGuard
+
+loadUser id@UserId = ...
+```
+
+Guards return the standard checked-runtime protocol:
+
+```tri
+guardOk value
+guardFail
+```
+
+Guards do not author diagnostics. The checked-exec runner owns guard failure and
+malformed-guard diagnostics using boundary context from the checked artifact.
+
+Guards are injected by the checker. They are not discovered by the runtime as a
+separate metadata layer. The checking process transforms a view tree into an
+executable tree with the necessary guard applications inserted.
+
+## 5. View Tree Artifact
+
+The primary checker-facing artifact is a view executable term graph.
+
+Conceptually:
+
+```text
+ViewTree
+ version
+ root node id
+ nodes
+```
+
+Each node is tagged tree data. Nodes combine executable payloads, view claims,
+and structural relationships in one graph.
+
+Representative node forms:
+
+```text
+Value node view executableTree
+Apply node calleeNode argNode expectedOrInferredView
+Require node requiredView sourceNode
+External node name view
+```
+
+This is not a mandatory final encoding; it is the semantic target. The important
+property is that executable trees and checking structure are carried together in
+a single portable artifact.
+
+A node may contain opaque executable fields. Those fields are tree terms, but
+they are not recursively decoded as view-tree nodes or Views unless the node's
+semantics explicitly says so.
+
+## 6. Checker Semantics
+
+The checker is an interpreter over the view tree.
+
+For each node it may:
+
+1. validate the node envelope;
+2. validate Views referenced by the node;
+3. check compatibility between expected and actual Views;
+4. recursively check child nodes;
+5. inject guards required by guarded Views;
+6. produce the executable tree for that node;
+7. memoize node results by node id.
+
+The root node result is a checked-execution program.
+
+In abstract form:
+
+```text
+checkViewTree : ViewTree -> Result CheckedExec Diagnostic
+```
+
+or, in self-hosted terms:
+
+```tri
+checkViewTree viewTree = ... -- ok checkedExec / err diagnostic
+```
+
+## 7. Compatibility and Guard Injection
+
+Structural compatibility is about Views. Guard injection is about producing the
+checked-execution tree.
+
+For example, if a node is required to satisfy:
+
+```tri
+viewGuarded (viewRef "UserId") userIdGuard
+```
+
+then the checker verifies the underlying View relationship and emits executable
+code that applies `userIdGuard` at the appropriate checked boundary.
+
+The checker, not the runtime metadata system, owns this transformation.
+
+## 8. Source Annotations
+
+Source annotations are one frontend syntax for producing view-tree nodes.
+
+Examples:
+
+```tri
+Nat = viewRef "Nat"
+Box a = viewPair (viewRef "Box") a
+
+idNat x@Nat =@Nat x
+idBox x@(Box String) =@(Box String) x
+```
+
+Annotations are value-level View expressions. Names such as `Nat` and `Box` are
+ordinary program values/functions that evaluate to Views.
+
+A frontend that supports this syntax should lower the source into a view tree
+that contains the relevant executable terms, views, and checking structure. The
+artifact must not depend on source names or on the frontend implementation that
+produced it.
+
+## 9. Contract Expressions
+
+Contract-expression helpers remain useful as authoring/building tools, but they
+are not the fundamental artifact model.
+
+Preferred style for expression-oriented authoring is pipeline-first:
+
+```tri
+mapBoolStringUse = cFn <|
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
+ |> cApply (cFn [(viewBool)] viewString)
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire (viewList viewString)
+```
+
+These helpers should be understood as convenient ways to build typed/checkable
+structure, not as a permanent replacement for view-tree artifacts.
+
+## 10. Artifact Direction
+
+The target direction is to make the view tree the canonical checked-program
+artifact.
+
+Older split concepts remain useful internally or during development:
+
+```text
+tree term
+view value
+typed-program node
+module/export manifest
+```
+
+But the durable design should avoid treating contracts as detached facts about a
+separate program. The portable checker input is the checkable program itself.
+
+In short:
+
+```text
+Do not store code over here and contracts over there.
+Store a view tree: executable code plus the structure needed to check and guard it.
+```
+
+## 11. IO Interaction Trees
+
+`tricu` IO is represented as ordinary interaction-tree data:
+
+```tri
+io action = pair "tricuIO" (pair version action)
+pure value = pair 0 value
+bind action k = pair 1 (pair action k)
+```
+
+View Contracts do not change that representation. A checked program may produce
+an ordinary IO interaction tree, and the existing IO driver can execute it
+unchanged.
+
+For source evaluation with contracts enabled, `tricu eval --io` performs an
+additional frontend instrumentation pass over visible IO continuations. When a
+continuation returns a `pure (...)` value that mentions source-annotated
+functions, the frontend lowers that pure expression into the existing portable
+checked-exec protocol before returning the next IO action.
+
+This means source sugar works for practical checked IO paths such as:
+
+```tri
+acceptNames xs@(NonEmptyList String) =@String "accepted"
+
+main = io (bind (pure []) (xs : pure (acceptNames xs)))
+```
+
+and for explicit higher-order boundaries:
+
+```tri
+useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String
+ handler xs
+
+main = io (bind (pure []) (xs : pure (useHandler acceptNames xs)))
+```
+
+The IO runtime does not perform View inference or guard injection at every step.
+The source/frontend pass constructs checked-exec boundaries once; the runtime
+only evaluates the resulting interaction tree.
+
+Current limitations:
+
+- This is source-visible instrumentation, not whole-program function-flow
+ tracking.
+- Higher-order guarantees require explicit annotated boundaries.
+- Raw prebuilt interaction trees, imported executable artifacts, and content-store
+ terms are not automatically re-instrumented unless they pass through this
+ source-lowering path.
+- The IO action shape itself is only shallowly checkable unless users provide
+ guarded Views for the relevant boundaries.
+- Continuation result Views are not inferred from external effects; dynamic IO
+ values should cross annotated/guarded boundaries when runtime enforcement is
+ required.
+
+Making IO checking more complete is future work. In particular, a future design
+may validate every continuation-produced action structurally, carry checked
+wrappers with higher-order function values, or define a portable checked-IO
+artifact instead of relying on Haskell/frontend source instrumentation.
+
+## 12. Host Independence
+
+No part of the core View Tree design is specific to Haskell or to the current implementation.
+
+Any producer may emit a view-tree artifact if it follows the portable tree-data
+encoding. Any checker implementation may consume it if it implements the typed
+node semantics.
+
+The current implementation can produce and consume these artifacts, but it is
+not the semantic authority. The artifact format and the self-hosted checker
+semantics are the authority.
diff --git a/lib/arboricx/arboricx.tri b/lib/arboricx/arboricx.tri
@@ -1,4 +1,7 @@
-!import "manifest.tri" !Local
+!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).
diff --git a/lib/arboricx/common.tri b/lib/arboricx/common.tri
@@ -1,6 +1,6 @@
-!import "../prelude.tri" !Local
-!import "../bytes.tri" !Local
-!import "../binary.tri" !Local
+!import "prelude" !Local
+!import "binary" !Local
+
arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
arboricxMajorVersion = [(0) (1)]
diff --git a/lib/arboricx/dispatch.tri b/lib/arboricx/dispatch.tri
@@ -1,4 +1,5 @@
-!import "arboricx.tri" !Local
+!import "prelude" !Local
+!import "arboricx" !Local
-- Multi-purpose kernel dispatch.
-- runArboricxTyped tag bundleBytes args
diff --git a/lib/arboricx/manifest.tri b/lib/arboricx/manifest.tri
@@ -1,4 +1,7 @@
-!import "nodes.tri" !Local
+!import "prelude" !Local
+!import "binary" !Local
+!import "arboricx.common" !Local
+!import "arboricx.nodes" !Local
readManifestMagic = (bs :
expectBytes arboricxManifestMagic bs)
diff --git a/lib/arboricx/nodes.tri b/lib/arboricx/nodes.tri
@@ -1,4 +1,6 @@
-!import "common.tri" !Local
+!import "prelude" !Local
+!import "binary" !Local
+!import "arboricx.common" !Local
-- Indexed Arboricx node section reader.
--
diff --git a/lib/arboricx/server.tri b/lib/arboricx/server.tri
@@ -1,8 +1,9 @@
-!import "../io.tri" !Local
-!import "../http.tri" !Local
-!import "../socket.tri" !Local
-!import "../patterns.tri" !Local
-!import "arboricx.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
+!import "http" !Local
+!import "socket" !Local
+!import "patterns" !Local
+!import "arboricx" !Local
-- ---------------------------------------------------------------------------
-- Store layout helpers
diff --git a/lib/binary.tri b/lib/binary.tri
@@ -1,6 +1,4 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "bytes.tri" !Local
+!import "prelude" !Local
errUnexpectedEof = 1
errUnexpectedBytes = 2
diff --git a/lib/bytes.tri b/lib/bytes.tri
@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
bytesNil? = emptyList?
diff --git a/lib/conversions.tri b/lib/conversions.tri
@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
incDecRev = y (self : matchList
"1"
diff --git a/lib/http.tri b/lib/http.tri
@@ -1,6 +1,7 @@
-!import "prelude.tri" !Local
-!import "io.tri" !Local
-!import "socket.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
+!import "patterns" !Local
+!import "socket" !Local
-- ---------------------------------------------------------------------------
-- Constants
diff --git a/lib/io.tri b/lib/io.tri
@@ -1,6 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "conversions.tri" !Local
+!import "prelude" !Local
+!import "patterns" !Local
-- IO constructors for host-interpreted interaction trees.
-- Free-monad style: Bind is the single sequencing mechanism.
diff --git a/lib/lazy.tri b/lib/lazy.tri
@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
lazyBool = (thenK elseK cond :
((chosen : chosen t)
diff --git a/lib/list.tri b/lib/list.tri
@@ -1,4 +1,4 @@
-!import "base.tri" !Local
+!import "base" !Local
_ = t
diff --git a/lib/patterns.tri b/lib/patterns.tri
@@ -1,6 +1,4 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "lazy.tri" !Local
+!import "prelude" !Local
match_ = y (self value patterns :
triage
diff --git a/lib/prelude.tri b/lib/prelude.tri
@@ -1,7 +1,7 @@
-- Standard tricu prelude.
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "bytes.tri" !Local
-!import "lazy.tri" !Local
-!import "conversions.tri" !Local
+!import "base" !Local
+!import "list" !Local
+!import "bytes" !Local
+!import "lazy" !Local
+!import "conversions" !Local
diff --git a/lib/socket.tri b/lib/socket.tri
@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "io.tri" !Local
+!import "prelude" !Local
+!import "io" !Local
-- Socket primitives for the IO driver.
-- ok value t -- pair true (pair value t)
diff --git a/lib/view.tri b/lib/view.tri
@@ -0,0 +1,1560 @@
+!import "prelude" !Local
+!import "patterns" !Local
+
+-- ---------------------------------------------------------------------------
+-- View Contract core, validation kernel
+--
+-- This layer validates typed/checkable program trees: executable payload slots
+-- and view-flow structure travel together in one portable value. Executable
+-- payloads remain opaque to metadata validation until a checker/interpreter
+-- explicitly chooses to run or rewrite them.
+-- ---------------------------------------------------------------------------
+
+-- Generic tagged records / fields. Constructors use field sentinels; accessors
+-- for fixed-format records use finite positional destructuring to avoid driving
+-- recursive field lookup while top-level definitions normalize.
+record = (tag fields : pair tag fields)
+recordTag = fst
+recordFields = snd
+
+field = (tag value : pair tag value)
+fieldTag = fst
+fieldValue = snd
+
+field0 = (fields : fieldValue (head fields))
+field1 = (fields : fieldValue (head (tail fields)))
+field2 = (fields : fieldValue (head (tail (tail fields))))
+field3 = (fields : fieldValue (head (tail (tail (tail fields)))))
+field4 = (fields : fieldValue (head (tail (tail (tail (tail fields))))))
+
+field0Tag? = (fields tag : equal? (fieldTag (head fields)) tag)
+field1Tag? = (fields tag : equal? (fieldTag (head (tail fields))) tag)
+field2Tag? = (fields tag : equal? (fieldTag (head (tail (tail fields)))) tag)
+field3Tag? = (fields tag : equal? (fieldTag (head (tail (tail (tail fields))))) tag)
+
+fields1? = (fields tag0 :
+ and?
+ (field0Tag? fields tag0)
+ (emptyList? (tail fields)))
+
+fields2? = (fields tag0 tag1 :
+ and?
+ (and? (field0Tag? fields tag0) (field1Tag? fields tag1))
+ (emptyList? (tail (tail fields))))
+
+fields3? = (fields tag0 tag1 tag2 :
+ and?
+ (and? (fields2Prefix fields tag0 tag1) (field2Tag? fields tag2))
+ (emptyList? (tail (tail (tail fields)))))
+
+fields4? = (fields tag0 tag1 tag2 tag3 :
+ and?
+ (and? (fields2Prefix fields tag0 tag1) (and? (field2Tag? fields tag2) (field3Tag? fields tag3)))
+ (emptyList? (tail (tail (tail (tail fields))))))
+
+fields2Prefix = (fields tag0 tag1 :
+ and? (field0Tag? fields tag0) (field1Tag? fields tag1))
+
+-- View tags / fields
+viewTagAny = 0
+viewTagFn = 1
+viewTagRef = 2
+viewTagList = 3
+viewTagMaybe = 4
+viewTagPair = 5
+viewTagResult = 6
+viewTagGuarded = 7
+viewFieldArgs = 0
+viewFieldResult = 1
+viewFieldRef = 2
+viewFieldElem = 3
+viewFieldLeft = 4
+viewFieldRight = 5
+viewFieldErr = 6
+viewFieldOk = 7
+viewFieldBase = 8
+viewFieldGuard = 9
+
+-- Evidence tags
+evidenceTagTrusted = 0
+evidenceTagInferred = 1
+evidenceTagRequired = 2
+
+-- Boundary strategies / policy
+boundaryStrategyError = 0
+boundaryStrategyTrust = 1
+policyStrict = pair boundaryStrategyError t
+policyGradual = pair boundaryStrategyTrust t
+policyBoundaryStrategy = fst
+
+-- Structured checker error tags. Result payloads remain strings for compatibility;
+-- these numeric tags give portable tests and frontends a stable diagnostic API.
+errorTagOk = 0
+errorTagMalformedPolicy = 1
+errorTagMalformedProgram = 2
+errorTagUnknownNode = 3
+errorTagMissingRequiredView = 4
+errorTagMissingFunctionArgumentView = 5
+errorTagZeroArityFunction = 6
+errorTagGuardFailed = 7
+errorTagMalformedGuardResult = 8
+errorTagUnknown = 99
+
+diagnosticFieldSymbol = 0
+diagnosticFieldExpectedView = 1
+diagnosticFieldActualView = 2
+diagnosticFieldActualTag = 3
+diagnosticFieldGuardContext = 4
+
+diagnostic = (tag fields : record tag fields)
+diagnosticTag = recordTag
+diagnosticPayload = recordFields
+diagnosticSymbol = (diag : field0 (diagnosticPayload diag))
+diagnosticExpectedView = (diag : field1 (diagnosticPayload diag))
+diagnosticActualView = (diag : field2 (diagnosticPayload diag))
+
+diagnosticMessage = (diag :
+ let tag = diagnosticTag diag in
+ lazyBool
+ (_ : "malformed view policy")
+ (_ :
+ lazyBool
+ (_ : "malformed view program")
+ (_ :
+ lazyBool
+ (_ : "unknown typed node tag")
+ (_ :
+ lazyBool
+ (_ : "required view is not known")
+ (_ :
+ lazyBool
+ (_ : "function argument view is not known")
+ (_ :
+ lazyBool
+ (_ : "cannot apply zero-arity Fn view")
+ (_ :
+ lazyBool
+ (_ : "guard failed")
+ (_ :
+ lazyBool
+ (_ : "malformed guard result")
+ (_ : "unknown checker error")
+ (equal? tag errorTagMalformedGuardResult))
+ (equal? tag errorTagGuardFailed))
+ (equal? tag errorTagZeroArityFunction))
+ (equal? tag errorTagMissingFunctionArgumentView))
+ (equal? tag errorTagMissingRequiredView))
+ (equal? tag errorTagUnknownNode))
+ (equal? tag errorTagMalformedProgram))
+ (equal? tag errorTagMalformedPolicy))
+
+-- Environment tags / fields
+viewFactTagKnown = 0
+viewFactFieldView = 0
+viewFactFieldEvidence = 1
+envEntryTagViews = 0
+
+contractExprTagValue = 0
+contractExprTagFn = 1
+contractExprTagCall = 2
+contractExprTagRequire = 3
+contractExprFieldView = 0
+contractExprFieldArgs = 0
+contractExprFieldResult = 1
+contractExprFieldFn = 0
+contractExprFieldArg = 1
+contractExprFieldExpr = 0
+contractExprFieldRequired = 1
+
+-- View-tree checker artifact tags / fields. A view tree is the durable
+-- checker input: executable payloads and checking structure travel together.
+-- Term fields are opaque executable trees; View validation must not recurse
+-- into them as metadata.
+typedProgramTag = 20
+typedNodeTagValue = 21
+typedNodeTagApply = 22
+typedNodeTagRequire = 23
+typedProgramFieldRoot = 0
+typedProgramFieldNodes = 1
+typedNodeFieldSymbol = 0
+typedNodeFieldView = 1
+typedNodeFieldTerm = 2
+typedNodeFieldCallee = 3
+typedNodeFieldArg = 4
+
+-- Checked-exec / runtime guard protocol tags. Successful checker results always
+-- carry checked-exec artifacts; unguarded roots are represented as checkedPure.
+guardResultTagOk = 30
+guardResultTagFail = 31
+guardResultFieldValue = 0
+
+checkedExecTagPure = 40
+checkedExecTagFail = 41
+checkedExecTagGuard = 42
+checkedExecTagBind = 43
+checkedExecFieldValue = 0
+checkedExecFieldDiagnostic = 1
+checkedExecFieldView = 2
+checkedExecFieldGuard = 3
+checkedExecFieldContinuation = 4
+checkedExecFieldGuardContext = 5
+
+guardContextTagRootValue = 50
+guardContextTagRootRequire = 51
+guardContextTagSymbolValue = 52
+guardContextTagSymbolRequire = 53
+guardContextTagFunctionArgument = 54
+guardContextTagFunctionResult = 55
+guardContextTagUnknown = 59
+guardContextFieldSymbol = 0
+guardContextFieldApplication = 1
+guardContextFieldCallee = 2
+guardContextFieldArg = 3
+guardContextFieldArgIndex = 4
+
+envEntryFieldSymbol = 0
+envEntryFieldViews = 1
+
+viewAny = record viewTagAny t
+viewFn args result =
+ record viewTagFn [(field viewFieldArgs args) (field viewFieldResult result)]
+viewRef symbol = record viewTagRef [(field viewFieldRef symbol)]
+viewList elem = record viewTagList [(field viewFieldElem elem)]
+viewMaybe elem = record viewTagMaybe [(field viewFieldElem elem)]
+viewPair left right =
+ record viewTagPair [(field viewFieldLeft left) (field viewFieldRight right)]
+viewResult errView okView =
+ record viewTagResult [(field viewFieldErr errView) (field viewFieldOk okView)]
+viewGuarded baseView guard =
+ record viewTagGuarded [(field viewFieldBase baseView) (field viewFieldGuard guard)]
+
+viewTag = recordTag
+viewPayload = recordFields
+fnArgs = (view : field0 (viewPayload view))
+fnResult = (view : field1 (viewPayload view))
+
+fnResidual = (restArgs result :
+ lazyList
+ (_ : result)
+ (_ _ : viewFn restArgs result)
+ restArgs)
+
+anyView? = (view : equal? view viewAny)
+fnView? = (view : equal? (viewTag view) viewTagFn)
+refView? = (view : equal? (viewTag view) viewTagRef)
+listView? = (view : equal? (viewTag view) viewTagList)
+maybeView? = (view : equal? (viewTag view) viewTagMaybe)
+pairView? = (view : equal? (viewTag view) viewTagPair)
+resultView? = (view : equal? (viewTag view) viewTagResult)
+guardedView? = (view : equal? (viewTag view) viewTagGuarded)
+guardedViewBase = (view : field0 (viewPayload view))
+guardedViewGuard = (view : field1 (viewPayload view))
+
+viewFact = (view evidence :
+ record viewFactTagKnown
+ [(field viewFactFieldView view)
+ (field viewFactFieldEvidence evidence)])
+viewFactView = (fact : field0 (recordFields fact))
+viewFactEvidence = (fact : field1 (recordFields fact))
+
+envEntry = (symbol viewSet :
+ record envEntryTagViews
+ [(field envEntryFieldSymbol symbol)
+ (field envEntryFieldViews viewSet)])
+envEntrySymbol = (entry : field0 (recordFields entry))
+envEntryViews = (entry : field1 (recordFields entry))
+
+-- ---------------------------------------------------------------------------
+-- Well-formed metadata checks. This is the first point where the checker starts
+-- protecting itself: every typed node is shape-checked before flow interpretation.
+-- ---------------------------------------------------------------------------
+
+validEvidence? = (e :
+ or?
+ (equal? e evidenceTagTrusted)
+ (or? (equal? e evidenceTagInferred) (equal? e evidenceTagRequired)))
+
+validBoundaryStrategy? = (strategy :
+ or?
+ (equal? strategy boundaryStrategyError)
+ (equal? strategy boundaryStrategyTrust))
+
+wellFormedPolicy? = (policy :
+ validBoundaryStrategy? (policyBoundaryStrategy policy))
+
+wellFormedFnArgs_ self viewSelf views =
+ lazyList
+ (_ : true)
+ (view rest :
+ lazyBool
+ (_ : self viewSelf rest)
+ (_ : false)
+ (viewSelf view))
+ views
+
+wellFormedFnView? = (view :
+ fields2? (viewPayload view) viewFieldArgs viewFieldResult)
+
+wellFormedAnyView? = (view :
+ equal? (viewPayload view) t)
+
+wellFormedRefView? = (view :
+ fields1? (viewPayload view) viewFieldRef)
+
+wellFormedUnaryView? = (view fieldTag :
+ fields1? (viewPayload view) fieldTag)
+
+wellFormedPairView? = (view :
+ fields2? (viewPayload view) viewFieldLeft viewFieldRight)
+
+wellFormedResultView? = (view :
+ fields2? (viewPayload view) viewFieldErr viewFieldOk)
+
+wellFormedGuardedView? = (view :
+ fields2? (viewPayload view) viewFieldBase viewFieldGuard)
+
+wellFormedView_ self view =
+ lazyBool
+ (_ : wellFormedAnyView? view)
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self (fnResult view))
+ (_ : false)
+ (y wellFormedFnArgs_ self (fnArgs view)))
+ (_ :
+ lazyBool
+ (_ : wellFormedRefView? view)
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self (field0 (viewPayload view)))
+ (_ : false)
+ (wellFormedUnaryView? view viewFieldElem))
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self (field1 (viewPayload view)))
+ (_ : false)
+ (self (field0 (viewPayload view))))
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self (field1 (viewPayload view)))
+ (_ : false)
+ (self (field0 (viewPayload view))))
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self (guardedViewBase view))
+ (_ : false)
+ (wellFormedGuardedView? view))
+ (_ : false)
+ (guardedView? view))
+ (and? (resultView? view) (wellFormedResultView? view)))
+ (and? (pairView? view) (wellFormedPairView? view)))
+ (or? (listView? view) (maybeView? view)))
+ (refView? view))
+ (and? (fnView? view) (wellFormedFnView? view)))
+ (anyView? view)
+
+wellFormedView? = (view :
+ y wellFormedView_ view)
+
+wellFormedViews_ self views =
+ lazyList
+ (_ : true)
+ (view rest :
+ lazyBool
+ (_ : self rest)
+ (_ : false)
+ (wellFormedView? view))
+ views
+
+wellFormedViews? = (views :
+ y wellFormedViews_ views)
+
+wellFormedViewFact? = (fact :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ :
+ and?
+ (wellFormedView? (viewFactView fact))
+ (validEvidence? (viewFactEvidence fact)))
+ (_ : false)
+ (fields2? (recordFields fact) viewFactFieldView viewFactFieldEvidence))
+ (_ : false)
+ (equal? (recordTag fact) viewFactTagKnown))
+
+wellFormedViewSet_ self viewSet =
+ lazyList
+ (_ : true)
+ (fact rest :
+ lazyBool
+ (_ : self rest)
+ (_ : false)
+ (wellFormedViewFact? fact))
+ viewSet
+
+wellFormedViewSet? = (viewSet :
+ y wellFormedViewSet_ viewSet)
+
+wellFormedEnvEntry? = (entry :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : wellFormedViewSet? (envEntryViews entry))
+ (_ : false)
+ (fields2? (recordFields entry) envEntryFieldSymbol envEntryFieldViews))
+ (_ : false)
+ (equal? (recordTag entry) envEntryTagViews))
+
+wellFormedEnv_ self env =
+ lazyList
+ (_ : true)
+ (entry rest :
+ lazyBool
+ (_ : self rest)
+ (_ : false)
+ (wellFormedEnvEntry? entry))
+ env
+
+wellFormedEnv? = (env :
+ y wellFormedEnv_ env)
+
+-- ---------------------------------------------------------------------------
+-- Flow environment
+-- env = listOf tagged envEntry
+-- viewSet = listOf tagged viewFact
+-- ---------------------------------------------------------------------------
+
+lookupViews_ self symbol env =
+ lazyList
+ (_ : nothing)
+ (entry rest :
+ lazyBool
+ (_ : just (envEntryViews entry))
+ (_ : self symbol rest)
+ (equal? symbol (envEntrySymbol entry)))
+ env
+
+lookupViews = (symbol env :
+ y lookupViews_ symbol env)
+
+viewSetHas_ self view viewSet =
+ lazyList
+ (_ : false)
+ (fact rest :
+ lazyBool
+ (_ : true)
+ (_ : self view rest)
+ (equal? view (viewFactView fact)))
+ viewSet
+
+viewSetHas? = (view viewSet :
+ lazyBool
+ (_ : true)
+ (_ : y viewSetHas_ view viewSet)
+ (anyView? view))
+
+hasView? = (symbol view env :
+ lazyMaybe
+ (_ : anyView? view)
+ (viewSet : viewSetHas? view viewSet)
+ (lookupViews symbol env))
+
+addViewToSet = (view evidence viewSet :
+ lazyBool
+ (_ : viewSet)
+ (_ : pair (viewFact view evidence) viewSet)
+ (viewSetHas? view viewSet))
+
+extendEnv_ self symbol view evidence env =
+ lazyList
+ (_ : [(envEntry symbol [(viewFact view evidence)])])
+ (entry rest :
+ lazyBool
+ (_ :
+ pair
+ (envEntry symbol (addViewToSet view evidence (envEntryViews entry)))
+ rest)
+ (_ : pair entry (self symbol view evidence rest))
+ (equal? symbol (envEntrySymbol entry)))
+ env
+
+extendEnv = (symbol view evidence env :
+ y extendEnv_ symbol view evidence env)
+
+findFnView_ self viewSet =
+ lazyList
+ (_ : nothing)
+ (fact rest :
+ let view = viewFactView fact in
+ lazyBool
+ (_ : just view)
+ (_ : self rest)
+ (fnView? view))
+ viewSet
+
+findFnView = (viewSet :
+ y findFnView_ viewSet)
+
+firstKnownView = (viewSet :
+ lazyList
+ (_ : viewAny)
+ (fact rest : viewFactView fact)
+ viewSet)
+
+actualViewFor = (symbol env :
+ lazyMaybe
+ (_ : viewAny)
+ (viewSet : firstKnownView viewSet)
+ (lookupViews symbol env))
+
+checkerErr = (tag fields env : err (diagnostic tag fields) env)
+checkerOk = (env : ok env t)
+
+missingRequiredView = (policy symbol view env :
+ lazyBool
+ (_ :
+ checkerErr
+ errorTagMissingRequiredView
+ [(field diagnosticFieldSymbol symbol)
+ (field diagnosticFieldExpectedView view)
+ (field diagnosticFieldActualView (actualViewFor symbol env))]
+ env)
+ (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
+ (equal? (policyBoundaryStrategy policy) boundaryStrategyError))
+
+missingArgumentView = (policy symbol view env :
+ lazyBool
+ (_ :
+ checkerErr
+ errorTagMissingFunctionArgumentView
+ [(field diagnosticFieldSymbol symbol)
+ (field diagnosticFieldExpectedView view)
+ (field diagnosticFieldActualView (actualViewFor symbol env))]
+ env)
+ (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
+ (equal? (policyBoundaryStrategy policy) boundaryStrategyError))
+
+checkApplicationSymbols = (policy argSymbol outSymbol env fnView :
+ lazyList
+ (_ : checkerErr errorTagZeroArityFunction t env)
+ (argView restArgs :
+ let resultView = fnResidual restArgs (fnResult fnView) in
+ lazyBool
+ (_ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred env))
+ (_ :
+ lazyResult
+ (diag envAtError : err diag envAtError)
+ (nextEnv _ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred nextEnv))
+ (missingArgumentOrGuardedBase policy argSymbol argView env))
+ (hasView? argSymbol argView env))
+ (fnArgs fnView))
+
+-- ---------------------------------------------------------------------------
+-- View-tree checker artifact
+-- ---------------------------------------------------------------------------
+
+typedProgram = (root nodes :
+ record typedProgramTag
+ [(field typedProgramFieldRoot root)
+ (field typedProgramFieldNodes nodes)])
+
+typedProgramRoot = (program : field0 (recordFields program))
+typedProgramNodes = (program : field1 (recordFields program))
+
+typedValue = (symbol view term :
+ record typedNodeTagValue
+ [(field typedNodeFieldSymbol symbol)
+ (field typedNodeFieldView view)
+ (field typedNodeFieldTerm term)])
+
+typedApply = (symbol callee arg term :
+ record typedNodeTagApply
+ [(field typedNodeFieldSymbol symbol)
+ (field typedNodeFieldCallee callee)
+ (field typedNodeFieldArg arg)
+ (field typedNodeFieldTerm term)])
+
+typedRequire = (symbol view term :
+ record typedNodeTagRequire
+ [(field typedNodeFieldSymbol symbol)
+ (field typedNodeFieldView view)
+ (field typedNodeFieldTerm term)])
+
+typedNodeSymbol = (node : field0 (recordFields node))
+typedNodeView = (node : field1 (recordFields node))
+typedNodeTerm = (node : field2 (recordFields node))
+typedApplyCallee = (node : field1 (recordFields node))
+typedApplyArg = (node : field2 (recordFields node))
+typedApplyTerm = (node : field0 (tail (tail (tail (recordFields node)))))
+
+wellFormedTypedValue? = (node :
+ lazyBool
+ (_ : wellFormedView? (typedNodeView node))
+ (_ : false)
+ (fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
+
+wellFormedTypedApply? = (node :
+ fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee typedNodeFieldArg)
+
+wellFormedTypedApplyPayload? = (node :
+ and?
+ (fields2Prefix (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee)
+ (and?
+ (field2Tag? (recordFields node) typedNodeFieldArg)
+ (and?
+ (field0Tag? (tail (tail (tail (recordFields node)))) typedNodeFieldTerm)
+ (emptyList? (tail (tail (tail (tail (recordFields node)))))))))
+
+wellFormedTypedRequire? = (node :
+ lazyBool
+ (_ : wellFormedView? (typedNodeView node))
+ (_ : false)
+ (fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
+
+wellFormedTypedNode? = (node :
+ let tag = recordTag node in
+ lazyBool
+ (_ : wellFormedTypedValue? node)
+ (_ :
+ lazyBool
+ (_ : wellFormedTypedApplyPayload? node)
+ (_ :
+ lazyBool
+ (_ : wellFormedTypedRequire? node)
+ (_ : false)
+ (equal? tag typedNodeTagRequire))
+ (equal? tag typedNodeTagApply))
+ (equal? tag typedNodeTagValue))
+
+wellFormedTypedNodes_ self nodes =
+ lazyList
+ (_ : true)
+ (node rest :
+ lazyBool
+ (_ : self rest)
+ (_ : false)
+ (wellFormedTypedNode? node))
+ nodes
+
+wellFormedTypedNodes? = (nodes : y wellFormedTypedNodes_ nodes)
+
+wellFormedTypedProgram? = (program :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : wellFormedTypedNodes? (typedProgramNodes program))
+ (_ : false)
+ (fields2? (recordFields program) typedProgramFieldRoot typedProgramFieldNodes))
+ (_ : false)
+ (equal? (recordTag program) typedProgramTag))
+
+checkTypedValueNode = (node env :
+ let symbol = typedNodeSymbol node in
+ let view = typedNodeView node in
+ lazyBool
+ (_ :
+ checkerOk
+ (extendEnv
+ symbol
+ view
+ evidenceTagTrusted
+ (extendEnv symbol (guardedViewBase view) evidenceTagTrusted env)))
+ (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
+ (guardedView? view))
+
+checkTypedRequireNode = (policy node env :
+ let symbol = typedNodeSymbol node in
+ let view = typedNodeView node in
+ lazyBool
+ (_ : checkerOk env)
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : checkerOk (extendEnv symbol view evidenceTagRequired env))
+ (_ : missingRequiredView policy symbol view env)
+ (hasView? symbol (guardedViewBase view) env))
+ (_ : missingRequiredView policy symbol view env)
+ (guardedView? view))
+ (hasView? symbol view env))
+
+missingArgumentOrGuardedBase = (policy symbol view env :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : checkerOk (extendEnv symbol view evidenceTagRequired env))
+ (_ : missingArgumentView policy symbol view env)
+ (hasView? symbol (guardedViewBase view) env))
+ (_ : missingArgumentView policy symbol view env)
+ (guardedView? view))
+
+checkTypedApplyNode = (policy node env :
+ lazyMaybe
+ (_ : checkerOk env)
+ (calleeViews :
+ lazyMaybe
+ (_ : checkerOk env)
+ (fnView : checkApplicationSymbols policy (typedApplyArg node) (typedNodeSymbol node) env fnView)
+ (findFnView calleeViews))
+ (lookupViews (typedApplyCallee node) env))
+
+checkTypedNode = (policy node env :
+ let tag = recordTag node in
+ lazyBool
+ (_ : checkTypedValueNode node env)
+ (_ :
+ lazyBool
+ (_ : checkTypedApplyNode policy node env)
+ (_ : checkTypedRequireNode policy node env)
+ (equal? tag typedNodeTagApply))
+ (equal? tag typedNodeTagValue))
+
+flowCheckTypedNodes_ self nodes policy env =
+ lazyList
+ (_ : checkerOk env)
+ (node rest :
+ lazyResult
+ (diag envAtError : err diag envAtError)
+ (nextEnv _ : self rest policy nextEnv)
+ (checkTypedNode policy node env))
+ nodes
+
+flowCheckTypedNodes = (policy nodes :
+ y flowCheckTypedNodes_ nodes policy t)
+
+lookupTypedTerm_ self symbol nodes =
+ lazyList
+ (_ : nothing)
+ (node rest :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : just (typedApplyTerm node))
+ (_ : just (typedNodeTerm node))
+ (equal? (recordTag node) typedNodeTagApply))
+ (_ : self symbol rest)
+ (equal? symbol (typedNodeSymbol node)))
+ nodes
+
+lookupTypedTerm = (symbol program :
+ y lookupTypedTerm_ symbol (typedProgramNodes program))
+
+lookupTypedView_ self symbol nodes =
+ lazyList
+ (_ : nothing)
+ (node rest :
+ let tag = recordTag node in
+ lazyBool
+ (_ : just (typedNodeView node))
+ (_ : self symbol rest)
+ (and?
+ (or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire))
+ (equal? symbol (typedNodeSymbol node))))
+ nodes
+
+lookupTypedView = (symbol program :
+ y lookupTypedView_ symbol (typedProgramNodes program))
+
+lookupApplyDefinition_ self symbol nodes =
+ lazyList
+ (_ : nothing)
+ (node rest :
+ lazyBool
+ (_ : just node)
+ (_ : self symbol rest)
+ (and?
+ (equal? (recordTag node) typedNodeTagApply)
+ (equal? symbol (typedNodeSymbol node))))
+ nodes
+
+lookupApplyDefinition = (symbol program :
+ y lookupApplyDefinition_ symbol (typedProgramNodes program))
+
+firstFnArgView = (view :
+ lazyBool
+ (_ :
+ lazyList
+ (_ : nothing)
+ (arg rest : just arg)
+ (fnArgs view))
+ (_ : nothing)
+ (fnView? view))
+
+appliedFnResultView = (view :
+ lazyBool
+ (_ :
+ lazyList
+ (_ : nothing)
+ (arg rest : just (fnResidual rest (fnResult view)))
+ (fnArgs view))
+ (_ : nothing)
+ (fnView? view))
+
+lookupSymbolView_ self symbol program =
+ lazyMaybe
+ (_ :
+ lazyMaybe
+ (_ : nothing)
+ (applyNode :
+ lazyMaybe
+ (_ : nothing)
+ (calleeView : appliedFnResultView calleeView)
+ (self (typedApplyCallee applyNode) program))
+ (lookupApplyDefinition symbol program))
+ (view : just view)
+ (lookupTypedView symbol program)
+
+lookupSymbolView = (symbol program :
+ y lookupSymbolView_ symbol program)
+
+guardContextUnknown = record guardContextTagUnknown t
+
+guardContextRootValue = (symbol :
+ record guardContextTagRootValue [(field guardContextFieldSymbol symbol)])
+guardContextRootRequire = (symbol :
+ record guardContextTagRootRequire [(field guardContextFieldSymbol symbol)])
+guardContextSymbolValue = (symbol :
+ record guardContextTagSymbolValue [(field guardContextFieldSymbol symbol)])
+guardContextSymbolRequire = (symbol :
+ record guardContextTagSymbolRequire [(field guardContextFieldSymbol symbol)])
+guardContextFunctionArgument = (application callee arg argIndex :
+ record guardContextTagFunctionArgument
+ [(field guardContextFieldApplication application)
+ (field guardContextFieldCallee callee)
+ (field guardContextFieldArg arg)
+ (field guardContextFieldArgIndex argIndex)])
+guardContextFunctionResult = (application callee arg :
+ record guardContextTagFunctionResult
+ [(field guardContextFieldApplication application)
+ (field guardContextFieldCallee callee)
+ (field guardContextFieldArg arg)])
+
+guardContextObservation = (root symbol nodeTag :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : guardContextRootValue symbol)
+ (_ : guardContextRootRequire symbol)
+ (equal? nodeTag typedNodeTagValue))
+ (_ :
+ lazyBool
+ (_ : guardContextSymbolValue symbol)
+ (_ : guardContextSymbolRequire symbol)
+ (equal? nodeTag typedNodeTagValue))
+ (equal? root symbol))
+
+applySymbolGuardedObservations_ self root symbol nodes exec =
+ lazyList
+ (_ : exec)
+ (node rest :
+ let tag = recordTag node in
+ lazyBool
+ (_ :
+ let view = typedNodeView node in
+ lazyBool
+ (_ :
+ self
+ root
+ symbol
+ rest
+ (checkedBind
+ exec
+ (value : checkedGuardWithContext (guardContextObservation root symbol tag) view (guardedViewGuard view) value (checkedValue : checkedPure checkedValue))))
+ (_ : self root symbol rest exec)
+ (guardedView? view))
+ (_ : self root symbol rest exec)
+ (and?
+ (or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire))
+ (equal? symbol (typedNodeSymbol node))))
+ nodes
+
+applySymbolGuardedObservations = (program symbol exec :
+ y applySymbolGuardedObservations_ (typedProgramRoot program) symbol (typedProgramNodes program) exec)
+
+compileApplyExec = (self program applyNode :
+ let calleeSym = typedApplyCallee applyNode in
+ let argSym = typedApplyArg applyNode in
+ let calleeExec = self program calleeSym in
+ let argExec = self program argSym in
+ lazyMaybe
+ (_ :
+ checkedBind
+ calleeExec
+ (calleeValue :
+ checkedBind
+ argExec
+ (argValue : checkedPure (calleeValue argValue))))
+ (calleeView :
+ let applicationExec =
+ lazyMaybe
+ (_ :
+ checkedBind
+ calleeExec
+ (calleeValue :
+ checkedBind
+ argExec
+ (argValue : checkedPure (calleeValue argValue))))
+ (argView :
+ lazyBool
+ (_ :
+ checkedBind
+ calleeExec
+ (calleeValue :
+ checkedBind
+ argExec
+ (argValue :
+ checkedBind
+ (checkedGuardWithContext (guardContextFunctionArgument (typedNodeSymbol applyNode) calleeSym argSym 0) argView (guardedViewGuard argView) argValue (checkedValue : checkedPure checkedValue))
+ (checkedValue : checkedPure (calleeValue checkedValue)))))
+ (_ :
+ checkedBind
+ calleeExec
+ (calleeValue :
+ checkedBind
+ argExec
+ (argValue : checkedPure (calleeValue argValue))))
+ (guardedView? argView))
+ (firstFnArgView calleeView) in
+ lazyMaybe
+ (_ : applicationExec)
+ (resultView :
+ lazyBool
+ (_ :
+ checkedBind
+ applicationExec
+ (value : checkedGuardWithContext (guardContextFunctionResult (typedNodeSymbol applyNode) calleeSym argSym) resultView (guardedViewGuard resultView) value (checkedValue : checkedPure checkedValue)))
+ (_ : applicationExec)
+ (guardedView? resultView))
+ (appliedFnResultView calleeView))
+ (lookupSymbolView calleeSym program))
+
+compileSymbol_ self program symbol =
+ lazyMaybe
+ (_ :
+ lazyMaybe
+ (_ : checkedPure t)
+ (term : applySymbolGuardedObservations program symbol (checkedPure term))
+ (lookupTypedTerm symbol program))
+ (applyNode : applySymbolGuardedObservations program symbol (compileApplyExec self program applyNode))
+ (lookupApplyDefinition symbol program)
+
+compileSymbol = (program symbol :
+ y compileSymbol_ program symbol)
+
+checkedExecForRootTerm = (program term :
+ compileSymbol program (typedProgramRoot program))
+
+-- ---------------------------------------------------------------------------
+-- Checked execution / runtime guard protocol
+-- ---------------------------------------------------------------------------
+
+guardOk = (value :
+ record guardResultTagOk [(field guardResultFieldValue value)])
+guardFail = record guardResultTagFail t
+
+guardResultOk? = (result : equal? (recordTag result) guardResultTagOk)
+guardResultFail? = (result : equal? (recordTag result) guardResultTagFail)
+guardResultValue = (result : field0 (recordFields result))
+
+checkedPure = (value :
+ record checkedExecTagPure [(field checkedExecFieldValue value)])
+checkedFail = (diag :
+ record checkedExecTagFail [(field checkedExecFieldDiagnostic diag)])
+checkedGuardWithContext = (context view guard value continuation :
+ record checkedExecTagGuard
+ [(field checkedExecFieldView view)
+ (field checkedExecFieldGuard guard)
+ (field checkedExecFieldValue value)
+ (field checkedExecFieldContinuation continuation)
+ (field checkedExecFieldGuardContext context)])
+checkedGuard = (view guard value continuation :
+ checkedGuardWithContext guardContextUnknown view guard value continuation)
+checkedBind = (exec continuation :
+ record checkedExecTagBind
+ [(field checkedExecFieldValue exec)
+ (field checkedExecFieldContinuation continuation)])
+
+checkedExecValue = (exec : field0 (recordFields exec))
+checkedExecDiagnostic = (exec : field0 (recordFields exec))
+checkedExecView = (exec : field0 (recordFields exec))
+checkedExecGuard = (exec : field1 (recordFields exec))
+checkedExecGuardValue = (exec : field2 (recordFields exec))
+checkedExecContinuation = (exec : field3 (recordFields exec))
+checkedExecGuardContext = (exec : field4 (recordFields exec))
+checkedExecBindExec = (exec : field0 (recordFields exec))
+checkedExecBindContinuation = (exec : field1 (recordFields exec))
+
+checkedRuntimeOk = (value : ok value t)
+checkedRuntimeFail = (diag : err diag t)
+
+diagnosticGuardContext = (diag : field3 (diagnosticPayload diag))
+
+checkedGuardFailedDiagnostic = (context view :
+ diagnostic
+ errorTagGuardFailed
+ [(field diagnosticFieldSymbol 0)
+ (field diagnosticFieldExpectedView view)
+ (field diagnosticFieldActualView viewAny)
+ (field diagnosticFieldGuardContext context)])
+
+malformedGuardResultDiagnostic = (context view actual :
+ diagnostic
+ errorTagMalformedGuardResult
+ [(field diagnosticFieldSymbol 0)
+ (field diagnosticFieldExpectedView view)
+ (field diagnosticFieldActualTag (recordTag actual))
+ (field diagnosticFieldGuardContext context)])
+
+runChecked_ self exec =
+ let tag = recordTag exec in
+ lazyBool
+ (_ : checkedRuntimeOk (checkedExecValue exec))
+ (_ :
+ lazyBool
+ (_ : checkedRuntimeFail (checkedExecDiagnostic exec))
+ (_ :
+ lazyBool
+ (_ :
+ let view = checkedExecView exec in
+ let guard = checkedExecGuard exec in
+ let value = checkedExecGuardValue exec in
+ let continuation = checkedExecContinuation exec in
+ let context = checkedExecGuardContext exec in
+ let guardResult = guard value in
+ lazyBool
+ (_ : self (continuation (guardResultValue guardResult)))
+ (_ :
+ lazyBool
+ (_ : checkedRuntimeFail (checkedGuardFailedDiagnostic context view))
+ (_ : checkedRuntimeFail (malformedGuardResultDiagnostic context view guardResult))
+ (guardResultFail? guardResult))
+ (guardResultOk? guardResult))
+ (_ :
+ lazyBool
+ (_ :
+ lazyResult
+ (diag runtimeEnv : checkedRuntimeFail diag)
+ (value runtimeEnv : self ((checkedExecBindContinuation exec) value))
+ (self (checkedExecBindExec exec)))
+ (_ : checkedRuntimeFail (malformedGuardResultDiagnostic guardContextUnknown viewAny exec))
+ (equal? tag checkedExecTagBind))
+ (equal? tag checkedExecTagGuard))
+ (equal? tag checkedExecTagFail))
+ (equal? tag checkedExecTagPure)
+
+runChecked = (exec : y runChecked_ exec)
+
+checkTypedProgramWith = (policy program :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ :
+ lazyResult
+ (diag env : err diag env)
+ (env rest :
+ lazyMaybe
+ (_ : checkerErr errorTagMalformedProgram t env)
+ (term : ok (checkedExecForRootTerm program term) env)
+ (lookupTypedTerm (typedProgramRoot program) program))
+ (flowCheckTypedNodes policy (typedProgramNodes program)))
+ (_ : checkerErr errorTagMalformedProgram t t)
+ (wellFormedTypedProgram? program))
+ (_ : checkerErr errorTagMalformedPolicy t t)
+ (wellFormedPolicy? policy))
+
+checkTypedProgram = (program :
+ checkTypedProgramWith policyGradual program)
+
+checkedProgramTree = (result :
+ matchResult
+ (diag env : t)
+ (exec env :
+ matchResult
+ (runtimeDiag runtimeEnv : t)
+ (value runtimeEnv : value)
+ (runChecked exec))
+ result)
+
+checkerResultErrorTag = (result :
+ matchResult
+ (diag env : diagnosticTag diag)
+ (env rest : errorTagOk)
+ result)
+
+-- ---------------------------------------------------------------------------
+-- Portable contract examples / self-tests. These are plain tricu values that
+-- travel with the checker and exercise the same validators used by clients.
+-- ---------------------------------------------------------------------------
+
+viewBool = viewRef 0
+viewString = viewRef 1
+viewByte = viewRef 2
+viewUnit = viewRef 3
+
+renderViewArgs_ self viewSelf views =
+ lazyList
+ (_ : "")
+ (view rest :
+ lazyBool
+ (_ : viewSelf view)
+ (_ : append (viewSelf view) (append ", " (self viewSelf rest)))
+ (emptyList? rest))
+ views
+
+renderView_ self view =
+ lazyBool
+ (_ : "Bool")
+ (_ :
+ lazyBool
+ (_ : "String")
+ (_ :
+ lazyBool
+ (_ : "Byte")
+ (_ :
+ lazyBool
+ (_ : "Unit")
+ (_ :
+ lazyBool
+ (_ : "Any")
+ (_ :
+ lazyBool
+ (_ : append "Ref " (showNumber (field0 (viewPayload view))))
+ (_ :
+ lazyBool
+ (_ : append "List " (self (field0 (viewPayload view))))
+ (_ :
+ lazyBool
+ (_ : append "Maybe " (self (field0 (viewPayload view))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ "Pair "
+ (append
+ (self (field0 (viewPayload view)))
+ (append " " (self (field1 (viewPayload view))))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ "Result "
+ (append
+ (self (field0 (viewPayload view)))
+ (append " " (self (field1 (viewPayload view))))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ "Fn ["
+ (append
+ (y renderViewArgs_ self (fnArgs view))
+ (append "] " (self (fnResult view)))))
+ (_ :
+ lazyBool
+ (_ : append "Guarded " (self (guardedViewBase view)))
+ (_ : "View")
+ (guardedView? view))
+ (fnView? view))
+ (resultView? view))
+ (pairView? view))
+ (maybeView? view))
+ (listView? view))
+ (refView? view))
+ (anyView? view))
+ (equal? view viewUnit))
+ (equal? view viewByte))
+ (equal? view viewString))
+ (equal? view viewBool)
+
+renderView = (view :
+ y renderView_ view)
+
+append3 = (a b c : append a (append b c))
+append4 = (a b c d : append a (append b (append c d)))
+
+guardContextSymbol = (context : field0 (recordFields context))
+guardContextApplication = (context : field0 (recordFields context))
+guardContextCallee = (context : field1 (recordFields context))
+guardContextArg = (context : field2 (recordFields context))
+guardContextArgIndex = (context : field3 (recordFields context))
+
+renderGuardContext = (context :
+ let tag = recordTag context in
+ lazyBool
+ (_ : append " at root typedValue symbol " (showNumber (guardContextSymbol context)))
+ (_ :
+ lazyBool
+ (_ : append " at root typedRequire symbol " (showNumber (guardContextSymbol context)))
+ (_ :
+ lazyBool
+ (_ : append " at typedValue symbol " (showNumber (guardContextSymbol context)))
+ (_ :
+ lazyBool
+ (_ : append " at typedRequire symbol " (showNumber (guardContextSymbol context)))
+ (_ :
+ lazyBool
+ (_ :
+ append4
+ " at argument "
+ (showNumber (guardContextArgIndex context))
+ " of application symbol "
+ (append
+ (showNumber (guardContextApplication context))
+ (append
+ " (callee symbol "
+ (append
+ (showNumber (guardContextCallee context))
+ (append ", arg symbol " (append (showNumber (guardContextArg context)) ")"))))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ " at result of application symbol "
+ (append
+ (showNumber (guardContextApplication context))
+ (append
+ " (callee symbol "
+ (append
+ (showNumber (guardContextCallee context))
+ (append ", arg symbol " (append (showNumber (guardContextArg context)) ")"))))))
+ (_ : "")
+ (equal? tag guardContextTagFunctionResult))
+ (equal? tag guardContextTagFunctionArgument))
+ (equal? tag guardContextTagSymbolRequire))
+ (equal? tag guardContextTagSymbolValue))
+ (equal? tag guardContextTagRootRequire))
+ (equal? tag guardContextTagRootValue))
+
+renderDiagnostic = (diag :
+ let tag = diagnosticTag diag in
+ lazyBool
+ (_ : "malformed view policy")
+ (_ :
+ lazyBool
+ (_ : "malformed view program")
+ (_ :
+ lazyBool
+ (_ : append "unknown typed node tag " (showNumber (field0 (diagnosticPayload diag))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ "symbol "
+ (append
+ (showNumber (diagnosticSymbol diag))
+ (append
+ " expected "
+ (append
+ (renderView (diagnosticExpectedView diag))
+ (append " but got " (renderView (diagnosticActualView diag)))))))
+ (_ :
+ lazyBool
+ (_ :
+ append
+ "symbol "
+ (append
+ (showNumber (diagnosticSymbol diag))
+ (append
+ " expected "
+ (append
+ (renderView (diagnosticExpectedView diag))
+ (append " but got " (renderView (diagnosticActualView diag)))))))
+ (_ :
+ lazyBool
+ (_ : "cannot apply zero-arity Fn view")
+ (_ :
+ lazyBool
+ (_ : append (append "guard failed" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag))))
+ (_ :
+ lazyBool
+ (_ : append (append "malformed guard result" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag))))
+ (_ : "unknown checker error")
+ (equal? tag errorTagMalformedGuardResult))
+ (equal? tag errorTagGuardFailed))
+ (equal? tag errorTagZeroArityFunction))
+ (equal? tag errorTagMissingFunctionArgumentView))
+ (equal? tag errorTagMissingRequiredView))
+ (equal? tag errorTagUnknownNode))
+ (equal? tag errorTagMalformedProgram))
+ (equal? tag errorTagMalformedPolicy))
+
+viewContractProbe = (condition :
+ matchBool "ok" "fail" condition)
+
+viewContractExpectResult = (expected result :
+ matchResult
+ (diag env : viewContractProbe (equal? (diagnosticMessage diag) expected))
+ (env rest : viewContractProbe (equal? "ok" expected))
+ result)
+
+viewContractExpectErrorTag = (expected result :
+ viewContractProbe (equal? (checkerResultErrorTag result) expected))
+
+viewContractExpectDiagnostic = (tag symbol expectedView result :
+ matchResult
+ (diag env :
+ viewContractProbe
+ (and?
+ (equal? (diagnosticTag diag) tag)
+ (and?
+ (equal? (diagnosticSymbol diag) symbol)
+ (equal? (diagnosticExpectedView diag) expectedView))))
+ (env rest : "fail")
+ result)
+
+viewContractExpectDiagnosticActual = (tag symbol expectedView actualView result :
+ matchResult
+ (diag env :
+ viewContractProbe
+ (and?
+ (equal? (diagnosticTag diag) tag)
+ (and?
+ (equal? (diagnosticSymbol diag) symbol)
+ (and?
+ (equal? (diagnosticExpectedView diag) expectedView)
+ (equal? (diagnosticActualView diag) actualView)))))
+ (env rest : "fail")
+ result)
+
+-- Small typed-program builder layer. These aliases make hand-written
+-- contracts look like source-level declarations while emitting typed nodes.
+typedDeclareFn = (symbol args result term :
+ typedValue symbol (viewFn args result) term)
+
+viewUnary = (arg result :
+ viewFn [(arg)] result)
+
+viewBinary = (left right result :
+ viewFn [(left) (right)] result)
+
+viewTernary = (first second third result :
+ viewFn [(first) (second) (third)] result)
+
+typedDeclareUnary = (symbol arg result term :
+ typedDeclareFn symbol [(arg)] result term)
+
+typedDeclareBinary = (symbol left right result term :
+ typedDeclareFn symbol [(left) (right)] result term)
+
+typedDeclareTernary = (symbol first second third result term :
+ typedDeclareFn symbol [(first) (second) (third)] result term)
+
+typedUseUnary = (arg result fnSym argSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareUnary fnSym arg result t)
+ (typedValue argSym arg t)
+ (typedApply outSym fnSym argSym t)
+ (typedRequire outSym result t)])
+
+typedUseBinary = (left right result fnSym leftSym rightSym partialSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareBinary fnSym left right result t)
+ (typedValue leftSym left t)
+ (typedValue rightSym right t)
+ (typedApply partialSym fnSym leftSym t)
+ (typedApply outSym partialSym rightSym t)
+ (typedRequire outSym result t)])
+
+typedUseTernary = (first second third result fnSym firstSym secondSym thirdSym partial1Sym partial2Sym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareTernary fnSym first second third result t)
+ (typedValue firstSym first t)
+ (typedValue secondSym second t)
+ (typedValue thirdSym third t)
+ (typedApply partial1Sym fnSym firstSym t)
+ (typedApply partial2Sym partial1Sym secondSym t)
+ (typedApply outSym partial2Sym thirdSym t)
+ (typedRequire outSym result t)])
+
+cValue = (view :
+ record contractExprTagValue [(field contractExprFieldView view)])
+
+cFn = (args result :
+ record contractExprTagFn
+ [(field contractExprFieldArgs args) (field contractExprFieldResult result)])
+
+cCall = (fn arg :
+ record contractExprTagCall
+ [(field contractExprFieldFn fn) (field contractExprFieldArg arg)])
+
+cApply = (arg fn : cCall fn arg)
+
+cRequire = (view expr :
+ record contractExprTagRequire
+ [(field contractExprFieldExpr expr) (field contractExprFieldRequired view)])
+
+cCompiledSymbol = fst
+cCompiledNext = (compiled : fst (snd compiled))
+cCompiledNodes = (compiled : snd (snd compiled))
+cCompiled = (symbol next nodes : pair symbol (pair next nodes))
+
+cCompile_ self base expr =
+ let tag = recordTag expr in
+ let fields = recordFields expr in
+ lazyBool
+ (_ :
+ cCompiled
+ base
+ (succ base)
+ [(typedValue base (field0 fields) t)])
+ (_ :
+ lazyBool
+ (_ :
+ cCompiled
+ base
+ (succ base)
+ [(typedDeclareFn base (field0 fields) (field1 fields) t)])
+ (_ :
+ lazyBool
+ (_ :
+ let fnCompiled = self base (field0 fields) in
+ let argCompiled = self (cCompiledNext fnCompiled) (field1 fields) in
+ let outSym = cCompiledNext argCompiled in
+ cCompiled
+ outSym
+ (succ outSym)
+ (append
+ (cCompiledNodes fnCompiled)
+ (append
+ (cCompiledNodes argCompiled)
+ [(typedApply outSym (cCompiledSymbol fnCompiled) (cCompiledSymbol argCompiled) t)])))
+ (_ :
+ let innerCompiled = self base (field0 fields) in
+ cCompiled
+ (cCompiledSymbol innerCompiled)
+ (cCompiledNext innerCompiled)
+ (append
+ (cCompiledNodes innerCompiled)
+ [(typedRequire (cCompiledSymbol innerCompiled) (field1 fields) t)]))
+ (equal? tag contractExprTagCall))
+ (equal? tag contractExprTagFn))
+ (equal? tag contractExprTagValue)
+
+cCompile = (base expr : y cCompile_ base expr)
+
+cCompileAt = (base expr :
+ let compiled = cCompile base expr in
+ typedProgram (cCompiledSymbol compiled) (cCompiledNodes compiled))
+
+typedContractCheck = (program :
+ viewContractExpectResult "ok" (checkTypedProgram program))
+
+viewContractSelfTests = [
+ (viewContractProbe (wellFormedView? viewAny))
+ (viewContractProbe (wellFormedView? (viewRef 10)))
+ (viewContractProbe (wellFormedView? (viewList viewBool)))
+ (viewContractProbe (wellFormedView? (viewMaybe viewString)))
+ (viewContractProbe (wellFormedView? (viewPair viewBool viewString)))
+ (viewContractProbe (wellFormedView? (viewResult viewString viewBool)))
+ (viewContractProbe (wellFormedView? (viewGuarded viewString (x : x))))
+ (viewContractProbe (equal? (renderView viewBool) "Bool"))
+ (viewContractProbe (equal? (renderView (viewList viewBool)) "List Bool"))
+ (viewContractProbe (equal? (renderView (viewMaybe viewString)) "Maybe String"))
+ (viewContractProbe (equal? (renderView (viewPair viewBool viewString)) "Pair Bool String"))
+ (viewContractProbe (equal? (renderView (viewResult viewString viewBool)) "Result String Bool"))
+ (viewContractProbe (equal? (renderView (viewGuarded viewString (x : x))) "Guarded String"))
+ (viewContractProbe (equal? (renderView (viewFn [(viewBool) (viewString)] viewUnit)) "Fn [Bool, String] Unit"))
+ (viewContractProbe (not? (wellFormedView? 10)))
+ (viewContractProbe (not? (wellFormedView? (record viewTagList [(field 99 viewBool)]))))
+ (viewContractExpectResult
+ "ok"
+ (checkTypedProgram
+ (typedProgram
+ 0
+ [(typedValue 0 viewBool t)
+ (typedRequire 0 viewBool t)])))
+ (viewContractExpectResult
+ "ok"
+ (checkTypedProgram
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewBool)] viewString) t)
+ (typedValue 1 viewBool t)
+ (typedApply 2 0 1 t)
+ (typedRequire 2 viewString t)])))
+ (typedContractCheck (typedUseUnary viewBool viewString 20 21 22))
+ (typedContractCheck (typedUseBinary viewBool viewString viewUnit 30 31 32 33 34))
+ (typedContractCheck (typedUseTernary viewBool viewString viewByte viewUnit 40 41 42 43 44 45 46))
+ (typedContractCheck
+ (cCompileAt
+ 50
+ (cRequire viewString (cApply (cValue viewBool) (cFn [(viewBool)] viewString)))))
+ (typedContractCheck
+ (cCompileAt
+ 60
+ (cRequire
+ (viewList viewString)
+ (cApply
+ (cValue (viewList viewBool))
+ (cApply
+ (cFn [(viewBool)] viewString)
+ (cFn [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)))))))
+ (viewContractExpectResult
+ "function argument view is not known"
+ (checkTypedProgramWith
+ policyStrict
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewBool)] viewString) t)
+ (typedApply 2 0 1 t)])))
+ (viewContractExpectResult
+ "ok"
+ (checkTypedProgramWith
+ policyGradual
+ (typedProgram
+ 0
+ [(typedRequire 0 viewBool t)])))
+ (viewContractExpectResult
+ "malformed view program"
+ (checkTypedProgram (record 99 t)))
+ (viewContractExpectResult
+ "ok"
+ (checkTypedProgram
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewBool)] viewString) t)
+ (typedValue 1 viewBool t)
+ (typedApply 2 0 1 (t t))
+ (typedRequire 2 viewString (t t))])))
+ (viewContractProbe
+ (equal?
+ (checkedProgramTree
+ (checkTypedProgram
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewBool)] viewString) t)
+ (typedValue 1 viewBool t)
+ (typedApply 2 0 1 (t t))
+ (typedRequire 2 viewString (t t))])))
+ (t t)))
+ (viewContractExpectErrorTag
+ errorTagMissingFunctionArgumentView
+ (checkTypedProgramWith
+ policyStrict
+ (typedProgram
+ 2
+ [(typedValue 0 (viewFn [(viewBool)] viewString) t)
+ (typedApply 2 0 1 (t t))])))
+ (viewContractExpectErrorTag
+ errorTagMalformedProgram
+ (checkTypedProgram
+ (typedProgram 0 [(record typedNodeTagValue t)])))
+ (viewContractExpectErrorTag
+ errorTagMalformedPolicy
+ (checkTypedProgramWith (pair 99 t) (typedProgram 0 t)))
+ (viewContractExpectErrorTag
+ errorTagMalformedProgram
+ (checkTypedProgram (record 99 t)))]
diff --git a/lib/views/catalog.tri b/lib/views/catalog.tri
@@ -0,0 +1,267 @@
+!import "prelude" !Local
+!import "view" !Local
+
+-- Stdlib-shaped typed-program catalog. These helpers are stable lowering
+-- targets for frontend-emitted API contracts. They are monomorphic
+-- instantiations of familiar polymorphic shapes.
+listMapUseContract = (elemIn elemOut mapSym fnSym xsSym partialSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareFn
+ mapSym
+ [(viewFn [(elemIn)] elemOut) (viewList elemIn)]
+ (viewList elemOut)
+ t)
+ (typedDeclareFn fnSym [(elemIn)] elemOut t)
+ (typedValue xsSym (viewList elemIn) t)
+ (typedApply partialSym mapSym fnSym t)
+ (typedApply outSym partialSym xsSym t)
+ (typedRequire outSym (viewList elemOut) t)])
+
+headMaybeUseContract = (elem headSym xsSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareFn headSym [(viewList elem)] (viewMaybe elem) t)
+ (typedValue xsSym (viewList elem) t)
+ (typedApply outSym headSym xsSym t)
+ (typedRequire outSym (viewMaybe elem) t)])
+
+listFilterUseContract = (elem filterSym predSym xsSym partialSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareFn
+ filterSym
+ [(viewFn [(elem)] viewBool) (viewList elem)]
+ (viewList elem)
+ t)
+ (typedDeclareFn predSym [(elem)] viewBool t)
+ (typedValue xsSym (viewList elem) t)
+ (typedApply partialSym filterSym predSym t)
+ (typedApply outSym partialSym xsSym t)
+ (typedRequire outSym (viewList elem) t)])
+
+listFoldUseContract = (acc elem foldSym fnSym initSym xsSym partialFnSym partialInitSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareFn
+ foldSym
+ [(viewFn [(acc) (elem)] acc) acc (viewList elem)]
+ acc
+ t)
+ (typedDeclareFn fnSym [(acc) (elem)] acc t)
+ (typedValue initSym acc t)
+ (typedValue xsSym (viewList elem) t)
+ (typedApply partialFnSym foldSym fnSym t)
+ (typedApply partialInitSym partialFnSym initSym t)
+ (typedApply outSym partialInitSym xsSym t)
+ (typedRequire outSym acc t)])
+
+listMapMaybeUseContract = (elemIn elemOut mapMaybeSym fnSym xsSym partialSym outSym :
+ typedProgram
+ outSym
+ [(typedDeclareFn
+ mapMaybeSym
+ [(viewFn [(elemIn)] (viewMaybe elemOut)) (viewList elemIn)]
+ (viewList elemOut)
+ t)
+ (typedDeclareFn fnSym [(elemIn)] (viewMaybe elemOut) t)
+ (typedValue xsSym (viewList elemIn) t)
+ (typedApply partialSym mapMaybeSym fnSym t)
+ (typedApply outSym partialSym xsSym t)
+ (typedRequire outSym (viewList elemOut) t)])
+
+-- Concrete stdlib-shaped typed programs. These are deliberately monomorphic
+-- examples of the shapes a frontend can emit for polymorphic library functions.
+listMapBoolStringExpr = cFn <|
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
+ |> cApply (cFn [(viewBool)] viewString)
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire (viewList viewString)
+
+headMaybeBoolExpr = cFn <|
+ [(viewList viewBool)] (viewMaybe viewBool)
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire (viewMaybe viewBool)
+
+listFilterBoolExpr = cFn <|
+ [(viewFn [(viewBool)] viewBool) (viewList viewBool)] (viewList viewBool)
+ |> cApply (cFn [(viewBool)] viewBool)
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire (viewList viewBool)
+
+listFoldStringBoolExpr = cFn <|
+ [(viewFn [(viewString) (viewBool)] viewString) viewString (viewList viewBool)] viewString
+ |> cApply (cFn [(viewString) (viewBool)] viewString)
+ |> cApply (cValue viewString)
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire viewString
+
+listMapMaybeBoolStringExpr = cFn <|
+ [(viewFn [(viewBool)] (viewMaybe viewString)) (viewList viewBool)] (viewList viewString)
+ |> cApply (cFn [(viewBool)] (viewMaybe viewString))
+ |> cApply (cValue (viewList viewBool))
+ |> cRequire (viewList viewString)
+
+-- Keep catalog exports as explicit finite typed-programs. `cCompileAt` is useful
+-- as a frontend-emission helper, but forcing generated node lists at module
+-- import time can violate top-level normalization discipline.
+listMapBoolStringContract =
+ listMapUseContract viewBool viewString 100 101 102 103 104
+headMaybeBoolContract =
+ headMaybeUseContract viewBool 110 111 112
+listFilterBoolContract =
+ listFilterUseContract viewBool 120 121 122 123 124
+listFoldStringBoolContract =
+ listFoldUseContract viewString viewBool 130 131 132 133 134 135 136
+listMapMaybeBoolStringContract =
+ listMapMaybeUseContract viewBool viewString 140 141 142 143 144
+
+listMapWrongFunctionArgContract =
+ typedProgram
+ 152
+ [(typedDeclareFn
+ 150
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)]
+ (viewList viewString)
+ t)
+ (typedDeclareFn 151 [(viewString)] viewString t)
+ (typedApply 152 150 151 t)]
+
+listMapWrongListArgContract =
+ typedProgram
+ 164
+ [(typedDeclareFn
+ 160
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)]
+ (viewList viewString)
+ t)
+ (typedDeclareFn 161 [(viewBool)] viewString t)
+ (typedValue 162 (viewList viewString) t)
+ (typedApply 163 160 161 t)
+ (typedApply 164 163 162 t)]
+
+listMapWrongOutputContract =
+ typedProgram
+ 174
+ [(typedDeclareFn
+ 170
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)]
+ (viewList viewString)
+ t)
+ (typedDeclareFn 171 [(viewBool)] viewString t)
+ (typedValue 172 (viewList viewBool) t)
+ (typedApply 173 170 171 t)
+ (typedApply 174 173 172 t)
+ (typedRequire 174 (viewList viewBool) t)]
+
+listFilterWrongPredicateContract =
+ typedProgram
+ 182
+ [(typedDeclareFn
+ 180
+ [(viewFn [(viewBool)] viewBool) (viewList viewBool)]
+ (viewList viewBool)
+ t)
+ (typedDeclareFn 181 [(viewBool)] viewString t)
+ (typedApply 182 180 181 t)]
+
+listMapWrongListArgExpr = cFn <|
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
+ |> cApply (cFn [(viewBool)] viewString)
+ |> cApply (cValue (viewList viewString))
+ |> cRequire (viewList viewString)
+
+listMapWrongListArgExprContract =
+ typedProgram
+ 194
+ [(typedDeclareFn
+ 190
+ [(viewFn [(viewBool)] viewString) (viewList viewBool)]
+ (viewList viewString)
+ t)
+ (typedDeclareFn 191 [(viewBool)] viewString t)
+ (typedValue 193 (viewList viewString) t)
+ (typedApply 192 190 191 t)
+ (typedApply 194 192 193 t)
+ (typedRequire 194 (viewList viewString) t)]
+
+viewCatalogSelfTests =
+ append
+ viewContractSelfTests
+ [ (typedContractCheck listMapBoolStringContract)
+ (typedContractCheck headMaybeBoolContract)
+ (typedContractCheck listFilterBoolContract)
+ (typedContractCheck listFoldStringBoolContract)
+ (typedContractCheck listMapMaybeBoolStringContract)
+ (viewContractExpectResult
+ "function argument view is not known"
+ (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
+ (viewContractExpectResult
+ "function argument view is not known"
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract))
+ (viewContractExpectResult
+ "required view is not known"
+ (checkTypedProgramWith policyStrict listMapWrongOutputContract))
+ (viewContractExpectResult
+ "function argument view is not known"
+ (checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
+ (viewContractExpectResult
+ "function argument view is not known"
+ (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
+ (viewContractExpectErrorTag
+ errorTagOk
+ (checkTypedProgram listMapBoolStringContract))
+ (viewContractExpectErrorTag
+ errorTagMissingFunctionArgumentView
+ (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
+ (viewContractExpectErrorTag
+ errorTagMissingFunctionArgumentView
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract))
+ (viewContractExpectErrorTag
+ errorTagMissingFunctionArgumentView
+ (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
+ (viewContractExpectErrorTag
+ errorTagMissingRequiredView
+ (checkTypedProgramWith policyStrict listMapWrongOutputContract))
+ (viewContractExpectDiagnostic
+ errorTagMissingFunctionArgumentView
+ 162
+ (viewList viewBool)
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract))
+ (viewContractExpectDiagnostic
+ errorTagMissingRequiredView
+ 174
+ (viewList viewBool)
+ (checkTypedProgramWith policyStrict listMapWrongOutputContract))
+ (viewContractExpectDiagnosticActual
+ errorTagMissingFunctionArgumentView
+ 162
+ (viewList viewBool)
+ (viewList viewString)
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract))
+ (viewContractExpectDiagnosticActual
+ errorTagMissingFunctionArgumentView
+ 193
+ (viewList viewBool)
+ (viewList viewString)
+ (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
+ (viewContractExpectDiagnosticActual
+ errorTagMissingRequiredView
+ 174
+ (viewList viewBool)
+ (viewList viewString)
+ (checkTypedProgramWith policyStrict listMapWrongOutputContract))
+ (viewContractExpectDiagnosticActual
+ errorTagMissingFunctionArgumentView
+ 181
+ (viewFn [(viewBool)] viewBool)
+ (viewFn [(viewBool)] viewString)
+ (checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
+ (matchResult
+ (diag env :
+ viewContractProbe
+ (equal?
+ (renderDiagnostic diag)
+ "symbol 162 expected List Bool but got List String"))
+ (env rest : "fail")
+ (checkTypedProgramWith policyStrict listMapWrongListArgContract))]
diff --git a/src/Check.hs b/src/Check.hs
@@ -0,0 +1,42 @@
+module Check
+ ( module Check.Core
+ , module Check.IO
+ , checkFile
+ , checkFileWithStore
+ , checkSource
+ ) where
+
+import Check.Core
+import Check.IO
+import ContentStore (ObjectRef, StorePath, getViewType)
+import Eval (evalTricu)
+import FileEval (LoadedSource(..), defaultStorePath, evaluateFile, evaluateFileWithStore, loadFileWithStore)
+import Research (Env, ViewType)
+
+import qualified Data.Map as Map
+
+import System.IO.Unsafe (unsafePerformIO)
+
+checkFile :: FilePath -> IO String
+checkFile path = do
+ store <- defaultStorePath
+ checkFileWithStore store path
+
+checkFileWithStore :: StorePath -> FilePath -> IO String
+checkFileWithStore store path = do
+ loaded <- loadFileWithStore store path
+ viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri"
+ let baseEnv = Map.union viewEnv (loadedImports loaded)
+ checkerEnv = evalTricu baseEnv (loadedAst loaded)
+ imports <- importedViewsFromResolvedModulesEither (loadImportedView store) (loadedModules loaded)
+ checkProgramWithEnvAndImportedViews checkerEnv imports (loadedAst loaded)
+
+viewCheckerEnv :: Env
+viewCheckerEnv = unsafePerformIO (evaluateFile "./lib/view.tri")
+{-# NOINLINE viewCheckerEnv #-}
+
+checkSource :: String -> IO String
+checkSource = checkSourceWithEnv viewCheckerEnv
+
+loadImportedView :: StorePath -> ObjectRef -> IO (Either String ViewType)
+loadImportedView = getViewType
diff --git a/src/Check/Core.hs b/src/Check/Core.hs
@@ -0,0 +1,751 @@
+module Check.Core
+ ( ImportedView(..)
+ , importedViewsFromResolvedModules
+ , importedViewsFromResolvedModulesEither
+ , checkProgramWithEnvAndImportedViews
+ , checkSourceWithEnv
+ , checkSourceWithEnvAndImportedViews
+ , lowerSource
+ , lowerSourceWithDebug
+ , lowerSourceWithImportedViews
+ , lowerSourceWithImportedViewsDebug
+ , lowerViewExpr
+ ) where
+
+import Control.Monad.State.Strict
+import Data.Char (isDigit)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+
+import ContentStore.Alias (ObjectRef(..))
+import Eval (evalTricu, result)
+import Module.Resolver
+ ( ResolvedExport(..)
+ , ResolvedModule(..)
+ )
+import Parser (parseTricu)
+import Research
+
+data ImportedView = ImportedView
+ { importedViewName :: String
+ , importedViewType :: ViewType
+ } deriving (Show, Eq)
+
+-- Convert module-resolution metadata into checker evidence inputs. The loader
+-- decodes a portable view artifact into a syntactic ViewType, but this function
+-- does not judge compatibility or policy. It only says: this resolved imported
+-- name has an advertised view fact that should be emitted into the typed program.
+importedViewsFromResolvedModules :: (ObjectRef -> IO (Maybe ViewType)) -> [ResolvedModule] -> IO [ImportedView]
+importedViewsFromResolvedModules loadView = importedViewsFromResolvedModulesEither loadViewEither
+ where
+ loadViewEither ref = do
+ mView <- loadView ref
+ pure $ maybe (Left "artifact not found or could not be decoded") Right mView
+
+importedViewsFromResolvedModulesEither :: (ObjectRef -> IO (Either String ViewType)) -> [ResolvedModule] -> IO [ImportedView]
+importedViewsFromResolvedModulesEither loadView modules = concat <$> mapM fromModule modules
+ where
+ fromModule m = concat <$> mapM fromExport (resolvedModuleExports m)
+
+ fromExport ex = case resolvedExportView ex of
+ Nothing -> pure []
+ Just ref -> do
+ eView <- loadView ref
+ case eView of
+ Left err -> errorWithoutStackTrace $
+ "View Contract artifact invalid for imported export "
+ ++ show (resolvedExportLocalName ex)
+ ++ " (kind " ++ showRefKind ref ++ ", hash " ++ showRefHash ref ++ "): "
+ ++ err
+ Right view -> pure [ImportedView (resolvedExportLocalName ex) view]
+
+ showRefKind = T.unpack . objectRefKind
+ showRefHash = T.unpack . objectRefHash
+
+checkSourceWithEnv :: Env -> String -> IO String
+checkSourceWithEnv checkerEnv = checkSourceWithEnvAndImportedViews checkerEnv []
+
+checkSourceWithEnvAndImportedViews :: Env -> [ImportedView] -> String -> IO String
+checkSourceWithEnvAndImportedViews checkerEnv imports source =
+ checkProgramWithEnvAndImportedViews checkerEnv imports (parseTricu source)
+
+checkProgramWithEnvAndImportedViews :: Env -> [ImportedView] -> [TricuAST] -> IO String
+checkProgramWithEnvAndImportedViews checkerEnv imports asts = do
+ case lowerProgramWithImportedViewsDebugInEnv checkerEnv imports asts of
+ Left err -> pure err
+ Right (typedProgramSource, debugNames) -> do
+ let input =
+ "matchResult " ++
+ "(diag env : renderDiagnostic diag) " ++
+ "(exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (_ runtimeEnv : \"ok\") (runChecked exec)) " ++
+ "(checkTypedProgramWith policyStrict " ++ parens typedProgramSource ++ ")"
+ let env = evalTricu checkerEnv (parseTricu input)
+ pure $ case toString (result env) of
+ Right s -> annotateDiagnostic debugNames s
+ Left _ -> formatT Decode (result env)
+
+-- Debug names are a frontend-only side table. The portable checker renders
+-- canonical numeric-symbol diagnostics; the CLI annotates that presentation
+-- afterward without feeding labels back into checker semantics.
+annotateDiagnostic :: Map.Map Integer String -> String -> String
+annotateDiagnostic debugNames message =
+ case words message of
+ ("symbol" : symText : rest)
+ | all isDigit symText
+ , Just label <- Map.lookup (read symText) debugNames ->
+ "symbol " ++ symText ++ " (" ++ label ++ ") " ++ unwords rest
+ _ -> message
+
+lowerSource :: String -> Either String String
+lowerSource = lowerProgram . parseTricu
+
+lowerSourceWithDebug :: String -> Either String (String, Map.Map Integer String)
+lowerSourceWithDebug = lowerProgramWithDebug . parseTricu
+
+lowerSourceWithImportedViews :: [ImportedView] -> String -> Either String String
+lowerSourceWithImportedViews imports = lowerProgramWithImportedViews imports . parseTricu
+
+lowerSourceWithImportedViewsDebug :: [ImportedView] -> String -> Either String (String, Map.Map Integer String)
+lowerSourceWithImportedViewsDebug imports = lowerProgramWithImportedViewsDebug imports . parseTricu
+
+-- Symbol allocation is intentionally deterministic so emitted view-tree
+-- nodes are stable and lower-only tests can inspect them directly:
+--
+-- * top-level definitions receive symbols 0..n-1 in source order;
+-- * local binders, literals, application results, and synthetic typed nodes
+-- are allocated monotonically from nextSym;
+-- * external names are allocated on first reference and then reused.
+--
+-- Symbols are view-tree node identifiers only. Checker semantics remain in
+-- lib/view.tri; the frontend only emits typed/checkable structure about these
+-- symbols.
+data LowerState = LowerState
+ { nextSym :: Integer
+ , topSyms :: Map.Map String Integer
+ , scopes :: [Map.Map String Integer]
+ , externSyms :: Map.Map String Integer
+ , knownNodeViews :: Map.Map Integer ViewExpr
+ , nodePayloads :: Map.Map Integer T
+ , debugNames :: Map.Map Integer String
+ }
+
+type LowerM a = StateT LowerState (Either String) a
+
+lowerProgram :: [TricuAST] -> Either String String
+lowerProgram asts = fst <$> lowerProgramWithDebug asts
+
+lowerProgramWithDebug :: [TricuAST] -> Either String (String, Map.Map Integer String)
+lowerProgramWithDebug = lowerProgramWithImportedViewsDebug []
+
+lowerProgramWithImportedViews :: [ImportedView] -> [TricuAST] -> Either String String
+lowerProgramWithImportedViews imports asts = fst <$> lowerProgramWithImportedViewsDebug imports asts
+
+lowerProgramWithImportedViewsDebug :: [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String)
+lowerProgramWithImportedViewsDebug = lowerProgramWithImportedViewsDebugInEnv Map.empty
+
+lowerProgramWithImportedViewsDebugInEnv :: Env -> [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String)
+lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do
+ let definitions = [ def | def <- asts, isDefinition def ]
+ topNames = map definitionName definitions
+ tops = Map.fromList (zip topNames [0..])
+ topCount = Map.size tops
+ importedSyms = Map.fromList
+ [ (importedViewName imported, fromIntegral (topCount + idx))
+ | (idx, imported) <- zip [0..] imports
+ ]
+ topDebug = Map.fromList [ (sym, name) | (name, sym) <- Map.toList tops ]
+ importDebug = Map.fromList
+ [ (sym, "imported " ++ name)
+ | (name, sym) <- Map.toList importedSyms
+ ]
+ importKnown = Map.fromList
+ [ (sym, viewTypeToExpr (importedViewType imported))
+ | imported <- imports
+ , Just sym <- [Map.lookup (importedViewName imported) importedSyms]
+ ]
+ payloads = Map.fromList $
+ [ (sym, term)
+ | (name, sym) <- Map.toList tops
+ , Just term <- [Map.lookup name checkerEnvForLowering]
+ ] ++
+ [ (sym, term)
+ | (name, sym) <- Map.toList importedSyms
+ , Just term <- [Map.lookup name checkerEnvForLowering]
+ ]
+ annotated = [ def | def@SDefAnn {} <- asts ]
+ initialState = LowerState
+ { nextSym = fromIntegral (Map.size tops + Map.size importedSyms)
+ , topSyms = tops
+ , scopes = []
+ , externSyms = importedSyms
+ , knownNodeViews = importKnown
+ , nodePayloads = payloads
+ , debugNames = Map.union topDebug importDebug
+ }
+ (localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState
+ importNodes <- mapM (lowerImportedView (nodePayloads finalState))
+ [ (sym, viewTypeToExpr (importedViewType imported))
+ | imported <- imports
+ , Just sym <- [Map.lookup (importedViewName imported) importedSyms]
+ ]
+ let nodes = importNodes ++ localNodes
+ rootSym = if null nodes then 0 else nextSym finalState - 1
+ typedProgramSource =
+ "typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]"
+ pure (typedProgramSource, debugNames finalState)
+lowerImportedView :: Map.Map Integer T -> (Integer, ViewExpr) -> Either String String
+lowerImportedView payloadsBySym (sym, view) = do
+ viewExpr <- lowerViewExpr view
+ let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym)
+ pure $ "typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload
+
+lowerAnnotatedProgram :: [TricuAST] -> LowerM [String]
+lowerAnnotatedProgram defs = do
+ declarations <- concat <$> mapM lowerDefinitionDeclaration defs
+ flows <- concat <$> mapM lowerDefinitionFlow defs
+ pure (declarations ++ flows)
+
+lowerDefinitionDeclaration :: TricuAST -> LowerM [String]
+lowerDefinitionDeclaration (SDefAnn name args ret _) = do
+ sym <- symbolForTop name
+ argViews <- mapM lowerArgView args
+ retExpr <- liftEither (maybe (Right "viewAny") lowerViewExpr ret)
+ recordKnown sym (declaredDefinitionView args ret)
+ node <- emitDeclaration sym argViews retExpr
+ pure [node]
+lowerDefinitionDeclaration _ = liftEither (Left "internal check error: expected annotated definition")
+
+lowerDefinitionFlow :: TricuAST -> LowerM [String]
+lowerDefinitionFlow (SDefAnn _ args ret body) = withDefinitionScope args $ do
+ binderNodes <- concat <$> mapM lowerBinderDeclaration args
+ let phantomViews = map lowerPhantomArgType (phantomArgs args)
+ (returnArgs, returnResult) <- lowerReturnObligation ret
+ bodyNodes <- lowerBodyWithPhantoms (phantomViews ++ returnArgs) returnResult body
+ pure (binderNodes ++ bodyNodes)
+lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotated definition")
+
+viewAnyType :: ViewExpr
+viewAnyType = VEName "Any"
+
+declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
+declaredDefinitionView args ret =
+ case map argType args of
+ [] -> resultType
+ views -> viewExprFn views resultType
+ where
+ resultType = maybe viewAnyType id ret
+
+argType :: DefArg -> ViewExpr
+argType (DefBinder _ Nothing) = viewAnyType
+argType (DefBinder _ (Just ty)) = ty
+argType (DefPhantom ty) = ty
+
+emitDeclaration :: Integer -> [String] -> String -> LowerM String
+emitDeclaration sym [] retExpr = do
+ payload <- payloadSourceFor sym
+ pure $ "typedValue " ++ show sym ++ " " ++ parens retExpr ++ " " ++ payload
+emitDeclaration sym views retExpr = do
+ payload <- payloadSourceFor sym
+ pure $ "typedValue " ++ show sym ++ " (viewFn [" ++ unwords (map parens views) ++ "] " ++ parens retExpr ++ ") " ++ payload
+
+typedValueNode :: Integer -> ViewExpr -> LowerM String
+typedValueNode sym view = do
+ viewExpr <- liftEither (lowerViewExpr view)
+ payload <- payloadSourceFor sym
+ pure ("typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
+
+typedRequireNode :: Integer -> ViewExpr -> LowerM String
+typedRequireNode sym view = do
+ viewExpr <- liftEither (lowerViewExpr view)
+ payload <- payloadSourceFor sym
+ pure ("typedRequire " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
+
+declareKnown :: Integer -> ViewExpr -> LowerM String
+declareKnown sym view = do
+ recordKnown sym view
+ typedValueNode sym view
+
+declareKnownWithPayload :: Integer -> ViewExpr -> T -> LowerM String
+declareKnownWithPayload sym view payload = do
+ recordPayload sym payload
+ declareKnown sym view
+
+declareKnownFresh :: ViewExpr -> LowerM (Integer, [String])
+declareKnownFresh view = do
+ sym <- freshSym
+ node <- declareKnown sym view
+ pure (sym, [node])
+
+declareKnownFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String])
+declareKnownFreshWithPayload view payload = do
+ sym <- freshSym
+ node <- declareKnownWithPayload sym view payload
+ pure (sym, [node])
+
+declareAndRequireFresh :: ViewExpr -> LowerM (Integer, [String])
+declareAndRequireFresh view = do
+ sym <- freshSym
+ declareNode <- declareKnown sym view
+ requireNode <- typedRequireNode sym view
+ pure (sym, [declareNode, requireNode])
+
+declareAndRequireFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String])
+declareAndRequireFreshWithPayload view payload = do
+ sym <- freshSym
+ declareNode <- declareKnownWithPayload sym view payload
+ requireNode <- typedRequireNode sym view
+ pure (sym, [declareNode, requireNode])
+
+lowerBinderDeclaration :: DefArg -> LowerM [String]
+lowerBinderDeclaration (DefBinder name mTy) = do
+ sym <- symbolForLocal name
+ node <- declareKnown sym (maybe viewAnyType id mTy)
+ pure [node]
+lowerBinderDeclaration (DefPhantom _) = pure []
+
+lowerBodyWithPhantoms :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM [String]
+lowerBodyWithPhantoms [] _ SLambda {} = pure []
+lowerBodyWithPhantoms [] expected body =
+ lowerExprAgainst body expected
+lowerBodyWithPhantoms phantomViews expected (SLambda params body) =
+ lowerLambdaSpine phantomViews expected params body
+lowerBodyWithPhantoms phantomViews expected body =
+ lowerExprAgainst body (residualViewExpr phantomViews expected)
+
+lowerLambdaSpine :: [ViewExpr] -> ViewExpr -> [String] -> TricuAST -> LowerM [String]
+lowerLambdaSpine phantomViews expected [] body = lowerBodyWithPhantoms phantomViews expected body
+lowerLambdaSpine [] _ _ _ = pure []
+lowerLambdaSpine (view : views) expected (param : params) body =
+ withLocalBinder param $ \paramSym -> do
+ declareParam <- declareKnown paramSym view
+ restNodes <- lowerLambdaSpine views expected params body
+ pure (declareParam : restNodes)
+
+residualViewExpr :: [ViewExpr] -> ViewExpr -> ViewExpr
+residualViewExpr [] resultView = resultView
+residualViewExpr args resultView = viewExprFn args resultView
+
+phantomArgs :: [DefArg] -> [DefArg]
+phantomArgs [] = []
+phantomArgs (DefPhantom ty : rest) = DefPhantom ty : phantomArgs rest
+phantomArgs (_ : rest) = phantomArgs rest
+
+lowerPhantomArgType :: DefArg -> ViewExpr
+lowerPhantomArgType (DefPhantom ty) = ty
+lowerPhantomArgType _ = error "internal check error: expected phantom arg"
+
+lowerReturnObligation :: Maybe ViewExpr -> LowerM ([ViewExpr], ViewExpr)
+lowerReturnObligation Nothing = pure ([], viewAnyType)
+lowerReturnObligation (Just ty) = pure (peelFnObligation ty)
+
+peelFnObligation :: ViewExpr -> ([ViewExpr], ViewExpr)
+peelFnObligation ty = case viewExprFnParts ty of
+ Just (args, resultView) ->
+ let (restArgs, finalResult) = peelFnObligation resultView
+ in (args ++ restArgs, finalResult)
+ Nothing -> ([], ty)
+
+withDefinitionScope :: [DefArg] -> LowerM a -> LowerM a
+withDefinitionScope args action = do
+ binderEntries <- mapM allocateBinder [ name | DefBinder name _ <- args ]
+ modify $ \st -> st { scopes = Map.fromList binderEntries : scopes st }
+ resultValue <- action
+ modify $ \st -> st { scopes = drop 1 (scopes st) }
+ pure resultValue
+
+allocateBinder :: String -> LowerM (String, Integer)
+allocateBinder name = do
+ sym <- freshSym
+ recordDebugName sym name
+ pure (name, sym)
+
+withLocalBinder :: String -> (Integer -> LowerM a) -> LowerM a
+withLocalBinder name action = do
+ sym <- freshSym
+ recordDebugName sym name
+ withLocalAlias name sym (action sym)
+
+withLocalAlias :: String -> Integer -> LowerM a -> LowerM a
+withLocalAlias name sym action = do
+ modify $ \st -> st { scopes = Map.singleton name sym : scopes st }
+ resultValue <- action
+ modify $ \st -> st { scopes = drop 1 (scopes st) }
+ pure resultValue
+
+recordKnown :: Integer -> ViewExpr -> LowerM ()
+recordKnown sym view =
+ modify $ \st -> st { knownNodeViews = Map.insert sym view (knownNodeViews st) }
+
+recordPayload :: Integer -> T -> LowerM ()
+recordPayload sym payload =
+ modify $ \st -> st { nodePayloads = Map.insert sym payload (nodePayloads st) }
+
+payloadFor :: Integer -> LowerM (Maybe T)
+payloadFor sym = do
+ st <- get
+ pure (Map.lookup sym (nodePayloads st))
+
+payloadSourceFor :: Integer -> LowerM String
+payloadSourceFor sym = maybe "t" treeSource <$> payloadFor sym
+
+knownNodeViewFor :: Integer -> LowerM (Maybe ViewExpr)
+knownNodeViewFor sym = do
+ st <- get
+ pure (Map.lookup sym (knownNodeViews st))
+
+recordDebugName :: Integer -> String -> LowerM ()
+recordDebugName sym label =
+ modify $ \st -> st { debugNames = Map.insertWith keepExisting sym label (debugNames st) }
+ where
+ keepExisting _ old = old
+
+lowerExpr :: TricuAST -> LowerM (Integer, [String])
+lowerExpr expr = do
+ (sym, nodes, _) <- lowerExprKnown expr
+ pure (sym, nodes)
+
+lowerExprAgainst :: TricuAST -> ViewExpr -> LowerM [String]
+lowerExprAgainst body expected = do
+ (_, nodes, _) <- lowerExprKnownAgainst body expected
+ pure nodes
+
+lowerExprKnownAgainst :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerExprKnownAgainst expr expected = case (expr, viewExprAsType expected) of
+ (SApp (SApp (SVar "pair" _) left) right, Just (VTPair leftView rightView)) ->
+ let leftExpr = viewTypeToExpr leftView
+ rightExpr = viewTypeToExpr rightView
+ in lowerUnshadowedConstructor "pair" expr expected $ do
+ (_, leftNodes, _) <- lowerExprKnownAgainst left leftExpr
+ (_, rightNodes, _) <- lowerExprKnownAgainst right rightExpr
+ (sym, nodes) <- declareAndRequireFresh expected
+ pure (sym, leftNodes ++ rightNodes ++ nodes, Just expected)
+ (SApp (SVar "just" _) value, Just (VTMaybe elemView)) ->
+ let elemExpr = viewTypeToExpr elemView
+ in lowerUnshadowedConstructor "just" expr expected $ do
+ (_, valueNodes, _) <- lowerExprKnownAgainst value elemExpr
+ (sym, nodes) <- declareAndRequireFresh expected
+ pure (sym, valueNodes ++ nodes, Just expected)
+ (SVar "nothing" _, Just (VTMaybe _)) ->
+ lowerUnshadowedConstructor "nothing" expr expected $ do
+ (sym, nodes) <- declareAndRequireFresh expected
+ pure (sym, nodes, Just expected)
+ (SApp (SApp (SVar "ok" _) value) rest, Just (VTResult _ okView)) ->
+ lowerUnshadowedConstructor "ok" expr expected $
+ lowerResultConstructor expected (viewTypeToExpr okView) value rest
+ (SApp (SApp (SVar "err" _) value) rest, Just (VTResult errView _)) ->
+ lowerUnshadowedConstructor "err" expr expected $
+ lowerResultConstructor expected (viewTypeToExpr errView) value rest
+ (SApp (SLambda [name] body) value, _) -> do
+ (valueSym, valueNodes, _) <- lowerExprKnown value
+ bodyResult <- withLocalAlias name valueSym (lowerExprKnownAgainst body expected)
+ let (bodySym, bodyNodes, bodyKnown) = bodyResult
+ pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
+ (SList items, Just (VTList elemView)) -> do
+ let elemExpr = viewTypeToExpr elemView
+ lowered <- mapM (`lowerExprKnownAgainst` elemExpr) items
+ let itemNodes = concat [ nodes | (_, nodes, _) <- lowered ]
+ (sym, nodes) <- declareAndRequireFresh expected
+ pure (sym, itemNodes ++ nodes, Just expected)
+ (SLambda _ _, _) ->
+ case peelFnObligation expected of
+ ([], _) -> lowerExprKnownAndRequire expr expected
+ (argViews, resultView) -> lowerLambdaAgainst argViews resultView expr
+ _ -> lowerExprKnownAndRequire expr expected
+
+lowerUnshadowedConstructor :: String -> TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr) -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerUnshadowedConstructor name fallback expected lowerCtor = do
+ ctorIsUnbound <- nameIsUnbound name
+ if ctorIsUnbound
+ then lowerCtor
+ else lowerExprKnownAndRequire fallback expected
+
+lowerResultConstructor :: ViewExpr -> ViewExpr -> TricuAST -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerResultConstructor expected valueView value rest = do
+ (_, valueNodes, _) <- lowerExprKnownAgainst value valueView
+ (_, restNodes, _) <- lowerExprKnown rest
+ (sym, nodes) <- declareAndRequireFresh expected
+ pure (sym, valueNodes ++ restNodes ++ nodes, Just expected)
+
+lowerExprKnownAndRequire :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerExprKnownAndRequire body expected = do
+ (bodySym, bodyNodes, known) <- lowerExprKnown body
+ requireNode <- typedRequireNode bodySym expected
+ pure (bodySym, bodyNodes ++ [requireNode], known)
+
+lowerLambdaAgainst :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerLambdaAgainst argViews resultView (SLambda params body) = do
+ nodes <- lowerLambdaSpine argViews resultView params body
+ sym <- freshSym
+ let fnView = residualViewExpr argViews resultView
+ declareNode <- declareKnown sym fnView
+ pure (sym, nodes ++ [declareNode], Just fnView)
+lowerLambdaAgainst argViews resultView body =
+ lowerExprKnownAndRequire body (residualViewExpr argViews resultView)
+
+lowerExprKnown :: TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerExprKnown (SVar name _) = do
+ sym <- symbolForName name
+ known <- knownNodeViewFor sym
+ pure (sym, [], known)
+lowerExprKnown (SStr s) = do
+ let view = VEName "String"
+ (sym, nodes) <- declareKnownFreshWithPayload view (ofString s)
+ recordDebugName sym "string literal"
+ pure (sym, nodes, Just view)
+lowerExprKnown (SInt n)
+ | n >= 0 && n <= 255 = do
+ let view = VEName "Byte"
+ (sym, nodes) <- declareKnownFreshWithPayload view (ofNumber n)
+ recordDebugName sym "byte literal"
+ pure (sym, nodes, Just view)
+ | otherwise = do
+ sym <- freshSym
+ pure (sym, [], Nothing)
+lowerExprKnown TLeaf = do
+ let view = VEName "Unit"
+ (sym, nodes) <- declareKnownFreshWithPayload view Leaf
+ recordDebugName sym "unit literal"
+ pure (sym, nodes, Just view)
+lowerExprKnown (SList items) = do
+ (sym, nodes, view, _) <- lowerListLiteral items
+ pure (sym, nodes, Just view)
+lowerExprKnown (SApp (SLambda [name] body) value) = do
+ (valueSym, valueNodes, known) <- lowerExprKnown value
+ bodyResult <- withLocalAlias name valueSym (lowerExprKnown body)
+ let (bodySym, bodyNodes, bodyKnown) = bodyResult
+ pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
+lowerExprKnown (SApp func arg) = do
+ (funcSym, funcNodes, funcKnown) <- lowerExprKnown func
+ (argSym, argNodes, _) <- lowerApplicationArgument funcKnown arg
+ outSym <- freshSym
+ recordDebugName outSym (applicationDebugLabel func)
+ funcPayload <- payloadFor funcSym
+ argPayload <- payloadFor argSym
+ case (funcPayload, argPayload) of
+ (Just f, Just a) -> recordPayload outSym (apply f a)
+ _ -> pure ()
+ applyPayload <- payloadSourceFor outSym
+ let applyNode = "typedApply " ++ show outSym ++ " " ++ show funcSym ++ " " ++ show argSym ++ " " ++ applyPayload
+ outKnown = applicationResultView funcKnown
+ mapM_ (recordKnown outSym) outKnown
+ pure (outSym, funcNodes ++ argNodes ++ [applyNode], outKnown)
+lowerExprKnown (SLambda params body) = do
+ nodes <- lowerUnannotatedLambda params body
+ sym <- freshSym
+ pure (sym, nodes, Nothing)
+lowerExprKnown _ = do
+ sym <- freshSym
+ pure (sym, [], Nothing)
+
+lowerListLiteral :: [TricuAST] -> LowerM (Integer, [String], ViewExpr, [Integer])
+lowerListLiteral items = do
+ lowered <- mapM lowerExprKnown items
+ let itemSyms = [ itemSym | (itemSym, _, _) <- lowered ]
+ itemNodes = concat [ nodes | (_, nodes, _) <- lowered ]
+ view = listLiteralView [ known | (_, _, known) <- lowered ]
+ itemPayloads <- mapM payloadFor itemSyms
+ let mPayload = ofList <$> sequence itemPayloads
+ (sym, declareNodes) <- case mPayload of
+ Just payload -> declareKnownFreshWithPayload view payload
+ Nothing -> declareKnownFresh view
+ pure (sym, itemNodes ++ declareNodes, view, itemSyms)
+
+lowerApplicationArgument :: Maybe ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
+lowerApplicationArgument (Just fnView) arg =
+ case viewExprFnParts fnView of
+ Just (argView : _, _) -> lowerExprKnownAgainst arg argView
+ _ -> lowerExprKnown arg
+lowerApplicationArgument _ arg =
+ lowerExprKnown arg
+
+applicationDebugLabel :: TricuAST -> String
+applicationDebugLabel func =
+ case applicationHeadName func of
+ Just name -> name ++ " application result"
+ Nothing -> "application result"
+
+applicationHeadName :: TricuAST -> Maybe String
+applicationHeadName (SVar name _) = Just name
+applicationHeadName (SApp func _) = applicationHeadName func
+applicationHeadName _ = Nothing
+
+applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr
+applicationResultView (Just fnView) = case viewExprFnParts fnView of
+ Just (_ : restArgs, resultView) ->
+ Just $ case restArgs of
+ [] -> resultView
+ _ -> viewExprFn restArgs resultView
+ _ -> Nothing
+applicationResultView _ = Nothing
+
+listLiteralView :: [Maybe ViewExpr] -> ViewExpr
+listLiteralView [] = viewExprList viewAnyType
+listLiteralView (Just firstView : rest)
+ | all (== Just firstView) rest = viewExprList firstView
+listLiteralView _ = viewExprList viewAnyType
+
+lowerUnannotatedLambda :: [String] -> TricuAST -> LowerM [String]
+lowerUnannotatedLambda [] body = do
+ (_, nodes) <- lowerExpr body
+ pure nodes
+lowerUnannotatedLambda (param : params) body =
+ withLocalBinder param $ \paramSym -> do
+ declareParam <- declareKnown paramSym viewAnyType
+ restNodes <- lowerUnannotatedLambda params body
+ pure (declareParam : restNodes)
+
+symbolForTop :: String -> LowerM Integer
+symbolForTop name = do
+ st <- get
+ case Map.lookup name (topSyms st) of
+ Just sym -> pure sym
+ Nothing -> liftEither (Left $ "internal check error: missing top-level symbol: " ++ name)
+
+symbolForLocal :: String -> LowerM Integer
+symbolForLocal name = do
+ st <- get
+ case lookupInScopes name (scopes st) of
+ Just sym -> pure sym
+ Nothing -> liftEither (Left $ "internal check error: missing local symbol: " ++ name)
+
+symbolForName :: String -> LowerM Integer
+symbolForName name = do
+ st <- get
+ case lookupInScopes name (scopes st) of
+ Just sym -> pure sym
+ Nothing -> case Map.lookup name (topSyms st) of
+ Just sym -> pure sym
+ Nothing -> symbolForExternal name
+
+symbolForExternal :: String -> LowerM Integer
+symbolForExternal name = do
+ st <- get
+ case Map.lookup name (externSyms st) of
+ Just sym -> pure sym
+ Nothing -> do
+ sym <- freshSym
+ recordDebugName sym ("external " ++ name)
+ modify $ \st' -> st' { externSyms = Map.insert name sym (externSyms st') }
+ pure sym
+
+nameIsUnbound :: String -> LowerM Bool
+nameIsUnbound name = do
+ st <- get
+ pure $ case lookupInScopes name (scopes st) of
+ Just _ -> False
+ Nothing -> Map.notMember name (topSyms st)
+
+lookupInScopes :: String -> [Map.Map String Integer] -> Maybe Integer
+lookupInScopes _ [] = Nothing
+lookupInScopes name (scope : rest) =
+ case Map.lookup name scope of
+ Just sym -> Just sym
+ Nothing -> lookupInScopes name rest
+
+freshSym :: LowerM Integer
+freshSym = do
+ st <- get
+ let sym = nextSym st
+ put st { nextSym = sym + 1 }
+ pure sym
+
+isDefinition :: TricuAST -> Bool
+isDefinition SDef {} = True
+isDefinition SDefAnn {} = True
+isDefinition _ = False
+
+definitionName :: TricuAST -> String
+definitionName (SDef name _ _) = name
+definitionName (SDefAnn name _ _ _) = name
+definitionName _ = error "definitionName: expected top-level definition"
+
+liftEither :: Either String a -> LowerM a
+liftEither value = StateT $ \st -> case value of
+ Left err -> Left err
+ Right resultValue -> Right (resultValue, st)
+
+lowerArgView :: DefArg -> LowerM String
+lowerArgView (DefBinder _ Nothing) = pure "viewAny"
+lowerArgView (DefBinder _ (Just ty)) = liftEither (lowerViewExpr ty)
+lowerArgView (DefPhantom ty) = liftEither (lowerViewExpr ty)
+
+viewTypeToExpr :: ViewType -> ViewExpr
+viewTypeToExpr view = case view of
+ VTName name -> VEName name
+ VTRef n -> VEApp (VEName "Ref") (VEInt n)
+ VTRefText s -> VEApp (VEName "Ref") (VEString s)
+ VTList item -> VEApp (VEName "List") (viewTypeToExpr item)
+ VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item)
+ VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right)
+ VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok)
+ VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard))
+ VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView)
+
+viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr
+viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView
+
+viewExprList :: ViewExpr -> ViewExpr
+viewExprList = VEApp (VEName "List")
+
+viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr)
+viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView)
+viewExprFnParts _ = Nothing
+
+viewExprAsType :: ViewExpr -> Maybe ViewType
+viewExprAsType view = case view of
+ VEName name -> Just (VTName name)
+ VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n)
+ VEApp (VEName "Ref") (VEString s) -> Just (VTRefText s)
+ VEApp (VEName "List") item -> VTList <$> viewExprAsType item
+ VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item
+ VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right
+ VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok
+ VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView
+ _ -> Nothing
+
+lowerViewExpr :: ViewExpr -> Either String String
+lowerViewExpr ty = case ty of
+ VEName "Any" -> Right "viewAny"
+ VEName "Bool" -> Right "viewBool"
+ VEName "String" -> Right "viewString"
+ VEName "Byte" -> Right "viewByte"
+ VEName "Unit" -> Right "viewUnit"
+ VEName name -> Right name
+ VEInt n -> Right (show n)
+ VEString s -> Right (show s)
+ VEList items -> do
+ itemExprs <- mapM lowerViewExpr items
+ Right $ "[" ++ unwords (map parens itemExprs) ++ "]"
+ VEApp (VEName "Ref") (VEInt n) -> Right $ "viewRef " ++ show n
+ VEApp (VEName "Ref") (VEString s) -> Right $ "viewRef " ++ show s
+ VEApp (VEName "List") elemView -> do
+ elemExpr <- lowerViewExpr elemView
+ Right $ "viewList " ++ parens elemExpr
+ VEApp (VEName "Maybe") elemView -> do
+ elemExpr <- lowerViewExpr elemView
+ Right $ "viewMaybe " ++ parens elemExpr
+ VEApp (VEApp (VEName "Pair") left) right -> do
+ l <- lowerViewExpr left
+ r <- lowerViewExpr right
+ Right $ "viewPair " ++ parens l ++ " " ++ parens r
+ VEApp (VEApp (VEName "Result") err) ok -> do
+ e <- lowerViewExpr err
+ a <- lowerViewExpr ok
+ Right $ "viewResult " ++ parens e ++ " " ++ parens a
+ VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> do
+ as <- mapM lowerViewExpr args
+ r <- lowerViewExpr resultView
+ Right $ "viewFn [" ++ unwords (map parens as) ++ "] " ++ parens r
+ VEApp func arg -> do
+ f <- lowerViewExpr func
+ a <- lowerViewExpr arg
+ Right $ parens f ++ " " ++ parens a
+ VERaw raw -> Right raw
+
+treeSource :: T -> String
+treeSource Leaf = "t"
+treeSource (Stem x) = "(t " ++ treeSource x ++ ")"
+treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")"
+
+parens :: String -> String
+parens s = "(" ++ s ++ ")"
diff --git a/src/Check/IO.hs b/src/Check/IO.hs
@@ -0,0 +1,409 @@
+module Check.IO
+ ( instrumentIOContinuations
+ ) where
+
+import Control.Monad.State.Strict
+import qualified Data.Map as Map
+
+import Check.Core (lowerViewExpr)
+import Parser (parseTricu)
+import Research
+
+viewAnyType :: ViewExpr
+viewAnyType = VEName "Any"
+
+argType :: DefArg -> ViewExpr
+argType (DefBinder _ Nothing) = viewAnyType
+argType (DefBinder _ (Just ty)) = ty
+argType (DefPhantom ty) = ty
+
+declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
+declaredDefinitionView args ret =
+ case map argType args of
+ [] -> resultType
+ views -> viewExprFn views resultType
+ where
+ resultType = maybe viewAnyType id ret
+
+viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr
+viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView
+
+viewExprList :: ViewExpr -> ViewExpr
+viewExprList = VEApp (VEName "List")
+
+viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr)
+viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView)
+viewExprFnParts _ = Nothing
+
+viewExprAsType :: ViewExpr -> Maybe ViewType
+viewExprAsType view = case view of
+ VEName name -> Just (VTName name)
+ VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n)
+ VEApp (VEName "Ref") (VEString st) -> Just (VTRefText st)
+ VEApp (VEName "List") item -> VTList <$> viewExprAsType item
+ VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item
+ VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right
+ VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok
+ VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView
+ _ -> Nothing
+
+viewTypeToExpr :: ViewType -> ViewExpr
+viewTypeToExpr view = case view of
+ VTName name -> VEName name
+ VTRef n -> VEApp (VEName "Ref") (VEInt n)
+ VTRefText st -> VEApp (VEName "Ref") (VEString st)
+ VTList item -> VEApp (VEName "List") (viewTypeToExpr item)
+ VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item)
+ VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right)
+ VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok)
+ VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard))
+ VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView)
+
+treeSource :: T -> String
+treeSource Leaf = "t"
+treeSource (Stem x) = "(t " ++ treeSource x ++ ")"
+treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")"
+
+applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr
+applicationResultView (Just fnView) = case viewExprFnParts fnView of
+ Just (_ : restArgs, resultView) ->
+ Just $ case restArgs of
+ [] -> resultView
+ _ -> viewExprFn restArgs resultView
+ _ -> Nothing
+applicationResultView _ = Nothing
+
+-- Instrument source-level IO continuations so pure calls to annotated
+-- functions can run the already-portable checked-exec protocol at runtime.
+-- This is deliberately a lowering pass: it builds checked boundaries once from
+-- source annotations, then ordinary IO execution only evaluates runChecked.
+instrumentIOContinuations :: [TricuAST] -> Either String [TricuAST]
+instrumentIOContinuations asts = mapM transformTop asts
+ where
+ contracts = Map.fromList
+ [ (name, (args, ret, body))
+ | SDefAnn name args ret body <- asts
+ , all isRuntimeBinder args
+ ]
+
+ isRuntimeBinder DefBinder {} = True
+ isRuntimeBinder DefPhantom {} = False
+
+ transformTop (SDef name params body) = SDef name params <$> transformExpr body
+ transformTop (SDefAnn name args ret body) = SDefAnn name args ret <$> transformExpr body
+ transformTop other = transformExpr other
+
+ transformExpr expr = case expr of
+ SApp (SVar "io" h) action -> SApp (SVar "io" h) <$> transformIOAction action
+ SApp f a -> SApp <$> transformExpr f <*> transformExpr a
+ SLambda params body -> SLambda params <$> transformExpr body
+ TStem x -> TStem <$> transformExpr x
+ TFork x y -> TFork <$> transformExpr x <*> transformExpr y
+ _ -> pure expr
+
+ transformIOAction action = case action of
+ SApp (SVar "pure" _) value ->
+ case checkedPureActionFor value of
+ Just checked -> parseOne checked
+ Nothing -> SApp (SVar "pure" Nothing) <$> transformExpr value
+ SApp (SApp (SVar "bind" h) left) (SLambda params body) ->
+ SApp <$> (SApp (SVar "bind" h) <$> transformIOAction left) <*> (SLambda params <$> transformIOAction body)
+ SApp f a -> SApp <$> transformIOAction f <*> transformIOAction a
+ SLambda params body -> SLambda params <$> transformIOAction body
+ _ -> transformExpr action
+
+ checkedPureActionFor value =
+ case contractedApplication value of
+ Just (name, defArgs, ret, body, callArgs) ->
+ Just (checkedPureApplicationActionSource contracts name defArgs ret body callArgs)
+ Nothing ->
+ if mentionsContractedName contracts value
+ then Just (checkedPureValueActionSource contracts value)
+ else Nothing
+ where
+ contractedApplication valueExpr = do
+ (headExpr, callArgs) <- applicationSpine valueExpr
+ name <- case headExpr of
+ SVar n _ -> Just n
+ _ -> Nothing
+ (defArgs, ret, body) <- Map.lookup name contracts
+ if length callArgs == length defArgs
+ then Just (name, defArgs, ret, body, callArgs)
+ else Nothing
+
+ parseOne source = case parseTricu source of
+ [expr] -> Right expr
+ _ -> Left $ "internal check error: could not parse generated checked IO action: " ++ source
+
+applicationSpine :: TricuAST -> Maybe (TricuAST, [TricuAST])
+applicationSpine expr = Just (go expr [])
+ where
+ go (SApp f a) args = go f (a : args)
+ go headExpr args = (headExpr, args)
+
+checkedPureApplicationActionSource :: RuntimeContracts -> String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> [TricuAST] -> String
+checkedPureApplicationActionSource contracts name defArgs ret body callArgs =
+ checkedProgramAction boundaryProgram ("(_ runtimeEnv : " ++ bodyAction ++ ")")
+ where
+ argViews = map argType defArgs
+ retView = maybe viewAnyType id ret
+ fnView = "viewFn [" ++ unwords (map (parens . unsafeLowerViewExpr) argViews) ++ "] " ++ parens (unsafeLowerViewExpr retView)
+ boundaryRoot = fromIntegral (length callArgs * 2) :: Integer
+ boundaryProgram = "typedProgram " ++ show boundaryRoot ++ " [" ++ unwords (map parens boundaryNodes) ++ "]"
+ boundaryNodes = functionNode : concat argApplyNodes
+ functionNode = "typedValue 0 " ++ parens fnView ++ " " ++ parens (astSource (SVar name Nothing))
+ argApplyNodes =
+ [ let argSym = fromIntegral (idx * 2 - 1) :: Integer
+ outSym = fromIntegral (idx * 2) :: Integer
+ calleeSym = if idx == 1 then 0 else fromIntegral ((idx - 1) * 2)
+ argView = argRuntimeViewSource view
+ prefixArgs = take idx callArgs
+ payload = astSource (foldl SApp (SVar name Nothing) prefixArgs)
+ in [ "typedValue " ++ show argSym ++ " " ++ parens argView ++ " " ++ parens (astSource arg)
+ , "typedApply " ++ show outSym ++ " " ++ show calleeSym ++ " " ++ show argSym ++ " " ++ parens payload
+ ]
+ | (idx, (view, arg)) <- zip [1 :: Int ..] (zip argViews callArgs)
+ ]
+ (bodyRoot, bodyNodes) = runtimeBodyProgramNodes contracts defArgs retView body callArgs
+ bodyProgram = "typedProgram " ++ show bodyRoot ++ " [" ++ unwords (map parens bodyNodes) ++ "]"
+ bodyAction = checkedProgramAction bodyProgram "(value runtimeEnv : pure value)"
+
+type RuntimeContracts = Map.Map String ([DefArg], Maybe ViewExpr, TricuAST)
+
+mentionsContractedName :: RuntimeContracts -> TricuAST -> Bool
+mentionsContractedName contracts expr = case expr of
+ SVar name _ -> Map.member name contracts
+ SApp f a -> mentionsContractedName contracts f || mentionsContractedName contracts a
+ SLambda _ body -> mentionsContractedName contracts body
+ SList items -> any (mentionsContractedName contracts) items
+ TStem x -> mentionsContractedName contracts x
+ TFork x y -> mentionsContractedName contracts x || mentionsContractedName contracts y
+ SDef _ _ body -> mentionsContractedName contracts body
+ SDefAnn _ _ _ body -> mentionsContractedName contracts body
+ _ -> False
+
+checkedPureValueActionSource :: RuntimeContracts -> TricuAST -> String
+checkedPureValueActionSource contracts value =
+ checkedProgramAction program "(value runtimeEnv : pure value)"
+ where
+ (rootSym, nodes) = runtimeExpressionProgramNodes contracts value viewAnyType
+ program = "typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]"
+
+checkedProgramAction :: String -> String -> String
+checkedProgramAction program okCase =
+ "matchResult " ++
+ "(diag env : pure (renderDiagnostic diag)) " ++
+ "(exec env : matchResult " ++
+ "(runtimeDiag runtimeEnv : pure (renderDiagnostic runtimeDiag)) " ++
+ okCase ++ " " ++
+ "(runChecked exec)) " ++
+ "(checkTypedProgramWith policyStrict " ++ parens program ++ ")"
+
+runtimeExpressionProgramNodes :: RuntimeContracts -> TricuAST -> ViewExpr -> (Integer, [String])
+runtimeExpressionProgramNodes contracts expr expected =
+ let (rootSym, nodes, _) = runRuntimeLower 0 Map.empty Map.empty Map.empty contracts (lowerRuntimeExprAgainst expr expected)
+ in (rootSym, nodes)
+
+runtimeBodyProgramNodes :: RuntimeContracts -> [DefArg] -> ViewExpr -> TricuAST -> [TricuAST] -> (Integer, [String])
+runtimeBodyProgramNodes contracts defArgs retView body callArgs =
+ let binders = [ (idx, name, maybe viewAnyType id mView, arg)
+ | (idx, (DefBinder name mView, arg)) <- zip [0 :: Integer ..] (zip defArgs callArgs)
+ ]
+ initialNext = fromIntegral (length binders)
+ initialKnown = Map.fromList [ (idx, view) | (idx, _, view, _) <- binders ]
+ subst = Map.fromList [ (name, arg) | (_, name, _, arg) <- binders ]
+ symbols = Map.fromList [ (name, idx) | (idx, name, _, _) <- binders ]
+ argNodes = concatMap argBoundaryNodes binders
+ (rootSym, bodyNodes, _) = runRuntimeLower initialNext initialKnown subst symbols contracts (lowerRuntimeExpr body)
+ resultRequire = "typedRequire " ++ show rootSym ++ " " ++ parens (unsafeLowerViewExpr retView) ++ " " ++ parens (astSource (substAst subst body))
+ in (rootSym, argNodes ++ bodyNodes ++ [resultRequire])
+ where
+ argBoundaryNodes (idx, _name, view, arg) =
+ [ "typedValue " ++ show idx ++ " " ++ parens (argRuntimeViewSource view) ++ " " ++ parens (astSource arg)
+ , "typedRequire " ++ show idx ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens (astSource arg)
+ ]
+
+data RuntimeLower = RuntimeLower
+ { runtimeNext :: Integer
+ , runtimeKnown :: Map.Map Integer ViewExpr
+ , runtimeSubst :: Map.Map String TricuAST
+ , runtimeSymbols :: Map.Map String Integer
+ , runtimeContracts :: RuntimeContracts
+ }
+
+type RuntimeM a = State RuntimeLower a
+
+runRuntimeLower :: Integer -> Map.Map Integer ViewExpr -> Map.Map String TricuAST -> Map.Map String Integer -> RuntimeContracts -> RuntimeM (Integer, [String], Maybe ViewExpr) -> (Integer, [String], Maybe ViewExpr)
+runRuntimeLower next known subst symbols contracts action = evalState action RuntimeLower
+ { runtimeNext = next
+ , runtimeKnown = known
+ , runtimeSubst = subst
+ , runtimeSymbols = symbols
+ , runtimeContracts = contracts
+ }
+
+freshRuntimeSym :: RuntimeM Integer
+freshRuntimeSym = do
+ st <- get
+ let sym = runtimeNext st
+ put st { runtimeNext = sym + 1 }
+ pure sym
+
+runtimeKnownFor :: Integer -> RuntimeM (Maybe ViewExpr)
+runtimeKnownFor sym = gets (Map.lookup sym . runtimeKnown)
+
+recordRuntimeKnown :: Integer -> ViewExpr -> RuntimeM ()
+recordRuntimeKnown sym view = modify $ \st -> st { runtimeKnown = Map.insert sym view (runtimeKnown st) }
+
+lowerRuntimeExpr :: TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr)
+lowerRuntimeExpr expr = case expr of
+ SVar name _ -> do
+ symbols <- gets runtimeSymbols
+ case Map.lookup name symbols of
+ Just sym -> do
+ known <- runtimeKnownFor sym
+ pure (sym, [], known)
+ Nothing -> do
+ contracts <- gets runtimeContracts
+ sym <- freshRuntimeSym
+ case Map.lookup name contracts of
+ Just (defArgs, ret, _) -> do
+ let view = declaredDefinitionView defArgs ret
+ viewSource = unsafeLowerViewExpr view
+ recordRuntimeKnown sym view
+ pure (sym, ["typedValue " ++ show sym ++ " " ++ parens viewSource ++ " " ++ parens (astSource expr)], Just view)
+ Nothing ->
+ pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource expr)], Just viewAnyType)
+ SStr s -> do
+ sym <- freshRuntimeSym
+ let view = VEName "String"
+ recordRuntimeKnown sym view
+ pure (sym, ["typedValue " ++ show sym ++ " viewString " ++ parens (astSource (SStr s))], Just view)
+ SInt n | n >= 0 && n <= 255 -> do
+ sym <- freshRuntimeSym
+ let view = VEName "Byte"
+ recordRuntimeKnown sym view
+ pure (sym, ["typedValue " ++ show sym ++ " viewByte " ++ show n], Just view)
+ TLeaf -> do
+ sym <- freshRuntimeSym
+ let view = VEName "Unit"
+ recordRuntimeKnown sym view
+ pure (sym, ["typedValue " ++ show sym ++ " viewUnit t"], Just view)
+ SList items -> do
+ lowered <- mapM lowerRuntimeExpr items
+ sym <- freshRuntimeSym
+ let view = viewExprList viewAnyType
+ recordRuntimeKnown sym view
+ subst <- gets runtimeSubst
+ let payload = astSource (substAst subst expr)
+ pure (sym, concat [ ns | (_, ns, _) <- lowered ] ++ ["typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens payload], Just view)
+ SApp f a -> lowerRuntimeApplication f a expr
+ _ -> do
+ sym <- freshRuntimeSym
+ subst <- gets runtimeSubst
+ pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource (substAst subst expr))], Just viewAnyType)
+
+lowerRuntimeApplication :: TricuAST -> TricuAST -> TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr)
+lowerRuntimeApplication f a expr = do
+ (fSym, fNodes, fKnown) <- lowerRuntimeExpr f
+ let expectedArg = case fKnown >>= viewExprFnParts of
+ Just (argView : _, _) -> Just argView
+ _ -> Nothing
+ (aSym, aNodes, _) <- case expectedArg of
+ Just view -> lowerRuntimeExprAgainst a view
+ Nothing -> lowerRuntimeExpr a
+ outSym <- freshRuntimeSym
+ let outKnown = applicationResultView fKnown
+ mapM_ (recordRuntimeKnown outSym) outKnown
+ subst <- gets runtimeSubst
+ let payload = astSource (substAst subst expr)
+ applyNode = "typedApply " ++ show outSym ++ " " ++ show fSym ++ " " ++ show aSym ++ " " ++ parens payload
+ pure (outSym, fNodes ++ aNodes ++ [applyNode], outKnown)
+
+lowerRuntimeExprAgainst :: TricuAST -> ViewExpr -> RuntimeM (Integer, [String], Maybe ViewExpr)
+lowerRuntimeExprAgainst expr expected = do
+ mBoundary <- dynamicBoundaryValue expr expected
+ case mBoundary of
+ Just resultValue -> pure resultValue
+ Nothing -> do
+ (sym, nodes, known) <- lowerRuntimeExpr expr
+ subst <- gets runtimeSubst
+ let requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens (astSource (substAst subst expr))
+ pure (sym, nodes ++ [requireNode], known)
+
+-- IO continuations receive host-produced values whose structural View may not be
+-- statically known to the source lowerer. At an explicit annotated boundary we
+-- may introduce the requested base observation and let guarded Views perform the
+-- runtime assertion. This keeps guard failures in checked-exec instead of
+-- rejecting dynamic IO values as frontend-unknown Any.
+dynamicBoundaryValue :: TricuAST -> ViewExpr -> RuntimeM (Maybe (Integer, [String], Maybe ViewExpr))
+dynamicBoundaryValue expr expected = case expr of
+ SVar name _ -> do
+ symbols <- gets runtimeSymbols
+ contracts <- gets runtimeContracts
+ case (Map.lookup name symbols, Map.lookup name contracts) of
+ (Nothing, Nothing) -> do
+ subst <- gets runtimeSubst
+ sym <- freshRuntimeSym
+ let payload = astSource (substAst subst expr)
+ knownView = dynamicBoundaryKnownView expected
+ valueNode = "typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr knownView) ++ " " ++ parens payload
+ requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens payload
+ recordRuntimeKnown sym knownView
+ pure (Just (sym, [valueNode, requireNode], Just knownView))
+ _ -> pure Nothing
+ _ -> pure Nothing
+
+dynamicBoundaryKnownView :: ViewExpr -> ViewExpr
+dynamicBoundaryKnownView view = case viewExprAsType view of
+ Just (VTGuarded base _) -> viewTypeToExpr base
+ _ -> view
+
+substAst :: Map.Map String TricuAST -> TricuAST -> TricuAST
+substAst subst expr = case expr of
+ SVar name Nothing -> Map.findWithDefault expr name subst
+ SApp f a -> SApp (substAst subst f) (substAst subst a)
+ SLambda params body -> SLambda params (substAst (foldr Map.delete subst params) body)
+ SList items -> SList (map (substAst subst) items)
+ TStem x -> TStem (substAst subst x)
+ TFork x y -> TFork (substAst subst x) (substAst subst y)
+ _ -> expr
+
+argRuntimeViewSource :: ViewExpr -> String
+argRuntimeViewSource view =
+ "lazyBool (_ : guardedViewBase " ++ v ++ ") (_ : " ++ v ++ ") (guardedView? " ++ v ++ ")"
+ where
+ v = parens (unsafeLowerViewExpr view)
+
+unsafeLowerViewExpr :: ViewExpr -> String
+unsafeLowerViewExpr view = case lowerViewExpr view of
+ Right source -> source
+ Left err -> errorWithoutStackTrace err
+
+astSource :: TricuAST -> String
+astSource expr = case expr of
+ SVar name Nothing -> name
+ SVar name (Just hash) -> name ++ "#" ++ hash
+ SInt n -> show n
+ SStr s -> show s
+ SList items -> "[" ++ unwords (map (parens . astSource) items) ++ "]"
+ SApp f a -> parens (astSource f) ++ " " ++ parens (astSource a)
+ SLambda params body -> parens (unwords params ++ " : " ++ astSource body)
+ TLeaf -> "t"
+ TStem x -> "(t " ++ astSource x ++ ")"
+ TFork x y -> "(t " ++ astSource x ++ " " ++ astSource y ++ ")"
+ SEmpty -> "[]"
+ SDef name params body -> name ++ " " ++ unwords params ++ " = " ++ astSource body
+ SDefAnn name args ret body -> name ++ " " ++ unwords (map defArgSource args) ++ maybe "" ((" =@" ++) . viewAnnSource) ret ++ " " ++ astSource body
+ SImport path ns -> "!import " ++ show path ++ " " ++ ns
+
+viewAnnSource :: ViewExpr -> String
+viewAnnSource = unsafeLowerViewExpr
+
+defArgSource :: DefArg -> String
+defArgSource (DefBinder name Nothing) = name
+defArgSource (DefBinder name (Just view)) = name ++ "@" ++ viewAnnSource view
+defArgSource (DefPhantom view) = "@" ++ viewAnnSource view
+
+parens :: String -> String
+parens s = "(" ++ s ++ ")"
diff --git a/src/ContentStore.hs b/src/ContentStore.hs
@@ -1,319 +1,17 @@
-module ContentStore where
-
-import Research
-
-import Control.Monad (foldM, forM_, void)
-import Data.ByteString (ByteString)
-import Data.Char (isHexDigit)
-import Data.List (nub, sort)
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Text (Text)
-import Database.SQLite.Simple
-import System.IO (hPutStrLn, stderr)
-import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
-import System.Environment (lookupEnv)
-import System.Exit (die)
-import System.FilePath ((</>), takeDirectory)
-
-import qualified Data.Map as Map
-import qualified Data.Text as T
-
-data StoredNode = StoredNode ByteString deriving (Show)
-
-instance FromRow StoredNode where
- fromRow = StoredNode <$> field
-
-data StoredTerm = StoredTerm
- { termHash :: Text
- , termNames :: Text
- , termMetadata :: Text
- , termCreatedAt :: Integer
- , termTags :: Text
- } deriving (Show)
-
-instance FromRow StoredTerm where
- fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field
-
-parseNameList :: Text -> [Text]
-parseNameList = filter (not . T.null) . T.splitOn ","
-
-serializeNameList :: [Text] -> Text
-serializeNameList = T.intercalate "," . nub . sort
-
-initContentStore :: IO Connection
-initContentStore = initContentStoreWithPath Nothing
-
--- | Initialise a content store with an explicit path, or fall back
--- to the environment variable / default location.
-initContentStoreWithPath :: Maybe FilePath -> IO Connection
-initContentStoreWithPath mPath = do
- dbPath <- case mPath of
- Just p -> return p
- Nothing -> getContentStorePath
- createDirectoryIfMissing True (takeDirectory dbPath)
- conn <- open dbPath
- setupDatabase conn
- return conn
-
--- | Initialise a database connection (file-backed or in-memory).
--- This is factored out so tests can reuse it with ":memory:".
-setupDatabase :: Connection -> IO ()
-setupDatabase conn = do
- execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
- \hash TEXT PRIMARY KEY, \
- \names TEXT, \
- \metadata TEXT, \
- \created_at INTEGER DEFAULT (strftime('%s','now')), \
- \tags TEXT DEFAULT '')"
- execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)"
- execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)"
- execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
- \hash TEXT PRIMARY KEY, \
- \node_data BLOB NOT NULL)"
- -- Seed canonical Leaf node payload (0x00)
- putMerkleNode conn NLeaf
-
--- | Create an in-memory ContentStore connection (for tests).
-newContentStore :: IO Connection
-newContentStore = do
- conn <- open ":memory:"
- setupDatabase conn
- return conn
-
-getContentStorePath :: IO FilePath
-getContentStorePath = do
- maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
- case maybeLocalPath of
- Just p -> return p
- Nothing -> do
- dataDir <- getXdgDirectory XdgData "tricu"
- return $ dataDir </> "content-store.db"
-
-
-
-hashTerm :: T -> Text
-hashTerm = nodeHash . buildMerkle
-
-storeTerm :: Connection -> [String] -> T -> IO Text
-storeTerm conn newNamesStrList term = do
- let termHashText = hashTerm term
- newNamesTextList = map T.pack newNamesStrList
- metadataText = T.pack "{}"
- -- Store all Merkle nodes for this term. This traversal is where lazy T
- -- values are forced into normalized Merkle nodes for persistence.
- hPutStrLn stderr $ "[tricu] storing " ++ show newNamesStrList
- _ <- storeMerkleNodes conn term
- existingNamesQuery <- query conn
- "SELECT names FROM terms WHERE hash = ?"
- (Only termHashText) :: IO [Only Text]
-
- case existingNamesQuery of
- [] -> do
- let allNamesToStore = serializeNameList newNamesTextList
- execute conn
- "INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
- (termHashText, allNamesToStore, metadataText, T.pack "")
- [(Only currentNamesText)] -> do
- let currentNamesList = parseNameList currentNamesText
- let combinedNamesList = currentNamesList ++ newNamesTextList
- let allNamesToStore = serializeNameList combinedNamesList
- execute conn
- "UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
- (allNamesToStore, metadataText, termHashText)
- _ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
-
- return termHashText
-
--- | Reconstruct a Tree Calculus term from its Merkle root hash.
--- Recursively loads nodes and rebuilds the T structure.
-loadTree :: Connection -> MerkleHash -> IO (Maybe T)
-loadTree conn h = do
- maybeNode <- getNodeMerkle conn h
- case maybeNode of
- Nothing -> return Nothing
- Just node -> Just <$> buildTree node
- where
- buildTree :: Node -> IO T
- buildTree NLeaf = return Leaf
- buildTree (NStem childHash) = do
- child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
- return (Stem child)
- buildTree (NFork lHash rHash) = do
- left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
- right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
- return (Fork left right)
-
--- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
--- Returns the hash of the root node.
-storeMerkleNodes :: Connection -> T -> IO MerkleHash
-storeMerkleNodes conn Leaf = do
- putMerkleNode conn NLeaf
- return $ nodeHash NLeaf
-storeMerkleNodes conn (Stem t) = do
- childHash <- storeMerkleNodes conn t
- let thisNode = NStem childHash
- putMerkleNode conn thisNode
- return $ nodeHash thisNode
-storeMerkleNodes conn (Fork l r) = do
- leftHash <- storeMerkleNodes conn l
- rightHash <- storeMerkleNodes conn r
- let thisNode = NFork leftHash rightHash
- putMerkleNode conn thisNode
- return $ nodeHash thisNode
-
-
--- | Insert a Merkle node into the store (idempotent).
-putMerkleNode :: Connection -> Node -> IO ()
-putMerkleNode conn node =
- execute conn "INSERT OR IGNORE INTO merkle_nodes (hash, node_data) VALUES (?, ?)"
- (nodeHash node, serializeNode node)
-
--- | Retrieve a Merkle node by its hash.
-getNodeMerkle :: Connection -> MerkleHash -> IO (Maybe Node)
-getNodeMerkle conn h =
- queryMaybeOne conn "SELECT node_data FROM merkle_nodes WHERE hash = ?" (Only h) >>= \case
- Just (StoredNode bs) -> return $ Just (deserializeNode bs)
- Nothing -> return Nothing
-
-
-
-hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
-hashToTerm conn hashText =
- queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText)
-
-nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
-nameToTerm conn nameText =
- queryMaybeOne conn
- (selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1")
- (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
-
-listStoredTerms :: Connection -> IO [StoredTerm]
-listStoredTerms conn =
- query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
-
-storeEnvironment :: Connection -> Env -> IO ()
-storeEnvironment conn env = do
- let defs = Map.toList $ Map.delete "!result" env
- let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
-
- forM_ groupedDefs $ \(term, namesList) -> case namesList of
- _:_ -> void $ storeTerm conn namesList term
- _ -> errorWithoutStackTrace "storeEnvironment: empty names list"
-
-loadTerm :: Connection -> String -> IO (Maybe T)
-loadTerm conn identifier = do
- result <- getTerm conn (T.pack identifier)
- case result of
- Just storedTerm -> loadTree conn (termHash storedTerm)
- Nothing -> return Nothing
-
-getTerm :: Connection -> Text -> IO (Maybe StoredTerm)
-getTerm conn identifier = do
- if '#' `elem` (T.unpack identifier)
- then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier))
- else nameToTerm conn identifier
-
-loadEnvironment :: Connection -> IO Env
-loadEnvironment conn = do
- terms <- listStoredTerms conn
- foldM addTermToEnv Map.empty terms
- where
- addTermToEnv env storedTerm = do
- maybeT <- loadTree conn (termHash storedTerm)
- case maybeT of
- Just t -> do
- let namesList = parseNameList (termNames storedTerm)
- return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList
- Nothing -> return env
-
-termVersions :: Connection -> String -> IO [(Text, T, Integer)]
-termVersions conn name = do
- let nameText = T.pack name
- results <- query conn
- ("SELECT hash, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC")
- (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
-
- catMaybes <$> mapM (\(hashVal, timestamp) -> do
- maybeT <- loadTree conn hashVal
- return $ fmap (\t -> (hashVal, t, timestamp)) maybeT
- ) results
-
-setTag :: Connection -> Text -> Text -> IO ()
-setTag conn hash tagValue = do
- exists <- termExists conn hash
- if exists
- then do
- currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
- case currentTagsQuery of
- [Only tagsText] -> do
- let tagsList = parseNameList tagsText
- newTagsList = tagValue : tagsList
- newTags = serializeNameList newTagsList
- execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash)
- _ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)"
- else
- putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist"
-
-termExists :: Connection -> Text -> IO Bool
-termExists conn hash = do
- results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]]
- return $ not (null results)
-
-termToTags :: Connection -> Text -> IO [Text]
-termToTags conn hash = do
- tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
- case tagsQuery of
- [Only tagsText] -> return $ parseNameList tagsText
- _ -> return []
-
-tagToTerm :: Connection -> Text -> IO [StoredTerm]
-tagToTerm conn tagValue = do
- let pattern = "%" <> tagValue <> "%"
- query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern)
-
-allTermTags :: Connection -> IO [StoredTerm]
-allTermTags conn = do
- query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC")
-
-selectStoredTermFields :: Query
-selectStoredTermFields = "SELECT hash, names, metadata, created_at, tags FROM terms"
-
-queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r)
-queryMaybeOne conn qry params = do
- results <- query conn qry params
- case results of
- [row] -> return $ Just row
- _ -> return Nothing
-
--- | Resolve a user-supplied identifier (full/prefix hash, term name) to
--- a single term hash and the list of names bound to it. Dies on
--- ambiguity or missing term (matching the CLI @export@ semantics).
-resolveExportTarget :: Connection -> String -> IO (Text, [Text])
-resolveExportTarget conn input = do
- let raw = T.pack $ dropWhile (== '#') input
- byName <- query conn
- "SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
- (raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
- case byName of
- [Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
- (_:_) -> die $ "Ambiguous term name: " ++ input
- [] -> do
- byHash <- query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
- (Only (raw <> T.pack "%")) :: IO [Only T.Text]
- case byHash of
- [Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
- [] -> if looksLikeHash raw
- then return (raw, [])
- else die $ "No term found matching: " ++ input
- _ -> die $ "Ambiguous hash prefix: " ++ input
-
-namesForHash :: Connection -> Text -> IO [Text]
-namesForHash conn h = do
- stored <- hashToTerm conn h
- return $ maybe [] (parseNameList . termNames) stored
-
--- | Return 'True' when @t@ looks like a full or partial SHA-256 hex hash.
-looksLikeHash :: Text -> Bool
-looksLikeHash t =
- let len = T.length t
- in len >= 16 && len <= 64 && T.all isHexDigit t
+module ContentStore
+ ( module ContentStore.Object
+ , module ContentStore.Filesystem
+ , module ContentStore.Arboricx
+ , module ContentStore.Alias
+ , module ContentStore.Resolver
+ , module ContentStore.ViewTree
+ , module ContentStore.ViewContract
+ ) where
+
+import ContentStore.Arboricx
+import ContentStore.Alias
+import ContentStore.Filesystem
+import ContentStore.Object
+import ContentStore.Resolver
+import ContentStore.ViewTree
+import ContentStore.ViewContract
diff --git a/src/ContentStore/Alias.hs b/src/ContentStore/Alias.hs
@@ -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
diff --git a/src/ContentStore/Arboricx.hs b/src/ContentStore/Arboricx.hs
@@ -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
diff --git a/src/ContentStore/Bundle.hs b/src/ContentStore/Bundle.hs
@@ -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)
diff --git a/src/ContentStore/Filesystem.hs b/src/ContentStore/Filesystem.hs
@@ -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
diff --git a/src/ContentStore/Object.hs b/src/ContentStore/Object.hs
@@ -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
diff --git a/src/ContentStore/Resolver.hs b/src/ContentStore/Resolver.hs
@@ -0,0 +1,110 @@
+module ContentStore.Resolver
+ ( ObjectResolver(..)
+ , filesystemResolver
+ , cachedFilesystemResolver
+ , resolveObjectByHash
+ , resolveManifest
+ , resolveTree
+ ) where
+
+import ContentStore.Alias
+import ContentStore.Arboricx
+import ContentStore.Filesystem
+import ContentStore.Object
+import Module.Manifest
+import Research (Node(..), T, deserializeNode)
+import qualified Research
+
+import Data.ByteString (ByteString)
+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')
+import qualified Data.Map as Map
+import qualified Data.Text as T
+
+-- | Object and alias resolution capability. Module/import code should depend on
+-- this boundary rather than on a concrete filesystem store. Future resolvers can
+-- add trusted remotes, registries, or caches while preserving the same verified
+-- content-addressed interface.
+data ObjectResolver = ObjectResolver
+ { resolverAlias :: AliasKind -> T.Text -> IO (Maybe ObjectRef)
+ , resolverObject :: ObjectRef -> IO (Maybe ByteString)
+ , resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest)
+ , resolverTree :: ObjectHash -> IO (Maybe T)
+ }
+
+filesystemResolver :: StorePath -> ObjectResolver
+filesystemResolver store = resolver
+ where
+ resolver = ObjectResolver
+ { resolverAlias = readAlias store
+ , resolverObject = \ref -> getObject store (objectRefHash ref)
+ , resolverManifest = resolveManifestFromObjects resolver
+ , resolverTree = resolveTreeFromObjects resolver
+ }
+
+cachedFilesystemResolver :: StorePath -> IO ObjectResolver
+cachedFilesystemResolver store = do
+ objectCache <- newIORef Map.empty
+ manifestCache <- newIORef Map.empty
+ treeCache <- newIORef Map.empty
+ let resolver = ObjectResolver
+ { resolverAlias = readAlias store
+ , resolverObject = cachedLookup objectCache (\ref -> getObject store (objectRefHash ref))
+ , resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver)
+ , resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver)
+ }
+ return resolver
+ where
+ cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v
+ cachedLookup ref load key = do
+ cache <- readIORef ref
+ case Map.lookup key cache of
+ Just value -> return value
+ Nothing -> do
+ value <- load key
+ atomicModifyIORef' ref (\m -> (Map.insert key value m, ()))
+ return value
+
+resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString)
+resolveObjectByHash resolver kind h =
+ resolverObject resolver (ObjectRef kind h)
+
+resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
+resolveManifest = resolverManifest
+
+resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
+resolveManifestFromObjects resolver h = do
+ mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h
+ case mBytes of
+ Nothing -> return Nothing
+ Just bytes -> case decodeManifest bytes of
+ Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err
+ Right manifest -> return (Just manifest)
+
+resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T)
+resolveTree = resolverTree
+
+resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T)
+resolveTreeFromObjects resolver h = do
+ mNode <- resolveNode resolver h
+ case mNode of
+ Nothing -> return Nothing
+ Just node -> hydrate node
+ where
+ resolveNode r nodeHash = do
+ mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash
+ case mBytes of
+ Nothing -> return Nothing
+ Just bytes -> return (Just (deserializeNode bytes))
+
+ hydrate NLeaf = return (Just Research.Leaf)
+ hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child
+ hydrate (NFork left right) = do
+ l <- hydrateHash left
+ r <- hydrateHash right
+ return $ Research.Fork <$> l <*> r
+
+ hydrateHash nodeHash = do
+ mChild <- resolveNode resolver nodeHash
+ case mChild of
+ Nothing -> return Nothing
+ Just child -> hydrate child
diff --git a/src/ContentStore/ViewContract.hs b/src/ContentStore/ViewContract.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module ContentStore.ViewContract
+ ( viewContractTypeKind
+ , viewContractTypeDomain
+ , encodeViewType
+ , decodeViewType
+ , treeToViewType
+ , viewTypeToTree
+ , putViewType
+ , getViewType
+ ) where
+
+import ContentStore.Alias (ObjectRef(..))
+import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm)
+import ContentStore.Filesystem (getObject, putObject)
+import ContentStore.Object (Domain(..), StorePath, ObjectHash)
+import Research (T(..), ViewRef(..), ViewType(..), pattern VTRef, pattern VTRefText, ofList, ofNumber, ofString, toList, toNumber, toString)
+
+import Data.Bits (shiftL, shiftR, (.&.))
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Word (Word8)
+import Text.Read (readMaybe)
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+
+viewContractTypeKind :: Text
+viewContractTypeKind = "arboricx.view-contract.type.v1"
+
+viewContractTypeDomain :: Domain
+viewContractTypeDomain = Domain viewContractTypeKind
+
+encodeViewType :: ViewType -> BS.ByteString
+encodeViewType = go
+ where
+ go (VTName name) = BS.cons 0x00 (putBytes (encodeUtf8 (T.pack name)))
+ go (VTRefRaw (ViewRefInt n)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("i:" ++ show n))))
+ go (VTRefRaw (ViewRefText s)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("s:" ++ s))))
+ go (VTList item) = BS.cons 0x02 (go item)
+ go (VTMaybe item) = BS.cons 0x03 (go item)
+ go (VTPair left right) = BS.cons 0x04 (go left <> go right)
+ go (VTResult err ok) = BS.cons 0x05 (go err <> go ok)
+ go (VTGuarded base guard) = BS.cons 0x07 (go base <> putBytes (encodeTreeTerm guard))
+ go (VTFn args result) =
+ BS.cons 0x06 (putU32 (length args) <> mconcat (map go args) <> go result)
+
+putViewType :: StorePath -> ViewType -> IO ObjectRef
+putViewType store view = do
+ h <- putObject store viewContractTypeDomain (encodeViewType view)
+ pure ObjectRef { objectRefKind = viewContractTypeKind, objectRefHash = h }
+
+getViewType :: StorePath -> ObjectRef -> IO (Either String ViewType)
+getViewType store ref
+ | objectRefKind ref /= viewContractTypeKind =
+ pure $ Left $ "unsupported View Contract type object kind: " ++ T.unpack (objectRefKind ref)
+ | otherwise = do
+ mPayload <- getObject store (objectRefHash ref)
+ pure $ case mPayload of
+ Nothing -> Left $ "missing View Contract type object: " ++ T.unpack (objectRefHash ref)
+ Just payload -> decodeViewType payload
+
+decodeViewType :: BS.ByteString -> Either String ViewType
+decodeViewType payload = do
+ (view, rest) <- getViewTypeBytes payload
+ if BS.null rest
+ then Right view
+ else Left "trailing bytes after View Contract type"
+
+viewTypeToTree :: ViewType -> T
+viewTypeToTree view = case view of
+ VTName "Any" -> record 0 []
+ VTName "Bool" -> viewTypeToTree (VTRef 0)
+ VTName "String" -> viewTypeToTree (VTRef 1)
+ VTName "Byte" -> viewTypeToTree (VTRef 2)
+ VTName "Unit" -> viewTypeToTree (VTRef 3)
+ VTName name -> viewTypeToTree (VTRefText name)
+ VTRefRaw ref -> record 2 [field 2 (viewRefToTree ref)]
+ VTList item -> record 3 [field 3 (viewTypeToTree item)]
+ VTMaybe item -> record 4 [field 3 (viewTypeToTree item)]
+ VTPair left right -> record 5 [field 4 (viewTypeToTree left), field 5 (viewTypeToTree right)]
+ VTResult err ok -> record 6 [field 6 (viewTypeToTree err), field 7 (viewTypeToTree ok)]
+ VTGuarded base guard -> record 7 [field 8 (viewTypeToTree base), field 9 guard]
+ VTFn args result -> record 1 [field 0 (ofList (map viewTypeToTree args)), field 1 (viewTypeToTree result)]
+ where
+ record tag fields = Fork (ofNumber tag) (ofList fields)
+ field tag value = Fork (ofNumber tag) value
+ viewRefToTree (ViewRefInt n) = ofNumber n
+ viewRefToTree (ViewRefText s) = ofString s
+
+treeToViewType :: T -> Either String ViewType
+treeToViewType viewTree = do
+ (tag, fields) <- recordParts viewTree
+ case tag of
+ 0 -> do
+ expectNoFields fields "Any"
+ Right (VTName "Any")
+ 1 -> do
+ argsTree <- fieldValueAt 0 fields
+ resultTree <- fieldValueAt 1 fields
+ args <- toList argsTree
+ VTFn <$> mapM treeToViewType args <*> treeToViewType resultTree
+ 2 -> VTRefRaw <$> (fieldValueAt 2 fields >>= viewRefFromTree)
+ 3 -> VTList <$> (fieldValueAt 3 fields >>= treeToViewType)
+ 4 -> VTMaybe <$> (fieldValueAt 3 fields >>= treeToViewType)
+ 5 -> VTPair <$> (fieldValueAt 4 fields >>= treeToViewType) <*> (fieldValueAt 5 fields >>= treeToViewType)
+ 6 -> VTResult <$> (fieldValueAt 6 fields >>= treeToViewType) <*> (fieldValueAt 7 fields >>= treeToViewType)
+ 7 -> VTGuarded <$> (fieldValueAt 8 fields >>= treeToViewType) <*> fieldValueAt 9 fields
+ _ -> Left $ "unknown View Contract view tag in tree: " ++ show tag
+ where
+ recordParts (Fork tagTree fieldsTree) = do
+ tag <- toNumber tagTree
+ fields <- toList fieldsTree
+ pure (tag, fields)
+ recordParts _ = Left "View Contract view tree is not a record"
+
+ expectNoFields fields label =
+ if null fields
+ then Right ()
+ else Left $ "View Contract " ++ label ++ " view has unexpected fields"
+
+ fieldValueAt expectedTag fields = do
+ values <- mapM fieldParts fields
+ case values of
+ [(actualTag, value)] | actualTag == expectedTag -> Right value
+ _ -> case lookup expectedTag values of
+ Just value -> Right value
+ Nothing -> Left $ "View Contract view tree missing field tag: " ++ show expectedTag
+
+ fieldParts (Fork tagTree value) = do
+ tag <- toNumber tagTree
+ pure (tag, value)
+ fieldParts _ = Left "View Contract view field is not a pair"
+
+ viewRefFromTree tree =
+ case toNumber tree of
+ Right n -> Right (ViewRefInt n)
+ Left _ -> ViewRefText <$> toString tree
+
+getViewTypeBytes :: BS.ByteString -> Either String (ViewType, BS.ByteString)
+getViewTypeBytes bs = case BS.uncons bs of
+ Nothing -> Left "unexpected end of View Contract type"
+ Just (tag, rest) -> case tag of
+ 0x00 -> do
+ (rawName, afterName) <- getBytes rest
+ name <- either (const (Left "View Contract type name is not valid UTF-8")) Right (decodeUtf8' rawName)
+ pure (VTName (T.unpack name), afterName)
+ 0x01 -> do
+ (rawRef, afterRef) <- getBytes rest
+ refText <- either (const (Left "View Contract ref is not valid UTF-8")) Right (decodeUtf8' rawRef)
+ ref <- parseViewRef (T.unpack refText)
+ pure (VTRefRaw ref, afterRef)
+ 0x02 -> do
+ (item, afterItem) <- getViewTypeBytes rest
+ pure (VTList item, afterItem)
+ 0x03 -> do
+ (item, afterItem) <- getViewTypeBytes rest
+ pure (VTMaybe item, afterItem)
+ 0x04 -> do
+ (left, afterLeft) <- getViewTypeBytes rest
+ (right, afterRight) <- getViewTypeBytes afterLeft
+ pure (VTPair left right, afterRight)
+ 0x05 -> do
+ (err, afterErr) <- getViewTypeBytes rest
+ (ok, afterOk) <- getViewTypeBytes afterErr
+ pure (VTResult err ok, afterOk)
+ 0x06 -> do
+ (argc, afterArgc) <- getU32 rest
+ (args, afterArgs) <- getMany argc afterArgc
+ (result, afterResult) <- getViewTypeBytes afterArgs
+ pure (VTFn args result, afterResult)
+ 0x07 -> do
+ (base, afterBase) <- getViewTypeBytes rest
+ (rawGuard, afterGuard) <- getBytes afterBase
+ guard <- decodeTreeTerm rawGuard
+ pure (VTGuarded base guard, afterGuard)
+ _ -> Left $ "unknown View Contract type tag: " ++ show tag
+
+parseViewRef :: String -> Either String ViewRef
+parseViewRef raw = case raw of
+ 'i' : ':' : rest -> ViewRefInt <$> maybe (Left "View Contract integer ref is not an integer") Right (readMaybe rest)
+ 's' : ':' : rest -> Right (ViewRefText rest)
+ legacy -> ViewRefInt <$> maybe (Left "View Contract ref is neither tagged nor a legacy integer") Right (readMaybe legacy)
+
+getMany :: Int -> BS.ByteString -> Either String ([ViewType], BS.ByteString)
+getMany n bs
+ | n < 0 = Left "negative View Contract argument count"
+ | otherwise = go n bs []
+ where
+ go 0 rest acc = Right (reverse acc, rest)
+ go k rest acc = do
+ (item, afterItem) <- getViewTypeBytes rest
+ go (k - 1) afterItem (item : acc)
+
+putBytes :: BS.ByteString -> BS.ByteString
+putBytes bytes = putU32 (BS.length bytes) <> bytes
+
+getBytes :: BS.ByteString -> Either String (BS.ByteString, BS.ByteString)
+getBytes bs = do
+ (len, afterLen) <- getU32 bs
+ let (payload, rest) = BS.splitAt len afterLen
+ if BS.length payload == len
+ then Right (payload, rest)
+ else Left "truncated length-prefixed View Contract field"
+
+putU32 :: Int -> BS.ByteString
+putU32 n
+ | n < 0 = error "putU32: negative length"
+ | n > 0xffffffff = error "putU32: length too large"
+ | otherwise = BS.pack
+ [ fromIntegral ((n `shiftR` 24) .&. 0xff)
+ , fromIntegral ((n `shiftR` 16) .&. 0xff)
+ , fromIntegral ((n `shiftR` 8) .&. 0xff)
+ , fromIntegral (n .&. 0xff)
+ ]
+
+getU32 :: BS.ByteString -> Either String (Int, BS.ByteString)
+getU32 bs
+ | BS.length bs < 4 = Left "truncated View Contract u32"
+ | otherwise =
+ let [b0, b1, b2, b3] = BS.unpack (BS.take 4 bs)
+ n = word8ToInt b0 `shiftL` 24
+ + word8ToInt b1 `shiftL` 16
+ + word8ToInt b2 `shiftL` 8
+ + word8ToInt b3
+ in Right (n, BS.drop 4 bs)
+
+word8ToInt :: Word8 -> Int
+word8ToInt = fromIntegral
diff --git a/src/ContentStore/ViewTree.hs b/src/ContentStore/ViewTree.hs
@@ -0,0 +1,135 @@
+module ContentStore.ViewTree
+ ( viewTreeKind
+ , viewTreeDomain
+ , encodeViewTree
+ , decodeViewTree
+ , singletonViewTree
+ , viewTreeRootTerm
+ , putViewTree
+ , getViewTree
+ ) where
+
+import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm)
+import ContentStore.Alias (ObjectRef(..))
+import ContentStore.Filesystem (getObject, putObject)
+import ContentStore.Object (Domain(..), StorePath)
+import ContentStore.ViewContract (viewTypeToTree)
+import Research (T(..), ViewType(..), ofList, ofNumber, toList, toNumber)
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+
+viewTreeKind :: T.Text
+viewTreeKind = "arboricx.view-tree.v1"
+
+viewTreeDomain :: Domain
+viewTreeDomain = Domain viewTreeKind
+
+-- View-tree artifacts are ordinary tree data. Their node envelope semantics
+-- live in lib/view.tri; this module only provides CAS persistence for the
+-- portable tree payload.
+encodeViewTree :: T -> BS.ByteString
+encodeViewTree = encodeTreeTerm
+
+decodeViewTree :: BS.ByteString -> Either String T
+decodeViewTree = decodeTreeTerm
+
+singletonViewTree :: Maybe ViewType -> T -> T
+singletonViewTree mView term =
+ record typedProgramTag
+ [ field typedProgramFieldRoot (ofNumber 0)
+ , field typedProgramFieldNodes (ofList [typedValueNode 0 (maybe viewAnyTree viewTypeToTree mView) term])
+ ]
+
+-- | Extract the executable root payload from a view-tree artifact without
+-- judging view validity. Checker semantics remain in lib/view.tri; this is only
+-- the module loader's payload projection for imports.
+viewTreeRootTerm :: T -> Either String T
+viewTreeRootTerm tree = do
+ tag <- recordTag tree
+ if tag /= typedProgramTag
+ then Left $ "view-tree root has unexpected tag: " ++ show tag
+ else do
+ root <- fieldValue typedProgramFieldRoot tree >>= toNumber
+ nodes <- fieldValue typedProgramFieldNodes tree >>= toList
+ lookupRoot root nodes
+ where
+ lookupRoot _ [] = Left "view-tree root symbol not found"
+ lookupRoot root (node : rest) = do
+ sym <- fieldValue typedNodeFieldSymbol node >>= toNumber
+ if sym == root
+ then nodeTerm node
+ else lookupRoot root rest
+
+ nodeTerm node = do
+ tag <- recordTag node
+ case tag of
+ 21 -> fieldValue typedNodeFieldTerm node
+ 22 -> fieldValue typedNodeFieldTerm node
+ 23 -> fieldValue typedNodeFieldTerm node
+ _ -> Left $ "view-tree node has unexpected tag: " ++ show tag
+
+record :: Integer -> [T] -> T
+record tag fields = Fork (ofNumber tag) (ofList fields)
+
+field :: Integer -> T -> T
+field tag value = Fork (ofNumber tag) value
+
+typedValueNode :: Integer -> T -> T -> T
+typedValueNode sym view term =
+ record typedNodeTagValue
+ [ field typedNodeFieldSymbol (ofNumber sym)
+ , field typedNodeFieldView view
+ , field typedNodeFieldTerm term
+ ]
+
+viewAnyTree :: T
+viewAnyTree = record 0 []
+
+recordTag :: T -> Either String Integer
+recordTag (Fork tagTree _) = toNumber tagTree
+recordTag _ = Left "view-tree value is not a record"
+
+recordFields :: T -> Either String [T]
+recordFields (Fork _ fieldsTree) = toList fieldsTree
+recordFields _ = Left "view-tree value is not a record"
+
+fieldValue :: Integer -> T -> Either String T
+fieldValue expected recordTree = do
+ fields <- recordFields recordTree
+ values <- mapM fieldParts fields
+ case lookup expected values of
+ Just value -> Right value
+ Nothing -> Left $ "view-tree missing field tag: " ++ show expected
+
+fieldParts :: T -> Either String (Integer, T)
+fieldParts (Fork tagTree value) = do
+ tag <- toNumber tagTree
+ Right (tag, value)
+fieldParts _ = Left "view-tree field is not a pair"
+
+typedProgramTag, typedProgramFieldRoot, typedProgramFieldNodes :: Integer
+typedProgramTag = 20
+typedProgramFieldRoot = 0
+typedProgramFieldNodes = 1
+
+typedNodeTagValue, typedNodeFieldSymbol, typedNodeFieldView, typedNodeFieldTerm :: Integer
+typedNodeTagValue = 21
+typedNodeFieldSymbol = 0
+typedNodeFieldView = 1
+typedNodeFieldTerm = 2
+
+putViewTree :: StorePath -> T -> IO ObjectRef
+putViewTree store viewTree = do
+ h <- putObject store viewTreeDomain (encodeViewTree viewTree)
+ pure ObjectRef { objectRefKind = viewTreeKind, objectRefHash = h }
+
+getViewTree :: StorePath -> ObjectRef -> IO (Either String T)
+getViewTree store ref
+ | objectRefKind ref /= viewTreeKind =
+ pure $ Left $ "unsupported view-tree object kind: " ++ T.unpack (objectRefKind ref)
+ | otherwise = do
+ mPayload <- getObject store (objectRefHash ref)
+ pure $ case mPayload of
+ Nothing -> Left $ "missing view-tree object: " ++ T.unpack (objectRefHash ref)
+ Just payload -> decodeViewTree payload
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -1,20 +1,16 @@
module Eval where
-import ContentStore
import Parser
import Research
-import Control.Monad (foldM)
import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map ()
import Data.Set (Set)
-import Database.SQLite.Simple
import Debug.Trace (trace)
import qualified Data.Foldable as F ()
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.Text as T
data DB
= BVar Int
@@ -43,6 +39,16 @@ evalSingle env term
-> Map.insert "!result" res (Map.insert name res env)
Nothing
-> Map.insert "!result" res (Map.insert name res env)
+ | SDefAnn name args _ body <- term
+ = let params = annotatedBinders args
+ res = evalASTSync env (if null params then body else SLambda params body)
+ in case Map.lookup name env of
+ Just existingValue
+ | existingValue == res -> env
+ | otherwise
+ -> Map.insert "!result" res (Map.insert name res env)
+ Nothing
+ -> Map.insert "!result" res (Map.insert name res env)
| SApp func arg <- term
= let res = apply (evalASTSync env func) (evalASTSync env arg)
in Map.insert "!result" res env
@@ -87,94 +93,17 @@ evalASTSync env term = case term of
SEmpty -> Leaf
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
-evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
-evalAST mconn selectedVersions ast = do
- let varNames = collectVarNames ast
- resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
- return $ evalASTSync resolvedEnv ast
-
--- | Evaluate a single AST term using a local environment augmented by
--- lazily-resolved store terms.
-evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
-evalASTWithEnv mconn localEnv ast = do
- let varNames = collectVarNames ast
- storeEnv <- resolveTermsFromStore mconn Map.empty varNames
- let combinedEnv = Map.union localEnv storeEnv
- return $ evalASTSync combinedEnv ast
-
-evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
-evalSingleWithStore mconn env term
- | SDef name params body <- term = do
- res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
- case Map.lookup name env of
- Just existingValue
- | existingValue == res -> return env
- | otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
- Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
- | otherwise = do
- res <- evalASTWithEnv mconn env term
- return $ Map.insert "!result" res env
-
-evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
-evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
- where
- go env' [] = return env'
- go env' [def] = do
- updatedEnv <- evalSingleWithStore mconn env' def
- return $ Map.insert "!result" (result updatedEnv) updatedEnv
- go env' (def:xs) = do
- updatedEnv <- evalSingleWithStore mconn env' def
- evalTricuWithStore mconn updatedEnv xs
+evalAST :: Env -> TricuAST -> IO T
+evalAST env ast = return $ evalASTSync env ast
recoverParams :: TricuAST -> TricuAST
recoverParams (SDef name [] (SLambda params body)) = SDef name params body
recoverParams term = term
-collectVarNames :: TricuAST -> [(String, Maybe String)]
-collectVarNames = go []
- where
- go acc (SVar name mhash) = (name, mhash) : acc
- go acc (SApp t u) = go (go acc t) u
- go acc (SLambda vars body) =
- let boundVars = Set.fromList vars
- collected = go [] body
- in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
- go acc (TStem t) = go acc t
- go acc (TFork t u) = go (go acc t) u
- go acc (SList xs) = foldl' go acc xs
- go acc _ = acc
-
-resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
-resolveTermsFromStore Nothing _ _ = return Map.empty
-resolveTermsFromStore (Just conn) selectedVersions varNames = do
- foldM (\env (name, mhash) -> do
- term <- resolveTermFromStore conn selectedVersions name mhash
- case term of
- Just t -> return $ Map.insert (getVarKey name mhash) t env
- Nothing -> return env
- ) Map.empty varNames
- where
- getVarKey name Nothing = name
- getVarKey name (Just hash) = name ++ "#" ++ hash
-
-resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
-resolveTermFromStore conn selectedVersions name mhash = case mhash of
- Just hashPrefix -> do
- versions <- termVersions conn name
- let matchingVersions = filter (\(hash, _, _) ->
- T.isPrefixOf (T.pack hashPrefix) hash) versions
- case matchingVersions of
- [] -> return Nothing
- [(_, term, _)] -> return $ Just term
- _ -> return Nothing
- Nothing -> case Map.lookup name selectedVersions of
- Just hash -> loadTree conn hash
- Nothing -> do
- versions <- termVersions conn name
- case versions of
- [] -> return Nothing
- [(_, term, _)] -> return $ Just term
- _ -> return $ Just (head (map (\(_, t, _) -> t) versions))
+annotatedBinders :: [DefArg] -> [String]
+annotatedBinders [] = []
+annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest
+annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest
elimLambda :: TricuAST -> TricuAST
elimLambda = go
@@ -262,6 +191,7 @@ freeVars (SVar v (Just _)) = Set.singleton v
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
+freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args))
freeVars (TStem t) = freeVars t
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
freeVars (SList xs) = foldMap freeVars xs
@@ -275,13 +205,13 @@ reorderDefs env defs
| otherwise = orderedDefs ++ others
where
(defsOnly, others) = partition isDef defs
- defNames = [ name | SDef name _ _ <- defsOnly ]
+ defNames = [ defName def | def <- defsOnly ]
defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
graph = buildDepGraph defsOnly
sortedDefs = sortDeps graph
- defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
+ defMap = Map.fromList [(defName def, def) | def <- defsOnly]
orderedDefs = map (defMap Map.!) sortedDefs
freeVarsDefs = foldMap snd defsWithFreeVars
@@ -291,6 +221,7 @@ reorderDefs env defs
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
isDef SDef {} = True
+ isDef SDefAnn {} = True
isDef _ = False
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
@@ -300,11 +231,11 @@ buildDepGraph topDefs
"Conflicting definitions detected: " ++ show conflictingDefs
| otherwise =
Map.fromList
- [ (name, depends topDefs def)
- | def@(SDef name _ _) <- topDefs]
+ [ (defName def, depends topDefs def)
+ | def <- topDefs]
where
defsMap = Map.fromListWith (++)
- [(name, [(name, body)]) | SDef name _ body <- topDefs]
+ [(defName def, [(defName def, defBody def)]) | def <- topDefs]
conflictingDefs =
[ name
@@ -330,10 +261,24 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
(Set.union sortedSet (Set.fromList ready))
notReady
+defName :: TricuAST -> String
+defName (SDef name _ _) = name
+defName (SDefAnn name _ _ _) = name
+defName _ = error "defName: expected definition"
+
+defBody :: TricuAST -> TricuAST
+defBody (SDef _ _ body) = body
+defBody (SDefAnn _ _ _ body) = body
+defBody _ = error "defBody: expected definition"
+
depends :: [TricuAST] -> TricuAST -> Set.Set String
-depends topDefs def@(SDef _ _ _) =
+depends topDefs def@SDef {} =
+ Set.intersection
+ (Set.fromList [defName d | d <- topDefs])
+ (freeVars def)
+depends topDefs def@SDefAnn {} =
Set.intersection
- (Set.fromList [n | SDef n _ _ <- topDefs])
+ (Set.fromList [defName d | d <- topDefs])
(freeVars def)
depends _ _ = Set.empty
@@ -353,6 +298,7 @@ findVarNames ast = case ast of
SApp a b -> findVarNames a ++ findVarNames b
SLambda args body -> findVarNames body \\ args
SDef name args body -> name : (findVarNames body \\ args)
+ SDefAnn name args _ body -> name : (findVarNames body \\ annotatedBinders args)
_ -> []
-- Convert named TricuAST to De Bruijn form
@@ -372,6 +318,7 @@ toDB env = \case
SList xs -> BList (map (toDB env) xs)
SEmpty -> BEmpty
SDef{} -> error "toDB: unexpected SDef at this stage"
+ SDefAnn{} -> error "toDB: unexpected SDefAnn at this stage"
SImport _ _ -> BEmpty
-- Does a term depend on the current binder (level 0)?
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -1,22 +1,41 @@
module FileEval
- ( preprocessFile
+ ( ContractMode(..)
+ , LoadedSource(..)
+ , preprocessFile
+ , preprocessFileWithStore
+ , preprocessFileWithResolver
, evaluateFile
- , evaluateFileWithContext
, evaluateFileWithStore
+ , evaluateFileWithContext
+ , evaluateFileWithContextWithStore
+ , evaluateFileWithContextWithStoreAndMode
, evaluateFileResult
, compileFile
+ , compileFileWithStore
+ , loadFileWithStore
+ , loadFileWithStoreMode
+ , defaultStorePath
) where
-import Eval (evalTricu, evalTricuWithStore)
+import Check.Core
+ ( checkProgramWithEnvAndImportedViews
+ , importedViewsFromResolvedModulesEither
+ , lowerViewExpr
+ )
+import ContentStore
+import Eval (evalASTSync, evalTricu, freeVars, result)
import Lexer
+import Module.Manifest
+import Module.Resolver
+import Module.Workspace
import Parser
import Research
import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
-import Database.SQLite.Simple (Connection)
-import Data.List (partition)
+import Data.List (partition, isPrefixOf)
import Data.Maybe (mapMaybe)
-import System.FilePath (takeDirectory, normalise, (</>))
+import System.Directory (getHomeDirectory, getTemporaryDirectory)
+import System.FilePath ((</>))
import System.Exit (die)
import qualified Data.ByteString as BS
@@ -32,153 +51,262 @@ extractMain env =
Just evalResult -> Right evalResult
Nothing -> Left "No `main` function detected"
-processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
- -> Either String ([TricuAST], [(FilePath, String, FilePath)])
-processImports seen _base currentPath asts =
+data ContractMode
+ = EnforceContracts
+ | IgnoreContracts
+ deriving (Eq, Show)
+
+data LoadedSource = LoadedSource
+ { loadedImports :: Env
+ , loadedAst :: [TricuAST]
+ , loadedModules :: [ResolvedModule]
+ }
+
+data LoadContext = LoadContext
+ { loadResolver :: ObjectResolver
+ , loadStore :: Maybe StorePath
+ , loadWorkspace :: Workspace
+ , loadContracts :: ContractMode
+ }
+
+processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
+processImports asts =
let (imports, nonImports) = partition isImp asts
- importPaths = mapMaybe getImportInfo imports
- in if currentPath `Set.member` seen
- then Left $ "Encountered cyclic import: " ++ currentPath
- else Right (nonImports, importPaths)
+ importTargets = mapMaybe getImportInfo imports
+ in (nonImports, importTargets)
where
isImp (SImport _ _) = True
isImp _ = False
- getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p)
+ getImportInfo (SImport p n) = Just (p, n)
getImportInfo _ = Nothing
evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do
- contents <- readFile filePath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError tokens err)
- Right _ast -> do
- processedAst <- preprocessFile filePath
- let finalEnv = evalTricu Map.empty processedAst
- case extractMain finalEnv of
- Right evalResult -> return evalResult
- Left err -> errorWithoutStackTrace err
+ env <- evaluateFile filePath
+ case extractMain env of
+ Right evalResult -> return evalResult
+ Left err -> errorWithoutStackTrace err
evaluateFile :: FilePath -> IO Env
-evaluateFile filePath = do
- contents <- readFile filePath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError tokens err)
- Right _ast -> do
- ast <- preprocessFile filePath
- pure $ evalTricu Map.empty ast
+evaluateFile = evaluateFileWithStore Nothing
+
+evaluateFileWithStore :: Maybe StorePath -> FilePath -> IO Env
+evaluateFileWithStore mStore filePath = do
+ loaded <- maybe loadFile loadFileWithStore mStore filePath
+ pure $ evalTricu (loadedImports loaded) (loadedAst loaded)
evaluateFileWithContext :: Env -> FilePath -> IO Env
-evaluateFileWithContext env filePath = do
- contents <- readFile filePath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError tokens err)
- Right _ast -> do
- ast <- preprocessFile filePath
- pure $ evalTricu env ast
-
--- | File evaluation that lazily resolves missing names from the
--- content store instead of pre-loading the entire store into memory.
-evaluateFileWithStore :: Maybe Connection -> Env -> FilePath -> IO Env
-evaluateFileWithStore mconn env filePath = do
- contents <- readFile filePath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError tokens err)
- Right _ast -> do
- ast <- preprocessFile filePath
- evalTricuWithStore mconn env ast
+evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
+
+evaluateFileWithContextWithStore :: Maybe StorePath -> Env -> FilePath -> IO Env
+evaluateFileWithContextWithStore mStore =
+ evaluateFileWithContextWithStoreAndMode EnforceContracts mStore
+
+evaluateFileWithContextWithStoreAndMode :: ContractMode -> Maybe StorePath -> Env -> FilePath -> IO Env
+evaluateFileWithContextWithStoreAndMode mode mStore env filePath = do
+ loaded <- case mStore of
+ Nothing -> loadFileMode mode filePath
+ Just store -> loadFileWithStoreMode mode store filePath
+ pure $ evalTricu (Map.union (loadedImports loaded) env) (loadedAst loaded)
preprocessFile :: FilePath -> IO [TricuAST]
-preprocessFile p = preprocessFile' Set.empty p p
+preprocessFile p = loadedAst <$> loadFile p
+
+preprocessFileWithStore :: StorePath -> FilePath -> IO [TricuAST]
+preprocessFileWithStore store p = loadedAst <$> loadFileWithStore store p
+
+preprocessFileWithResolver :: ObjectResolver -> FilePath -> IO [TricuAST]
+preprocessFileWithResolver resolver p = loadedAst <$> loadFileWithResolver resolver p
+
+loadFile :: FilePath -> IO LoadedSource
+loadFile = loadFileMode EnforceContracts
+
+loadFileMode :: ContractMode -> FilePath -> IO LoadedSource
+loadFileMode mode p = do
+ store <- defaultStorePath
+ loadFileWithStoreMode mode store p
-preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
-preprocessFile' seen base currentPath = do
+loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource
+loadFileWithStore = loadFileWithStoreMode EnforceContracts
+
+loadFileWithStoreMode :: ContractMode -> StorePath -> FilePath -> IO LoadedSource
+loadFileWithStoreMode mode store p = do
+ workspace <- findWorkspaceFor p
+ resolver <- cachedFilesystemResolver store
+ let ctx = LoadContext resolver (Just store) workspace mode
+ loadFile' ctx p
+
+loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource
+loadFileWithResolver resolver p = do
+ let ctx = LoadContext resolver Nothing emptyWorkspace EnforceContracts
+ loadFile' ctx p
+
+loadFile' :: LoadContext -> FilePath -> IO LoadedSource
+loadFile' ctx currentPath = do
contents <- readFile currentPath
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right ast ->
- case processImports seen base currentPath ast of
- Left err -> errorWithoutStackTrace err
- Right (nonImports, importPaths) -> do
- let seen' = Set.insert currentPath seen
- imported <- concat <$> mapM (processImportPath seen' base) importPaths
- pure $ imported ++ nonImports
+ let (nonImports, importTargets) = processImports ast
+ in do
+ let reexportOnlyModule = null (topLevelDefinitions nonImports) && not (null importTargets)
+ resolvedModules <- mapM (\(target, name) -> do
+ ensureWorkspaceModule ctx target
+ resolveModuleImportSelecting (loadResolver ctx) (selectedExportsForImport reexportOnlyModule target name nonImports) target name) importTargets
+ let moduleEnv = resolvedModulesEnv resolvedModules
+ pure LoadedSource
+ { loadedImports = moduleEnv
+ , loadedAst = nonImports
+ , loadedModules = resolvedModules
+ }
+
+ensureWorkspaceModule :: LoadContext -> String -> IO ()
+ensureWorkspaceModule ctx moduleTarget = do
+ existing <- resolverAlias (loadResolver ctx) ModuleAlias (T.pack moduleTarget)
+ case existing of
+ Just _ -> return ()
+ Nothing -> do
+ mSource <- resolveSourceModulePath ctx moduleTarget
+ case (loadStore ctx, mSource) of
+ (Just store, Just sourcePath) -> buildWorkspaceModule ctx store moduleTarget sourcePath
+ _ -> return ()
+
+resolveSourceModulePath :: LoadContext -> String -> IO (Maybe FilePath)
+resolveSourceModulePath ctx moduleTarget =
+ return (lookupWorkspaceModule (loadWorkspace ctx) (T.pack moduleTarget))
+
+buildWorkspaceModule :: LoadContext -> StorePath -> String -> FilePath -> IO ()
+buildWorkspaceModule ctx store moduleName sourcePath = do
+ loaded <- loadFile' ctx sourcePath
+ let asts = loadedAst loaded
+ case loadContracts ctx of
+ EnforceContracts -> enforceWorkspaceModuleContracts store moduleName (loadedImports loaded) (loadedModules loaded) asts
+ IgnoreContracts -> pure ()
+ let env = evalTricu (loadedImports loaded) asts
+ localNames = topLevelDefinitions asts
+ localViewExprs = topLevelDefinitionViews asts
+ localViews = case loadContracts ctx of
+ EnforceContracts
+ | Map.null localViewExprs -> pure (Right Map.empty)
+ | otherwise -> do
+ viewEnv <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty "./lib/view.tri"
+ let checkerEnv = evalTricu (Map.union viewEnv (loadedImports loaded)) asts
+ pure (resolveDefinitionViews checkerEnv localViewExprs)
+ IgnoreContracts -> pure (Right Map.empty)
+ names = if null localNames
+ then filter (/= "!result") (Map.keys env)
+ else localNames
+ localViewsResult <- localViews
+ resolvedLocalViews <- either (errorWithoutStackTrace . (("Workspace module " ++ show moduleName ++ " has invalid exported View Contract annotation: ") ++)) pure localViewsResult
+ exports <- mapM (buildExport env resolvedLocalViews) names
+ manifestHash <- putManifest store (ModuleManifest [] exports)
+ writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
where
- processImportPath _seen _base (_path, name, importPath) = do
- ast <- preprocessFile' _seen _base importPath
- pure $ map (nsDefinition (if name == "!Local" then "" else name))
- $ filter (not . isImp) ast
- isImp (SImport _ _) = True
- isImp _ = False
+ buildExport env localViews name = case Map.lookup name env of
+ Nothing -> errorWithoutStackTrace $ "Workspace module export not found after evaluation: " ++ name
+ Just term -> do
+ let exportView = Map.lookup name localViews
+ rootRef <- putViewTree store (singletonViewTree exportView term)
+ viewRef <- mapM (putViewType store) exportView
+ return ModuleExport
+ { moduleExportName = T.pack name
+ , moduleExportObject = rootRef
+ , moduleExportAbi = "arboricx.abi.view-tree.v1"
+ , moduleExportView = viewRef
+ }
+
+enforceWorkspaceModuleContracts :: StorePath -> String -> Env -> [ResolvedModule] -> [TricuAST] -> IO ()
+enforceWorkspaceModuleContracts store moduleName importEnv modules asts
+ | not (any isAnnotatedDefinition asts) = pure ()
+ | otherwise = do
+ viewEnv <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty "./lib/view.tri"
+ let checkerEnv = evalTricu (Map.union viewEnv importEnv) asts
+ imports <- importedViewsFromResolvedModulesEither (getViewType store) modules
+ resultText <- checkProgramWithEnvAndImportedViews checkerEnv imports asts
+ case resultText of
+ "ok" -> pure ()
+ diagnostic -> errorWithoutStackTrace $
+ "Workspace module " ++ show moduleName ++ " failed View Contract check: " ++ diagnostic
-makeRelativeTo :: FilePath -> FilePath -> FilePath
-makeRelativeTo f i =
- let d = takeDirectory f
- in normalise $ d </> i
-
-nsDefinition :: String -> TricuAST -> TricuAST
-nsDefinition "" def = def
-nsDefinition moduleName (SDef name args body)
- | isPrefixed name = SDef name args (nsBody moduleName body)
- | otherwise = SDef (nsVariable moduleName name)
- args (nsBody moduleName body)
-nsDefinition moduleName other =
- nsBody moduleName other
-
-nsBody :: String -> TricuAST -> TricuAST
-nsBody moduleName (SVar name mhash)
- | isPrefixed name = SVar name mhash
- | otherwise = SVar (nsVariable moduleName name) mhash
-nsBody moduleName (SApp func arg) =
- SApp (nsBody moduleName func) (nsBody moduleName arg)
-nsBody moduleName (SLambda args body) =
- SLambda args (nsBodyScoped moduleName args body)
-nsBody moduleName (SList items) =
- SList (map (nsBody moduleName) items)
-nsBody moduleName (TFork left right) =
- TFork (nsBody moduleName left) (nsBody moduleName right)
-nsBody moduleName (TStem subtree) =
- TStem (nsBody moduleName subtree)
-nsBody moduleName (SDef name args body) =
- SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body)
-nsBody _ other = other
-
-nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
-nsBodyScoped moduleName args body = case body of
- SVar name mhash ->
- if name `elem` args
- then SVar name mhash
- else nsBody moduleName (SVar name mhash)
- SApp func arg ->
- SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
- SLambda innerArgs innerBody ->
- SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
- SList items ->
- SList (map (nsBodyScoped moduleName args) items)
- TFork left right ->
- TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
- TStem subtree ->
- TStem (nsBodyScoped moduleName args subtree)
- SDef name innerArgs innerBody ->
- SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
- other -> other
-
-isPrefixed :: String -> Bool
-isPrefixed name = '.' `elem` name
-
-nsVariable :: String -> String -> String
-nsVariable "" name = name
-nsVariable moduleName name = moduleName ++ "." ++ name
+isAnnotatedDefinition :: TricuAST -> Bool
+isAnnotatedDefinition SDefAnn {} = True
+isAnnotatedDefinition _ = False
+
+topLevelDefinitions :: [TricuAST] -> [String]
+topLevelDefinitions = mapMaybe go
+ where
+ go (SDef name _ _) = Just name
+ go (SDefAnn name _ _ _) = Just name
+ go _ = Nothing
+
+topLevelDefinitionViews :: [TricuAST] -> Map.Map String ViewExpr
+topLevelDefinitionViews asts = Map.fromList (mapMaybe go asts)
+ where
+ go (SDefAnn name args resultView _) = Just (name, definitionView args resultView)
+ go _ = Nothing
+
+resolveDefinitionViews :: Env -> Map.Map String ViewExpr -> Either String (Map.Map String ViewType)
+resolveDefinitionViews env = mapM (resolveViewExpression env)
+
+resolveViewExpression :: Env -> ViewExpr -> Either String ViewType
+resolveViewExpression checkerEnv view = do
+ expr <- lowerViewExpr view
+ let term = evalASTSync checkerEnv (head (parseTricu expr))
+ probeEnv = Map.insert "__candidateView" term checkerEnv
+ probe = evalTricu probeEnv (parseTricu "viewContractProbe (wellFormedView? __candidateView)")
+ case toString (result probe) of
+ Right "ok" -> treeToViewType term
+ Right other -> Left $ "malformed view expression " ++ show expr ++ ": " ++ other
+ Left err -> Left $ "could not validate view expression " ++ show expr ++ ": " ++ err
+
+definitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
+definitionView args resultView =
+ case argViews of
+ [] -> finalView
+ _ -> VEApp (VEApp (VEName "Fn") (VEList argViews)) finalView
+ where
+ argViews = map defArgView args
+ finalView = maybe exportedViewAny id resultView
+
+defArgView :: DefArg -> ViewExpr
+defArgView (DefBinder _ Nothing) = exportedViewAny
+defArgView (DefBinder _ (Just ty)) = ty
+defArgView (DefPhantom ty) = ty
+
+exportedViewAny :: ViewExpr
+exportedViewAny = VEName "Any"
+
+defaultStorePath :: IO StorePath
+defaultStorePath = do
+ home <- getHomeDirectory
+ if home == "/homeless-shelter"
+ then do
+ tmp <- getTemporaryDirectory
+ return (StorePath (tmp </> "tricu" </> "store"))
+ else return (StorePath (home </> ".tricu" </> "store"))
+
+selectedExportsForImport :: Bool -> String -> String -> [TricuAST] -> Maybe (Set.Set T.Text)
+selectedExportsForImport True _ _ _ = Nothing
+selectedExportsForImport False _moduleTarget namespace asts =
+ Just $ Set.fromList directSelections
+ where
+ directSelections = mapMaybe select (Set.toList used)
+ used = foldMap freeVars asts
+ prefix = namespace ++ "."
+ select name
+ | namespace == "!Local" = Just (T.pack name)
+ | prefix `isPrefixOf` name = Just (T.pack (drop (length prefix) name))
+ | otherwise = Nothing
-- | Compile a tricu source file to a standalone Arboricx bundle.
-- Emits a canonical indexed bundle with no SHA-256 hashing.
compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
-compileFile inputPath outputPath maybeNames = do
- env <- evaluateFile inputPath
+compileFile = compileFileWithStore Nothing
+
+compileFileWithStore :: Maybe StorePath -> FilePath -> FilePath -> [T.Text] -> IO ()
+compileFileWithStore mStore inputPath outputPath maybeNames = do
+ env <- evaluateFileWithStore mStore inputPath
let defaultNames = ["main"]
wantedNames = if null maybeNames then defaultNames else maybeNames
wantedNamesUnpacked = map T.unpack wantedNames
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -33,14 +33,16 @@ tricuLexer = do
tricuLexer' =
[ try lnewline
, try indentMarker
- , try namespace
, try dot
, try identifierWithHash
- , try identifier
, try keywordT
+ , try identifier
+ , try namespace
, try integerLiteral
, try stringLiteral
+ , try assignAt
, assign
+ , atSign
, colon
, openParen
, closeParen
@@ -81,10 +83,10 @@ keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
identifierWithHash :: Lexer LToken
identifierWithHash = do
- first <- lowerChar <|> char '_'
+ first <- letterChar <|> char '_'
rest <- many $ letterChar
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
- <|> char '$' <|> char '@' <|> char '%'
+ <|> char '$' <|> char '%'
<|> char '\''
_ <- char '#' -- Consume '#'
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
@@ -103,10 +105,10 @@ identifierWithHash = do
identifier :: Lexer LToken
identifier = do
- first <- lowerChar <|> char '_'
+ first <- letterChar <|> char '_'
rest <- many $ letterChar
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
- <|> char '$' <|> char '@' <|> char '%'
+ <|> char '$' <|> char '%'
<|> char '\''
let name = first : rest
if name == "t" || name == "!result"
@@ -114,12 +116,7 @@ identifier = do
else return (LIdentifier name)
namespace :: Lexer LToken
-namespace = do
- name <- try (string "!Local") <|> do
- first <- upperChar
- rest <- many (letterChar <|> digitChar)
- return (first:rest)
- return (LNamespace name)
+namespace = LNamespace <$> string "!Local"
dot :: Lexer LToken
dot = char '.' $> LDot
@@ -130,12 +127,27 @@ lImport = do
space1
LStringLiteral path <- stringLiteral
space1
- LNamespace name <- namespace
+ name <- importAlias
return (LImport path name)
+importAlias :: Lexer String
+importAlias = string "!Local" <|> do
+ first <- letterChar <|> char '_'
+ rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.')
+ let name = first : rest
+ if name == "t" || name == "!result"
+ then fail "Keywords (`t`, `!result`) cannot be used as an import alias"
+ else pure name
+
+assignAt :: Lexer LToken
+assignAt = string "=@" $> LAssignAt
+
assign :: Lexer LToken
assign = char '=' $> LAssign
+atSign :: Lexer LToken
+atSign = char '@' $> LAt
+
colon :: Lexer LToken
colon = char ':' $> LColon
diff --git a/src/Main.hs b/src/Main.hs
@@ -1,17 +1,27 @@
module Main where
-import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
+import Check (checkFile, checkFileWithStore, instrumentIOContinuations)
+import ContentStore
+import ContentStore.Bundle
+import Module.Manifest
import System.Exit (die)
-import Eval (evalTricu, evalTricuWithStore, mainResult, result)
-import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
+import Eval (evalTricu, mainResult, result)
+import FileEval
+ ( ContractMode(..)
+ , LoadedSource(..)
+ , defaultStorePath
+ , evaluateFileWithContextWithStoreAndMode
+ , evaluateFileWithStore
+ , loadFileWithStoreMode
+ , compileFileWithStore
+ )
import IODriver (IOPermissions(..), runIO)
import Parser (parseTricu)
import REPL (repl)
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
-import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
+import Wire (encodeBundle, defaultExportNames, Bundle(..))
import Control.Monad (foldM, unless, when)
-import Data.Text (unpack, pack)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_tricu (version)
@@ -20,10 +30,9 @@ import Options.Applicative
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq
-import Database.SQLite.Simple (Connection, close)
-
import qualified Data.Map as Map
-import System.Environment (lookupEnv)
+import System.Directory (getHomeDirectory)
+import System.FilePath (takeBaseName, (</>))
-- ---------------------------------------------------------------------------
-- CLI argument types
@@ -31,11 +40,16 @@ import System.Environment (lookupEnv)
data TricuArgs
= Repl
+ | Check
+ { checkInput :: FilePath
+ , checkStore :: Maybe FilePath
+ }
| Eval
{ evalFiles :: [FilePath]
+ , evalStore :: Maybe FilePath
, evalFormat :: EvaluatedForm
, evalOutput :: FilePath
- , evalDb :: Maybe FilePath
+ , evalUnchecked :: Bool
, evalIo :: Bool
, evalAllowRead :: [FilePath]
, evalAllowWrite :: [FilePath]
@@ -45,21 +59,32 @@ data TricuArgs
}
| ArboricxCompile
{ compileInput :: FilePath
+ , compileStore :: Maybe FilePath
, compileOutput :: FilePath
, compileNames :: [String]
- , compileDb :: Maybe FilePath
}
| ArboricxImport
- { importFile :: FilePath
- , importDb :: Maybe FilePath
+ { importFile :: FilePath
+ , importStore :: Maybe FilePath
+ , importModule :: Maybe String
}
| ArboricxExport
{ exportTargets :: [String]
+ , exportModules :: [String]
, exportOutput :: FilePath
, exportNames :: [String]
- , exportDb :: Maybe FilePath
+ , exportStore :: Maybe FilePath
, dag :: Bool
}
+ | StoreAliasList
+ { storeAliasKind :: AliasKind
+ , storePathOpt :: Maybe FilePath
+ }
+ | StoreAliasGet
+ { storeAliasKind :: AliasKind
+ , storeAliasName :: String
+ , storePathOpt :: Maybe FilePath
+ }
deriving (Show)
-- ---------------------------------------------------------------------------
@@ -78,9 +103,25 @@ readEvaluatedForm = eitherReader $ \s -> case s of
"string" -> Right StringLit
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string"
+checkParser :: Parser TricuArgs
+checkParser = Check
+ <$> argument str (metavar "FILE")
+ <*> optional (option str
+ ( long "store"
+ <> short 's'
+ <> metavar "PATH"
+ <> help "Content-addressed store path for module import resolution"
+ ))
+
evalParser :: Parser TricuArgs
evalParser = Eval
<$> many (argument str (metavar "FILE..."))
+ <*> optional (option str
+ ( long "store"
+ <> short 's'
+ <> metavar "PATH"
+ <> help "Content-addressed store path for module import resolution"
+ ))
<*> option readEvaluatedForm
( long "format"
<> short 'f'
@@ -95,12 +136,10 @@ evalParser = Eval
<> value ""
<> help "Write output to file instead of stdout"
)
- <*> optional (option str
- ( long "db"
- <> short 'd'
- <> metavar "PATH"
- <> help "Content store database path"
- ))
+ <*> switch
+ ( long "unchecked"
+ <> help "Evaluate as untyped code: ignore View Contract annotations and do not publish unchecked view refs"
+ )
<*> switch
( long "io"
<> help "Interpret the result as an IO action tree and execute it"
@@ -137,6 +176,12 @@ compileParser = ArboricxCompile
<> value ""
<> help "Input .tri source file"
)
+ <*> optional (option str
+ ( long "store"
+ <> short 's'
+ <> metavar "PATH"
+ <> help "Content-addressed store path for module import resolution"
+ ))
<*> option str
( long "output"
<> short 'o'
@@ -150,12 +195,6 @@ compileParser = ArboricxCompile
<> metavar "NAME"
<> help "Definition name(s) to export as bundle roots (repeatable)"
))
- <*> optional (option str
- ( long "db"
- <> short 'd'
- <> metavar "PATH"
- <> help "Content store database path"
- ))
importParser :: Parser TricuArgs
importParser = ArboricxImport
@@ -167,10 +206,16 @@ importParser = ArboricxImport
<> help "Bundle file to import"
)
<*> optional (option str
- ( long "db"
- <> short 'd'
+ ( long "store"
+ <> short 's'
<> metavar "PATH"
- <> help "Content store database path"
+ <> help "Content-addressed store path"
+ ))
+ <*> optional (option str
+ ( long "module"
+ <> short 'm'
+ <> metavar "NAME"
+ <> help "Module alias to create for the imported bundle (defaults to bundle file basename)"
))
exportParser :: Parser TricuArgs
@@ -181,6 +226,12 @@ exportParser = ArboricxExport
<> metavar "TARGET"
<> help "Target hash or name (repeatable)"
))
+ <*> many (option str
+ ( long "module"
+ <> short 'm'
+ <> metavar "MODULE"
+ <> help "Module alias or manifest hash to export (repeatable; bundle export only)"
+ ))
<*> option str
( long "output"
<> short 'o'
@@ -195,16 +246,54 @@ exportParser = ArboricxExport
<> help "Export name(s) for the bundle manifest (repeatable)"
))
<*> optional (option str
- ( long "db"
- <> short 'd'
+ ( long "store"
+ <> short 's'
<> metavar "PATH"
- <> help "Content store database path"
+ <> help "Content-addressed store path"
))
<*> switch
( long "dag"
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
)
+aliasKindReader :: ReadM AliasKind
+aliasKindReader = eitherReader $ \s -> case s of
+ "names" -> Right NameAlias
+ "name" -> Right NameAlias
+ "modules" -> Right ModuleAlias
+ "module" -> Right ModuleAlias
+ "packages" -> Right PackageAlias
+ "package" -> Right PackageAlias
+ _ -> Left "alias kind must be one of: names, modules, packages"
+
+storePathParser :: Parser (Maybe FilePath)
+storePathParser = optional (option str
+ ( long "store"
+ <> short 's'
+ <> metavar "PATH"
+ <> help "Content-addressed store path"
+ ))
+
+aliasKindParser :: Parser AliasKind
+aliasKindParser = option aliasKindReader
+ ( long "kind"
+ <> short 'k'
+ <> metavar "KIND"
+ <> value NameAlias
+ <> help "Alias kind: names, modules, packages (default: names)"
+ )
+
+storeAliasListParser :: Parser TricuArgs
+storeAliasListParser = StoreAliasList
+ <$> aliasKindParser
+ <*> storePathParser
+
+storeAliasGetParser :: Parser TricuArgs
+storeAliasGetParser = StoreAliasGet
+ <$> aliasKindParser
+ <*> argument str (metavar "NAME")
+ <*> storePathParser
+
versionStr :: String
versionStr = "tricu " ++ showVersion version
@@ -213,10 +302,14 @@ tricuParser = (subparser topCommands <|> pure Repl)
<**> infoOption versionStr (long "version" <> help "Show version")
where
topCommands = mconcat
- [ command "eval" (info (evalParser <**> helper)
+ [ command "check" (info (checkParser <**> helper)
+ (progDesc "Check View Contract annotations and report ok or diagnostics"))
+ , command "eval" (info (evalParser <**> helper)
(progDesc "Evaluate tricu source and print the result of the final expression"))
, command "arboricx" (info (arboricxParser <**> helper)
(progDesc "Arboricx bundle operations"))
+ , command "store" (info (storeParser <**> helper)
+ (progDesc "Inspect and manage the content-addressed store"))
]
arboricxParser :: Parser TricuArgs
@@ -229,6 +322,20 @@ arboricxParser = subparser $ mconcat
(progDesc "Export one or more terms from the content store"))
]
+storeParser :: Parser TricuArgs
+storeParser = subparser $ mconcat
+ [ command "alias" (info (storeAliasParser <**> helper)
+ (progDesc "Inspect workspace aliases"))
+ ]
+
+storeAliasParser :: Parser TricuArgs
+storeAliasParser = subparser $ mconcat
+ [ command "list" (info (storeAliasListParser <**> helper)
+ (progDesc "List aliases by kind"))
+ , command "get" (info (storeAliasGetParser <**> helper)
+ (progDesc "Resolve an alias by kind and name"))
+ ]
+
-- ---------------------------------------------------------------------------
-- Entry point
-- ---------------------------------------------------------------------------
@@ -242,10 +349,13 @@ main = do
)
case args of
Repl -> runRepl
+ Check {} -> runCheck args
Eval {} -> runEval args
ArboricxCompile {} -> runCompile args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
+ StoreAliasList {} -> runStoreAliasList args
+ StoreAliasGet {} -> runStoreAliasGet args
-- ---------------------------------------------------------------------------
@@ -258,25 +368,40 @@ runRepl = do
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
+runCheck :: TricuArgs -> IO ()
+runCheck opts = do
+ output <- case checkStore opts of
+ Nothing -> checkFile (checkInput opts)
+ Just storePath -> checkFileWithStore (StorePath storePath) (checkInput opts)
+ putStrLn output
+
+evaluateCheckedIOFile :: StorePath -> ContractMode -> Env -> FilePath -> IO Env
+evaluateCheckedIOFile store mode env filePath = do
+ loaded <- loadFileWithStoreMode mode store filePath
+ checkedAst <- case instrumentIOContinuations (loadedAst loaded) of
+ Left err -> die err
+ Right asts -> pure asts
+ viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri"
+ pure $ evalTricu (Map.unions [viewEnv, loadedImports loaded, env]) checkedAst
+
runEval :: TricuArgs -> IO ()
runEval opts = do
let files = evalFiles opts
form = evalFormat opts
out = evalOutput opts
- mconn <- case evalDb opts of
- Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath)
- Nothing -> do
- mDbPath <- lookupEnv "TRICU_DB_PATH"
- case mDbPath of
- Just _ -> Just <$> initContentStoreWithPath Nothing
- Nothing -> return Nothing
resultT <- case files of
[] -> do
input <- getContents
- env <- evalTricuWithStore mconn Map.empty (parseTricu input)
+ let env = evalTricu Map.empty (parseTricu input)
return $ result env
_ -> do
- finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
+ mStoreOpt <- traverse (pure . StorePath) (evalStore opts)
+ let contractMode = if evalUnchecked opts then IgnoreContracts else EnforceContracts
+ finalEnv <- if evalIo opts && contractMode == EnforceContracts
+ then do
+ store <- maybe defaultStorePath pure mStoreOpt
+ foldM (evaluateCheckedIOFile store contractMode) Map.empty files
+ else foldM (evaluateFileWithContextWithStoreAndMode contractMode mStoreOpt) Map.empty files
return $ mainResult finalEnv
finalT <- if evalIo opts
then do
@@ -291,9 +416,6 @@ runEval opts = do
Left err -> die $ "IO error: " ++ err
Right val -> pure val
else return resultT
- case mconn of
- Just conn -> close conn
- Nothing -> return ()
writeOutput out (formatT form finalT)
runCompile :: TricuArgs -> IO ()
@@ -301,20 +423,35 @@ runCompile opts = do
let input = compileInput opts
out = compileOutput opts
names = compileNames opts
+ mStore = StorePath <$> compileStore opts
when (null out) $ die "tricu arboricx compile: --output is required"
when (null input) $ die "tricu arboricx compile: input file is required"
let nameTexts = if null names then [] else map T.pack names
- compileFile input out nameTexts
+ compileFileWithStore mStore input out nameTexts
runImport :: TricuArgs -> IO ()
runImport opts = do
let file = importFile opts
when (null file) $ die "tricu arboricx import: input file is required"
- withContentStore (importDb opts) $ \conn -> do
- bundleData <- BL.readFile file
- roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
- putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
- mapM_ (\r -> putStrLn $ " " ++ r) roots
+ store <- resolveStorePath (importStore opts)
+ bundleData <- BL.readFile file
+ roots <- unpackBundleToStore store (BL.toStrict bundleData)
+ mapM_ (\(name, root) ->
+ writeAlias store NameAlias name (treeTermRef root)) roots
+ let manifest = ModuleManifest []
+ [ ModuleExport
+ name
+ (treeTermRef root)
+ "arboricx.abi.tree.v1"
+ Nothing
+ | (name, root) <- roots
+ ]
+ moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts)
+ manifestHash <- putManifest store manifest
+ writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash)
+ putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
+ mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots
+ putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash
runExport :: TricuArgs -> IO ()
runExport opts =
@@ -325,37 +462,53 @@ runExport opts =
runExportBundle :: TricuArgs -> IO ()
runExportBundle opts = do
let targets = exportTargets opts
+ modules = exportModules opts
out = exportOutput opts
names = exportNames opts
- when (null out) $ die "tricu arboricx export: --output is required"
- when (null targets) $ die "tricu arboricx export: at least one --target is required"
- withContentStore (exportDb opts) $ \conn -> do
- terms <- mapM (\t -> do
- (h, _) <- resolveExportTarget conn t
- maybeTree <- loadTree conn h
- case maybeTree of
- Nothing -> die $ "Term not found in store: " ++ t
- Just tree -> return tree) targets
- let expNames = if null names
- then defaultExportNames (length terms)
- else map T.pack names
- when (length expNames /= length terms) $
- die "tricu arboricx export: number of --name values must match number of TARGETs"
- let namedTerms = zip expNames terms
- bundle = buildBundle namedTerms
- bundleData = encodeBundle bundle
- BL.writeFile out (BL.fromStrict bundleData)
- putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out
- putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
- putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
+ when (null out) $ die "tricu arboricx export: --output is required"
+ when (null targets && null modules) $
+ die "tricu arboricx export: at least one --target or --module is required"
+ store <- resolveStorePath (exportStore opts)
+ targetRoots <- mapM (resolveStoreTarget store) targets
+ moduleRoots <- concat <$> mapM (resolveModuleExports store) modules
+ let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots
+ entries = targetEntries ++ moduleRoots
+ expNames = if null names then map fst entries else map T.pack names
+ when (length expNames /= length entries) $
+ die "tricu arboricx export: number of --name values must match number of exported roots"
+ bundle <- packBundleFromStore store (zip expNames (map snd entries))
+ let bundleData = encodeBundle bundle
+ BL.writeFile out (BL.fromStrict bundleData)
+ putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out
+ putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
+ putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
+
+runStoreAliasList :: TricuArgs -> IO ()
+runStoreAliasList opts = do
+ store <- resolveStorePath (storePathOpt opts)
+ aliases <- listAliases store (storeAliasKind opts)
+ mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases
+
+runStoreAliasGet :: TricuArgs -> IO ()
+runStoreAliasGet opts = do
+ store <- resolveStorePath (storePathOpt opts)
+ mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts)
+ case mRef of
+ Nothing -> die $ "alias not found: " ++ storeAliasName opts
+ Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref
runExportDag :: TricuArgs -> IO ()
runExportDag opts = do
let targets = exportTargets opts
+ modules = exportModules opts
out = exportOutput opts
+ unless (null modules) $
+ die "tricu arboricx export --dag: --module is only supported for bundle export"
case targets of
- [target] -> withContentStore (exportDb opts) $ \conn -> do
- maybeTerm <- loadTerm conn target
+ [target] -> do
+ store <- resolveStorePath (exportStore opts)
+ root <- resolveStoreTarget store target
+ maybeTerm <- getTreeTerm store root
case maybeTerm of
Nothing -> die $ "Term not found: " ++ target
Just term -> do
@@ -371,12 +524,54 @@ runExportDag opts = do
-- Helpers
-- ---------------------------------------------------------------------------
-withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a
-withContentStore mPath act = do
- conn <- initContentStoreWithPath mPath
- result <- act conn
- close conn
- return result
+resolveStorePath :: Maybe FilePath -> IO StorePath
+resolveStorePath (Just path) = return (StorePath path)
+resolveStorePath Nothing = do
+ home <- getHomeDirectory
+ return (StorePath (home </> ".tricu" </> "store"))
+
+treeTermRef :: ObjectHash -> ObjectRef
+treeTermRef = ObjectRef (unDomain treeTermDomain)
+
+resolveStoreTarget :: StorePath -> String -> IO ObjectHash
+resolveStoreTarget store target = do
+ mAlias <- readAlias store NameAlias (T.pack target)
+ let root = maybe (T.pack target) objectRefHash mAlias
+ mTree <- getTreeTerm store root
+ case mTree of
+ Just _ -> return root
+ Nothing -> die $ "Term not found in store: " ++ target
+
+resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)]
+resolveModuleExports store moduleTarget = do
+ manifestHash <- resolveModuleManifestHash store moduleTarget
+ mManifest <- getManifest store manifestHash
+ manifest <- case mManifest of
+ Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget
+ Just value -> return value
+ mapM exportEntry (moduleManifestExports manifest)
+ where
+ exportEntry ex = do
+ let ref = moduleExportObject ex
+ unless (objectRefKind ref == unDomain treeTermDomain) $
+ die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref)
+ mTree <- getTreeTerm store (objectRefHash ref)
+ case mTree of
+ Nothing -> die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex)
+ Just _ -> return (moduleExportName ex, objectRefHash ref)
+
+resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash
+resolveModuleManifestHash store moduleTarget = do
+ mAlias <- readAlias store ModuleAlias (T.pack moduleTarget)
+ case mAlias of
+ Just ref -> do
+ unless (objectRefKind ref == unDomain manifestDomain) $
+ die $ "Module alias does not point at a module manifest: " ++ moduleTarget
+ return (objectRefHash ref)
+ Nothing -> return (T.pack moduleTarget)
+
+formatObjectRef :: ObjectRef -> String
+formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref)
writeOutput :: FilePath -> String -> IO ()
writeOutput path content
diff --git a/src/Module/Manifest.hs b/src/Module/Manifest.hs
@@ -0,0 +1,137 @@
+module Module.Manifest
+ ( ModuleManifest(..)
+ , ModuleReference(..)
+ , ModuleExport(..)
+ , manifestDomain
+ , encodeManifest
+ , decodeManifest
+ , putManifest
+ , getManifest
+ ) where
+
+import ContentStore.Filesystem (getObject, putObject)
+import ContentStore.Object
+import ContentStore.Alias (ObjectRef(..))
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+
+import qualified Data.Text as Text
+
+-- | Immutable module artifact. Names are export labels inside this manifest;
+-- content identity is carried by object references and the manifest CAS hash.
+data ModuleManifest = ModuleManifest
+ { moduleManifestReferences :: [ModuleReference]
+ , moduleManifestExports :: [ModuleExport]
+ } deriving (Eq, Ord, Show)
+
+-- | Direct content-addressed reference needed to understand, fetch, or audit
+-- this manifest. The alias is human-facing metadata for diagnostics/workspace
+-- presentation; the referenced object is the portable identity. These are not
+-- source-language imports.
+data ModuleReference = ModuleReference
+ { moduleReferenceAlias :: Text
+ , moduleReferenceRef :: ObjectRef
+ } deriving (Eq, Ord, Show)
+
+-- | Exported executable artifact plus optional direct View Contract type.
+data ModuleExport = ModuleExport
+ { moduleExportName :: Text
+ , moduleExportObject :: ObjectRef
+ , moduleExportAbi :: Text
+ , moduleExportView :: Maybe ObjectRef
+ } deriving (Eq, Ord, Show)
+
+manifestDomain :: Domain
+manifestDomain = Domain "arboricx.module-manifest.v1"
+
+encodeManifest :: ModuleManifest -> ByteString
+encodeManifest manifest = encodeUtf8 $ Text.unlines $
+ ["arboricx.module-manifest.v1"]
+ ++ map encodeReference (moduleManifestReferences manifest)
+ ++ map encodeExport (moduleManifestExports manifest)
+ where
+ encodeReference ref = Text.intercalate "\t"
+ [ "reference"
+ , esc (moduleReferenceAlias ref)
+ , esc (objectRefKind $ moduleReferenceRef ref)
+ , esc (objectRefHash $ moduleReferenceRef ref)
+ ]
+ encodeExport ex = Text.intercalate "\t"
+ [ "export"
+ , esc (moduleExportName ex)
+ , esc (objectRefKind $ moduleExportObject ex)
+ , esc (objectRefHash $ moduleExportObject ex)
+ , esc (moduleExportAbi ex)
+ , maybe "-" (esc . objectRefKind) (moduleExportView ex)
+ , maybe "-" (esc . objectRefHash) (moduleExportView ex)
+ ]
+
+-- | Parse the canonical manifest encoding.
+decodeManifest :: ByteString -> Either String ModuleManifest
+decodeManifest bs = do
+ txt <- either (Left . show) Right (decodeUtf8' bs)
+ case Text.lines txt of
+ [] -> Left "empty module manifest"
+ header : rows
+ | header /= "arboricx.module-manifest.v1" -> Left "unsupported module manifest version"
+ | otherwise -> foldl step (Right (ModuleManifest [] [])) rows
+ where
+ step acc line = do
+ manifest <- acc
+ case Text.splitOn "\t" line of
+ ["reference", alias, kind, hash] -> do
+ ref <- ModuleReference <$> unesc alias <*> (ObjectRef <$> unesc kind <*> unesc hash)
+ Right manifest { moduleManifestReferences = moduleManifestReferences manifest ++ [ref] }
+ ["export", name, kind, hash, abi, viewKind, viewHash] -> do
+ view <- optionalRef viewKind viewHash
+ ex <- ModuleExport
+ <$> unesc name
+ <*> (ObjectRef <$> unesc kind <*> unesc hash)
+ <*> unesc abi
+ <*> pure view
+ Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
+ _ -> Left $ "invalid module manifest row: " ++ Text.unpack line
+
+putManifest :: StorePath -> ModuleManifest -> IO ObjectHash
+putManifest store = putObject store manifestDomain . encodeManifest
+
+getManifest :: StorePath -> ObjectHash -> IO (Maybe ModuleManifest)
+getManifest store h = do
+ mBytes <- getObject store h
+ case mBytes of
+ Nothing -> return Nothing
+ Just bytes -> case decodeManifest bytes of
+ Left err -> fail $ "invalid module manifest " ++ Text.unpack h ++ ": " ++ err
+ Right manifest -> return (Just manifest)
+
+optionalRef :: Text -> Text -> Either String (Maybe ObjectRef)
+optionalRef "-" "-" = Right Nothing
+optionalRef kind hash = Just <$> (ObjectRef <$> unesc kind <*> unesc hash)
+
+esc :: Text -> Text
+esc = Text.concatMap $ \c -> case c of
+ '%' -> "%25"
+ '\t' -> "%09"
+ '\n' -> "%0A"
+ '\r' -> "%0D"
+ _ -> Text.singleton c
+
+unesc :: Text -> Either String Text
+unesc txt = go txt ""
+ where
+ go rest acc = case Text.uncons rest of
+ Nothing -> Right acc
+ Just ('%', xs) ->
+ let (code, tail') = Text.splitAt 2 xs
+ decoded = case code of
+ "25" -> Just "%"
+ "09" -> Just "\t"
+ "0A" -> Just "\n"
+ "0D" -> Just "\r"
+ _ -> Nothing
+ in case decoded of
+ Nothing -> Left $ "invalid percent escape: %" ++ Text.unpack code
+ Just c -> go tail' (acc <> c)
+ Just (c, xs) -> go xs (acc <> Text.singleton c)
diff --git a/src/Module/Resolver.hs b/src/Module/Resolver.hs
@@ -0,0 +1,153 @@
+module Module.Resolver
+ ( ResolvedExport(..)
+ , ResolvedModule(..)
+ , resolveModuleImport
+ , resolveModuleImportSelecting
+ , resolveModuleImports
+ , resolvedModulesEnv
+ ) where
+
+import ContentStore.Alias
+import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
+import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm)
+import ContentStore.Object
+import ContentStore.Resolver
+import Module.Manifest
+import Research
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+
+-- | A manifest export resolved into the importing source's local lexical scope.
+-- The executable term is loaded, while object/view refs remain available for
+-- later checker and diagnostics phases.
+data ResolvedExport = ResolvedExport
+ { resolvedExportSourceName :: T.Text
+ , resolvedExportLocalName :: String
+ , resolvedExportObject :: ObjectRef
+ , resolvedExportAbi :: T.Text
+ , resolvedExportView :: Maybe ObjectRef
+ , resolvedExportTerm :: T
+ } deriving (Show, Eq)
+
+data ResolvedModule = ResolvedModule
+ { resolvedModuleTarget :: String
+ , resolvedModuleNamespace :: String
+ , resolvedModuleManifest :: ObjectHash
+ , resolvedModuleExports :: [ResolvedExport]
+ } deriving (Show, Eq)
+
+resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST])
+resolveModuleImports resolver asts = do
+ let (imports, nonImports) = foldr splitImport ([], []) asts
+ modules <- mapM (uncurry (resolveModuleImport resolver)) imports
+ return (modules, nonImports)
+ where
+ splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest)
+ splitImport ast (is, rest) = (is, ast : rest)
+
+resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule
+resolveModuleImport resolver moduleTarget namespace =
+ resolveModuleImportSelecting resolver Nothing moduleTarget namespace
+
+resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule
+resolveModuleImportSelecting resolver selected moduleTarget namespace = do
+ manifestHash <- resolveModuleManifestHash resolver moduleTarget
+ mManifest <- resolveManifest resolver manifestHash
+ manifest <- case mManifest of
+ Nothing -> errorWithoutStackTrace $
+ "Module import failed for " ++ show moduleTarget
+ ++ " as " ++ show namespace
+ ++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain)
+ ++ ", hash " ++ T.unpack manifestHash ++ ")"
+ Just value -> return value
+ let wantedExports = case selected of
+ Nothing -> moduleManifestExports manifest
+ Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest)
+ exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports
+ return ResolvedModule
+ { resolvedModuleTarget = moduleTarget
+ , resolvedModuleNamespace = namespace
+ , resolvedModuleManifest = manifestHash
+ , resolvedModuleExports = exports
+ }
+ where
+ localNamespace = if namespace == "!Local" then "" else namespace
+
+resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport
+resolveModuleExport resolver namespace ex = do
+ let ref = moduleExportObject ex
+ sourceName = moduleExportName ex
+ term <- resolveExportTerm resolver sourceName ref
+ return ResolvedExport
+ { resolvedExportSourceName = sourceName
+ , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
+ , resolvedExportObject = ref
+ , resolvedExportAbi = moduleExportAbi ex
+ , resolvedExportView = moduleExportView ex
+ , resolvedExportTerm = term
+ }
+
+resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T
+resolveExportTerm resolver sourceName ref
+ | objectRefKind ref == viewTreeKind = do
+ bytes <- requireObject "view tree"
+ case decodeViewTree bytes >>= viewTreeRootTerm of
+ Left err -> errorWithoutStackTrace $
+ "Module export " ++ show (T.unpack sourceName)
+ ++ " references invalid view tree " ++ T.unpack (objectRefHash ref)
+ ++ ": " ++ err
+ Right term -> return term
+ | objectRefKind ref == unDomain treeTermDomain = do
+ bytes <- requireObject "tree term"
+ case decodeTreeTerm bytes of
+ Left err -> errorWithoutStackTrace $
+ "Module export " ++ show (T.unpack sourceName)
+ ++ " references invalid tree term " ++ T.unpack (objectRefHash ref)
+ ++ ": " ++ err
+ Right term -> return term
+ | otherwise = errorWithoutStackTrace $
+ "Module export " ++ show (T.unpack sourceName)
+ ++ " has unsupported object kind " ++ show (T.unpack (objectRefKind ref))
+ ++ "; expected " ++ show (T.unpack viewTreeKind)
+ ++ " or " ++ show (T.unpack (unDomain treeTermDomain))
+ where
+ requireObject label = do
+ mBytes <- resolverObject resolver ref
+ case mBytes of
+ Just bytes -> return bytes
+ Nothing -> errorWithoutStackTrace $
+ "Module export " ++ show (T.unpack sourceName)
+ ++ " references missing " ++ label ++ " " ++ T.unpack (objectRefHash ref)
+ ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
+
+resolvedModulesEnv :: [ResolvedModule] -> Env
+resolvedModulesEnv modules = Map.fromList
+ [ (resolvedExportLocalName ex, resolvedExportTerm ex)
+ | m <- modules
+ , ex <- resolvedModuleExports m
+ ]
+
+resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash
+resolveModuleManifestHash resolver moduleTarget = do
+ mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget)
+ case mAlias of
+ Just ref ->
+ if objectRefKind ref == unDomain manifestDomain
+ then return (objectRefHash ref)
+ else errorWithoutStackTrace $
+ "Module alias " ++ show moduleTarget
+ ++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref))
+ ++ "; expected " ++ show (T.unpack (unDomain manifestDomain))
+ ++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")"
+ Nothing ->
+ case textToHashBytes (T.pack moduleTarget) of
+ Right _ -> return (T.pack moduleTarget)
+ Left _ -> errorWithoutStackTrace $
+ "Module alias not found: " ++ show moduleTarget
+ ++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash"
+
+nsVariable :: String -> String -> String
+nsVariable "" name = name
+nsVariable moduleName name = moduleName ++ "." ++ name
diff --git a/src/Module/Workspace.hs b/src/Module/Workspace.hs
@@ -0,0 +1,66 @@
+module Module.Workspace
+ ( Workspace(..)
+ , emptyWorkspace
+ , lookupWorkspaceModule
+ , findWorkspaceFor
+ , parseWorkspace
+ ) where
+
+import Data.Char (isSpace)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import System.Directory (doesDirectoryExist, doesFileExist)
+import System.FilePath (takeDirectory, (</>))
+
+data Workspace = Workspace
+ { workspaceRoot :: FilePath
+ , workspaceModules :: Map.Map T.Text FilePath
+ } deriving (Show, Eq)
+
+emptyWorkspace :: Workspace
+emptyWorkspace = Workspace "" Map.empty
+
+lookupWorkspaceModule :: Workspace -> T.Text -> Maybe FilePath
+lookupWorkspaceModule (Workspace root modules) name = (root </>) <$> Map.lookup name modules
+
+findWorkspaceFor :: FilePath -> IO Workspace
+findWorkspaceFor sourcePath = search (takeDirectory sourcePath)
+ where
+ search dir = do
+ let path = dir </> "tricu.workspace"
+ exists <- doesFileExist path
+ if exists
+ then parseWorkspaceAt dir <$> readFile path
+ else do
+ let parent = takeDirectory dir
+ if parent == dir
+ then return emptyWorkspace
+ else do
+ parentExists <- doesDirectoryExist parent
+ if parentExists then search parent else return emptyWorkspace
+
+parseWorkspace :: String -> Workspace
+parseWorkspace = parseWorkspaceAt ""
+
+parseWorkspaceAt :: FilePath -> String -> Workspace
+parseWorkspaceAt root input = Workspace root $ Map.fromList
+ [ (T.pack name, path)
+ | raw <- lines input
+ , Just (name, path) <- [parseLine raw]
+ ]
+
+parseLine :: String -> Maybe (String, FilePath)
+parseLine raw =
+ let line = trim (takeWhile (/= '#') raw)
+ in case words line of
+ [] -> Nothing
+ ["module", name, "=", path] -> Just (name, stripQuotes path)
+ _ -> Nothing
+
+trim :: String -> String
+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+stripQuotes :: String -> String
+stripQuotes s = case s of
+ ('"':rest) | not (null rest) && last rest == '"' -> init rest
+ _ -> s
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -75,20 +75,133 @@ topItemP = do
definitionHeadTop :: [LToken] -> Maybe (String, [String])
definitionHeadTop toks =
- case collectIdentifiersNoNewlines toks of
- (name:args, LAssign : _)
+ case toks of
+ LIdentifier name : rest
| name `Set.notMember` reservedNames
- , all (`Set.notMember` reservedNames) args -> Just (name, args)
- _ -> Nothing
+ , definitionAssignOnLine rest -> Just (name, [])
+ _ -> Nothing
+
+-- A top-level definition head is any identifier-led line containing `=` or `=@`.
+-- Detailed validation happens in definitionP.
+definitionAssignOnLine :: [LToken] -> Bool
+definitionAssignOnLine [] = False
+definitionAssignOnLine (LNewline : _) = False
+definitionAssignOnLine (LAssign : _) = True
+definitionAssignOnLine (LAssignAt : _) = True
+definitionAssignOnLine (LIdentifier "where" : _) = False
+definitionAssignOnLine (LIdentifier "in" : _) = False
+definitionAssignOnLine (_ : rest) = definitionAssignOnLine rest
definitionP :: TokParser TricuAST
definitionP = do
name <- identifierNameP
- args <- many identifierNameP
- void (tok (== LAssign) "=")
+ (args, annotated) <- definitionArgsP False
+ ret <- optional returnAnnotationP
bodyIndent <- skipNestedNewlinesGetIndent
body <- exprAtIndentP bodyIndent
- pure (SDef name args body)
+ if annotated || ret /= Nothing
+ then pure (SDefAnn name args ret body)
+ else pure (SDef name (binderNames args) body)
+
+binderNames :: [DefArg] -> [String]
+binderNames [] = []
+binderNames (DefBinder name _ : rest) = name : binderNames rest
+binderNames (DefPhantom _ : rest) = binderNames rest
+
+definitionArgsP :: Bool -> TokParser ([DefArg], Bool)
+definitionArgsP seenPhantom = do
+ mt <- peekP
+ case mt of
+ Just LAssign -> do
+ void (tok (== LAssign) "=")
+ pure ([], False)
+ Just LAssignAt -> pure ([], False)
+ Just (LIdentifier _) | not seenPhantom -> do
+ name <- identifierNameP
+ mAnn <- optional (try (tok (== LAt) "@" *> annotationTypeP))
+ (rest, ann) <- definitionArgsP seenPhantom
+ pure (DefBinder name mAnn : rest, ann || mAnn /= Nothing)
+ Just LAt -> do
+ void (tok (== LAt) "@")
+ ty <- annotationTypeP
+ (rest, ann) <- definitionArgsP True
+ pure (DefPhantom ty : rest, True || ann)
+ Just (LIdentifier _) -> fail "named binders cannot appear after phantom type annotations"
+ _ -> fail "expected definition argument or assignment"
+
+returnAnnotationP :: TokParser ViewExpr
+returnAnnotationP = do
+ void (tok (== LAssignAt) "=@")
+ annotationTypeP
+
+annotationTypeP :: TokParser ViewExpr
+annotationTypeP =
+ atomicTypeP
+ <|> parenTypeP
+
+parenTypeP :: TokParser ViewExpr
+parenTypeP = do
+ void (tok (== LOpenParen) "(")
+ ty <- typeP
+ void (tok (== LCloseParen) ")")
+ pure ty
+
+typeP :: TokParser ViewExpr
+typeP = appTypeP
+
+appTypeP :: TokParser ViewExpr
+appTypeP = do
+ first <- typeAtomP
+ rest <- many typeAtomP
+ pure (foldl VEApp first rest)
+
+typeAtomP :: TokParser ViewExpr
+typeAtomP =
+ typeListP
+ <|> typeStringP
+ <|> typeIntP
+ <|> atomicTypeP
+ <|> parenTypeP
+
+typeListP :: TokParser ViewExpr
+typeListP = do
+ void (tok (== LOpenBracket) "[")
+ args <- many typeP
+ void (tok (== LCloseBracket) "]")
+ pure (VEList args)
+
+typeIntP :: TokParser ViewExpr
+typeIntP = do
+ n <- tok isInt "integer"
+ case n of
+ LIntegerLiteral i -> pure (VEInt (fromIntegral i))
+ _ -> fail "internal parser error: expected integer"
+ where
+ isInt (LIntegerLiteral _) = True
+ isInt _ = False
+
+typeStringP :: TokParser ViewExpr
+typeStringP = do
+ s <- tok isString "string"
+ case s of
+ LStringLiteral value -> pure (VEString value)
+ _ -> fail "internal parser error: expected string"
+ where
+ isString (LStringLiteral _) = True
+ isString _ = False
+
+atomicTypeP :: TokParser ViewExpr
+atomicTypeP = do
+ t <- tok isTypeName "type name"
+ case t of
+ LNamespace name -> pure (VEName name)
+ LIdentifier name -> pure (VEName name)
+ _ -> fail "internal parser error: expected type name"
+
+isTypeName :: LToken -> Bool
+isTypeName (LNamespace _) = True
+isTypeName (LIdentifier _) = True
+isTypeName _ = False
importP :: TokParser TricuAST
importP = do
@@ -146,15 +259,17 @@ lambdaHeadNested toks =
_ -> Nothing
collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
-collectIdentifiersNoNewlines (LIdentifier name : rest) =
- let (names, final) = collectIdentifiersNoNewlines rest
- in (name : names, final)
+collectIdentifiersNoNewlines (LIdentifier name : rest)
+ | name `Set.notMember` reservedNames =
+ let (names, final) = collectIdentifiersNoNewlines rest
+ in (name : names, final)
collectIdentifiersNoNewlines rest = ([], rest)
collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
-collectIdentifiersWithNewlines (LIdentifier name : rest) =
- let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
- in (name : names, final)
+collectIdentifiersWithNewlines (LIdentifier name : rest)
+ | name `Set.notMember` reservedNames =
+ let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
+ in (name : names, final)
collectIdentifiersWithNewlines rest = ([], rest)
consumeLambdaHead :: Context -> [String] -> TokParser ()
@@ -194,7 +309,7 @@ pipeTopP =
pipeAtIndentP :: Int -> TokParser TricuAST
pipeAtIndentP n =
- pipeChainP (appAtIndentP n) appNestedP
+ pipeChainP (appAtIndentP n) (appAtIndentP n)
pipeNestedP :: TokParser TricuAST
pipeNestedP =
@@ -303,6 +418,7 @@ atomTopP = do
case toks of
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
+ LIdentifier _ : LDot : _ -> namespacedVarP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier "let" : _ -> letP
LIdentifier "do" : _ -> doP
@@ -354,6 +470,7 @@ listElementP = do
case toks of
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
+ LIdentifier _ : LDot : _ -> namespacedVarP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier "let" : _ -> letP
LIdentifier "do" : _ -> doP
@@ -486,14 +603,19 @@ namespacedVarP = do
void (tok (== LDot) ".")
nameTok <- tok isVar "identifier"
case (nsTok, nameTok) of
+ (LIdentifier ns, LIdentifier name) ->
+ pure (SVar (ns ++ "." ++ name) Nothing)
+ (LIdentifier ns, LIdentifierWithHash name hash) ->
+ pure (SVar (ns ++ "." ++ name) (Just hash))
(LNamespace ns, LIdentifier name) ->
pure (SVar (ns ++ "." ++ name) Nothing)
(LNamespace ns, LIdentifierWithHash name hash) ->
pure (SVar (ns ++ "." ++ name) (Just hash))
_ -> fail "internal parser error: expected namespaced identifier"
where
- isNamespace (LNamespace _) = True
- isNamespace _ = False
+ isNamespace (LIdentifier name) = name `Set.notMember` reservedNames
+ isNamespace (LNamespace _) = True
+ isNamespace _ = False
isVar (LIdentifier _) = True
isVar (LIdentifierWithHash _ _) = True
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -1,675 +1,241 @@
module REPL where
-import ContentStore
-import Eval
+import Check (checkFileWithStore)
+import Eval (evalTricu, result)
import FileEval
-import Lexer ()
-import Parser
-import Research
-import Wire (buildBundle, encodeBundle, importBundle)
-
-import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
-import Control.Exception (SomeException, catch, displayException)
-import Control.Monad ()
-import Control.Monad (forever, when, forM_, foldM, unless)
-import Control.Monad.Catch (handle)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Class ()
-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-import Data.ByteString ()
-import Data.Char (isSpace)
-
-import qualified Data.ByteString.Lazy as BL
-import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.List (dropWhileEnd, isPrefixOf, find)
-import Data.Maybe (isJust, fromJust)
-import Data.Time (getCurrentTime, diffUTCTime)
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Data.Time.Format (formatTime, defaultTimeLocale)
+ ( ContractMode(..)
+ , LoadedSource(..)
+ , defaultStorePath
+ , loadFileWithStoreMode
+ )
+import Parser (parseTricu)
+import Research (EvaluatedForm(..), Env, formatT)
+import ContentStore (StorePath(..))
+
+import Control.Exception (SomeException, catch, displayException)
+import Control.Monad.IO.Class (liftIO)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (isPrefixOf, sort)
import Data.Version (showVersion)
-import Database.SQLite.Simple (Connection, Only(..), query)
import Paths_tricu (version)
-import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
import System.Console.Haskeline
-import System.Directory (doesFileExist, createDirectoryIfMissing)
-import System.FSNotify
-import System.FilePath (takeDirectory, (</>))
-import Text.Read (readMaybe)
+import System.Directory (doesFileExist)
import qualified Data.Map as Map
-import qualified Data.Text as T
-import qualified Data.Text.IO as T ()
+-- | Source-local REPL with the same filesystem CAS/module loader used by the
+-- CLI. View Contract checking is explicit (`!check`); evaluation can run in
+-- normal publishing mode or unchecked mode.
data REPLState = REPLState
- { replForm :: EvaluatedForm
- , replContentStore :: Maybe Connection
- , replWatchedFile :: Maybe FilePath
- , replSelectedVersions :: Map.Map String T.Text
- , replWatcherThread :: Maybe ThreadId
+ { replForm :: EvaluatedForm
+ , replEnv :: Env
+ , replStore :: StorePath
+ , replContracts :: ContractMode
+ , replEnvRef :: IORef Env
}
repl :: IO ()
repl = do
- conn <- ContentStore.initContentStore
- runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
+ store <- defaultStorePath
+ envRef <- newIORef Map.empty
+ let settings = Settings
+ { complete = completeRepl envRef
+ , historyFile = Just "~/.local/state/tricu/history"
+ , autoAddHistory = True
+ }
+ runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef))
where
- settings :: Settings IO
- settings = Settings
- { complete = completeWord Nothing " \t" completeCommands
- , historyFile = Just "~/.local/state/tricu/history"
- , autoAddHistory = True
- }
-
- completeCommands :: String -> IO [Completion]
- completeCommands str = return $ map simpleCompletion $
- filter (str `isPrefixOf`) commands
- where
- commands = [ "!exit"
- , "!output"
- , "!import"
- , "!clear"
- , "!reset"
- , "!help"
- , "!definitions"
- , "!watch"
- , "!refresh"
- , "!versions"
- , "!select"
- , "!tag"
- , "!export"
- , "!bundleimport"
- ]
loop :: REPLState -> InputT IO ()
- loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
+ loop state = do
minput <- getInputLine "tricu < "
case minput of
Nothing -> return ()
- Just s
- | strip s == "" -> loop state
- | strip s == "!exit" -> outputStrLn "Exiting tricu"
- | strip s == "!clear" -> do
- liftIO $ putStr "\ESC[2J\ESC[H"
- loop state
- | strip s == "!reset" -> do
- outputStrLn "Selected versions reset"
- loop state { replSelectedVersions = Map.empty }
- | strip s == "!help" -> do
- outputStrLn $ "tricu version " ++ showVersion version
- outputStrLn "Available commands:"
- outputStrLn " !exit - Exit the REPL"
- outputStrLn " !clear - Clear the screen"
- outputStrLn " !reset - Reset preferences for selected versions"
- outputStrLn " !help - Show tricu version and available commands"
- outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
- outputStrLn " !definitions - List all defined terms in the content store"
- outputStrLn " !import - Import definitions from file to the content store"
- outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them"
- outputStrLn " !versions - Show all versions of a term by name"
- outputStrLn " !select - Select a specific version of a term for subsequent lookups"
- outputStrLn " !tag - Add or update a tag for a term by hash or name"
- outputStrLn " !export - Export a term bundle to file (hash, file)"
- outputStrLn " !bundleimport- Import a bundle file into the content store"
- loop state
- | strip s == "!output" -> handleOutput state
- | strip s == "!definitions" -> handleDefinitions state
- | "!import" `isPrefixOf` strip s -> handleImport state
- | "!watch" `isPrefixOf` strip s -> handleWatch state
- | strip s == "!refresh" -> handleRefresh state
- | "!versions" `isPrefixOf` strip s -> handleVersions state
- | "!select" `isPrefixOf` strip s -> handleSelect state
- | "!tag" `isPrefixOf` strip s -> handleTag state
- | "!export" `isPrefixOf` strip s -> handleExport state
- | "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
- | take 2 s == "--" -> loop state
- | otherwise -> do
- evalResult <- liftIO $ catch
- (processInput state s)
- (errorHandler state)
- loop evalResult
+ Just raw -> do
+ let s = strip raw
+ case s of
+ "" -> loop state
+ "!exit" -> outputStrLn "Exiting tricu"
+ "!clear" -> liftIO (putStr "\ESC[2J\ESC[H") >> loop state
+ "!reset" -> do
+ liftIO $ writeIORef (replEnvRef state) Map.empty
+ outputStrLn "Environment reset"
+ loop state { replEnv = Map.empty }
+ "!help" -> printHelp >> loop state
+ "!output" -> handleOutput state
+ "!env" -> handleEnv state >> loop state
+ _ | "!load" `isPrefixOf` s -> handleLoad state (strip $ drop 5 s)
+ | "!check" `isPrefixOf` s -> handleCheck state (strip $ drop 6 s)
+ | "!store" `isPrefixOf` s -> handleStore state (strip $ drop 6 s)
+ | "!format" `isPrefixOf` s -> handleFormat state (strip $ drop 7 s)
+ | "!unchecked" `isPrefixOf` s -> handleUnchecked state (strip $ drop 10 s)
+ | take 2 s == "--" -> loop state
+ | otherwise -> do
+ next <- liftIO $ catch (processInput state raw) (errorHandler state)
+ loop next
+
+ printHelp :: InputT IO ()
+ printHelp = do
+ outputStrLn $ "tricu version " ++ showVersion version
+ outputStrLn "Available commands:"
+ outputStrLn " !exit - Exit the REPL"
+ outputStrLn " !clear - Clear the screen"
+ outputStrLn " !reset - Reset the in-memory environment"
+ outputStrLn " !help - Show this help"
+ outputStrLn " !output - Change output format interactively"
+ outputStrLn " !format FORM - Set output format: tree, fsl, ast, ternary, ascii, decode, number, string"
+ outputStrLn " !load FILE - Load and evaluate a .tri file into the environment"
+ outputStrLn " !check FILE - Check View Contract annotations in a .tri file"
+ outputStrLn " !store [PATH] - Show or set the content-addressed store path"
+ outputStrLn " !unchecked [on|off] - Show or set unchecked eval mode"
+ outputStrLn " !env - List names currently in the REPL environment"
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
- let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
+ let formats = outputFormats
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
-
- evalResult <- runMaybeT $ do
- input <- MaybeT $ getInputLine "Select output format (1-8) < "
- case reads input of
- [(n, "")] | n >= 1 && n <= 8 ->
- return $ formats !! (n-1)
- _ -> MaybeT $ return Nothing
-
- case evalResult of
- Nothing -> do
- outputStrLn "Invalid selection. Keeping current output format."
- loop state
- Just newForm -> do
+ input <- getInputLine "Select output format (1-8) < "
+ case input >>= readMaybeInt of
+ Just n | n >= 1 && n <= length formats -> do
+ let newForm = formats !! (n - 1)
outputStrLn $ "Output format changed to: " ++ show newForm
loop state { replForm = newForm }
-
- handleDefinitions :: REPLState -> InputT IO ()
- handleDefinitions state = case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- terms <- liftIO $ ContentStore.listStoredTerms conn
-
- if null terms
- then do
- liftIO $ printWarning "No terms in content store."
- loop state
- else do
- liftIO $ do
- printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:"
-
- let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
-
- forM_ terms $ \term -> do
- let namesStr = T.unpack (termNames term)
- hash = termHash term
- padding = replicate (maxNameWidth - length namesStr) ' '
-
- liftIO $ do
- putStr " "
- printVariable namesStr
- putStr padding
- putStr " [hash: "
- displayColoredHash hash
- putStrLn "]"
-
- tags <- ContentStore.termToTags conn hash
- unless (null tags) $ displayTags tags
-
- loop state
-
- handleImport :: REPLState -> InputT IO ()
- handleImport state = do
- let fset = setComplete completeFilename defaultSettings
- filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "")
- case filename of
- Nothing -> loop state
- Just f -> do
- let cleanFilename = strip f
- exists <- liftIO $ doesFileExist cleanFilename
+ _ -> outputStrLn "Invalid selection. Keeping current output format." >> loop state
+
+ handleFormat :: REPLState -> String -> InputT IO ()
+ handleFormat state arg =
+ case readEvaluatedForm arg of
+ Just form -> outputStrLn ("Output format changed to: " ++ show form) >> loop state { replForm = form }
+ Nothing -> outputStrLn "Usage: !format tree|fsl|ast|ternary|ascii|decode|number|string" >> loop state
+
+ handleLoad :: REPLState -> String -> InputT IO ()
+ handleLoad state path
+ | null path = outputStrLn "Usage: !load FILE" >> loop state
+ | otherwise = do
+ exists <- liftIO $ doesFileExist path
+ if not exists
+ then outputStrLn ("File not found: " ++ path) >> loop state
+ else do
+ loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path
+ let env' = evalTricu (Map.union (loadedImports loaded) (replEnv state)) (loadedAst loaded)
+ liftIO $ writeIORef (replEnvRef state) env'
+ outputStrLn $ "Loaded " ++ path
+ loop state { replEnv = env' }
+
+ handleCheck :: REPLState -> String -> InputT IO ()
+ handleCheck state path
+ | null path = outputStrLn "Usage: !check FILE" >> loop state
+ | otherwise = do
+ exists <- liftIO $ doesFileExist path
if not exists
- then do
- liftIO $ printError $ "File not found: " ++ cleanFilename
+ then outputStrLn ("File not found: " ++ path) >> loop state
+ else do
+ output <- liftIO $ checkFileWithStore (replStore state) path
+ outputStrLn output
loop state
- else importFile state cleanFilename
- importFile :: REPLState -> String -> InputT IO ()
- importFile state cleanFilename = do
- _code <- liftIO $ readFile cleanFilename
- case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
+ handleStore :: REPLState -> String -> InputT IO ()
+ handleStore state path
+ | null path = do
+ outputStrLn $ "Store: " ++ storePathString (replStore state)
loop state
- Just conn -> do
- env <- liftIO $ evaluateFile cleanFilename
-
- liftIO $ do
- printSuccess $ "Importing file: " ++ cleanFilename
- let defs = Map.toList $ Map.delete "!result" env
-
- importedCount <- foldM (\count (name, term) -> do
- hash <- ContentStore.storeTerm conn [name] term
- printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
- return (count + (1 :: Int))
- ) 0 defs
-
- printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
-
- loop state
-
- handleWatch :: REPLState -> InputT IO ()
- handleWatch state = do
- dbPath <- liftIO ContentStore.getContentStorePath
- let filepath = takeDirectory dbPath </> "scratch.tri"
- let dirPath = takeDirectory filepath
-
- liftIO $ createDirectoryIfMissing True dirPath
-
- fileExists <- liftIO $ doesFileExist filepath
- unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n"
-
- outputStrLn $ "Using scratch file: " ++ filepath
-
- when (isJust (replWatcherThread state)) $ do
- outputStrLn "Stopping previous file watch"
- liftIO $ killThread (fromJust $ replWatcherThread state)
-
- outputStrLn $ "Starting to watch file: " ++ filepath
- outputStrLn "Press Ctrl+C to stop watching and return to REPL"
-
- liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
-
- lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
-
- watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
- _stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
- now <- getCurrentTime
- lastProcessed <- readIORef lastProcessedRef
- when (diffUTCTime now lastProcessed > 0.5) $ do
- putStrLn $ "\nFile changed: " ++ filepath
- processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
- writeIORef lastProcessedRef now
- forever $ threadDelay 1000000
-
- watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
-
- _handleUnwatch :: REPLState -> InputT IO ()
- _handleUnwatch state = case replWatchedFile state of
- Nothing -> do
- outputStrLn "No file is currently being watched"
- loop state
- Just path -> do
- outputStrLn $ "Stopped watching " ++ path
- when (isJust (replWatcherThread state)) $ do
- liftIO $ killThread (fromJust $ replWatcherThread state)
- loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }
-
- handleRefresh :: REPLState -> InputT IO ()
- handleRefresh state = case replContentStore state of
- Nothing -> do
- outputStrLn "Content store not initialized"
- loop state
- Just _conn -> do
- outputStrLn "Environment refreshed from content store (definitions are live)"
- loop state
-
- handleVersions :: REPLState -> InputT IO ()
- handleVersions state = case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- liftIO $ printPrompt "Term name: "
- nameInput <- getInputLine ""
- case nameInput of
- Nothing -> loop state
- Just n -> do
- let termName = strip n
- versions <- liftIO $ ContentStore.termVersions conn termName
- if null versions
- then liftIO $ printError $ "No versions found for term: " ++ termName
- else do
- liftIO $ do
- printKeyword "Versions of "
- printVariable termName
- putStrLn ":"
-
- forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
- tags <- ContentStore.termToTags conn hash
- putStr $ show (i :: Int) ++ ". "
- displayColoredHash hash
- putStr $ " (" ++ formatTimestamp ts ++ ")"
- unless (null tags) $ do
- putStr " ["
- printKeyword "Tags: "
- forM_ (zip [0..] tags) $ \(j, tag) -> do
- printTag (T.unpack tag)
- when (j < length tags - 1) $ putStr ", "
- putStr "]"
- putStrLn ""
- loop state
-
- handleSelect :: REPLState -> InputT IO ()
- handleSelect state = case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- liftIO $ printPrompt "Term name: "
- nameInput <- getInputLine ""
- case nameInput of
- Nothing -> loop state
- Just n -> do
- let cleanName = strip n
- versions <- liftIO $ ContentStore.termVersions conn cleanName
- if null versions
- then do
- liftIO $ printError $ "No versions found for term: " ++ cleanName
- loop state
- else do
- liftIO $ do
- printKeyword "Versions of "
- printVariable cleanName
- putStrLn ":"
-
- forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
- tags <- ContentStore.termToTags conn hash
- putStr $ show (i :: Int) ++ ". "
- displayColoredHash hash
- putStr $ " (" ++ formatTimestamp ts ++ ")"
- unless (null tags) $ do
- putStr " ["
- printKeyword "Tags: "
- forM_ (zip [0..] tags) $ \(j, tag) -> do
- printTag (T.unpack tag)
- when (j < length tags - 1) $ putStr ", "
- putStr "]"
- putStrLn ""
-
- liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): "
- choiceInput <- getInputLine ""
- let choice = strip <$> choiceInput
-
- selectedHash <- case choice of
- Just selectedStr | not (null selectedStr) -> do
- case readMaybe selectedStr :: Maybe Int of
- Just idx | idx > 0 && idx <= length versions -> do
- let (h, _, _) = versions !! (idx - 1)
- return $ Just h
- _ -> do
- let potentialHash = T.pack selectedStr
- let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions
- case foundByHash of
- Just (h, _, _) -> return $ Just h
- Nothing -> do
- liftIO $ printError "Invalid selection or hash not found in list."
- return Nothing
- _ -> return Nothing
-
- case selectedHash of
- Just hashToSelect -> do
- let newState = state { replSelectedVersions =
- Map.insert cleanName hashToSelect (replSelectedVersions state) }
- liftIO $ do
- printSuccess "Selected version "
- displayColoredHash hashToSelect
- putStr " for term "
- printVariable cleanName
- putStrLn ""
- loop newState
- Nothing -> loop state
-
- handleTag :: REPLState -> InputT IO ()
- handleTag state = case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): "
- identInput <- getInputLine ""
- case identInput of
- Nothing -> loop state
- Just ident -> do
- let cleanIdent = strip ident
-
- mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent
-
- case mFullHash of
- Nothing -> do
- liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent
- loop state
- Just fullHash -> do
- liftIO $ do
- putStr "Tagging term with hash: "
- displayColoredHash fullHash
- putStrLn ""
- tags <- liftIO $ ContentStore.termToTags conn fullHash
- unless (null tags) $ do
- liftIO $ do
- printKeyword "Existing tags:"
- displayTags tags
-
- liftIO $ printPrompt "Tag to add/set: "
- tagValueInput <- getInputLine ""
- case tagValueInput of
- Nothing -> loop state
- Just tv -> do
- let tagVal = T.pack (strip tv)
- liftIO $ do
- ContentStore.setTag conn fullHash tagVal
- printSuccess $ "Tag '"
- printTag (T.unpack tagVal)
- putStr "' set for term with hash "
- displayColoredHash fullHash
- putStrLn ""
- loop state
-
- resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text)
- resolveIdentifierToHash conn ident
- | T.pack "#" `T.isInfixOf` T.pack ident = do
- let hashPrefix = T.pack ident
- matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text]
- case matchingHashes of
- [Only fullHash] -> return $ Just fullHash
- [] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing
- _ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing
- | otherwise = do
- versions <- ContentStore.termVersions conn ident
- if null versions
- then do printError $ "No versions found for term name: " ++ ident; return Nothing
- else return $ Just $ (\(h,_,_) -> h) $ head versions
+ | otherwise = do
+ outputStrLn $ "Store changed to: " ++ path
+ loop state { replStore = StorePath path }
+
+ handleUnchecked :: REPLState -> String -> InputT IO ()
+ handleUnchecked state arg = setUnchecked state arg
+
+ setUnchecked :: REPLState -> String -> InputT IO ()
+ setUnchecked state arg = case arg of
+ "" -> reportContracts state >> loop state
+ "on" -> setMode IgnoreContracts
+ "off" -> setMode EnforceContracts
+ _ -> outputStrLn "Usage: !unchecked [on|off]" >> loop state
+ where
+ setMode mode = do
+ outputStrLn $ contractModeMessage mode
+ loop state { replContracts = mode }
- handleExport :: REPLState -> InputT IO ()
- handleExport state = do
- let fset = setComplete completeFilename defaultSettings
- hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
- case hashInput of
- Nothing -> loop state
- Just hashStr -> do
- fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
- case fileInput of
- Nothing -> loop state
- Just outFile -> case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- let cleanHash = strip hashStr
- hash <- liftIO $ do
- let h = T.pack cleanHash
- if '#' `T.elem` h
- then return h
- else do
- results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
- (Only (h <> "%")) :: IO [Only T.Text]
- case results of
- [Only fullHash] -> return fullHash
- [] -> do
- results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
- (Only (h <> "%")) :: IO [Only T.Text]
- case results2 of
- [Only fullHash] -> return fullHash
- _ -> do
- printError $ "No term found matching: " ++ cleanHash
- return h
- _ -> do
- printError $ "Ambiguous match for: " ++ cleanHash
- return h
- maybeTree <- liftIO $ loadTree conn hash
- case maybeTree of
- Nothing -> do
- liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
- loop state
- Just tree -> do
- let bundle = buildBundle [(T.pack "root", tree)]
- bundleData = encodeBundle bundle
- liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
- liftIO $ do
- printSuccess $ "Exported bundle with root "
- displayColoredHash hash
- putStrLn $ " to " ++ outFile
- loop state
+ reportContracts :: REPLState -> InputT IO ()
+ reportContracts state = outputStrLn $ contractModeMessage (replContracts state)
- handleBundleImport :: REPLState -> InputT IO ()
- handleBundleImport state = do
- let fset = setComplete completeFilename defaultSettings
- fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
- case fileInput of
- Nothing -> loop state
- Just inFile -> case replContentStore state of
- Nothing -> do
- liftIO $ printError "Content store not initialized"
- loop state
- Just conn -> do
- exists <- liftIO $ doesFileExist inFile
- if not exists
- then do
- liftIO $ printError $ "File not found: " ++ inFile
- loop state
- else do
- bundleData <- liftIO $ BL.readFile inFile
- roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
- liftIO $ do
- printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
- mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
- loop state
+ handleEnv :: REPLState -> InputT IO ()
+ handleEnv state =
+ case sort (Map.keys (replEnv state)) of
+ [] -> outputStrLn "Environment is empty"
+ names -> mapM_ outputStrLn names
- interruptHandler :: REPLState -> Interrupt -> InputT IO ()
- interruptHandler state _ = do
- liftIO $ do
- printWarning "Interrupted with CTRL+C"
- printWarning "You can use the !exit command or CTRL+D to exit"
- loop state
+ processInput :: REPLState -> String -> IO REPLState
+ processInput state input = do
+ let env' = evalTricu (replEnv state) (parseTricu input)
+ writeIORef (replEnvRef state) env'
+ putStrLn $ formatT (replForm state) (result env')
+ return state { replEnv = env' }
errorHandler :: REPLState -> SomeException -> IO REPLState
errorHandler state e = do
- printError $ "Error: " ++ displayException e
+ putStrLn $ "Error: " ++ displayException e
return state
- processInput :: REPLState -> String -> IO REPLState
- processInput state input = do
- let asts = parseTricu input
- case asts of
- [] -> return state
- _ -> case replContentStore state of
- Nothing -> do
- printError "Content store not initialized"
- return state
- Just conn -> do
- newState <- foldM (\s astNode -> do
- let varsInAst = Eval.findVarNames astNode
- foldM (\currentSelectionState varName ->
- if Map.member varName (replSelectedVersions currentSelectionState)
- then return currentSelectionState
- else do
- versions <- ContentStore.termVersions conn varName
- if length versions > 1
- then do
- let (latestHash, _, _) = head versions
- liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent."
- return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) }
- else return currentSelectionState
- ) s varsInAst
- ) state asts
-
- forM_ asts $ \ast -> do
- case ast of
- SDef name [] body -> do
- evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
- hash <- ContentStore.storeTerm conn [name] evalResult
-
- liftIO $ do
- putStr "tricu > "
- printSuccess "Stored definition: "
- printVariable name
- putStr " with hash "
- displayColoredHash hash
- putStrLn ""
-
- putStr "tricu > "
- printResult $ formatT (replForm newState) evalResult
- putStrLn ""
-
- _ -> do
- evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
- liftIO $ do
- putStr "tricu > "
- printResult $ formatT (replForm newState) evalResult
- putStrLn ""
- return newState
-
- strip :: String -> String
- strip = dropWhileEnd isSpace . dropWhile isSpace
-
- watchLoop :: REPLState -> InputT IO ()
- watchLoop state = handle (\Interrupt -> do
- outputStrLn "\nStopped watching file"
- when (isJust (replWatcherThread state)) $ do
- liftIO $ killThread (fromJust $ replWatcherThread state)
- loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
- liftIO $ threadDelay 1000000
- watchLoop state
-
- processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
- processWatchedFile filepath mconn selectedVersions outputForm = do
- content <- readFile filepath
- let asts = parseTricu content
-
- case mconn of
- Nothing -> putStrLn "Content store not initialized for watched file processing."
- Just conn -> do
- forM_ asts $ \ast -> case ast of
- SDef name [] body -> do
- evalResult <- evalAST (Just conn) selectedVersions body
- hash <- ContentStore.storeTerm conn [name] evalResult
- putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
- putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
- _ -> do
- evalResult <- evalAST (Just conn) selectedVersions ast
- putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
- putStrLn $ "tricu > Processed file: " ++ filepath
-
- formatTimestamp :: Integer -> String
- formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
-
- displayColoredHash :: T.Text -> IO ()
- displayColoredHash hash = do
- let (prefix, rest) = T.splitAt 16 hash
- setSGR [SetColor Foreground Vivid Cyan]
- putStr $ T.unpack prefix
- setSGR [SetColor Foreground Dull White]
- putStr $ T.unpack rest
- setSGR [Reset]
-
- withColor :: ColorIntensity -> Color -> IO () -> IO ()
- withColor intensity color action = do
- setSGR [SetColor Foreground intensity color]
- action
- setSGR [Reset]
-
- printColored :: ColorIntensity -> Color -> String -> IO ()
- printColored intensity color text = withColor intensity color $ putStr text
-
- printlnColored :: ColorIntensity -> Color -> String -> IO ()
- printlnColored intensity color text = withColor intensity color $ putStrLn text
-
- printSuccess :: String -> IO ()
- printSuccess = printlnColored Vivid Green
-
- printError :: String -> IO ()
- printError = printlnColored Vivid Red
-
- printWarning :: String -> IO ()
- printWarning = printlnColored Vivid Yellow
-
- printPrompt :: String -> IO ()
- printPrompt = printColored Vivid Blue
-
- printVariable :: String -> IO ()
- printVariable = printColored Vivid Magenta
-
- printTag :: String -> IO ()
- printTag = printColored Vivid Yellow
-
- printKeyword :: String -> IO ()
- printKeyword = printColored Vivid Blue
-
- printResult :: String -> IO ()
- printResult = printColored Dull White
-
- displayTags :: [T.Text] -> IO ()
- displayTags [] = return ()
- displayTags tags = do
- putStr " Tags: "
- forM_ (zip [0..] tags) $ \(i, tag) -> do
- printTag (T.unpack tag)
- when (i < length tags - 1) $ putStr ", "
- putStrLn ""
+completeRepl :: IORef Env -> CompletionFunc IO
+completeRepl envRef input@(left, _right)
+ | commandWantsFile line = completeFilename input
+ | "!" `isPrefixOf` line = completeWord Nothing " \t" completeCommands input
+ | otherwise = completeWord Nothing termBreakChars completeTerms input
+ where
+ line = reverse left
+ completeCommands str = return $ map simpleCompletion $
+ filter (str `isPrefixOf`) commands
+ completeTerms str = do
+ env <- readIORef envRef
+ return $ map simpleCompletion $
+ filter (str `isPrefixOf`) (sort $ Map.keys env)
+ commands =
+ [ "!exit"
+ , "!output"
+ , "!format"
+ , "!clear"
+ , "!reset"
+ , "!help"
+ , "!load"
+ , "!check"
+ , "!store"
+ , "!unchecked"
+ , "!env"
+ ]
+ commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "]
+ termBreakChars = " \t\n\r()[]{}\"'"
+
+outputFormats :: [EvaluatedForm]
+outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
+
+readEvaluatedForm :: String -> Maybe EvaluatedForm
+readEvaluatedForm s = case s of
+ "tree" -> Just Tree
+ "fsl" -> Just FSL
+ "ast" -> Just AST
+ "ternary" -> Just Ternary
+ "ascii" -> Just Ascii
+ "decode" -> Just Decode
+ "number" -> Just Number
+ "string" -> Just StringLit
+ _ -> Nothing
+
+contractModeMessage :: ContractMode -> String
+contractModeMessage EnforceContracts = "Contracts: on"
+contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
+
+storePathString :: StorePath -> FilePath
+storePathString (StorePath path) = path
+
+strip :: String -> String
+strip = f . f
+ where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
+
+readMaybeInt :: String -> Maybe Int
+readMaybeInt s = case reads s of
+ [(n, "")] -> Just n
+ _ -> Nothing
diff --git a/src/Research.hs b/src/Research.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
module Research where
import Crypto.Hash (hash, SHA256, Digest)
@@ -17,6 +19,45 @@ import qualified Data.Text as T
data T = Leaf | Stem T | Fork T T
deriving (Show, Eq, Ord)
+-- View Contract source annotations
+data ViewRef
+ = ViewRefInt Integer
+ | ViewRefText String
+ deriving (Show, Eq, Ord)
+
+data ViewType
+ = VTName String
+ | VTRefRaw ViewRef
+ | VTList ViewType
+ | VTMaybe ViewType
+ | VTPair ViewType ViewType
+ | VTResult ViewType ViewType
+ | VTGuarded ViewType T
+ | VTFn [ViewType] ViewType
+ deriving (Show, Eq, Ord)
+
+pattern VTRef :: Integer -> ViewType
+pattern VTRef n = VTRefRaw (ViewRefInt n)
+
+pattern VTRefText :: String -> ViewType
+pattern VTRefText s = VTRefRaw (ViewRefText s)
+
+{-# COMPLETE VTName, VTRef, VTRefText, VTList, VTMaybe, VTPair, VTResult, VTGuarded, VTFn #-}
+
+data ViewExpr
+ = VEName String
+ | VEInt Integer
+ | VEString String
+ | VEList [ViewExpr]
+ | VEApp ViewExpr ViewExpr
+ | VERaw String
+ deriving (Show, Eq, Ord)
+
+data DefArg
+ = DefBinder String (Maybe ViewExpr)
+ | DefPhantom ViewExpr
+ deriving (Show, Eq, Ord)
+
-- Abstract Syntax Tree for tricu
data TricuAST
= SVar String (Maybe String)
@@ -24,6 +65,7 @@ data TricuAST
| SStr String
| SList [TricuAST]
| SDef String [String] TricuAST
+ | SDefAnn String [DefArg] (Maybe ViewExpr) TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem TricuAST
@@ -41,6 +83,8 @@ data LToken
| LNamespace String
| LImport String String
| LAssign
+ | LAssignAt
+ | LAt
| LColon
| LDot
| LOpenParen
@@ -65,7 +109,6 @@ type Env = Map.Map String T
-- Merkle DAG Node types
-- Each Tree Calculus node becomes a content-addressed object.
-
type MerkleHash = Text
data Node
diff --git a/src/Wire.hs b/src/Wire.hs
@@ -16,11 +16,10 @@ module Wire
, decodeBundle
, verifyBundle
, buildBundle
- , importBundle
+ , reconstructBundleTerms
, defaultExportNames
) where
-import ContentStore (storeTerm)
import Research hiding (Node)
import Control.Monad (foldM, forM_, unless, when)
@@ -41,7 +40,6 @@ import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Data.Word (Word16, Word32, Word64, Word8)
-import Database.SQLite.Simple (Connection)
import GHC.Generics (Generic)
import qualified Data.ByteString as BS
@@ -774,11 +772,11 @@ verifyManifestConstraints manifest = do
Left "manifest export has empty name"
-- ---------------------------------------------------------------------------
--- Import into content store
+-- Bundle reconstruction
-- ---------------------------------------------------------------------------
-reconstructTerms :: Seq BundleNode -> Vector T
-reconstructTerms nodes = V.create $ do
+reconstructBundleTerms :: Seq BundleNode -> Vector T
+reconstructBundleTerms nodes = V.create $ do
let n = Seq.length nodes
vec <- MV.new n
forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do
@@ -792,19 +790,6 @@ reconstructTerms nodes = V.create $ do
MV.write vec i t
return vec
-importBundle :: Connection -> ByteString -> IO [Text]
-importBundle conn bs = case decodeBundle bs of
- Left err -> error $ "Wire.importBundle: " ++ err
- Right bundle -> case verifyBundle bundle of
- Left err -> error $ "Wire.importBundle verify: " ++ err
- Right () -> do
- let terms = reconstructTerms (bundleNodes bundle)
- forM_ (manifestExports $ bundleManifest bundle) $ \exp -> do
- let term = terms V.! fromIntegral (exportRoot exp)
- _ <- storeTerm conn [T.unpack $ exportName exp] term
- return ()
- return $ map exportName $ manifestExports $ bundleManifest bundle
-
-- ---------------------------------------------------------------------------
-- Primitive binary helpers
-- ---------------------------------------------------------------------------
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,5 +1,6 @@
module Main where
+import Check
import Eval
import FileEval
import Lexer
@@ -8,17 +9,22 @@ import REPL
import Research
import Wire
import ContentStore
+import ContentStore.Bundle
+import Module.Manifest
+import Module.Resolver
import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
import Control.Exception (bracket, evaluate, try, SomeException)
+import System.IO.Unsafe (unsafePerformIO)
import qualified Network.Socket as NS
-import Control.Monad (forM_)
+import Control.Monad (forM, forM_)
import Control.Monad.IO.Class (liftIO)
import System.IO.Temp (withSystemTempDirectory)
-import System.Directory (createDirectory, doesFileExist, doesDirectoryExist)
+import System.Directory (createDirectory, doesFileExist, doesDirectoryExist, listDirectory)
+import System.FilePath ((</>))
import Data.Bits (xor)
import Data.Char (digitToInt)
-import Data.List (isInfixOf)
+import Data.List (find, isInfixOf)
import Data.Text (Text, unpack)
import Data.Word (Word8)
import Test.Tasty
@@ -26,11 +32,12 @@ import Test.Tasty.HUnit
import Text.Megaparsec (runParser)
import Data.ByteString (ByteString)
+import qualified Data.Foldable as Foldable
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
-import Database.SQLite.Simple (close, Connection)
+import qualified Data.Vector as V
main :: IO ()
main = defaultMain tests
@@ -38,6 +45,35 @@ main = defaultMain tests
tricuTestString :: String -> String
tricuTestString s = show $ result (evalTricu Map.empty $ parseTricu s)
+testStore :: StorePath
+testStore = StorePath "/tmp/tricu-test-store"
+{-# NOINLINE testStore #-}
+
+viewTestEnv :: Env
+viewTestEnv = unsafePerformIO (evaluateFileWithStore (Just testStore) "./lib/view.tri")
+{-# NOINLINE viewTestEnv #-}
+
+viewCatalogTestEnv :: Env
+viewCatalogTestEnv = unsafePerformIO $ do
+ catalog <- evaluateFileWithStore (Just testStore) "./lib/views/catalog.tri"
+ pure (Map.union viewTestEnv catalog)
+{-# NOINLINE viewCatalogTestEnv #-}
+
+allTestLibsEnv :: Env
+allTestLibsEnv = unsafePerformIO $ do
+ base <- evaluateFile "./lib/base.tri"
+ list <- evaluateFile "./lib/list.tri"
+ bytes <- evaluateFile "./lib/bytes.tri"
+ bin <- evaluateFile "./lib/binary.tri"
+ http <- evaluateFile "./lib/http.tri"
+ arbor <- evaluateFile "./lib/arboricx/arboricx.tri"
+ io <- evaluateFile "./lib/io.tri"
+ sock <- evaluateFile "./lib/socket.tri"
+ view <- evaluateFileWithStore (Just testStore) "./lib/view.tri"
+ catalog <- evaluateFileWithStore (Just testStore) "./lib/views/catalog.tri"
+ pure (Map.unions [base, list, bytes, bin, http, arbor, io, sock, view, catalog])
+{-# NOINLINE allTestLibsEnv #-}
+
tests :: TestTree
tests = testGroup "Tricu Tests"
[ lexer
@@ -47,18 +83,19 @@ tests = testGroup "Tricu Tests"
, providedLibraries
, maybeTests
, fileEval
- , modules
, demos
, decoding
--- , elimLambdaSingle
--- , stressElimLambda
--- , byteMarshallingTests
--- , wireTests
--- , tricuReaderTests
--- , byteListUtilities
--- , binaryParserTests
+ , elimLambdaSingle
+ , stressElimLambda
+ , byteMarshallingTests
+ , wireTests
+ , tricuReaderTests
+ , byteListUtilities
+ , binaryParserTests
, httpParsingTests
--- , ioDriverTests
+ , contentStoreTests
+ , viewContractTests
+ , ioDriverTests
]
lexer :: TestTree
@@ -145,6 +182,19 @@ lexer = testGroup "Lexer Tests"
let input = "foo$bar = 1"
expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1]
runParser tricuLexer "" input @?= expect
+
+ , testCase "Lex @ and =@ as annotation tokens" $ do
+ let input = "f x@Bool =@String x"
+ expect = Right
+ [ LIdentifier "f"
+ , LIdentifier "x"
+ , LAt
+ , LIdentifier "Bool"
+ , LAssignAt
+ , LIdentifier "String"
+ , LIdentifier "x"
+ ]
+ runParser tricuLexer "" input @?= expect
]
parser :: TestTree
@@ -240,6 +290,50 @@ parser = testGroup "Parser Tests"
, testCase "Evaluate top-level definition arguments" $ do
tricuTestString "const a b = a\nconst 1 2" @?= "Fork (Stem Leaf) Leaf"
+ , testCase "Parse annotated definition binders" $ do
+ let input = "foo x@Bool xs@(List Bool) =@String x"
+ expect = SDefAnn
+ "foo"
+ [DefBinder "x" (Just (VEName "Bool")), DefBinder "xs" (Just (VEApp (VEName "List") (VEName "Bool")))]
+ (Just (VEName "String"))
+ (SVar "x" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse phantom tail annotations" $ do
+ let input = "foo x@Bool @(List Bool) =@String x"
+ expect = SDefAnn
+ "foo"
+ [DefBinder "x" (Just (VEName "Bool")), DefPhantom (VEApp (VEName "List") (VEName "Bool"))]
+ (Just (VEName "String"))
+ (SVar "x" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse pure phantom function annotation" $ do
+ let input = "foo @Bool @(Fn [Bool] String) =@Unit (x : x)"
+ expect = SDefAnn
+ "foo"
+ [DefPhantom (VEName "Bool"), DefPhantom (VEApp (VEApp (VEName "Fn") (VEList [VEName "Bool"])) (VEName "String"))]
+ (Just (VEName "Unit"))
+ (SLambda ["x"] (SVar "x" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Evaluate annotated definition as ordinary definition" $ do
+ tricuTestString "id x@Bool =@Bool x\nid t" @?= "Leaf"
+
+ , testCase "Reject named binders after phantom annotations" $ do
+ let tokens = lexTricu "foo @Bool x@Bool =@Bool x"
+ case parseSingleExpr tokens of
+ Left _ -> return ()
+ Right ast -> assertFailure $ "Expected parse failure, got " ++ show ast
+
+ , testCase "Unparenthesized annotation names remain ordinary aliases" $ do
+ let input = "foo x@List Bool =@Bool x"
+ expect = SDefAnn "foo"
+ [DefBinder "x" (Just (VEName "List")), DefBinder "Bool" Nothing]
+ (Just (VEName "Bool"))
+ (SVar "x" Nothing)
+ parseSingle input @?= expect
+
, testCase "Parse let expression" $ do
let input = "let x = t t in x"
expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf)
@@ -562,742 +656,620 @@ lambdas = testGroup "Lambda Evaluation Tests"
maybeTests :: TestTree
maybeTests = testGroup "Maybe Tests"
[ testCase "nothing is Leaf" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "just wraps value in Stem" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "just (t t)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem (Stem Leaf)
, testCase "matchMaybe on nothing returns default" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "matchMaybe \"empty\" (x : x) nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "empty"
, testCase "matchMaybe on just extracts value" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "matchMaybe \"empty\" (x : x) (just (t t))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem Leaf
, testCase "maybe applies f inside just" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybe 0 (x : succ x) (just 5)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 6
, testCase "maybe returns default on nothing" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybe 0 (x : succ x) nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "maybeMap transforms just value" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeMap (x : succ x) (just 3)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (ofNumber 4)
, testCase "maybeMap returns nothing on nothing" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeMap (x : succ x) nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "maybeBind flattens just" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeBind (just 3) (x : just (succ x))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (ofNumber 4)
, testCase "maybeBind returns nothing on nothing" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeBind nothing (x : just (succ x))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "maybeOr returns just value" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeOr 99 (just 5)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "maybeOr returns default on nothing" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybeOr 99 nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 99
, testCase "maybe? on just is true" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybe? (just t)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "maybe? on nothing is false" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "maybe? nothing"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
]
providedLibraries :: TestTree
providedLibraries = testGroup "Library Tests"
[ testCase "Triage test Leaf" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "test t"
- env = decodeResult $ result $ evalTricu library (parseTricu input)
+ env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= "\"Leaf\""
, testCase "Triage test (Stem Leaf)" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "test (t t)"
- env = decodeResult $ result $ evalTricu library (parseTricu input)
+ env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= "\"Stem\""
, testCase "Triage test (Fork Leaf Leaf)" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "test (t t t)"
- env = decodeResult $ result $ evalTricu library (parseTricu input)
+ env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= "\"Fork\""
, testCase "Boolean NOT: true" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "not? true"
- env = result $ evalTricu library (parseTricu input)
+ env = result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= Leaf
, testCase "Boolean NOT: false" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "not? false"
- env = result $ evalTricu library (parseTricu input)
+ env = result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= Stem Leaf
, testCase "Boolean AND TF" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t)"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FT" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t t)"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FF" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t)"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND TT" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t t)"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem Leaf
, testCase "List head" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "head [(t) (t t) (t t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Leaf
, testCase "List tail" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "head (tail (tail [(t) (t t) (t t t)]))"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "List map" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "Empty list check" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "emptyList? []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem Leaf
, testCase "Non-empty list check" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "not? (emptyList? [(1) (2) (3)])"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem Leaf
, testCase "Concatenate strings" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "append \"Hello, \" \"world!\""
- env = decodeResult $ result $ evalTricu library (parseTricu input)
+ env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
env @?= "\"Hello, world!\""
, testCase "Verifying Equality" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "equal? (t t t) (t t t)"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= Stem Leaf
, testCase "headMaybe on empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "headMaybe []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "headMaybe on non-empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "headMaybe [(t) (t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT Leaf
, testCase "lastMaybe on empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lastMaybe []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "lastMaybe on single element" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lastMaybe [(t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (Stem Leaf)
, testCase "lastMaybe on multi-element list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lastMaybe [(t) (t t) (t t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (Fork Leaf Leaf)
, testCase "nthMaybe first element" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "nthMaybe 0 [(t) (t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT Leaf
, testCase "nthMaybe middle element" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "nthMaybe 1 [(t) (t t) (t t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (Stem Leaf)
, testCase "nthMaybe out of bounds" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "nthMaybe 5 [(t) (t t)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "reverse empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "reverse []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "reverse non-empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "reverse [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 3, ofNumber 2, ofNumber 1]
, testCase "take 0 any list = empty" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "take 0 [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "take 2 [1,2,3] = [1,2]" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "take 2 [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 1, ofNumber 2]
, testCase "take overlong returns whole list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "take 5 [(1) (2)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 1, ofNumber 2]
, testCase "drop 0 any list = list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "drop 0 [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 1, ofNumber 2, ofNumber 3]
, testCase "drop 2 [1,2,3] = [3]" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "drop 2 [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 3]
, testCase "drop overlong returns empty" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "drop 5 [(1) (2)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "splitAt 0 [1,2] = pair [] [1,2]" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "splitAt 0 [(1) (2)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (ofList []) (ofList [ofNumber 1, ofNumber 2])
, testCase "splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "splitAt 2 [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [ofNumber 3])
, testCase "splitAt overlong = pair [1,2] []" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "splitAt 5 [(1) (2)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [])
, testCase "concatMap on empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "concatMap (x : [(x) (x)]) []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "concatMap doubles elements" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "concatMap (x : [(x) (x)]) [(1) (2)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 1, ofNumber 1, ofNumber 2, ofNumber 2]
, testCase "find on empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "find (x : equal? x 2) []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "find finds element" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "find (x : equal? x 2) [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (ofNumber 2)
, testCase "find missing element" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "find (x : equal? x 9) [(1) (2) (3)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "partition empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "partition (x : equal? x 2) []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (ofList []) (ofList [])
, testCase "partition splits list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "partition (x : lt? 2 x) [(1) (2) (3) (4)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (ofList [ofNumber 3, ofNumber 4]) (ofList [ofNumber 1, ofNumber 2])
, testCase "zipWith on empty lists" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "zipWith add [] []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "zipWith adds pairwise" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "zipWith add [(1) (2)] [(10) (20)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 11, ofNumber 22]
, testCase "zipWith truncates to shorter list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "zipWith add [(1) (2)] [(10)]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofNumber 11]
, testCase "strLength" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "strLength \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "strAppend" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "strAppend \"hello\" \" world\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "hello world"
, testCase "equal? equal strings" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "equal? \"abc\" \"abc\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "equal? different strings" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "equal? \"abc\" \"def\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "strEmpty? on empty" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "strEmpty? \"\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "strEmpty? on non-empty" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "strEmpty? \"a\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "startsWith? prefix matches" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "startsWith? \"he\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "startsWith? prefix too long" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "startsWith? \"hello\" \"he\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "startsWith? empty prefix" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "startsWith? \"\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "endsWith? suffix matches" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "endsWith? \"lo\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "endsWith? suffix too long" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "endsWith? \"hello\" \"lo\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "endsWith? empty suffix" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "endsWith? \"\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "contains? substring found" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "contains? \"ell\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "contains? substring missing" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "contains? \"xyz\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "contains? empty needle" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "contains? \"\" \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "lines splits on newline" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lines \"a\\nb\\nc\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString "a", ofString "b", ofString "c"]
, testCase "lines single line" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lines \"hello\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString "hello"]
, testCase "lines empty string" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lines \"\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString ""]
, testCase "lines trailing newline" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "lines \"a\\n\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString "a", ofString ""]
, testCase "unlines joins with newline" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "unlines [(\"a\") (\"b\")]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "a\nb\n"
, testCase "unlines empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "unlines []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString ""
, testCase "words splits on space" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "words \"hello world\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString "hello", ofString "world"]
, testCase "words empty string" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "words \"\""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList []
, testCase "words multiple spaces" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "words \" hello world \""
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList [ofString "hello", ofString "world"]
, testCase "unwords joins with space" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "unwords [(\"hello\") (\"world\")]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "hello world"
, testCase "unwords single word" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "unwords [(\"hello\")]"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "hello"
, testCase "unwords empty list" $ do
- library <- evaluateFile "./lib/list.tri"
let input = "unwords []"
- env = evalTricu library (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString ""
]
arithmeticTests :: TestTree
arithmeticTests = testGroup "Arithmetic Tests"
[ testCase "isZero? on 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "isZero? 0"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "isZero? on 5" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "isZero? 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "add 0 3 = 3" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "add 0 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 3
, testCase "add 3 0 = 3" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "add 3 0"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 3
, testCase "add 2 3 = 5" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "add 2 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "sub 5 2 = 3" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "sub 5 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 3
, testCase "sub 2 5 = 0 (saturated)" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "sub 2 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "sub 5 5 = 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "sub 5 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "lt? 2 3 = true" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lt? 2 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "lt? 3 2 = false" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lt? 3 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "lt? 2 2 = false" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lt? 2 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "lte? 2 3 = true" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lte? 2 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "lte? 3 2 = false" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lte? 3 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "lte? 2 2 = true" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lte? 2 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "mul 0 5 = 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 0 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "mul 5 0 = 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 5 0"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "mul 2 3 = 6" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 2 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 6
, testCase "mul 3 3 = 9" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 3 3"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 9
, testCase "pred 0 = 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "pred 0"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "pred 1 = 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "pred 1"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "pred 5 = 4" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "pred 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 4
, testCase "add is commutative" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "equal? (add 4 7) (add 7 4)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "add is associative" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "equal? (add (add 2 3) 4) (add 2 (add 3 4))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "sub x 0 = x" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "sub 7 0"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 7
, testCase "sub chained" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "sub (sub 10 3) 2"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "mul identity 1" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 1 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "mul identity 2" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 5 1"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 5
, testCase "mul is commutative" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "equal? (mul 3 4) (mul 4 3)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "mul is associative" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "equal? (mul (mul 2 3) 4) (mul 2 (mul 3 4))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "mul distributes over add" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "equal? (mul 2 (add 3 4)) (add (mul 2 3) (mul 2 4))"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "lt? reflexive is false" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lt? 5 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "lte? reflexive is true" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "lte? 5 5"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "lt? transitivity" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "and? (lt? 2 5) (lt? 5 7)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "add larger numbers" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "add 12 15"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 27
, testCase "mul larger numbers" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "mul 5 6"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 30
, testCase "isZero? on add 0 0" $ do
- base <- evaluateFile "./lib/base.tri"
let input = "isZero? (add 0 0)"
- env = evalTricu base (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
]
@@ -1312,54 +1284,14 @@ fileEval = testGroup "File evaluation tests"
res @?= Fork (Stem Leaf) Leaf
, testCase "Mapping and Equality" $ do
- library <- liftIO $ evaluateFile "./lib/list.tri"
- fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
+ fEnv <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/map.tri"
(mainResult fEnv) @?= Stem Leaf
, testCase "Eval and decoding string" $ do
- library <- liftIO $ evaluateFile "./lib/list.tri"
- res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
+ res <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
-modules :: TestTree
-modules = testGroup "Test modules"
- [ testCase "Detect cyclic dependencies" $ do
- result <- try (liftIO $ evaluateFileResult "./test/cycle-1.tri") :: IO (Either SomeException T)
- case result of
- Left e -> do
- let errorMsg = show e
- if "Encountered cyclic import" `isInfixOf` errorMsg
- then return ()
- else assertFailure $ "Unexpected error: " ++ errorMsg
- Right _ -> assertFailure "Expected cyclic dependencies"
- , testCase "Module imports and namespacing" $ do
- res <- liftIO $ evaluateFileResult "./test/namespace-A.tri"
- res @?= Leaf
- , testCase "Multiple imports" $ do
- res <- liftIO $ evaluateFileResult "./test/vars-A.tri"
- res @?= Leaf
- , testCase "Error on unresolved variable" $ do
- result <- try (liftIO $ evaluateFileResult "./test/unresolved-A.tri") :: IO (Either SomeException T)
- case result of
- Left e -> do
- let errorMsg = show e
- if "undefinedVar" `isInfixOf` errorMsg
- then return ()
- else assertFailure $ "Unexpected error: " ++ errorMsg
- Right _ -> assertFailure "Expected unresolved variable error"
- , testCase "Multi-level imports" $ do
- res <- liftIO $ evaluateFileResult "./test/multi-level-A.tri"
- res @?= Leaf
- , testCase "Lambda expression namespaces" $ do
- res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
- res @?= Leaf
- , testCase "Local namespace import chain" $ do
- res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
- res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
- ]
-
-
-- All of our demo tests are also module tests
demos :: TestTree
demos = testGroup "Test provided demo functionality"
@@ -1575,6 +1507,486 @@ byteMarshallingTests = testGroup "Byte Marshalling Tests"
]
-- --------------------------------------------------------------------------
+-- Content store tests
+-- --------------------------------------------------------------------------
+
+contentStoreTests :: TestTree
+contentStoreTests = testGroup "Content Store Tests"
+ [ testCase "Filesystem CAS: put/get object and sharded path" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ domain = Domain "test.object.v1"
+ payload = BS.pack [1, 2, 3, 4]
+ h <- putObject store domain payload
+ shardForHash h @?= take 3 (unpack h)
+ objectPath store h @?= dir </> "objects" </> take 3 (unpack h) </> unpack h
+ doesFileExist (objectPath store h) >>= (@?= True)
+ getObject store h >>= (@?= Just payload)
+
+ , testCase "Filesystem CAS: idempotent object writes" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ domain = Domain "test.object.v1"
+ payload = BS.pack [9, 8, 7]
+ h1 <- putObject store domain payload
+ h2 <- putObject store domain payload
+ h1 @?= h2
+ countStoredObjects store >>= (@?= 1)
+
+ , testCase "Filesystem CAS: putTree/getTree round trip" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ term = Fork (Stem Leaf) (Fork Leaf (Stem Leaf))
+ leafHash = nodeHash NLeaf
+ stemHash = nodeHash (NStem leafHash)
+ rightHash = nodeHash (NFork leafHash stemHash)
+ expectedRoot = nodeHash (NFork stemHash rightHash)
+ root <- putTree store term
+ root @?= expectedRoot
+ getTree store root >>= (@?= Just term)
+
+ , testCase "Filesystem CAS: shared subtrees are deduplicated" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ shared = Stem Leaf
+ term = Fork shared shared
+ _ <- putTree store term
+ countStoredObjects store >>= (@?= 3)
+
+ , testCase "Workspace aliases: write/read/list object refs" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ ref = ObjectRef "arboricx.tree-root.v1" "abc123"
+ writeAlias store NameAlias "main" ref
+ readAlias store NameAlias "main" >>= (@?= Just ref)
+ listAliases store NameAlias >>= (@?= [("main", ref)])
+
+ , testCase "Module manifests: deterministic encoding and hash" $ do
+ let manifest = ModuleManifest
+ [ ModuleReference "base" (ObjectRef (unDomain manifestDomain) "111") ]
+ [ ModuleExport
+ "main"
+ (ObjectRef (unDomain treeTermDomain) "222")
+ "arboricx.abi.tree.v1"
+ (Just (ObjectRef viewContractTypeKind "333"))
+ ]
+ encoded = encodeManifest manifest
+ decodeManifest encoded @?= Right manifest
+ hashObject manifestDomain encoded @?= "7c3cb85454744894a403d2d12c7ece6d391c0cfbeb4bf3adfc7e69ae70ec4f5c"
+
+ , testCase "View Contract type artifacts: encode/decode round trip" $ do
+ let view = VTFn [VTList (VTName "String"), VTPair (VTName "Byte") (VTMaybe (VTRef 7))]
+ (VTResult (VTName "Byte") (VTName "Bool"))
+ decodeViewType (encodeViewType view) @?= Right view
+
+ , testCase "View Contract type artifacts: encode/decode string refs" $ do
+ let view = VTFn [VTRefText "Nat"] (VTPair (VTRefText "Box") (VTName "String"))
+ decodeViewType (encodeViewType view) @?= Right view
+
+ , testCase "View Contract type artifacts: encode/decode guarded views with opaque guard trees" $ do
+ let guardTree = Fork (Stem Leaf) Leaf
+ view = VTGuarded (VTRefText "UserId") guardTree
+ decodeViewType (encodeViewType view) @?= Right view
+
+ , testCase "View-tree artifacts: encode/decode and put/get through CAS" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ viewTree = Fork (Stem Leaf) (Fork Leaf (Stem Leaf))
+ decodeViewTree (encodeViewTree viewTree) @?= Right viewTree
+ ref <- putViewTree store viewTree
+ objectRefKind ref @?= viewTreeKind
+ getViewTree store ref >>= (@?= Right viewTree)
+
+ , testCase "View Contract type artifacts: put/get through CAS" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ view = VTFn [VTName "Bool"] (VTName "String")
+ ref <- putViewType store view
+ objectRefKind ref @?= viewContractTypeKind
+ getViewType store ref >>= (@?= Right view)
+
+ , testCase "Module manifests: put/get round trip through CAS" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ term = Fork Leaf (Stem Leaf)
+ manifestFor root = ModuleManifest []
+ [ ModuleExport
+ "main"
+ (ObjectRef (unDomain treeTermDomain) root)
+ "arboricx.abi.tree.v1"
+ Nothing
+ ]
+ root <- putTreeTerm store term
+ h <- putManifest store (manifestFor root)
+ getManifest store h >>= (@?= Just (manifestFor root))
+
+ , testCase "ObjectResolver: resolves manifests and trees without filesystem coupling" $ do
+ let term = Fork Leaf (Stem Leaf)
+ leafH = nodeHash NLeaf
+ stemH = nodeHash (NStem leafH)
+ rootH = nodeHash (NFork leafH stemH)
+ termH = hashObject treeTermDomain (encodeTreeTerm term)
+ manifest = ModuleManifest []
+ [ ModuleExport
+ "value"
+ (ObjectRef (unDomain treeTermDomain) termH)
+ "arboricx.abi.tree.v1"
+ Nothing
+ ]
+ manifestBytes = encodeManifest manifest
+ manifestH = hashObject manifestDomain manifestBytes
+ objects = Map.fromList
+ [ (("arboricx.merkle.node.v1", leafH), serializeNode NLeaf)
+ , (("arboricx.merkle.node.v1", stemH), serializeNode (NStem leafH))
+ , (("arboricx.merkle.node.v1", rootH), serializeNode (NFork leafH stemH))
+ , ((unDomain treeTermDomain, termH), encodeTreeTerm term)
+ , ((unDomain manifestDomain, manifestH), manifestBytes)
+ ]
+ hydrate objs h = case deserializeNode <$> Map.lookup ("arboricx.merkle.node.v1", h) objs of
+ Nothing -> return Nothing
+ Just NLeaf -> return (Just Leaf)
+ Just (NStem child) -> fmap Stem <$> hydrate objs child
+ Just (NFork left right) -> do
+ l <- hydrate objs left
+ r <- hydrate objs right
+ return $ Fork <$> l <*> r
+ resolver = ObjectResolver
+ { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
+ then Just (ObjectRef (unDomain manifestDomain) manifestH)
+ else Nothing
+ , resolverObject = \ref -> return $ Map.lookup (objectRefKind ref, objectRefHash ref) objects
+ , resolverManifest = \h -> return $ do
+ bytes <- Map.lookup (unDomain manifestDomain, h) objects
+ either (const Nothing) Just (decodeManifest bytes)
+ , resolverTree = hydrate objects
+ }
+ resolverAlias resolver ModuleAlias "demo" >>= (@?= Just (ObjectRef (unDomain manifestDomain) manifestH))
+ resolveManifest resolver manifestH >>= (@?= Just manifest)
+ resolveTree resolver rootH >>= (@?= Just term)
+
+ , testCase "Workspace modules: auto-build source module into manifest" $
+ withSystemTempDirectory "tricu-workspace-module" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "value = t t\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.value\n"
+ env <- evaluateFileWithStore (Just store) mainPath
+ result env @?= Stem Leaf
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected workspace build to write util module alias"
+ Just ref -> do
+ objectRefKind ref @?= unDomain manifestDomain
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected workspace module manifest"
+ Just manifest -> case moduleManifestExports manifest of
+ [ex] -> do
+ objectRefKind (moduleExportObject ex) @?= viewTreeKind
+ loaded <- getViewTree store (moduleExportObject ex)
+ (loaded >>= viewTreeRootTerm) @?= Right (Stem Leaf)
+ other -> assertFailure $ "unexpected exports: " ++ show other
+
+ , testCase "Workspace modules: attach direct View Contract type artifacts to annotated exports" $
+ withSystemTempDirectory "tricu-workspace-export-views" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "id x@Bool =@Bool x\nplain = t\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.id t\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected workspace build to write util module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected workspace module manifest"
+ Just manifest -> do
+ let exports = moduleManifestExports manifest
+ viewFor name = moduleExportView =<< findExport name exports
+ map moduleExportName exports @?= ["id", "plain"]
+ map (objectRefKind . moduleExportObject) exports @?= [viewTreeKind, viewTreeKind]
+ map moduleExportAbi exports @?= ["arboricx.abi.view-tree.v1", "arboricx.abi.view-tree.v1"]
+ case viewFor "id" of
+ Nothing -> assertFailure "expected annotated export view ref"
+ Just viewRef -> do
+ objectRefKind viewRef @?= viewContractTypeKind
+ getViewType store viewRef >>= (@?= Right (VTFn [VTRef 0] (VTRef 0)))
+ viewFor "plain" @?= Nothing
+
+ , testCase "Workspace module checks: consumer imports use producer-checked view refs" $
+ withSystemTempDirectory "tricu-workspace-consumer-check-ok" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "id x@Bool =@Bool x\n"
+ writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.id x\n"
+ output <- checkFileWithStore store mainPath
+ output @?= "ok"
+
+ , testCase "Workspace module checks: consumer mismatches are judged from imported view refs" $
+ withSystemTempDirectory "tricu-workspace-consumer-check-fail" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "toString x@Bool =@String \"ok\"\n"
+ writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.toString x\n"
+ output <- checkFileWithStore store mainPath
+ output @?= "symbol 3 (Util.toString application result) expected Bool but got String"
+
+ , testCase "Workspace module checks: producer checks use imported view refs" $
+ withSystemTempDirectory "tricu-workspace-producer-import-view-ok" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ depPath = dir </> "dep.tri"
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n"
+ writeFile depPath "id x@Bool =@Bool x\n"
+ writeFile libPath "!import \"dep\" Dep\n\nuseId x@Bool =@Bool Dep.id x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.useId t\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected producer-checked util module alias"
+ Just ref -> do
+ Just manifest <- getManifest store (objectRefHash ref)
+ case moduleExportView =<< findExport "useId" (moduleManifestExports manifest) of
+ Nothing -> assertFailure "expected imported-view-checked export view"
+ Just viewRef -> getViewType store viewRef >>= (@?= Right (VTFn [VTRef 0] (VTRef 0)))
+
+ , testCase "Workspace module checks: producer rejects mismatches against imported view refs" $
+ withSystemTempDirectory "tricu-workspace-producer-import-view-fail" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ depPath = dir </> "dep.tri"
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n"
+ writeFile depPath "toString x@Bool =@String \"ok\"\n"
+ writeFile libPath "!import \"dep\" Dep\n\nuseString x@Bool =@Bool Dep.toString x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.useString t\n"
+ outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env)
+ case outcome of
+ Right _ -> assertFailure "expected producer-side imported view mismatch"
+ Left err -> show err `containsAll`
+ [ "Workspace module"
+ , "util"
+ , "failed View Contract check"
+ , "Dep.toString application result"
+ , "expected Bool but got String"
+ ]
+ mDepAlias <- readAlias store ModuleAlias "dep"
+ case mDepAlias of
+ Nothing -> assertFailure "expected dependency alias to be published"
+ Just _ -> pure ()
+ readAlias store ModuleAlias "util" >>= (@?= Nothing)
+
+ , testCase "Workspace module checks: imported exports without views remain checker-policy failures" $
+ withSystemTempDirectory "tricu-workspace-consumer-check-missing-view" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "plain = t\n"
+ writeFile mainPath "!import \"util\" Util\n\nfoo =@Bool Util.plain\n"
+ output <- checkFileWithStore store mainPath
+ output @?= "symbol 1 (external Util.plain) expected Bool but got Any"
+
+ , testCase "Workspace module checks: invalid imported view artifacts report artifact diagnostics" $
+ withSystemTempDirectory "tricu-workspace-consumer-check-invalid-view" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "id x@Bool =@Bool x\n"
+ writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.id x\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ Just aliasRef <- readAlias store ModuleAlias "util"
+ Just manifest <- getManifest store (objectRefHash aliasRef)
+ let corruptRef = ObjectRef "not-a-view-contract-type.v1" "badbad"
+ corruptExport ex = ex { moduleExportView = Just corruptRef }
+ corruptManifest = manifest { moduleManifestExports = map corruptExport (moduleManifestExports manifest) }
+ corruptHash <- putManifest store corruptManifest
+ writeAlias store ModuleAlias "util" (ObjectRef (unDomain manifestDomain) corruptHash)
+ outcome <- try (checkFileWithStore store mainPath) :: IO (Either SomeException String)
+ case outcome of
+ Right _ -> assertFailure "expected invalid imported view artifact failure"
+ Left err -> show err `containsAll`
+ [ "View Contract artifact invalid"
+ , "Util.id"
+ , "not-a-view-contract-type.v1"
+ , "badbad"
+ , "unsupported View Contract type object kind"
+ ]
+
+ , testCase "Workspace modules: reject annotated exports that fail producer-side View Contract checks" $
+ withSystemTempDirectory "tricu-workspace-bad-export-view" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "bad x@String =@Bool x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.bad\n"
+ outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env)
+ case outcome of
+ Right _ -> assertFailure "expected producer-side View Contract failure"
+ Left err -> show err `containsAll`
+ [ "Workspace module"
+ , "util"
+ , "failed View Contract check"
+ , "expected Bool but got String"
+ ]
+ readAlias store ModuleAlias "util" >>= (@?= Nothing)
+
+ , testCase "Unchecked workspace eval ignores bad annotations and publishes no view refs" $
+ withSystemTempDirectory "tricu-workspace-unchecked-bad-export-view" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile libPath "bad x@String =@Bool x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.bad \"hi\"\n"
+ env <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty mainPath
+ toString (mainResult env) @?= Right "hi"
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected unchecked eval to publish executable module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected unchecked module manifest"
+ Just manifest -> case moduleManifestExports manifest of
+ [ex] -> moduleExportView ex @?= Nothing
+ other -> assertFailure $ "unexpected exports: " ++ show other
+
+ , testCase "Workspace modules: exported names are local top-level definitions only" $
+ withSystemTempDirectory "tricu-workspace-local-exports" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ depPath = dir </> "dep.tri"
+ libPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n"
+ writeFile depPath "helper = t t\n"
+ writeFile libPath "!import \"dep\" !Local\n\nvalue = helper\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.value\n"
+ env <- evaluateFileWithStore (Just store) mainPath
+ result env @?= Stem Leaf
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected workspace build to write util module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected workspace module manifest"
+ Just manifest -> map moduleExportName (moduleManifestExports manifest) @?= ["value"]
+
+ , testCase "Module imports: resolve manifest exports from store" $
+ withSystemTempDirectory "tricu-module-import" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ sourcePath = dir </> "consumer.tri"
+ term = Fork Leaf (Stem Leaf)
+ manifestFor root = ModuleManifest []
+ [ ModuleExport
+ "value"
+ (ObjectRef (unDomain treeTermDomain) root)
+ "arboricx.abi.tree.v1"
+ Nothing
+ ]
+ root <- putTreeTerm store term
+ manifestHash <- putManifest store (manifestFor root)
+ writeAlias store ModuleAlias "demo" (ObjectRef (unDomain manifestDomain) manifestHash)
+ writeFile sourcePath "!import \"demo\" Demo\n\nmain = Demo.value\n"
+ env <- evaluateFileWithStore (Just store) sourcePath
+ result env @?= term
+
+ , testCase "Module resolver diagnostics: missing alias names workspace/module guidance" $ do
+ let resolver = filesystemResolver (StorePath "/tmp/tricu-test-missing-module-store")
+ outcome <- try (resolveModuleImport resolver "definitely-not-a-module" "Demo") :: IO (Either SomeException ResolvedModule)
+ case outcome of
+ Right _ -> assertFailure "expected missing module alias failure"
+ Left err -> show err `containsAll` ["Module alias not found", "definitely-not-a-module", "tricu.workspace", "ModuleAlias"]
+
+ , testCase "Module resolver diagnostics: alias kind mismatch names expected kind" $ do
+ let resolver = ObjectResolver
+ { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
+ then Just (ObjectRef "arboricx.tree-root.v1" "abc123")
+ else Nothing
+ , resolverObject = \_ -> return Nothing
+ , resolverManifest = \_ -> return Nothing
+ , resolverTree = \_ -> return Nothing
+ }
+ outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule)
+ case outcome of
+ Right _ -> assertFailure "expected alias kind mismatch failure"
+ Left err -> show err `containsAll` ["Module alias", "demo", "unsupported object kind", "arboricx.tree-root.v1", "arboricx.module-manifest.v1"]
+
+ , testCase "Module resolver diagnostics: missing tree term names export and hash" $ do
+ let root = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ manifest = ModuleManifest []
+ [ ModuleExport "value" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing ]
+ resolver = ObjectResolver
+ { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
+ then Just (ObjectRef (unDomain manifestDomain) "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb")
+ else Nothing
+ , resolverObject = \_ -> return Nothing
+ , resolverManifest = \_ -> return (Just manifest)
+ , resolverTree = \_ -> return Nothing
+ }
+ outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule)
+ case outcome of
+ Right _ -> assertFailure "expected missing tree term failure"
+ Left err -> show err `containsAll` ["Module export", "value", "missing tree term", unpack root]
+
+ , testCase "Arboricx bundle: unpack transport bundle into CAS tree terms" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ term = Fork (Stem Leaf) Leaf
+ bundle = buildBundle [("main", term)]
+ exports <- unpackBundleToStore store (encodeBundle bundle)
+ case exports of
+ [("main", root)] -> getTreeTerm store root >>= (@?= Just term)
+ other -> assertFailure $ "unexpected exports: " ++ show other
+
+ , testCase "Arboricx bundle: pack CAS tree terms into transport bundle" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let store = StorePath dir
+ term = Fork Leaf (Stem Leaf)
+ root <- putTreeTerm store term
+ bundle <- packBundleFromStore store [("main", root)]
+ bundleRoots bundle @?= [2]
+ let terms = reconstructBundleTermsForTest (bundleNodes bundle)
+ case manifestExports (bundleManifest bundle) of
+ [exported] -> do
+ exportName exported @?= "main"
+ terms V.! fromIntegral (exportRoot exported) @?= term
+ other -> assertFailure $ "unexpected exports: " ++ show other
+ ]
+
+reconstructBundleTermsForTest :: Seq.Seq BundleNode -> V.Vector T
+reconstructBundleTermsForTest nodes = V.fromList (go <$> Foldable.toList nodes)
+ where
+ built = V.fromList (go <$> Foldable.toList nodes)
+ go BNLeaf = Leaf
+ go (BNStem child) = Stem (built V.! fromIntegral child)
+ go (BNFork left right) = Fork (built V.! fromIntegral left) (built V.! fromIntegral right)
+
+findExport :: Text -> [ModuleExport] -> Maybe ModuleExport
+findExport name = find ((== name) . moduleExportName)
+
+countStoredObjects :: StorePath -> IO Int
+countStoredObjects store@(StorePath root) = do
+ ensureStore store
+ shards <- listDirectory (root </> "objects")
+ fmap sum $ forM shards $ \shard -> do
+ files <- listDirectory (root </> "objects" </> shard)
+ return (length files)
+
+-- --------------------------------------------------------------------------
-- Wire module tests
-- --------------------------------------------------------------------------
@@ -1676,16 +2088,16 @@ wireTests = testGroup "Wire Tests"
Left err -> assertBool ("Expected duplicate error, got: " ++ err) ("duplicate" `isInfixOf` err)
Right () -> assertFailure "Expected duplicate nodes to be rejected"
- , testCase "Indexed bundle: import into content store" $ do
- let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t"
- bundle = buildBundle [("validateEmail", term)]
- wireData = encodeBundle bundle
- dstConn <- newContentStore
- roots <- importBundle dstConn wireData
- roots @?= ["validateEmail"]
- loaded <- loadTerm dstConn "validateEmail"
- loaded @?= Just term
- close dstConn
+ , testCase "Indexed bundle: unpack into filesystem CAS" $
+ withSystemTempDirectory "tricu-store" $ \dir -> do
+ let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t"
+ bundle = buildBundle [("validateEmail", term)]
+ wireData = encodeBundle bundle
+ store = StorePath dir
+ roots <- unpackBundleToStore store wireData
+ case roots of
+ [("validateEmail", root)] -> getTree store root >>= (@?= Just term)
+ other -> assertFailure $ "unexpected roots: " ++ show other
, testCase "Indexed bundle: round-trip decode and verify" $ do
let term = result $ evalTricu Map.empty $ parseTricu "x = t\ny = t x\nz = t y\nmain = z"
@@ -1744,8 +2156,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
[ testCase "Tricu reader parses indexed bundle (id fixture)" $ do
bundleBytes <- BS.readFile "./test/fixtures/id.arboricx"
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
- let env = Map.insert "testBundle" bundleT readerEnv
+ let env = Map.insert "testBundle" bundleT allTestLibsEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
codeExpr = parseTricu "pairFirst (pairSecond (runArboricx testBundle t))"
@@ -1755,8 +2166,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
, testCase "Tricu reader parses indexed bundle (append fixture)" $ do
bundleBytes <- BS.readFile "./test/fixtures/append.arboricx"
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
- let env = Map.insert "testBundle" bundleT readerEnv
+ let env = Map.insert "testBundle" bundleT allTestLibsEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
tag @?= trueT
@@ -1765,8 +2175,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
forM_ ["true", "false"] $ \name -> do
bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
- let env = Map.insert "testBundle" bundleT readerEnv
+ let env = Map.insert "testBundle" bundleT allTestLibsEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
tag @?= trueT
@@ -1902,176 +2311,147 @@ byteListUtilities :: TestTree
byteListUtilities = testGroup "Byte List Utility Tests"
[ testCase "isNil: empty list is nil" $ do
let input = "bytesNil? []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "isNil: non-empty list is not nil" $ do
let input = "bytesNil? [(1)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "head: empty list is nothing" $ do
let input = "bytesHead []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "head: non-empty list returns first element" $ do
let input = "bytesHead [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (byteT 1)
, testCase "tail: empty list is nothing" $ do
let input = "bytesTail []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= nothingT
, testCase "tail: non-empty list returns rest" $ do
let input = "bytesTail [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= justT (bytesT [2])
, testCase "length: empty list is zero" $ do
let input = "bytesLength []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 0
, testCase "length: single element list is one" $ do
let input = "bytesLength [(1)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 1
, testCase "length: three element list is three" $ do
let input = "bytesLength [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofNumber 3
, testCase "append: empty ++ [1,2] = [1,2]" $ do
let input = "bytesAppend [] [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2]
, testCase "append: [1,2] ++ [3] = [1,2,3]" $ do
let input = "bytesAppend [(1) (2)] [(3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2,3]
, testCase "append: [1,2] ++ empty = [1,2]" $ do
let input = "bytesAppend [(1) (2)] []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2]
, testCase "take: take 0 any list = empty" $ do
let input = "bytesTake 0 [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT []
, testCase "take: take 2 [1,2,3] = [1,2]" $ do
let input = "bytesTake 2 [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2]
, testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do
let input = "bytesTake 5 [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2]
, testCase "drop: drop 0 any list = list" $ do
let input = "bytesDrop 0 [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [1,2,3]
, testCase "drop: drop 2 [1,2,3] = [3]" $ do
let input = "bytesDrop 2 [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [3]
, testCase "drop: drop 5 [1,2] = empty (overlong)" $ do
let input = "bytesDrop 5 [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT []
, testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do
let input = "bytesSplitAt 0 [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT []) (bytesT [1,2])
, testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
let input = "bytesSplitAt 2 [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT [1,2]) (bytesT [3])
, testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do
let input = "bytesSplitAt 5 [(1) (2)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT [1,2]) (bytesT [])
, testCase "byteEq: equal bytes are equal" $ do
let input = "equal? 1 1"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "byteEq: unequal bytes are not equal" $ do
let input = "equal? 1 2"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "bytesEq: empty == empty" $ do
let input = "bytesEq? [] []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "bytesEq: empty != [1]" $ do
let input = "bytesEq? [] [(1)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "bytesEq: [1] != empty" $ do
let input = "bytesEq? [(1)] []"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "bytesEq: equal lists are equal" $ do
let input = "bytesEq? [(1) (2) (3)] [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= trueT
, testCase "bytesEq: different last element" $ do
let input = "bytesEq? [(1) (2) (3)] [(1) (2) (4)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
, testCase "bytesEq: different lengths" $ do
let input = "bytesEq? [(1) (2)] [(1) (2) (3)]"
- library <- evaluateFile "./lib/bytes.tri"
- let env = evalTricu library (parseTricu input)
+ let env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= falseT
]
@@ -2088,116 +2468,880 @@ parserErr code rest = Fork falseT (Fork code rest)
binaryParserTests :: TestTree
binaryParserTests = testGroup "Binary Parser Tests"
[ testCase "pureParser succeeds" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "pureParser 42 [(1) (2)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 42) (bytesT [1, 2])
, testCase "failParser fails" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "failParser 99 [(1) (2)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 99) (bytesT [1, 2])
, testCase "mapParser transforms value" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "mapParser succ readU8 [(1) (2)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 2) (bytesT [2])
, testCase "bindParser chains parsers" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "bindParser readU8 (x : readU8) [(1) (2)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 2) (bytesT [])
, testCase "thenParser discards first result" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "thenParser readU8 readU8 [(1) (2)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 2) (bytesT [])
, testCase "orParser tries second on first failure" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "orParser (failParser 1) readU8 [(5)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 5) (bytesT [])
, testCase "orParser returns first on success" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "orParser readU8 (failParser 1) [(5)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 5) (bytesT [])
, testCase "readWhile consumes matching bytes" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "readWhile (x : lt? x 3) [(1) (2) (3) (4)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
, testCase "readWhile leaves non-matching byte" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "bindParser (readWhile (x : lt? x 3)) (x : readU8) [(1) (2) (3)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 3) (bytesT [])
, testCase "readUntil stops at matching byte" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "readUntil (x : equal? x 3) [(1) (2) (3) (4)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
, testCase "readRemaining returns all bytes" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "readRemaining [(1) (2) (3)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (bytesT [1, 2, 3]) (bytesT [])
, testCase "peekU8 does not consume" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "bindParser peekU8 (x : readU8) [(7) (8)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofNumber 7) (bytesT [8])
, testCase "peekU8 second read gets same byte" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "bindParser peekU8 (x : bindParser peekU8 (y : pureParser (pair x y))) [(7)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7])
, testCase "eof? succeeds at empty input" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "eof? []"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk Leaf (bytesT [])
, testCase "eof? fails on non-empty input" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "eof? [(1)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 1) (bytesT [1])
, testCase "expectAscii matches string" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "expectAscii \"hi\" [(104) (105) (106)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk Leaf (bytesT [106])
, testCase "expectAscii fails on mismatch" $ do
- lib <- evaluateFile "./lib/binary.tri"
let input = "expectAscii \"hi\" [(104) (99)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 2) (bytesT [104, 99])
]
-- --------------------------------------------------------------------------
+-- View Contract tests
+-- --------------------------------------------------------------------------
+
+viewContractTests :: TestTree
+viewContractTests = testGroup "View Contract Tests"
+ [ testCase "typedValue satisfies typedRequire" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(typedValue 0 (viewRef 10) t) (typedRequire 0 (viewRef 10) t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "typedApply infers result view from Fn" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 2 [(typedValue 0 (viewRef 10) t) (typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t) (typedRequire 2 (viewRef 10) t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "typedProgram carries abstract executable tree payloads" $ do
+ let input = unwords
+ [ "matchBool \"yes\" \"no\""
+ , "(and?"
+ , " (equal?"
+ , " (checkedProgramTree (checkTypedProgramWith policyStrict"
+ , " (typedProgram 0 [(typedValue 0 (viewFn [(viewRef 10)] (viewRef 10)) (x : x))])))"
+ , " (x : x))"
+ , " (equal?"
+ , " (checkedProgramTree (checkTypedProgramWith policyStrict"
+ , " (typedProgram 2"
+ , " [(typedValue 0 (viewFn [(viewRef 10)] (viewRef 10)) (x : x))"
+ , " (typedValue 1 (viewRef 10) (t t))"
+ , " (typedApply 2 0 1 (t t))"
+ , " (typedRequire 2 (viewRef 10) (t t))])))"
+ , " (t t)))"
+ ]
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "checkTypedProgram returns checked-exec wrapper on success" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchBool \"yes\" \"no\" (equal? (recordTag exec) checkedExecTagPure)) (checkTypedProgram (typedProgram 0 [(typedValue 0 (viewRef 10) (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "guarded typedRequire injects checked guard on root success" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString (t t)) (typedRequire 0 (viewGuarded viewString (x : guardOk x)) (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "guarded typedRequire injects checked guard on root failure" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString (t t)) (typedRequire 0 (viewGuarded viewString (x : guardFail)) (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "root guarded observations compose in typed-node order" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"2\"))) \"x\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "x12"
+
+ , testCase "guarded typedValue implies base evidence and composes with later guarded require" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"2\"))) \"x\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "x12"
+
+ , testCase "guarded function argument injects before root application" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardOk x))] viewString) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "guarded function argument failure skips root application" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardFail))] viewString) (x : \"entered\")) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "guarded function argument failure renders application context" $ do
+ let input = "matchResult (diag env : renderDiagnostic diag) (exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardFail))] viewString) (x : \"entered\")) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String"
+
+ , testCase "non-root guarded requirement composes before argument use" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : x)) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedApply 2 0 1 \"x\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "x1"
+
+ , testCase "non-root guarded requirement failure skips argument use" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"entered\")) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardFail)) \"x\") (typedApply 2 0 1 \"entered\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "guarded function result injects after root application success" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardOk x))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "guarded function result failure stops at checked boundary" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardFail))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "guarded function result failure renders application context" $ do
+ let input = "matchResult (diag env : renderDiagnostic diag) (exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardFail))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed at result of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String"
+
+ , testCase "nested curried application injects guarded later argument" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewGuarded viewString (x : guardOk (append x \"!\")))] viewString) (x : y : y)) (typedValue 1 viewString \"a\") (typedApply 2 0 1 (y : y)) (typedValue 3 viewString \"b\") (typedApply 4 2 3 \"b\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "b!"
+
+ , testCase "unreachable guarded symbol does not run guard" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString \"root\") (typedValue 1 viewString \"unused\") (typedRequire 1 (viewGuarded viewString (x : guardFail)) \"unused\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "root"
+
+ , testCase "later guarded require is a global symbol observation" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : x)) (typedValue 1 viewString \"x\") (typedApply 2 0 1 \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"!\"))) \"x\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "x!"
+
+ , testCase "repeated reachable uses rerun symbol observations" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewString)] viewString) (x : y : append x y)) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"!\"))) \"x\") (typedApply 2 0 1 (y : append \"x\" y)) (typedApply 4 2 1 \"xx\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "x!x!"
+
+ , testCase "guarded callee symbol observation runs before application" $ do
+ let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"raw\")) (typedRequire 0 (viewGuarded (viewFn [(viewString)] viewString) (f : guardOk (x : \"guarded\"))) (x : \"raw\")) (typedValue 1 viewString \"arg\") (typedApply 2 0 1 \"raw\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guarded"
+
+ , testCase "guarded callee symbol failure skips application" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"entered\")) (typedRequire 0 (viewGuarded (viewFn [(viewString)] viewString) (f : guardFail)) (x : \"entered\")) (typedValue 1 viewString \"arg\") (typedApply 2 0 1 \"entered\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "nested curried guarded argument failure skips final callee" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewGuarded viewString (x : guardFail))] viewString) (x : y : \"entered\")) (typedValue 1 viewString \"a\") (typedApply 2 0 1 (y : \"entered\")) (typedValue 3 viewString \"b\") (typedApply 4 2 3 \"entered\")]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "runChecked guard success unwraps and continues" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (value env : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked (checkedGuard viewString (x : guardOk x) (t t) (x : checkedPure x)))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "runChecked guard failure does not enter continuation" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedGuard viewString (x : guardFail) (t t) (x : checkedPure \"entered\")))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "checkedBind composes checked execution success" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (value env : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked (checkedBind (checkedPure (t t)) (x : checkedPure x)))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "checkedBind propagates checked execution failure" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedBind (checkedGuard viewString (x : guardFail) (t t) (x : checkedPure x)) (x : checkedPure \"entered\")))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "guard failed"
+
+ , testCase "runChecked malformed guard result fails at checked-exec boundary" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedGuard viewString (x : record 99 t) (t t) (x : checkedPure x)))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "malformed guard result"
+
+ , testCase "Strict policy rejects missing argument view for known Fn" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "function argument view is not known"
+
+ , testCase "Gradual policy trusts missing argument view for known Fn" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyGradual (typedProgram 2 [(typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t) (typedRequire 0 (viewRef 10) t) (typedRequire 2 (viewRef 10) t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "Strict policy rejects explicit missing typedRequire" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyStrict (typedProgram 0 [(typedRequire 0 (viewRef 10) t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "required view is not known"
+
+ , testCase "Gradual policy trusts explicit missing typedRequire" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyGradual (typedProgram 0 [(typedRequire 0 (viewRef 10) t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "typedApply leaves unknown callees gradual" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 2 [(typedApply 2 1 0 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "Malformed typed node is rejected before flow checking" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(record 99 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "malformed view program"
+
+ , testCase "Raw numeric views are rejected before flow checking" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(typedValue 0 10 t)]))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "malformed view program"
+
+ , testCase "Malformed policy is rejected before program checking" $ do
+ let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith (pair 99 t) (typedProgram 0 t))"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "malformed view policy"
+
+ , testCase "Environment validator accepts only well-formed env entries" $ do
+ let input = "matchBool \"yes\" \"no\" (wellFormedEnv? [(envEntry 0 [(viewFact (viewRef 10) evidenceTagTrusted)])])"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "Portable View Contract self-tests all pass" $ do
+ let input = "viewContractSelfTests"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofList (replicate 32 (ofString "ok"))
+
+ , testCase "Structured diagnostic tag reports required-view failures" $ do
+ let input = "checkerResultErrorTag (checkTypedProgramWith policyStrict listMapWrongOutputContract)"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofNumber 4
+
+ , testCase "Structured diagnostic payload reports actual argument view" $ do
+ let input = "matchResult (diag env : matchBool \"yes\" \"no\" (equal? (diagnosticActualView diag) (viewList viewString))) (env rest : \"unexpected-ok\") (checkTypedProgramWith policyStrict listMapWrongListArgContract)"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "yes"
+
+ , testCase "Rendered diagnostic explains expected and actual views" $ do
+ let input = "matchResult (diag env : renderDiagnostic diag) (env rest : \"unexpected-ok\") (checkTypedProgramWith policyStrict listMapWrongListArgContract)"
+ env = evalTricu allTestLibsEnv (parseTricu input)
+ result env @?= ofString "symbol 162 expected List Bool but got List String"
+
+ , testCase "tricu check lowers annotated identity flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "id x@Bool =@Bool x\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports annotated body mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "id x@String =@Bool x\n"
+ output @?= "symbol 1 (x) expected Bool but got String"
+
+ , testCase "tricu check lowers application flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "f x@Bool =@Bool g x\ng y@Bool =@Bool y\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports application argument mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "f x@String =@Bool g x\ng y@Bool =@Bool y\n"
+ output @?= "symbol 2 (x) expected Bool but got String"
+
+ , testCase "tricu check maps phantom annotation to exposed lambda binder" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @Bool =@Bool (x : x)\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports phantom lambda body mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @String =@Bool (x : x)\n"
+ output @?= "symbol 1 (x) expected Bool but got String"
+
+ , testCase "tricu check maps multiple phantoms to lambda spine" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @Bool @String =@String (x y : y)\n"
+ output @?= "ok"
+
+ , testCase "tricu check leaves unconsumed phantoms as residual function requirement" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @Bool =@Bool bar\n"
+ output @?= "symbol 1 (external bar) expected Fn [Bool] Bool but got Any"
+
+ , testCase "tricu check accepts trusted imported View Contract facts" $ do
+ let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
+ output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
+ output @?= "ok"
+
+ , testCase "tricu check judges imported View Contract facts in checker" $ do
+ let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "String"))]
+ output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
+ output @?= "symbol 3 (Ext.id application result) expected Bool but got String"
+
+ , testCase "tricu lower emits imported View Contract facts as view-tree nodes" $ do
+ let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
+ case lowerSourceWithImportedViews imported "foo x@Bool =@Bool Ext.id x\n" of
+ Left err -> assertFailure err
+ Right lowered -> lowered @?= "typedProgram 3 [(typedValue 1 (viewFn [(viewBool)] (viewBool)) t) (typedValue 0 (viewFn [(viewBool)] (viewBool)) t) (typedValue 2 (viewBool) t) (typedRequire 2 (viewBool) t) (typedApply 3 1 2 t) (typedRequire 3 (viewBool) t)]"
+
+ , testCase "tricu lower emits symbolic View Contract refs in view-tree nodes" $ do
+ case lowerSource "foo x@(Ref \"UserId\") =@(Ref \"UserId\") x\n" of
+ Left err -> assertFailure err
+ Right lowered -> lowered @?= "typedProgram 1 [(typedValue 0 (viewFn [(viewRef \"UserId\")] (viewRef \"UserId\")) t) (typedValue 1 (viewRef \"UserId\") t) (typedRequire 1 (viewRef \"UserId\") t)]"
+
+ , testCase "tricu check converts resolved module export views into imported facts" $ do
+ let viewRef = ObjectRef viewContractTypeKind "abc123"
+ resolvedExport = ResolvedExport
+ { resolvedExportSourceName = "id"
+ , resolvedExportLocalName = "Ext.id"
+ , resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456"
+ , resolvedExportAbi = "arboricx.abi.tree.v1"
+ , resolvedExportView = Just viewRef
+ , resolvedExportTerm = Leaf
+ }
+ resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport]
+ loadView ref = pure $ if ref == viewRef
+ then Just (VTFn [VTName "Bool"] (VTName "Bool"))
+ else Nothing
+ imported <- importedViewsFromResolvedModules loadView [resolvedModule]
+ imported @?= [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
+ output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports missing resolved View Contract artifacts" $ do
+ let viewRef = ObjectRef viewContractTypeKind "abc123"
+ resolvedExport = ResolvedExport
+ { resolvedExportSourceName = "id"
+ , resolvedExportLocalName = "Ext.id"
+ , resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456"
+ , resolvedExportAbi = "arboricx.abi.tree.v1"
+ , resolvedExportView = Just viewRef
+ , resolvedExportTerm = Leaf
+ }
+ resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport]
+ outcome <- try (importedViewsFromResolvedModules (\_ -> pure Nothing) [resolvedModule]) :: IO (Either SomeException [ImportedView])
+ case outcome of
+ Right _ -> assertFailure "expected missing view artifact failure"
+ Left err -> show err `containsAll` ["View Contract artifact invalid", "Ext.id", "arboricx.view-contract.type.v1", "abc123", "artifact not found"]
+
+ , testCase "tricu check recognizes string literal views" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "s =@String \"hi\"\n"
+ output @?= "ok"
+
+ , testCase "tricu check recognizes byte literal views" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "b =@Byte 42\n"
+ output @?= "ok"
+
+ , testCase "tricu check recognizes unit literal views" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "u =@Unit t\n"
+ output @?= "ok"
+
+ , testCase "tricu check recognizes homogeneous list literal views" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(\"a\") (\"b\")]\n"
+ output @?= "ok"
+
+ , testCase "tricu check propagates let-bound literal views" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "x =@(List String) let y = \"hi\" in [(y)]\n"
+ output @?= "ok"
+
+ , testCase "tricu check uses binder views in list literals" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "xs x@String =@(List String) [(x) (\"b\")]\n"
+ output @?= "ok"
+
+ , testCase "tricu check consumes Fn return annotations through lambda spine" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [String] String) (x : x)\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports Fn return annotation lambda mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [String] Bool) (x : x)\n"
+ output @?= "symbol 1 (x) expected Bool but got String"
+
+ , testCase "tricu check propagates application result views into list literals" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@String y\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports application result view mismatches in list literals" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@Bool y\n"
+ output @?= "symbol 3 (g application result) expected String but got Bool"
+
+ , testCase "tricu check propagates phantom lambda binder views into list literals" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @String =@(List String) (x : [(x)])\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports phantom lambda binder list mismatches" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo @Byte =@(List String) (x : [(x)])\n"
+ output @?= "symbol 1 (x) expected String but got Byte"
+
+ , testCase "tricu check checks lambda literals in expected Fn lists" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "fs =@(List (Fn [String] String)) [((x : x))]\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports lambda literals in expected Fn list mismatches" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "fs =@(List (Fn [String] Bool)) [((x : x))]\n"
+ output @?= "symbol 1 (x) expected Bool but got String"
+
+ , testCase "tricu check propagates expected Fn through partial lambda application" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [Byte] String) (x y : x) \"hi\"\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports expected Fn mismatch through partial lambda application" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [Byte] Bool) (x y : x) \"hi\"\n"
+ output @?= "symbol 1 (string literal) expected Bool but got String"
+
+ , testCase "tricu check lowers expected Pair constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String Byte) pair \"a\" 1\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports expected Pair constructor element mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String Byte) pair 1 \"a\"\n"
+ output @?= "symbol 1 (byte literal) expected String but got Byte"
+
+ , testCase "tricu check lowers expected Maybe just constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) just \"a\"\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports expected Maybe just element mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) just 1\n"
+ output @?= "symbol 1 (byte literal) expected String but got Byte"
+
+ , testCase "tricu check lowers expected Maybe nothing constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) nothing\n"
+ output @?= "ok"
+
+ , testCase "tricu check lowers expected Result ok constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) ok \"a\" t\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports expected Result ok value mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) ok 1 t\n"
+ output @?= "symbol 1 (byte literal) expected String but got Byte"
+
+ , testCase "tricu check lowers expected Result err constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) err 1 t\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports expected Result err value mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) err \"a\" t\n"
+ output @?= "symbol 1 (string literal) expected Byte but got String"
+
+ , testCase "tricu check lowers nested Maybe List constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) just [(\"a\")]\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports nested Maybe List constructor element mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) just [(1)]\n"
+ output @?= "symbol 1 (byte literal) expected String but got Byte"
+
+ , testCase "tricu check lowers nested Pair Maybe constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String (Maybe Byte)) pair \"a\" (just 1)\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports nested Pair Maybe constructor mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String (Maybe Byte)) pair \"a\" (just \"b\")\n"
+ output @?= "symbol 2 (string literal) expected Byte but got String"
+
+ , testCase "tricu check lowers nested Result List constructor flow" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte (List String)) ok [(\"a\")] t\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports nested Result List constructor mismatch" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte (List String)) ok [(1)] t\n"
+ output @?= "symbol 1 (byte literal) expected String but got Byte"
+
+ , testCase "tricu check propagates expected views through let into constructors" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) let xs = [(\"a\")] in just xs\n"
+ output @?= "ok"
+
+ , testCase "tricu check reports let-bound constructor mismatches" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) let xs = [(1)] in just xs\n"
+ output @?= "symbol 2 expected List String but got List Byte"
+
+ , testCase "tricu check does not use constructor lowering for shadowed pair" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "pair x y = x\np =@(Pair String Byte) pair \"a\" 1\n"
+ output @?= "symbol 5 (pair application result) expected Pair String Byte but got Any"
+
+ , testCase "tricu check does not use constructor lowering for shadowed just" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "just x = x\nm =@(Maybe String) just \"a\"\n"
+ output @?= "symbol 3 (just application result) expected Maybe String but got Any"
+
+ , testCase "tricu check documents do-block lowering with explicit bind operator" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "pure x@String =@(Maybe String) just x\nbind m@(Maybe String) f@(Fn [String] (Maybe String)) =@(Maybe String) m\nm =@(Maybe String) do bind\n x <- pure \"a\"\n pure x\n"
+ output @?= "ok"
+
+ , testCase "tricu check lowerSource emits expected constructor payload typed nodes" $ do
+ case lowerSource "m =@(Maybe String) just \"a\"\n" of
+ Left err -> assertFailure err
+ Right lowered -> do
+ assertBool "expected String payload requirement" $
+ "typedRequire 1 (viewString)" `isInfixOf` lowered
+ assertBool "expected Maybe String constructor declaration" $
+ "typedValue 2 (viewMaybe (viewString))" `isInfixOf` lowered
+
+ , testCase "tricu check lowerSource emits expected Fn argument typed nodes" $ do
+ case lowerSource "f x@String =@String x\ny =@String f 1\n" of
+ Left err -> assertFailure err
+ Right lowered ->
+ assertBool "expected application argument requirement" $
+ "typedRequire 3 (viewString)" `isInfixOf` lowered
+
+ , testCase "tricu check lowerSource emits phantom-to-lambda typed nodes" $ do
+ case lowerSource "foo @String =@String (x : x)\n" of
+ Left err -> assertFailure err
+ Right lowered -> do
+ assertBool "expected lambda binder declaration" $
+ "typedValue 1 (viewString) t" `isInfixOf` lowered
+ assertBool "expected lambda body requirement" $
+ "typedRequire 1 (viewString) t" `isInfixOf` lowered
+
+ , testCase "tricu check lowerSource emits list element requirements" $ do
+ case lowerSource "xs =@(List String) [(1)]\n" of
+ Left err -> assertFailure err
+ Right lowered -> do
+ assertBool "expected Byte evidence for literal element" $
+ "typedValue 1 (viewByte)" `isInfixOf` lowered
+ assertBool "expected actual Byte tree payload for literal element" $
+ "typedValue 1 (viewByte) (t (t t) t)" `isInfixOf` lowered
+ assertBool "expected String requirement for list element" $
+ "typedRequire 1 (viewString)" `isInfixOf` lowered
+
+ , testCase "tricu check lowerSource documents constructor shadowing fallback" $ do
+ case lowerSource "just x = x\nm =@(Maybe String) just \"a\"\n" of
+ Left err -> assertFailure err
+ Right lowered -> do
+ assertBool "expected normal application result requirement" $
+ "typedRequire 3 (viewMaybe (viewString)) t" `isInfixOf` lowered
+ assertBool "shadowed just should not emit payload requirement" $
+ not ("typedRequire 2 (viewString) t" `isInfixOf` lowered)
+
+ , testCase "tricu check lowerSource emits do-block callback Fn typed nodes" $ do
+ case lowerSource "pure x@String =@(Maybe String) just x\nbind m@(Maybe String) f@(Fn [String] (Maybe String)) =@(Maybe String) m\nm =@(Maybe String) do bind\n x <- pure \"a\"\n pure x\n" of
+ Left err -> assertFailure err
+ Right lowered -> do
+ assertBool "expected callback lambda declaration" $
+ "typedValue 12 (viewFn [(viewString)] (viewMaybe (viewString))) t" `isInfixOf` lowered
+ assertBool "expected bind application to declared callback" $
+ "typedApply 13 9 12 t" `isInfixOf` lowered
+
+ , testCase "tricu check lowerSourceWithDebug records top and binder names" $ do
+ case lowerSourceWithDebug "id x@String =@String x\n" of
+ Left err -> assertFailure err
+ Right (_, debugNames) -> do
+ Map.lookup 0 debugNames @?= Just "id"
+ Map.lookup 1 debugNames @?= Just "x"
+
+ , testCase "tricu check lowerSourceWithDebug records literal and application labels" $ do
+ case lowerSourceWithDebug "f x@String =@String x\ny =@String f 1\n" of
+ Left err -> assertFailure err
+ Right (_, debugNames) -> do
+ Map.lookup 3 debugNames @?= Just "byte literal"
+ Map.lookup 4 debugNames @?= Just "f application result"
+
+ , testCase "tricu check lowerSourceWithDebug records curried application head labels" $ do
+ case lowerSourceWithDebug "f x@String y@Byte =@String x\ny =@String f \"a\" 1\n" of
+ Left err -> assertFailure err
+ Right (_, debugNames) -> do
+ Map.lookup 5 debugNames @?= Just "f application result"
+ Map.lookup 7 debugNames @?= Just "f application result"
+
+ , testCase "tricu check source syntax success demo" $ do
+ output <- checkFile "./demos/viewContracts/sourceSyntax/success.tri"
+ output @?= "ok"
+
+ , testCase "tricu check source syntax labeled diagnostic demo" $ do
+ output <- checkFile "./demos/viewContracts/sourceSyntax/failure.tri"
+ output @?= "symbol 4 (x) expected Bool but got String"
+
+ , testCase "tricu check annotations can reference local view aliases" $
+ withSystemTempDirectory "tricu-local-view-alias" $ \dir -> do
+ let path = dir </> "alias.tri"
+ writeFile path "Nat = viewRef \"Nat\"\n\nidNat x@Nat =@Nat x\n"
+ output <- checkFile path
+ output @?= "ok"
+
+ , testCase "tricu check annotations can reference guarded local view aliases" $
+ withSystemTempDirectory "tricu-guarded-view-alias" $ \dir -> do
+ let path = dir </> "guarded-alias.tri"
+ writeFile path "userIdGuard = x : guardOk x\nUserId = viewGuarded (viewRef \"UserId\") userIdGuard\n\nidUser x@UserId =@UserId x\n"
+ output <- checkFile path
+ output @?= "ok"
+
+ , testCase "tricu check runs source-level guarded root failure" $
+ withSystemTempDirectory "tricu-guarded-root-failure" $ \dir -> do
+ let path = dir </> "guarded-root-failure.tri"
+ writeFile path "reject = x : guardFail\nRejectedString = viewGuarded viewString reject\n\nmain =@RejectedString \"x\"\n"
+ output <- checkFile path
+ output @?= "guard failed at root typedRequire symbol 3 for Guarded String"
+
+ , testCase "tricu check runs source-level guarded root success" $
+ withSystemTempDirectory "tricu-guarded-root-success" $ \dir -> do
+ let path = dir </> "guarded-root-success.tri"
+ writeFile path "accept = x : guardOk x\nAcceptedString = viewGuarded viewString accept\n\nmain =@AcceptedString \"x\"\n"
+ output <- checkFile path
+ output @?= "ok"
+
+ , testCase "tricu check runs source-level guarded argument failure" $
+ withSystemTempDirectory "tricu-guarded-argument-failure" $ \dir -> do
+ let path = dir </> "guarded-argument-failure.tri"
+ writeFile path "reject = x : guardFail\nRejectedString = viewGuarded viewString reject\n\nidRejected x@RejectedString =@String \"entered\"\nmain =@String idRejected \"x\"\n"
+ output <- checkFile path
+ output @?= "guard failed at typedRequire symbol 6 for Guarded String"
+
+ , testCase "imported VTGuarded lowers to portable viewGuarded" $ do
+ let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)"))
+ imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))]
+ case lowerSourceWithImportedViews imported "main =@String Ext.id \"x\"\n" of
+ Left err -> assertFailure err
+ Right lowered -> assertBool "expected imported guarded view to survive lowering" $ "viewGuarded" `isInfixOf` lowered
+
+ , testCase "tricu check runs imported guarded argument failure" $ do
+ let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)"))
+ imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))]
+ output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "main =@String Ext.id \"x\"\n"
+ output @?= "guard failed at typedRequire symbol 2 for Guarded String"
+
+ , testCase "tricu check rejects malformed local view aliases" $
+ withSystemTempDirectory "tricu-malformed-view-alias" $ \dir -> do
+ let path = dir </> "bad-alias.tri"
+ writeFile path "Bad = \"not a view\"\n\nidBad x@Bad =@Bad x\n"
+ output <- checkFile path
+ output @?= "malformed view program"
+
+ , testCase "tricu check rejects malformed local view constructors" $
+ withSystemTempDirectory "tricu-malformed-view-constructor" $ \dir -> do
+ let path = dir </> "bad-constructor.tri"
+ writeFile path "BadBox a = pair \"not\" a\n\nidBad x@(BadBox String) =@(BadBox String) x\n"
+ output <- checkFile path
+ output @?= "malformed view program"
+
+ , testCase "tricu check annotations can apply user-defined view constructors" $
+ withSystemTempDirectory "tricu-local-view-constructor" $ \dir -> do
+ let path = dir </> "constructor.tri"
+ writeFile path "Box a = viewPair (viewRef \"Box\") a\n\nidBox x@(Box String) =@(Box String) x\n"
+ output <- checkFile path
+ output @?= "ok"
+
+ , testCase "Workspace modules publish resolved custom view aliases" $
+ withSystemTempDirectory "tricu-workspace-custom-view-alias" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ utilPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile utilPath "Nat = t 2 [(t 2 10)]\nidNat x@Nat =@Nat x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.idNat 1\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected util module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected util module manifest"
+ Just manifest -> case find ((== "idNat") . unpack . moduleExportName) (moduleManifestExports manifest) of
+ Nothing -> assertFailure "expected idNat export"
+ Just ex -> case moduleExportView ex of
+ Nothing -> assertFailure "expected idNat view ref"
+ Just viewRef -> do
+ view <- getViewType store viewRef
+ view @?= Right (VTFn [VTRef 10] (VTRef 10))
+
+ , testCase "Workspace modules publish string custom view aliases" $
+ withSystemTempDirectory "tricu-workspace-string-view-alias" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ utilPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile utilPath "Nat = t 2 [(t 2 \"Nat\")]\nidNat x@Nat =@Nat x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.idNat 1\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected util module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected util module manifest"
+ Just manifest -> case find ((== "idNat") . unpack . moduleExportName) (moduleManifestExports manifest) of
+ Nothing -> assertFailure "expected idNat export"
+ Just ex -> case moduleExportView ex of
+ Nothing -> assertFailure "expected idNat view ref"
+ Just viewRef -> do
+ view <- getViewType store viewRef
+ view @?= Right (VTFn [VTRefText "Nat"] (VTRefText "Nat"))
+
+ , testCase "Workspace modules publish guarded custom view aliases" $
+ withSystemTempDirectory "tricu-workspace-guarded-view-alias" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ utilPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ guardTerm = result (evalTricu viewTestEnv (parseTricu "(x : t 30 [(t 0 x)])"))
+ expectedView = VTFn [VTGuarded (VTRefText "UserId") guardTerm] (VTGuarded (VTRefText "UserId") guardTerm)
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile utilPath "UserId = t 7 [(t 8 (t 2 [(t 2 \"UserId\")])) (t 9 (x : t 30 [(t 0 x)]))]\nidUser x@UserId =@UserId x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.idUser 1\n"
+ _ <- evaluateFileWithStore (Just store) mainPath
+ mAlias <- readAlias store ModuleAlias "util"
+ case mAlias of
+ Nothing -> assertFailure "expected util module alias"
+ Just ref -> do
+ mManifest <- getManifest store (objectRefHash ref)
+ case mManifest of
+ Nothing -> assertFailure "expected util module manifest"
+ Just manifest -> case find ((== "idUser") . unpack . moduleExportName) (moduleManifestExports manifest) of
+ Nothing -> assertFailure "expected idUser export"
+ Just ex -> do
+ objectRefKind (moduleExportObject ex) @?= viewTreeKind
+ moduleExportAbi ex @?= "arboricx.abi.view-tree.v1"
+ loadedTree <- getViewTree store (moduleExportObject ex)
+ case moduleExportView ex of
+ Nothing -> assertFailure "expected idUser view ref"
+ Just viewRef -> do
+ objectRefKind viewRef @?= viewContractTypeKind
+ view <- getViewType store viewRef
+ view @?= Right expectedView
+ case loadedTree of
+ Left err -> assertFailure err
+ Right tree -> do
+ rootTerm <- either assertFailure pure (viewTreeRootTerm tree)
+ tree @?= singletonViewTree (Just expectedView) rootTerm
+
+ , testCase "Workspace modules reject malformed custom view aliases" $
+ withSystemTempDirectory "tricu-workspace-malformed-view-alias" $ \dir -> do
+ let store = StorePath (dir </> "store")
+ utilPath = dir </> "util.tri"
+ mainPath = dir </> "main.tri"
+ writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
+ writeFile utilPath "Bad = \"not a view\"\nidBad x@Bad =@Bad x\n"
+ writeFile mainPath "!import \"util\" Util\n\nmain = Util.idBad 1\n"
+ outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env)
+ case outcome of
+ Right _ -> assertFailure "expected malformed custom view alias rejection"
+ Left err -> show err `containsAll`
+ [ "Workspace module"
+ , "util"
+ , "failed View Contract check"
+ , "malformed view program"
+ ]
+ readAlias store ModuleAlias "util" >>= (@?= Nothing)
+
+ , testCase "tricu check catches undersaturated annotated function calls via residual Fn view" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "f x@String y@String =@String x\nmain =@String f \"a\"\n"
+ output @?= "symbol 5 (f application result) expected String but got Fn [String] String"
+
+ , testCase "tricu check catches oversaturated annotated function calls via non-Fn result" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "f x@String y@String =@String x\nmain =@String f \"a\" \"b\" \"c\"\n"
+ output @?= "symbol 9 (f application result) expected String but got Any"
+
+ , testCase "tricu check source syntax demo includes callee-aware diagnostic" $ do
+ output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@Bool y\n"
+ output @?= "symbol 3 (g application result) expected String but got Bool"
+ ]
+
+-- --------------------------------------------------------------------------
-- IO driver tests
-- --------------------------------------------------------------------------
ioDriverTests :: TestTree
ioDriverTests = testGroup "IO driver tests"
[ -- Existing behaviour tests
- testCase "readFile through onReadFile returns file contents" $
+ testCase "View Contract checked-exec can produce an IO interaction tree" $ do
+ final <- runIOSource $
+ unlines
+ [ "Any = viewAny"
+ , "ioSentinel? = (value : and? (equal? (fst value) \"tricuIO\") (equal? (fst (snd value)) 1))"
+ , "requireIO = (value : lazyBool (_ : guardOk value) (_ : guardFail) (ioSentinel? value))"
+ , "viewIO = viewGuarded Any requireIO"
+ , "checkedIO = (action : matchResult (diag env : io (pure (renderDiagnostic diag))) (exec env : matchResult (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag))) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewIO action)])))"
+ , "main = checkedIO (io (pure \"checked hello\"))"
+ ]
+ final @?= ofString "checked hello"
+
+ , testCase "View Contract IO guard rejects non-interaction-tree root" $ do
+ final <- runIOSource $
+ unlines
+ [ "Any = viewAny"
+ , "ioSentinel? = (value : and? (equal? (fst value) \"tricuIO\") (equal? (fst (snd value)) 1))"
+ , "requireIO = (value : lazyBool (_ : guardOk value) (_ : guardFail) (ioSentinel? value))"
+ , "viewIO = viewGuarded Any requireIO"
+ , "checkedIO = (action : matchResult (diag env : io (pure (renderDiagnostic diag))) (exec env : matchResult (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag))) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewIO action)])))"
+ , "main = checkedIO \"not io\""
+ ]
+ final @?= ofString "guard failed at root typedValue symbol 0 for Guarded Any"
+
+ , testCase "source sugar enforces pure View Contracts inside IO continuations" $ do
+ final <- runIOSource $
+ unlines
+ [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))"
+ , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty"
+ , "acceptNames xs@(NonEmptyList String) =@String \"accepted\""
+ , "main = io (bind (pure []) (xs : pure (acceptNames xs)))"
+ ]
+ final @?= ofString "guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded List String"
+
+ , testCase "source sugar enforces nested pure View Contracts inside IO continuations" $ do
+ final <- runIOSource $
+ unlines
+ [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))"
+ , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty"
+ , "acceptNames xs@(NonEmptyList String) =@String \"accepted\""
+ , "main = io (bind (pure []) (xs : pure (append (acceptNames xs) \"!\")))"
+ ]
+ final @?= ofString "guard failed at typedValue symbol 2 for Guarded List String"
+
+ , testCase "source sugar enforces higher-order View Contracts inside IO continuations" $ do
+ final <- runIOSource $
+ unlines
+ [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))"
+ , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty"
+ , "acceptNames xs@(NonEmptyList String) =@String \"accepted\""
+ , "useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String handler xs"
+ , "main = io (bind (pure []) (xs : pure (useHandler acceptNames xs)))"
+ ]
+ final @?= ofString "guard failed at typedRequire symbol 1 for Guarded List String"
+
+ , testCase "readFile through onReadFile returns file contents" $
withSystemTempDirectory "tricu-io-read" $ \dir -> do
let sourcePath = dir ++ "/input.txt"
writeFile sourcePath "abc123"
@@ -3306,93 +4450,79 @@ httpParsingTests = testGroup "HTTP Parsing Tests"
[
-- chomp / request-line reader
testCase "chomp strips trailing CR" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "chomp [(104) (105) (13)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [104, 105]
, testCase "chomp leaves line without CR" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "chomp [(104) (105)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT [104, 105]
, testCase "chomp empty list" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "chomp []"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= bytesT []
, testCase "readLineBytes with CRLF" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "readLineBytes [(104) (105) (13) (10) (120)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
, testCase "readLineBytes with bare LF" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "readLineBytes [(104) (105) (10) (120)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
, testCase "readLineBytes empty line" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "readLineBytes [(13) (10) (120)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT []) (bytesT [120])
, testCase "readLineBytes EOF mid-line returns line" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "readLineBytes [(104) (105)]"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= pairT (bytesT [104, 105]) (bytesT [])
-- parseRequestLine
, testCase "parseRequestLine GET slash" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk
(pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
(ofString "x")
, testCase "parseRequestLine POST path" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk
(pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
(ofString "")
, testCase "parseRequestLine too short" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine \"GET\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
, testCase "parseRequestLine no version" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine \"GET /foo\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
, testCase "parseRequestLine empty line" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine \"\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
, testCase "parseRequestLine rejects extra fields" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-- parseHeaders
, testCase "parseHeaders two headers lowercases names" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk
(ofList
[ pairT (ofString "host") (ofString "localhost")
@@ -3401,206 +4531,179 @@ httpParsingTests = testGroup "HTTP Parsing Tests"
(ofString "x")
, testCase "parseHeaders preserves colon in value" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk
(ofList [pairT (ofString "x-custom") (ofString "a: b")])
(ofString "x")
, testCase "parseHeaders accepts empty value" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk
(ofList [pairT (ofString "x-empty") (ofString "")])
(ofString "x")
, testCase "parseHeaders immediate blank" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseHeaders \"\\r\\nx\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (ofList []) (ofString "x")
, testCase "parseHeaders rejects missing colon" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseHeaders \"Host\\r\\n\\r\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
, testCase "parseContentLengthValue accepts max body bytes" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "ok"
, testCase "parseContentLengthValue accepts shorter decimal below max" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "ok"
, testCase "parseContentLengthValue strips leading zeros before limit check" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseContentLengthValue \"0000000000001\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserOk (justT (ofNumber 1)) Leaf
, testCase "parseContentLengthValue rejects body above max" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseContentLengthValue \"1048577\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
, testCase "parseContentLengthValue rejects longer body above max" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "parseContentLengthValue \"2000000\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
-- statusLine / headerLine
, testCase "statusLine 200 OK" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusLine 200 \"OK\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 200 OK\r\n"
, testCase "headerLine Content-Length" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "headerLine \"Content-Length\" \"42\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Content-Length: 42\r\n"
-- statusPhrase
, testCase "statusPhrase 200" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 200"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "OK"
, testCase "statusPhrase 201" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 201"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Created"
, testCase "statusPhrase 204" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 204"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "No Content"
, testCase "statusPhrase 400" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 400"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Bad Request"
, testCase "statusPhrase 404" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 404"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Not Found"
, testCase "statusPhrase 405" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 405"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Method Not Allowed"
, testCase "statusPhrase 431" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 431"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Request Header Fields Too Large"
, testCase "statusPhrase 501" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 501"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Not Implemented"
, testCase "statusPhrase 505" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 505"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP Version Not Supported"
, testCase "statusPhrase 500" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 500"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Internal Server Error"
, testCase "statusPhrase unknown" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "statusPhrase 999"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "Internal Server Error"
-- buildResponse
, testCase "buildResponse 200 no headers" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "buildResponse 200 [] \"hi\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
, testCase "buildResponse 404 with header" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found"
-- convenience responses
, testCase "okResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "okResponse \"hi\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
, testCase "notFoundResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "notFoundResponse"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 10\r\nConnection: close\r\n\r\nNot found\n"
, testCase "textResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "textResponse \"hi\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
, testCase "jsonResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "jsonResponse \"{}\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}"
, testCase "createdResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "createdResponse \"created\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 201 Created\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 8\r\nConnection: close\r\n\r\ncreated\n"
, testCase "emptyResponse 204" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "emptyResponse 204"
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
, testCase "badRequestResponse" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "badRequestResponse \"Bad Request\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 12\r\nConnection: close\r\n\r\nBad Request\n"
, testCase "errorResponse 405" $ do
- lib <- evaluateFile "./lib/http.tri"
let input = "errorResponse 405 \"Method Not Allowed\\n\""
- env = evalTricu lib (parseTricu input)
+ env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofString "HTTP/1.1 405 Method Not Allowed\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 19\r\nConnection: close\r\n\r\nMethod Not Allowed\n"
]
+containsAll :: String -> [String] -> Assertion
+containsAll text needles =
+ forM_ needles $ \needle ->
+ assertBool ("expected " ++ show needle ++ " in: " ++ text) (needle `isInfixOf` text)
+
withFreePort :: (Int -> IO a) -> IO a
withFreePort action =
bracket
@@ -3614,10 +4717,10 @@ withFreePort action =
runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T)
runIOSourceWith perms readerEnv initialState source = do
- ioEnv <- evaluateFile "./lib/io.tri"
- sockEnv <- evaluateFile "./lib/socket.tri"
- let combinedEnv = Map.union sockEnv ioEnv
- evalEnv <- evalTricuWithStore Nothing combinedEnv (parseTricu source)
+ checkedAst <- case instrumentIOContinuations (parseTricu source) of
+ Left err -> assertFailure err
+ Right asts -> pure asts
+ let evalEnv = evalTricu allTestLibsEnv checkedAst
let fullTree = mainResult evalEnv
result <- runIOWith perms readerEnv initialState fullTree
case result of
diff --git a/test/cycle-1.tri b/test/cycle-1.tri
@@ -1,4 +0,0 @@
-
-!import "cycle-2.tri" Cycle2
-
-cycle1 = t Cycle2.cycle2
diff --git a/test/cycle-2.tri b/test/cycle-2.tri
@@ -1,4 +0,0 @@
-
-!import "cycle-1.tri" Cycle1
-
-cycle2 = t Cycle1.cycle1
diff --git a/test/lambda-A.tri b/test/lambda-A.tri
@@ -1 +0,0 @@
-main = (x : x) t
diff --git a/test/local-ns/1.tri b/test/local-ns/1.tri
@@ -1,4 +0,0 @@
-
-!import "2.tri" Two
-
-main = Two.x
diff --git a/test/local-ns/2.tri b/test/local-ns/2.tri
@@ -1,2 +0,0 @@
-
-!import "3.tri" !Local
diff --git a/test/local-ns/3.tri b/test/local-ns/3.tri
@@ -1 +0,0 @@
-x = 3
diff --git a/test/multi-level-A.tri b/test/multi-level-A.tri
@@ -1,2 +0,0 @@
-!import "multi-level-B.tri" B
-main = B.main
diff --git a/test/multi-level-B.tri b/test/multi-level-B.tri
@@ -1,2 +0,0 @@
-!import "multi-level-C.tri" C
-main = C.val
diff --git a/test/multi-level-C.tri b/test/multi-level-C.tri
@@ -1 +0,0 @@
-val = t
diff --git a/test/named-imports/1.tri b/test/named-imports/1.tri
@@ -1,7 +0,0 @@
-
-!import "lib/base.tri"
-
-!import "test/named-imports/2.tri"
-!import "test/named-imports/3.tri" ThreeRenamed
-
-main = equal? (equal? Two.x 2) (equal? ThreeRenamed.x 3)
diff --git a/test/named-imports/2.tri b/test/named-imports/2.tri
@@ -1,2 +0,0 @@
-
-x = 2
diff --git a/test/named-imports/3.tri b/test/named-imports/3.tri
@@ -1,2 +0,0 @@
-
-x = 3
diff --git a/test/namespace-A.tri b/test/namespace-A.tri
@@ -1,2 +0,0 @@
-!import "namespace-B.tri" B
-main = B.x
diff --git a/test/namespace-B.tri b/test/namespace-B.tri
@@ -1 +0,0 @@
-x = t
diff --git a/test/vars-A.tri b/test/vars-A.tri
@@ -1,6 +0,0 @@
-
-!import "vars-B.tri" B
-
-!import "vars-C.tri" C
-
-main = B.y (C.z)
diff --git a/test/vars-B.tri b/test/vars-B.tri
@@ -1 +0,0 @@
-y = x : x
diff --git a/test/vars-C.tri b/test/vars-C.tri
@@ -1 +0,0 @@
-z = t
diff --git a/tricu.cabal b/tricu.cabal
@@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
-version: 1.1.0
+version: 2.0.0
description: A language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
@@ -11,6 +11,7 @@ license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
+ tricu.workspace
executable tricu
main-is: Main.hs
@@ -52,7 +53,6 @@ executable tricu
, memory
, mtl
, network
- , sqlite-simple
, stm
, tasty
, tasty-hunit
@@ -62,11 +62,25 @@ executable tricu
, vector
, zlib
other-modules:
+ Check
+ Check.Core
+ Check.IO
ContentStore
+ ContentStore.Alias
+ ContentStore.Arboricx
+ ContentStore.Bundle
+ ContentStore.Filesystem
+ ContentStore.Object
+ ContentStore.Resolver
+ ContentStore.ViewTree
+ ContentStore.ViewContract
Eval
FileEval
IODriver
Lexer
+ Module.Manifest
+ Module.Resolver
+ Module.Workspace
Parser
Paths_tricu
REPL
@@ -99,7 +113,6 @@ benchmark tricu-bench
, memory
, mtl
, network
- , sqlite-simple
, text
, time
, transformers
@@ -109,10 +122,21 @@ benchmark tricu-bench
other-modules:
ApplyStats
ContentStore
+ ContentStore.Alias
+ ContentStore.Arboricx
+ ContentStore.Bundle
+ ContentStore.Filesystem
+ ContentStore.Object
+ ContentStore.Resolver
+ ContentStore.ViewTree
+ ContentStore.ViewContract
Eval
FileEval
IODriver
Lexer
+ Module.Manifest
+ Module.Resolver
+ Module.Workspace
Parser
Paths_tricu
Research
@@ -145,7 +169,6 @@ test-suite tricu-tests
, memory
, mtl
, network
- , sqlite-simple
, stm
, tasty
, tasty-hunit
@@ -158,11 +181,25 @@ test-suite tricu-tests
, zlib
default-language: Haskell2010
other-modules:
+ Check
+ Check.Core
+ Check.IO
ContentStore
+ ContentStore.Alias
+ ContentStore.Arboricx
+ ContentStore.Bundle
+ ContentStore.Filesystem
+ ContentStore.Object
+ ContentStore.Resolver
+ ContentStore.ViewTree
+ ContentStore.ViewContract
Eval
FileEval
IODriver
Lexer
+ Module.Manifest
+ Module.Resolver
+ Module.Workspace
Parser
Paths_tricu
REPL
diff --git a/tricu.workspace b/tricu.workspace
@@ -0,0 +1,20 @@
+# tricu workspace module source map
+module base = lib/base.tri
+module list = lib/list.tri
+module bytes = lib/bytes.tri
+module conversions = lib/conversions.tri
+module lazy = lib/lazy.tri
+module prelude = lib/prelude.tri
+module binary = lib/binary.tri
+module patterns = lib/patterns.tri
+module io = lib/io.tri
+module socket = lib/socket.tri
+module http = lib/http.tri
+module view = lib/view.tri
+module views.catalog = lib/views/catalog.tri
+module arboricx.common = lib/arboricx/common.tri
+module arboricx.nodes = lib/arboricx/nodes.tri
+module arboricx.manifest = lib/arboricx/manifest.tri
+module arboricx = lib/arboricx/arboricx.tri
+module arboricx.dispatch = lib/arboricx/dispatch.tri
+module arboricx.server = lib/arboricx/server.tri
