Tricu 2.0.0
Sorry for squashing all of this but 🤷
This commit is contained in:
84
README.md
84
README.md
@@ -2,7 +2,7 @@
|
||||
|
||||
## Introduction
|
||||
|
||||
tricu (pronounced "tree-shoe") is an experimental programming language written in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf). I will refer to this "family" of calculi as TC.
|
||||
tricu (pronounced "tree-shoe") is an experimental programming language written in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf). I refer to this "family" of calculi as TC below.
|
||||
|
||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||
|
||||
@@ -37,23 +37,6 @@ tricu > "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||
tricu < -- or calculate its size (/demos/size.tri)
|
||||
tricu < size not?
|
||||
tricu > 12
|
||||
|
||||
tricu < !help
|
||||
tricu version 1.1.0
|
||||
Available commands:
|
||||
!exit - Exit the REPL
|
||||
!clear - Clear the screen
|
||||
!reset - Reset preferences for selected versions
|
||||
!help - Show tricu version and available commands
|
||||
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
|
||||
!definitions - List all defined terms in the content store
|
||||
!import - Import definitions from file to the content store
|
||||
!watch - Watch a file for changes, evaluate terms, and store them
|
||||
!versions - Show all versions of a term by name
|
||||
!select - Select a specific version of a term for subsequent lookups
|
||||
!tag - Add or update a tag for a term by hash or name
|
||||
!export - Export a term bundle to file (hash, file)
|
||||
!bundleimport- Import a bundle file into the content store
|
||||
```
|
||||
|
||||
## Installation and Use
|
||||
@@ -69,4 +52,67 @@ You can easily build and run this project using [Nix](https://nixos.org/download
|
||||
|
||||
## Usage
|
||||
|
||||
I'll update this once the CLI stabilizes more.
|
||||
### CLI
|
||||
|
||||
Evaluate one or more files:
|
||||
|
||||
```sh
|
||||
tricu eval program.tri
|
||||
tricu eval --format decode program.tri
|
||||
tricu eval --output result.txt program.tri
|
||||
```
|
||||
|
||||
Annotated programs run normally under `eval`; annotations are metadata, not
|
||||
runtime types. If you want evaluation to ignore View Contracts completely while
|
||||
loading workspace modules, use unchecked mode:
|
||||
|
||||
```sh
|
||||
tricu eval --unchecked program.tri
|
||||
```
|
||||
|
||||
Unchecked eval parses annotation syntax, discards contract metadata, skips
|
||||
producer-side View Contract checks during workspace module auto-builds, and does
|
||||
not publish unchecked View refs. Executable module exports may still be cached in
|
||||
the content store.
|
||||
|
||||
Check View Contract annotations explicitly:
|
||||
|
||||
```sh
|
||||
tricu check program.tri
|
||||
tricu check --store ./.tricu-store program.tri
|
||||
```
|
||||
|
||||
Compile/import/export Arboricx bundles:
|
||||
|
||||
```sh
|
||||
tricu arboricx compile --file program.tri --output program.arboricx
|
||||
tricu arboricx import --file program.arboricx --module program
|
||||
tricu arboricx export --module prelude --output prelude.arboricx
|
||||
```
|
||||
|
||||
Inspect store aliases:
|
||||
|
||||
```sh
|
||||
tricu store alias list --kind modules
|
||||
tricu store alias get --kind modules prelude
|
||||
```
|
||||
|
||||
### REPL
|
||||
|
||||
Running `tricu` with no subcommand starts the REPL. The REPL uses the same
|
||||
filesystem content store and workspace module loader as the CLI.
|
||||
|
||||
Useful commands:
|
||||
|
||||
```text
|
||||
!load FILE load/evaluate a .tri file without printing a result
|
||||
!check FILE run View Contract checking for a file
|
||||
!store [PATH] show or set the content-addressed store
|
||||
!unchecked on evaluate loaded files without contract checking/publishing refs
|
||||
!unchecked off return to normal producer-checked module loading
|
||||
!format decode set output format by name
|
||||
!env list current in-memory bindings
|
||||
```
|
||||
|
||||
`!load` and `!check` support filename tab completion. Normal REPL input also
|
||||
supports tab completion for names currently in the REPL environment.
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "prelude" !Local
|
||||
|
||||
main = lambdaEqualsTC
|
||||
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "../lib/io.tri" !Local
|
||||
!import "prelude" !Local
|
||||
!import "io" !Local
|
||||
|
||||
-- Interaction Tree Effect Runtime
|
||||
--
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 :
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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 :
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "prelude" !Local
|
||||
|
||||
main = exampleTwo
|
||||
-- Level Order Traversal of a labelled binary tree
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
!import "../lib/prelude.tri" !Local
|
||||
!import "prelude" !Local
|
||||
|
||||
main = size size
|
||||
|
||||
|
||||
@@ -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
190
demos/viewContracts.tri
Normal 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
|
||||
137
demos/viewContracts/README.md
Normal file
137
demos/viewContracts/README.md
Normal 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
|
||||
```
|
||||
119
demos/viewContracts/complete.tri
Normal file
119
demos/viewContracts/complete.tri
Normal 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)]
|
||||
9
demos/viewContracts/diagnostic.tri
Normal file
9
demos/viewContracts/diagnostic.tri
Normal 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)
|
||||
116
demos/viewContracts/frontendEmission/README.md
Normal file
116
demos/viewContracts/frontendEmission/README.md
Normal 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.
|
||||
@@ -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)
|
||||
20
demos/viewContracts/frontendEmission/map-success.emitted.tri
Normal file
20
demos/viewContracts/frontendEmission/map-success.emitted.tri
Normal 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)
|
||||
@@ -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)
|
||||
30
demos/viewContracts/io-continuation.tri
Normal file
30
demos/viewContracts/io-continuation.tri
Normal 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)))
|
||||
51
demos/viewContracts/io.tri
Normal file
51
demos/viewContracts/io.tri
Normal 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"))
|
||||
17
demos/viewContracts/modules/README.md
Normal file
17
demos/viewContracts/modules/README.md
Normal 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`.
|
||||
3
demos/viewContracts/modules/failure.tri
Normal file
3
demos/viewContracts/modules/failure.tri
Normal file
@@ -0,0 +1,3 @@
|
||||
!import "vc.demo.util" Util
|
||||
|
||||
foo x@Bool =@Bool Util.toString x
|
||||
3
demos/viewContracts/modules/success.tri
Normal file
3
demos/viewContracts/modules/success.tri
Normal file
@@ -0,0 +1,3 @@
|
||||
!import "vc.demo.util" Util
|
||||
|
||||
foo x@Bool =@Bool Util.id x
|
||||
1
demos/viewContracts/modules/tricu.workspace
Normal file
1
demos/viewContracts/modules/tricu.workspace
Normal file
@@ -0,0 +1 @@
|
||||
module vc.demo.util = util.tri
|
||||
2
demos/viewContracts/modules/util.tri
Normal file
2
demos/viewContracts/modules/util.tri
Normal file
@@ -0,0 +1,2 @@
|
||||
id x@Bool =@Bool x
|
||||
toString x@Bool =@String "ok"
|
||||
3
demos/viewContracts/selfTests.tri
Normal file
3
demos/viewContracts/selfTests.tri
Normal file
@@ -0,0 +1,3 @@
|
||||
!import "views.catalog" !Local
|
||||
|
||||
main = viewCatalogSelfTests
|
||||
9
demos/viewContracts/sourceSyntax/failure.tri
Normal file
9
demos/viewContracts/sourceSyntax/failure.tri
Normal 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"
|
||||
10
demos/viewContracts/sourceSyntax/success.tri
Normal file
10
demos/viewContracts/sourceSyntax/success.tri
Normal 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)
|
||||
10
demos/viewContracts/stdlibContracts.tri
Normal file
10
demos/viewContracts/stdlibContracts.tri
Normal 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)]
|
||||
596
docs/content-store-and-module-format.md
Normal file
596
docs/content-store-and-module-format.md
Normal 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
371
docs/guard-injection.md
Normal 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.
|
||||
505
docs/module-system-design.md
Normal file
505
docs/module-system-design.md
Normal 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.
|
||||
582
docs/view-contract-syntax.md
Normal file
582
docs/view-contract-syntax.md
Normal 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
337
docs/view-contracts.md
Normal 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.
|
||||
@@ -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).
|
||||
|
||||
@@ -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)]
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
!import "arboricx.tri" !Local
|
||||
!import "prelude" !Local
|
||||
!import "arboricx" !Local
|
||||
|
||||
-- Multi-purpose kernel dispatch.
|
||||
-- runArboricxTyped tag bundleBytes args
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -1,4 +1,6 @@
|
||||
!import "common.tri" !Local
|
||||
!import "prelude" !Local
|
||||
!import "binary" !Local
|
||||
!import "arboricx.common" !Local
|
||||
|
||||
-- Indexed Arboricx node section reader.
|
||||
--
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -1,6 +1,4 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "bytes.tri" !Local
|
||||
!import "prelude" !Local
|
||||
|
||||
errUnexpectedEof = 1
|
||||
errUnexpectedBytes = 2
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "base" !Local
|
||||
!import "list" !Local
|
||||
|
||||
bytesNil? = emptyList?
|
||||
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
!import "base.tri" !Local
|
||||
!import "list.tri" !Local
|
||||
!import "base" !Local
|
||||
!import "list" !Local
|
||||
|
||||
incDecRev = y (self : matchList
|
||||
"1"
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
!import "base.tri" !Local
|
||||
!import "base" !Local
|
||||
|
||||
_ = t
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
1560
lib/view.tri
Normal file
File diff suppressed because it is too large
Load Diff
267
lib/views/catalog.tri
Normal file
267
lib/views/catalog.tri
Normal 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
42
src/Check.hs
Normal 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
751
src/Check/Core.hs
Normal 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
409
src/Check/IO.hs
Normal 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 ++ ")"
|
||||
@@ -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
81
src/ContentStore/Alias.hs
Normal 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
|
||||
94
src/ContentStore/Arboricx.hs
Normal file
94
src/ContentStore/Arboricx.hs
Normal 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
|
||||
37
src/ContentStore/Bundle.hs
Normal file
37
src/ContentStore/Bundle.hs
Normal 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)
|
||||
60
src/ContentStore/Filesystem.hs
Normal file
60
src/ContentStore/Filesystem.hs
Normal 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
|
||||
45
src/ContentStore/Object.hs
Normal file
45
src/ContentStore/Object.hs
Normal 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
|
||||
110
src/ContentStore/Resolver.hs
Normal file
110
src/ContentStore/Resolver.hs
Normal 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
|
||||
230
src/ContentStore/ViewContract.hs
Normal file
230
src/ContentStore/ViewContract.hs
Normal 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
|
||||
135
src/ContentStore/ViewTree.hs
Normal file
135
src/ContentStore/ViewTree.hs
Normal 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
|
||||
135
src/Eval.hs
135
src/Eval.hs
@@ -1,20 +1,16 @@
|
||||
module Eval where
|
||||
|
||||
import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.List (partition, (\\), elemIndex, foldl')
|
||||
import Data.Map ()
|
||||
import Data.Set (Set)
|
||||
import Database.SQLite.Simple
|
||||
import Debug.Trace (trace)
|
||||
|
||||
import qualified Data.Foldable as F ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
data DB
|
||||
= BVar Int
|
||||
@@ -43,6 +39,16 @@ evalSingle env term
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SDefAnn name args _ body <- term
|
||||
= let params = annotatedBinders args
|
||||
res = evalASTSync env (if null params then body else SLambda params body)
|
||||
in case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> env
|
||||
| otherwise
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
@@ -87,94 +93,17 @@ evalASTSync env term = case term of
|
||||
SEmpty -> Leaf
|
||||
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
|
||||
|
||||
evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalAST mconn selectedVersions ast = do
|
||||
let varNames = collectVarNames ast
|
||||
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
-- | Evaluate a single AST term using a local environment augmented by
|
||||
-- lazily-resolved store terms.
|
||||
evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
|
||||
evalASTWithEnv mconn localEnv ast = do
|
||||
let varNames = collectVarNames ast
|
||||
storeEnv <- resolveTermsFromStore mconn Map.empty varNames
|
||||
let combinedEnv = Map.union localEnv storeEnv
|
||||
return $ evalASTSync combinedEnv ast
|
||||
|
||||
evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
|
||||
evalSingleWithStore mconn env term
|
||||
| SDef name params body <- term = do
|
||||
res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
|
||||
case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> return env
|
||||
| otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
| otherwise = do
|
||||
res <- evalASTWithEnv mconn env term
|
||||
return $ Map.insert "!result" res env
|
||||
|
||||
evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
|
||||
evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
|
||||
where
|
||||
go env' [] = return env'
|
||||
go env' [def] = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
return $ Map.insert "!result" (result updatedEnv) updatedEnv
|
||||
go env' (def:xs) = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
evalTricuWithStore mconn updatedEnv xs
|
||||
evalAST :: Env -> TricuAST -> IO T
|
||||
evalAST env ast = return $ evalASTSync env ast
|
||||
|
||||
recoverParams :: TricuAST -> TricuAST
|
||||
recoverParams (SDef name [] (SLambda params body)) = SDef name params body
|
||||
recoverParams term = term
|
||||
|
||||
collectVarNames :: TricuAST -> [(String, Maybe String)]
|
||||
collectVarNames = go []
|
||||
where
|
||||
go acc (SVar name mhash) = (name, mhash) : acc
|
||||
go acc (SApp t u) = go (go acc t) u
|
||||
go acc (SLambda vars body) =
|
||||
let boundVars = Set.fromList vars
|
||||
collected = go [] body
|
||||
in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
|
||||
go acc (TStem t) = go acc t
|
||||
go acc (TFork t u) = go (go acc t) u
|
||||
go acc (SList xs) = foldl' go acc xs
|
||||
go acc _ = acc
|
||||
|
||||
resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
|
||||
resolveTermsFromStore Nothing _ _ = return Map.empty
|
||||
resolveTermsFromStore (Just conn) selectedVersions varNames = do
|
||||
foldM (\env (name, mhash) -> do
|
||||
term <- resolveTermFromStore conn selectedVersions name mhash
|
||||
case term of
|
||||
Just t -> return $ Map.insert (getVarKey name mhash) t env
|
||||
Nothing -> return env
|
||||
) Map.empty varNames
|
||||
where
|
||||
getVarKey name Nothing = name
|
||||
getVarKey name (Just hash) = name ++ "#" ++ hash
|
||||
|
||||
resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
|
||||
resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
Just hashPrefix -> do
|
||||
versions <- termVersions conn name
|
||||
let matchingVersions = filter (\(hash, _, _) ->
|
||||
T.isPrefixOf (T.pack hashPrefix) hash) versions
|
||||
case matchingVersions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return Nothing
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> loadTree conn hash
|
||||
Nothing -> do
|
||||
versions <- termVersions conn name
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||
annotatedBinders :: [DefArg] -> [String]
|
||||
annotatedBinders [] = []
|
||||
annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest
|
||||
annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
@@ -262,6 +191,7 @@ freeVars (SVar v (Just _)) = Set.singleton v
|
||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
|
||||
freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args))
|
||||
freeVars (TStem t) = freeVars t
|
||||
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SList xs) = foldMap freeVars xs
|
||||
@@ -275,13 +205,13 @@ reorderDefs env defs
|
||||
| otherwise = orderedDefs ++ others
|
||||
where
|
||||
(defsOnly, others) = partition isDef defs
|
||||
defNames = [ name | SDef name _ _ <- defsOnly ]
|
||||
defNames = [ defName def | def <- defsOnly ]
|
||||
|
||||
defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
|
||||
|
||||
graph = buildDepGraph defsOnly
|
||||
sortedDefs = sortDeps graph
|
||||
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
||||
defMap = Map.fromList [(defName def, def) | def <- defsOnly]
|
||||
orderedDefs = map (defMap Map.!) sortedDefs
|
||||
|
||||
freeVarsDefs = foldMap snd defsWithFreeVars
|
||||
@@ -291,6 +221,7 @@ reorderDefs env defs
|
||||
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||
|
||||
isDef SDef {} = True
|
||||
isDef SDefAnn {} = True
|
||||
isDef _ = False
|
||||
|
||||
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||
@@ -300,11 +231,11 @@ buildDepGraph topDefs
|
||||
"Conflicting definitions detected: " ++ show conflictingDefs
|
||||
| otherwise =
|
||||
Map.fromList
|
||||
[ (name, depends topDefs def)
|
||||
| def@(SDef name _ _) <- topDefs]
|
||||
[ (defName def, depends topDefs def)
|
||||
| def <- topDefs]
|
||||
where
|
||||
defsMap = Map.fromListWith (++)
|
||||
[(name, [(name, body)]) | SDef name _ body <- topDefs]
|
||||
[(defName def, [(defName def, defBody def)]) | def <- topDefs]
|
||||
|
||||
conflictingDefs =
|
||||
[ name
|
||||
@@ -330,10 +261,24 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||
(Set.union sortedSet (Set.fromList ready))
|
||||
notReady
|
||||
|
||||
defName :: TricuAST -> String
|
||||
defName (SDef name _ _) = name
|
||||
defName (SDefAnn name _ _ _) = name
|
||||
defName _ = error "defName: expected definition"
|
||||
|
||||
defBody :: TricuAST -> TricuAST
|
||||
defBody (SDef _ _ body) = body
|
||||
defBody (SDefAnn _ _ _ body) = body
|
||||
defBody _ = error "defBody: expected definition"
|
||||
|
||||
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||
depends topDefs def@(SDef _ _ _) =
|
||||
depends topDefs def@SDef {} =
|
||||
Set.intersection
|
||||
(Set.fromList [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)?
|
||||
|
||||
366
src/FileEval.hs
366
src/FileEval.hs
@@ -1,22 +1,41 @@
|
||||
module FileEval
|
||||
( preprocessFile
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, preprocessFile
|
||||
, preprocessFileWithStore
|
||||
, preprocessFileWithResolver
|
||||
, evaluateFile
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithStore
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithContextWithStore
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileResult
|
||||
, compileFile
|
||||
, compileFileWithStore
|
||||
, loadFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, defaultStorePath
|
||||
) where
|
||||
|
||||
import Eval (evalTricu, evalTricuWithStore)
|
||||
import Check.Core
|
||||
( checkProgramWithEnvAndImportedViews
|
||||
, importedViewsFromResolvedModulesEither
|
||||
, lowerViewExpr
|
||||
)
|
||||
import ContentStore
|
||||
import Eval (evalASTSync, evalTricu, freeVars, result)
|
||||
import Lexer
|
||||
import Module.Manifest
|
||||
import Module.Resolver
|
||||
import Module.Workspace
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
|
||||
import Database.SQLite.Simple (Connection)
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.List (partition, isPrefixOf)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import System.FilePath (takeDirectory, normalise, (</>))
|
||||
import System.Directory (getHomeDirectory, getTemporaryDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import System.Exit (die)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@@ -32,153 +51,262 @@ extractMain env =
|
||||
Just evalResult -> Right evalResult
|
||||
Nothing -> Left "No `main` function detected"
|
||||
|
||||
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
|
||||
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
|
||||
processImports seen _base currentPath asts =
|
||||
data ContractMode
|
||||
= EnforceContracts
|
||||
| IgnoreContracts
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LoadedSource = LoadedSource
|
||||
{ loadedImports :: Env
|
||||
, loadedAst :: [TricuAST]
|
||||
, loadedModules :: [ResolvedModule]
|
||||
}
|
||||
|
||||
data LoadContext = LoadContext
|
||||
{ loadResolver :: ObjectResolver
|
||||
, loadStore :: Maybe StorePath
|
||||
, loadWorkspace :: Workspace
|
||||
, loadContracts :: ContractMode
|
||||
}
|
||||
|
||||
processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
|
||||
processImports asts =
|
||||
let (imports, nonImports) = partition isImp asts
|
||||
importPaths = mapMaybe getImportInfo imports
|
||||
in if currentPath `Set.member` seen
|
||||
then Left $ "Encountered cyclic import: " ++ currentPath
|
||||
else Right (nonImports, importPaths)
|
||||
importTargets = mapMaybe getImportInfo imports
|
||||
in (nonImports, importTargets)
|
||||
where
|
||||
isImp (SImport _ _) = True
|
||||
isImp _ = False
|
||||
getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p)
|
||||
getImportInfo (SImport p n) = Just (p, n)
|
||||
getImportInfo _ = Nothing
|
||||
|
||||
evaluateFileResult :: FilePath -> IO T
|
||||
evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
processedAst <- preprocessFile filePath
|
||||
let finalEnv = evalTricu Map.empty processedAst
|
||||
case extractMain finalEnv of
|
||||
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
|
||||
|
||||
38
src/Lexer.hs
38
src/Lexer.hs
@@ -33,14 +33,16 @@ tricuLexer = do
|
||||
tricuLexer' =
|
||||
[ try lnewline
|
||||
, try indentMarker
|
||||
, try namespace
|
||||
, try dot
|
||||
, try identifierWithHash
|
||||
, try identifier
|
||||
, try keywordT
|
||||
, try identifier
|
||||
, try namespace
|
||||
, try integerLiteral
|
||||
, try stringLiteral
|
||||
, try assignAt
|
||||
, assign
|
||||
, atSign
|
||||
, colon
|
||||
, openParen
|
||||
, closeParen
|
||||
@@ -81,10 +83,10 @@ keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
|
||||
|
||||
identifierWithHash :: Lexer LToken
|
||||
identifierWithHash = do
|
||||
first <- lowerChar <|> char '_'
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '$' <|> char '%'
|
||||
<|> char '\''
|
||||
_ <- char '#' -- Consume '#'
|
||||
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
|
||||
@@ -103,10 +105,10 @@ identifierWithHash = do
|
||||
|
||||
identifier :: Lexer LToken
|
||||
identifier = do
|
||||
first <- lowerChar <|> char '_'
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '$' <|> char '%'
|
||||
<|> char '\''
|
||||
let name = first : rest
|
||||
if name == "t" || name == "!result"
|
||||
@@ -114,12 +116,7 @@ identifier = do
|
||||
else return (LIdentifier name)
|
||||
|
||||
namespace :: Lexer LToken
|
||||
namespace = do
|
||||
name <- try (string "!Local") <|> do
|
||||
first <- upperChar
|
||||
rest <- many (letterChar <|> digitChar)
|
||||
return (first:rest)
|
||||
return (LNamespace name)
|
||||
namespace = LNamespace <$> string "!Local"
|
||||
|
||||
dot :: Lexer LToken
|
||||
dot = char '.' $> LDot
|
||||
@@ -130,12 +127,27 @@ lImport = do
|
||||
space1
|
||||
LStringLiteral path <- stringLiteral
|
||||
space1
|
||||
LNamespace name <- namespace
|
||||
name <- importAlias
|
||||
return (LImport path name)
|
||||
|
||||
importAlias :: Lexer String
|
||||
importAlias = string "!Local" <|> do
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.')
|
||||
let name = first : rest
|
||||
if name == "t" || name == "!result"
|
||||
then fail "Keywords (`t`, `!result`) cannot be used as an import alias"
|
||||
else pure name
|
||||
|
||||
assignAt :: Lexer LToken
|
||||
assignAt = string "=@" $> LAssignAt
|
||||
|
||||
assign :: Lexer LToken
|
||||
assign = char '=' $> LAssign
|
||||
|
||||
atSign :: Lexer LToken
|
||||
atSign = char '@' $> LAt
|
||||
|
||||
colon :: Lexer LToken
|
||||
colon = char ':' $> LColon
|
||||
|
||||
|
||||
339
src/Main.hs
339
src/Main.hs
@@ -1,17 +1,27 @@
|
||||
module Main where
|
||||
|
||||
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
|
||||
import Check (checkFile, checkFileWithStore, instrumentIOContinuations)
|
||||
import ContentStore
|
||||
import ContentStore.Bundle
|
||||
import Module.Manifest
|
||||
import System.Exit (die)
|
||||
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
|
||||
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, compileFileWithStore
|
||||
)
|
||||
import IODriver (IOPermissions(..), runIO)
|
||||
import Parser (parseTricu)
|
||||
import REPL (repl)
|
||||
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
|
||||
import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
|
||||
import Wire (encodeBundle, defaultExportNames, Bundle(..))
|
||||
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Data.Text (unpack, pack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Version (showVersion)
|
||||
import Paths_tricu (version)
|
||||
@@ -20,10 +30,9 @@ import Options.Applicative
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Sequence as Seq
|
||||
import Database.SQLite.Simple (Connection, close)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Directory (getHomeDirectory)
|
||||
import System.FilePath (takeBaseName, (</>))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- CLI argument types
|
||||
@@ -31,11 +40,16 @@ import System.Environment (lookupEnv)
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Check
|
||||
{ checkInput :: FilePath
|
||||
, checkStore :: Maybe FilePath
|
||||
}
|
||||
| Eval
|
||||
{ evalFiles :: [FilePath]
|
||||
, evalStore :: Maybe FilePath
|
||||
, evalFormat :: EvaluatedForm
|
||||
, evalOutput :: FilePath
|
||||
, evalDb :: Maybe FilePath
|
||||
, evalUnchecked :: Bool
|
||||
, evalIo :: Bool
|
||||
, evalAllowRead :: [FilePath]
|
||||
, evalAllowWrite :: [FilePath]
|
||||
@@ -45,21 +59,32 @@ data TricuArgs
|
||||
}
|
||||
| ArboricxCompile
|
||||
{ compileInput :: FilePath
|
||||
, compileStore :: Maybe FilePath
|
||||
, compileOutput :: FilePath
|
||||
, compileNames :: [String]
|
||||
, compileDb :: Maybe FilePath
|
||||
}
|
||||
| ArboricxImport
|
||||
{ importFile :: FilePath
|
||||
, importDb :: Maybe FilePath
|
||||
, 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
|
||||
store <- resolveStorePath (importStore opts)
|
||||
bundleData <- BL.readFile file
|
||||
roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
|
||||
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_ (\r -> putStrLn $ " " ++ r) roots
|
||||
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
|
||||
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 namedTerms) ++ " export(s) to " ++ out
|
||||
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
137
src/Module/Manifest.hs
Normal 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
153
src/Module/Resolver.hs
Normal 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
66
src/Module/Workspace.hs
Normal 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
|
||||
140
src/Parser.hs
140
src/Parser.hs
@@ -75,20 +75,133 @@ topItemP = do
|
||||
|
||||
definitionHeadTop :: [LToken] -> Maybe (String, [String])
|
||||
definitionHeadTop toks =
|
||||
case collectIdentifiersNoNewlines toks of
|
||||
(name:args, LAssign : _)
|
||||
case toks of
|
||||
LIdentifier name : rest
|
||||
| name `Set.notMember` reservedNames
|
||||
, all (`Set.notMember` reservedNames) args -> Just (name, args)
|
||||
, 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,13 +259,15 @@ lambdaHeadNested toks =
|
||||
_ -> Nothing
|
||||
|
||||
collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
|
||||
collectIdentifiersNoNewlines (LIdentifier name : rest) =
|
||||
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) =
|
||||
collectIdentifiersWithNewlines (LIdentifier name : rest)
|
||||
| name `Set.notMember` reservedNames =
|
||||
let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
|
||||
in (name : names, final)
|
||||
collectIdentifiersWithNewlines rest = ([], rest)
|
||||
@@ -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,12 +603,17 @@ 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 (LIdentifier name) = name `Set.notMember` reservedNames
|
||||
isNamespace (LNamespace _) = True
|
||||
isNamespace _ = False
|
||||
|
||||
|
||||
798
src/REPL.hs
798
src/REPL.hs
@@ -1,675 +1,241 @@
|
||||
module REPL where
|
||||
|
||||
import ContentStore
|
||||
import Eval
|
||||
import Check (checkFileWithStore)
|
||||
import Eval (evalTricu, result)
|
||||
import FileEval
|
||||
import Lexer ()
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, importBundle)
|
||||
( 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 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
|
||||
, 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)))
|
||||
where
|
||||
settings :: Settings IO
|
||||
settings = Settings
|
||||
{ complete = completeWord Nothing " \t" completeCommands
|
||||
store <- defaultStorePath
|
||||
envRef <- newIORef Map.empty
|
||||
let settings = Settings
|
||||
{ complete = completeRepl envRef
|
||||
, historyFile = Just "~/.local/state/tricu/history"
|
||||
, autoAddHistory = True
|
||||
}
|
||||
|
||||
completeCommands :: String -> IO [Completion]
|
||||
completeCommands str = return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) commands
|
||||
runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef))
|
||||
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
|
||||
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 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
|
||||
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
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ cleanFilename
|
||||
loop state
|
||||
else importFile state cleanFilename
|
||||
|
||||
importFile :: REPLState -> String -> InputT IO ()
|
||||
importFile state cleanFilename = do
|
||||
_code <- liftIO $ readFile cleanFilename
|
||||
case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
env <- liftIO $ evaluateFile cleanFilename
|
||||
|
||||
liftIO $ do
|
||||
printSuccess $ "Importing file: " ++ cleanFilename
|
||||
let defs = Map.toList $ Map.delete "!result" env
|
||||
|
||||
importedCount <- foldM (\count (name, term) -> do
|
||||
hash <- ContentStore.storeTerm conn [name] term
|
||||
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
return (count + (1 :: Int))
|
||||
) 0 defs
|
||||
|
||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||
|
||||
loop state
|
||||
|
||||
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
|
||||
handleLoad :: REPLState -> String -> InputT IO ()
|
||||
handleLoad state path
|
||||
| null path = outputStrLn "Usage: !load FILE" >> loop state
|
||||
| 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
|
||||
exists <- liftIO $ doesFileExist path
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ inFile
|
||||
loop state
|
||||
then outputStrLn ("File not found: " ++ path) >> 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
|
||||
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
|
||||
|
||||
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"
|
||||
handleStore :: REPLState -> String -> InputT IO ()
|
||||
handleStore state path
|
||||
| null path = do
|
||||
outputStrLn $ "Store: " ++ storePathString (replStore state)
|
||||
loop state
|
||||
| otherwise = do
|
||||
outputStrLn $ "Store changed to: " ++ path
|
||||
loop state { replStore = StorePath path }
|
||||
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
printError $ "Error: " ++ displayException e
|
||||
return state
|
||||
handleUnchecked :: REPLState -> String -> InputT IO ()
|
||||
handleUnchecked state arg = setUnchecked state arg
|
||||
|
||||
setUnchecked :: REPLState -> String -> InputT IO ()
|
||||
setUnchecked state arg = case arg of
|
||||
"" -> reportContracts state >> loop state
|
||||
"on" -> setMode IgnoreContracts
|
||||
"off" -> setMode EnforceContracts
|
||||
_ -> outputStrLn "Usage: !unchecked [on|off]" >> loop state
|
||||
where
|
||||
setMode mode = do
|
||||
outputStrLn $ contractModeMessage mode
|
||||
loop state { replContracts = mode }
|
||||
|
||||
reportContracts :: REPLState -> InputT IO ()
|
||||
reportContracts state = outputStrLn $ contractModeMessage (replContracts 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"
|
||||
let env' = evalTricu (replEnv state) (parseTricu input)
|
||||
writeIORef (replEnvRef state) env'
|
||||
putStrLn $ formatT (replForm state) (result env')
|
||||
return state { replEnv = env' }
|
||||
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
putStrLn $ "Error: " ++ displayException e
|
||||
return state
|
||||
Just conn -> do
|
||||
newState <- foldM (\s astNode -> do
|
||||
let varsInAst = Eval.findVarNames astNode
|
||||
foldM (\currentSelectionState varName ->
|
||||
if Map.member varName (replSelectedVersions currentSelectionState)
|
||||
then return currentSelectionState
|
||||
else do
|
||||
versions <- ContentStore.termVersions conn varName
|
||||
if length versions > 1
|
||||
then do
|
||||
let (latestHash, _, _) = head versions
|
||||
liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent."
|
||||
return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) }
|
||||
else return currentSelectionState
|
||||
) s varsInAst
|
||||
) state asts
|
||||
|
||||
forM_ asts $ \ast -> do
|
||||
case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
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()[]{}\"'"
|
||||
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printSuccess "Stored definition: "
|
||||
printVariable name
|
||||
putStr " with hash "
|
||||
displayColoredHash hash
|
||||
putStrLn ""
|
||||
outputFormats :: [EvaluatedForm]
|
||||
outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
||||
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
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
|
||||
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
return newState
|
||||
contractModeMessage :: ContractMode -> String
|
||||
contractModeMessage EnforceContracts = "Contracts: on"
|
||||
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
|
||||
|
||||
storePathString :: StorePath -> FilePath
|
||||
storePathString (StorePath path) = path
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
strip = f . f
|
||||
where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
|
||||
|
||||
watchLoop :: REPLState -> InputT IO ()
|
||||
watchLoop state = handle (\Interrupt -> do
|
||||
outputStrLn "\nStopped watching file"
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
|
||||
liftIO $ threadDelay 1000000
|
||||
watchLoop state
|
||||
|
||||
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
||||
processWatchedFile filepath mconn selectedVersions outputForm = do
|
||||
content <- readFile filepath
|
||||
let asts = parseTricu content
|
||||
|
||||
case mconn of
|
||||
Nothing -> putStrLn "Content store not initialized for watched file processing."
|
||||
Just conn -> do
|
||||
forM_ asts $ \ast -> case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||
|
||||
formatTimestamp :: Integer -> String
|
||||
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
|
||||
|
||||
displayColoredHash :: T.Text -> IO ()
|
||||
displayColoredHash hash = do
|
||||
let (prefix, rest) = T.splitAt 16 hash
|
||||
setSGR [SetColor Foreground Vivid Cyan]
|
||||
putStr $ T.unpack prefix
|
||||
setSGR [SetColor Foreground Dull White]
|
||||
putStr $ T.unpack rest
|
||||
setSGR [Reset]
|
||||
|
||||
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
||||
withColor intensity color action = do
|
||||
setSGR [SetColor Foreground intensity color]
|
||||
action
|
||||
setSGR [Reset]
|
||||
|
||||
printColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printColored intensity color text = withColor intensity color $ putStr text
|
||||
|
||||
printlnColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printlnColored intensity color text = withColor intensity color $ putStrLn text
|
||||
|
||||
printSuccess :: String -> IO ()
|
||||
printSuccess = printlnColored Vivid Green
|
||||
|
||||
printError :: String -> IO ()
|
||||
printError = printlnColored Vivid Red
|
||||
|
||||
printWarning :: String -> IO ()
|
||||
printWarning = printlnColored Vivid Yellow
|
||||
|
||||
printPrompt :: String -> IO ()
|
||||
printPrompt = printColored Vivid Blue
|
||||
|
||||
printVariable :: String -> IO ()
|
||||
printVariable = printColored Vivid Magenta
|
||||
|
||||
printTag :: String -> IO ()
|
||||
printTag = printColored Vivid Yellow
|
||||
|
||||
printKeyword :: String -> IO ()
|
||||
printKeyword = printColored Vivid Blue
|
||||
|
||||
printResult :: String -> IO ()
|
||||
printResult = printColored Dull White
|
||||
|
||||
displayTags :: [T.Text] -> IO ()
|
||||
displayTags [] = return ()
|
||||
displayTags tags = do
|
||||
putStr " Tags: "
|
||||
forM_ (zip [0..] tags) $ \(i, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (i < length tags - 1) $ putStr ", "
|
||||
putStrLn ""
|
||||
readMaybeInt :: String -> Maybe Int
|
||||
readMaybeInt s = case reads s of
|
||||
[(n, "")] -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
@@ -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
|
||||
|
||||
23
src/Wire.hs
23
src/Wire.hs
@@ -16,11 +16,10 @@ module Wire
|
||||
, decodeBundle
|
||||
, verifyBundle
|
||||
, buildBundle
|
||||
, importBundle
|
||||
, reconstructBundleTerms
|
||||
, defaultExportNames
|
||||
) where
|
||||
|
||||
import ContentStore (storeTerm)
|
||||
import Research hiding (Node)
|
||||
|
||||
import Control.Monad (foldM, forM_, unless, when)
|
||||
@@ -41,7 +40,6 @@ import Data.Vector (Vector)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Vector.Mutable as MV
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
import Database.SQLite.Simple (Connection)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@@ -774,11 +772,11 @@ verifyManifestConstraints manifest = do
|
||||
Left "manifest export has empty name"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Import into content store
|
||||
-- Bundle reconstruction
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
reconstructTerms :: Seq BundleNode -> Vector T
|
||||
reconstructTerms nodes = V.create $ do
|
||||
reconstructBundleTerms :: Seq BundleNode -> Vector T
|
||||
reconstructBundleTerms nodes = V.create $ do
|
||||
let n = Seq.length nodes
|
||||
vec <- MV.new n
|
||||
forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do
|
||||
@@ -792,19 +790,6 @@ reconstructTerms nodes = V.create $ do
|
||||
MV.write vec i t
|
||||
return vec
|
||||
|
||||
importBundle :: Connection -> ByteString -> IO [Text]
|
||||
importBundle conn bs = case decodeBundle bs of
|
||||
Left err -> error $ "Wire.importBundle: " ++ err
|
||||
Right bundle -> case verifyBundle bundle of
|
||||
Left err -> error $ "Wire.importBundle verify: " ++ err
|
||||
Right () -> do
|
||||
let terms = reconstructTerms (bundleNodes bundle)
|
||||
forM_ (manifestExports $ bundleManifest bundle) $ \exp -> do
|
||||
let term = terms V.! fromIntegral (exportRoot exp)
|
||||
_ <- storeTerm conn [T.unpack $ exportName exp] term
|
||||
return ()
|
||||
return $ map exportName $ manifestExports $ bundleManifest bundle
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Primitive binary helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
2105
test/Spec.hs
2105
test/Spec.hs
File diff suppressed because it is too large
Load Diff
@@ -1,4 +0,0 @@
|
||||
|
||||
!import "cycle-2.tri" Cycle2
|
||||
|
||||
cycle1 = t Cycle2.cycle2
|
||||
@@ -1,4 +0,0 @@
|
||||
|
||||
!import "cycle-1.tri" Cycle1
|
||||
|
||||
cycle2 = t Cycle1.cycle1
|
||||
@@ -1 +0,0 @@
|
||||
main = (x : x) t
|
||||
@@ -1,4 +0,0 @@
|
||||
|
||||
!import "2.tri" Two
|
||||
|
||||
main = Two.x
|
||||
@@ -1,2 +0,0 @@
|
||||
|
||||
!import "3.tri" !Local
|
||||
@@ -1 +0,0 @@
|
||||
x = 3
|
||||
@@ -1,2 +0,0 @@
|
||||
!import "multi-level-B.tri" B
|
||||
main = B.main
|
||||
@@ -1,2 +0,0 @@
|
||||
!import "multi-level-C.tri" C
|
||||
main = C.val
|
||||
@@ -1 +0,0 @@
|
||||
val = t
|
||||
@@ -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)
|
||||
@@ -1,2 +0,0 @@
|
||||
|
||||
x = 2
|
||||
@@ -1,2 +0,0 @@
|
||||
|
||||
x = 3
|
||||
@@ -1,2 +0,0 @@
|
||||
!import "namespace-B.tri" B
|
||||
main = B.x
|
||||
@@ -1 +0,0 @@
|
||||
x = t
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user