Tricu 2.0.0

Sorry for squashing all of this but 🤷
This commit is contained in:
2026-05-25 12:43:15 -05:00
parent 2e2db07bd6
commit fdebb6c13d
105 changed files with 10139 additions and 1938 deletions

View File

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

View File

@@ -1,4 +1,4 @@
!import "../lib/prelude.tri" !Local
!import "prelude" !Local
main = lambdaEqualsTC

View File

@@ -1,5 +1,5 @@
!import "../lib/prelude.tri" !Local
!import "../lib/io.tri" !Local
!import "prelude" !Local
!import "io" !Local
-- Interaction Tree Effect Runtime
--

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -1,4 +1,4 @@
!import "../lib/prelude.tri" !Local
!import "prelude" !Local
main = exampleTwo
-- Level Order Traversal of a labelled binary tree

View File

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

View File

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

View File

@@ -1,4 +1,4 @@
!import "../lib/prelude.tri" !Local
!import "prelude" !Local
main = size size

View File

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

190
demos/viewContracts.tri Normal file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -0,0 +1,3 @@
!import "vc.demo.util" Util
foo x@Bool =@Bool Util.toString x

View File

@@ -0,0 +1,3 @@
!import "vc.demo.util" Util
foo x@Bool =@Bool Util.id x

View File

@@ -0,0 +1 @@
module vc.demo.util = util.tri

View File

@@ -0,0 +1,2 @@
id x@Bool =@Bool x
toString x@Bool =@String "ok"

View File

@@ -0,0 +1,3 @@
!import "views.catalog" !Local
main = viewCatalogSelfTests

View File

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

View File

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

View File

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

View File

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

371
docs/guard-injection.md Normal file
View File

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

View File

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

View File

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

337
docs/view-contracts.md Normal file
View File

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

View File

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

View File

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

View File

@@ -1,4 +1,5 @@
!import "arboricx.tri" !Local
!import "prelude" !Local
!import "arboricx" !Local
-- Multi-purpose kernel dispatch.
-- runArboricxTyped tag bundleBytes args

View File

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

View File

@@ -1,4 +1,6 @@
!import "common.tri" !Local
!import "prelude" !Local
!import "binary" !Local
!import "arboricx.common" !Local
-- Indexed Arboricx node section reader.
--

View File

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

View File

@@ -1,6 +1,4 @@
!import "base.tri" !Local
!import "list.tri" !Local
!import "bytes.tri" !Local
!import "prelude" !Local
errUnexpectedEof = 1
errUnexpectedBytes = 2

View File

@@ -1,5 +1,5 @@
!import "base.tri" !Local
!import "list.tri" !Local
!import "base" !Local
!import "list" !Local
bytesNil? = emptyList?

View File

@@ -1,5 +1,5 @@
!import "base.tri" !Local
!import "list.tri" !Local
!import "base" !Local
!import "list" !Local
incDecRev = y (self : matchList
"1"

View File

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

View File

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

View File

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

View File

@@ -1,4 +1,4 @@
!import "base.tri" !Local
!import "base" !Local
_ = t

View File

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

View File

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

View File

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

1560
lib/view.tri Normal file

File diff suppressed because it is too large Load Diff

267
lib/views/catalog.tri Normal file
View File

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

42
src/Check.hs Normal file
View File

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

751
src/Check/Core.hs Normal file
View File

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

409
src/Check/IO.hs Normal file
View File

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

View File

@@ -1,319 +1,17 @@
module ContentStore where
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 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
import ContentStore.Arboricx
import ContentStore.Alias
import ContentStore.Filesystem
import ContentStore.Object
import ContentStore.Resolver
import ContentStore.ViewTree
import ContentStore.ViewContract

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -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 [n | SDef n _ _ <- topDefs])
(Set.fromList [defName d | d <- topDefs])
(freeVars def)
depends topDefs def@SDefAnn {} =
Set.intersection
(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)?

View File

@@ -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
evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
-- | 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
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
preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
preprocessFile' seen base currentPath = do
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
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
}
makeRelativeTo :: FilePath -> FilePath -> FilePath
makeRelativeTo f i =
let d = takeDirectory f
in normalise $ d </> i
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
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
isAnnotatedDefinition :: TricuAST -> Bool
isAnnotatedDefinition SDefAnn {} = True
isAnnotatedDefinition _ = False
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
topLevelDefinitions :: [TricuAST] -> [String]
topLevelDefinitions = mapMaybe go
where
go (SDef name _ _) = Just name
go (SDefAnn name _ _ _) = Just name
go _ = Nothing
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
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
isPrefixed :: String -> Bool
isPrefixed name = '.' `elem` name
resolveDefinitionViews :: Env -> Map.Map String ViewExpr -> Either String (Map.Map String ViewType)
resolveDefinitionViews env = mapM (resolveViewExpression env)
nsVariable :: String -> String -> String
nsVariable "" name = name
nsVariable moduleName name = moduleName ++ "." ++ name
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

View File

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

View File

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

137
src/Module/Manifest.hs Normal file
View File

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

153
src/Module/Resolver.hs Normal file
View File

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

66
src/Module/Workspace.hs Normal file
View File

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

View File

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

View File

@@ -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)
( ContractMode(..)
, LoadedSource(..)
, defaultStorePath
, loadFileWithStoreMode
)
import Parser (parseTricu)
import Research (EvaluatedForm(..), Env, formatT)
import ContentStore (StorePath(..))
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)
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 }
_ -> outputStrLn "Invalid selection. Keeping current output format." >> loop state
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
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
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
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 do
liftIO $ printError $ "File not found: " ++ cleanFilename
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 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
| otherwise = do
outputStrLn $ "Store changed to: " ++ path
loop state { replStore = StorePath path }
liftIO $ do
printSuccess $ "Importing file: " ++ cleanFilename
let defs = Map.toList $ Map.delete "!result" env
handleUnchecked :: REPLState -> String -> InputT IO ()
handleUnchecked state arg = setUnchecked state arg
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
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 }
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
reportContracts :: REPLState -> InputT IO ()
reportContracts state = outputStrLn $ contractModeMessage (replContracts state)
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
handleExport :: REPLState -> InputT IO ()
handleExport state = do
let fset = setComplete completeFilename defaultSettings
hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
case hashInput of
Nothing -> loop state
Just hashStr -> do
fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
case fileInput of
Nothing -> loop state
Just outFile -> case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
let cleanHash = strip hashStr
hash <- liftIO $ do
let h = T.pack cleanHash
if '#' `T.elem` h
then return h
else do
results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
(Only (h <> "%")) :: IO [Only T.Text]
case results of
[Only fullHash] -> return fullHash
[] -> do
results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
(Only (h <> "%")) :: IO [Only T.Text]
case results2 of
[Only fullHash] -> return fullHash
_ -> do
printError $ "No term found matching: " ++ cleanHash
return h
_ -> do
printError $ "Ambiguous match for: " ++ cleanHash
return h
maybeTree <- liftIO $ loadTree conn hash
case maybeTree of
Nothing -> do
liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
loop state
Just tree -> do
let bundle = buildBundle [(T.pack "root", tree)]
bundleData = encodeBundle bundle
liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
liftIO $ do
printSuccess $ "Exported bundle with root "
displayColoredHash hash
putStrLn $ " to " ++ outFile
loop state
handleBundleImport :: REPLState -> InputT IO ()
handleBundleImport state = do
let fset = setComplete completeFilename defaultSettings
fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
case fileInput of
Nothing -> loop state
Just inFile -> case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
loop state
Just conn -> do
exists <- liftIO $ doesFileExist inFile
if not exists
then do
liftIO $ printError $ "File not found: " ++ inFile
loop state
else do
bundleData <- liftIO $ BL.readFile inFile
roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
liftIO $ do
printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
loop state
interruptHandler :: REPLState -> Interrupt -> InputT IO ()
interruptHandler state _ = do
liftIO $ do
printWarning "Interrupted with CTRL+C"
printWarning "You can use the !exit command or CTRL+D to exit"
loop state
errorHandler :: REPLState -> SomeException -> IO REPLState
errorHandler state e = do
printError $ "Error: " ++ displayException e
return state
handleEnv :: REPLState -> InputT IO ()
handleEnv state =
case sort (Map.keys (replEnv state)) of
[] -> outputStrLn "Environment is empty"
names -> mapM_ outputStrLn names
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
let env' = evalTricu (replEnv state) (parseTricu input)
writeIORef (replEnvRef state) env'
putStrLn $ formatT (replForm state) (result env')
return state { replEnv = env' }
forM_ asts $ \ast -> do
case ast of
SDef name [] body -> do
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
hash <- ContentStore.storeTerm conn [name] evalResult
errorHandler :: REPLState -> SomeException -> IO REPLState
errorHandler state e = do
putStrLn $ "Error: " ++ displayException e
return state
liftIO $ do
putStr "tricu > "
printSuccess "Stored definition: "
printVariable name
putStr " with hash "
displayColoredHash hash
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()[]{}\"'"
putStr "tricu > "
printResult $ formatT (replForm newState) evalResult
putStrLn ""
outputFormats :: [EvaluatedForm]
outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
_ -> do
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
liftIO $ do
putStr "tricu > "
printResult $ formatT (replForm newState) evalResult
putStrLn ""
return newState
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
strip :: String -> String
strip = dropWhileEnd isSpace . dropWhile isSpace
contractModeMessage :: ContractMode -> String
contractModeMessage EnforceContracts = "Contracts: on"
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
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
storePathString :: StorePath -> FilePath
storePathString (StorePath path) = path
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
processWatchedFile filepath mconn selectedVersions outputForm = do
content <- readFile filepath
let asts = parseTricu content
strip :: String -> String
strip = f . f
where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
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 ""
readMaybeInt :: String -> Maybe Int
readMaybeInt s = case reads s of
[(n, "")] -> Just n
_ -> Nothing

View File

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

View File

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

File diff suppressed because it is too large Load Diff

View File

@@ -1,4 +0,0 @@
!import "cycle-2.tri" Cycle2
cycle1 = t Cycle2.cycle2

View File

@@ -1,4 +0,0 @@
!import "cycle-1.tri" Cycle1
cycle2 = t Cycle1.cycle1

View File

@@ -1 +0,0 @@
main = (x : x) t

View File

@@ -1,4 +0,0 @@
!import "2.tri" Two
main = Two.x

View File

@@ -1,2 +0,0 @@
!import "3.tri" !Local

View File

@@ -1 +0,0 @@
x = 3

View File

@@ -1,2 +0,0 @@
!import "multi-level-B.tri" B
main = B.main

View File

@@ -1,2 +0,0 @@
!import "multi-level-C.tri" C
main = C.val

View File

@@ -1 +0,0 @@
val = t

View File

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

View File

@@ -1,2 +0,0 @@
x = 2

View File

@@ -1,2 +0,0 @@
x = 3

View File

@@ -1,2 +0,0 @@
!import "namespace-B.tri" B
main = B.x

View File

@@ -1 +0,0 @@
x = t

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