diff --git a/README.md b/README.md index 7b380cc..2165bea 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ## Introduction -tricu (pronounced "tree-shoe") is an experimental programming language written in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf). I will refer to this "family" of calculi as TC. +tricu (pronounced "tree-shoe") is an experimental programming language written in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf). I refer to this "family" of calculi as TC below. tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`. @@ -37,23 +37,6 @@ tricu > "(t (t (t t) (t t t)) (t t (t t t)))" tricu < -- or calculate its size (/demos/size.tri) tricu < size not? tricu > 12 - -tricu < !help -tricu version 1.1.0 -Available commands: - !exit - Exit the REPL - !clear - Clear the screen - !reset - Reset preferences for selected versions - !help - Show tricu version and available commands - !output - Change output format (tree|fsl|ast|ternary|ascii|decode) - !definitions - List all defined terms in the content store - !import - Import definitions from file to the content store - !watch - Watch a file for changes, evaluate terms, and store them - !versions - Show all versions of a term by name - !select - Select a specific version of a term for subsequent lookups - !tag - Add or update a tag for a term by hash or name - !export - Export a term bundle to file (hash, file) - !bundleimport- Import a bundle file into the content store ``` ## Installation and Use @@ -69,4 +52,67 @@ You can easily build and run this project using [Nix](https://nixos.org/download ## Usage -I'll update this once the CLI stabilizes more. +### CLI + +Evaluate one or more files: + +```sh +tricu eval program.tri +tricu eval --format decode program.tri +tricu eval --output result.txt program.tri +``` + +Annotated programs run normally under `eval`; annotations are metadata, not +runtime types. If you want evaluation to ignore View Contracts completely while +loading workspace modules, use unchecked mode: + +```sh +tricu eval --unchecked program.tri +``` + +Unchecked eval parses annotation syntax, discards contract metadata, skips +producer-side View Contract checks during workspace module auto-builds, and does +not publish unchecked View refs. Executable module exports may still be cached in +the content store. + +Check View Contract annotations explicitly: + +```sh +tricu check program.tri +tricu check --store ./.tricu-store program.tri +``` + +Compile/import/export Arboricx bundles: + +```sh +tricu arboricx compile --file program.tri --output program.arboricx +tricu arboricx import --file program.arboricx --module program +tricu arboricx export --module prelude --output prelude.arboricx +``` + +Inspect store aliases: + +```sh +tricu store alias list --kind modules +tricu store alias get --kind modules prelude +``` + +### REPL + +Running `tricu` with no subcommand starts the REPL. The REPL uses the same +filesystem content store and workspace module loader as the CLI. + +Useful commands: + +```text +!load FILE load/evaluate a .tri file without printing a result +!check FILE run View Contract checking for a file +!store [PATH] show or set the content-addressed store +!unchecked on evaluate loaded files without contract checking/publishing refs +!unchecked off return to normal producer-checked module loading +!format decode set output format by name +!env list current in-memory bindings +``` + +`!load` and `!check` support filename tab completion. Normal REPL input also +supports tab completion for names currently in the REPL environment. diff --git a/demos/equality.tri b/demos/equality.tri index 4988a80..877522e 100644 --- a/demos/equality.tri +++ b/demos/equality.tri @@ -1,4 +1,4 @@ -!import "../lib/prelude.tri" !Local +!import "prelude" !Local main = lambdaEqualsTC diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri index 20346e3..7073b5c 100644 --- a/demos/interactionTrees.tri +++ b/demos/interactionTrees.tri @@ -1,5 +1,5 @@ -!import "../lib/prelude.tri" !Local -!import "../lib/io.tri" !Local +!import "prelude" !Local +!import "io" !Local -- Interaction Tree Effect Runtime -- diff --git a/demos/interactionTrees/arboricxServer.tri b/demos/interactionTrees/arboricxServer.tri index 9741c5d..d424a31 100644 --- a/demos/interactionTrees/arboricxServer.tri +++ b/demos/interactionTrees/arboricxServer.tri @@ -1,5 +1,6 @@ -!import "../../lib/io.tri" !Local -!import "../../lib/arboricx/server.tri" !Local +!import "base" !Local +!import "io" !Local +!import "arboricx.server" !Local -- Arboricx HTTP registry server demo. -- Run with --allow-write ./store --allow-read ./store diff --git a/demos/interactionTrees/echoServer.tri b/demos/interactionTrees/echoServer.tri index 21f3b46..2d85b55 100644 --- a/demos/interactionTrees/echoServer.tri +++ b/demos/interactionTrees/echoServer.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/io.tri" !Local -!import "../../lib/socket.tri" !Local +!import "prelude" !Local +!import "io" !Local +!import "socket" !Local -- Main accept+echo loop. Recursion via y. echoLoop = y (self : server : diff --git a/demos/interactionTrees/environment.tri b/demos/interactionTrees/environment.tri index 543d4d0..d7a7813 100644 --- a/demos/interactionTrees/environment.tri +++ b/demos/interactionTrees/environment.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Environment effects: ask and local. -- ask reads the current environment value. diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri index 4be6a8e..d23c0ae 100644 --- a/demos/interactionTrees/forkAwait.tri +++ b/demos/interactionTrees/forkAwait.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Basic fork and await. -- fork spawns a concurrent task and returns a handle. diff --git a/demos/interactionTrees/getLineAsync.tri b/demos/interactionTrees/getLineAsync.tri index bb9809d..209c1b8 100644 --- a/demos/interactionTrees/getLineAsync.tri +++ b/demos/interactionTrees/getLineAsync.tri @@ -12,7 +12,8 @@ -- 3. You see: -- Hello, ! -!import "../lib/io.tri" !Local +!import "prelude" !Local +!import "io" !Local main = io <| bind (fork getLine) (h : diff --git a/demos/interactionTrees/greet.tri b/demos/interactionTrees/greet.tri index 09dd002..5b65692 100644 --- a/demos/interactionTrees/greet.tri +++ b/demos/interactionTrees/greet.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Greet and return a pure value. -- putStrLn writes to stdout; pure lifts "done" into IO. diff --git a/demos/interactionTrees/httpServer.tri b/demos/interactionTrees/httpServer.tri index f2f36aa..b7520a2 100644 --- a/demos/interactionTrees/httpServer.tri +++ b/demos/interactionTrees/httpServer.tri @@ -1,7 +1,7 @@ -!import "../lib/prelude.tri" !Local -!import "../lib/io.tri" !Local -!import "../lib/socket.tri" !Local -!import "../lib/http.tri" !Local +!import "prelude" !Local +!import "io" !Local +!import "socket" !Local +!import "http" !Local myRouter = (method path headers body : matchBool diff --git a/demos/interactionTrees/safeRead.tri b/demos/interactionTrees/safeRead.tri index b70efe8..2a8c58c 100644 --- a/demos/interactionTrees/safeRead.tri +++ b/demos/interactionTrees/safeRead.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- readFile returns a Result. matchResult branches on ok / err. -- Run with --allow-read PATH or --unsafe-io. diff --git a/demos/interactionTrees/shout.tri b/demos/interactionTrees/shout.tri index 8ca9481..9526865 100644 --- a/demos/interactionTrees/shout.tri +++ b/demos/interactionTrees/shout.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Transform an IO result. -- mapIO applies a pure function to the value produced by an action. diff --git a/demos/interactionTrees/state.tri b/demos/interactionTrees/state.tri index f986241..0976f5c 100644 --- a/demos/interactionTrees/state.tri +++ b/demos/interactionTrees/state.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Mutable state via get and put. -- get reads the current state. diff --git a/demos/interactionTrees/writeThenRead.tri b/demos/interactionTrees/writeThenRead.tri index 84f6d63..15aacbd 100644 --- a/demos/interactionTrees/writeThenRead.tri +++ b/demos/interactionTrees/writeThenRead.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Write a file, then read it back. -- thenIO discards the writeFile Result and continues. diff --git a/demos/interactionTrees/yield.tri b/demos/interactionTrees/yield.tri index 0f55a55..bf9e883 100644 --- a/demos/interactionTrees/yield.tri +++ b/demos/interactionTrees/yield.tri @@ -1,6 +1,6 @@ -!import "../../lib/base.tri" !Local -!import "../../lib/list.tri" !Local -!import "../../lib/io.tri" !Local +!import "base" !Local +!import "list" !Local +!import "io" !Local -- Cooperative scheduling with yield. -- yield returns control to the scheduler so other tasks can run. diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri index 97c9a83..639c88e 100644 --- a/demos/levelOrderTraversal.tri +++ b/demos/levelOrderTraversal.tri @@ -1,4 +1,4 @@ -!import "../lib/prelude.tri" !Local +!import "prelude" !Local main = exampleTwo -- Level Order Traversal of a labelled binary tree diff --git a/demos/patternMatching.tri b/demos/patternMatching.tri index 88f733d..2875f65 100644 --- a/demos/patternMatching.tri +++ b/demos/patternMatching.tri @@ -1,4 +1,4 @@ -!import "../lib/patterns.tri" !Local +!import "patterns" !Local -- We can do conditional pattern matching by providing a list of lists, where -- each sublist contains a boolean expression and a function to return if said diff --git a/demos/runArboricxBundle.tri b/demos/runArboricxBundle.tri index c633965..29f74f9 100644 --- a/demos/runArboricxBundle.tri +++ b/demos/runArboricxBundle.tri @@ -1,6 +1,6 @@ -!import "../lib/prelude.tri" !Local -!import "../lib/io.tri" !Local -!import "../lib/arboricx/arboricx.tri" !Local +!import "prelude" !Local +!import "io" !Local +!import "arboricx" !Local -- Read an Arboricx bundle from disk and execute it. -- This demo loads test/fixtures/id.arboricx and applies the diff --git a/demos/size.tri b/demos/size.tri index 884d511..f9e3c44 100644 --- a/demos/size.tri +++ b/demos/size.tri @@ -1,4 +1,4 @@ -!import "../lib/prelude.tri" !Local +!import "prelude" !Local main = size size diff --git a/demos/toSource.tri b/demos/toSource.tri index 305a136..ac74337 100644 --- a/demos/toSource.tri +++ b/demos/toSource.tri @@ -1,4 +1,4 @@ -!import "../lib/prelude.tri" !Local +!import "prelude" !Local main = toSource not? -- Thanks to intensionality, we can inspect the structure of a given value diff --git a/demos/viewContracts.tri b/demos/viewContracts.tri new file mode 100644 index 0000000..141002c --- /dev/null +++ b/demos/viewContracts.tri @@ -0,0 +1,190 @@ +!import "prelude" !Local +!import "view" !Local + +-- ============================================================================ +-- View Contracts in tricu +-- ============================================================================ +-- +-- Verify this guide passes checking with: +-- +-- tricu check demos/viewContracts.tri +-- +-- Expected output: +-- +-- ok +-- +-- This file uses tricu syntax sugar. The lower-level portable View Tree +-- form is shown in demos/viewContracts/complete.tri. + +-- ============================================================================ +-- 1. What's the problem? +-- ============================================================================ +-- +-- Programs grow by connecting definitions. A common mistake is connecting a +-- value with one shape to code that expects another shape: +-- +-- a function expects Bool, but receives String +-- a function returns String, but its caller expects Bool +-- a list is expected to contain bytes, but contains strings +-- +-- In a large program, those mistakes are often far away from where the bad value +-- was first introduced. View Contracts give tricu a portable way to check those +-- boundaries. + +-- ============================================================================ +-- 2. Views: useful built-in shapes +-- ============================================================================ +-- +-- A View is a description of the shape we expect at a boundary. tricu includes +-- built-in Views for common shapes such as: +-- +-- Bool +-- String +-- Byte +-- Unit +-- List View +-- Maybe View +-- Pair View1 View2 +-- Fn [View1] View2 +-- +-- tricu has unconventional but intuitive sugar for annotations: +-- +-- name =@View value +-- function argument@View =@ResultView body +-- +-- These examples are ordinary checked source definitions. + +message =@String "hello" + +names =@(List String) [("Ada") ("Grace")] + +chooseFirst left@String right@String =@String left + +stringIdentity =@(Fn [String] String) (x : x) + +-- Uncommenting the below definition demonstrates a plain View mismatch: +-- +-- bad =@Bool "not a Bool" +-- +-- `tricu check` reports that the value is known as String where Bool was +-- required. + +-- ============================================================================ +-- 3. Why don't you just have Types? +-- ============================================================================ +-- +-- tricu is built on Tree Calculus. A defining feature of Tree Calculus is +-- intensionality: programs can inspect and construct program-shaped trees directly. +-- That intensional power is useful, but it makes ordinary sound static typing a +-- hard fit. A value can be both data and executable structure, and code can make +-- decisions based on tree shape in ways a conventional type checker may not be +-- able to predict soundly. This is an area of active research, not a settled +-- claim that Tree Calculus languages cannot ever have useful typed variants. +-- +-- View Contracts are not advertised as "the type system for tricu". They are +-- a practical contract layer: portable metadata plus checker/runtime boundaries +-- that catch many real mistakes while leaving the underlying language intact. + +-- For more information about sound typing for Tree Calculus: +-- https://github.com/barry-jay-personal/typed_tree_calculus + +-- ============================================================================ +-- 4. What are the Contracts about, then? +-- ============================================================================ +-- +-- `List String` tells us that every element is a String. It does not tell us the +-- list has at least one element. +-- +-- That matters for functions like `head`. Calling `head` on an empty list is a +-- bug. We want to express the stronger requirement: +-- +-- this is a List String, and it is non-empty +-- +-- That is what a guarded View is for. + +-- A guard is ordinary tricu code. It receives the runtime value and returns: +-- +-- guardOk value -- accept the value +-- guardFail -- reject the boundary +-- +-- The guard does not write diagnostics. The checked runner reports where the +-- failing boundary came from. + +requireNonEmpty = (xs : + lazyBool + (_ : guardFail) + (_ : guardOk xs) + (emptyList? xs)) + +-- A user-defined View can be parameterized just like an ordinary function. +-- +-- NonEmptyList String +-- +-- means "a List String guarded by requireNonEmpty". + +NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty + +-- ============================================================================ +-- 5. Using a custom View in normal annotations +-- ============================================================================ +-- +-- This value satisfies the custom contract. + +contributors =@(NonEmptyList String) [("Ada") ("Grace")] + +-- This function requires NonEmptyList String before its body can run. In a +-- library, this is the kind of contract you would put on an operation like +-- `head`: callers must prove the list is non-empty first. + +acceptNames xs@(NonEmptyList String) =@String "accepted non-empty names" + +primaryContributor =@String acceptNames contributors + +-- Uncommenting this definition demonstrates a guarded View failure: +-- +-- nobody =@(NonEmptyList String) [] +-- +-- The structure is fine (`[]` is a List String), but the runtime guard rejects +-- it because the list is empty. + +-- ============================================================================ +-- 6. Contracts protect callers too +-- ============================================================================ +-- +-- Contracts can describe function results as well as arguments. If a function +-- promises to return `NonEmptyList String`, checked execution guards that result +-- before callers depend on it. + +mkContributors name@String =@(NonEmptyList String) [(name)] + +fromSingleName =@String acceptNames (mkContributors "Evelyn") + +-- Uncommenting this version would fail because the result contract is too +-- strong for the implementation: +-- +-- badContributors name@String =@(NonEmptyList String) [] + +-- ============================================================================ +-- 7. Writing your own Views and Contracts +-- ============================================================================ +-- +-- The pattern is: +-- +-- 1. Start with the closest structural View. +-- 2. Write a guard for the runtime fact the structure cannot express. +-- 3. Package them with viewGuarded. +-- 4. Use the new View in normal annotations. +-- +-- Examples of useful guarded Views: +-- +-- NonEmptyList String +-- SortedList Byte +-- FixedLengthBytes 32 +-- ValidUserId +-- NonEmptyString +-- +-- Guards are intentionally runtime checks. Use plain Views for ordinary shape +-- checking, and guarded Views when a boundary really must enforce a stronger +-- invariant. + +main =@String primaryContributor diff --git a/demos/viewContracts/README.md b/demos/viewContracts/README.md new file mode 100644 index 0000000..8045465 --- /dev/null +++ b/demos/viewContracts/README.md @@ -0,0 +1,137 @@ +# View Contract Demos + +These demos exercise the finalized View Contract stack in `lib/view.tri`: +portable View Trees/checkable typed-program nodes, structural View flow checks, +runtime guarded Views, checked-exec, source annotations, and module-boundary +View metadata. + +## End-user guide + +Start here. `demos/viewContracts.tri` is written with normal source annotation +sugar and reads as a short guide to View Contracts: motivating structural +mismatches, explaining plain Views, noting why this is not a full static type +system, and building a custom `NonEmptyList` guarded View. + +```bash +tricu check demos/viewContracts.tri +``` + +Expected output: + +```text +ok +``` + +## Complete explicit demo + +`demos/viewContracts/complete.tri` shows the same layer from the portable +View Tree/checkable-program side. It uses explicit builders such as +`typedValue`, `typedRequire`, and `typedApply`, and demonstrates contextual guard +diagnostics, observation composition, reachability, and malformed guard output. + +```bash +tricu eval demos/viewContracts/complete.tri -f decode +``` + +## Portable checker self-tests + +Runs the checker self-test suite carried as ordinary `tricu` code. + +```bash +tricu eval demos/viewContracts/selfTests.tri -f decode +``` + +Expected output is a list of `"ok"` strings. + +## Diagnostic rendering + +Shows a strict-mode structural View failure rendered for humans. + +```bash +tricu eval demos/viewContracts/diagnostic.tri -f decode +``` + +Expected output: + +```text +"symbol 162 expected List Bool but got List String" +``` + +## Stdlib-shaped contracts + +Checks successful higher-order contracts shaped like common stdlib APIs. + +```bash +tricu eval demos/viewContracts/stdlibContracts.tri -f decode +``` + +Expected output: + +```text +["ok", "ok", "ok", "ok", "ok"] +``` + +These examples are structural View checks, not runtime guarded checks. + +## Frontend emission layer + +`frontendEmission/` documents the portable artifact shape a frontend can emit +after parsing/elaboration. The `*.source.txt` files are pseudo-source; the +matching `*.emitted.tri` files are explicit typed-program builder output. + +This layer is still instructive because it shows the exact bridge between source +syntax and portable View Tree/checkable metadata. + +## Source syntax sugar + +The `sourceSyntax/` demos use ergonomic annotations and the `tricu check` +frontend. The frontend lowers annotations to the same typed-program nodes used by +the explicit demos above, then executes checked-exec so guarded annotations fail +through the portable runner. + +Successful check: + +```bash +tricu check demos/viewContracts/sourceSyntax/success.tri +``` + +Expected output: + +```text +ok +``` + +Labeled diagnostic check: + +```bash +tricu check demos/viewContracts/sourceSyntax/failure.tri +``` + +Expected first failing diagnostic: + +```text +symbol 4 (x) expected Bool but got String +``` + +If the first definition is fixed or removed, the later application-result +failure demonstrates callee-aware labels: + +```text +symbol 3 (g application result) expected String but got Bool +``` + +## Module boundary layer + +`modules/` shows producer-checked module export Views flowing into a consumer +check as module-boundary evidence. During auto-build, annotated exports are +checked before the module manifest alias is published. Consumers then use the +manifest's View Contract metadata as assumptions, while compatibility is still +judged by `lib/view.tri`. + +```bash +tricu check demos/viewContracts/modules/success.tri +# ok + +tricu check demos/viewContracts/modules/failure.tri +# symbol 3 (Util.toString application result) expected Bool but got String +``` diff --git a/demos/viewContracts/complete.tri b/demos/viewContracts/complete.tri new file mode 100644 index 0000000..f5e9bda --- /dev/null +++ b/demos/viewContracts/complete.tri @@ -0,0 +1,119 @@ +!import "prelude" !Local +!import "view" !Local + +-- Complete explicit View Contract demo. +-- Run with: tricu eval demos/viewContracts/complete.tri -f decode +-- +-- This file uses the low-level portable typed-program builders directly. It is +-- useful for understanding what source annotations lower to. For the end-user +-- guide, see demos/viewContracts.tri. + +requireNonEmpty = (xs : + lazyBool + (_ : guardFail) + (_ : guardOk xs) + (emptyList? xs)) + +NonEmptyList = (elemView : + viewGuarded (viewList elemView) requireNonEmpty) + +checkedResult = (result : + matchResult + (diag env : renderDiagnostic diag) + (exec env : + matchResult + (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) + (value runtimeEnv : value) + (runChecked exec)) + result) + +checkedContract = (program : + checkedResult (checkTypedProgramWith policyStrict program)) + +plainViewFailure = + matchResult + (diag env : renderDiagnostic diag) + (exec env : "unexpected-ok") + (checkTypedProgramWith + policyStrict + (typedProgram + 0 + [(typedValue 0 (viewList viewString) [("Ada")]) + (typedRequire 0 (viewList viewBool) t)])) + +nonEmptyRootSuccess = + matchBool + "ok" + "unexpected-value" + (equal? + (checkedContract + (typedProgram + 0 + [(typedValue 0 (NonEmptyList viewString) [("Ada") ("Grace")])])) + [("Ada") ("Grace")]) + +nonEmptyRootFailure = + checkedContract + (typedProgram + 0 + [(typedValue 0 (viewList viewString) []) + (typedRequire 0 (NonEmptyList viewString) [])]) + +firstNameSuccess = + checkedContract + (typedProgram + 2 + [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs)) + (typedValue 1 (viewList viewString) [("Ada") ("Grace")]) + (typedApply 2 0 1 "Ada") + (typedRequire 2 viewString "Ada")]) + +firstNameFailure = + checkedContract + (typedProgram + 2 + [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs)) + (typedValue 1 (viewList viewString) []) + (typedApply 2 0 1 t) + (typedRequire 2 viewString t)]) + +resultGuardFailure = + checkedContract + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewString)] (NonEmptyList viewString)) (name : [])) + (typedValue 1 viewString "Ada") + (typedApply 2 0 1 [])]) + +observationComposition = + checkedContract + (typedProgram + 0 + [(typedValue 0 viewString "Ada") + (typedRequire 0 (viewGuarded viewString (x : guardOk (append x " Lovelace"))) "Ada") + (typedRequire 0 (viewGuarded viewString (x : guardOk (append x "!"))) "Ada")]) + +unreachableGuard = + checkedContract + (typedProgram + 0 + [(typedValue 0 viewString "only the root is checked") + (typedValue 1 (viewList viewString) []) + (typedRequire 1 (NonEmptyList viewString) [])]) + +malformedGuard = + checkedContract + (typedProgram + 0 + [(typedValue 0 (viewGuarded viewString (x : record 99 t)) "bad guard")]) + +main = [ + (append "plain View structural failure: " plainViewFailure) + (append "NonEmptyList root success: " nonEmptyRootSuccess) + (append "NonEmptyList root failure: " nonEmptyRootFailure) + (append "NonEmptyList function argument success: " firstNameSuccess) + (append "NonEmptyList function argument failure: " firstNameFailure) + (append "NonEmptyList function result failure: " resultGuardFailure) + (append "guard observations compose: " observationComposition) + (append "unreachable guard does not run: " unreachableGuard) + (append "malformed guard result: " malformedGuard)] diff --git a/demos/viewContracts/diagnostic.tri b/demos/viewContracts/diagnostic.tri new file mode 100644 index 0000000..b0c27e1 --- /dev/null +++ b/demos/viewContracts/diagnostic.tri @@ -0,0 +1,9 @@ +!import "prelude" !Local +!import "view" !Local +!import "views.catalog" !Local + +main = + matchResult + (diag env : renderDiagnostic diag) + (env rest : "ok") + (checkTypedProgramWith policyStrict listMapWrongListArgContract) diff --git a/demos/viewContracts/frontendEmission/README.md b/demos/viewContracts/frontendEmission/README.md new file mode 100644 index 0000000..6494a5d --- /dev/null +++ b/demos/viewContracts/frontendEmission/README.md @@ -0,0 +1,116 @@ +# Frontend Emission Demos + +These examples show the layer between source-level View annotations and the +portable View Contract checker. + +Each `*.source.txt` file is pseudo-source: it is not parsed by `tricu`. It shows +the information a frontend has after parsing/elaboration. + +Each matching `*.emitted.tri` file shows the lowered typed-program metadata that +a frontend can emit today. A successful check returns checked-exec; these demos +focus on structural Views, so they report `"ok"` as soon as metadata checking +succeeds. Guarded programs should run the returned checked-exec with +`runChecked`, as shown in `demos/viewContracts.tri` and by `tricu check`. + +## Successful map use + +Pseudo-source: + +```text +map : Fn [Fn [Bool] String, List Bool] (List String) +f : Fn [Bool] String +xs : List Bool + +partial = map f +out = partial xs + +require out : List String +``` + +Run the emitted artifact: + +```bash +tricu eval demos/viewContracts/frontendEmission/map-success.emitted.tri -f decode +``` + +Expected output: + +```text +"ok" +``` + +## Wrong list argument + +Pseudo-source: + +```text +map : Fn [Fn [Bool] String, List Bool] (List String) +f : Fn [Bool] String +xs : List String + +partial = map f +out = partial xs +``` + +Run: + +```bash +tricu eval demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri -f decode +``` + +Expected output: + +```text +"symbol 162 expected List Bool but got List String" +``` + +## Wrong filter predicate + +Pseudo-source: + +```text +filter : Fn [Fn [Bool] Bool, List Bool] (List Bool) +pred : Fn [Bool] String +xs : List Bool + +partial = filter pred +out = partial xs +``` + +Run: + +```bash +tricu eval demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri -f decode +``` + +Expected output: + +```text +"symbol 181 expected Fn [Bool] Bool but got Fn [Bool] String" +``` + +## Lowering shape + +A frontend does not need to expose `tricu` syntax internally. It only needs to +emit portable typed-program nodes: + +```text +typedValue symbol view term +typedApply out callee arg term +typedRequire symbol view term +``` + +The source-level flow: + +```text +out = map f xs +``` + +lowers to curried Tree Calculus application nodes: + +```text +typedApply partial map f partialTerm +typedApply out partial xs outTerm +``` + +Function Views drive argument checking and result inference. diff --git a/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri b/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri new file mode 100644 index 0000000..0f8d58f --- /dev/null +++ b/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri @@ -0,0 +1,17 @@ +!import "prelude" !Local +!import "view" !Local +!import "views.catalog" !Local + +-- Lowering of filter-wrong-predicate.source.txt to portable typed-program metadata. +-- Symbols: +-- 180 filter +-- 181 pred +-- 182 partial + +program = listFilterWrongPredicateContract + +main = + matchResult + (diag env : renderDiagnostic diag) + (env rest : "unexpected-ok") + (checkTypedProgramWith policyStrict program) diff --git a/demos/viewContracts/frontendEmission/map-success.emitted.tri b/demos/viewContracts/frontendEmission/map-success.emitted.tri new file mode 100644 index 0000000..2341529 --- /dev/null +++ b/demos/viewContracts/frontendEmission/map-success.emitted.tri @@ -0,0 +1,20 @@ +!import "prelude" !Local +!import "view" !Local +!import "views.catalog" !Local + +-- Lowering of map-success.source.txt to portable typed-program metadata. +-- Symbols: +-- 100 map +-- 101 f +-- 102 xs +-- 103 partial +-- 104 out + +program = + listMapUseContract viewBool viewString 100 101 102 103 104 + +main = + matchResult + (diag env : renderDiagnostic diag) + (env rest : "ok") + (checkTypedProgramWith policyStrict program) diff --git a/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri b/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri new file mode 100644 index 0000000..06aeda4 --- /dev/null +++ b/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri @@ -0,0 +1,19 @@ +!import "prelude" !Local +!import "view" !Local +!import "views.catalog" !Local + +-- Lowering of map-wrong-list.source.txt to portable typed-program metadata. +-- Symbols: +-- 160 map +-- 161 f +-- 162 xs +-- 163 partial +-- 164 out + +program = listMapWrongListArgContract + +main = + matchResult + (diag env : renderDiagnostic diag) + (env rest : "unexpected-ok") + (checkTypedProgramWith policyStrict program) diff --git a/demos/viewContracts/io-continuation.tri b/demos/viewContracts/io-continuation.tri new file mode 100644 index 0000000..0437e95 --- /dev/null +++ b/demos/viewContracts/io-continuation.tri @@ -0,0 +1,30 @@ +!import "prelude" !Local +!import "io" !Local +!import "view" !Local + +-- View Contracts inside IO continuations +-- Run with: +-- +-- tricu eval demos/viewContracts/io-continuation.tri --io -f decode +-- +-- Checked IO evaluation instruments continuation bodies once from source +-- annotations. The IO runtime still executes ordinary interaction-tree actions; +-- the returned continuations already contain the checked-exec guard boundaries. + +requireNonEmpty = (xs : + lazyBool + (_ : guardFail) + (_ : guardOk xs) + (emptyList? xs)) + +NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty + +acceptNames xs@(NonEmptyList String) =@String "accepted" + +useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String + handler xs + +-- The IO action yields an empty list. The higher-order boundary requires a +-- handler that accepts NonEmptyList String, so the continuation-internal pure +-- call fails before returning the next IO value. +main = io (bind (pure []) (xs : pure (useHandler acceptNames xs))) diff --git a/demos/viewContracts/io.tri b/demos/viewContracts/io.tri new file mode 100644 index 0000000..b453af6 --- /dev/null +++ b/demos/viewContracts/io.tri @@ -0,0 +1,51 @@ +!import "prelude" !Local +!import "io" !Local +!import "view" !Local + +-- View Contracts + IO interaction trees +-- Run with: +-- +-- tricu eval demos/viewContracts/io.tri --io -f decode +-- +-- The IO runtime expects the top-level value to be an interaction tree wrapped +-- by the `io` sentinel: +-- +-- pair "tricuIO" (pair version action) +-- +-- View Contracts can validate that boundary before the IO driver starts. The IO +-- value is still just an interaction tree; this demo only checks how it was +-- exposed. + +ioSentinel? = (value : + and? + (equal? (fst value) "tricuIO") + (equal? (fst (snd value)) 1)) + +requireIO = (value : + lazyBool + (_ : guardOk value) + (_ : guardFail) + (ioSentinel? value)) + +-- A first useful IO View is intentionally shallow: +-- +-- viewAny -- accept any payload structurally +-- requireIO sentinel -- require the top-level IO wrapper at runtime +-- +-- This does not prove every future continuation step is well-formed. It proves +-- the checked program exposes an IO interaction tree to the host driver. +viewIO = viewGuarded viewAny requireIO + +checkedIO = (action : + matchResult + (diag env : io (pure (renderDiagnostic diag))) + (exec env : + matchResult + (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag))) + (value runtimeEnv : value) + (runChecked exec)) + (checkTypedProgramWith + policyStrict + (typedProgram 0 [(typedValue 0 viewIO action)]))) + +main = checkedIO (io (pure "checked interaction tree")) diff --git a/demos/viewContracts/modules/README.md b/demos/viewContracts/modules/README.md new file mode 100644 index 0000000..3e6f203 --- /dev/null +++ b/demos/viewContracts/modules/README.md @@ -0,0 +1,17 @@ +# Module View Contract demo + +This demo shows producer-checked module export Views flowing into a consumer +check as trusted View Contract evidence. + +```sh +tricu check demos/viewContracts/modules/success.tri +# ok + +tricu check demos/viewContracts/modules/failure.tri +# symbol 3 (Util.toString application result) expected Bool but got String +``` + +`util.tri` is a local workspace module. During auto-build, its annotated exports +are checked before the module manifest alias is published. The consumer then +uses the manifest's View Contract metadata and View Tree export artifacts as +module-boundary assumptions; compatibility is still judged by `lib/view.tri`. diff --git a/demos/viewContracts/modules/failure.tri b/demos/viewContracts/modules/failure.tri new file mode 100644 index 0000000..5e581fc --- /dev/null +++ b/demos/viewContracts/modules/failure.tri @@ -0,0 +1,3 @@ +!import "vc.demo.util" Util + +foo x@Bool =@Bool Util.toString x diff --git a/demos/viewContracts/modules/success.tri b/demos/viewContracts/modules/success.tri new file mode 100644 index 0000000..2bc3809 --- /dev/null +++ b/demos/viewContracts/modules/success.tri @@ -0,0 +1,3 @@ +!import "vc.demo.util" Util + +foo x@Bool =@Bool Util.id x diff --git a/demos/viewContracts/modules/tricu.workspace b/demos/viewContracts/modules/tricu.workspace new file mode 100644 index 0000000..dc33128 --- /dev/null +++ b/demos/viewContracts/modules/tricu.workspace @@ -0,0 +1 @@ +module vc.demo.util = util.tri diff --git a/demos/viewContracts/modules/util.tri b/demos/viewContracts/modules/util.tri new file mode 100644 index 0000000..18e3b9e --- /dev/null +++ b/demos/viewContracts/modules/util.tri @@ -0,0 +1,2 @@ +id x@Bool =@Bool x +toString x@Bool =@String "ok" diff --git a/demos/viewContracts/selfTests.tri b/demos/viewContracts/selfTests.tri new file mode 100644 index 0000000..8d8d7bb --- /dev/null +++ b/demos/viewContracts/selfTests.tri @@ -0,0 +1,3 @@ +!import "views.catalog" !Local + +main = viewCatalogSelfTests diff --git a/demos/viewContracts/sourceSyntax/failure.tri b/demos/viewContracts/sourceSyntax/failure.tri new file mode 100644 index 0000000..64ccf93 --- /dev/null +++ b/demos/viewContracts/sourceSyntax/failure.tri @@ -0,0 +1,9 @@ +-- Source-level View Contract diagnostic demo. +-- Run with: tricu check demos/viewContracts/sourceSyntax/failure.tri + +makeBool x@String =@Bool x + +xs =@(List String) [(g "hi")] +g y@String =@Bool y + +main = "if you're seeing this instead of an error, you ran the file unchecked" diff --git a/demos/viewContracts/sourceSyntax/success.tri b/demos/viewContracts/sourceSyntax/success.tri new file mode 100644 index 0000000..8493fd5 --- /dev/null +++ b/demos/viewContracts/sourceSyntax/success.tri @@ -0,0 +1,10 @@ +-- Source-level View Contract syntax sugar demo. +-- Run with: tricu check demos/viewContracts/sourceSyntax/success.tri + +message =@String "hello" + +boxedMessages =@(Maybe (List String)) just [(message) ("world")] + +chooseFirst x@String y@Byte =@String x + +fromLambda =@(Fn [String] String) (x : x) diff --git a/demos/viewContracts/stdlibContracts.tri b/demos/viewContracts/stdlibContracts.tri new file mode 100644 index 0000000..1aea06d --- /dev/null +++ b/demos/viewContracts/stdlibContracts.tri @@ -0,0 +1,10 @@ +!import "prelude" !Local +!import "view" !Local +!import "views.catalog" !Local + +main = [ + (typedContractCheck listMapBoolStringContract) + (typedContractCheck headMaybeBoolContract) + (typedContractCheck listFilterBoolContract) + (typedContractCheck listFoldStringBoolContract) + (typedContractCheck listMapMaybeBoolStringContract)] diff --git a/docs/content-store-and-module-format.md b/docs/content-store-and-module-format.md new file mode 100644 index 0000000..f004322 --- /dev/null +++ b/docs/content-store-and-module-format.md @@ -0,0 +1,596 @@ +# Content Store and Module Format Design + +Status: concrete design draft. + +This document narrows the higher-level module-system direction into concrete +format and storage decisions. It intentionally avoids source/provenance details: +modules export usable portable artifacts, not edit history. + +Related design overview: `docs/module-system-design.md`. + +## 1. Scope + +This document specifies the first target shape for: + +- a neutral filesystem-backed content-addressed store; +- Arboricx Merkle node persistence; +- indexed Arboricx bundle import/export as transport; +- module manifests as immutable export maps; +- workspace aliases as mutable human-facing references; +- View Contract artifact attachment to module exports. + +It does not specify: + +- package manager semantics; +- dependency solving; +- source-level rebuild/provenance metadata; +- final import syntax; +- garbage collection; +- registry/sync protocol. + +## 2. Non-Negotiable Boundaries + +The content store is not `tricu`-specific and is not Haskell-specific. + +The store may contain objects produced by `tricu`, Haskell, Tree Calculus tools, +Arboricx tooling, or future frontends. The store core only knows object bytes, +object kinds, hashes, aliases, and optionally structural references for known +portable formats. + +View Contracts may be first-class artifact references because they are portable +Tree Calculus data checked by pure Tree Calculus code. They are not +Haskell-private semantics. + +Source and build provenance are intentionally excluded from the first module +manifest format. A module manifest answers: + +```text +What portable artifacts does this module export, and what portable contracts are +paired with them? +``` + +It does not answer: + +```text +Which source file, parser, frontend, or build command produced these artifacts? +``` + +## 3. Hashing Convention + +Objects are content-addressed by SHA-256 over domain-separated canonical bytes. + +General rule: + +```text +hash = SHA256(domainUtf8 || 0x00 || canonicalPayloadBytes) +``` + +This matches the existing Merkle node convention in `Research.nodeHash`: + +```text +SHA256("arboricx.merkle.node.v1" || 0x00 || nodePayload) +``` + +The domain string is part of the object format. It prevents identical payload +bytes in different formats from accidentally sharing identity. + +Hashes are represented externally as 64 lowercase hexadecimal characters. + +## 4. Filesystem Store Layout + +The canonical filesystem store layout is: + +```text +store/ + objects/ + abc/ + abc123... -- object bytes, sharded by first 3 hex chars + aliases/ + names/ + modules/ + packages/ + manifests/ + tmp/ +``` + +The three-character shard follows the existing `lib/arboricx/server.tri` +convention. + +### 4.1 Object paths + +For object hash: + +```text +abc123... +``` + +object bytes live at: + +```text +store/objects/abc/abc123... +``` + +The object filename is the full hash. The shard directory is the first three hex +characters. + +### 4.2 Atomic writes + +Writers should use: + +```text +store/tmp/..tmp +``` + +then atomically rename into: + +```text +store/objects// +``` + +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: +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: + kind: + hash: + + exports: + - name: + object: + kind: + hash: + abi: + view: optional + kind: + hash: + catalog: optional + kind: + 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: +``` + +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: + abi: arboricx.abi.tree.v1 +``` + +Export with View Contract: + +```text +name: "map" +object: + kind: arboricx.tree-term.v1 + hash: + abi: arboricx.abi.tree.v1 +view: + kind: arboricx.view-contract.type.v1 + 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: numeric/legacy ref +s: 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 +``` + +### 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/ +store/aliases/names/ +store/aliases/packages/ +``` + +Alias file contents should be simple and explicit, for example: + +```text +kind: arboricx.module-manifest.v1 +hash: abc123... +``` + +Exact encoding can be decided with the first implementation. The important rule +is that aliases are mutable pointers, not content identity. + +## 11. Existing Convention Alignment + +This design intentionally preserves existing conventions where they already fit: + +- SHA-256 domain-separated Merkle node hashing; +- `Leaf` / `Stem` / `Fork` node payload tags `0x00`, `0x01`, `0x02`; +- three-character object sharding from `lib/arboricx/server.tri`; +- indexed Arboricx bundles as compact transport objects; +- optional human-facing export names in manifests; +- View Contract checker evidence as portable Tree Calculus data. + +It replaces or demotes conventions that do not fit: + +- SQLite `terms.names` comma-separated aliases become workspace aliases/indexes; +- SQLite `terms.tags` comma-separated tags become optional metadata/indexes; +- file imports as AST flattening become transitional behavior; +- names cease to be semantic identity. + +## 12. Implementation Sketch + +A staged implementation can proceed as follows: + +1. Add filesystem CAS helpers alongside the existing SQLite store. +2. Store/load Arboricx Merkle nodes using the filesystem layout. +3. Implement tree-term storage and reconstruction from filesystem CAS. +4. Implement pack from CAS tree terms/Merkle roots to indexed Arboricx bundle. +5. Implement unpack from indexed Arboricx bundle to CAS tree terms/Merkle roots. +6. Define a concrete module manifest encoding. +7. Store/load module manifests as content-addressed objects. +8. Add workspace alias read/write helpers. +9. Teach import resolution to target module manifests/exports. +10. Attach exported View Contract artifacts to module exports. +11. Gradually migrate existing `!import` users. + +## 13. Deferred Decisions + +These are intentionally left out of the first concrete format: + +- package version solving; +- registry/remotes protocol; +- garbage collection/reachability; +- source/provenance/build-record objects; +- editor/update workflows; +- rich visibility/export rules; +- final import syntax; +- whether module manifests also need a tree-native encoding. + +## 14. Summary + +The concrete v1 direction is: + +```text +Store: + filesystem-backed content-addressed objects + +Hashing: + SHA256(domain || 0x00 || canonical payload) + +Tree persistence: + Arboricx Merkle nodes + +Transport: + indexed .arboricx bundles, packable from and unpackable to CAS roots + +Modules: + immutable manifests pairing export names with object refs and optional View + Contract refs + +Workspace: + mutable aliases from human names to immutable content hashes +``` + +This keeps the store portable, preserves Arboricx's compact transport role, +restores Merkle DAGs as the persistence model, and gives View Contracts a stable +module/export attachment point without making the store `tricu`-specific. diff --git a/docs/guard-injection.md b/docs/guard-injection.md new file mode 100644 index 0000000..601d256 --- /dev/null +++ b/docs/guard-injection.md @@ -0,0 +1,371 @@ +# Guard Injection Semantics + +This document describes the runtime guard model for View Contracts. + +Views describe portable structural contracts. Guarded views refine those +contracts with executable predicates while keeping ordinary value-level code free +of `Maybe`, `Result`, sentinel, or host-language abort handling. + +```tri +viewGuarded baseView guard +``` + +A guarded view means: when this guarded view is observed along the reachable +checked-execution path, run `guard` against the runtime value. + +## Goals + +- Preserve ordinary value-level program shapes. +- Keep guard failure out of user code. +- Avoid Haskell-specific checker/runtime semantics. +- Represent guard boundaries explicitly in portable tree data. +- Make successful guarded execution transparent: guarded values are unwrapped + before ordinary code receives them. +- Prefer correctness-by-default over avoiding repeated predicate cost. + +## Non-goals + +- Preventing user-written guards from diverging. +- Letting guards author their own diagnostics. +- Solving IO interaction-tree composition. +- Finalizing long-term artifact identity policy. +- Deduplicating or hoisting repeated guard checks. + +## Plain Views vs Guards + +Plain Views still provide concrete benefits without guards: + +- structural flow checking; +- portable API metadata; +- module/export contract metadata; +- content-store view-tree metadata; +- cross-frontend agreement on contract structure; +- diagnostics for wrong-view flows. + +Guards are for invariants that require runtime value inspection, such as: + +- non-empty list; +- sorted list; +- byte string of exactly 32 bytes; +- protocol payload with a valid checksum; +- domain-specific runtime predicate. + +Guards are deliberately more expensive than ordinary Views. Use them when the +runtime contract must be enforced. + +## Guard Result Protocol + +Guards return one of two standardized shapes: + +```tri +guardOk value +guardFail +``` + +Guards do not provide diagnostics. The checked-exec runner owns diagnostics. +Malformed guard output is treated as a checked-runtime failure. + +## Checked Execution Protocol + +A successful typed-program check returns a checked-execution artifact, not a raw +payload. + +Current constructors: + +```tri +checkedPure value +checkedFail diagnostic +checkedGuard view guard value continuation +checkedGuardWithContext context view guard value continuation +checkedBind exec continuation +``` + +`checkedGuard` is the compatibility/default constructor. It lowers to +`checkedGuardWithContext` with an unknown context. Checker-injected guard +boundaries use `checkedGuardWithContext` so failures can identify where the +boundary came from. + +Runner: + +```tri +runChecked checkedExec +``` + +Semantics: + +```text +runChecked (checkedPure value) + = checkedRuntimeOk value + +runChecked (checkedFail diagnostic) + = checkedRuntimeFail diagnostic + +runChecked (checkedGuardWithContext context view guard value continuation) + = case guard value of + guardOk checkedValue -> runChecked (continuation checkedValue) + guardFail -> checkedRuntimeFail (guardFailed context view) + malformed -> checkedRuntimeFail (malformedGuardResult context view malformed) + +runChecked (checkedGuard view guard value continuation) + = runChecked (checkedGuardWithContext unknownContext view guard value continuation) + +runChecked (checkedBind exec continuation) + = case runChecked exec of + checkedRuntimeOk value -> runChecked (continuation value) + checkedRuntimeFail diag -> checkedRuntimeFail diag +``` + +Important invariant: + +> Guard failure is consumed by `runChecked`. It is never passed into ordinary +> user code. + +## Checker Result Shape + +`checkTypedProgramWith` returns checked-exec on success: + +```tri +ok checkedExec env +``` + +Even unguarded programs return: + +```tri +checkedPure rootPayload +``` + +Compatibility helper: + +```tri +checkedProgramTree result +``` + +`checkedProgramTree` runs/unwraps checked-exec to preserve older raw-tree helper +behavior. + +The Haskell `tricu check` path now evaluates successful checker output through +`runChecked`, so source-level guarded annotations fail through the same portable +checked-exec protocol. + +## Boundary Semantics + +Guard insertion follows correctness-first semantics: + +> Every guarded View observation on the reachable checked-execution path runs +> its guard. + +Important boundary kinds: + +### Guarded typed value + +```tri +typedValue sym (viewGuarded base guard) payload +``` + +This observes `sym` as a guarded value. It also supplies base-view evidence for +flow checking. + +### Guarded requirement + +```tri +typedRequire sym (viewGuarded base guard) payload +``` + +The symbol must satisfy `base`; the guarded observation is attached to `sym` and +is enforced when `sym` is used or exposed along the reachable root path. + +### Guarded function argument + +For: + +```tri +viewFn [(viewGuarded base guard)] result +``` + +application checking guards the argument before the callee receives it. + +### Guarded function result + +For: + +```tri +viewFn [arg] (viewGuarded base guard) +``` + +application checking guards the application result before exposing it as the +result value. + +### Guarded callee symbol + +If a function symbol itself has a guarded observation, that guard runs before the +function value is applied. A successful guard may transform the function value; +the application uses the guarded value. + +## Global Symbol Observations + +Guarded `typedValue` and `typedRequire` nodes are **global per-symbol +observations**, not position-sensitive flow events. + +All guarded observations for a symbol compose in typed-node order whenever that +symbol is used or exposed on the reachable checked-execution path. + +This means a later requirement still applies to an earlier syntactic use: + +```tri +typedValue 1 viewString "x" +typedApply 2 f 1 "x" +typedRequire 1 (viewGuarded viewString guard) "x" +``` + +The guarded requirement is attached to symbol `1`; compiling the reachable root +path that uses symbol `1` runs that guard. + +Rationale: + +- typed programs are declarative symbol graphs, not imperative event traces; +- global observations are simpler and more correct-by-default; +- producers cannot accidentally bypass a guard by ordering a requirement too + late; +- staged raw/checked phases should use distinct symbols. + +## Reachability and Repetition + +Guards are not run eagerly for every guarded node in a program. + +Execution is root-reachable: + +```tri +compileSymbol (typedProgramRoot program) +``` + +Only guarded observations reachable from the root checked-execution path run. +Unreachable guarded symbols do not pay guard cost and do not fail execution. + +Repeated reachable uses rerun guards. There is currently no deduplication or +hoisting. This is intentional: each guarded observation/use is a runtime contract +boundary. + +Future optimization policies may add explicit deduplication or hoisting, but the +baseline semantics are repeated, deterministic guard execution. + +## Function and Application Compilation + +Checked execution is built compositionally from typed-node dependencies: + +1. compile the callee symbol; +2. compile the argument symbol; +3. run any guarded observations attached to the argument symbol; +4. run the guarded function-argument boundary, if present; +5. apply the callee to the checked argument; +6. run the guarded function-result boundary, if present; +7. run guarded observations attached to the application result symbol. + +This handles nested and curried application chains because each `typedApply` +consumes one function argument and produces a symbol whose inferred view is the +function residual/result view. + +## Diagnostics + +Guards do not author diagnostics. The checked-exec runner renders diagnostics +from checker-owned boundary context plus the guarded View. + +Checker-injected guard nodes carry portable structural context. Current context +kinds are: + +- root `typedValue` exposure; +- root `typedRequire` exposure; +- non-root `typedValue` symbol observation; +- non-root `typedRequire` symbol observation; +- function argument boundary; +- function result boundary; +- unknown/default context for manually constructed `checkedGuard` values. + +Examples: + +```text +guard failed at root typedValue symbol 0 for Guarded String +guard failed at root typedRequire symbol 3 for Guarded String +guard failed at typedRequire symbol 6 for Guarded String +guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String +guard failed at result of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String +malformed guard result at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String +``` + +Manually constructed `checkedGuard` values use unknown context and therefore +render without a boundary suffix: + +```text +guard failed for String +malformed guard result for String +``` + +The context is diagnostic-only. It does not affect guard execution, View +compatibility, success/failure semantics, or continuation values. + +The context deliberately contains raw portable data such as symbols and +application edges. It does not preserve source aliases such as `NonEmptyString`, +and it does not rely on Haskell-side post-processing or source-name annotation. +Named View rendering is a separate future design topic. + +## Why Not Abort in Haskell? + +A host-level abort primitive would move guard semantics into Haskell. The design +instead encodes guard failure in portable checked-exec artifacts and interprets +it with portable `tricu` code. + +Haskell may evaluate the runner, but Haskell is not the semantic source of guard +validity or failure behavior. + +## Why Not Maybe / Result Everywhere? + +Returning `Maybe` or `Result` from every guarded boundary would infect ordinary +APIs. A function expecting a `List Byte` would have to accept +`Maybe (List Byte)` or `Result Error (List Byte)`, and every downstream caller +would need defensive handling. + +The checked-exec runner avoids this. It unwraps successful guard results before +continuing and stops checked execution on failure. + +## Known Sharp Edges + +### Guard divergence + +A user-written guard may diverge. This design handles intentional failure via +`guardFail`; it does not solve arbitrary nontermination. Fuel or timeouts are +separate runtime concerns. + +### Payload trust + +Typed nodes carry executable payloads. Guard injection must not expose an +unchecked precomputed payload at a guarded boundary. Boundaries are mediated by +checked-exec nodes. + +This does not make malicious producer forgery impossible; it gives honest +frontends a portable, checkable protocol that avoids accidental bypasses. + +### Cyclic typed-apply graphs + +The current symbol compiler assumes typed programs are well-founded dependency +graphs as emitted by the frontend/lowering path. Cyclic typed-apply graphs are a +malformed-program validation concern, not a guard-specific semantic feature. + +## Current Implementation Status + +Implemented in `lib/view.tri` and exercised by tests: + +- `guardOk` / `guardFail`; +- `checkedPure`, `checkedFail`, `checkedGuard`, `checkedGuardWithContext`, `checkedBind`; +- `runChecked`; +- success from `checkTypedProgramWith` returns checked-exec; +- `checkedProgramTree` compatibility helper; +- guarded root exposure; +- guarded `typedValue` and `typedRequire`; +- guarded function arguments and results; +- guarded callee observations; +- nested/curried application guard composition; +- global per-symbol observations; +- root-reachability behavior; +- repeated reachable uses rerun guards; +- source/Haskell `tricu check` integration; +- imported/module `VTGuarded` lowering to portable `viewGuarded`; +- portable guard boundary diagnostics with symbol/application context. diff --git a/docs/module-system-design.md b/docs/module-system-design.md new file mode 100644 index 0000000..c0d6866 --- /dev/null +++ b/docs/module-system-design.md @@ -0,0 +1,505 @@ +# Module System and Content Store Design + +Status: design draft. + +This document records the intended direction for reworking `tricu` modules, +imports, Arboricx storage/transport, and the content store. It is not an +implementation plan yet; it is a shared design target. + +## 1. Problem Statement + +The current module/import/content-store system is useful as a prototype, but it +is not coherent enough to build on indefinitely. + +Current behavior combines several partially-overlapping systems: + +- `!import "path.tri" Namespace` and `!import "path.tri" !Local` perform + filesystem-relative source preprocessing; +- imported definitions are flattened into one program; +- namespace qualification is implemented by string rewriting; +- evaluation uses a flat `Map String T` environment; +- the Haskell content store stores Tree Calculus Merkle nodes plus an ad hoc + `terms` table with comma-separated names and tags; +- the REPL can resolve names from the content store, including multiple versions; +- Arboricx bundles provide compact indexed transport objects; +- `lib/arboricx/server.tri` already sketches a filesystem-backed object store. + +This works only when users and maintainers are mindful of sharp edges: + +- names serve too many roles at once; +- modules are not first-class semantic objects; +- imports are closer to AST paste-and-prefix than resolution; +- `!Local` imports can create global collisions; +- content identity, human aliases, source files, and evaluated terms are not + cleanly separated; +- the SQLite schema is convenient but not a principled content-addressed store; +- Arboricx transport and long-lived storage are not clearly distinguished. + +## 2. Design Principles + +### 2.1 Content addressability is foundational + +Immutable content should be identified by hashes. Human names should be metadata +or workspace aliases over content, not semantic identity. + +This follows the core lesson from systems such as Unison: separate stable +content identity from ergonomic naming and namespace organization. + +### 2.2 The content store is language-neutral + +The content store must not be married to `tricu` or Haskell. + +It stores a small set of portable Arboricx artifacts: module manifests, +complete tree terms, and direct View Contract types. Lower-level Merkle/bundle +formats exist for transport and DAG tooling, but the store core should treat all +objects as content-addressed bytes with formats/media types. + +`tricu` and Haskell are clients/tooling. They are not the semantic owners of the +store. + +### 2.3 View Contracts are portable enough to integrate + +The store may integrate with View Contracts because the checker and evidence +format are pure Tree Calculus / portable tree data. View Contracts are not a +Haskell-private or `tricu`-private semantic layer. + +The module resolver may emit typed-program evidence, but checker semantics remain +unchanged: + +```text +Haskell emits evidence. +tricu judges evidence. +``` + +### 2.4 Modules should reflect definitions as they actually exist + +The module system should conform to the reality of content-addressed immutable +artifacts and mutable human aliases. We should not contort definitions to fit a +traditional text-file module system if that fights the storage model. + +### 2.5 Transport and storage are different jobs + +Indexed Arboricx bundles are excellent transport/execution objects. Merkle DAGs +are better long-lived persistence objects. These should remain separate but +interoperable representations. + +## 3. Conceptual Architecture + +```text +Content Store + neutral content-addressed object store + +Arboricx CAS / Merkle Store + Tree Calculus node/object formats suitable for persistence and dedupe + +Arboricx Bundle + compact indexed transport/execution format + +View Contract Artifact + portable evidence/checker data over tree artifacts + +Module Manifest + immutable export map from names to content objects and optional contracts + +Workspace + mutable aliases, selected versions, package pins, and user-facing names + +tricu + one frontend/toolchain that emits/consumes these portable artifacts +``` + +The content store stores objects. Arboricx defines important object formats. +View Contracts define portable checking artifacts. `tricu` produces and consumes +those formats. + +### 3.1 Execution imports versus contract checking + +Import resolution has two intentionally different performance profiles. + +For normal execution/evaluation, resolving a module import should hydrate only +the executable exports directly demanded by the importing source. Exported Tree +Calculus values are complete normal forms: importing `foo` does not require +hydrating separate `bar` or `baz` exports that may have helped build it. This is +the fast path for `!import`, including `!Local` imports. + +View Contract checking is a separate evidence-gathering path. It may load +exported direct view types for the symbols that participate in a check. That +slower path must remain behind the typed program boundary: + +```text +Haskell emits evidence. +tricu judges evidence. +``` + +Reusable view catalogs are ordinary tricu libraries/tree terms, not a separate +core CAS artifact kind. + +For locally built workspace modules, advertised direct export views are +producer-checked before the manifest alias is written. Producer checking includes +advertised views from any imported modules used by that source, so a module +cannot publish a local annotated export that contradicts a dependency's exported +view. If producer checking fails, the module alias is not written. + +Consumer checking then resolves selected module exports, decodes their +`arboricx.view-contract.type.v1` refs, and emits trusted `KnownView` evidence +for the local imported symbols. Those facts are module-boundary assumptions: +local workspace builds create them after producer-side checking, while external +or prebuilt manifests are trusted inputs for now. In all cases, compatibility +with local requirements is still judged by the portable checker in `lib/view.tri`. + +## 4. Content Store Direction + +### 4.1 Store core + +The store core should be a content-addressed object store: + +```text +hash -> object bytes +hash -> object kind / media type +hash -> optional metadata/index entries +``` + +The hash should be over canonical bytes with domain separation. The object kind +or media type determines how a client interprets those bytes. + +Current module/check object kinds: + +```text +arboricx.module-manifest.v1 +arboricx.tree-term.v1 +arboricx.view-contract.type.v1 +``` + +Merkle nodes and indexed bundles remain lower-level Arboricx transport/DAG +formats, but they are not the module/eval storage model. typed programs and view +catalogs are ordinary tree terms unless a future external tooling use case proves +that they need their own object kind. + +The store core should not need to know what a `tricu` definition means. + +### 4.2 Filesystem-backed layout + +The long-term store should converge with the direction already sketched in +`lib/arboricx/server.tri`: + +```text +store/ + objects/ + abc/ + abc123...object + aliases/ + names/ + modules/ + packages/ + manifests/ + tmp/ +``` + +SQLite may remain useful as an optional index/cache, but it should not be the +canonical store model. + +### 4.3 Structural references, not language dependencies + +The store may understand structural content references when they are part of an +object format. For example, a Merkle node naturally references child hashes: + +```text +Leaf +Stem childHash +Fork leftHash rightHash +``` + +This is not a `tricu` dependency graph. It is content structure. + +Language/tool-level relationships such as "compiled from source", "exported by +module", or "checked with contract" can live in manifests or indexes. They +should not be required by the store core. + +## 5. Arboricx Role + +Arboricx should be understood as a family of portable Tree Calculus artifact +formats, not as a single storage mechanism. + +### 5.1 Arboricx Bundle + +The existing indexed `.arboricx` format remains the preferred transport and +execution object: + +- compact; +- self-contained; +- deterministic; +- easy to parse in constrained runtimes; +- suitable for deployment and HTTP serving; +- structurally verifiable without hash recomputation per node. + +It says: + +```text +Here is everything you need, densely packed. +``` + +### 5.2 Arboricx CAS / Merkle Store + +The persistent store should use content-addressed structural objects: + +```text +Leaf +Stem childHash +Fork leftHash rightHash +``` + +This enables dedupe across definitions, modules, packages, and versions. A large +program that shares subtrees with other programs should not store those subtrees +multiple times. + +It says: + +```text +Here are immutable objects, addressable independently. +``` + +### 5.3 Pack and unpack + +Transport and storage should interoperate explicitly: + +```text +CAS root(s) -> pack -> indexed Arboricx bundle +Arboricx bundle -> unpack -> CAS root(s) +``` + +The bundle can be treated as an opaque content-addressed blob by the store, and +it can also be unpacked into Merkle nodes for dedupe and partial reuse. + +## 6. Modules + +### 6.1 Module identity + +A module should be an immutable manifest object. Its identity is the hash of its +canonical manifest bytes. + +A module name is not identity. It is a workspace alias or package-level alias to +a module hash. + +### 6.2 Module contents + +A module manifest should primarily be an export map: + +```text +module hash +exports: + name -> content reference +metadata: + package + version + description + license + createdBy +optional: + view contract artifact refs + ABI/media type info + source/provenance refs +``` + +The manifest should be portable and mostly format-oriented. It should not depend +on Haskell data structures or `tricu`-specific internal semantics. + +### 6.3 Export entries + +An export entry may eventually look conceptually like: + +```text +name: "map" +object: sha256:... +kind: arboricx.tree-term.v1 +abi: arboricx.abi.tree.v1 +view: sha256:... -- optional View Contract artifact +source: sha256:... -- optional source/provenance object +``` + +Executable module exports are complete normalized tree terms stored as one +`arboricx.tree-term.v1` object per named export. Merkle-node storage remains +available for DAG-oriented tooling, but module/eval imports should not store or +hydrate every subtree as a separate filesystem object. + +### 6.4 Import behavior + +Imports should resolve module aliases or content references to module manifests, +then bind selected exports into the local source scope. + +Export selection has one intentional aggregator special case: + +```text +module with local top-level definitions -> exports only those local definitions +module with only imports -> reexports the evaluated import env +``` + +This lets files such as `prelude.tri` act as explicit barrel modules without +making every ordinary module reexport its imports. A module that defines even one +local top-level name does not implicitly reexport imported names. + +The future pipeline should be: + +```text +parse source +resolve imports/names to module exports and content refs +lower source using resolved refs +emit a view-tree artifact +check evidence when requested +store/export artifacts +``` + +It should not be: + +```text +paste imported ASTs into one file and rewrite strings +``` + +## 7. Workspace Layer + +Mutable human-facing state belongs in a workspace layer. + +Examples: + +```text +List -> module hash +Http -> module hash +map -> definition/tree hash +selected List version -> module hash +package pin prelude -> package/module hash +``` + +The workspace is where names, selections, pins, and aliases live. Renaming should +usually mutate workspace aliases, not immutable content objects. + +This gives humans stable ergonomic names without making names semantic identity. + +## 8. Definition Identity + +There are two useful identities and we should support both. + +### 8.1 Tree identity + +A Tree Calculus value has a Merkle root hash. This identifies the executable tree +itself. + +This is the right identity for: + +- execution; +- dedupe; +- bundle roots; +- low-level artifact sharing. + +### 8.2 Module/export identity + +The module manifest is the higher-level artifact boundary. It pairs each export +name with its compiled tree term and optional direct View Contract type. + +The content store should not require extra definition/source/provenance objects, +and fully untyped Tree Calculus code must remain valid. + +## 9. View Contract Integration + +View Contracts should attach to modules/exports as portable artifacts. + +An imported definition can be assigned a local numeric symbol while lowering a +typed program. Its global identity remains a content hash or module export ref. + +This is the intended split: + +```text +typed program local symbol: 3 +Debug label: "List.map" +Resolved object: sha256:... +Exported view: Fn [...] +``` + +De Bruijn-style integer symbols are still appropriate inside a typed program. They +are local evidence identifiers, not global content identity. + +We should not make global objects depend on numeric checker symbols. + +Untyped code remains valid with no contract artifact. If a boundary needs to +participate in checking but has no information, it may use `Any` or rely on +policy. We should not pretend all untyped functions have an infinite +`Any -> Any -> ...` contract. + +## 10. Import Syntax Direction + +Exact syntax is future work, but the current `!import` form should be considered +a transitional mechanism. + +Future imports should distinguish: + +- path-based source imports for local development; +- workspace/module alias imports; +- explicit content-addressed imports; +- selected/exposed names; +- qualified versus unqualified binding. + +Possible directions: + +```tri +import "./list.tri" as List +import List exposing (map foldl) +import #abc123... as List +``` + +The syntax should be designed after the object/module model is clearer. + +## 11. Migration Strategy + +A plausible migration path: + +1. Define the neutral object store model and filesystem layout. +2. Implement Merkle node persistence against that layout. +3. Add pack/unpack between CAS roots and indexed Arboricx bundles. +4. Replace ad hoc SQLite `terms` names/tags with workspace aliases or a clearer + index layer. +5. Define module manifest objects. +6. Teach source imports to resolve manifests/exports instead of rewriting ASTs. +7. Attach View Contract artifacts to module exports. +8. Gradually migrate existing `lib/` and `demos/` imports. + +Compatibility shims may keep existing `!import` working during migration. + +## 12. Open Questions + +- What exact canonical byte format should store objects use? +- Should module manifests be binary, tree-encoded, or both? +- What media type/kind registry do we need first? +- How should object references be represented in source syntax? +- How should workspaces be stored and shared? +- What is the minimum useful module manifest? +- Should source files compile directly to module manifests, or should manifests + be produced by explicit package commands? +- How much Arboricx bundle metadata should reference CAS roots? +- What GC/reachability model should the store eventually use? + +## 13. Summary + +The desired design is: + +```text +Content store: + portable CAS for immutable objects and structural references + +Arboricx bundle: + compact indexed transport/execution object + +Arboricx CAS: + persistent Merkle DAG/object representation for dedupe and partial reuse + +Modules: + immutable manifests mapping export names to content objects and optional + contracts + +Workspace: + mutable human aliases, version selections, and package/module pins + +View Contracts: + portable evidence artifacts attached to exports and checked by pure Tree + Calculus code +``` + +The key architectural rule is that hashes provide stable identity, while names +provide human usability. The module system should be built on that separation. diff --git a/docs/view-contract-syntax.md b/docs/view-contract-syntax.md new file mode 100644 index 0000000..6fd929d --- /dev/null +++ b/docs/view-contract-syntax.md @@ -0,0 +1,582 @@ +# View Contract Syntax Design + +## 1. Purpose + +This document specifies source-level syntax sugar for emitting View Contract +metadata from annotated `tricu` definitions. + +The syntax is frontend sugar. It lowers to ordinary typed-program nodes consumed +by the portable checker in `lib/view.tri` and catalog helpers in +`lib/views/catalog.tri`. + +The checker remains independent of source syntax. + +## 2. Definition Annotations + +A definition may carry argument and return view annotations directly in its head. + +```tri +name arg1@Type1 arg2@Type2 =@ReturnType body +``` + +This declares: + +```text +name : Fn [Type1 Type2] ReturnType +arg1 : Type1 +arg2 : Type2 +``` + +and lowers to View Contract metadata: + +```tri +typedDeclareFn nameSym [(Type1) (Type2)] ReturnType t +typedValue arg1Sym Type1 t +typedValue arg2Sym Type2 t +``` + +If body flow metadata is emitted, the body result is required to satisfy the +appropriate residual view. + +## 3. Syntax Forms + +### 3.1 Binder annotation + +```tri +x@Bool +xs@(List Bool) +f@(Fn [Bool] String) +``` + +A binder annotation introduces a normal term binder and contributes an argument +view to the function contract. + +### 3.2 Phantom argument annotation + +```tri +name @A @B =@C body +``` + +A phantom argument annotation contributes an argument view to the function +contract but introduces no term binder. + +This is useful for point-free and combinator-heavy definitions. + +```tri +name @A @B =@C body +``` + +declares: + +```text +name : Fn [A B] C +``` + +The body itself must satisfy the residual function view: + +```text +Fn [A B] C +``` + +### 3.3 Binder prefix with phantom tail + +Phantom annotations may appear after binder annotations: + +```tri +name x@A @B =@C body +``` + +This declares: + +```text +name : Fn [A B] C +x : A +``` + +The body must satisfy: + +```text +Fn [B] C +``` + +This allows a named binder prefix with a point-free tail. + +### 3.4 Return annotation + +```tri +name x@A =@B body +name =@B body +``` + +`=@B` contributes the result view. + +A definition with no arguments and a return annotation is a value contract, not a +zero-arity function contract: + +```tri +name =@Bool body +``` + +lowers to: + +```tri +typedValue nameSym viewBool t +``` + +not: + +```tri +typedDeclareFn nameSym [] viewBool t +``` + +## 4. Ordering Rule + +Phantom argument annotations may only appear at the end of the argument list. + +Valid: + +```tri +foo x@A y@B =@C body +foo @A @B =@C body +foo x@A @B =@C body +foo x y@B @C =@D body +``` + +Invalid: + +```tri +foo x@A @B z@C =@D body +foo @A x@B =@C body +``` + +Once a phantom `@Type` item appears, no later named binder may appear. + +## 5. Contract-Bearing Definitions + +A definition is contract-bearing if its head contains any of: + +```text +binder@Type +@Type +=@Type +``` + +Ordinary unannotated definitions do not emit View Contract metadata. + +```tri +foo x y = body +``` + +emits no contract metadata. + +## 6. Unannotated Binders in Contract-Bearing Heads + +In a contract-bearing definition, an unannotated binder contributes `Any`. + +```tri +foo x y@Bool =@String body +``` + +means: + +```text +foo : Fn [Any Bool] String +x : Any +y : Bool +``` + +This keeps mixed annotation lightweight without emitting contracts for fully +unannotated definitions. + +## 7. Missing Return Annotation + +If a contract-bearing definition has argument annotations but no return +annotation, the return view defaults to `Any`. + +```tri +foo x@Bool = body +``` + +means: + +```text +foo : Fn [Bool] Any +x : Bool +``` + +## 8. Type Annotation Grammar + +Annotations are intentionally small at the attachment site. + +After `@` or `=@`, the parser accepts either a single atomic view expression or +a parenthesized compound view expression. + +Valid: + +```tri +x@Bool +x@(List Bool) +f@(Fn [Bool] String) +r@(Result String Bool) +name =@Bool body +name =@(List Bool) body +``` + +These are not structural annotations: + +```tri +x@List Bool +f@Fn [Bool] String +name =@List Bool body +``` + +They are parsed according to normal definition-head rules. For example, +`x@List Bool` means binder `x` has the atomic view expression `List`, followed by +an unannotated binder named `Bool`. Use parentheses when the annotation itself is +an application. + +## 9. Type Grammar + +View expressions are ordinary value-level expressions in a restricted annotation +grammar: + +```text +ViewExpr + = name + | integer + | [ViewExpr...] + | ViewExpr ViewExpr + | (ViewExpr) +``` + +Built-in names lower to standard view values: + +```text +Any -> viewAny +Bool -> viewBool +String -> viewString +Byte -> viewByte +Unit -> viewUnit +``` + +Atomic refs lower explicitly. String refs are the preferred user-facing form; +numeric refs remain available for low-level/generated code: + +```text +Ref "Nat" -> viewRef "Nat" +Ref 10 -> viewRef 10 +``` + +Additional named views and view constructors are ordinary `tricu` values: + +```tri +Nat = viewRef "Nat" +Box a = viewPair (viewRef "Box") a + +idNat x@Nat =@Nat x +idBox x@(Box String) =@(Box String) x +``` + +The frontend resolves names and evaluates view expressions, but well-formedness +is judged by the self-hosted checker (`wellFormedView?` in `lib/view.tri`). +Malformed view values are rejected when checked or published. + +## 10. List Syntax in Types + +Function argument lists use the source type grammar: + +```tri +Fn [Bool String] Unit +Fn [(List Bool) (Maybe String)] Unit +``` + +The lowered typed program must still respect ordinary `tricu` list syntax, where +each list element is parenthesized when needed: + +```tri +viewFn [(viewBool) (viewString)] viewUnit +``` + +## 11. Residual Body View + +For a contract-bearing definition, the full definition view is always: + +```text +Fn [allArgumentViews...] returnView +``` + +except for nullary value annotations, which use the return view directly. + +The body obligation depends on how many argument views are represented by named +binders in the definition head. + +Let: + +```text +argViews = [A B C] +returnView = R +binderCount = number of named binders before the phantom tail +remaining = drop binderCount argViews +``` + +Then: + +```text +bodyRequiredView = residual(remaining, returnView) +``` + +where: + +```text +residual([], R) = R +residual([A ...], R) = Fn [A ...] R +``` + +Examples: + +```tri +foo x@A y@B =@C body +``` + +Body required view: + +```text +C +``` + +```tri +foo @A @B =@C body +``` + +Body required view: + +```text +Fn [A B] C +``` + +```tri +foo x@A @B =@C body +``` + +Body required view: + +```text +Fn [B] C +``` + +## 12. Lowering Examples + +### 12.1 Fully annotated binders + +Source: + +```tri +foo x@Bool xs@(List Bool) =@String body +``` + +Definition contract: + +```tri +typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t +typedValue xSym viewBool t +typedValue xsSym (viewList viewBool) t +``` + +Body obligation: + +```tri +typedRequire bodySym viewString t +``` + +### 12.2 Pure phantom signature + +Source: + +```tri +foo @Bool @(List Bool) =@String body +``` + +Definition contract: + +```tri +typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t +``` + +Body obligation: + +```tri +typedRequire bodySym (viewFn [(viewBool) (viewList viewBool)] viewString) t +``` + +### 12.3 Binder prefix with phantom tail + +Source: + +```tri +foo x@Bool @(List Bool) =@String body +``` + +Definition contract: + +```tri +typedDeclareFn fooSym [(viewBool) (viewList viewBool)] viewString t +typedValue xSym viewBool t +``` + +Body obligation: + +```tri +typedRequire bodySym (viewFn [(viewList viewBool)] viewString) t +``` + +### 12.4 Value annotation + +Source: + +```tri +message =@String "hello" +``` + +Definition contract: + +```tri +typedValue messageSym viewString t +``` + +Body obligation: + +```tri +typedRequire bodySym viewString t +``` + +## 13. `tricu check` + +`tricu check` consumes an annotated program, lowers annotations to typed program +metadata, runs the checker, and reports either `ok` or rendered diagnostics. + +Initial behavior: + +```bash +tricu check path/to/program.tri +``` + +outputs checker success or errors. Diagnostics are rendered by the portable +checker, then annotated by the frontend with source/debug labels when available: + +```tri +id x@String =@Bool x +``` + +reports: + +```text +symbol 1 (x) expected Bool but got String +``` + +Application result labels include the application head when known: + +```tri +xs =@(List String) [(g "hi")] +g y@String =@Bool y +``` + +reports: + +```text +symbol 3 (g application result) expected String but got Bool +``` + +These labels are presentation-only metadata. The checker still judges only the +emitted typed-program evidence. + +Future behavior may include: + +```bash +tricu check --out path/to/executable.arboricx path/to/program.tri +``` + +which checks an annotated source program and emits an executable Arboricx bundle. + +The checker library remains available independently of the CLI workflow. + +## 14. Frontend Lowering Boundaries + +The annotation syntax is frontend sugar. The canonical checker input remains a +plain typed program: ordinary `typedValue`, `typedDeclareFn`, +`typedRequire`, and `typedApply` nodes represented as portable `tricu` +data. + +The frontend may emit richer evidence from source forms, but it does not decide +semantic compatibility. In short: + +```text +Haskell emits evidence. +tricu judges evidence. +``` + +Current source-driven evidence includes: + +- literal views for strings, bytes, unit, and homogeneous list literals; +- expected element requirements for `List T` bodies; +- expected `Fn` requirements for lambda literals and curried application spines; +- application argument requirements when the callee has a known `Fn` view; +- expected constructor flow for unshadowed stdlib constructors: + - `pair` with expected `Pair A B`; + - `just` and `nothing` with expected `Maybe A`; + - `ok` and `err` with expected `Result E A`. + +Constructor lowering only applies when the constructor name is not shadowed by a +local binder or top-level definition in the checked source. If a program defines +its own `pair`, `just`, `nothing`, `ok`, or `err`, checking falls back to normal +application evidence. + +For tooling and regression tests, the frontend exposes a lowering-only API that +returns emitted typed program text without invoking the checker: + +```hs +lowerSource :: String -> Either String String +``` + +It also exposes debug labels for symbols: + +```hs +lowerSourceWithDebug :: String -> Either String (String, Map Integer String) +``` + +Debug labels are presentation metadata only. They are not part of checker +semantics and are not consumed by `lib/view.tri`. + +`do` blocks have no separate View Contract semantics. The parser lowers them +through their explicit bind operator: + +```tri +do bind + x <- action + next x +``` + +becomes ordinary application/lambda structure. Checking then follows the known +`Fn` view of the bind operator, including the callback argument view when it is +available. + +## 15. Summary + +The annotation syntax is: + +```tri +name arg@A arg2@B =@C body +name @A @B =@C body +name arg@A @B =@C body +name =@C body +``` + +Core rules: + +1. Binder annotations introduce binders and argument views. +2. Phantom annotations introduce argument views only. +3. Phantom annotations may only appear after all binders. +4. Unannotated binders in contract-bearing heads contribute `Any`. +5. Missing return annotations in contract-bearing heads default to `Any`. +6. Nullary `=@T` definitions are value contracts, not zero-arity functions. +7. Compound annotation types must be parenthesized. +8. Lowering emits ordinary typed-program nodes for the existing checker. diff --git a/docs/view-contracts.md b/docs/view-contracts.md new file mode 100644 index 0000000..876348f --- /dev/null +++ b/docs/view-contracts.md @@ -0,0 +1,337 @@ +# View Contracts and View Trees + +## 1. Purpose + +View Contracts are the portable checking layer for Tree Calculus programs. + +The checker does not consume detached metadata about a separate executable. Its +canonical input is a typed, checkable tree artifact: ordinary tree data that +contains both the executable program payloads and the view/contract structure +needed to validate and transform them. + +The checker consumes this artifact and returns either: + +```text +checked-execution artifact +``` + +or: + +```text +structured diagnostic +``` + +A checked-execution artifact is interpreted by `runChecked`. Unguarded programs +are represented as `checkedPure rootPayload`; guarded programs contain explicit +checked guard/bind nodes. + +This keeps checking independent of any particular host implementation. A typed +artifact may be produced by any frontend, compiler, hand-written generator, or +future self-hosted `tricu` toolchain. + +## 2. Design Principle + +The model follows the same discipline as interaction trees. + +Interaction trees use tagged structural envelopes with explicit executable +payloads: + +```tri +io action = pair "tricuIO" (pair version action) +pure x = pair 0 x +bind action k = pair 1 (pair action k) +``` + +The interpreter understands the outer structure, but it does not recursively +mistake every subtree for interpreter metadata. A continuation `k` is an opaque +executable tree until the interpreter reaches the `bind` step that applies it. + +View trees use the same rule: + +```text +structure says how to check; +opaque executable fields are only executed/applied by the checker at the +appropriate step. +``` + +This is the key distinction that allows Views to carry guards without confusing +ordinary program trees with View metadata. + +## 3. Views + +A View is an extrinsic contract over an ordinary Tree Calculus value. Tree +Calculus values do not carry native runtime types; a View describes how a value +may be treated by the checker or by a checked boundary. + +Core View forms: + +```text +Any +Ref ref +Fn [argView...] resultView +List elemView +Maybe elemView +Pair leftView rightView +Result errView okView +Guarded baseView guard +``` + +`Ref` supports both generated/numeric and symbolic references. Symbolic refs are +preferred for user-authored views: + +```tri +UserId = viewRef "UserId" +``` + +A guarded view refines a base view with an executable guard: + +```tri +UserId = viewGuarded (viewRef "UserId") userIdGuard +``` + +The guard is ordinary program code. The View validator checks that the guarded +view envelope is well-formed, and recursively validates the `baseView`, but it +must treat the guard payload/reference as opaque executable data, not as another +View. + +## 4. Guards + +Guards are ordinary `tricu` values/functions grouped with the Views they refine. + +Example: + +```tri +userIdGuard = value : + -- ordinary program that validates value + +UserId = viewGuarded (viewRef "UserId") userIdGuard + +loadUser id@UserId = ... +``` + +Guards return the standard checked-runtime protocol: + +```tri +guardOk value +guardFail +``` + +Guards do not author diagnostics. The checked-exec runner owns guard failure and +malformed-guard diagnostics using boundary context from the checked artifact. + +Guards are injected by the checker. They are not discovered by the runtime as a +separate metadata layer. The checking process transforms a view tree into an +executable tree with the necessary guard applications inserted. + +## 5. View Tree Artifact + +The primary checker-facing artifact is a view executable term graph. + +Conceptually: + +```text +ViewTree + version + root node id + nodes +``` + +Each node is tagged tree data. Nodes combine executable payloads, view claims, +and structural relationships in one graph. + +Representative node forms: + +```text +Value node view executableTree +Apply node calleeNode argNode expectedOrInferredView +Require node requiredView sourceNode +External node name view +``` + +This is not a mandatory final encoding; it is the semantic target. The important +property is that executable trees and checking structure are carried together in +a single portable artifact. + +A node may contain opaque executable fields. Those fields are tree terms, but +they are not recursively decoded as view-tree nodes or Views unless the node's +semantics explicitly says so. + +## 6. Checker Semantics + +The checker is an interpreter over the view tree. + +For each node it may: + +1. validate the node envelope; +2. validate Views referenced by the node; +3. check compatibility between expected and actual Views; +4. recursively check child nodes; +5. inject guards required by guarded Views; +6. produce the executable tree for that node; +7. memoize node results by node id. + +The root node result is a checked-execution program. + +In abstract form: + +```text +checkViewTree : ViewTree -> Result CheckedExec Diagnostic +``` + +or, in self-hosted terms: + +```tri +checkViewTree viewTree = ... -- ok checkedExec / err diagnostic +``` + +## 7. Compatibility and Guard Injection + +Structural compatibility is about Views. Guard injection is about producing the +checked-execution tree. + +For example, if a node is required to satisfy: + +```tri +viewGuarded (viewRef "UserId") userIdGuard +``` + +then the checker verifies the underlying View relationship and emits executable +code that applies `userIdGuard` at the appropriate checked boundary. + +The checker, not the runtime metadata system, owns this transformation. + +## 8. Source Annotations + +Source annotations are one frontend syntax for producing view-tree nodes. + +Examples: + +```tri +Nat = viewRef "Nat" +Box a = viewPair (viewRef "Box") a + +idNat x@Nat =@Nat x +idBox x@(Box String) =@(Box String) x +``` + +Annotations are value-level View expressions. Names such as `Nat` and `Box` are +ordinary program values/functions that evaluate to Views. + +A frontend that supports this syntax should lower the source into a view tree +that contains the relevant executable terms, views, and checking structure. The +artifact must not depend on source names or on the frontend implementation that +produced it. + +## 9. Contract Expressions + +Contract-expression helpers remain useful as authoring/building tools, but they +are not the fundamental artifact model. + +Preferred style for expression-oriented authoring is pipeline-first: + +```tri +mapBoolStringUse = cFn <| + [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString) + |> cApply (cFn [(viewBool)] viewString) + |> cApply (cValue (viewList viewBool)) + |> cRequire (viewList viewString) +``` + +These helpers should be understood as convenient ways to build typed/checkable +structure, not as a permanent replacement for view-tree artifacts. + +## 10. Artifact Direction + +The target direction is to make the view tree the canonical checked-program +artifact. + +Older split concepts remain useful internally or during development: + +```text +tree term +view value +typed-program node +module/export manifest +``` + +But the durable design should avoid treating contracts as detached facts about a +separate program. The portable checker input is the checkable program itself. + +In short: + +```text +Do not store code over here and contracts over there. +Store a view tree: executable code plus the structure needed to check and guard it. +``` + +## 11. IO Interaction Trees + +`tricu` IO is represented as ordinary interaction-tree data: + +```tri +io action = pair "tricuIO" (pair version action) +pure value = pair 0 value +bind action k = pair 1 (pair action k) +``` + +View Contracts do not change that representation. A checked program may produce +an ordinary IO interaction tree, and the existing IO driver can execute it +unchanged. + +For source evaluation with contracts enabled, `tricu eval --io` performs an +additional frontend instrumentation pass over visible IO continuations. When a +continuation returns a `pure (...)` value that mentions source-annotated +functions, the frontend lowers that pure expression into the existing portable +checked-exec protocol before returning the next IO action. + +This means source sugar works for practical checked IO paths such as: + +```tri +acceptNames xs@(NonEmptyList String) =@String "accepted" + +main = io (bind (pure []) (xs : pure (acceptNames xs))) +``` + +and for explicit higher-order boundaries: + +```tri +useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String + handler xs + +main = io (bind (pure []) (xs : pure (useHandler acceptNames xs))) +``` + +The IO runtime does not perform View inference or guard injection at every step. +The source/frontend pass constructs checked-exec boundaries once; the runtime +only evaluates the resulting interaction tree. + +Current limitations: + +- This is source-visible instrumentation, not whole-program function-flow + tracking. +- Higher-order guarantees require explicit annotated boundaries. +- Raw prebuilt interaction trees, imported executable artifacts, and content-store + terms are not automatically re-instrumented unless they pass through this + source-lowering path. +- The IO action shape itself is only shallowly checkable unless users provide + guarded Views for the relevant boundaries. +- Continuation result Views are not inferred from external effects; dynamic IO + values should cross annotated/guarded boundaries when runtime enforcement is + required. + +Making IO checking more complete is future work. In particular, a future design +may validate every continuation-produced action structurally, carry checked +wrappers with higher-order function values, or define a portable checked-IO +artifact instead of relying on Haskell/frontend source instrumentation. + +## 12. Host Independence + +No part of the core View Tree design is specific to Haskell or to the current implementation. + +Any producer may emit a view-tree artifact if it follows the portable tree-data +encoding. Any checker implementation may consume it if it implements the typed +node semantics. + +The current implementation can produce and consume these artifacts, but it is +not the semantic authority. The artifact format and the self-hosted checker +semantics are the authority. diff --git a/lib/arboricx/arboricx.tri b/lib/arboricx/arboricx.tri index a85e03a..b4f0391 100644 --- a/lib/arboricx/arboricx.tri +++ b/lib/arboricx/arboricx.tri @@ -1,4 +1,7 @@ -!import "manifest.tri" !Local +!import "prelude" !Local +!import "arboricx.common" !Local +!import "arboricx.manifest" !Local +!import "arboricx.nodes" !Local -- Read and validate a full Arboricx bundle. -- Returns (pair validManifest afterContainer). diff --git a/lib/arboricx/common.tri b/lib/arboricx/common.tri index 51c9a45..36db27a 100644 --- a/lib/arboricx/common.tri +++ b/lib/arboricx/common.tri @@ -1,6 +1,6 @@ -!import "../prelude.tri" !Local -!import "../bytes.tri" !Local -!import "../binary.tri" !Local +!import "prelude" !Local +!import "binary" !Local + arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)] arboricxMajorVersion = [(0) (1)] diff --git a/lib/arboricx/dispatch.tri b/lib/arboricx/dispatch.tri index 0eea7a5..985f022 100644 --- a/lib/arboricx/dispatch.tri +++ b/lib/arboricx/dispatch.tri @@ -1,4 +1,5 @@ -!import "arboricx.tri" !Local +!import "prelude" !Local +!import "arboricx" !Local -- Multi-purpose kernel dispatch. -- runArboricxTyped tag bundleBytes args diff --git a/lib/arboricx/manifest.tri b/lib/arboricx/manifest.tri index a94a6a7..f375145 100644 --- a/lib/arboricx/manifest.tri +++ b/lib/arboricx/manifest.tri @@ -1,4 +1,7 @@ -!import "nodes.tri" !Local +!import "prelude" !Local +!import "binary" !Local +!import "arboricx.common" !Local +!import "arboricx.nodes" !Local readManifestMagic = (bs : expectBytes arboricxManifestMagic bs) diff --git a/lib/arboricx/nodes.tri b/lib/arboricx/nodes.tri index e27a66d..9b2a78c 100644 --- a/lib/arboricx/nodes.tri +++ b/lib/arboricx/nodes.tri @@ -1,4 +1,6 @@ -!import "common.tri" !Local +!import "prelude" !Local +!import "binary" !Local +!import "arboricx.common" !Local -- Indexed Arboricx node section reader. -- diff --git a/lib/arboricx/server.tri b/lib/arboricx/server.tri index cf74f6e..c979982 100644 --- a/lib/arboricx/server.tri +++ b/lib/arboricx/server.tri @@ -1,8 +1,9 @@ -!import "../io.tri" !Local -!import "../http.tri" !Local -!import "../socket.tri" !Local -!import "../patterns.tri" !Local -!import "arboricx.tri" !Local +!import "prelude" !Local +!import "io" !Local +!import "http" !Local +!import "socket" !Local +!import "patterns" !Local +!import "arboricx" !Local -- --------------------------------------------------------------------------- -- Store layout helpers diff --git a/lib/binary.tri b/lib/binary.tri index 8440a55..c4f92bc 100644 --- a/lib/binary.tri +++ b/lib/binary.tri @@ -1,6 +1,4 @@ -!import "base.tri" !Local -!import "list.tri" !Local -!import "bytes.tri" !Local +!import "prelude" !Local errUnexpectedEof = 1 errUnexpectedBytes = 2 diff --git a/lib/bytes.tri b/lib/bytes.tri index 6fb656a..9f47b8c 100644 --- a/lib/bytes.tri +++ b/lib/bytes.tri @@ -1,5 +1,5 @@ -!import "base.tri" !Local -!import "list.tri" !Local +!import "base" !Local +!import "list" !Local bytesNil? = emptyList? diff --git a/lib/conversions.tri b/lib/conversions.tri index 97621fd..3e5af88 100644 --- a/lib/conversions.tri +++ b/lib/conversions.tri @@ -1,5 +1,5 @@ -!import "base.tri" !Local -!import "list.tri" !Local +!import "base" !Local +!import "list" !Local incDecRev = y (self : matchList "1" diff --git a/lib/http.tri b/lib/http.tri index 6baa025..80b01f6 100644 --- a/lib/http.tri +++ b/lib/http.tri @@ -1,6 +1,7 @@ -!import "prelude.tri" !Local -!import "io.tri" !Local -!import "socket.tri" !Local +!import "prelude" !Local +!import "io" !Local +!import "patterns" !Local +!import "socket" !Local -- --------------------------------------------------------------------------- -- Constants diff --git a/lib/io.tri b/lib/io.tri index 64ea73c..3c4df89 100644 --- a/lib/io.tri +++ b/lib/io.tri @@ -1,6 +1,5 @@ -!import "base.tri" !Local -!import "list.tri" !Local -!import "conversions.tri" !Local +!import "prelude" !Local +!import "patterns" !Local -- IO constructors for host-interpreted interaction trees. -- Free-monad style: Bind is the single sequencing mechanism. diff --git a/lib/lazy.tri b/lib/lazy.tri index 2ba3677..dfe04c5 100644 --- a/lib/lazy.tri +++ b/lib/lazy.tri @@ -1,5 +1,5 @@ -!import "base.tri" !Local -!import "list.tri" !Local +!import "base" !Local +!import "list" !Local lazyBool = (thenK elseK cond : ((chosen : chosen t) diff --git a/lib/list.tri b/lib/list.tri index d7fec38..191fc64 100644 --- a/lib/list.tri +++ b/lib/list.tri @@ -1,4 +1,4 @@ -!import "base.tri" !Local +!import "base" !Local _ = t diff --git a/lib/patterns.tri b/lib/patterns.tri index 1526bb6..24e3a98 100644 --- a/lib/patterns.tri +++ b/lib/patterns.tri @@ -1,6 +1,4 @@ -!import "base.tri" !Local -!import "list.tri" !Local -!import "lazy.tri" !Local +!import "prelude" !Local match_ = y (self value patterns : triage diff --git a/lib/prelude.tri b/lib/prelude.tri index d2c2093..02d404c 100644 --- a/lib/prelude.tri +++ b/lib/prelude.tri @@ -1,7 +1,7 @@ -- Standard tricu prelude. -!import "base.tri" !Local -!import "list.tri" !Local -!import "bytes.tri" !Local -!import "lazy.tri" !Local -!import "conversions.tri" !Local +!import "base" !Local +!import "list" !Local +!import "bytes" !Local +!import "lazy" !Local +!import "conversions" !Local diff --git a/lib/socket.tri b/lib/socket.tri index a6be36f..cf934ad 100644 --- a/lib/socket.tri +++ b/lib/socket.tri @@ -1,5 +1,5 @@ -!import "base.tri" !Local -!import "io.tri" !Local +!import "prelude" !Local +!import "io" !Local -- Socket primitives for the IO driver. -- ok value t -- pair true (pair value t) diff --git a/lib/view.tri b/lib/view.tri new file mode 100644 index 0000000..30e4b3d --- /dev/null +++ b/lib/view.tri @@ -0,0 +1,1560 @@ +!import "prelude" !Local +!import "patterns" !Local + +-- --------------------------------------------------------------------------- +-- View Contract core, validation kernel +-- +-- This layer validates typed/checkable program trees: executable payload slots +-- and view-flow structure travel together in one portable value. Executable +-- payloads remain opaque to metadata validation until a checker/interpreter +-- explicitly chooses to run or rewrite them. +-- --------------------------------------------------------------------------- + +-- Generic tagged records / fields. Constructors use field sentinels; accessors +-- for fixed-format records use finite positional destructuring to avoid driving +-- recursive field lookup while top-level definitions normalize. +record = (tag fields : pair tag fields) +recordTag = fst +recordFields = snd + +field = (tag value : pair tag value) +fieldTag = fst +fieldValue = snd + +field0 = (fields : fieldValue (head fields)) +field1 = (fields : fieldValue (head (tail fields))) +field2 = (fields : fieldValue (head (tail (tail fields)))) +field3 = (fields : fieldValue (head (tail (tail (tail fields))))) +field4 = (fields : fieldValue (head (tail (tail (tail (tail fields)))))) + +field0Tag? = (fields tag : equal? (fieldTag (head fields)) tag) +field1Tag? = (fields tag : equal? (fieldTag (head (tail fields))) tag) +field2Tag? = (fields tag : equal? (fieldTag (head (tail (tail fields)))) tag) +field3Tag? = (fields tag : equal? (fieldTag (head (tail (tail (tail fields))))) tag) + +fields1? = (fields tag0 : + and? + (field0Tag? fields tag0) + (emptyList? (tail fields))) + +fields2? = (fields tag0 tag1 : + and? + (and? (field0Tag? fields tag0) (field1Tag? fields tag1)) + (emptyList? (tail (tail fields)))) + +fields3? = (fields tag0 tag1 tag2 : + and? + (and? (fields2Prefix fields tag0 tag1) (field2Tag? fields tag2)) + (emptyList? (tail (tail (tail fields))))) + +fields4? = (fields tag0 tag1 tag2 tag3 : + and? + (and? (fields2Prefix fields tag0 tag1) (and? (field2Tag? fields tag2) (field3Tag? fields tag3))) + (emptyList? (tail (tail (tail (tail fields)))))) + +fields2Prefix = (fields tag0 tag1 : + and? (field0Tag? fields tag0) (field1Tag? fields tag1)) + +-- View tags / fields +viewTagAny = 0 +viewTagFn = 1 +viewTagRef = 2 +viewTagList = 3 +viewTagMaybe = 4 +viewTagPair = 5 +viewTagResult = 6 +viewTagGuarded = 7 +viewFieldArgs = 0 +viewFieldResult = 1 +viewFieldRef = 2 +viewFieldElem = 3 +viewFieldLeft = 4 +viewFieldRight = 5 +viewFieldErr = 6 +viewFieldOk = 7 +viewFieldBase = 8 +viewFieldGuard = 9 + +-- Evidence tags +evidenceTagTrusted = 0 +evidenceTagInferred = 1 +evidenceTagRequired = 2 + +-- Boundary strategies / policy +boundaryStrategyError = 0 +boundaryStrategyTrust = 1 +policyStrict = pair boundaryStrategyError t +policyGradual = pair boundaryStrategyTrust t +policyBoundaryStrategy = fst + +-- Structured checker error tags. Result payloads remain strings for compatibility; +-- these numeric tags give portable tests and frontends a stable diagnostic API. +errorTagOk = 0 +errorTagMalformedPolicy = 1 +errorTagMalformedProgram = 2 +errorTagUnknownNode = 3 +errorTagMissingRequiredView = 4 +errorTagMissingFunctionArgumentView = 5 +errorTagZeroArityFunction = 6 +errorTagGuardFailed = 7 +errorTagMalformedGuardResult = 8 +errorTagUnknown = 99 + +diagnosticFieldSymbol = 0 +diagnosticFieldExpectedView = 1 +diagnosticFieldActualView = 2 +diagnosticFieldActualTag = 3 +diagnosticFieldGuardContext = 4 + +diagnostic = (tag fields : record tag fields) +diagnosticTag = recordTag +diagnosticPayload = recordFields +diagnosticSymbol = (diag : field0 (diagnosticPayload diag)) +diagnosticExpectedView = (diag : field1 (diagnosticPayload diag)) +diagnosticActualView = (diag : field2 (diagnosticPayload diag)) + +diagnosticMessage = (diag : + let tag = diagnosticTag diag in + lazyBool + (_ : "malformed view policy") + (_ : + lazyBool + (_ : "malformed view program") + (_ : + lazyBool + (_ : "unknown typed node tag") + (_ : + lazyBool + (_ : "required view is not known") + (_ : + lazyBool + (_ : "function argument view is not known") + (_ : + lazyBool + (_ : "cannot apply zero-arity Fn view") + (_ : + lazyBool + (_ : "guard failed") + (_ : + lazyBool + (_ : "malformed guard result") + (_ : "unknown checker error") + (equal? tag errorTagMalformedGuardResult)) + (equal? tag errorTagGuardFailed)) + (equal? tag errorTagZeroArityFunction)) + (equal? tag errorTagMissingFunctionArgumentView)) + (equal? tag errorTagMissingRequiredView)) + (equal? tag errorTagUnknownNode)) + (equal? tag errorTagMalformedProgram)) + (equal? tag errorTagMalformedPolicy)) + +-- Environment tags / fields +viewFactTagKnown = 0 +viewFactFieldView = 0 +viewFactFieldEvidence = 1 +envEntryTagViews = 0 + +contractExprTagValue = 0 +contractExprTagFn = 1 +contractExprTagCall = 2 +contractExprTagRequire = 3 +contractExprFieldView = 0 +contractExprFieldArgs = 0 +contractExprFieldResult = 1 +contractExprFieldFn = 0 +contractExprFieldArg = 1 +contractExprFieldExpr = 0 +contractExprFieldRequired = 1 + +-- View-tree checker artifact tags / fields. A view tree is the durable +-- checker input: executable payloads and checking structure travel together. +-- Term fields are opaque executable trees; View validation must not recurse +-- into them as metadata. +typedProgramTag = 20 +typedNodeTagValue = 21 +typedNodeTagApply = 22 +typedNodeTagRequire = 23 +typedProgramFieldRoot = 0 +typedProgramFieldNodes = 1 +typedNodeFieldSymbol = 0 +typedNodeFieldView = 1 +typedNodeFieldTerm = 2 +typedNodeFieldCallee = 3 +typedNodeFieldArg = 4 + +-- Checked-exec / runtime guard protocol tags. Successful checker results always +-- carry checked-exec artifacts; unguarded roots are represented as checkedPure. +guardResultTagOk = 30 +guardResultTagFail = 31 +guardResultFieldValue = 0 + +checkedExecTagPure = 40 +checkedExecTagFail = 41 +checkedExecTagGuard = 42 +checkedExecTagBind = 43 +checkedExecFieldValue = 0 +checkedExecFieldDiagnostic = 1 +checkedExecFieldView = 2 +checkedExecFieldGuard = 3 +checkedExecFieldContinuation = 4 +checkedExecFieldGuardContext = 5 + +guardContextTagRootValue = 50 +guardContextTagRootRequire = 51 +guardContextTagSymbolValue = 52 +guardContextTagSymbolRequire = 53 +guardContextTagFunctionArgument = 54 +guardContextTagFunctionResult = 55 +guardContextTagUnknown = 59 +guardContextFieldSymbol = 0 +guardContextFieldApplication = 1 +guardContextFieldCallee = 2 +guardContextFieldArg = 3 +guardContextFieldArgIndex = 4 + +envEntryFieldSymbol = 0 +envEntryFieldViews = 1 + +viewAny = record viewTagAny t +viewFn args result = + record viewTagFn [(field viewFieldArgs args) (field viewFieldResult result)] +viewRef symbol = record viewTagRef [(field viewFieldRef symbol)] +viewList elem = record viewTagList [(field viewFieldElem elem)] +viewMaybe elem = record viewTagMaybe [(field viewFieldElem elem)] +viewPair left right = + record viewTagPair [(field viewFieldLeft left) (field viewFieldRight right)] +viewResult errView okView = + record viewTagResult [(field viewFieldErr errView) (field viewFieldOk okView)] +viewGuarded baseView guard = + record viewTagGuarded [(field viewFieldBase baseView) (field viewFieldGuard guard)] + +viewTag = recordTag +viewPayload = recordFields +fnArgs = (view : field0 (viewPayload view)) +fnResult = (view : field1 (viewPayload view)) + +fnResidual = (restArgs result : + lazyList + (_ : result) + (_ _ : viewFn restArgs result) + restArgs) + +anyView? = (view : equal? view viewAny) +fnView? = (view : equal? (viewTag view) viewTagFn) +refView? = (view : equal? (viewTag view) viewTagRef) +listView? = (view : equal? (viewTag view) viewTagList) +maybeView? = (view : equal? (viewTag view) viewTagMaybe) +pairView? = (view : equal? (viewTag view) viewTagPair) +resultView? = (view : equal? (viewTag view) viewTagResult) +guardedView? = (view : equal? (viewTag view) viewTagGuarded) +guardedViewBase = (view : field0 (viewPayload view)) +guardedViewGuard = (view : field1 (viewPayload view)) + +viewFact = (view evidence : + record viewFactTagKnown + [(field viewFactFieldView view) + (field viewFactFieldEvidence evidence)]) +viewFactView = (fact : field0 (recordFields fact)) +viewFactEvidence = (fact : field1 (recordFields fact)) + +envEntry = (symbol viewSet : + record envEntryTagViews + [(field envEntryFieldSymbol symbol) + (field envEntryFieldViews viewSet)]) +envEntrySymbol = (entry : field0 (recordFields entry)) +envEntryViews = (entry : field1 (recordFields entry)) + +-- --------------------------------------------------------------------------- +-- Well-formed metadata checks. This is the first point where the checker starts +-- protecting itself: every typed node is shape-checked before flow interpretation. +-- --------------------------------------------------------------------------- + +validEvidence? = (e : + or? + (equal? e evidenceTagTrusted) + (or? (equal? e evidenceTagInferred) (equal? e evidenceTagRequired))) + +validBoundaryStrategy? = (strategy : + or? + (equal? strategy boundaryStrategyError) + (equal? strategy boundaryStrategyTrust)) + +wellFormedPolicy? = (policy : + validBoundaryStrategy? (policyBoundaryStrategy policy)) + +wellFormedFnArgs_ self viewSelf views = + lazyList + (_ : true) + (view rest : + lazyBool + (_ : self viewSelf rest) + (_ : false) + (viewSelf view)) + views + +wellFormedFnView? = (view : + fields2? (viewPayload view) viewFieldArgs viewFieldResult) + +wellFormedAnyView? = (view : + equal? (viewPayload view) t) + +wellFormedRefView? = (view : + fields1? (viewPayload view) viewFieldRef) + +wellFormedUnaryView? = (view fieldTag : + fields1? (viewPayload view) fieldTag) + +wellFormedPairView? = (view : + fields2? (viewPayload view) viewFieldLeft viewFieldRight) + +wellFormedResultView? = (view : + fields2? (viewPayload view) viewFieldErr viewFieldOk) + +wellFormedGuardedView? = (view : + fields2? (viewPayload view) viewFieldBase viewFieldGuard) + +wellFormedView_ self view = + lazyBool + (_ : wellFormedAnyView? view) + (_ : + lazyBool + (_ : + lazyBool + (_ : self (fnResult view)) + (_ : false) + (y wellFormedFnArgs_ self (fnArgs view))) + (_ : + lazyBool + (_ : wellFormedRefView? view) + (_ : + lazyBool + (_ : + lazyBool + (_ : self (field0 (viewPayload view))) + (_ : false) + (wellFormedUnaryView? view viewFieldElem)) + (_ : + lazyBool + (_ : + lazyBool + (_ : self (field1 (viewPayload view))) + (_ : false) + (self (field0 (viewPayload view)))) + (_ : + lazyBool + (_ : + lazyBool + (_ : self (field1 (viewPayload view))) + (_ : false) + (self (field0 (viewPayload view)))) + (_ : + lazyBool + (_ : + lazyBool + (_ : self (guardedViewBase view)) + (_ : false) + (wellFormedGuardedView? view)) + (_ : false) + (guardedView? view)) + (and? (resultView? view) (wellFormedResultView? view))) + (and? (pairView? view) (wellFormedPairView? view))) + (or? (listView? view) (maybeView? view))) + (refView? view)) + (and? (fnView? view) (wellFormedFnView? view))) + (anyView? view) + +wellFormedView? = (view : + y wellFormedView_ view) + +wellFormedViews_ self views = + lazyList + (_ : true) + (view rest : + lazyBool + (_ : self rest) + (_ : false) + (wellFormedView? view)) + views + +wellFormedViews? = (views : + y wellFormedViews_ views) + +wellFormedViewFact? = (fact : + lazyBool + (_ : + lazyBool + (_ : + and? + (wellFormedView? (viewFactView fact)) + (validEvidence? (viewFactEvidence fact))) + (_ : false) + (fields2? (recordFields fact) viewFactFieldView viewFactFieldEvidence)) + (_ : false) + (equal? (recordTag fact) viewFactTagKnown)) + +wellFormedViewSet_ self viewSet = + lazyList + (_ : true) + (fact rest : + lazyBool + (_ : self rest) + (_ : false) + (wellFormedViewFact? fact)) + viewSet + +wellFormedViewSet? = (viewSet : + y wellFormedViewSet_ viewSet) + +wellFormedEnvEntry? = (entry : + lazyBool + (_ : + lazyBool + (_ : wellFormedViewSet? (envEntryViews entry)) + (_ : false) + (fields2? (recordFields entry) envEntryFieldSymbol envEntryFieldViews)) + (_ : false) + (equal? (recordTag entry) envEntryTagViews)) + +wellFormedEnv_ self env = + lazyList + (_ : true) + (entry rest : + lazyBool + (_ : self rest) + (_ : false) + (wellFormedEnvEntry? entry)) + env + +wellFormedEnv? = (env : + y wellFormedEnv_ env) + +-- --------------------------------------------------------------------------- +-- Flow environment +-- env = listOf tagged envEntry +-- viewSet = listOf tagged viewFact +-- --------------------------------------------------------------------------- + +lookupViews_ self symbol env = + lazyList + (_ : nothing) + (entry rest : + lazyBool + (_ : just (envEntryViews entry)) + (_ : self symbol rest) + (equal? symbol (envEntrySymbol entry))) + env + +lookupViews = (symbol env : + y lookupViews_ symbol env) + +viewSetHas_ self view viewSet = + lazyList + (_ : false) + (fact rest : + lazyBool + (_ : true) + (_ : self view rest) + (equal? view (viewFactView fact))) + viewSet + +viewSetHas? = (view viewSet : + lazyBool + (_ : true) + (_ : y viewSetHas_ view viewSet) + (anyView? view)) + +hasView? = (symbol view env : + lazyMaybe + (_ : anyView? view) + (viewSet : viewSetHas? view viewSet) + (lookupViews symbol env)) + +addViewToSet = (view evidence viewSet : + lazyBool + (_ : viewSet) + (_ : pair (viewFact view evidence) viewSet) + (viewSetHas? view viewSet)) + +extendEnv_ self symbol view evidence env = + lazyList + (_ : [(envEntry symbol [(viewFact view evidence)])]) + (entry rest : + lazyBool + (_ : + pair + (envEntry symbol (addViewToSet view evidence (envEntryViews entry))) + rest) + (_ : pair entry (self symbol view evidence rest)) + (equal? symbol (envEntrySymbol entry))) + env + +extendEnv = (symbol view evidence env : + y extendEnv_ symbol view evidence env) + +findFnView_ self viewSet = + lazyList + (_ : nothing) + (fact rest : + let view = viewFactView fact in + lazyBool + (_ : just view) + (_ : self rest) + (fnView? view)) + viewSet + +findFnView = (viewSet : + y findFnView_ viewSet) + +firstKnownView = (viewSet : + lazyList + (_ : viewAny) + (fact rest : viewFactView fact) + viewSet) + +actualViewFor = (symbol env : + lazyMaybe + (_ : viewAny) + (viewSet : firstKnownView viewSet) + (lookupViews symbol env)) + +checkerErr = (tag fields env : err (diagnostic tag fields) env) +checkerOk = (env : ok env t) + +missingRequiredView = (policy symbol view env : + lazyBool + (_ : + checkerErr + errorTagMissingRequiredView + [(field diagnosticFieldSymbol symbol) + (field diagnosticFieldExpectedView view) + (field diagnosticFieldActualView (actualViewFor symbol env))] + env) + (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env)) + (equal? (policyBoundaryStrategy policy) boundaryStrategyError)) + +missingArgumentView = (policy symbol view env : + lazyBool + (_ : + checkerErr + errorTagMissingFunctionArgumentView + [(field diagnosticFieldSymbol symbol) + (field diagnosticFieldExpectedView view) + (field diagnosticFieldActualView (actualViewFor symbol env))] + env) + (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env)) + (equal? (policyBoundaryStrategy policy) boundaryStrategyError)) + +checkApplicationSymbols = (policy argSymbol outSymbol env fnView : + lazyList + (_ : checkerErr errorTagZeroArityFunction t env) + (argView restArgs : + let resultView = fnResidual restArgs (fnResult fnView) in + lazyBool + (_ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred env)) + (_ : + lazyResult + (diag envAtError : err diag envAtError) + (nextEnv _ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred nextEnv)) + (missingArgumentOrGuardedBase policy argSymbol argView env)) + (hasView? argSymbol argView env)) + (fnArgs fnView)) + +-- --------------------------------------------------------------------------- +-- View-tree checker artifact +-- --------------------------------------------------------------------------- + +typedProgram = (root nodes : + record typedProgramTag + [(field typedProgramFieldRoot root) + (field typedProgramFieldNodes nodes)]) + +typedProgramRoot = (program : field0 (recordFields program)) +typedProgramNodes = (program : field1 (recordFields program)) + +typedValue = (symbol view term : + record typedNodeTagValue + [(field typedNodeFieldSymbol symbol) + (field typedNodeFieldView view) + (field typedNodeFieldTerm term)]) + +typedApply = (symbol callee arg term : + record typedNodeTagApply + [(field typedNodeFieldSymbol symbol) + (field typedNodeFieldCallee callee) + (field typedNodeFieldArg arg) + (field typedNodeFieldTerm term)]) + +typedRequire = (symbol view term : + record typedNodeTagRequire + [(field typedNodeFieldSymbol symbol) + (field typedNodeFieldView view) + (field typedNodeFieldTerm term)]) + +typedNodeSymbol = (node : field0 (recordFields node)) +typedNodeView = (node : field1 (recordFields node)) +typedNodeTerm = (node : field2 (recordFields node)) +typedApplyCallee = (node : field1 (recordFields node)) +typedApplyArg = (node : field2 (recordFields node)) +typedApplyTerm = (node : field0 (tail (tail (tail (recordFields node))))) + +wellFormedTypedValue? = (node : + lazyBool + (_ : wellFormedView? (typedNodeView node)) + (_ : false) + (fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm)) + +wellFormedTypedApply? = (node : + fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee typedNodeFieldArg) + +wellFormedTypedApplyPayload? = (node : + and? + (fields2Prefix (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee) + (and? + (field2Tag? (recordFields node) typedNodeFieldArg) + (and? + (field0Tag? (tail (tail (tail (recordFields node)))) typedNodeFieldTerm) + (emptyList? (tail (tail (tail (tail (recordFields node))))))))) + +wellFormedTypedRequire? = (node : + lazyBool + (_ : wellFormedView? (typedNodeView node)) + (_ : false) + (fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm)) + +wellFormedTypedNode? = (node : + let tag = recordTag node in + lazyBool + (_ : wellFormedTypedValue? node) + (_ : + lazyBool + (_ : wellFormedTypedApplyPayload? node) + (_ : + lazyBool + (_ : wellFormedTypedRequire? node) + (_ : false) + (equal? tag typedNodeTagRequire)) + (equal? tag typedNodeTagApply)) + (equal? tag typedNodeTagValue)) + +wellFormedTypedNodes_ self nodes = + lazyList + (_ : true) + (node rest : + lazyBool + (_ : self rest) + (_ : false) + (wellFormedTypedNode? node)) + nodes + +wellFormedTypedNodes? = (nodes : y wellFormedTypedNodes_ nodes) + +wellFormedTypedProgram? = (program : + lazyBool + (_ : + lazyBool + (_ : wellFormedTypedNodes? (typedProgramNodes program)) + (_ : false) + (fields2? (recordFields program) typedProgramFieldRoot typedProgramFieldNodes)) + (_ : false) + (equal? (recordTag program) typedProgramTag)) + +checkTypedValueNode = (node env : + let symbol = typedNodeSymbol node in + let view = typedNodeView node in + lazyBool + (_ : + checkerOk + (extendEnv + symbol + view + evidenceTagTrusted + (extendEnv symbol (guardedViewBase view) evidenceTagTrusted env))) + (_ : checkerOk (extendEnv symbol view evidenceTagTrusted env)) + (guardedView? view)) + +checkTypedRequireNode = (policy node env : + let symbol = typedNodeSymbol node in + let view = typedNodeView node in + lazyBool + (_ : checkerOk env) + (_ : + lazyBool + (_ : + lazyBool + (_ : checkerOk (extendEnv symbol view evidenceTagRequired env)) + (_ : missingRequiredView policy symbol view env) + (hasView? symbol (guardedViewBase view) env)) + (_ : missingRequiredView policy symbol view env) + (guardedView? view)) + (hasView? symbol view env)) + +missingArgumentOrGuardedBase = (policy symbol view env : + lazyBool + (_ : + lazyBool + (_ : checkerOk (extendEnv symbol view evidenceTagRequired env)) + (_ : missingArgumentView policy symbol view env) + (hasView? symbol (guardedViewBase view) env)) + (_ : missingArgumentView policy symbol view env) + (guardedView? view)) + +checkTypedApplyNode = (policy node env : + lazyMaybe + (_ : checkerOk env) + (calleeViews : + lazyMaybe + (_ : checkerOk env) + (fnView : checkApplicationSymbols policy (typedApplyArg node) (typedNodeSymbol node) env fnView) + (findFnView calleeViews)) + (lookupViews (typedApplyCallee node) env)) + +checkTypedNode = (policy node env : + let tag = recordTag node in + lazyBool + (_ : checkTypedValueNode node env) + (_ : + lazyBool + (_ : checkTypedApplyNode policy node env) + (_ : checkTypedRequireNode policy node env) + (equal? tag typedNodeTagApply)) + (equal? tag typedNodeTagValue)) + +flowCheckTypedNodes_ self nodes policy env = + lazyList + (_ : checkerOk env) + (node rest : + lazyResult + (diag envAtError : err diag envAtError) + (nextEnv _ : self rest policy nextEnv) + (checkTypedNode policy node env)) + nodes + +flowCheckTypedNodes = (policy nodes : + y flowCheckTypedNodes_ nodes policy t) + +lookupTypedTerm_ self symbol nodes = + lazyList + (_ : nothing) + (node rest : + lazyBool + (_ : + lazyBool + (_ : just (typedApplyTerm node)) + (_ : just (typedNodeTerm node)) + (equal? (recordTag node) typedNodeTagApply)) + (_ : self symbol rest) + (equal? symbol (typedNodeSymbol node))) + nodes + +lookupTypedTerm = (symbol program : + y lookupTypedTerm_ symbol (typedProgramNodes program)) + +lookupTypedView_ self symbol nodes = + lazyList + (_ : nothing) + (node rest : + let tag = recordTag node in + lazyBool + (_ : just (typedNodeView node)) + (_ : self symbol rest) + (and? + (or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire)) + (equal? symbol (typedNodeSymbol node)))) + nodes + +lookupTypedView = (symbol program : + y lookupTypedView_ symbol (typedProgramNodes program)) + +lookupApplyDefinition_ self symbol nodes = + lazyList + (_ : nothing) + (node rest : + lazyBool + (_ : just node) + (_ : self symbol rest) + (and? + (equal? (recordTag node) typedNodeTagApply) + (equal? symbol (typedNodeSymbol node)))) + nodes + +lookupApplyDefinition = (symbol program : + y lookupApplyDefinition_ symbol (typedProgramNodes program)) + +firstFnArgView = (view : + lazyBool + (_ : + lazyList + (_ : nothing) + (arg rest : just arg) + (fnArgs view)) + (_ : nothing) + (fnView? view)) + +appliedFnResultView = (view : + lazyBool + (_ : + lazyList + (_ : nothing) + (arg rest : just (fnResidual rest (fnResult view))) + (fnArgs view)) + (_ : nothing) + (fnView? view)) + +lookupSymbolView_ self symbol program = + lazyMaybe + (_ : + lazyMaybe + (_ : nothing) + (applyNode : + lazyMaybe + (_ : nothing) + (calleeView : appliedFnResultView calleeView) + (self (typedApplyCallee applyNode) program)) + (lookupApplyDefinition symbol program)) + (view : just view) + (lookupTypedView symbol program) + +lookupSymbolView = (symbol program : + y lookupSymbolView_ symbol program) + +guardContextUnknown = record guardContextTagUnknown t + +guardContextRootValue = (symbol : + record guardContextTagRootValue [(field guardContextFieldSymbol symbol)]) +guardContextRootRequire = (symbol : + record guardContextTagRootRequire [(field guardContextFieldSymbol symbol)]) +guardContextSymbolValue = (symbol : + record guardContextTagSymbolValue [(field guardContextFieldSymbol symbol)]) +guardContextSymbolRequire = (symbol : + record guardContextTagSymbolRequire [(field guardContextFieldSymbol symbol)]) +guardContextFunctionArgument = (application callee arg argIndex : + record guardContextTagFunctionArgument + [(field guardContextFieldApplication application) + (field guardContextFieldCallee callee) + (field guardContextFieldArg arg) + (field guardContextFieldArgIndex argIndex)]) +guardContextFunctionResult = (application callee arg : + record guardContextTagFunctionResult + [(field guardContextFieldApplication application) + (field guardContextFieldCallee callee) + (field guardContextFieldArg arg)]) + +guardContextObservation = (root symbol nodeTag : + lazyBool + (_ : + lazyBool + (_ : guardContextRootValue symbol) + (_ : guardContextRootRequire symbol) + (equal? nodeTag typedNodeTagValue)) + (_ : + lazyBool + (_ : guardContextSymbolValue symbol) + (_ : guardContextSymbolRequire symbol) + (equal? nodeTag typedNodeTagValue)) + (equal? root symbol)) + +applySymbolGuardedObservations_ self root symbol nodes exec = + lazyList + (_ : exec) + (node rest : + let tag = recordTag node in + lazyBool + (_ : + let view = typedNodeView node in + lazyBool + (_ : + self + root + symbol + rest + (checkedBind + exec + (value : checkedGuardWithContext (guardContextObservation root symbol tag) view (guardedViewGuard view) value (checkedValue : checkedPure checkedValue)))) + (_ : self root symbol rest exec) + (guardedView? view)) + (_ : self root symbol rest exec) + (and? + (or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire)) + (equal? symbol (typedNodeSymbol node)))) + nodes + +applySymbolGuardedObservations = (program symbol exec : + y applySymbolGuardedObservations_ (typedProgramRoot program) symbol (typedProgramNodes program) exec) + +compileApplyExec = (self program applyNode : + let calleeSym = typedApplyCallee applyNode in + let argSym = typedApplyArg applyNode in + let calleeExec = self program calleeSym in + let argExec = self program argSym in + lazyMaybe + (_ : + checkedBind + calleeExec + (calleeValue : + checkedBind + argExec + (argValue : checkedPure (calleeValue argValue)))) + (calleeView : + let applicationExec = + lazyMaybe + (_ : + checkedBind + calleeExec + (calleeValue : + checkedBind + argExec + (argValue : checkedPure (calleeValue argValue)))) + (argView : + lazyBool + (_ : + checkedBind + calleeExec + (calleeValue : + checkedBind + argExec + (argValue : + checkedBind + (checkedGuardWithContext (guardContextFunctionArgument (typedNodeSymbol applyNode) calleeSym argSym 0) argView (guardedViewGuard argView) argValue (checkedValue : checkedPure checkedValue)) + (checkedValue : checkedPure (calleeValue checkedValue))))) + (_ : + checkedBind + calleeExec + (calleeValue : + checkedBind + argExec + (argValue : checkedPure (calleeValue argValue)))) + (guardedView? argView)) + (firstFnArgView calleeView) in + lazyMaybe + (_ : applicationExec) + (resultView : + lazyBool + (_ : + checkedBind + applicationExec + (value : checkedGuardWithContext (guardContextFunctionResult (typedNodeSymbol applyNode) calleeSym argSym) resultView (guardedViewGuard resultView) value (checkedValue : checkedPure checkedValue))) + (_ : applicationExec) + (guardedView? resultView)) + (appliedFnResultView calleeView)) + (lookupSymbolView calleeSym program)) + +compileSymbol_ self program symbol = + lazyMaybe + (_ : + lazyMaybe + (_ : checkedPure t) + (term : applySymbolGuardedObservations program symbol (checkedPure term)) + (lookupTypedTerm symbol program)) + (applyNode : applySymbolGuardedObservations program symbol (compileApplyExec self program applyNode)) + (lookupApplyDefinition symbol program) + +compileSymbol = (program symbol : + y compileSymbol_ program symbol) + +checkedExecForRootTerm = (program term : + compileSymbol program (typedProgramRoot program)) + +-- --------------------------------------------------------------------------- +-- Checked execution / runtime guard protocol +-- --------------------------------------------------------------------------- + +guardOk = (value : + record guardResultTagOk [(field guardResultFieldValue value)]) +guardFail = record guardResultTagFail t + +guardResultOk? = (result : equal? (recordTag result) guardResultTagOk) +guardResultFail? = (result : equal? (recordTag result) guardResultTagFail) +guardResultValue = (result : field0 (recordFields result)) + +checkedPure = (value : + record checkedExecTagPure [(field checkedExecFieldValue value)]) +checkedFail = (diag : + record checkedExecTagFail [(field checkedExecFieldDiagnostic diag)]) +checkedGuardWithContext = (context view guard value continuation : + record checkedExecTagGuard + [(field checkedExecFieldView view) + (field checkedExecFieldGuard guard) + (field checkedExecFieldValue value) + (field checkedExecFieldContinuation continuation) + (field checkedExecFieldGuardContext context)]) +checkedGuard = (view guard value continuation : + checkedGuardWithContext guardContextUnknown view guard value continuation) +checkedBind = (exec continuation : + record checkedExecTagBind + [(field checkedExecFieldValue exec) + (field checkedExecFieldContinuation continuation)]) + +checkedExecValue = (exec : field0 (recordFields exec)) +checkedExecDiagnostic = (exec : field0 (recordFields exec)) +checkedExecView = (exec : field0 (recordFields exec)) +checkedExecGuard = (exec : field1 (recordFields exec)) +checkedExecGuardValue = (exec : field2 (recordFields exec)) +checkedExecContinuation = (exec : field3 (recordFields exec)) +checkedExecGuardContext = (exec : field4 (recordFields exec)) +checkedExecBindExec = (exec : field0 (recordFields exec)) +checkedExecBindContinuation = (exec : field1 (recordFields exec)) + +checkedRuntimeOk = (value : ok value t) +checkedRuntimeFail = (diag : err diag t) + +diagnosticGuardContext = (diag : field3 (diagnosticPayload diag)) + +checkedGuardFailedDiagnostic = (context view : + diagnostic + errorTagGuardFailed + [(field diagnosticFieldSymbol 0) + (field diagnosticFieldExpectedView view) + (field diagnosticFieldActualView viewAny) + (field diagnosticFieldGuardContext context)]) + +malformedGuardResultDiagnostic = (context view actual : + diagnostic + errorTagMalformedGuardResult + [(field diagnosticFieldSymbol 0) + (field diagnosticFieldExpectedView view) + (field diagnosticFieldActualTag (recordTag actual)) + (field diagnosticFieldGuardContext context)]) + +runChecked_ self exec = + let tag = recordTag exec in + lazyBool + (_ : checkedRuntimeOk (checkedExecValue exec)) + (_ : + lazyBool + (_ : checkedRuntimeFail (checkedExecDiagnostic exec)) + (_ : + lazyBool + (_ : + let view = checkedExecView exec in + let guard = checkedExecGuard exec in + let value = checkedExecGuardValue exec in + let continuation = checkedExecContinuation exec in + let context = checkedExecGuardContext exec in + let guardResult = guard value in + lazyBool + (_ : self (continuation (guardResultValue guardResult))) + (_ : + lazyBool + (_ : checkedRuntimeFail (checkedGuardFailedDiagnostic context view)) + (_ : checkedRuntimeFail (malformedGuardResultDiagnostic context view guardResult)) + (guardResultFail? guardResult)) + (guardResultOk? guardResult)) + (_ : + lazyBool + (_ : + lazyResult + (diag runtimeEnv : checkedRuntimeFail diag) + (value runtimeEnv : self ((checkedExecBindContinuation exec) value)) + (self (checkedExecBindExec exec))) + (_ : checkedRuntimeFail (malformedGuardResultDiagnostic guardContextUnknown viewAny exec)) + (equal? tag checkedExecTagBind)) + (equal? tag checkedExecTagGuard)) + (equal? tag checkedExecTagFail)) + (equal? tag checkedExecTagPure) + +runChecked = (exec : y runChecked_ exec) + +checkTypedProgramWith = (policy program : + lazyBool + (_ : + lazyBool + (_ : + lazyResult + (diag env : err diag env) + (env rest : + lazyMaybe + (_ : checkerErr errorTagMalformedProgram t env) + (term : ok (checkedExecForRootTerm program term) env) + (lookupTypedTerm (typedProgramRoot program) program)) + (flowCheckTypedNodes policy (typedProgramNodes program))) + (_ : checkerErr errorTagMalformedProgram t t) + (wellFormedTypedProgram? program)) + (_ : checkerErr errorTagMalformedPolicy t t) + (wellFormedPolicy? policy)) + +checkTypedProgram = (program : + checkTypedProgramWith policyGradual program) + +checkedProgramTree = (result : + matchResult + (diag env : t) + (exec env : + matchResult + (runtimeDiag runtimeEnv : t) + (value runtimeEnv : value) + (runChecked exec)) + result) + +checkerResultErrorTag = (result : + matchResult + (diag env : diagnosticTag diag) + (env rest : errorTagOk) + result) + +-- --------------------------------------------------------------------------- +-- Portable contract examples / self-tests. These are plain tricu values that +-- travel with the checker and exercise the same validators used by clients. +-- --------------------------------------------------------------------------- + +viewBool = viewRef 0 +viewString = viewRef 1 +viewByte = viewRef 2 +viewUnit = viewRef 3 + +renderViewArgs_ self viewSelf views = + lazyList + (_ : "") + (view rest : + lazyBool + (_ : viewSelf view) + (_ : append (viewSelf view) (append ", " (self viewSelf rest))) + (emptyList? rest)) + views + +renderView_ self view = + lazyBool + (_ : "Bool") + (_ : + lazyBool + (_ : "String") + (_ : + lazyBool + (_ : "Byte") + (_ : + lazyBool + (_ : "Unit") + (_ : + lazyBool + (_ : "Any") + (_ : + lazyBool + (_ : append "Ref " (showNumber (field0 (viewPayload view)))) + (_ : + lazyBool + (_ : append "List " (self (field0 (viewPayload view)))) + (_ : + lazyBool + (_ : append "Maybe " (self (field0 (viewPayload view)))) + (_ : + lazyBool + (_ : + append + "Pair " + (append + (self (field0 (viewPayload view))) + (append " " (self (field1 (viewPayload view)))))) + (_ : + lazyBool + (_ : + append + "Result " + (append + (self (field0 (viewPayload view))) + (append " " (self (field1 (viewPayload view)))))) + (_ : + lazyBool + (_ : + append + "Fn [" + (append + (y renderViewArgs_ self (fnArgs view)) + (append "] " (self (fnResult view))))) + (_ : + lazyBool + (_ : append "Guarded " (self (guardedViewBase view))) + (_ : "View") + (guardedView? view)) + (fnView? view)) + (resultView? view)) + (pairView? view)) + (maybeView? view)) + (listView? view)) + (refView? view)) + (anyView? view)) + (equal? view viewUnit)) + (equal? view viewByte)) + (equal? view viewString)) + (equal? view viewBool) + +renderView = (view : + y renderView_ view) + +append3 = (a b c : append a (append b c)) +append4 = (a b c d : append a (append b (append c d))) + +guardContextSymbol = (context : field0 (recordFields context)) +guardContextApplication = (context : field0 (recordFields context)) +guardContextCallee = (context : field1 (recordFields context)) +guardContextArg = (context : field2 (recordFields context)) +guardContextArgIndex = (context : field3 (recordFields context)) + +renderGuardContext = (context : + let tag = recordTag context in + lazyBool + (_ : append " at root typedValue symbol " (showNumber (guardContextSymbol context))) + (_ : + lazyBool + (_ : append " at root typedRequire symbol " (showNumber (guardContextSymbol context))) + (_ : + lazyBool + (_ : append " at typedValue symbol " (showNumber (guardContextSymbol context))) + (_ : + lazyBool + (_ : append " at typedRequire symbol " (showNumber (guardContextSymbol context))) + (_ : + lazyBool + (_ : + append4 + " at argument " + (showNumber (guardContextArgIndex context)) + " of application symbol " + (append + (showNumber (guardContextApplication context)) + (append + " (callee symbol " + (append + (showNumber (guardContextCallee context)) + (append ", arg symbol " (append (showNumber (guardContextArg context)) ")")))))) + (_ : + lazyBool + (_ : + append + " at result of application symbol " + (append + (showNumber (guardContextApplication context)) + (append + " (callee symbol " + (append + (showNumber (guardContextCallee context)) + (append ", arg symbol " (append (showNumber (guardContextArg context)) ")")))))) + (_ : "") + (equal? tag guardContextTagFunctionResult)) + (equal? tag guardContextTagFunctionArgument)) + (equal? tag guardContextTagSymbolRequire)) + (equal? tag guardContextTagSymbolValue)) + (equal? tag guardContextTagRootRequire)) + (equal? tag guardContextTagRootValue)) + +renderDiagnostic = (diag : + let tag = diagnosticTag diag in + lazyBool + (_ : "malformed view policy") + (_ : + lazyBool + (_ : "malformed view program") + (_ : + lazyBool + (_ : append "unknown typed node tag " (showNumber (field0 (diagnosticPayload diag)))) + (_ : + lazyBool + (_ : + append + "symbol " + (append + (showNumber (diagnosticSymbol diag)) + (append + " expected " + (append + (renderView (diagnosticExpectedView diag)) + (append " but got " (renderView (diagnosticActualView diag))))))) + (_ : + lazyBool + (_ : + append + "symbol " + (append + (showNumber (diagnosticSymbol diag)) + (append + " expected " + (append + (renderView (diagnosticExpectedView diag)) + (append " but got " (renderView (diagnosticActualView diag))))))) + (_ : + lazyBool + (_ : "cannot apply zero-arity Fn view") + (_ : + lazyBool + (_ : append (append "guard failed" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag)))) + (_ : + lazyBool + (_ : append (append "malformed guard result" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag)))) + (_ : "unknown checker error") + (equal? tag errorTagMalformedGuardResult)) + (equal? tag errorTagGuardFailed)) + (equal? tag errorTagZeroArityFunction)) + (equal? tag errorTagMissingFunctionArgumentView)) + (equal? tag errorTagMissingRequiredView)) + (equal? tag errorTagUnknownNode)) + (equal? tag errorTagMalformedProgram)) + (equal? tag errorTagMalformedPolicy)) + +viewContractProbe = (condition : + matchBool "ok" "fail" condition) + +viewContractExpectResult = (expected result : + matchResult + (diag env : viewContractProbe (equal? (diagnosticMessage diag) expected)) + (env rest : viewContractProbe (equal? "ok" expected)) + result) + +viewContractExpectErrorTag = (expected result : + viewContractProbe (equal? (checkerResultErrorTag result) expected)) + +viewContractExpectDiagnostic = (tag symbol expectedView result : + matchResult + (diag env : + viewContractProbe + (and? + (equal? (diagnosticTag diag) tag) + (and? + (equal? (diagnosticSymbol diag) symbol) + (equal? (diagnosticExpectedView diag) expectedView)))) + (env rest : "fail") + result) + +viewContractExpectDiagnosticActual = (tag symbol expectedView actualView result : + matchResult + (diag env : + viewContractProbe + (and? + (equal? (diagnosticTag diag) tag) + (and? + (equal? (diagnosticSymbol diag) symbol) + (and? + (equal? (diagnosticExpectedView diag) expectedView) + (equal? (diagnosticActualView diag) actualView))))) + (env rest : "fail") + result) + +-- Small typed-program builder layer. These aliases make hand-written +-- contracts look like source-level declarations while emitting typed nodes. +typedDeclareFn = (symbol args result term : + typedValue symbol (viewFn args result) term) + +viewUnary = (arg result : + viewFn [(arg)] result) + +viewBinary = (left right result : + viewFn [(left) (right)] result) + +viewTernary = (first second third result : + viewFn [(first) (second) (third)] result) + +typedDeclareUnary = (symbol arg result term : + typedDeclareFn symbol [(arg)] result term) + +typedDeclareBinary = (symbol left right result term : + typedDeclareFn symbol [(left) (right)] result term) + +typedDeclareTernary = (symbol first second third result term : + typedDeclareFn symbol [(first) (second) (third)] result term) + +typedUseUnary = (arg result fnSym argSym outSym : + typedProgram + outSym + [(typedDeclareUnary fnSym arg result t) + (typedValue argSym arg t) + (typedApply outSym fnSym argSym t) + (typedRequire outSym result t)]) + +typedUseBinary = (left right result fnSym leftSym rightSym partialSym outSym : + typedProgram + outSym + [(typedDeclareBinary fnSym left right result t) + (typedValue leftSym left t) + (typedValue rightSym right t) + (typedApply partialSym fnSym leftSym t) + (typedApply outSym partialSym rightSym t) + (typedRequire outSym result t)]) + +typedUseTernary = (first second third result fnSym firstSym secondSym thirdSym partial1Sym partial2Sym outSym : + typedProgram + outSym + [(typedDeclareTernary fnSym first second third result t) + (typedValue firstSym first t) + (typedValue secondSym second t) + (typedValue thirdSym third t) + (typedApply partial1Sym fnSym firstSym t) + (typedApply partial2Sym partial1Sym secondSym t) + (typedApply outSym partial2Sym thirdSym t) + (typedRequire outSym result t)]) + +cValue = (view : + record contractExprTagValue [(field contractExprFieldView view)]) + +cFn = (args result : + record contractExprTagFn + [(field contractExprFieldArgs args) (field contractExprFieldResult result)]) + +cCall = (fn arg : + record contractExprTagCall + [(field contractExprFieldFn fn) (field contractExprFieldArg arg)]) + +cApply = (arg fn : cCall fn arg) + +cRequire = (view expr : + record contractExprTagRequire + [(field contractExprFieldExpr expr) (field contractExprFieldRequired view)]) + +cCompiledSymbol = fst +cCompiledNext = (compiled : fst (snd compiled)) +cCompiledNodes = (compiled : snd (snd compiled)) +cCompiled = (symbol next nodes : pair symbol (pair next nodes)) + +cCompile_ self base expr = + let tag = recordTag expr in + let fields = recordFields expr in + lazyBool + (_ : + cCompiled + base + (succ base) + [(typedValue base (field0 fields) t)]) + (_ : + lazyBool + (_ : + cCompiled + base + (succ base) + [(typedDeclareFn base (field0 fields) (field1 fields) t)]) + (_ : + lazyBool + (_ : + let fnCompiled = self base (field0 fields) in + let argCompiled = self (cCompiledNext fnCompiled) (field1 fields) in + let outSym = cCompiledNext argCompiled in + cCompiled + outSym + (succ outSym) + (append + (cCompiledNodes fnCompiled) + (append + (cCompiledNodes argCompiled) + [(typedApply outSym (cCompiledSymbol fnCompiled) (cCompiledSymbol argCompiled) t)]))) + (_ : + let innerCompiled = self base (field0 fields) in + cCompiled + (cCompiledSymbol innerCompiled) + (cCompiledNext innerCompiled) + (append + (cCompiledNodes innerCompiled) + [(typedRequire (cCompiledSymbol innerCompiled) (field1 fields) t)])) + (equal? tag contractExprTagCall)) + (equal? tag contractExprTagFn)) + (equal? tag contractExprTagValue) + +cCompile = (base expr : y cCompile_ base expr) + +cCompileAt = (base expr : + let compiled = cCompile base expr in + typedProgram (cCompiledSymbol compiled) (cCompiledNodes compiled)) + +typedContractCheck = (program : + viewContractExpectResult "ok" (checkTypedProgram program)) + +viewContractSelfTests = [ + (viewContractProbe (wellFormedView? viewAny)) + (viewContractProbe (wellFormedView? (viewRef 10))) + (viewContractProbe (wellFormedView? (viewList viewBool))) + (viewContractProbe (wellFormedView? (viewMaybe viewString))) + (viewContractProbe (wellFormedView? (viewPair viewBool viewString))) + (viewContractProbe (wellFormedView? (viewResult viewString viewBool))) + (viewContractProbe (wellFormedView? (viewGuarded viewString (x : x)))) + (viewContractProbe (equal? (renderView viewBool) "Bool")) + (viewContractProbe (equal? (renderView (viewList viewBool)) "List Bool")) + (viewContractProbe (equal? (renderView (viewMaybe viewString)) "Maybe String")) + (viewContractProbe (equal? (renderView (viewPair viewBool viewString)) "Pair Bool String")) + (viewContractProbe (equal? (renderView (viewResult viewString viewBool)) "Result String Bool")) + (viewContractProbe (equal? (renderView (viewGuarded viewString (x : x))) "Guarded String")) + (viewContractProbe (equal? (renderView (viewFn [(viewBool) (viewString)] viewUnit)) "Fn [Bool, String] Unit")) + (viewContractProbe (not? (wellFormedView? 10))) + (viewContractProbe (not? (wellFormedView? (record viewTagList [(field 99 viewBool)])))) + (viewContractExpectResult + "ok" + (checkTypedProgram + (typedProgram + 0 + [(typedValue 0 viewBool t) + (typedRequire 0 viewBool t)]))) + (viewContractExpectResult + "ok" + (checkTypedProgram + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewBool)] viewString) t) + (typedValue 1 viewBool t) + (typedApply 2 0 1 t) + (typedRequire 2 viewString t)]))) + (typedContractCheck (typedUseUnary viewBool viewString 20 21 22)) + (typedContractCheck (typedUseBinary viewBool viewString viewUnit 30 31 32 33 34)) + (typedContractCheck (typedUseTernary viewBool viewString viewByte viewUnit 40 41 42 43 44 45 46)) + (typedContractCheck + (cCompileAt + 50 + (cRequire viewString (cApply (cValue viewBool) (cFn [(viewBool)] viewString))))) + (typedContractCheck + (cCompileAt + 60 + (cRequire + (viewList viewString) + (cApply + (cValue (viewList viewBool)) + (cApply + (cFn [(viewBool)] viewString) + (cFn [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString))))))) + (viewContractExpectResult + "function argument view is not known" + (checkTypedProgramWith + policyStrict + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewBool)] viewString) t) + (typedApply 2 0 1 t)]))) + (viewContractExpectResult + "ok" + (checkTypedProgramWith + policyGradual + (typedProgram + 0 + [(typedRequire 0 viewBool t)]))) + (viewContractExpectResult + "malformed view program" + (checkTypedProgram (record 99 t))) + (viewContractExpectResult + "ok" + (checkTypedProgram + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewBool)] viewString) t) + (typedValue 1 viewBool t) + (typedApply 2 0 1 (t t)) + (typedRequire 2 viewString (t t))]))) + (viewContractProbe + (equal? + (checkedProgramTree + (checkTypedProgram + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewBool)] viewString) t) + (typedValue 1 viewBool t) + (typedApply 2 0 1 (t t)) + (typedRequire 2 viewString (t t))]))) + (t t))) + (viewContractExpectErrorTag + errorTagMissingFunctionArgumentView + (checkTypedProgramWith + policyStrict + (typedProgram + 2 + [(typedValue 0 (viewFn [(viewBool)] viewString) t) + (typedApply 2 0 1 (t t))]))) + (viewContractExpectErrorTag + errorTagMalformedProgram + (checkTypedProgram + (typedProgram 0 [(record typedNodeTagValue t)]))) + (viewContractExpectErrorTag + errorTagMalformedPolicy + (checkTypedProgramWith (pair 99 t) (typedProgram 0 t))) + (viewContractExpectErrorTag + errorTagMalformedProgram + (checkTypedProgram (record 99 t)))] diff --git a/lib/views/catalog.tri b/lib/views/catalog.tri new file mode 100644 index 0000000..c35ddd3 --- /dev/null +++ b/lib/views/catalog.tri @@ -0,0 +1,267 @@ +!import "prelude" !Local +!import "view" !Local + +-- Stdlib-shaped typed-program catalog. These helpers are stable lowering +-- targets for frontend-emitted API contracts. They are monomorphic +-- instantiations of familiar polymorphic shapes. +listMapUseContract = (elemIn elemOut mapSym fnSym xsSym partialSym outSym : + typedProgram + outSym + [(typedDeclareFn + mapSym + [(viewFn [(elemIn)] elemOut) (viewList elemIn)] + (viewList elemOut) + t) + (typedDeclareFn fnSym [(elemIn)] elemOut t) + (typedValue xsSym (viewList elemIn) t) + (typedApply partialSym mapSym fnSym t) + (typedApply outSym partialSym xsSym t) + (typedRequire outSym (viewList elemOut) t)]) + +headMaybeUseContract = (elem headSym xsSym outSym : + typedProgram + outSym + [(typedDeclareFn headSym [(viewList elem)] (viewMaybe elem) t) + (typedValue xsSym (viewList elem) t) + (typedApply outSym headSym xsSym t) + (typedRequire outSym (viewMaybe elem) t)]) + +listFilterUseContract = (elem filterSym predSym xsSym partialSym outSym : + typedProgram + outSym + [(typedDeclareFn + filterSym + [(viewFn [(elem)] viewBool) (viewList elem)] + (viewList elem) + t) + (typedDeclareFn predSym [(elem)] viewBool t) + (typedValue xsSym (viewList elem) t) + (typedApply partialSym filterSym predSym t) + (typedApply outSym partialSym xsSym t) + (typedRequire outSym (viewList elem) t)]) + +listFoldUseContract = (acc elem foldSym fnSym initSym xsSym partialFnSym partialInitSym outSym : + typedProgram + outSym + [(typedDeclareFn + foldSym + [(viewFn [(acc) (elem)] acc) acc (viewList elem)] + acc + t) + (typedDeclareFn fnSym [(acc) (elem)] acc t) + (typedValue initSym acc t) + (typedValue xsSym (viewList elem) t) + (typedApply partialFnSym foldSym fnSym t) + (typedApply partialInitSym partialFnSym initSym t) + (typedApply outSym partialInitSym xsSym t) + (typedRequire outSym acc t)]) + +listMapMaybeUseContract = (elemIn elemOut mapMaybeSym fnSym xsSym partialSym outSym : + typedProgram + outSym + [(typedDeclareFn + mapMaybeSym + [(viewFn [(elemIn)] (viewMaybe elemOut)) (viewList elemIn)] + (viewList elemOut) + t) + (typedDeclareFn fnSym [(elemIn)] (viewMaybe elemOut) t) + (typedValue xsSym (viewList elemIn) t) + (typedApply partialSym mapMaybeSym fnSym t) + (typedApply outSym partialSym xsSym t) + (typedRequire outSym (viewList elemOut) t)]) + +-- Concrete stdlib-shaped typed programs. These are deliberately monomorphic +-- examples of the shapes a frontend can emit for polymorphic library functions. +listMapBoolStringExpr = cFn <| + [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString) + |> cApply (cFn [(viewBool)] viewString) + |> cApply (cValue (viewList viewBool)) + |> cRequire (viewList viewString) + +headMaybeBoolExpr = cFn <| + [(viewList viewBool)] (viewMaybe viewBool) + |> cApply (cValue (viewList viewBool)) + |> cRequire (viewMaybe viewBool) + +listFilterBoolExpr = cFn <| + [(viewFn [(viewBool)] viewBool) (viewList viewBool)] (viewList viewBool) + |> cApply (cFn [(viewBool)] viewBool) + |> cApply (cValue (viewList viewBool)) + |> cRequire (viewList viewBool) + +listFoldStringBoolExpr = cFn <| + [(viewFn [(viewString) (viewBool)] viewString) viewString (viewList viewBool)] viewString + |> cApply (cFn [(viewString) (viewBool)] viewString) + |> cApply (cValue viewString) + |> cApply (cValue (viewList viewBool)) + |> cRequire viewString + +listMapMaybeBoolStringExpr = cFn <| + [(viewFn [(viewBool)] (viewMaybe viewString)) (viewList viewBool)] (viewList viewString) + |> cApply (cFn [(viewBool)] (viewMaybe viewString)) + |> cApply (cValue (viewList viewBool)) + |> cRequire (viewList viewString) + +-- Keep catalog exports as explicit finite typed-programs. `cCompileAt` is useful +-- as a frontend-emission helper, but forcing generated node lists at module +-- import time can violate top-level normalization discipline. +listMapBoolStringContract = + listMapUseContract viewBool viewString 100 101 102 103 104 +headMaybeBoolContract = + headMaybeUseContract viewBool 110 111 112 +listFilterBoolContract = + listFilterUseContract viewBool 120 121 122 123 124 +listFoldStringBoolContract = + listFoldUseContract viewString viewBool 130 131 132 133 134 135 136 +listMapMaybeBoolStringContract = + listMapMaybeUseContract viewBool viewString 140 141 142 143 144 + +listMapWrongFunctionArgContract = + typedProgram + 152 + [(typedDeclareFn + 150 + [(viewFn [(viewBool)] viewString) (viewList viewBool)] + (viewList viewString) + t) + (typedDeclareFn 151 [(viewString)] viewString t) + (typedApply 152 150 151 t)] + +listMapWrongListArgContract = + typedProgram + 164 + [(typedDeclareFn + 160 + [(viewFn [(viewBool)] viewString) (viewList viewBool)] + (viewList viewString) + t) + (typedDeclareFn 161 [(viewBool)] viewString t) + (typedValue 162 (viewList viewString) t) + (typedApply 163 160 161 t) + (typedApply 164 163 162 t)] + +listMapWrongOutputContract = + typedProgram + 174 + [(typedDeclareFn + 170 + [(viewFn [(viewBool)] viewString) (viewList viewBool)] + (viewList viewString) + t) + (typedDeclareFn 171 [(viewBool)] viewString t) + (typedValue 172 (viewList viewBool) t) + (typedApply 173 170 171 t) + (typedApply 174 173 172 t) + (typedRequire 174 (viewList viewBool) t)] + +listFilterWrongPredicateContract = + typedProgram + 182 + [(typedDeclareFn + 180 + [(viewFn [(viewBool)] viewBool) (viewList viewBool)] + (viewList viewBool) + t) + (typedDeclareFn 181 [(viewBool)] viewString t) + (typedApply 182 180 181 t)] + +listMapWrongListArgExpr = cFn <| + [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString) + |> cApply (cFn [(viewBool)] viewString) + |> cApply (cValue (viewList viewString)) + |> cRequire (viewList viewString) + +listMapWrongListArgExprContract = + typedProgram + 194 + [(typedDeclareFn + 190 + [(viewFn [(viewBool)] viewString) (viewList viewBool)] + (viewList viewString) + t) + (typedDeclareFn 191 [(viewBool)] viewString t) + (typedValue 193 (viewList viewString) t) + (typedApply 192 190 191 t) + (typedApply 194 192 193 t) + (typedRequire 194 (viewList viewString) t)] + +viewCatalogSelfTests = + append + viewContractSelfTests + [ (typedContractCheck listMapBoolStringContract) + (typedContractCheck headMaybeBoolContract) + (typedContractCheck listFilterBoolContract) + (typedContractCheck listFoldStringBoolContract) + (typedContractCheck listMapMaybeBoolStringContract) + (viewContractExpectResult + "function argument view is not known" + (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract)) + (viewContractExpectResult + "function argument view is not known" + (checkTypedProgramWith policyStrict listMapWrongListArgContract)) + (viewContractExpectResult + "required view is not known" + (checkTypedProgramWith policyStrict listMapWrongOutputContract)) + (viewContractExpectResult + "function argument view is not known" + (checkTypedProgramWith policyStrict listFilterWrongPredicateContract)) + (viewContractExpectResult + "function argument view is not known" + (checkTypedProgramWith policyStrict listMapWrongListArgExprContract)) + (viewContractExpectErrorTag + errorTagOk + (checkTypedProgram listMapBoolStringContract)) + (viewContractExpectErrorTag + errorTagMissingFunctionArgumentView + (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract)) + (viewContractExpectErrorTag + errorTagMissingFunctionArgumentView + (checkTypedProgramWith policyStrict listMapWrongListArgContract)) + (viewContractExpectErrorTag + errorTagMissingFunctionArgumentView + (checkTypedProgramWith policyStrict listMapWrongListArgExprContract)) + (viewContractExpectErrorTag + errorTagMissingRequiredView + (checkTypedProgramWith policyStrict listMapWrongOutputContract)) + (viewContractExpectDiagnostic + errorTagMissingFunctionArgumentView + 162 + (viewList viewBool) + (checkTypedProgramWith policyStrict listMapWrongListArgContract)) + (viewContractExpectDiagnostic + errorTagMissingRequiredView + 174 + (viewList viewBool) + (checkTypedProgramWith policyStrict listMapWrongOutputContract)) + (viewContractExpectDiagnosticActual + errorTagMissingFunctionArgumentView + 162 + (viewList viewBool) + (viewList viewString) + (checkTypedProgramWith policyStrict listMapWrongListArgContract)) + (viewContractExpectDiagnosticActual + errorTagMissingFunctionArgumentView + 193 + (viewList viewBool) + (viewList viewString) + (checkTypedProgramWith policyStrict listMapWrongListArgExprContract)) + (viewContractExpectDiagnosticActual + errorTagMissingRequiredView + 174 + (viewList viewBool) + (viewList viewString) + (checkTypedProgramWith policyStrict listMapWrongOutputContract)) + (viewContractExpectDiagnosticActual + errorTagMissingFunctionArgumentView + 181 + (viewFn [(viewBool)] viewBool) + (viewFn [(viewBool)] viewString) + (checkTypedProgramWith policyStrict listFilterWrongPredicateContract)) + (matchResult + (diag env : + viewContractProbe + (equal? + (renderDiagnostic diag) + "symbol 162 expected List Bool but got List String")) + (env rest : "fail") + (checkTypedProgramWith policyStrict listMapWrongListArgContract))] diff --git a/src/Check.hs b/src/Check.hs new file mode 100644 index 0000000..36035b0 --- /dev/null +++ b/src/Check.hs @@ -0,0 +1,42 @@ +module Check + ( module Check.Core + , module Check.IO + , checkFile + , checkFileWithStore + , checkSource + ) where + +import Check.Core +import Check.IO +import ContentStore (ObjectRef, StorePath, getViewType) +import Eval (evalTricu) +import FileEval (LoadedSource(..), defaultStorePath, evaluateFile, evaluateFileWithStore, loadFileWithStore) +import Research (Env, ViewType) + +import qualified Data.Map as Map + +import System.IO.Unsafe (unsafePerformIO) + +checkFile :: FilePath -> IO String +checkFile path = do + store <- defaultStorePath + checkFileWithStore store path + +checkFileWithStore :: StorePath -> FilePath -> IO String +checkFileWithStore store path = do + loaded <- loadFileWithStore store path + viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri" + let baseEnv = Map.union viewEnv (loadedImports loaded) + checkerEnv = evalTricu baseEnv (loadedAst loaded) + imports <- importedViewsFromResolvedModulesEither (loadImportedView store) (loadedModules loaded) + checkProgramWithEnvAndImportedViews checkerEnv imports (loadedAst loaded) + +viewCheckerEnv :: Env +viewCheckerEnv = unsafePerformIO (evaluateFile "./lib/view.tri") +{-# NOINLINE viewCheckerEnv #-} + +checkSource :: String -> IO String +checkSource = checkSourceWithEnv viewCheckerEnv + +loadImportedView :: StorePath -> ObjectRef -> IO (Either String ViewType) +loadImportedView = getViewType diff --git a/src/Check/Core.hs b/src/Check/Core.hs new file mode 100644 index 0000000..0a48855 --- /dev/null +++ b/src/Check/Core.hs @@ -0,0 +1,751 @@ +module Check.Core + ( ImportedView(..) + , importedViewsFromResolvedModules + , importedViewsFromResolvedModulesEither + , checkProgramWithEnvAndImportedViews + , checkSourceWithEnv + , checkSourceWithEnvAndImportedViews + , lowerSource + , lowerSourceWithDebug + , lowerSourceWithImportedViews + , lowerSourceWithImportedViewsDebug + , lowerViewExpr + ) where + +import Control.Monad.State.Strict +import Data.Char (isDigit) +import qualified Data.Map as Map +import qualified Data.Text as T + +import ContentStore.Alias (ObjectRef(..)) +import Eval (evalTricu, result) +import Module.Resolver + ( ResolvedExport(..) + , ResolvedModule(..) + ) +import Parser (parseTricu) +import Research + +data ImportedView = ImportedView + { importedViewName :: String + , importedViewType :: ViewType + } deriving (Show, Eq) + +-- Convert module-resolution metadata into checker evidence inputs. The loader +-- decodes a portable view artifact into a syntactic ViewType, but this function +-- does not judge compatibility or policy. It only says: this resolved imported +-- name has an advertised view fact that should be emitted into the typed program. +importedViewsFromResolvedModules :: (ObjectRef -> IO (Maybe ViewType)) -> [ResolvedModule] -> IO [ImportedView] +importedViewsFromResolvedModules loadView = importedViewsFromResolvedModulesEither loadViewEither + where + loadViewEither ref = do + mView <- loadView ref + pure $ maybe (Left "artifact not found or could not be decoded") Right mView + +importedViewsFromResolvedModulesEither :: (ObjectRef -> IO (Either String ViewType)) -> [ResolvedModule] -> IO [ImportedView] +importedViewsFromResolvedModulesEither loadView modules = concat <$> mapM fromModule modules + where + fromModule m = concat <$> mapM fromExport (resolvedModuleExports m) + + fromExport ex = case resolvedExportView ex of + Nothing -> pure [] + Just ref -> do + eView <- loadView ref + case eView of + Left err -> errorWithoutStackTrace $ + "View Contract artifact invalid for imported export " + ++ show (resolvedExportLocalName ex) + ++ " (kind " ++ showRefKind ref ++ ", hash " ++ showRefHash ref ++ "): " + ++ err + Right view -> pure [ImportedView (resolvedExportLocalName ex) view] + + showRefKind = T.unpack . objectRefKind + showRefHash = T.unpack . objectRefHash + +checkSourceWithEnv :: Env -> String -> IO String +checkSourceWithEnv checkerEnv = checkSourceWithEnvAndImportedViews checkerEnv [] + +checkSourceWithEnvAndImportedViews :: Env -> [ImportedView] -> String -> IO String +checkSourceWithEnvAndImportedViews checkerEnv imports source = + checkProgramWithEnvAndImportedViews checkerEnv imports (parseTricu source) + +checkProgramWithEnvAndImportedViews :: Env -> [ImportedView] -> [TricuAST] -> IO String +checkProgramWithEnvAndImportedViews checkerEnv imports asts = do + case lowerProgramWithImportedViewsDebugInEnv checkerEnv imports asts of + Left err -> pure err + Right (typedProgramSource, debugNames) -> do + let input = + "matchResult " ++ + "(diag env : renderDiagnostic diag) " ++ + "(exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (_ runtimeEnv : \"ok\") (runChecked exec)) " ++ + "(checkTypedProgramWith policyStrict " ++ parens typedProgramSource ++ ")" + let env = evalTricu checkerEnv (parseTricu input) + pure $ case toString (result env) of + Right s -> annotateDiagnostic debugNames s + Left _ -> formatT Decode (result env) + +-- Debug names are a frontend-only side table. The portable checker renders +-- canonical numeric-symbol diagnostics; the CLI annotates that presentation +-- afterward without feeding labels back into checker semantics. +annotateDiagnostic :: Map.Map Integer String -> String -> String +annotateDiagnostic debugNames message = + case words message of + ("symbol" : symText : rest) + | all isDigit symText + , Just label <- Map.lookup (read symText) debugNames -> + "symbol " ++ symText ++ " (" ++ label ++ ") " ++ unwords rest + _ -> message + +lowerSource :: String -> Either String String +lowerSource = lowerProgram . parseTricu + +lowerSourceWithDebug :: String -> Either String (String, Map.Map Integer String) +lowerSourceWithDebug = lowerProgramWithDebug . parseTricu + +lowerSourceWithImportedViews :: [ImportedView] -> String -> Either String String +lowerSourceWithImportedViews imports = lowerProgramWithImportedViews imports . parseTricu + +lowerSourceWithImportedViewsDebug :: [ImportedView] -> String -> Either String (String, Map.Map Integer String) +lowerSourceWithImportedViewsDebug imports = lowerProgramWithImportedViewsDebug imports . parseTricu + +-- Symbol allocation is intentionally deterministic so emitted view-tree +-- nodes are stable and lower-only tests can inspect them directly: +-- +-- * top-level definitions receive symbols 0..n-1 in source order; +-- * local binders, literals, application results, and synthetic typed nodes +-- are allocated monotonically from nextSym; +-- * external names are allocated on first reference and then reused. +-- +-- Symbols are view-tree node identifiers only. Checker semantics remain in +-- lib/view.tri; the frontend only emits typed/checkable structure about these +-- symbols. +data LowerState = LowerState + { nextSym :: Integer + , topSyms :: Map.Map String Integer + , scopes :: [Map.Map String Integer] + , externSyms :: Map.Map String Integer + , knownNodeViews :: Map.Map Integer ViewExpr + , nodePayloads :: Map.Map Integer T + , debugNames :: Map.Map Integer String + } + +type LowerM a = StateT LowerState (Either String) a + +lowerProgram :: [TricuAST] -> Either String String +lowerProgram asts = fst <$> lowerProgramWithDebug asts + +lowerProgramWithDebug :: [TricuAST] -> Either String (String, Map.Map Integer String) +lowerProgramWithDebug = lowerProgramWithImportedViewsDebug [] + +lowerProgramWithImportedViews :: [ImportedView] -> [TricuAST] -> Either String String +lowerProgramWithImportedViews imports asts = fst <$> lowerProgramWithImportedViewsDebug imports asts + +lowerProgramWithImportedViewsDebug :: [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String) +lowerProgramWithImportedViewsDebug = lowerProgramWithImportedViewsDebugInEnv Map.empty + +lowerProgramWithImportedViewsDebugInEnv :: Env -> [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String) +lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do + let definitions = [ def | def <- asts, isDefinition def ] + topNames = map definitionName definitions + tops = Map.fromList (zip topNames [0..]) + topCount = Map.size tops + importedSyms = Map.fromList + [ (importedViewName imported, fromIntegral (topCount + idx)) + | (idx, imported) <- zip [0..] imports + ] + topDebug = Map.fromList [ (sym, name) | (name, sym) <- Map.toList tops ] + importDebug = Map.fromList + [ (sym, "imported " ++ name) + | (name, sym) <- Map.toList importedSyms + ] + importKnown = Map.fromList + [ (sym, viewTypeToExpr (importedViewType imported)) + | imported <- imports + , Just sym <- [Map.lookup (importedViewName imported) importedSyms] + ] + payloads = Map.fromList $ + [ (sym, term) + | (name, sym) <- Map.toList tops + , Just term <- [Map.lookup name checkerEnvForLowering] + ] ++ + [ (sym, term) + | (name, sym) <- Map.toList importedSyms + , Just term <- [Map.lookup name checkerEnvForLowering] + ] + annotated = [ def | def@SDefAnn {} <- asts ] + initialState = LowerState + { nextSym = fromIntegral (Map.size tops + Map.size importedSyms) + , topSyms = tops + , scopes = [] + , externSyms = importedSyms + , knownNodeViews = importKnown + , nodePayloads = payloads + , debugNames = Map.union topDebug importDebug + } + (localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState + importNodes <- mapM (lowerImportedView (nodePayloads finalState)) + [ (sym, viewTypeToExpr (importedViewType imported)) + | imported <- imports + , Just sym <- [Map.lookup (importedViewName imported) importedSyms] + ] + let nodes = importNodes ++ localNodes + rootSym = if null nodes then 0 else nextSym finalState - 1 + typedProgramSource = + "typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]" + pure (typedProgramSource, debugNames finalState) +lowerImportedView :: Map.Map Integer T -> (Integer, ViewExpr) -> Either String String +lowerImportedView payloadsBySym (sym, view) = do + viewExpr <- lowerViewExpr view + let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym) + pure $ "typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload + +lowerAnnotatedProgram :: [TricuAST] -> LowerM [String] +lowerAnnotatedProgram defs = do + declarations <- concat <$> mapM lowerDefinitionDeclaration defs + flows <- concat <$> mapM lowerDefinitionFlow defs + pure (declarations ++ flows) + +lowerDefinitionDeclaration :: TricuAST -> LowerM [String] +lowerDefinitionDeclaration (SDefAnn name args ret _) = do + sym <- symbolForTop name + argViews <- mapM lowerArgView args + retExpr <- liftEither (maybe (Right "viewAny") lowerViewExpr ret) + recordKnown sym (declaredDefinitionView args ret) + node <- emitDeclaration sym argViews retExpr + pure [node] +lowerDefinitionDeclaration _ = liftEither (Left "internal check error: expected annotated definition") + +lowerDefinitionFlow :: TricuAST -> LowerM [String] +lowerDefinitionFlow (SDefAnn _ args ret body) = withDefinitionScope args $ do + binderNodes <- concat <$> mapM lowerBinderDeclaration args + let phantomViews = map lowerPhantomArgType (phantomArgs args) + (returnArgs, returnResult) <- lowerReturnObligation ret + bodyNodes <- lowerBodyWithPhantoms (phantomViews ++ returnArgs) returnResult body + pure (binderNodes ++ bodyNodes) +lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotated definition") + +viewAnyType :: ViewExpr +viewAnyType = VEName "Any" + +declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr +declaredDefinitionView args ret = + case map argType args of + [] -> resultType + views -> viewExprFn views resultType + where + resultType = maybe viewAnyType id ret + +argType :: DefArg -> ViewExpr +argType (DefBinder _ Nothing) = viewAnyType +argType (DefBinder _ (Just ty)) = ty +argType (DefPhantom ty) = ty + +emitDeclaration :: Integer -> [String] -> String -> LowerM String +emitDeclaration sym [] retExpr = do + payload <- payloadSourceFor sym + pure $ "typedValue " ++ show sym ++ " " ++ parens retExpr ++ " " ++ payload +emitDeclaration sym views retExpr = do + payload <- payloadSourceFor sym + pure $ "typedValue " ++ show sym ++ " (viewFn [" ++ unwords (map parens views) ++ "] " ++ parens retExpr ++ ") " ++ payload + +typedValueNode :: Integer -> ViewExpr -> LowerM String +typedValueNode sym view = do + viewExpr <- liftEither (lowerViewExpr view) + payload <- payloadSourceFor sym + pure ("typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload) + +typedRequireNode :: Integer -> ViewExpr -> LowerM String +typedRequireNode sym view = do + viewExpr <- liftEither (lowerViewExpr view) + payload <- payloadSourceFor sym + pure ("typedRequire " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload) + +declareKnown :: Integer -> ViewExpr -> LowerM String +declareKnown sym view = do + recordKnown sym view + typedValueNode sym view + +declareKnownWithPayload :: Integer -> ViewExpr -> T -> LowerM String +declareKnownWithPayload sym view payload = do + recordPayload sym payload + declareKnown sym view + +declareKnownFresh :: ViewExpr -> LowerM (Integer, [String]) +declareKnownFresh view = do + sym <- freshSym + node <- declareKnown sym view + pure (sym, [node]) + +declareKnownFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String]) +declareKnownFreshWithPayload view payload = do + sym <- freshSym + node <- declareKnownWithPayload sym view payload + pure (sym, [node]) + +declareAndRequireFresh :: ViewExpr -> LowerM (Integer, [String]) +declareAndRequireFresh view = do + sym <- freshSym + declareNode <- declareKnown sym view + requireNode <- typedRequireNode sym view + pure (sym, [declareNode, requireNode]) + +declareAndRequireFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String]) +declareAndRequireFreshWithPayload view payload = do + sym <- freshSym + declareNode <- declareKnownWithPayload sym view payload + requireNode <- typedRequireNode sym view + pure (sym, [declareNode, requireNode]) + +lowerBinderDeclaration :: DefArg -> LowerM [String] +lowerBinderDeclaration (DefBinder name mTy) = do + sym <- symbolForLocal name + node <- declareKnown sym (maybe viewAnyType id mTy) + pure [node] +lowerBinderDeclaration (DefPhantom _) = pure [] + +lowerBodyWithPhantoms :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM [String] +lowerBodyWithPhantoms [] _ SLambda {} = pure [] +lowerBodyWithPhantoms [] expected body = + lowerExprAgainst body expected +lowerBodyWithPhantoms phantomViews expected (SLambda params body) = + lowerLambdaSpine phantomViews expected params body +lowerBodyWithPhantoms phantomViews expected body = + lowerExprAgainst body (residualViewExpr phantomViews expected) + +lowerLambdaSpine :: [ViewExpr] -> ViewExpr -> [String] -> TricuAST -> LowerM [String] +lowerLambdaSpine phantomViews expected [] body = lowerBodyWithPhantoms phantomViews expected body +lowerLambdaSpine [] _ _ _ = pure [] +lowerLambdaSpine (view : views) expected (param : params) body = + withLocalBinder param $ \paramSym -> do + declareParam <- declareKnown paramSym view + restNodes <- lowerLambdaSpine views expected params body + pure (declareParam : restNodes) + +residualViewExpr :: [ViewExpr] -> ViewExpr -> ViewExpr +residualViewExpr [] resultView = resultView +residualViewExpr args resultView = viewExprFn args resultView + +phantomArgs :: [DefArg] -> [DefArg] +phantomArgs [] = [] +phantomArgs (DefPhantom ty : rest) = DefPhantom ty : phantomArgs rest +phantomArgs (_ : rest) = phantomArgs rest + +lowerPhantomArgType :: DefArg -> ViewExpr +lowerPhantomArgType (DefPhantom ty) = ty +lowerPhantomArgType _ = error "internal check error: expected phantom arg" + +lowerReturnObligation :: Maybe ViewExpr -> LowerM ([ViewExpr], ViewExpr) +lowerReturnObligation Nothing = pure ([], viewAnyType) +lowerReturnObligation (Just ty) = pure (peelFnObligation ty) + +peelFnObligation :: ViewExpr -> ([ViewExpr], ViewExpr) +peelFnObligation ty = case viewExprFnParts ty of + Just (args, resultView) -> + let (restArgs, finalResult) = peelFnObligation resultView + in (args ++ restArgs, finalResult) + Nothing -> ([], ty) + +withDefinitionScope :: [DefArg] -> LowerM a -> LowerM a +withDefinitionScope args action = do + binderEntries <- mapM allocateBinder [ name | DefBinder name _ <- args ] + modify $ \st -> st { scopes = Map.fromList binderEntries : scopes st } + resultValue <- action + modify $ \st -> st { scopes = drop 1 (scopes st) } + pure resultValue + +allocateBinder :: String -> LowerM (String, Integer) +allocateBinder name = do + sym <- freshSym + recordDebugName sym name + pure (name, sym) + +withLocalBinder :: String -> (Integer -> LowerM a) -> LowerM a +withLocalBinder name action = do + sym <- freshSym + recordDebugName sym name + withLocalAlias name sym (action sym) + +withLocalAlias :: String -> Integer -> LowerM a -> LowerM a +withLocalAlias name sym action = do + modify $ \st -> st { scopes = Map.singleton name sym : scopes st } + resultValue <- action + modify $ \st -> st { scopes = drop 1 (scopes st) } + pure resultValue + +recordKnown :: Integer -> ViewExpr -> LowerM () +recordKnown sym view = + modify $ \st -> st { knownNodeViews = Map.insert sym view (knownNodeViews st) } + +recordPayload :: Integer -> T -> LowerM () +recordPayload sym payload = + modify $ \st -> st { nodePayloads = Map.insert sym payload (nodePayloads st) } + +payloadFor :: Integer -> LowerM (Maybe T) +payloadFor sym = do + st <- get + pure (Map.lookup sym (nodePayloads st)) + +payloadSourceFor :: Integer -> LowerM String +payloadSourceFor sym = maybe "t" treeSource <$> payloadFor sym + +knownNodeViewFor :: Integer -> LowerM (Maybe ViewExpr) +knownNodeViewFor sym = do + st <- get + pure (Map.lookup sym (knownNodeViews st)) + +recordDebugName :: Integer -> String -> LowerM () +recordDebugName sym label = + modify $ \st -> st { debugNames = Map.insertWith keepExisting sym label (debugNames st) } + where + keepExisting _ old = old + +lowerExpr :: TricuAST -> LowerM (Integer, [String]) +lowerExpr expr = do + (sym, nodes, _) <- lowerExprKnown expr + pure (sym, nodes) + +lowerExprAgainst :: TricuAST -> ViewExpr -> LowerM [String] +lowerExprAgainst body expected = do + (_, nodes, _) <- lowerExprKnownAgainst body expected + pure nodes + +lowerExprKnownAgainst :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr) +lowerExprKnownAgainst expr expected = case (expr, viewExprAsType expected) of + (SApp (SApp (SVar "pair" _) left) right, Just (VTPair leftView rightView)) -> + let leftExpr = viewTypeToExpr leftView + rightExpr = viewTypeToExpr rightView + in lowerUnshadowedConstructor "pair" expr expected $ do + (_, leftNodes, _) <- lowerExprKnownAgainst left leftExpr + (_, rightNodes, _) <- lowerExprKnownAgainst right rightExpr + (sym, nodes) <- declareAndRequireFresh expected + pure (sym, leftNodes ++ rightNodes ++ nodes, Just expected) + (SApp (SVar "just" _) value, Just (VTMaybe elemView)) -> + let elemExpr = viewTypeToExpr elemView + in lowerUnshadowedConstructor "just" expr expected $ do + (_, valueNodes, _) <- lowerExprKnownAgainst value elemExpr + (sym, nodes) <- declareAndRequireFresh expected + pure (sym, valueNodes ++ nodes, Just expected) + (SVar "nothing" _, Just (VTMaybe _)) -> + lowerUnshadowedConstructor "nothing" expr expected $ do + (sym, nodes) <- declareAndRequireFresh expected + pure (sym, nodes, Just expected) + (SApp (SApp (SVar "ok" _) value) rest, Just (VTResult _ okView)) -> + lowerUnshadowedConstructor "ok" expr expected $ + lowerResultConstructor expected (viewTypeToExpr okView) value rest + (SApp (SApp (SVar "err" _) value) rest, Just (VTResult errView _)) -> + lowerUnshadowedConstructor "err" expr expected $ + lowerResultConstructor expected (viewTypeToExpr errView) value rest + (SApp (SLambda [name] body) value, _) -> do + (valueSym, valueNodes, _) <- lowerExprKnown value + bodyResult <- withLocalAlias name valueSym (lowerExprKnownAgainst body expected) + let (bodySym, bodyNodes, bodyKnown) = bodyResult + pure (bodySym, valueNodes ++ bodyNodes, bodyKnown) + (SList items, Just (VTList elemView)) -> do + let elemExpr = viewTypeToExpr elemView + lowered <- mapM (`lowerExprKnownAgainst` elemExpr) items + let itemNodes = concat [ nodes | (_, nodes, _) <- lowered ] + (sym, nodes) <- declareAndRequireFresh expected + pure (sym, itemNodes ++ nodes, Just expected) + (SLambda _ _, _) -> + case peelFnObligation expected of + ([], _) -> lowerExprKnownAndRequire expr expected + (argViews, resultView) -> lowerLambdaAgainst argViews resultView expr + _ -> lowerExprKnownAndRequire expr expected + +lowerUnshadowedConstructor :: String -> TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr) -> LowerM (Integer, [String], Maybe ViewExpr) +lowerUnshadowedConstructor name fallback expected lowerCtor = do + ctorIsUnbound <- nameIsUnbound name + if ctorIsUnbound + then lowerCtor + else lowerExprKnownAndRequire fallback expected + +lowerResultConstructor :: ViewExpr -> ViewExpr -> TricuAST -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr) +lowerResultConstructor expected valueView value rest = do + (_, valueNodes, _) <- lowerExprKnownAgainst value valueView + (_, restNodes, _) <- lowerExprKnown rest + (sym, nodes) <- declareAndRequireFresh expected + pure (sym, valueNodes ++ restNodes ++ nodes, Just expected) + +lowerExprKnownAndRequire :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr) +lowerExprKnownAndRequire body expected = do + (bodySym, bodyNodes, known) <- lowerExprKnown body + requireNode <- typedRequireNode bodySym expected + pure (bodySym, bodyNodes ++ [requireNode], known) + +lowerLambdaAgainst :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr) +lowerLambdaAgainst argViews resultView (SLambda params body) = do + nodes <- lowerLambdaSpine argViews resultView params body + sym <- freshSym + let fnView = residualViewExpr argViews resultView + declareNode <- declareKnown sym fnView + pure (sym, nodes ++ [declareNode], Just fnView) +lowerLambdaAgainst argViews resultView body = + lowerExprKnownAndRequire body (residualViewExpr argViews resultView) + +lowerExprKnown :: TricuAST -> LowerM (Integer, [String], Maybe ViewExpr) +lowerExprKnown (SVar name _) = do + sym <- symbolForName name + known <- knownNodeViewFor sym + pure (sym, [], known) +lowerExprKnown (SStr s) = do + let view = VEName "String" + (sym, nodes) <- declareKnownFreshWithPayload view (ofString s) + recordDebugName sym "string literal" + pure (sym, nodes, Just view) +lowerExprKnown (SInt n) + | n >= 0 && n <= 255 = do + let view = VEName "Byte" + (sym, nodes) <- declareKnownFreshWithPayload view (ofNumber n) + recordDebugName sym "byte literal" + pure (sym, nodes, Just view) + | otherwise = do + sym <- freshSym + pure (sym, [], Nothing) +lowerExprKnown TLeaf = do + let view = VEName "Unit" + (sym, nodes) <- declareKnownFreshWithPayload view Leaf + recordDebugName sym "unit literal" + pure (sym, nodes, Just view) +lowerExprKnown (SList items) = do + (sym, nodes, view, _) <- lowerListLiteral items + pure (sym, nodes, Just view) +lowerExprKnown (SApp (SLambda [name] body) value) = do + (valueSym, valueNodes, known) <- lowerExprKnown value + bodyResult <- withLocalAlias name valueSym (lowerExprKnown body) + let (bodySym, bodyNodes, bodyKnown) = bodyResult + pure (bodySym, valueNodes ++ bodyNodes, bodyKnown) +lowerExprKnown (SApp func arg) = do + (funcSym, funcNodes, funcKnown) <- lowerExprKnown func + (argSym, argNodes, _) <- lowerApplicationArgument funcKnown arg + outSym <- freshSym + recordDebugName outSym (applicationDebugLabel func) + funcPayload <- payloadFor funcSym + argPayload <- payloadFor argSym + case (funcPayload, argPayload) of + (Just f, Just a) -> recordPayload outSym (apply f a) + _ -> pure () + applyPayload <- payloadSourceFor outSym + let applyNode = "typedApply " ++ show outSym ++ " " ++ show funcSym ++ " " ++ show argSym ++ " " ++ applyPayload + outKnown = applicationResultView funcKnown + mapM_ (recordKnown outSym) outKnown + pure (outSym, funcNodes ++ argNodes ++ [applyNode], outKnown) +lowerExprKnown (SLambda params body) = do + nodes <- lowerUnannotatedLambda params body + sym <- freshSym + pure (sym, nodes, Nothing) +lowerExprKnown _ = do + sym <- freshSym + pure (sym, [], Nothing) + +lowerListLiteral :: [TricuAST] -> LowerM (Integer, [String], ViewExpr, [Integer]) +lowerListLiteral items = do + lowered <- mapM lowerExprKnown items + let itemSyms = [ itemSym | (itemSym, _, _) <- lowered ] + itemNodes = concat [ nodes | (_, nodes, _) <- lowered ] + view = listLiteralView [ known | (_, _, known) <- lowered ] + itemPayloads <- mapM payloadFor itemSyms + let mPayload = ofList <$> sequence itemPayloads + (sym, declareNodes) <- case mPayload of + Just payload -> declareKnownFreshWithPayload view payload + Nothing -> declareKnownFresh view + pure (sym, itemNodes ++ declareNodes, view, itemSyms) + +lowerApplicationArgument :: Maybe ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr) +lowerApplicationArgument (Just fnView) arg = + case viewExprFnParts fnView of + Just (argView : _, _) -> lowerExprKnownAgainst arg argView + _ -> lowerExprKnown arg +lowerApplicationArgument _ arg = + lowerExprKnown arg + +applicationDebugLabel :: TricuAST -> String +applicationDebugLabel func = + case applicationHeadName func of + Just name -> name ++ " application result" + Nothing -> "application result" + +applicationHeadName :: TricuAST -> Maybe String +applicationHeadName (SVar name _) = Just name +applicationHeadName (SApp func _) = applicationHeadName func +applicationHeadName _ = Nothing + +applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr +applicationResultView (Just fnView) = case viewExprFnParts fnView of + Just (_ : restArgs, resultView) -> + Just $ case restArgs of + [] -> resultView + _ -> viewExprFn restArgs resultView + _ -> Nothing +applicationResultView _ = Nothing + +listLiteralView :: [Maybe ViewExpr] -> ViewExpr +listLiteralView [] = viewExprList viewAnyType +listLiteralView (Just firstView : rest) + | all (== Just firstView) rest = viewExprList firstView +listLiteralView _ = viewExprList viewAnyType + +lowerUnannotatedLambda :: [String] -> TricuAST -> LowerM [String] +lowerUnannotatedLambda [] body = do + (_, nodes) <- lowerExpr body + pure nodes +lowerUnannotatedLambda (param : params) body = + withLocalBinder param $ \paramSym -> do + declareParam <- declareKnown paramSym viewAnyType + restNodes <- lowerUnannotatedLambda params body + pure (declareParam : restNodes) + +symbolForTop :: String -> LowerM Integer +symbolForTop name = do + st <- get + case Map.lookup name (topSyms st) of + Just sym -> pure sym + Nothing -> liftEither (Left $ "internal check error: missing top-level symbol: " ++ name) + +symbolForLocal :: String -> LowerM Integer +symbolForLocal name = do + st <- get + case lookupInScopes name (scopes st) of + Just sym -> pure sym + Nothing -> liftEither (Left $ "internal check error: missing local symbol: " ++ name) + +symbolForName :: String -> LowerM Integer +symbolForName name = do + st <- get + case lookupInScopes name (scopes st) of + Just sym -> pure sym + Nothing -> case Map.lookup name (topSyms st) of + Just sym -> pure sym + Nothing -> symbolForExternal name + +symbolForExternal :: String -> LowerM Integer +symbolForExternal name = do + st <- get + case Map.lookup name (externSyms st) of + Just sym -> pure sym + Nothing -> do + sym <- freshSym + recordDebugName sym ("external " ++ name) + modify $ \st' -> st' { externSyms = Map.insert name sym (externSyms st') } + pure sym + +nameIsUnbound :: String -> LowerM Bool +nameIsUnbound name = do + st <- get + pure $ case lookupInScopes name (scopes st) of + Just _ -> False + Nothing -> Map.notMember name (topSyms st) + +lookupInScopes :: String -> [Map.Map String Integer] -> Maybe Integer +lookupInScopes _ [] = Nothing +lookupInScopes name (scope : rest) = + case Map.lookup name scope of + Just sym -> Just sym + Nothing -> lookupInScopes name rest + +freshSym :: LowerM Integer +freshSym = do + st <- get + let sym = nextSym st + put st { nextSym = sym + 1 } + pure sym + +isDefinition :: TricuAST -> Bool +isDefinition SDef {} = True +isDefinition SDefAnn {} = True +isDefinition _ = False + +definitionName :: TricuAST -> String +definitionName (SDef name _ _) = name +definitionName (SDefAnn name _ _ _) = name +definitionName _ = error "definitionName: expected top-level definition" + +liftEither :: Either String a -> LowerM a +liftEither value = StateT $ \st -> case value of + Left err -> Left err + Right resultValue -> Right (resultValue, st) + +lowerArgView :: DefArg -> LowerM String +lowerArgView (DefBinder _ Nothing) = pure "viewAny" +lowerArgView (DefBinder _ (Just ty)) = liftEither (lowerViewExpr ty) +lowerArgView (DefPhantom ty) = liftEither (lowerViewExpr ty) + +viewTypeToExpr :: ViewType -> ViewExpr +viewTypeToExpr view = case view of + VTName name -> VEName name + VTRef n -> VEApp (VEName "Ref") (VEInt n) + VTRefText s -> VEApp (VEName "Ref") (VEString s) + VTList item -> VEApp (VEName "List") (viewTypeToExpr item) + VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item) + VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right) + VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok) + VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard)) + VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView) + +viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr +viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView + +viewExprList :: ViewExpr -> ViewExpr +viewExprList = VEApp (VEName "List") + +viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr) +viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView) +viewExprFnParts _ = Nothing + +viewExprAsType :: ViewExpr -> Maybe ViewType +viewExprAsType view = case view of + VEName name -> Just (VTName name) + VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n) + VEApp (VEName "Ref") (VEString s) -> Just (VTRefText s) + VEApp (VEName "List") item -> VTList <$> viewExprAsType item + VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item + VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right + VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok + VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView + _ -> Nothing + +lowerViewExpr :: ViewExpr -> Either String String +lowerViewExpr ty = case ty of + VEName "Any" -> Right "viewAny" + VEName "Bool" -> Right "viewBool" + VEName "String" -> Right "viewString" + VEName "Byte" -> Right "viewByte" + VEName "Unit" -> Right "viewUnit" + VEName name -> Right name + VEInt n -> Right (show n) + VEString s -> Right (show s) + VEList items -> do + itemExprs <- mapM lowerViewExpr items + Right $ "[" ++ unwords (map parens itemExprs) ++ "]" + VEApp (VEName "Ref") (VEInt n) -> Right $ "viewRef " ++ show n + VEApp (VEName "Ref") (VEString s) -> Right $ "viewRef " ++ show s + VEApp (VEName "List") elemView -> do + elemExpr <- lowerViewExpr elemView + Right $ "viewList " ++ parens elemExpr + VEApp (VEName "Maybe") elemView -> do + elemExpr <- lowerViewExpr elemView + Right $ "viewMaybe " ++ parens elemExpr + VEApp (VEApp (VEName "Pair") left) right -> do + l <- lowerViewExpr left + r <- lowerViewExpr right + Right $ "viewPair " ++ parens l ++ " " ++ parens r + VEApp (VEApp (VEName "Result") err) ok -> do + e <- lowerViewExpr err + a <- lowerViewExpr ok + Right $ "viewResult " ++ parens e ++ " " ++ parens a + VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> do + as <- mapM lowerViewExpr args + r <- lowerViewExpr resultView + Right $ "viewFn [" ++ unwords (map parens as) ++ "] " ++ parens r + VEApp func arg -> do + f <- lowerViewExpr func + a <- lowerViewExpr arg + Right $ parens f ++ " " ++ parens a + VERaw raw -> Right raw + +treeSource :: T -> String +treeSource Leaf = "t" +treeSource (Stem x) = "(t " ++ treeSource x ++ ")" +treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")" + +parens :: String -> String +parens s = "(" ++ s ++ ")" diff --git a/src/Check/IO.hs b/src/Check/IO.hs new file mode 100644 index 0000000..807f908 --- /dev/null +++ b/src/Check/IO.hs @@ -0,0 +1,409 @@ +module Check.IO + ( instrumentIOContinuations + ) where + +import Control.Monad.State.Strict +import qualified Data.Map as Map + +import Check.Core (lowerViewExpr) +import Parser (parseTricu) +import Research + +viewAnyType :: ViewExpr +viewAnyType = VEName "Any" + +argType :: DefArg -> ViewExpr +argType (DefBinder _ Nothing) = viewAnyType +argType (DefBinder _ (Just ty)) = ty +argType (DefPhantom ty) = ty + +declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr +declaredDefinitionView args ret = + case map argType args of + [] -> resultType + views -> viewExprFn views resultType + where + resultType = maybe viewAnyType id ret + +viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr +viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView + +viewExprList :: ViewExpr -> ViewExpr +viewExprList = VEApp (VEName "List") + +viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr) +viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView) +viewExprFnParts _ = Nothing + +viewExprAsType :: ViewExpr -> Maybe ViewType +viewExprAsType view = case view of + VEName name -> Just (VTName name) + VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n) + VEApp (VEName "Ref") (VEString st) -> Just (VTRefText st) + VEApp (VEName "List") item -> VTList <$> viewExprAsType item + VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item + VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right + VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok + VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView + _ -> Nothing + +viewTypeToExpr :: ViewType -> ViewExpr +viewTypeToExpr view = case view of + VTName name -> VEName name + VTRef n -> VEApp (VEName "Ref") (VEInt n) + VTRefText st -> VEApp (VEName "Ref") (VEString st) + VTList item -> VEApp (VEName "List") (viewTypeToExpr item) + VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item) + VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right) + VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok) + VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard)) + VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView) + +treeSource :: T -> String +treeSource Leaf = "t" +treeSource (Stem x) = "(t " ++ treeSource x ++ ")" +treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")" + +applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr +applicationResultView (Just fnView) = case viewExprFnParts fnView of + Just (_ : restArgs, resultView) -> + Just $ case restArgs of + [] -> resultView + _ -> viewExprFn restArgs resultView + _ -> Nothing +applicationResultView _ = Nothing + +-- Instrument source-level IO continuations so pure calls to annotated +-- functions can run the already-portable checked-exec protocol at runtime. +-- This is deliberately a lowering pass: it builds checked boundaries once from +-- source annotations, then ordinary IO execution only evaluates runChecked. +instrumentIOContinuations :: [TricuAST] -> Either String [TricuAST] +instrumentIOContinuations asts = mapM transformTop asts + where + contracts = Map.fromList + [ (name, (args, ret, body)) + | SDefAnn name args ret body <- asts + , all isRuntimeBinder args + ] + + isRuntimeBinder DefBinder {} = True + isRuntimeBinder DefPhantom {} = False + + transformTop (SDef name params body) = SDef name params <$> transformExpr body + transformTop (SDefAnn name args ret body) = SDefAnn name args ret <$> transformExpr body + transformTop other = transformExpr other + + transformExpr expr = case expr of + SApp (SVar "io" h) action -> SApp (SVar "io" h) <$> transformIOAction action + SApp f a -> SApp <$> transformExpr f <*> transformExpr a + SLambda params body -> SLambda params <$> transformExpr body + TStem x -> TStem <$> transformExpr x + TFork x y -> TFork <$> transformExpr x <*> transformExpr y + _ -> pure expr + + transformIOAction action = case action of + SApp (SVar "pure" _) value -> + case checkedPureActionFor value of + Just checked -> parseOne checked + Nothing -> SApp (SVar "pure" Nothing) <$> transformExpr value + SApp (SApp (SVar "bind" h) left) (SLambda params body) -> + SApp <$> (SApp (SVar "bind" h) <$> transformIOAction left) <*> (SLambda params <$> transformIOAction body) + SApp f a -> SApp <$> transformIOAction f <*> transformIOAction a + SLambda params body -> SLambda params <$> transformIOAction body + _ -> transformExpr action + + checkedPureActionFor value = + case contractedApplication value of + Just (name, defArgs, ret, body, callArgs) -> + Just (checkedPureApplicationActionSource contracts name defArgs ret body callArgs) + Nothing -> + if mentionsContractedName contracts value + then Just (checkedPureValueActionSource contracts value) + else Nothing + where + contractedApplication valueExpr = do + (headExpr, callArgs) <- applicationSpine valueExpr + name <- case headExpr of + SVar n _ -> Just n + _ -> Nothing + (defArgs, ret, body) <- Map.lookup name contracts + if length callArgs == length defArgs + then Just (name, defArgs, ret, body, callArgs) + else Nothing + + parseOne source = case parseTricu source of + [expr] -> Right expr + _ -> Left $ "internal check error: could not parse generated checked IO action: " ++ source + +applicationSpine :: TricuAST -> Maybe (TricuAST, [TricuAST]) +applicationSpine expr = Just (go expr []) + where + go (SApp f a) args = go f (a : args) + go headExpr args = (headExpr, args) + +checkedPureApplicationActionSource :: RuntimeContracts -> String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> [TricuAST] -> String +checkedPureApplicationActionSource contracts name defArgs ret body callArgs = + checkedProgramAction boundaryProgram ("(_ runtimeEnv : " ++ bodyAction ++ ")") + where + argViews = map argType defArgs + retView = maybe viewAnyType id ret + fnView = "viewFn [" ++ unwords (map (parens . unsafeLowerViewExpr) argViews) ++ "] " ++ parens (unsafeLowerViewExpr retView) + boundaryRoot = fromIntegral (length callArgs * 2) :: Integer + boundaryProgram = "typedProgram " ++ show boundaryRoot ++ " [" ++ unwords (map parens boundaryNodes) ++ "]" + boundaryNodes = functionNode : concat argApplyNodes + functionNode = "typedValue 0 " ++ parens fnView ++ " " ++ parens (astSource (SVar name Nothing)) + argApplyNodes = + [ let argSym = fromIntegral (idx * 2 - 1) :: Integer + outSym = fromIntegral (idx * 2) :: Integer + calleeSym = if idx == 1 then 0 else fromIntegral ((idx - 1) * 2) + argView = argRuntimeViewSource view + prefixArgs = take idx callArgs + payload = astSource (foldl SApp (SVar name Nothing) prefixArgs) + in [ "typedValue " ++ show argSym ++ " " ++ parens argView ++ " " ++ parens (astSource arg) + , "typedApply " ++ show outSym ++ " " ++ show calleeSym ++ " " ++ show argSym ++ " " ++ parens payload + ] + | (idx, (view, arg)) <- zip [1 :: Int ..] (zip argViews callArgs) + ] + (bodyRoot, bodyNodes) = runtimeBodyProgramNodes contracts defArgs retView body callArgs + bodyProgram = "typedProgram " ++ show bodyRoot ++ " [" ++ unwords (map parens bodyNodes) ++ "]" + bodyAction = checkedProgramAction bodyProgram "(value runtimeEnv : pure value)" + +type RuntimeContracts = Map.Map String ([DefArg], Maybe ViewExpr, TricuAST) + +mentionsContractedName :: RuntimeContracts -> TricuAST -> Bool +mentionsContractedName contracts expr = case expr of + SVar name _ -> Map.member name contracts + SApp f a -> mentionsContractedName contracts f || mentionsContractedName contracts a + SLambda _ body -> mentionsContractedName contracts body + SList items -> any (mentionsContractedName contracts) items + TStem x -> mentionsContractedName contracts x + TFork x y -> mentionsContractedName contracts x || mentionsContractedName contracts y + SDef _ _ body -> mentionsContractedName contracts body + SDefAnn _ _ _ body -> mentionsContractedName contracts body + _ -> False + +checkedPureValueActionSource :: RuntimeContracts -> TricuAST -> String +checkedPureValueActionSource contracts value = + checkedProgramAction program "(value runtimeEnv : pure value)" + where + (rootSym, nodes) = runtimeExpressionProgramNodes contracts value viewAnyType + program = "typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]" + +checkedProgramAction :: String -> String -> String +checkedProgramAction program okCase = + "matchResult " ++ + "(diag env : pure (renderDiagnostic diag)) " ++ + "(exec env : matchResult " ++ + "(runtimeDiag runtimeEnv : pure (renderDiagnostic runtimeDiag)) " ++ + okCase ++ " " ++ + "(runChecked exec)) " ++ + "(checkTypedProgramWith policyStrict " ++ parens program ++ ")" + +runtimeExpressionProgramNodes :: RuntimeContracts -> TricuAST -> ViewExpr -> (Integer, [String]) +runtimeExpressionProgramNodes contracts expr expected = + let (rootSym, nodes, _) = runRuntimeLower 0 Map.empty Map.empty Map.empty contracts (lowerRuntimeExprAgainst expr expected) + in (rootSym, nodes) + +runtimeBodyProgramNodes :: RuntimeContracts -> [DefArg] -> ViewExpr -> TricuAST -> [TricuAST] -> (Integer, [String]) +runtimeBodyProgramNodes contracts defArgs retView body callArgs = + let binders = [ (idx, name, maybe viewAnyType id mView, arg) + | (idx, (DefBinder name mView, arg)) <- zip [0 :: Integer ..] (zip defArgs callArgs) + ] + initialNext = fromIntegral (length binders) + initialKnown = Map.fromList [ (idx, view) | (idx, _, view, _) <- binders ] + subst = Map.fromList [ (name, arg) | (_, name, _, arg) <- binders ] + symbols = Map.fromList [ (name, idx) | (idx, name, _, _) <- binders ] + argNodes = concatMap argBoundaryNodes binders + (rootSym, bodyNodes, _) = runRuntimeLower initialNext initialKnown subst symbols contracts (lowerRuntimeExpr body) + resultRequire = "typedRequire " ++ show rootSym ++ " " ++ parens (unsafeLowerViewExpr retView) ++ " " ++ parens (astSource (substAst subst body)) + in (rootSym, argNodes ++ bodyNodes ++ [resultRequire]) + where + argBoundaryNodes (idx, _name, view, arg) = + [ "typedValue " ++ show idx ++ " " ++ parens (argRuntimeViewSource view) ++ " " ++ parens (astSource arg) + , "typedRequire " ++ show idx ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens (astSource arg) + ] + +data RuntimeLower = RuntimeLower + { runtimeNext :: Integer + , runtimeKnown :: Map.Map Integer ViewExpr + , runtimeSubst :: Map.Map String TricuAST + , runtimeSymbols :: Map.Map String Integer + , runtimeContracts :: RuntimeContracts + } + +type RuntimeM a = State RuntimeLower a + +runRuntimeLower :: Integer -> Map.Map Integer ViewExpr -> Map.Map String TricuAST -> Map.Map String Integer -> RuntimeContracts -> RuntimeM (Integer, [String], Maybe ViewExpr) -> (Integer, [String], Maybe ViewExpr) +runRuntimeLower next known subst symbols contracts action = evalState action RuntimeLower + { runtimeNext = next + , runtimeKnown = known + , runtimeSubst = subst + , runtimeSymbols = symbols + , runtimeContracts = contracts + } + +freshRuntimeSym :: RuntimeM Integer +freshRuntimeSym = do + st <- get + let sym = runtimeNext st + put st { runtimeNext = sym + 1 } + pure sym + +runtimeKnownFor :: Integer -> RuntimeM (Maybe ViewExpr) +runtimeKnownFor sym = gets (Map.lookup sym . runtimeKnown) + +recordRuntimeKnown :: Integer -> ViewExpr -> RuntimeM () +recordRuntimeKnown sym view = modify $ \st -> st { runtimeKnown = Map.insert sym view (runtimeKnown st) } + +lowerRuntimeExpr :: TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr) +lowerRuntimeExpr expr = case expr of + SVar name _ -> do + symbols <- gets runtimeSymbols + case Map.lookup name symbols of + Just sym -> do + known <- runtimeKnownFor sym + pure (sym, [], known) + Nothing -> do + contracts <- gets runtimeContracts + sym <- freshRuntimeSym + case Map.lookup name contracts of + Just (defArgs, ret, _) -> do + let view = declaredDefinitionView defArgs ret + viewSource = unsafeLowerViewExpr view + recordRuntimeKnown sym view + pure (sym, ["typedValue " ++ show sym ++ " " ++ parens viewSource ++ " " ++ parens (astSource expr)], Just view) + Nothing -> + pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource expr)], Just viewAnyType) + SStr s -> do + sym <- freshRuntimeSym + let view = VEName "String" + recordRuntimeKnown sym view + pure (sym, ["typedValue " ++ show sym ++ " viewString " ++ parens (astSource (SStr s))], Just view) + SInt n | n >= 0 && n <= 255 -> do + sym <- freshRuntimeSym + let view = VEName "Byte" + recordRuntimeKnown sym view + pure (sym, ["typedValue " ++ show sym ++ " viewByte " ++ show n], Just view) + TLeaf -> do + sym <- freshRuntimeSym + let view = VEName "Unit" + recordRuntimeKnown sym view + pure (sym, ["typedValue " ++ show sym ++ " viewUnit t"], Just view) + SList items -> do + lowered <- mapM lowerRuntimeExpr items + sym <- freshRuntimeSym + let view = viewExprList viewAnyType + recordRuntimeKnown sym view + subst <- gets runtimeSubst + let payload = astSource (substAst subst expr) + pure (sym, concat [ ns | (_, ns, _) <- lowered ] ++ ["typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens payload], Just view) + SApp f a -> lowerRuntimeApplication f a expr + _ -> do + sym <- freshRuntimeSym + subst <- gets runtimeSubst + pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource (substAst subst expr))], Just viewAnyType) + +lowerRuntimeApplication :: TricuAST -> TricuAST -> TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr) +lowerRuntimeApplication f a expr = do + (fSym, fNodes, fKnown) <- lowerRuntimeExpr f + let expectedArg = case fKnown >>= viewExprFnParts of + Just (argView : _, _) -> Just argView + _ -> Nothing + (aSym, aNodes, _) <- case expectedArg of + Just view -> lowerRuntimeExprAgainst a view + Nothing -> lowerRuntimeExpr a + outSym <- freshRuntimeSym + let outKnown = applicationResultView fKnown + mapM_ (recordRuntimeKnown outSym) outKnown + subst <- gets runtimeSubst + let payload = astSource (substAst subst expr) + applyNode = "typedApply " ++ show outSym ++ " " ++ show fSym ++ " " ++ show aSym ++ " " ++ parens payload + pure (outSym, fNodes ++ aNodes ++ [applyNode], outKnown) + +lowerRuntimeExprAgainst :: TricuAST -> ViewExpr -> RuntimeM (Integer, [String], Maybe ViewExpr) +lowerRuntimeExprAgainst expr expected = do + mBoundary <- dynamicBoundaryValue expr expected + case mBoundary of + Just resultValue -> pure resultValue + Nothing -> do + (sym, nodes, known) <- lowerRuntimeExpr expr + subst <- gets runtimeSubst + let requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens (astSource (substAst subst expr)) + pure (sym, nodes ++ [requireNode], known) + +-- IO continuations receive host-produced values whose structural View may not be +-- statically known to the source lowerer. At an explicit annotated boundary we +-- may introduce the requested base observation and let guarded Views perform the +-- runtime assertion. This keeps guard failures in checked-exec instead of +-- rejecting dynamic IO values as frontend-unknown Any. +dynamicBoundaryValue :: TricuAST -> ViewExpr -> RuntimeM (Maybe (Integer, [String], Maybe ViewExpr)) +dynamicBoundaryValue expr expected = case expr of + SVar name _ -> do + symbols <- gets runtimeSymbols + contracts <- gets runtimeContracts + case (Map.lookup name symbols, Map.lookup name contracts) of + (Nothing, Nothing) -> do + subst <- gets runtimeSubst + sym <- freshRuntimeSym + let payload = astSource (substAst subst expr) + knownView = dynamicBoundaryKnownView expected + valueNode = "typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr knownView) ++ " " ++ parens payload + requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens payload + recordRuntimeKnown sym knownView + pure (Just (sym, [valueNode, requireNode], Just knownView)) + _ -> pure Nothing + _ -> pure Nothing + +dynamicBoundaryKnownView :: ViewExpr -> ViewExpr +dynamicBoundaryKnownView view = case viewExprAsType view of + Just (VTGuarded base _) -> viewTypeToExpr base + _ -> view + +substAst :: Map.Map String TricuAST -> TricuAST -> TricuAST +substAst subst expr = case expr of + SVar name Nothing -> Map.findWithDefault expr name subst + SApp f a -> SApp (substAst subst f) (substAst subst a) + SLambda params body -> SLambda params (substAst (foldr Map.delete subst params) body) + SList items -> SList (map (substAst subst) items) + TStem x -> TStem (substAst subst x) + TFork x y -> TFork (substAst subst x) (substAst subst y) + _ -> expr + +argRuntimeViewSource :: ViewExpr -> String +argRuntimeViewSource view = + "lazyBool (_ : guardedViewBase " ++ v ++ ") (_ : " ++ v ++ ") (guardedView? " ++ v ++ ")" + where + v = parens (unsafeLowerViewExpr view) + +unsafeLowerViewExpr :: ViewExpr -> String +unsafeLowerViewExpr view = case lowerViewExpr view of + Right source -> source + Left err -> errorWithoutStackTrace err + +astSource :: TricuAST -> String +astSource expr = case expr of + SVar name Nothing -> name + SVar name (Just hash) -> name ++ "#" ++ hash + SInt n -> show n + SStr s -> show s + SList items -> "[" ++ unwords (map (parens . astSource) items) ++ "]" + SApp f a -> parens (astSource f) ++ " " ++ parens (astSource a) + SLambda params body -> parens (unwords params ++ " : " ++ astSource body) + TLeaf -> "t" + TStem x -> "(t " ++ astSource x ++ ")" + TFork x y -> "(t " ++ astSource x ++ " " ++ astSource y ++ ")" + SEmpty -> "[]" + SDef name params body -> name ++ " " ++ unwords params ++ " = " ++ astSource body + SDefAnn name args ret body -> name ++ " " ++ unwords (map defArgSource args) ++ maybe "" ((" =@" ++) . viewAnnSource) ret ++ " " ++ astSource body + SImport path ns -> "!import " ++ show path ++ " " ++ ns + +viewAnnSource :: ViewExpr -> String +viewAnnSource = unsafeLowerViewExpr + +defArgSource :: DefArg -> String +defArgSource (DefBinder name Nothing) = name +defArgSource (DefBinder name (Just view)) = name ++ "@" ++ viewAnnSource view +defArgSource (DefPhantom view) = "@" ++ viewAnnSource view + +parens :: String -> String +parens s = "(" ++ s ++ ")" diff --git a/src/ContentStore.hs b/src/ContentStore.hs index 0cdac87..cccbb55 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -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 diff --git a/src/ContentStore/Alias.hs b/src/ContentStore/Alias.hs new file mode 100644 index 0000000..bbd3e96 --- /dev/null +++ b/src/ContentStore/Alias.hs @@ -0,0 +1,81 @@ +module ContentStore.Alias + ( AliasKind(..) + , ObjectRef(..) + , aliasKindDirectory + , writeAlias + , readAlias + , listAliases + ) where + +import ContentStore.Filesystem (ensureStore) +import ContentStore.Object + +import Data.Text (Text) +import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory) +import System.FilePath (()) + +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO + +-- | Mutable workspace alias categories. Aliases are human-facing pointers to +-- immutable content objects; they are not content identity. +data AliasKind + = NameAlias + | ModuleAlias + | PackageAlias + deriving (Eq, Ord, Show) + +data ObjectRef = ObjectRef + { objectRefKind :: Text + , objectRefHash :: ObjectHash + } deriving (Eq, Ord, Show) + +aliasKindDirectory :: AliasKind -> FilePath +aliasKindDirectory NameAlias = "names" +aliasKindDirectory ModuleAlias = "modules" +aliasKindDirectory PackageAlias = "packages" + +writeAlias :: StorePath -> AliasKind -> Text -> ObjectRef -> IO () +writeAlias store@(StorePath root) kind name ref = do + ensureStore store + let dir = root "aliases" aliasKindDirectory kind + createDirectoryIfMissing True dir + TextIO.writeFile (dir Text.unpack name) (encodeObjectRef ref) + +readAlias :: StorePath -> AliasKind -> Text -> IO (Maybe ObjectRef) +readAlias store@(StorePath root) kind name = do + ensureStore store + let path = root "aliases" aliasKindDirectory kind Text.unpack name + exists <- doesFileExist path + if not exists + then return Nothing + else decodeObjectRef <$> TextIO.readFile path + +listAliases :: StorePath -> AliasKind -> IO [(Text, ObjectRef)] +listAliases store@(StorePath root) kind = do + ensureStore store + let dir = root "aliases" aliasKindDirectory kind + names <- listDirectory dir + fmap concat $ mapM load names + where + load name = do + mRef <- readAlias store kind (Text.pack name) + return $ maybe [] (\ref -> [(Text.pack name, ref)]) mRef + +encodeObjectRef :: ObjectRef -> Text +encodeObjectRef ref = Text.unlines + [ "kind: " <> objectRefKind ref + , "hash: " <> objectRefHash ref + ] + +decodeObjectRef :: Text -> Maybe ObjectRef +decodeObjectRef txt = do + kind <- lookupField "kind" fields + hash <- lookupField "hash" fields + return ObjectRef { objectRefKind = kind, objectRefHash = hash } + where + fields = map parseLine (Text.lines txt) + parseLine line = + let (k, rest) = Text.breakOn ":" line + in (Text.strip k, Text.strip (Text.drop 1 rest)) + lookupField key = lookup key diff --git a/src/ContentStore/Arboricx.hs b/src/ContentStore/Arboricx.hs new file mode 100644 index 0000000..c907575 --- /dev/null +++ b/src/ContentStore/Arboricx.hs @@ -0,0 +1,94 @@ +module ContentStore.Arboricx + ( merkleNodeDomain + , putNode + , getNode + , treeTermDomain + , encodeTreeTerm + , decodeTreeTerm + , putTreeTerm + , getTreeTerm + , putTree + , getTree + ) where + +import ContentStore.Filesystem +import ContentStore.Object +import Research + +import qualified Data.ByteString as BS + +merkleNodeDomain :: Domain +merkleNodeDomain = Domain "arboricx.merkle.node.v1" + +treeTermDomain :: Domain +treeTermDomain = Domain "arboricx.tree-term.v1" + +putNode :: StorePath -> Node -> IO ObjectHash +putNode store node = putObject store merkleNodeDomain (serializeNode node) + +getNode :: StorePath -> ObjectHash -> IO (Maybe Node) +getNode store h = fmap deserializeNode <$> getObject store h + +-- | Store a complete normal tree as one content object. Merkle nodes remain +-- available for DAG use cases, but module executable exports use this object +-- kind to avoid filesystem writes for every subtree of large normal forms. +encodeTreeTerm :: T -> BS.ByteString +encodeTreeTerm Leaf = BS.pack [0x00] +encodeTreeTerm (Stem t) = BS.cons 0x01 (encodeTreeTerm t) +encodeTreeTerm (Fork l r) = BS.cons 0x02 (encodeTreeTerm l <> encodeTreeTerm r) + +decodeTreeTerm :: BS.ByteString -> Either String T +decodeTreeTerm payload = do + (term, rest) <- getTerm payload + if BS.null rest + then Right term + else Left "trailing bytes after tree term" + where + getTerm bs = case BS.uncons bs of + Nothing -> Left "unexpected end of tree term" + Just (0x00, rest) -> Right (Leaf, rest) + Just (0x01, rest) -> do + (child, afterChild) <- getTerm rest + Right (Stem child, afterChild) + Just (0x02, rest) -> do + (left, afterLeft) <- getTerm rest + (right, afterRight) <- getTerm afterLeft + Right (Fork left right, afterRight) + Just (tag, _) -> Left $ "unknown tree term tag: " ++ show tag + +putTreeTerm :: StorePath -> T -> IO ObjectHash +putTreeTerm store = putObject store treeTermDomain . encodeTreeTerm + +getTreeTerm :: StorePath -> ObjectHash -> IO (Maybe T) +getTreeTerm store h = do + mPayload <- getObject store h + case mPayload of + Nothing -> pure Nothing + Just payload -> case decodeTreeTerm payload of + Left err -> fail $ "invalid tree term " ++ show h ++ ": " ++ err + Right term -> pure (Just term) + +putTree :: StorePath -> T -> IO ObjectHash +putTree store = go + where + go Leaf = putNode store NLeaf + go (Stem t) = do + child <- go t + putNode store (NStem child) + go (Fork l r) = do + left <- go l + right <- go r + putNode store (NFork left right) + +getTree :: StorePath -> ObjectHash -> IO (Maybe T) +getTree store root = do + mNode <- getNode store root + case mNode of + Nothing -> return Nothing + Just node -> case node of + NLeaf -> return (Just Leaf) + NStem child -> fmap Stem <$> getTree store child + NFork left right -> do + ml <- getTree store left + mr <- getTree store right + return $ Fork <$> ml <*> mr diff --git a/src/ContentStore/Bundle.hs b/src/ContentStore/Bundle.hs new file mode 100644 index 0000000..5bf44c4 --- /dev/null +++ b/src/ContentStore/Bundle.hs @@ -0,0 +1,37 @@ +module ContentStore.Bundle + ( packBundleFromStore + , unpackBundleToStore + ) where + +import ContentStore.Arboricx +import ContentStore.Object +import Wire + +import Control.Monad (forM) +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Vector as V + +-- | Pack named CAS tree terms into an indexed Arboricx transport bundle. +packBundleFromStore :: StorePath -> [(Text, ObjectHash)] -> IO Bundle +packBundleFromStore store exports = do + terms <- forM exports $ \(name, root) -> do + mt <- getTreeTerm store root + case mt of + Nothing -> fail $ "CAS tree term not found: " ++ show root + Just term -> return (name, term) + return (buildBundle terms) + +-- | Unpack an indexed Arboricx transport bundle into CAS tree terms. +-- Returns each manifest export name paired with its stored CAS tree-term hash. +unpackBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)] +unpackBundleToStore store bs = case decodeBundle bs of + Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore decode: " ++ err + Right bundle -> case verifyBundle bundle of + Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore verify: " ++ err + Right () -> do + let terms = reconstructBundleTerms (bundleNodes bundle) + forM (manifestExports $ bundleManifest bundle) $ \exported -> do + let term = terms V.! fromIntegral (exportRoot exported) + root <- putTreeTerm store term + return (exportName exported, root) diff --git a/src/ContentStore/Filesystem.hs b/src/ContentStore/Filesystem.hs new file mode 100644 index 0000000..f4339be --- /dev/null +++ b/src/ContentStore/Filesystem.hs @@ -0,0 +1,60 @@ +module ContentStore.Filesystem + ( putObject + , getObject + , objectPath + , ensureStore + ) where + +import ContentStore.Object + +import Control.Monad (unless, when) +import Data.Text (unpack) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile) +import System.FilePath (()) +import System.IO (hClose, openBinaryTempFile) + +import qualified Data.ByteString as BS + +ensureStore :: StorePath -> IO () +ensureStore (StorePath root) = do + createDirectoryIfMissing True (root "objects") + createDirectoryIfMissing True (root "aliases" "names") + createDirectoryIfMissing True (root "aliases" "modules") + createDirectoryIfMissing True (root "aliases" "packages") + createDirectoryIfMissing True (root "manifests") + createDirectoryIfMissing True (root "tmp") + +objectPath :: StorePath -> ObjectHash -> FilePath +objectPath (StorePath root) h = root "objects" shardForHash h unpack h + +putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash +putObject store@(StorePath root) domain payload = do + ensureStore store + let h = hashObject domain payload + shardDir = root "objects" shardForHash h + finalPath = objectPath store h + createDirectoryIfMissing True shardDir + exists <- doesFileExist finalPath + if exists + then verifyExisting finalPath + else do + let tmpDir = root "tmp" + (tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp") + BS.hPut handle payload + hClose handle + raced <- doesFileExist finalPath + if raced + then removeFile tmpPath >> verifyExisting finalPath + else renameFile tmpPath finalPath + return h + where + verifyExisting path = do + existing <- BS.readFile path + when (existing /= payload) $ + fail $ "content-addressed object exists with mismatched bytes: " ++ path + +getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString) +getObject store h = do + let path = objectPath store h + exists <- doesFileExist path + if exists then Just <$> BS.readFile path else return Nothing diff --git a/src/ContentStore/Object.hs b/src/ContentStore/Object.hs new file mode 100644 index 0000000..706a645 --- /dev/null +++ b/src/ContentStore/Object.hs @@ -0,0 +1,45 @@ +module ContentStore.Object + ( Domain(..) + , ObjectHash + , StorePath(..) + , hashObject + , hashToText + , textToHashBytes + , shardForHash + ) where + +import Crypto.Hash (Digest, SHA256, hash) +import Data.ByteArray (convert) +import Data.ByteString.Base16 (decode, encode) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) + +import qualified Data.ByteString as BS +import qualified Data.Text as T + +newtype Domain = Domain { unDomain :: Text } + deriving (Eq, Ord, Show) + +type ObjectHash = Text + +newtype StorePath = StorePath { unStorePath :: FilePath } + deriving (Eq, Ord, Show) + +hashObject :: Domain -> BS.ByteString -> ObjectHash +hashObject (Domain domain) payload = hashToText digest + where + digest :: Digest SHA256 + digest = hash (encodeUtf8 domain <> BS.pack [0x00] <> payload) + +hashToText :: Digest SHA256 -> Text +hashToText = decodeUtf8 . encode . (convert :: Digest SHA256 -> BS.ByteString) + +textToHashBytes :: Text -> Either String BS.ByteString +textToHashBytes h = case decode (encodeUtf8 h) of + Left _ -> Left "invalid hexadecimal hash" + Right raw + | BS.length raw == 32 -> Right raw + | otherwise -> Left "hash must decode to 32 bytes" + +shardForHash :: ObjectHash -> FilePath +shardForHash = T.unpack . T.take 3 diff --git a/src/ContentStore/Resolver.hs b/src/ContentStore/Resolver.hs new file mode 100644 index 0000000..dc0545f --- /dev/null +++ b/src/ContentStore/Resolver.hs @@ -0,0 +1,110 @@ +module ContentStore.Resolver + ( ObjectResolver(..) + , filesystemResolver + , cachedFilesystemResolver + , resolveObjectByHash + , resolveManifest + , resolveTree + ) where + +import ContentStore.Alias +import ContentStore.Arboricx +import ContentStore.Filesystem +import ContentStore.Object +import Module.Manifest +import Research (Node(..), T, deserializeNode) +import qualified Research + +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef') +import qualified Data.Map as Map +import qualified Data.Text as T + +-- | Object and alias resolution capability. Module/import code should depend on +-- this boundary rather than on a concrete filesystem store. Future resolvers can +-- add trusted remotes, registries, or caches while preserving the same verified +-- content-addressed interface. +data ObjectResolver = ObjectResolver + { resolverAlias :: AliasKind -> T.Text -> IO (Maybe ObjectRef) + , resolverObject :: ObjectRef -> IO (Maybe ByteString) + , resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest) + , resolverTree :: ObjectHash -> IO (Maybe T) + } + +filesystemResolver :: StorePath -> ObjectResolver +filesystemResolver store = resolver + where + resolver = ObjectResolver + { resolverAlias = readAlias store + , resolverObject = \ref -> getObject store (objectRefHash ref) + , resolverManifest = resolveManifestFromObjects resolver + , resolverTree = resolveTreeFromObjects resolver + } + +cachedFilesystemResolver :: StorePath -> IO ObjectResolver +cachedFilesystemResolver store = do + objectCache <- newIORef Map.empty + manifestCache <- newIORef Map.empty + treeCache <- newIORef Map.empty + let resolver = ObjectResolver + { resolverAlias = readAlias store + , resolverObject = cachedLookup objectCache (\ref -> getObject store (objectRefHash ref)) + , resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver) + , resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver) + } + return resolver + where + cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v + cachedLookup ref load key = do + cache <- readIORef ref + case Map.lookup key cache of + Just value -> return value + Nothing -> do + value <- load key + atomicModifyIORef' ref (\m -> (Map.insert key value m, ())) + return value + +resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString) +resolveObjectByHash resolver kind h = + resolverObject resolver (ObjectRef kind h) + +resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest) +resolveManifest = resolverManifest + +resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest) +resolveManifestFromObjects resolver h = do + mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h + case mBytes of + Nothing -> return Nothing + Just bytes -> case decodeManifest bytes of + Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err + Right manifest -> return (Just manifest) + +resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T) +resolveTree = resolverTree + +resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T) +resolveTreeFromObjects resolver h = do + mNode <- resolveNode resolver h + case mNode of + Nothing -> return Nothing + Just node -> hydrate node + where + resolveNode r nodeHash = do + mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash + case mBytes of + Nothing -> return Nothing + Just bytes -> return (Just (deserializeNode bytes)) + + hydrate NLeaf = return (Just Research.Leaf) + hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child + hydrate (NFork left right) = do + l <- hydrateHash left + r <- hydrateHash right + return $ Research.Fork <$> l <*> r + + hydrateHash nodeHash = do + mChild <- resolveNode resolver nodeHash + case mChild of + Nothing -> return Nothing + Just child -> hydrate child diff --git a/src/ContentStore/ViewContract.hs b/src/ContentStore/ViewContract.hs new file mode 100644 index 0000000..672b295 --- /dev/null +++ b/src/ContentStore/ViewContract.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE PatternSynonyms #-} + +module ContentStore.ViewContract + ( viewContractTypeKind + , viewContractTypeDomain + , encodeViewType + , decodeViewType + , treeToViewType + , viewTypeToTree + , putViewType + , getViewType + ) where + +import ContentStore.Alias (ObjectRef(..)) +import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm) +import ContentStore.Filesystem (getObject, putObject) +import ContentStore.Object (Domain(..), StorePath, ObjectHash) +import Research (T(..), ViewRef(..), ViewType(..), pattern VTRef, pattern VTRefText, ofList, ofNumber, ofString, toList, toNumber, toString) + +import Data.Bits (shiftL, shiftR, (.&.)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Word (Word8) +import Text.Read (readMaybe) + +import qualified Data.ByteString as BS +import qualified Data.Text as T + +viewContractTypeKind :: Text +viewContractTypeKind = "arboricx.view-contract.type.v1" + +viewContractTypeDomain :: Domain +viewContractTypeDomain = Domain viewContractTypeKind + +encodeViewType :: ViewType -> BS.ByteString +encodeViewType = go + where + go (VTName name) = BS.cons 0x00 (putBytes (encodeUtf8 (T.pack name))) + go (VTRefRaw (ViewRefInt n)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("i:" ++ show n)))) + go (VTRefRaw (ViewRefText s)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("s:" ++ s)))) + go (VTList item) = BS.cons 0x02 (go item) + go (VTMaybe item) = BS.cons 0x03 (go item) + go (VTPair left right) = BS.cons 0x04 (go left <> go right) + go (VTResult err ok) = BS.cons 0x05 (go err <> go ok) + go (VTGuarded base guard) = BS.cons 0x07 (go base <> putBytes (encodeTreeTerm guard)) + go (VTFn args result) = + BS.cons 0x06 (putU32 (length args) <> mconcat (map go args) <> go result) + +putViewType :: StorePath -> ViewType -> IO ObjectRef +putViewType store view = do + h <- putObject store viewContractTypeDomain (encodeViewType view) + pure ObjectRef { objectRefKind = viewContractTypeKind, objectRefHash = h } + +getViewType :: StorePath -> ObjectRef -> IO (Either String ViewType) +getViewType store ref + | objectRefKind ref /= viewContractTypeKind = + pure $ Left $ "unsupported View Contract type object kind: " ++ T.unpack (objectRefKind ref) + | otherwise = do + mPayload <- getObject store (objectRefHash ref) + pure $ case mPayload of + Nothing -> Left $ "missing View Contract type object: " ++ T.unpack (objectRefHash ref) + Just payload -> decodeViewType payload + +decodeViewType :: BS.ByteString -> Either String ViewType +decodeViewType payload = do + (view, rest) <- getViewTypeBytes payload + if BS.null rest + then Right view + else Left "trailing bytes after View Contract type" + +viewTypeToTree :: ViewType -> T +viewTypeToTree view = case view of + VTName "Any" -> record 0 [] + VTName "Bool" -> viewTypeToTree (VTRef 0) + VTName "String" -> viewTypeToTree (VTRef 1) + VTName "Byte" -> viewTypeToTree (VTRef 2) + VTName "Unit" -> viewTypeToTree (VTRef 3) + VTName name -> viewTypeToTree (VTRefText name) + VTRefRaw ref -> record 2 [field 2 (viewRefToTree ref)] + VTList item -> record 3 [field 3 (viewTypeToTree item)] + VTMaybe item -> record 4 [field 3 (viewTypeToTree item)] + VTPair left right -> record 5 [field 4 (viewTypeToTree left), field 5 (viewTypeToTree right)] + VTResult err ok -> record 6 [field 6 (viewTypeToTree err), field 7 (viewTypeToTree ok)] + VTGuarded base guard -> record 7 [field 8 (viewTypeToTree base), field 9 guard] + VTFn args result -> record 1 [field 0 (ofList (map viewTypeToTree args)), field 1 (viewTypeToTree result)] + where + record tag fields = Fork (ofNumber tag) (ofList fields) + field tag value = Fork (ofNumber tag) value + viewRefToTree (ViewRefInt n) = ofNumber n + viewRefToTree (ViewRefText s) = ofString s + +treeToViewType :: T -> Either String ViewType +treeToViewType viewTree = do + (tag, fields) <- recordParts viewTree + case tag of + 0 -> do + expectNoFields fields "Any" + Right (VTName "Any") + 1 -> do + argsTree <- fieldValueAt 0 fields + resultTree <- fieldValueAt 1 fields + args <- toList argsTree + VTFn <$> mapM treeToViewType args <*> treeToViewType resultTree + 2 -> VTRefRaw <$> (fieldValueAt 2 fields >>= viewRefFromTree) + 3 -> VTList <$> (fieldValueAt 3 fields >>= treeToViewType) + 4 -> VTMaybe <$> (fieldValueAt 3 fields >>= treeToViewType) + 5 -> VTPair <$> (fieldValueAt 4 fields >>= treeToViewType) <*> (fieldValueAt 5 fields >>= treeToViewType) + 6 -> VTResult <$> (fieldValueAt 6 fields >>= treeToViewType) <*> (fieldValueAt 7 fields >>= treeToViewType) + 7 -> VTGuarded <$> (fieldValueAt 8 fields >>= treeToViewType) <*> fieldValueAt 9 fields + _ -> Left $ "unknown View Contract view tag in tree: " ++ show tag + where + recordParts (Fork tagTree fieldsTree) = do + tag <- toNumber tagTree + fields <- toList fieldsTree + pure (tag, fields) + recordParts _ = Left "View Contract view tree is not a record" + + expectNoFields fields label = + if null fields + then Right () + else Left $ "View Contract " ++ label ++ " view has unexpected fields" + + fieldValueAt expectedTag fields = do + values <- mapM fieldParts fields + case values of + [(actualTag, value)] | actualTag == expectedTag -> Right value + _ -> case lookup expectedTag values of + Just value -> Right value + Nothing -> Left $ "View Contract view tree missing field tag: " ++ show expectedTag + + fieldParts (Fork tagTree value) = do + tag <- toNumber tagTree + pure (tag, value) + fieldParts _ = Left "View Contract view field is not a pair" + + viewRefFromTree tree = + case toNumber tree of + Right n -> Right (ViewRefInt n) + Left _ -> ViewRefText <$> toString tree + +getViewTypeBytes :: BS.ByteString -> Either String (ViewType, BS.ByteString) +getViewTypeBytes bs = case BS.uncons bs of + Nothing -> Left "unexpected end of View Contract type" + Just (tag, rest) -> case tag of + 0x00 -> do + (rawName, afterName) <- getBytes rest + name <- either (const (Left "View Contract type name is not valid UTF-8")) Right (decodeUtf8' rawName) + pure (VTName (T.unpack name), afterName) + 0x01 -> do + (rawRef, afterRef) <- getBytes rest + refText <- either (const (Left "View Contract ref is not valid UTF-8")) Right (decodeUtf8' rawRef) + ref <- parseViewRef (T.unpack refText) + pure (VTRefRaw ref, afterRef) + 0x02 -> do + (item, afterItem) <- getViewTypeBytes rest + pure (VTList item, afterItem) + 0x03 -> do + (item, afterItem) <- getViewTypeBytes rest + pure (VTMaybe item, afterItem) + 0x04 -> do + (left, afterLeft) <- getViewTypeBytes rest + (right, afterRight) <- getViewTypeBytes afterLeft + pure (VTPair left right, afterRight) + 0x05 -> do + (err, afterErr) <- getViewTypeBytes rest + (ok, afterOk) <- getViewTypeBytes afterErr + pure (VTResult err ok, afterOk) + 0x06 -> do + (argc, afterArgc) <- getU32 rest + (args, afterArgs) <- getMany argc afterArgc + (result, afterResult) <- getViewTypeBytes afterArgs + pure (VTFn args result, afterResult) + 0x07 -> do + (base, afterBase) <- getViewTypeBytes rest + (rawGuard, afterGuard) <- getBytes afterBase + guard <- decodeTreeTerm rawGuard + pure (VTGuarded base guard, afterGuard) + _ -> Left $ "unknown View Contract type tag: " ++ show tag + +parseViewRef :: String -> Either String ViewRef +parseViewRef raw = case raw of + 'i' : ':' : rest -> ViewRefInt <$> maybe (Left "View Contract integer ref is not an integer") Right (readMaybe rest) + 's' : ':' : rest -> Right (ViewRefText rest) + legacy -> ViewRefInt <$> maybe (Left "View Contract ref is neither tagged nor a legacy integer") Right (readMaybe legacy) + +getMany :: Int -> BS.ByteString -> Either String ([ViewType], BS.ByteString) +getMany n bs + | n < 0 = Left "negative View Contract argument count" + | otherwise = go n bs [] + where + go 0 rest acc = Right (reverse acc, rest) + go k rest acc = do + (item, afterItem) <- getViewTypeBytes rest + go (k - 1) afterItem (item : acc) + +putBytes :: BS.ByteString -> BS.ByteString +putBytes bytes = putU32 (BS.length bytes) <> bytes + +getBytes :: BS.ByteString -> Either String (BS.ByteString, BS.ByteString) +getBytes bs = do + (len, afterLen) <- getU32 bs + let (payload, rest) = BS.splitAt len afterLen + if BS.length payload == len + then Right (payload, rest) + else Left "truncated length-prefixed View Contract field" + +putU32 :: Int -> BS.ByteString +putU32 n + | n < 0 = error "putU32: negative length" + | n > 0xffffffff = error "putU32: length too large" + | otherwise = BS.pack + [ fromIntegral ((n `shiftR` 24) .&. 0xff) + , fromIntegral ((n `shiftR` 16) .&. 0xff) + , fromIntegral ((n `shiftR` 8) .&. 0xff) + , fromIntegral (n .&. 0xff) + ] + +getU32 :: BS.ByteString -> Either String (Int, BS.ByteString) +getU32 bs + | BS.length bs < 4 = Left "truncated View Contract u32" + | otherwise = + let [b0, b1, b2, b3] = BS.unpack (BS.take 4 bs) + n = word8ToInt b0 `shiftL` 24 + + word8ToInt b1 `shiftL` 16 + + word8ToInt b2 `shiftL` 8 + + word8ToInt b3 + in Right (n, BS.drop 4 bs) + +word8ToInt :: Word8 -> Int +word8ToInt = fromIntegral diff --git a/src/ContentStore/ViewTree.hs b/src/ContentStore/ViewTree.hs new file mode 100644 index 0000000..4306a75 --- /dev/null +++ b/src/ContentStore/ViewTree.hs @@ -0,0 +1,135 @@ +module ContentStore.ViewTree + ( viewTreeKind + , viewTreeDomain + , encodeViewTree + , decodeViewTree + , singletonViewTree + , viewTreeRootTerm + , putViewTree + , getViewTree + ) where + +import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm) +import ContentStore.Alias (ObjectRef(..)) +import ContentStore.Filesystem (getObject, putObject) +import ContentStore.Object (Domain(..), StorePath) +import ContentStore.ViewContract (viewTypeToTree) +import Research (T(..), ViewType(..), ofList, ofNumber, toList, toNumber) + +import qualified Data.ByteString as BS +import qualified Data.Text as T + +viewTreeKind :: T.Text +viewTreeKind = "arboricx.view-tree.v1" + +viewTreeDomain :: Domain +viewTreeDomain = Domain viewTreeKind + +-- View-tree artifacts are ordinary tree data. Their node envelope semantics +-- live in lib/view.tri; this module only provides CAS persistence for the +-- portable tree payload. +encodeViewTree :: T -> BS.ByteString +encodeViewTree = encodeTreeTerm + +decodeViewTree :: BS.ByteString -> Either String T +decodeViewTree = decodeTreeTerm + +singletonViewTree :: Maybe ViewType -> T -> T +singletonViewTree mView term = + record typedProgramTag + [ field typedProgramFieldRoot (ofNumber 0) + , field typedProgramFieldNodes (ofList [typedValueNode 0 (maybe viewAnyTree viewTypeToTree mView) term]) + ] + +-- | Extract the executable root payload from a view-tree artifact without +-- judging view validity. Checker semantics remain in lib/view.tri; this is only +-- the module loader's payload projection for imports. +viewTreeRootTerm :: T -> Either String T +viewTreeRootTerm tree = do + tag <- recordTag tree + if tag /= typedProgramTag + then Left $ "view-tree root has unexpected tag: " ++ show tag + else do + root <- fieldValue typedProgramFieldRoot tree >>= toNumber + nodes <- fieldValue typedProgramFieldNodes tree >>= toList + lookupRoot root nodes + where + lookupRoot _ [] = Left "view-tree root symbol not found" + lookupRoot root (node : rest) = do + sym <- fieldValue typedNodeFieldSymbol node >>= toNumber + if sym == root + then nodeTerm node + else lookupRoot root rest + + nodeTerm node = do + tag <- recordTag node + case tag of + 21 -> fieldValue typedNodeFieldTerm node + 22 -> fieldValue typedNodeFieldTerm node + 23 -> fieldValue typedNodeFieldTerm node + _ -> Left $ "view-tree node has unexpected tag: " ++ show tag + +record :: Integer -> [T] -> T +record tag fields = Fork (ofNumber tag) (ofList fields) + +field :: Integer -> T -> T +field tag value = Fork (ofNumber tag) value + +typedValueNode :: Integer -> T -> T -> T +typedValueNode sym view term = + record typedNodeTagValue + [ field typedNodeFieldSymbol (ofNumber sym) + , field typedNodeFieldView view + , field typedNodeFieldTerm term + ] + +viewAnyTree :: T +viewAnyTree = record 0 [] + +recordTag :: T -> Either String Integer +recordTag (Fork tagTree _) = toNumber tagTree +recordTag _ = Left "view-tree value is not a record" + +recordFields :: T -> Either String [T] +recordFields (Fork _ fieldsTree) = toList fieldsTree +recordFields _ = Left "view-tree value is not a record" + +fieldValue :: Integer -> T -> Either String T +fieldValue expected recordTree = do + fields <- recordFields recordTree + values <- mapM fieldParts fields + case lookup expected values of + Just value -> Right value + Nothing -> Left $ "view-tree missing field tag: " ++ show expected + +fieldParts :: T -> Either String (Integer, T) +fieldParts (Fork tagTree value) = do + tag <- toNumber tagTree + Right (tag, value) +fieldParts _ = Left "view-tree field is not a pair" + +typedProgramTag, typedProgramFieldRoot, typedProgramFieldNodes :: Integer +typedProgramTag = 20 +typedProgramFieldRoot = 0 +typedProgramFieldNodes = 1 + +typedNodeTagValue, typedNodeFieldSymbol, typedNodeFieldView, typedNodeFieldTerm :: Integer +typedNodeTagValue = 21 +typedNodeFieldSymbol = 0 +typedNodeFieldView = 1 +typedNodeFieldTerm = 2 + +putViewTree :: StorePath -> T -> IO ObjectRef +putViewTree store viewTree = do + h <- putObject store viewTreeDomain (encodeViewTree viewTree) + pure ObjectRef { objectRefKind = viewTreeKind, objectRefHash = h } + +getViewTree :: StorePath -> ObjectRef -> IO (Either String T) +getViewTree store ref + | objectRefKind ref /= viewTreeKind = + pure $ Left $ "unsupported view-tree object kind: " ++ T.unpack (objectRefKind ref) + | otherwise = do + mPayload <- getObject store (objectRefHash ref) + pure $ case mPayload of + Nothing -> Left $ "missing view-tree object: " ++ T.unpack (objectRefHash ref) + Just payload -> decodeViewTree payload diff --git a/src/Eval.hs b/src/Eval.hs index f40fad7..ee2e58a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -1,20 +1,16 @@ module Eval where -import ContentStore import Parser import Research -import Control.Monad (foldM) import Data.List (partition, (\\), elemIndex, foldl') import Data.Map () import Data.Set (Set) -import Database.SQLite.Simple import Debug.Trace (trace) import qualified Data.Foldable as F () import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.Text as T data DB = BVar Int @@ -43,6 +39,16 @@ evalSingle env term -> Map.insert "!result" res (Map.insert name res env) Nothing -> Map.insert "!result" res (Map.insert name res env) + | SDefAnn name args _ body <- term + = let params = annotatedBinders args + res = evalASTSync env (if null params then body else SLambda params body) + in case Map.lookup name env of + Just existingValue + | existingValue == res -> env + | otherwise + -> Map.insert "!result" res (Map.insert name res env) + Nothing + -> Map.insert "!result" res (Map.insert name res env) | SApp func arg <- term = let res = apply (evalASTSync env func) (evalASTSync env arg) in Map.insert "!result" res env @@ -87,94 +93,17 @@ evalASTSync env term = case term of SEmpty -> Leaf _ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term -evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T -evalAST mconn selectedVersions ast = do - let varNames = collectVarNames ast - resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames - return $ evalASTSync resolvedEnv ast - --- | Evaluate a single AST term using a local environment augmented by --- lazily-resolved store terms. -evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T -evalASTWithEnv mconn localEnv ast = do - let varNames = collectVarNames ast - storeEnv <- resolveTermsFromStore mconn Map.empty varNames - let combinedEnv = Map.union localEnv storeEnv - return $ evalASTSync combinedEnv ast - -evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env -evalSingleWithStore mconn env term - | SDef name params body <- term = do - res <- evalASTWithEnv mconn env (if null params then body else SLambda params body) - case Map.lookup name env of - Just existingValue - | existingValue == res -> return env - | otherwise -> return $ Map.insert "!result" res (Map.insert name res env) - Nothing -> return $ Map.insert "!result" res (Map.insert name res env) - | otherwise = do - res <- evalASTWithEnv mconn env term - return $ Map.insert "!result" res env - -evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env -evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x)) - where - go env' [] = return env' - go env' [def] = do - updatedEnv <- evalSingleWithStore mconn env' def - return $ Map.insert "!result" (result updatedEnv) updatedEnv - go env' (def:xs) = do - updatedEnv <- evalSingleWithStore mconn env' def - evalTricuWithStore mconn updatedEnv xs +evalAST :: Env -> TricuAST -> IO T +evalAST env ast = return $ evalASTSync env ast recoverParams :: TricuAST -> TricuAST recoverParams (SDef name [] (SLambda params body)) = SDef name params body recoverParams term = term -collectVarNames :: TricuAST -> [(String, Maybe String)] -collectVarNames = go [] - where - go acc (SVar name mhash) = (name, mhash) : acc - go acc (SApp t u) = go (go acc t) u - go acc (SLambda vars body) = - let boundVars = Set.fromList vars - collected = go [] body - in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected - go acc (TStem t) = go acc t - go acc (TFork t u) = go (go acc t) u - go acc (SList xs) = foldl' go acc xs - go acc _ = acc - -resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env -resolveTermsFromStore Nothing _ _ = return Map.empty -resolveTermsFromStore (Just conn) selectedVersions varNames = do - foldM (\env (name, mhash) -> do - term <- resolveTermFromStore conn selectedVersions name mhash - case term of - Just t -> return $ Map.insert (getVarKey name mhash) t env - Nothing -> return env - ) Map.empty varNames - where - getVarKey name Nothing = name - getVarKey name (Just hash) = name ++ "#" ++ hash - -resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T) -resolveTermFromStore conn selectedVersions name mhash = case mhash of - Just hashPrefix -> do - versions <- termVersions conn name - let matchingVersions = filter (\(hash, _, _) -> - T.isPrefixOf (T.pack hashPrefix) hash) versions - case matchingVersions of - [] -> return Nothing - [(_, term, _)] -> return $ Just term - _ -> return Nothing - Nothing -> case Map.lookup name selectedVersions of - Just hash -> loadTree conn hash - Nothing -> do - versions <- termVersions conn name - case versions of - [] -> return Nothing - [(_, term, _)] -> return $ Just term - _ -> return $ Just (head (map (\(_, t, _) -> t) versions)) +annotatedBinders :: [DefArg] -> [String] +annotatedBinders [] = [] +annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest +annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest elimLambda :: TricuAST -> TricuAST elimLambda = go @@ -262,6 +191,7 @@ freeVars (SVar v (Just _)) = Set.singleton v freeVars (SApp t u) = Set.union (freeVars t) (freeVars u) freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs) freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params) +freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args)) freeVars (TStem t) = freeVars t freeVars (TFork t u) = Set.union (freeVars t) (freeVars u) freeVars (SList xs) = foldMap freeVars xs @@ -275,13 +205,13 @@ reorderDefs env defs | otherwise = orderedDefs ++ others where (defsOnly, others) = partition isDef defs - defNames = [ name | SDef name _ _ <- defsOnly ] + defNames = [ defName def | def <- defsOnly ] defsWithFreeVars = [(def, freeVars def) | def <- defsOnly] graph = buildDepGraph defsOnly sortedDefs = sortDeps graph - defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly] + defMap = Map.fromList [(defName def, def) | def <- defsOnly] orderedDefs = map (defMap Map.!) sortedDefs freeVarsDefs = foldMap snd defsWithFreeVars @@ -291,6 +221,7 @@ reorderDefs env defs missingDeps = Set.toList (allFreeVars `Set.difference` validNames) isDef SDef {} = True + isDef SDefAnn {} = True isDef _ = False buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String) @@ -300,11 +231,11 @@ buildDepGraph topDefs "Conflicting definitions detected: " ++ show conflictingDefs | otherwise = Map.fromList - [ (name, depends topDefs def) - | def@(SDef name _ _) <- topDefs] + [ (defName def, depends topDefs def) + | def <- topDefs] where defsMap = Map.fromListWith (++) - [(name, [(name, body)]) | SDef name _ body <- topDefs] + [(defName def, [(defName def, defBody def)]) | def <- topDefs] conflictingDefs = [ name @@ -330,10 +261,24 @@ sortDeps graph = go [] Set.empty (Map.keys graph) (Set.union sortedSet (Set.fromList ready)) notReady +defName :: TricuAST -> String +defName (SDef name _ _) = name +defName (SDefAnn name _ _ _) = name +defName _ = error "defName: expected definition" + +defBody :: TricuAST -> TricuAST +defBody (SDef _ _ body) = body +defBody (SDefAnn _ _ _ body) = body +defBody _ = error "defBody: expected definition" + depends :: [TricuAST] -> TricuAST -> Set.Set String -depends topDefs def@(SDef _ _ _) = +depends topDefs def@SDef {} = Set.intersection - (Set.fromList [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)? diff --git a/src/FileEval.hs b/src/FileEval.hs index 5205acb..4f5b6e1 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -1,22 +1,41 @@ module FileEval - ( preprocessFile + ( ContractMode(..) + , LoadedSource(..) + , preprocessFile + , preprocessFileWithStore + , preprocessFileWithResolver , evaluateFile - , evaluateFileWithContext , evaluateFileWithStore + , evaluateFileWithContext + , evaluateFileWithContextWithStore + , evaluateFileWithContextWithStoreAndMode , evaluateFileResult , compileFile + , compileFileWithStore + , loadFileWithStore + , loadFileWithStoreMode + , defaultStorePath ) where -import Eval (evalTricu, evalTricuWithStore) +import Check.Core + ( checkProgramWithEnvAndImportedViews + , importedViewsFromResolvedModulesEither + , lowerViewExpr + ) +import ContentStore +import Eval (evalASTSync, evalTricu, freeVars, result) import Lexer +import Module.Manifest +import Module.Resolver +import Module.Workspace import Parser import Research import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..)) -import Database.SQLite.Simple (Connection) -import Data.List (partition) +import Data.List (partition, isPrefixOf) import Data.Maybe (mapMaybe) -import System.FilePath (takeDirectory, normalise, ()) +import System.Directory (getHomeDirectory, getTemporaryDirectory) +import System.FilePath (()) import System.Exit (die) import qualified Data.ByteString as BS @@ -32,153 +51,262 @@ extractMain env = Just evalResult -> Right evalResult Nothing -> Left "No `main` function detected" -processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST] - -> Either String ([TricuAST], [(FilePath, String, FilePath)]) -processImports seen _base currentPath asts = +data ContractMode + = EnforceContracts + | IgnoreContracts + deriving (Eq, Show) + +data LoadedSource = LoadedSource + { loadedImports :: Env + , loadedAst :: [TricuAST] + , loadedModules :: [ResolvedModule] + } + +data LoadContext = LoadContext + { loadResolver :: ObjectResolver + , loadStore :: Maybe StorePath + , loadWorkspace :: Workspace + , loadContracts :: ContractMode + } + +processImports :: [TricuAST] -> ([TricuAST], [(String, String)]) +processImports asts = let (imports, nonImports) = partition isImp asts - importPaths = mapMaybe getImportInfo imports - in if currentPath `Set.member` seen - then Left $ "Encountered cyclic import: " ++ currentPath - else Right (nonImports, importPaths) + importTargets = mapMaybe getImportInfo imports + in (nonImports, importTargets) where isImp (SImport _ _) = True isImp _ = False - getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p) + getImportInfo (SImport p n) = Just (p, n) getImportInfo _ = Nothing evaluateFileResult :: FilePath -> IO T evaluateFileResult filePath = do - contents <- readFile filePath - let tokens = lexTricu contents - case parseProgram tokens of - Left err -> errorWithoutStackTrace (handleParseError tokens err) - Right _ast -> do - processedAst <- preprocessFile filePath - let finalEnv = evalTricu Map.empty processedAst - case extractMain finalEnv of - Right evalResult -> return evalResult - Left err -> errorWithoutStackTrace err + env <- evaluateFile filePath + case extractMain env of + Right evalResult -> return evalResult + Left err -> errorWithoutStackTrace err evaluateFile :: FilePath -> IO Env -evaluateFile filePath = do - contents <- readFile filePath - let tokens = lexTricu contents - case parseProgram tokens of - Left err -> errorWithoutStackTrace (handleParseError tokens err) - Right _ast -> do - ast <- preprocessFile filePath - pure $ evalTricu Map.empty ast +evaluateFile = evaluateFileWithStore Nothing + +evaluateFileWithStore :: Maybe StorePath -> FilePath -> IO Env +evaluateFileWithStore mStore filePath = do + loaded <- maybe loadFile loadFileWithStore mStore filePath + pure $ evalTricu (loadedImports loaded) (loadedAst loaded) evaluateFileWithContext :: Env -> FilePath -> IO Env -evaluateFileWithContext env filePath = do - contents <- readFile filePath - let tokens = lexTricu contents - case parseProgram tokens of - Left err -> errorWithoutStackTrace (handleParseError tokens err) - Right _ast -> do - ast <- preprocessFile filePath - pure $ evalTricu env ast +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 diff --git a/src/Lexer.hs b/src/Lexer.hs index 7c6922a..ef58f13 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -33,14 +33,16 @@ tricuLexer = do tricuLexer' = [ try lnewline , try indentMarker - , try namespace , try dot , try identifierWithHash - , try identifier , try keywordT + , try identifier + , try namespace , try integerLiteral , try stringLiteral + , try assignAt , assign + , atSign , colon , openParen , closeParen @@ -81,10 +83,10 @@ keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT identifierWithHash :: Lexer LToken identifierWithHash = do - first <- lowerChar <|> char '_' + first <- letterChar <|> char '_' rest <- many $ letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' - <|> char '$' <|> char '@' <|> char '%' + <|> char '$' <|> char '%' <|> char '\'' _ <- char '#' -- Consume '#' hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash @@ -103,10 +105,10 @@ identifierWithHash = do identifier :: Lexer LToken identifier = do - first <- lowerChar <|> char '_' + first <- letterChar <|> char '_' rest <- many $ letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' - <|> char '$' <|> char '@' <|> char '%' + <|> char '$' <|> char '%' <|> char '\'' let name = first : rest if name == "t" || name == "!result" @@ -114,12 +116,7 @@ identifier = do else return (LIdentifier name) namespace :: Lexer LToken -namespace = do - name <- try (string "!Local") <|> do - first <- upperChar - rest <- many (letterChar <|> digitChar) - return (first:rest) - return (LNamespace name) +namespace = LNamespace <$> string "!Local" dot :: Lexer LToken dot = char '.' $> LDot @@ -130,12 +127,27 @@ lImport = do space1 LStringLiteral path <- stringLiteral space1 - LNamespace name <- namespace + name <- importAlias return (LImport path name) +importAlias :: Lexer String +importAlias = string "!Local" <|> do + first <- letterChar <|> char '_' + rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.') + let name = first : rest + if name == "t" || name == "!result" + then fail "Keywords (`t`, `!result`) cannot be used as an import alias" + else pure name + +assignAt :: Lexer LToken +assignAt = string "=@" $> LAssignAt + assign :: Lexer LToken assign = char '=' $> LAssign +atSign :: Lexer LToken +atSign = char '@' $> LAt + colon :: Lexer LToken colon = char ':' $> LColon diff --git a/src/Main.hs b/src/Main.hs index e3c76e2..91879a0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,17 +1,27 @@ module Main where -import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget) +import Check (checkFile, checkFileWithStore, instrumentIOContinuations) +import ContentStore +import ContentStore.Bundle +import Module.Manifest import System.Exit (die) -import Eval (evalTricu, evalTricuWithStore, mainResult, result) -import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile) +import Eval (evalTricu, mainResult, result) +import FileEval + ( ContractMode(..) + , LoadedSource(..) + , defaultStorePath + , evaluateFileWithContextWithStoreAndMode + , evaluateFileWithStore + , loadFileWithStoreMode + , compileFileWithStore + ) import IODriver (IOPermissions(..), runIO) import Parser (parseTricu) import REPL (repl) import Research (T, EvaluatedForm(..), Env, formatT, exportDag) -import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..)) +import Wire (encodeBundle, defaultExportNames, Bundle(..)) import Control.Monad (foldM, unless, when) -import Data.Text (unpack, pack) import qualified Data.Text as T import Data.Version (showVersion) import Paths_tricu (version) @@ -20,10 +30,9 @@ import Options.Applicative import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Sequence as Seq -import Database.SQLite.Simple (Connection, close) - import qualified Data.Map as Map -import System.Environment (lookupEnv) +import System.Directory (getHomeDirectory) +import System.FilePath (takeBaseName, ()) -- --------------------------------------------------------------------------- -- CLI argument types @@ -31,11 +40,16 @@ import System.Environment (lookupEnv) data TricuArgs = Repl + | Check + { checkInput :: FilePath + , checkStore :: Maybe FilePath + } | Eval { evalFiles :: [FilePath] + , evalStore :: Maybe FilePath , evalFormat :: EvaluatedForm , evalOutput :: FilePath - , evalDb :: Maybe FilePath + , evalUnchecked :: Bool , evalIo :: Bool , evalAllowRead :: [FilePath] , evalAllowWrite :: [FilePath] @@ -45,21 +59,32 @@ data TricuArgs } | ArboricxCompile { compileInput :: FilePath + , compileStore :: Maybe FilePath , compileOutput :: FilePath , compileNames :: [String] - , compileDb :: Maybe FilePath } | ArboricxImport - { importFile :: FilePath - , importDb :: Maybe FilePath + { importFile :: FilePath + , importStore :: Maybe FilePath + , importModule :: Maybe String } | ArboricxExport { exportTargets :: [String] + , exportModules :: [String] , exportOutput :: FilePath , exportNames :: [String] - , exportDb :: Maybe FilePath + , exportStore :: Maybe FilePath , dag :: Bool } + | StoreAliasList + { storeAliasKind :: AliasKind + , storePathOpt :: Maybe FilePath + } + | StoreAliasGet + { storeAliasKind :: AliasKind + , storeAliasName :: String + , storePathOpt :: Maybe FilePath + } deriving (Show) -- --------------------------------------------------------------------------- @@ -78,9 +103,25 @@ readEvaluatedForm = eitherReader $ \s -> case s of "string" -> Right StringLit _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string" +checkParser :: Parser TricuArgs +checkParser = Check + <$> argument str (metavar "FILE") + <*> optional (option str + ( long "store" + <> short 's' + <> metavar "PATH" + <> help "Content-addressed store path for module import resolution" + )) + evalParser :: Parser TricuArgs evalParser = Eval <$> many (argument str (metavar "FILE...")) + <*> optional (option str + ( long "store" + <> short 's' + <> metavar "PATH" + <> help "Content-addressed store path for module import resolution" + )) <*> option readEvaluatedForm ( long "format" <> short 'f' @@ -95,12 +136,10 @@ evalParser = Eval <> value "" <> help "Write output to file instead of stdout" ) - <*> optional (option str - ( long "db" - <> short 'd' - <> metavar "PATH" - <> help "Content store database path" - )) + <*> switch + ( long "unchecked" + <> help "Evaluate as untyped code: ignore View Contract annotations and do not publish unchecked view refs" + ) <*> switch ( long "io" <> help "Interpret the result as an IO action tree and execute it" @@ -137,6 +176,12 @@ compileParser = ArboricxCompile <> value "" <> help "Input .tri source file" ) + <*> optional (option str + ( long "store" + <> short 's' + <> metavar "PATH" + <> help "Content-addressed store path for module import resolution" + )) <*> option str ( long "output" <> short 'o' @@ -150,12 +195,6 @@ compileParser = ArboricxCompile <> metavar "NAME" <> help "Definition name(s) to export as bundle roots (repeatable)" )) - <*> optional (option str - ( long "db" - <> short 'd' - <> metavar "PATH" - <> help "Content store database path" - )) importParser :: Parser TricuArgs importParser = ArboricxImport @@ -167,10 +206,16 @@ importParser = ArboricxImport <> help "Bundle file to import" ) <*> optional (option str - ( long "db" - <> short 'd' + ( long "store" + <> short 's' <> metavar "PATH" - <> help "Content store database path" + <> help "Content-addressed store path" + )) + <*> optional (option str + ( long "module" + <> short 'm' + <> metavar "NAME" + <> help "Module alias to create for the imported bundle (defaults to bundle file basename)" )) exportParser :: Parser TricuArgs @@ -181,6 +226,12 @@ exportParser = ArboricxExport <> metavar "TARGET" <> help "Target hash or name (repeatable)" )) + <*> many (option str + ( long "module" + <> short 'm' + <> metavar "MODULE" + <> help "Module alias or manifest hash to export (repeatable; bundle export only)" + )) <*> option str ( long "output" <> short 'o' @@ -195,16 +246,54 @@ exportParser = ArboricxExport <> help "Export name(s) for the bundle manifest (repeatable)" )) <*> optional (option str - ( long "db" - <> short 'd' + ( long "store" + <> short 's' <> metavar "PATH" - <> help "Content store database path" + <> help "Content-addressed store path" )) <*> switch ( long "dag" <> help "Export as a topologically-sorted DAG node table instead of a bundle" ) +aliasKindReader :: ReadM AliasKind +aliasKindReader = eitherReader $ \s -> case s of + "names" -> Right NameAlias + "name" -> Right NameAlias + "modules" -> Right ModuleAlias + "module" -> Right ModuleAlias + "packages" -> Right PackageAlias + "package" -> Right PackageAlias + _ -> Left "alias kind must be one of: names, modules, packages" + +storePathParser :: Parser (Maybe FilePath) +storePathParser = optional (option str + ( long "store" + <> short 's' + <> metavar "PATH" + <> help "Content-addressed store path" + )) + +aliasKindParser :: Parser AliasKind +aliasKindParser = option aliasKindReader + ( long "kind" + <> short 'k' + <> metavar "KIND" + <> value NameAlias + <> help "Alias kind: names, modules, packages (default: names)" + ) + +storeAliasListParser :: Parser TricuArgs +storeAliasListParser = StoreAliasList + <$> aliasKindParser + <*> storePathParser + +storeAliasGetParser :: Parser TricuArgs +storeAliasGetParser = StoreAliasGet + <$> aliasKindParser + <*> argument str (metavar "NAME") + <*> storePathParser + versionStr :: String versionStr = "tricu " ++ showVersion version @@ -213,10 +302,14 @@ tricuParser = (subparser topCommands <|> pure Repl) <**> infoOption versionStr (long "version" <> help "Show version") where topCommands = mconcat - [ command "eval" (info (evalParser <**> helper) + [ command "check" (info (checkParser <**> helper) + (progDesc "Check View Contract annotations and report ok or diagnostics")) + , command "eval" (info (evalParser <**> helper) (progDesc "Evaluate tricu source and print the result of the final expression")) , command "arboricx" (info (arboricxParser <**> helper) (progDesc "Arboricx bundle operations")) + , command "store" (info (storeParser <**> helper) + (progDesc "Inspect and manage the content-addressed store")) ] arboricxParser :: Parser TricuArgs @@ -229,6 +322,20 @@ arboricxParser = subparser $ mconcat (progDesc "Export one or more terms from the content store")) ] +storeParser :: Parser TricuArgs +storeParser = subparser $ mconcat + [ command "alias" (info (storeAliasParser <**> helper) + (progDesc "Inspect workspace aliases")) + ] + +storeAliasParser :: Parser TricuArgs +storeAliasParser = subparser $ mconcat + [ command "list" (info (storeAliasListParser <**> helper) + (progDesc "List aliases by kind")) + , command "get" (info (storeAliasGetParser <**> helper) + (progDesc "Resolve an alias by kind and name")) + ] + -- --------------------------------------------------------------------------- -- Entry point -- --------------------------------------------------------------------------- @@ -242,10 +349,13 @@ main = do ) case args of Repl -> runRepl + Check {} -> runCheck args Eval {} -> runEval args ArboricxCompile {} -> runCompile args ArboricxImport {} -> runImport args ArboricxExport {} -> runExport args + StoreAliasList {} -> runStoreAliasList args + StoreAliasGet {} -> runStoreAliasGet args -- --------------------------------------------------------------------------- @@ -258,25 +368,40 @@ runRepl = do putStrLn "You may exit with `CTRL+D` or the `!exit` command." repl +runCheck :: TricuArgs -> IO () +runCheck opts = do + output <- case checkStore opts of + Nothing -> checkFile (checkInput opts) + Just storePath -> checkFileWithStore (StorePath storePath) (checkInput opts) + putStrLn output + +evaluateCheckedIOFile :: StorePath -> ContractMode -> Env -> FilePath -> IO Env +evaluateCheckedIOFile store mode env filePath = do + loaded <- loadFileWithStoreMode mode store filePath + checkedAst <- case instrumentIOContinuations (loadedAst loaded) of + Left err -> die err + Right asts -> pure asts + viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri" + pure $ evalTricu (Map.unions [viewEnv, loadedImports loaded, env]) checkedAst + runEval :: TricuArgs -> IO () runEval opts = do let files = evalFiles opts form = evalFormat opts out = evalOutput opts - mconn <- case evalDb opts of - Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath) - Nothing -> do - mDbPath <- lookupEnv "TRICU_DB_PATH" - case mDbPath of - Just _ -> Just <$> initContentStoreWithPath Nothing - Nothing -> return Nothing resultT <- case files of [] -> do input <- getContents - env <- evalTricuWithStore mconn Map.empty (parseTricu input) + let env = evalTricu Map.empty (parseTricu input) return $ result env _ -> do - finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files + mStoreOpt <- traverse (pure . StorePath) (evalStore opts) + let contractMode = if evalUnchecked opts then IgnoreContracts else EnforceContracts + finalEnv <- if evalIo opts && contractMode == EnforceContracts + then do + store <- maybe defaultStorePath pure mStoreOpt + foldM (evaluateCheckedIOFile store contractMode) Map.empty files + else foldM (evaluateFileWithContextWithStoreAndMode contractMode mStoreOpt) Map.empty files return $ mainResult finalEnv finalT <- if evalIo opts then do @@ -291,9 +416,6 @@ runEval opts = do Left err -> die $ "IO error: " ++ err Right val -> pure val else return resultT - case mconn of - Just conn -> close conn - Nothing -> return () writeOutput out (formatT form finalT) runCompile :: TricuArgs -> IO () @@ -301,20 +423,35 @@ runCompile opts = do let input = compileInput opts out = compileOutput opts names = compileNames opts + mStore = StorePath <$> compileStore opts when (null out) $ die "tricu arboricx compile: --output is required" when (null input) $ die "tricu arboricx compile: input file is required" let nameTexts = if null names then [] else map T.pack names - compileFile input out nameTexts + compileFileWithStore mStore input out nameTexts runImport :: TricuArgs -> IO () runImport opts = do let file = importFile opts when (null file) $ die "tricu arboricx import: input file is required" - withContentStore (importDb opts) $ \conn -> do - bundleData <- BL.readFile file - roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData) - putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" - mapM_ (\r -> putStrLn $ " " ++ r) roots + store <- resolveStorePath (importStore opts) + bundleData <- BL.readFile file + roots <- unpackBundleToStore store (BL.toStrict bundleData) + mapM_ (\(name, root) -> + writeAlias store NameAlias name (treeTermRef root)) roots + let manifest = ModuleManifest [] + [ ModuleExport + name + (treeTermRef root) + "arboricx.abi.tree.v1" + Nothing + | (name, root) <- roots + ] + moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts) + manifestHash <- putManifest store manifest + writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash) + putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" + mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots + putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash runExport :: TricuArgs -> IO () runExport opts = @@ -325,37 +462,53 @@ runExport opts = runExportBundle :: TricuArgs -> IO () runExportBundle opts = do let targets = exportTargets opts + modules = exportModules opts out = exportOutput opts names = exportNames opts - when (null out) $ die "tricu arboricx export: --output is required" - when (null targets) $ die "tricu arboricx export: at least one --target is required" - withContentStore (exportDb opts) $ \conn -> do - terms <- mapM (\t -> do - (h, _) <- resolveExportTarget conn t - maybeTree <- loadTree conn h - case maybeTree of - Nothing -> die $ "Term not found in store: " ++ t - Just tree -> return tree) targets - let expNames = if null names - then defaultExportNames (length terms) - else map T.pack names - when (length expNames /= length terms) $ - die "tricu arboricx export: number of --name values must match number of TARGETs" - let namedTerms = zip expNames terms - bundle = buildBundle namedTerms - bundleData = encodeBundle bundle - BL.writeFile out (BL.fromStrict bundleData) - putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out - putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle)) - putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes" + when (null out) $ die "tricu arboricx export: --output is required" + when (null targets && null modules) $ + die "tricu arboricx export: at least one --target or --module is required" + store <- resolveStorePath (exportStore opts) + targetRoots <- mapM (resolveStoreTarget store) targets + moduleRoots <- concat <$> mapM (resolveModuleExports store) modules + let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots + entries = targetEntries ++ moduleRoots + expNames = if null names then map fst entries else map T.pack names + when (length expNames /= length entries) $ + die "tricu arboricx export: number of --name values must match number of exported roots" + bundle <- packBundleFromStore store (zip expNames (map snd entries)) + let bundleData = encodeBundle bundle + BL.writeFile out (BL.fromStrict bundleData) + putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out + putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle)) + putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes" + +runStoreAliasList :: TricuArgs -> IO () +runStoreAliasList opts = do + store <- resolveStorePath (storePathOpt opts) + aliases <- listAliases store (storeAliasKind opts) + mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases + +runStoreAliasGet :: TricuArgs -> IO () +runStoreAliasGet opts = do + store <- resolveStorePath (storePathOpt opts) + mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts) + case mRef of + Nothing -> die $ "alias not found: " ++ storeAliasName opts + Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref runExportDag :: TricuArgs -> IO () runExportDag opts = do let targets = exportTargets opts + modules = exportModules opts out = exportOutput opts + unless (null modules) $ + die "tricu arboricx export --dag: --module is only supported for bundle export" case targets of - [target] -> withContentStore (exportDb opts) $ \conn -> do - maybeTerm <- loadTerm conn target + [target] -> do + store <- resolveStorePath (exportStore opts) + root <- resolveStoreTarget store target + maybeTerm <- getTreeTerm store root case maybeTerm of Nothing -> die $ "Term not found: " ++ target Just term -> do @@ -371,12 +524,54 @@ runExportDag opts = do -- Helpers -- --------------------------------------------------------------------------- -withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a -withContentStore mPath act = do - conn <- initContentStoreWithPath mPath - result <- act conn - close conn - return result +resolveStorePath :: Maybe FilePath -> IO StorePath +resolveStorePath (Just path) = return (StorePath path) +resolveStorePath Nothing = do + home <- getHomeDirectory + return (StorePath (home ".tricu" "store")) + +treeTermRef :: ObjectHash -> ObjectRef +treeTermRef = ObjectRef (unDomain treeTermDomain) + +resolveStoreTarget :: StorePath -> String -> IO ObjectHash +resolveStoreTarget store target = do + mAlias <- readAlias store NameAlias (T.pack target) + let root = maybe (T.pack target) objectRefHash mAlias + mTree <- getTreeTerm store root + case mTree of + Just _ -> return root + Nothing -> die $ "Term not found in store: " ++ target + +resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)] +resolveModuleExports store moduleTarget = do + manifestHash <- resolveModuleManifestHash store moduleTarget + mManifest <- getManifest store manifestHash + manifest <- case mManifest of + Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget + Just value -> return value + mapM exportEntry (moduleManifestExports manifest) + where + exportEntry ex = do + let ref = moduleExportObject ex + unless (objectRefKind ref == unDomain treeTermDomain) $ + die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref) + mTree <- getTreeTerm store (objectRefHash ref) + case mTree of + Nothing -> die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex) + Just _ -> return (moduleExportName ex, objectRefHash ref) + +resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash +resolveModuleManifestHash store moduleTarget = do + mAlias <- readAlias store ModuleAlias (T.pack moduleTarget) + case mAlias of + Just ref -> do + unless (objectRefKind ref == unDomain manifestDomain) $ + die $ "Module alias does not point at a module manifest: " ++ moduleTarget + return (objectRefHash ref) + Nothing -> return (T.pack moduleTarget) + +formatObjectRef :: ObjectRef -> String +formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref) writeOutput :: FilePath -> String -> IO () writeOutput path content diff --git a/src/Module/Manifest.hs b/src/Module/Manifest.hs new file mode 100644 index 0000000..91734dd --- /dev/null +++ b/src/Module/Manifest.hs @@ -0,0 +1,137 @@ +module Module.Manifest + ( ModuleManifest(..) + , ModuleReference(..) + , ModuleExport(..) + , manifestDomain + , encodeManifest + , decodeManifest + , putManifest + , getManifest + ) where + +import ContentStore.Filesystem (getObject, putObject) +import ContentStore.Object +import ContentStore.Alias (ObjectRef(..)) + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) + +import qualified Data.Text as Text + +-- | Immutable module artifact. Names are export labels inside this manifest; +-- content identity is carried by object references and the manifest CAS hash. +data ModuleManifest = ModuleManifest + { moduleManifestReferences :: [ModuleReference] + , moduleManifestExports :: [ModuleExport] + } deriving (Eq, Ord, Show) + +-- | Direct content-addressed reference needed to understand, fetch, or audit +-- this manifest. The alias is human-facing metadata for diagnostics/workspace +-- presentation; the referenced object is the portable identity. These are not +-- source-language imports. +data ModuleReference = ModuleReference + { moduleReferenceAlias :: Text + , moduleReferenceRef :: ObjectRef + } deriving (Eq, Ord, Show) + +-- | Exported executable artifact plus optional direct View Contract type. +data ModuleExport = ModuleExport + { moduleExportName :: Text + , moduleExportObject :: ObjectRef + , moduleExportAbi :: Text + , moduleExportView :: Maybe ObjectRef + } deriving (Eq, Ord, Show) + +manifestDomain :: Domain +manifestDomain = Domain "arboricx.module-manifest.v1" + +encodeManifest :: ModuleManifest -> ByteString +encodeManifest manifest = encodeUtf8 $ Text.unlines $ + ["arboricx.module-manifest.v1"] + ++ map encodeReference (moduleManifestReferences manifest) + ++ map encodeExport (moduleManifestExports manifest) + where + encodeReference ref = Text.intercalate "\t" + [ "reference" + , esc (moduleReferenceAlias ref) + , esc (objectRefKind $ moduleReferenceRef ref) + , esc (objectRefHash $ moduleReferenceRef ref) + ] + encodeExport ex = Text.intercalate "\t" + [ "export" + , esc (moduleExportName ex) + , esc (objectRefKind $ moduleExportObject ex) + , esc (objectRefHash $ moduleExportObject ex) + , esc (moduleExportAbi ex) + , maybe "-" (esc . objectRefKind) (moduleExportView ex) + , maybe "-" (esc . objectRefHash) (moduleExportView ex) + ] + +-- | Parse the canonical manifest encoding. +decodeManifest :: ByteString -> Either String ModuleManifest +decodeManifest bs = do + txt <- either (Left . show) Right (decodeUtf8' bs) + case Text.lines txt of + [] -> Left "empty module manifest" + header : rows + | header /= "arboricx.module-manifest.v1" -> Left "unsupported module manifest version" + | otherwise -> foldl step (Right (ModuleManifest [] [])) rows + where + step acc line = do + manifest <- acc + case Text.splitOn "\t" line of + ["reference", alias, kind, hash] -> do + ref <- ModuleReference <$> unesc alias <*> (ObjectRef <$> unesc kind <*> unesc hash) + Right manifest { moduleManifestReferences = moduleManifestReferences manifest ++ [ref] } + ["export", name, kind, hash, abi, viewKind, viewHash] -> do + view <- optionalRef viewKind viewHash + ex <- ModuleExport + <$> unesc name + <*> (ObjectRef <$> unesc kind <*> unesc hash) + <*> unesc abi + <*> pure view + Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] } + _ -> Left $ "invalid module manifest row: " ++ Text.unpack line + +putManifest :: StorePath -> ModuleManifest -> IO ObjectHash +putManifest store = putObject store manifestDomain . encodeManifest + +getManifest :: StorePath -> ObjectHash -> IO (Maybe ModuleManifest) +getManifest store h = do + mBytes <- getObject store h + case mBytes of + Nothing -> return Nothing + Just bytes -> case decodeManifest bytes of + Left err -> fail $ "invalid module manifest " ++ Text.unpack h ++ ": " ++ err + Right manifest -> return (Just manifest) + +optionalRef :: Text -> Text -> Either String (Maybe ObjectRef) +optionalRef "-" "-" = Right Nothing +optionalRef kind hash = Just <$> (ObjectRef <$> unesc kind <*> unesc hash) + +esc :: Text -> Text +esc = Text.concatMap $ \c -> case c of + '%' -> "%25" + '\t' -> "%09" + '\n' -> "%0A" + '\r' -> "%0D" + _ -> Text.singleton c + +unesc :: Text -> Either String Text +unesc txt = go txt "" + where + go rest acc = case Text.uncons rest of + Nothing -> Right acc + Just ('%', xs) -> + let (code, tail') = Text.splitAt 2 xs + decoded = case code of + "25" -> Just "%" + "09" -> Just "\t" + "0A" -> Just "\n" + "0D" -> Just "\r" + _ -> Nothing + in case decoded of + Nothing -> Left $ "invalid percent escape: %" ++ Text.unpack code + Just c -> go tail' (acc <> c) + Just (c, xs) -> go xs (acc <> Text.singleton c) diff --git a/src/Module/Resolver.hs b/src/Module/Resolver.hs new file mode 100644 index 0000000..41d1a01 --- /dev/null +++ b/src/Module/Resolver.hs @@ -0,0 +1,153 @@ +module Module.Resolver + ( ResolvedExport(..) + , ResolvedModule(..) + , resolveModuleImport + , resolveModuleImportSelecting + , resolveModuleImports + , resolvedModulesEnv + ) where + +import ContentStore.Alias +import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain) +import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm) +import ContentStore.Object +import ContentStore.Resolver +import Module.Manifest +import Research + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T + +-- | A manifest export resolved into the importing source's local lexical scope. +-- The executable term is loaded, while object/view refs remain available for +-- later checker and diagnostics phases. +data ResolvedExport = ResolvedExport + { resolvedExportSourceName :: T.Text + , resolvedExportLocalName :: String + , resolvedExportObject :: ObjectRef + , resolvedExportAbi :: T.Text + , resolvedExportView :: Maybe ObjectRef + , resolvedExportTerm :: T + } deriving (Show, Eq) + +data ResolvedModule = ResolvedModule + { resolvedModuleTarget :: String + , resolvedModuleNamespace :: String + , resolvedModuleManifest :: ObjectHash + , resolvedModuleExports :: [ResolvedExport] + } deriving (Show, Eq) + +resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST]) +resolveModuleImports resolver asts = do + let (imports, nonImports) = foldr splitImport ([], []) asts + modules <- mapM (uncurry (resolveModuleImport resolver)) imports + return (modules, nonImports) + where + splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest) + splitImport ast (is, rest) = (is, ast : rest) + +resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule +resolveModuleImport resolver moduleTarget namespace = + resolveModuleImportSelecting resolver Nothing moduleTarget namespace + +resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule +resolveModuleImportSelecting resolver selected moduleTarget namespace = do + manifestHash <- resolveModuleManifestHash resolver moduleTarget + mManifest <- resolveManifest resolver manifestHash + manifest <- case mManifest of + Nothing -> errorWithoutStackTrace $ + "Module import failed for " ++ show moduleTarget + ++ " as " ++ show namespace + ++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain) + ++ ", hash " ++ T.unpack manifestHash ++ ")" + Just value -> return value + let wantedExports = case selected of + Nothing -> moduleManifestExports manifest + Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest) + exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports + return ResolvedModule + { resolvedModuleTarget = moduleTarget + , resolvedModuleNamespace = namespace + , resolvedModuleManifest = manifestHash + , resolvedModuleExports = exports + } + where + localNamespace = if namespace == "!Local" then "" else namespace + +resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport +resolveModuleExport resolver namespace ex = do + let ref = moduleExportObject ex + sourceName = moduleExportName ex + term <- resolveExportTerm resolver sourceName ref + return ResolvedExport + { resolvedExportSourceName = sourceName + , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName) + , resolvedExportObject = ref + , resolvedExportAbi = moduleExportAbi ex + , resolvedExportView = moduleExportView ex + , resolvedExportTerm = term + } + +resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T +resolveExportTerm resolver sourceName ref + | objectRefKind ref == viewTreeKind = do + bytes <- requireObject "view tree" + case decodeViewTree bytes >>= viewTreeRootTerm of + Left err -> errorWithoutStackTrace $ + "Module export " ++ show (T.unpack sourceName) + ++ " references invalid view tree " ++ T.unpack (objectRefHash ref) + ++ ": " ++ err + Right term -> return term + | objectRefKind ref == unDomain treeTermDomain = do + bytes <- requireObject "tree term" + case decodeTreeTerm bytes of + Left err -> errorWithoutStackTrace $ + "Module export " ++ show (T.unpack sourceName) + ++ " references invalid tree term " ++ T.unpack (objectRefHash ref) + ++ ": " ++ err + Right term -> return term + | otherwise = errorWithoutStackTrace $ + "Module export " ++ show (T.unpack sourceName) + ++ " has unsupported object kind " ++ show (T.unpack (objectRefKind ref)) + ++ "; expected " ++ show (T.unpack viewTreeKind) + ++ " or " ++ show (T.unpack (unDomain treeTermDomain)) + where + requireObject label = do + mBytes <- resolverObject resolver ref + case mBytes of + Just bytes -> return bytes + Nothing -> errorWithoutStackTrace $ + "Module export " ++ show (T.unpack sourceName) + ++ " references missing " ++ label ++ " " ++ T.unpack (objectRefHash ref) + ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")" + +resolvedModulesEnv :: [ResolvedModule] -> Env +resolvedModulesEnv modules = Map.fromList + [ (resolvedExportLocalName ex, resolvedExportTerm ex) + | m <- modules + , ex <- resolvedModuleExports m + ] + +resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash +resolveModuleManifestHash resolver moduleTarget = do + mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget) + case mAlias of + Just ref -> + if objectRefKind ref == unDomain manifestDomain + then return (objectRefHash ref) + else errorWithoutStackTrace $ + "Module alias " ++ show moduleTarget + ++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref)) + ++ "; expected " ++ show (T.unpack (unDomain manifestDomain)) + ++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")" + Nothing -> + case textToHashBytes (T.pack moduleTarget) of + Right _ -> return (T.pack moduleTarget) + Left _ -> errorWithoutStackTrace $ + "Module alias not found: " ++ show moduleTarget + ++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash" + +nsVariable :: String -> String -> String +nsVariable "" name = name +nsVariable moduleName name = moduleName ++ "." ++ name diff --git a/src/Module/Workspace.hs b/src/Module/Workspace.hs new file mode 100644 index 0000000..bffa5fa --- /dev/null +++ b/src/Module/Workspace.hs @@ -0,0 +1,66 @@ +module Module.Workspace + ( Workspace(..) + , emptyWorkspace + , lookupWorkspaceModule + , findWorkspaceFor + , parseWorkspace + ) where + +import Data.Char (isSpace) +import qualified Data.Map as Map +import qualified Data.Text as T +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (takeDirectory, ()) + +data Workspace = Workspace + { workspaceRoot :: FilePath + , workspaceModules :: Map.Map T.Text FilePath + } deriving (Show, Eq) + +emptyWorkspace :: Workspace +emptyWorkspace = Workspace "" Map.empty + +lookupWorkspaceModule :: Workspace -> T.Text -> Maybe FilePath +lookupWorkspaceModule (Workspace root modules) name = (root ) <$> Map.lookup name modules + +findWorkspaceFor :: FilePath -> IO Workspace +findWorkspaceFor sourcePath = search (takeDirectory sourcePath) + where + search dir = do + let path = dir "tricu.workspace" + exists <- doesFileExist path + if exists + then parseWorkspaceAt dir <$> readFile path + else do + let parent = takeDirectory dir + if parent == dir + then return emptyWorkspace + else do + parentExists <- doesDirectoryExist parent + if parentExists then search parent else return emptyWorkspace + +parseWorkspace :: String -> Workspace +parseWorkspace = parseWorkspaceAt "" + +parseWorkspaceAt :: FilePath -> String -> Workspace +parseWorkspaceAt root input = Workspace root $ Map.fromList + [ (T.pack name, path) + | raw <- lines input + , Just (name, path) <- [parseLine raw] + ] + +parseLine :: String -> Maybe (String, FilePath) +parseLine raw = + let line = trim (takeWhile (/= '#') raw) + in case words line of + [] -> Nothing + ["module", name, "=", path] -> Just (name, stripQuotes path) + _ -> Nothing + +trim :: String -> String +trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +stripQuotes :: String -> String +stripQuotes s = case s of + ('"':rest) | not (null rest) && last rest == '"' -> init rest + _ -> s diff --git a/src/Parser.hs b/src/Parser.hs index 6f8f6d7..afff149 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -75,20 +75,133 @@ topItemP = do definitionHeadTop :: [LToken] -> Maybe (String, [String]) definitionHeadTop toks = - case collectIdentifiersNoNewlines toks of - (name:args, LAssign : _) + case toks of + LIdentifier name : rest | name `Set.notMember` reservedNames - , all (`Set.notMember` reservedNames) args -> Just (name, args) - _ -> Nothing + , definitionAssignOnLine rest -> Just (name, []) + _ -> Nothing + +-- A top-level definition head is any identifier-led line containing `=` or `=@`. +-- Detailed validation happens in definitionP. +definitionAssignOnLine :: [LToken] -> Bool +definitionAssignOnLine [] = False +definitionAssignOnLine (LNewline : _) = False +definitionAssignOnLine (LAssign : _) = True +definitionAssignOnLine (LAssignAt : _) = True +definitionAssignOnLine (LIdentifier "where" : _) = False +definitionAssignOnLine (LIdentifier "in" : _) = False +definitionAssignOnLine (_ : rest) = definitionAssignOnLine rest definitionP :: TokParser TricuAST definitionP = do name <- identifierNameP - args <- many identifierNameP - void (tok (== LAssign) "=") + (args, annotated) <- definitionArgsP False + ret <- optional returnAnnotationP bodyIndent <- skipNestedNewlinesGetIndent body <- exprAtIndentP bodyIndent - pure (SDef name args body) + if annotated || ret /= Nothing + then pure (SDefAnn name args ret body) + else pure (SDef name (binderNames args) body) + +binderNames :: [DefArg] -> [String] +binderNames [] = [] +binderNames (DefBinder name _ : rest) = name : binderNames rest +binderNames (DefPhantom _ : rest) = binderNames rest + +definitionArgsP :: Bool -> TokParser ([DefArg], Bool) +definitionArgsP seenPhantom = do + mt <- peekP + case mt of + Just LAssign -> do + void (tok (== LAssign) "=") + pure ([], False) + Just LAssignAt -> pure ([], False) + Just (LIdentifier _) | not seenPhantom -> do + name <- identifierNameP + mAnn <- optional (try (tok (== LAt) "@" *> annotationTypeP)) + (rest, ann) <- definitionArgsP seenPhantom + pure (DefBinder name mAnn : rest, ann || mAnn /= Nothing) + Just LAt -> do + void (tok (== LAt) "@") + ty <- annotationTypeP + (rest, ann) <- definitionArgsP True + pure (DefPhantom ty : rest, True || ann) + Just (LIdentifier _) -> fail "named binders cannot appear after phantom type annotations" + _ -> fail "expected definition argument or assignment" + +returnAnnotationP :: TokParser ViewExpr +returnAnnotationP = do + void (tok (== LAssignAt) "=@") + annotationTypeP + +annotationTypeP :: TokParser ViewExpr +annotationTypeP = + atomicTypeP + <|> parenTypeP + +parenTypeP :: TokParser ViewExpr +parenTypeP = do + void (tok (== LOpenParen) "(") + ty <- typeP + void (tok (== LCloseParen) ")") + pure ty + +typeP :: TokParser ViewExpr +typeP = appTypeP + +appTypeP :: TokParser ViewExpr +appTypeP = do + first <- typeAtomP + rest <- many typeAtomP + pure (foldl VEApp first rest) + +typeAtomP :: TokParser ViewExpr +typeAtomP = + typeListP + <|> typeStringP + <|> typeIntP + <|> atomicTypeP + <|> parenTypeP + +typeListP :: TokParser ViewExpr +typeListP = do + void (tok (== LOpenBracket) "[") + args <- many typeP + void (tok (== LCloseBracket) "]") + pure (VEList args) + +typeIntP :: TokParser ViewExpr +typeIntP = do + n <- tok isInt "integer" + case n of + LIntegerLiteral i -> pure (VEInt (fromIntegral i)) + _ -> fail "internal parser error: expected integer" + where + isInt (LIntegerLiteral _) = True + isInt _ = False + +typeStringP :: TokParser ViewExpr +typeStringP = do + s <- tok isString "string" + case s of + LStringLiteral value -> pure (VEString value) + _ -> fail "internal parser error: expected string" + where + isString (LStringLiteral _) = True + isString _ = False + +atomicTypeP :: TokParser ViewExpr +atomicTypeP = do + t <- tok isTypeName "type name" + case t of + LNamespace name -> pure (VEName name) + LIdentifier name -> pure (VEName name) + _ -> fail "internal parser error: expected type name" + +isTypeName :: LToken -> Bool +isTypeName (LNamespace _) = True +isTypeName (LIdentifier _) = True +isTypeName _ = False importP :: TokParser TricuAST importP = do @@ -146,15 +259,17 @@ lambdaHeadNested toks = _ -> Nothing collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken]) -collectIdentifiersNoNewlines (LIdentifier name : rest) = - let (names, final) = collectIdentifiersNoNewlines rest - in (name : names, final) +collectIdentifiersNoNewlines (LIdentifier name : rest) + | name `Set.notMember` reservedNames = + let (names, final) = collectIdentifiersNoNewlines rest + in (name : names, final) collectIdentifiersNoNewlines rest = ([], rest) collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken]) -collectIdentifiersWithNewlines (LIdentifier name : rest) = - let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest) - in (name : names, final) +collectIdentifiersWithNewlines (LIdentifier name : rest) + | name `Set.notMember` reservedNames = + let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest) + in (name : names, final) collectIdentifiersWithNewlines rest = ([], rest) consumeLambdaHead :: Context -> [String] -> TokParser () @@ -194,7 +309,7 @@ pipeTopP = pipeAtIndentP :: Int -> TokParser TricuAST pipeAtIndentP n = - pipeChainP (appAtIndentP n) appNestedP + pipeChainP (appAtIndentP n) (appAtIndentP n) pipeNestedP :: TokParser TricuAST pipeNestedP = @@ -303,6 +418,7 @@ atomTopP = do case toks of LOpenParen : _ -> groupedP LOpenBracket : _ -> listP + LIdentifier _ : LDot : _ -> namespacedVarP LNamespace _ : LDot : _ -> namespacedVarP LIdentifier "let" : _ -> letP LIdentifier "do" : _ -> doP @@ -354,6 +470,7 @@ listElementP = do case toks of LOpenParen : _ -> groupedP LOpenBracket : _ -> listP + LIdentifier _ : LDot : _ -> namespacedVarP LNamespace _ : LDot : _ -> namespacedVarP LIdentifier "let" : _ -> letP LIdentifier "do" : _ -> doP @@ -486,14 +603,19 @@ namespacedVarP = do void (tok (== LDot) ".") nameTok <- tok isVar "identifier" case (nsTok, nameTok) of + (LIdentifier ns, LIdentifier name) -> + pure (SVar (ns ++ "." ++ name) Nothing) + (LIdentifier ns, LIdentifierWithHash name hash) -> + pure (SVar (ns ++ "." ++ name) (Just hash)) (LNamespace ns, LIdentifier name) -> pure (SVar (ns ++ "." ++ name) Nothing) (LNamespace ns, LIdentifierWithHash name hash) -> pure (SVar (ns ++ "." ++ name) (Just hash)) _ -> fail "internal parser error: expected namespaced identifier" where - isNamespace (LNamespace _) = True - isNamespace _ = False + isNamespace (LIdentifier name) = name `Set.notMember` reservedNames + isNamespace (LNamespace _) = True + isNamespace _ = False isVar (LIdentifier _) = True isVar (LIdentifierWithHash _ _) = True diff --git a/src/REPL.hs b/src/REPL.hs index 03703e6..9bd7adc 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -1,675 +1,241 @@ module REPL where -import ContentStore -import Eval +import Check (checkFileWithStore) +import Eval (evalTricu, result) import FileEval -import Lexer () -import Parser -import Research -import Wire (buildBundle, encodeBundle, importBundle) + ( ContractMode(..) + , LoadedSource(..) + , defaultStorePath + , loadFileWithStoreMode + ) +import Parser (parseTricu) +import Research (EvaluatedForm(..), Env, formatT) +import ContentStore (StorePath(..)) -import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId) -import Control.Exception (SomeException, catch, displayException) -import Control.Monad () -import Control.Monad (forever, when, forM_, foldM, unless) -import Control.Monad.Catch (handle) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class () -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Data.ByteString () -import Data.Char (isSpace) - -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.List (dropWhileEnd, isPrefixOf, find) -import Data.Maybe (isJust, fromJust) -import Data.Time (getCurrentTime, diffUTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.Format (formatTime, defaultTimeLocale) +import Control.Exception (SomeException, catch, displayException) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (isPrefixOf, sort) import Data.Version (showVersion) -import Database.SQLite.Simple (Connection, Only(..), query) import Paths_tricu (version) -import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..)) import System.Console.Haskeline -import System.Directory (doesFileExist, createDirectoryIfMissing) -import System.FSNotify -import System.FilePath (takeDirectory, ()) -import Text.Read (readMaybe) +import System.Directory (doesFileExist) import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.IO as T () +-- | Source-local REPL with the same filesystem CAS/module loader used by the +-- CLI. View Contract checking is explicit (`!check`); evaluation can run in +-- normal publishing mode or unchecked mode. data REPLState = REPLState - { replForm :: EvaluatedForm - , replContentStore :: Maybe Connection - , replWatchedFile :: Maybe FilePath - , replSelectedVersions :: Map.Map String T.Text - , replWatcherThread :: Maybe ThreadId + { replForm :: EvaluatedForm + , replEnv :: Env + , replStore :: StorePath + , replContracts :: ContractMode + , replEnvRef :: IORef Env } repl :: IO () repl = do - conn <- ContentStore.initContentStore - runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing))) + store <- defaultStorePath + envRef <- newIORef Map.empty + let settings = Settings + { complete = completeRepl envRef + , historyFile = Just "~/.local/state/tricu/history" + , autoAddHistory = True + } + runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef)) where - settings :: Settings IO - settings = Settings - { complete = completeWord Nothing " \t" completeCommands - , historyFile = Just "~/.local/state/tricu/history" - , autoAddHistory = True - } - - completeCommands :: String -> IO [Completion] - completeCommands str = return $ map simpleCompletion $ - filter (str `isPrefixOf`) commands - where - commands = [ "!exit" - , "!output" - , "!import" - , "!clear" - , "!reset" - , "!help" - , "!definitions" - , "!watch" - , "!refresh" - , "!versions" - , "!select" - , "!tag" - , "!export" - , "!bundleimport" - ] loop :: REPLState -> InputT IO () - loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do + loop state = do minput <- getInputLine "tricu < " case minput of Nothing -> return () - Just s - | strip s == "" -> loop state - | strip s == "!exit" -> outputStrLn "Exiting tricu" - | strip s == "!clear" -> do - liftIO $ putStr "\ESC[2J\ESC[H" - loop state - | strip s == "!reset" -> do - outputStrLn "Selected versions reset" - loop state { replSelectedVersions = Map.empty } - | strip s == "!help" -> do - outputStrLn $ "tricu version " ++ showVersion version - outputStrLn "Available commands:" - outputStrLn " !exit - Exit the REPL" - outputStrLn " !clear - Clear the screen" - outputStrLn " !reset - Reset preferences for selected versions" - outputStrLn " !help - Show tricu version and available commands" - outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)" - outputStrLn " !definitions - List all defined terms in the content store" - outputStrLn " !import - Import definitions from file to the content store" - outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them" - outputStrLn " !versions - Show all versions of a term by name" - outputStrLn " !select - Select a specific version of a term for subsequent lookups" - outputStrLn " !tag - Add or update a tag for a term by hash or name" - outputStrLn " !export - Export a term bundle to file (hash, file)" - outputStrLn " !bundleimport- Import a bundle file into the content store" - loop state - | strip s == "!output" -> handleOutput state - | strip s == "!definitions" -> handleDefinitions state - | "!import" `isPrefixOf` strip s -> handleImport state - | "!watch" `isPrefixOf` strip s -> handleWatch state - | strip s == "!refresh" -> handleRefresh state - | "!versions" `isPrefixOf` strip s -> handleVersions state - | "!select" `isPrefixOf` strip s -> handleSelect state - | "!tag" `isPrefixOf` strip s -> handleTag state - | "!export" `isPrefixOf` strip s -> handleExport state - | "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state - | take 2 s == "--" -> loop state - | otherwise -> do - evalResult <- liftIO $ catch - (processInput state s) - (errorHandler state) - loop evalResult + Just raw -> do + let s = strip raw + case s of + "" -> loop state + "!exit" -> outputStrLn "Exiting tricu" + "!clear" -> liftIO (putStr "\ESC[2J\ESC[H") >> loop state + "!reset" -> do + liftIO $ writeIORef (replEnvRef state) Map.empty + outputStrLn "Environment reset" + loop state { replEnv = Map.empty } + "!help" -> printHelp >> loop state + "!output" -> handleOutput state + "!env" -> handleEnv state >> loop state + _ | "!load" `isPrefixOf` s -> handleLoad state (strip $ drop 5 s) + | "!check" `isPrefixOf` s -> handleCheck state (strip $ drop 6 s) + | "!store" `isPrefixOf` s -> handleStore state (strip $ drop 6 s) + | "!format" `isPrefixOf` s -> handleFormat state (strip $ drop 7 s) + | "!unchecked" `isPrefixOf` s -> handleUnchecked state (strip $ drop 10 s) + | take 2 s == "--" -> loop state + | otherwise -> do + next <- liftIO $ catch (processInput state raw) (errorHandler state) + loop next + + printHelp :: InputT IO () + printHelp = do + outputStrLn $ "tricu version " ++ showVersion version + outputStrLn "Available commands:" + outputStrLn " !exit - Exit the REPL" + outputStrLn " !clear - Clear the screen" + outputStrLn " !reset - Reset the in-memory environment" + outputStrLn " !help - Show this help" + outputStrLn " !output - Change output format interactively" + outputStrLn " !format FORM - Set output format: tree, fsl, ast, ternary, ascii, decode, number, string" + outputStrLn " !load FILE - Load and evaluate a .tri file into the environment" + outputStrLn " !check FILE - Check View Contract annotations in a .tri file" + outputStrLn " !store [PATH] - Show or set the content-addressed store path" + outputStrLn " !unchecked [on|off] - Show or set unchecked eval mode" + outputStrLn " !env - List names currently in the REPL environment" handleOutput :: REPLState -> InputT IO () handleOutput state = do - let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit] + let formats = outputFormats outputStrLn "Available output formats:" mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f) (zip [1..] formats) - - evalResult <- runMaybeT $ do - input <- MaybeT $ getInputLine "Select output format (1-8) < " - case reads input of - [(n, "")] | n >= 1 && n <= 8 -> - return $ formats !! (n-1) - _ -> MaybeT $ return Nothing - - case evalResult of - Nothing -> do - outputStrLn "Invalid selection. Keeping current output format." - loop state - Just newForm -> do + input <- getInputLine "Select output format (1-8) < " + case input >>= readMaybeInt of + Just n | n >= 1 && n <= length formats -> do + let newForm = formats !! (n - 1) outputStrLn $ "Output format changed to: " ++ show newForm loop state { replForm = newForm } + _ -> outputStrLn "Invalid selection. Keeping current output format." >> loop state - handleDefinitions :: REPLState -> InputT IO () - handleDefinitions state = case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - terms <- liftIO $ ContentStore.listStoredTerms conn - - 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:" + 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 - let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms - - forM_ terms $ \term -> do - let namesStr = T.unpack (termNames term) - hash = termHash term - padding = replicate (maxNameWidth - length namesStr) ' ' - - liftIO $ do - putStr " " - printVariable namesStr - putStr padding - putStr " [hash: " - displayColoredHash hash - putStrLn "]" - - tags <- ContentStore.termToTags conn hash - unless (null tags) $ displayTags tags - - loop state - - handleImport :: REPLState -> InputT IO () - handleImport state = do - let fset = setComplete completeFilename defaultSettings - filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "") - case filename of - Nothing -> loop state - Just f -> do - let cleanFilename = strip f - exists <- liftIO $ doesFileExist cleanFilename + handleLoad :: REPLState -> String -> InputT IO () + handleLoad state path + | null path = outputStrLn "Usage: !load FILE" >> loop state + | otherwise = do + exists <- liftIO $ doesFileExist path if not exists - then do - liftIO $ printError $ "File not found: " ++ cleanFilename + then outputStrLn ("File not found: " ++ path) >> loop state + else do + loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path + let env' = evalTricu (Map.union (loadedImports loaded) (replEnv state)) (loadedAst loaded) + liftIO $ writeIORef (replEnvRef state) env' + outputStrLn $ "Loaded " ++ path + loop state { replEnv = env' } + + handleCheck :: REPLState -> String -> InputT IO () + handleCheck state path + | null path = outputStrLn "Usage: !check FILE" >> loop state + | otherwise = do + exists <- liftIO $ doesFileExist path + if not exists + then outputStrLn ("File not found: " ++ path) >> loop state + else do + output <- liftIO $ checkFileWithStore (replStore state) path + outputStrLn output loop state - else importFile state cleanFilename - importFile :: REPLState -> String -> InputT IO () - importFile state cleanFilename = do - _code <- liftIO $ readFile cleanFilename - case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - 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" - + 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 } - handleWatch :: REPLState -> InputT IO () - handleWatch state = do - dbPath <- liftIO ContentStore.getContentStorePath - let filepath = takeDirectory dbPath "scratch.tri" - let dirPath = takeDirectory filepath + handleUnchecked :: REPLState -> String -> InputT IO () + handleUnchecked state arg = setUnchecked state arg - liftIO $ createDirectoryIfMissing True dirPath + 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 } - fileExists <- liftIO $ doesFileExist filepath - unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n" + reportContracts :: REPLState -> InputT IO () + reportContracts state = outputStrLn $ contractModeMessage (replContracts state) - outputStrLn $ "Using scratch file: " ++ filepath - - when (isJust (replWatcherThread state)) $ do - outputStrLn "Stopping previous file watch" - liftIO $ killThread (fromJust $ replWatcherThread state) - - outputStrLn $ "Starting to watch file: " ++ filepath - outputStrLn "Press Ctrl+C to stop watching and return to REPL" - - liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) - - lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime - - watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do - _stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do - now <- getCurrentTime - lastProcessed <- readIORef lastProcessedRef - when (diffUTCTime now lastProcessed > 0.5) $ do - putStrLn $ "\nFile changed: " ++ filepath - processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) - writeIORef lastProcessedRef now - forever $ threadDelay 1000000 - - watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId } - - _handleUnwatch :: REPLState -> InputT IO () - _handleUnwatch state = case replWatchedFile state of - Nothing -> do - outputStrLn "No file is currently being watched" - loop state - Just path -> do - outputStrLn $ "Stopped watching " ++ path - when (isJust (replWatcherThread state)) $ do - liftIO $ killThread (fromJust $ replWatcherThread state) - loop state { replWatchedFile = Nothing, replWatcherThread = Nothing } - - handleRefresh :: REPLState -> InputT IO () - handleRefresh state = case replContentStore state of - Nothing -> do - outputStrLn "Content store not initialized" - loop state - Just _conn -> do - outputStrLn "Environment refreshed from content store (definitions are live)" - loop state - - handleVersions :: REPLState -> InputT IO () - handleVersions state = case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - liftIO $ printPrompt "Term name: " - nameInput <- getInputLine "" - case nameInput of - Nothing -> loop state - Just n -> do - let termName = strip n - versions <- liftIO $ ContentStore.termVersions conn termName - if null versions - then liftIO $ printError $ "No versions found for term: " ++ termName - else do - liftIO $ do - printKeyword "Versions of " - printVariable termName - putStrLn ":" - - forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do - tags <- ContentStore.termToTags conn hash - putStr $ show (i :: Int) ++ ". " - displayColoredHash hash - putStr $ " (" ++ formatTimestamp ts ++ ")" - unless (null tags) $ do - putStr " [" - printKeyword "Tags: " - forM_ (zip [0..] tags) $ \(j, tag) -> do - printTag (T.unpack tag) - when (j < length tags - 1) $ putStr ", " - putStr "]" - putStrLn "" - loop state - - handleSelect :: REPLState -> InputT IO () - handleSelect state = case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - liftIO $ printPrompt "Term name: " - nameInput <- getInputLine "" - case nameInput of - Nothing -> loop state - Just n -> do - let cleanName = strip n - versions <- liftIO $ ContentStore.termVersions conn cleanName - if null versions - then do - liftIO $ printError $ "No versions found for term: " ++ cleanName - loop state - else do - liftIO $ do - printKeyword "Versions of " - printVariable cleanName - putStrLn ":" - - forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do - tags <- ContentStore.termToTags conn hash - putStr $ show (i :: Int) ++ ". " - displayColoredHash hash - putStr $ " (" ++ formatTimestamp ts ++ ")" - unless (null tags) $ do - putStr " [" - printKeyword "Tags: " - forM_ (zip [0..] tags) $ \(j, tag) -> do - printTag (T.unpack tag) - when (j < length tags - 1) $ putStr ", " - putStr "]" - putStrLn "" - - liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): " - choiceInput <- getInputLine "" - let choice = strip <$> choiceInput - - selectedHash <- case choice of - Just selectedStr | not (null selectedStr) -> do - case readMaybe selectedStr :: Maybe Int of - Just idx | idx > 0 && idx <= length versions -> do - let (h, _, _) = versions !! (idx - 1) - return $ Just h - _ -> do - let potentialHash = T.pack selectedStr - let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions - case foundByHash of - Just (h, _, _) -> return $ Just h - Nothing -> do - liftIO $ printError "Invalid selection or hash not found in list." - return Nothing - _ -> return Nothing - - case selectedHash of - Just hashToSelect -> do - let newState = state { replSelectedVersions = - Map.insert cleanName hashToSelect (replSelectedVersions state) } - liftIO $ do - printSuccess "Selected version " - displayColoredHash hashToSelect - putStr " for term " - printVariable cleanName - putStrLn "" - loop newState - Nothing -> loop state - - handleTag :: REPLState -> InputT IO () - handleTag state = case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): " - identInput <- getInputLine "" - case identInput of - Nothing -> loop state - Just ident -> do - let cleanIdent = strip ident - - mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent - - case mFullHash of - Nothing -> do - liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent - loop state - Just fullHash -> do - liftIO $ do - putStr "Tagging term with hash: " - displayColoredHash fullHash - putStrLn "" - tags <- liftIO $ ContentStore.termToTags conn fullHash - unless (null tags) $ do - liftIO $ do - printKeyword "Existing tags:" - displayTags tags - - liftIO $ printPrompt "Tag to add/set: " - tagValueInput <- getInputLine "" - case tagValueInput of - Nothing -> loop state - Just tv -> do - let tagVal = T.pack (strip tv) - liftIO $ do - ContentStore.setTag conn fullHash tagVal - printSuccess $ "Tag '" - printTag (T.unpack tagVal) - putStr "' set for term with hash " - displayColoredHash fullHash - putStrLn "" - loop state - - resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text) - resolveIdentifierToHash conn ident - | T.pack "#" `T.isInfixOf` T.pack ident = do - let hashPrefix = T.pack ident - matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text] - case matchingHashes of - [Only fullHash] -> return $ Just fullHash - [] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing - _ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing - | otherwise = do - versions <- ContentStore.termVersions conn ident - if null versions - then do printError $ "No versions found for term name: " ++ ident; return Nothing - else return $ Just $ (\(h,_,_) -> h) $ head versions - - handleExport :: REPLState -> InputT IO () - handleExport state = do - let fset = setComplete completeFilename defaultSettings - hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "") - case hashInput of - Nothing -> loop state - Just hashStr -> do - fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "") - case fileInput of - Nothing -> loop state - Just outFile -> case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - let cleanHash = strip hashStr - hash <- liftIO $ do - let h = T.pack cleanHash - if '#' `T.elem` h - then return h - else do - results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1" - (Only (h <> "%")) :: IO [Only T.Text] - case results of - [Only fullHash] -> return fullHash - [] -> do - results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1" - (Only (h <> "%")) :: IO [Only T.Text] - case results2 of - [Only fullHash] -> return fullHash - _ -> do - printError $ "No term found matching: " ++ cleanHash - return h - _ -> do - printError $ "Ambiguous match for: " ++ cleanHash - return h - maybeTree <- liftIO $ loadTree conn hash - case maybeTree of - Nothing -> do - liftIO $ printError $ "Term not found in store: " ++ T.unpack hash - loop state - Just tree -> do - let bundle = buildBundle [(T.pack "root", tree)] - bundleData = encodeBundle bundle - liftIO $ BL.writeFile outFile (BL.fromStrict bundleData) - liftIO $ do - printSuccess $ "Exported bundle with root " - displayColoredHash hash - putStrLn $ " to " ++ outFile - loop state - - handleBundleImport :: REPLState -> InputT IO () - handleBundleImport state = do - let fset = setComplete completeFilename defaultSettings - fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "") - case fileInput of - Nothing -> loop state - Just inFile -> case replContentStore state of - Nothing -> do - liftIO $ printError "Content store not initialized" - loop state - Just conn -> do - exists <- liftIO $ doesFileExist inFile - if not exists - then do - liftIO $ printError $ "File not found: " ++ inFile - loop state - else do - bundleData <- liftIO $ BL.readFile inFile - roots <- liftIO $ importBundle conn (BL.toStrict bundleData) - liftIO $ do - printSuccess $ "Imported " ++ show (length roots) ++ " root(s):" - mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots - loop state - - interruptHandler :: REPLState -> Interrupt -> InputT IO () - interruptHandler state _ = do - liftIO $ do - printWarning "Interrupted with CTRL+C" - printWarning "You can use the !exit command or CTRL+D to exit" - loop state - - errorHandler :: REPLState -> SomeException -> IO REPLState - errorHandler state e = do - printError $ "Error: " ++ displayException e - return state + handleEnv :: REPLState -> InputT IO () + handleEnv state = + case sort (Map.keys (replEnv state)) of + [] -> outputStrLn "Environment is empty" + names -> mapM_ outputStrLn names processInput :: REPLState -> String -> IO REPLState processInput state input = do - let asts = parseTricu input - case asts of - [] -> return state - _ -> case replContentStore state of - Nothing -> do - printError "Content store not initialized" - return state - Just conn -> do - newState <- foldM (\s astNode -> do - let varsInAst = Eval.findVarNames astNode - foldM (\currentSelectionState varName -> - if Map.member varName (replSelectedVersions currentSelectionState) - then return currentSelectionState - else do - versions <- ContentStore.termVersions conn varName - if length versions > 1 - then do - let (latestHash, _, _) = head versions - liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent." - return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) } - else return currentSelectionState - ) s varsInAst - ) state asts + let env' = evalTricu (replEnv state) (parseTricu input) + writeIORef (replEnvRef state) env' + putStrLn $ formatT (replForm state) (result env') + return state { replEnv = env' } - forM_ asts $ \ast -> do - case ast of - SDef name [] body -> do - evalResult <- evalAST (Just conn) (replSelectedVersions newState) body - hash <- ContentStore.storeTerm conn [name] evalResult - - liftIO $ do - putStr "tricu > " - printSuccess "Stored definition: " - printVariable name - putStr " with hash " - displayColoredHash hash - putStrLn "" - - putStr "tricu > " - printResult $ formatT (replForm newState) evalResult - putStrLn "" + errorHandler :: REPLState -> SomeException -> IO REPLState + errorHandler state e = do + putStrLn $ "Error: " ++ displayException e + return state - _ -> do - evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast - liftIO $ do - putStr "tricu > " - printResult $ formatT (replForm newState) evalResult - putStrLn "" - return newState +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()[]{}\"'" - strip :: String -> String - strip = dropWhileEnd isSpace . dropWhile isSpace +outputFormats :: [EvaluatedForm] +outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit] - 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 +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 - processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO () - processWatchedFile filepath mconn selectedVersions outputForm = do - content <- readFile filepath - let asts = parseTricu content +contractModeMessage :: ContractMode -> String +contractModeMessage EnforceContracts = "Contracts: on" +contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)" - 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 +storePathString :: StorePath -> FilePath +storePathString (StorePath path) = path - formatTimestamp :: Integer -> String - formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts)) +strip :: String -> String +strip = f . f + where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r']) - 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 diff --git a/src/Research.hs b/src/Research.hs index f50f7d5..7455ceb 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Research where import Crypto.Hash (hash, SHA256, Digest) @@ -17,6 +19,45 @@ import qualified Data.Text as T data T = Leaf | Stem T | Fork T T deriving (Show, Eq, Ord) +-- View Contract source annotations +data ViewRef + = ViewRefInt Integer + | ViewRefText String + deriving (Show, Eq, Ord) + +data ViewType + = VTName String + | VTRefRaw ViewRef + | VTList ViewType + | VTMaybe ViewType + | VTPair ViewType ViewType + | VTResult ViewType ViewType + | VTGuarded ViewType T + | VTFn [ViewType] ViewType + deriving (Show, Eq, Ord) + +pattern VTRef :: Integer -> ViewType +pattern VTRef n = VTRefRaw (ViewRefInt n) + +pattern VTRefText :: String -> ViewType +pattern VTRefText s = VTRefRaw (ViewRefText s) + +{-# COMPLETE VTName, VTRef, VTRefText, VTList, VTMaybe, VTPair, VTResult, VTGuarded, VTFn #-} + +data ViewExpr + = VEName String + | VEInt Integer + | VEString String + | VEList [ViewExpr] + | VEApp ViewExpr ViewExpr + | VERaw String + deriving (Show, Eq, Ord) + +data DefArg + = DefBinder String (Maybe ViewExpr) + | DefPhantom ViewExpr + deriving (Show, Eq, Ord) + -- Abstract Syntax Tree for tricu data TricuAST = SVar String (Maybe String) @@ -24,6 +65,7 @@ data TricuAST | SStr String | SList [TricuAST] | SDef String [String] TricuAST + | SDefAnn String [DefArg] (Maybe ViewExpr) TricuAST | SApp TricuAST TricuAST | TLeaf | TStem TricuAST @@ -41,6 +83,8 @@ data LToken | LNamespace String | LImport String String | LAssign + | LAssignAt + | LAt | LColon | LDot | LOpenParen @@ -65,7 +109,6 @@ type Env = Map.Map String T -- Merkle DAG Node types -- Each Tree Calculus node becomes a content-addressed object. - type MerkleHash = Text data Node diff --git a/src/Wire.hs b/src/Wire.hs index 82c77d5..d305a50 100644 --- a/src/Wire.hs +++ b/src/Wire.hs @@ -16,11 +16,10 @@ module Wire , decodeBundle , verifyBundle , buildBundle - , importBundle + , reconstructBundleTerms , defaultExportNames ) where -import ContentStore (storeTerm) import Research hiding (Node) import Control.Monad (foldM, forM_, unless, when) @@ -41,7 +40,6 @@ import Data.Vector (Vector) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Data.Word (Word16, Word32, Word64, Word8) -import Database.SQLite.Simple (Connection) import GHC.Generics (Generic) import qualified Data.ByteString as BS @@ -774,11 +772,11 @@ verifyManifestConstraints manifest = do Left "manifest export has empty name" -- --------------------------------------------------------------------------- --- Import into content store +-- Bundle reconstruction -- --------------------------------------------------------------------------- -reconstructTerms :: Seq BundleNode -> Vector T -reconstructTerms nodes = V.create $ do +reconstructBundleTerms :: Seq BundleNode -> Vector T +reconstructBundleTerms nodes = V.create $ do let n = Seq.length nodes vec <- MV.new n forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do @@ -792,19 +790,6 @@ reconstructTerms nodes = V.create $ do MV.write vec i t return vec -importBundle :: Connection -> ByteString -> IO [Text] -importBundle conn bs = case decodeBundle bs of - Left err -> error $ "Wire.importBundle: " ++ err - Right bundle -> case verifyBundle bundle of - Left err -> error $ "Wire.importBundle verify: " ++ err - Right () -> do - let terms = reconstructTerms (bundleNodes bundle) - forM_ (manifestExports $ bundleManifest bundle) $ \exp -> do - let term = terms V.! fromIntegral (exportRoot exp) - _ <- storeTerm conn [T.unpack $ exportName exp] term - return () - return $ map exportName $ manifestExports $ bundleManifest bundle - -- --------------------------------------------------------------------------- -- Primitive binary helpers -- --------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs index 25458fa..c7dd703 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,6 @@ module Main where +import Check import Eval import FileEval import Lexer @@ -8,17 +9,22 @@ import REPL import Research import Wire import ContentStore +import ContentStore.Bundle +import Module.Manifest +import Module.Resolver import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms) import Control.Exception (bracket, evaluate, try, SomeException) +import System.IO.Unsafe (unsafePerformIO) import qualified Network.Socket as NS -import Control.Monad (forM_) +import Control.Monad (forM, forM_) import Control.Monad.IO.Class (liftIO) import System.IO.Temp (withSystemTempDirectory) -import System.Directory (createDirectory, doesFileExist, doesDirectoryExist) +import System.Directory (createDirectory, doesFileExist, doesDirectoryExist, listDirectory) +import System.FilePath (()) import Data.Bits (xor) import Data.Char (digitToInt) -import Data.List (isInfixOf) +import Data.List (find, isInfixOf) import Data.Text (Text, unpack) import Data.Word (Word8) import Test.Tasty @@ -26,11 +32,12 @@ import Test.Tasty.HUnit import Text.Megaparsec (runParser) import Data.ByteString (ByteString) +import qualified Data.Foldable as Foldable import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set -import Database.SQLite.Simple (close, Connection) +import qualified Data.Vector as V main :: IO () main = defaultMain tests @@ -38,6 +45,35 @@ main = defaultMain tests tricuTestString :: String -> String tricuTestString s = show $ result (evalTricu Map.empty $ parseTricu s) +testStore :: StorePath +testStore = StorePath "/tmp/tricu-test-store" +{-# NOINLINE testStore #-} + +viewTestEnv :: Env +viewTestEnv = unsafePerformIO (evaluateFileWithStore (Just testStore) "./lib/view.tri") +{-# NOINLINE viewTestEnv #-} + +viewCatalogTestEnv :: Env +viewCatalogTestEnv = unsafePerformIO $ do + catalog <- evaluateFileWithStore (Just testStore) "./lib/views/catalog.tri" + pure (Map.union viewTestEnv catalog) +{-# NOINLINE viewCatalogTestEnv #-} + +allTestLibsEnv :: Env +allTestLibsEnv = unsafePerformIO $ do + base <- evaluateFile "./lib/base.tri" + list <- evaluateFile "./lib/list.tri" + bytes <- evaluateFile "./lib/bytes.tri" + bin <- evaluateFile "./lib/binary.tri" + http <- evaluateFile "./lib/http.tri" + arbor <- evaluateFile "./lib/arboricx/arboricx.tri" + io <- evaluateFile "./lib/io.tri" + sock <- evaluateFile "./lib/socket.tri" + view <- evaluateFileWithStore (Just testStore) "./lib/view.tri" + catalog <- evaluateFileWithStore (Just testStore) "./lib/views/catalog.tri" + pure (Map.unions [base, list, bytes, bin, http, arbor, io, sock, view, catalog]) +{-# NOINLINE allTestLibsEnv #-} + tests :: TestTree tests = testGroup "Tricu Tests" [ lexer @@ -47,18 +83,19 @@ tests = testGroup "Tricu Tests" , providedLibraries , maybeTests , fileEval - , modules , demos , decoding --- , elimLambdaSingle --- , stressElimLambda --- , byteMarshallingTests --- , wireTests --- , tricuReaderTests --- , byteListUtilities --- , binaryParserTests + , elimLambdaSingle + , stressElimLambda + , byteMarshallingTests + , wireTests + , tricuReaderTests + , byteListUtilities + , binaryParserTests , httpParsingTests --- , ioDriverTests + , contentStoreTests + , viewContractTests + , ioDriverTests ] lexer :: TestTree @@ -145,6 +182,19 @@ lexer = testGroup "Lexer Tests" let input = "foo$bar = 1" expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1] runParser tricuLexer "" input @?= expect + + , testCase "Lex @ and =@ as annotation tokens" $ do + let input = "f x@Bool =@String x" + expect = Right + [ LIdentifier "f" + , LIdentifier "x" + , LAt + , LIdentifier "Bool" + , LAssignAt + , LIdentifier "String" + , LIdentifier "x" + ] + runParser tricuLexer "" input @?= expect ] parser :: TestTree @@ -240,6 +290,50 @@ parser = testGroup "Parser Tests" , testCase "Evaluate top-level definition arguments" $ do tricuTestString "const a b = a\nconst 1 2" @?= "Fork (Stem Leaf) Leaf" + , testCase "Parse annotated definition binders" $ do + let input = "foo x@Bool xs@(List Bool) =@String x" + expect = SDefAnn + "foo" + [DefBinder "x" (Just (VEName "Bool")), DefBinder "xs" (Just (VEApp (VEName "List") (VEName "Bool")))] + (Just (VEName "String")) + (SVar "x" Nothing) + parseSingle input @?= expect + + , testCase "Parse phantom tail annotations" $ do + let input = "foo x@Bool @(List Bool) =@String x" + expect = SDefAnn + "foo" + [DefBinder "x" (Just (VEName "Bool")), DefPhantom (VEApp (VEName "List") (VEName "Bool"))] + (Just (VEName "String")) + (SVar "x" Nothing) + parseSingle input @?= expect + + , testCase "Parse pure phantom function annotation" $ do + let input = "foo @Bool @(Fn [Bool] String) =@Unit (x : x)" + expect = SDefAnn + "foo" + [DefPhantom (VEName "Bool"), DefPhantom (VEApp (VEApp (VEName "Fn") (VEList [VEName "Bool"])) (VEName "String"))] + (Just (VEName "Unit")) + (SLambda ["x"] (SVar "x" Nothing)) + parseSingle input @?= expect + + , testCase "Evaluate annotated definition as ordinary definition" $ do + tricuTestString "id x@Bool =@Bool x\nid t" @?= "Leaf" + + , testCase "Reject named binders after phantom annotations" $ do + let tokens = lexTricu "foo @Bool x@Bool =@Bool x" + case parseSingleExpr tokens of + Left _ -> return () + Right ast -> assertFailure $ "Expected parse failure, got " ++ show ast + + , testCase "Unparenthesized annotation names remain ordinary aliases" $ do + let input = "foo x@List Bool =@Bool x" + expect = SDefAnn "foo" + [DefBinder "x" (Just (VEName "List")), DefBinder "Bool" Nothing] + (Just (VEName "Bool")) + (SVar "x" Nothing) + parseSingle input @?= expect + , testCase "Parse let expression" $ do let input = "let x = t t in x" expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf) @@ -562,742 +656,620 @@ lambdas = testGroup "Lambda Evaluation Tests" maybeTests :: TestTree maybeTests = testGroup "Maybe Tests" [ testCase "nothing is Leaf" $ do - base <- evaluateFile "./lib/base.tri" let input = "nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "just wraps value in Stem" $ do - base <- evaluateFile "./lib/base.tri" let input = "just (t t)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem (Stem Leaf) , testCase "matchMaybe on nothing returns default" $ do - base <- evaluateFile "./lib/base.tri" let input = "matchMaybe \"empty\" (x : x) nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "empty" , testCase "matchMaybe on just extracts value" $ do - base <- evaluateFile "./lib/base.tri" let input = "matchMaybe \"empty\" (x : x) (just (t t))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem Leaf , testCase "maybe applies f inside just" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybe 0 (x : succ x) (just 5)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 6 , testCase "maybe returns default on nothing" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybe 0 (x : succ x) nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "maybeMap transforms just value" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeMap (x : succ x) (just 3)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (ofNumber 4) , testCase "maybeMap returns nothing on nothing" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeMap (x : succ x) nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "maybeBind flattens just" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeBind (just 3) (x : just (succ x))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (ofNumber 4) , testCase "maybeBind returns nothing on nothing" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeBind nothing (x : just (succ x))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "maybeOr returns just value" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeOr 99 (just 5)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "maybeOr returns default on nothing" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybeOr 99 nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 99 , testCase "maybe? on just is true" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybe? (just t)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "maybe? on nothing is false" $ do - base <- evaluateFile "./lib/base.tri" let input = "maybe? nothing" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT ] providedLibraries :: TestTree providedLibraries = testGroup "Library Tests" [ testCase "Triage test Leaf" $ do - library <- evaluateFile "./lib/list.tri" let input = "test t" - env = decodeResult $ result $ evalTricu library (parseTricu input) + env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input) env @?= "\"Leaf\"" , testCase "Triage test (Stem Leaf)" $ do - library <- evaluateFile "./lib/list.tri" let input = "test (t t)" - env = decodeResult $ result $ evalTricu library (parseTricu input) + env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input) env @?= "\"Stem\"" , testCase "Triage test (Fork Leaf Leaf)" $ do - library <- evaluateFile "./lib/list.tri" let input = "test (t t t)" - env = decodeResult $ result $ evalTricu library (parseTricu input) + env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input) env @?= "\"Fork\"" , testCase "Boolean NOT: true" $ do - library <- evaluateFile "./lib/list.tri" let input = "not? true" - env = result $ evalTricu library (parseTricu input) + env = result $ evalTricu allTestLibsEnv (parseTricu input) env @?= Leaf , testCase "Boolean NOT: false" $ do - library <- evaluateFile "./lib/list.tri" let input = "not? false" - env = result $ evalTricu library (parseTricu input) + env = result $ evalTricu allTestLibsEnv (parseTricu input) env @?= Stem Leaf , testCase "Boolean AND TF" $ do - library <- evaluateFile "./lib/list.tri" let input = "and? (t t) (t)" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "Boolean AND FT" $ do - library <- evaluateFile "./lib/list.tri" let input = "and? (t) (t t)" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "Boolean AND FF" $ do - library <- evaluateFile "./lib/list.tri" let input = "and? (t) (t)" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "Boolean AND TT" $ do - library <- evaluateFile "./lib/list.tri" let input = "and? (t t) (t t)" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem Leaf , testCase "List head" $ do - library <- evaluateFile "./lib/list.tri" let input = "head [(t) (t t) (t t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Leaf , testCase "List tail" $ do - library <- evaluateFile "./lib/list.tri" let input = "head (tail (tail [(t) (t t) (t t t)]))" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Fork Leaf Leaf , testCase "List map" $ do - library <- evaluateFile "./lib/list.tri" let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Fork Leaf Leaf , testCase "Empty list check" $ do - library <- evaluateFile "./lib/list.tri" let input = "emptyList? []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem Leaf , testCase "Non-empty list check" $ do - library <- evaluateFile "./lib/list.tri" let input = "not? (emptyList? [(1) (2) (3)])" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem Leaf , testCase "Concatenate strings" $ do - library <- evaluateFile "./lib/list.tri" let input = "append \"Hello, \" \"world!\"" - env = decodeResult $ result $ evalTricu library (parseTricu input) + env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input) env @?= "\"Hello, world!\"" , testCase "Verifying Equality" $ do - library <- evaluateFile "./lib/list.tri" let input = "equal? (t t t) (t t t)" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= Stem Leaf , testCase "headMaybe on empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "headMaybe []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "headMaybe on non-empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "headMaybe [(t) (t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT Leaf , testCase "lastMaybe on empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "lastMaybe []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "lastMaybe on single element" $ do - library <- evaluateFile "./lib/list.tri" let input = "lastMaybe [(t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (Stem Leaf) , testCase "lastMaybe on multi-element list" $ do - library <- evaluateFile "./lib/list.tri" let input = "lastMaybe [(t) (t t) (t t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (Fork Leaf Leaf) , testCase "nthMaybe first element" $ do - library <- evaluateFile "./lib/list.tri" let input = "nthMaybe 0 [(t) (t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT Leaf , testCase "nthMaybe middle element" $ do - library <- evaluateFile "./lib/list.tri" let input = "nthMaybe 1 [(t) (t t) (t t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (Stem Leaf) , testCase "nthMaybe out of bounds" $ do - library <- evaluateFile "./lib/list.tri" let input = "nthMaybe 5 [(t) (t t)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "reverse empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "reverse []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "reverse non-empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "reverse [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 3, ofNumber 2, ofNumber 1] , testCase "take 0 any list = empty" $ do - library <- evaluateFile "./lib/list.tri" let input = "take 0 [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "take 2 [1,2,3] = [1,2]" $ do - library <- evaluateFile "./lib/list.tri" let input = "take 2 [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 1, ofNumber 2] , testCase "take overlong returns whole list" $ do - library <- evaluateFile "./lib/list.tri" let input = "take 5 [(1) (2)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 1, ofNumber 2] , testCase "drop 0 any list = list" $ do - library <- evaluateFile "./lib/list.tri" let input = "drop 0 [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 1, ofNumber 2, ofNumber 3] , testCase "drop 2 [1,2,3] = [3]" $ do - library <- evaluateFile "./lib/list.tri" let input = "drop 2 [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 3] , testCase "drop overlong returns empty" $ do - library <- evaluateFile "./lib/list.tri" let input = "drop 5 [(1) (2)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "splitAt 0 [1,2] = pair [] [1,2]" $ do - library <- evaluateFile "./lib/list.tri" let input = "splitAt 0 [(1) (2)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (ofList []) (ofList [ofNumber 1, ofNumber 2]) , testCase "splitAt 2 [1,2,3] = pair [1,2] [3]" $ do - library <- evaluateFile "./lib/list.tri" let input = "splitAt 2 [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [ofNumber 3]) , testCase "splitAt overlong = pair [1,2] []" $ do - library <- evaluateFile "./lib/list.tri" let input = "splitAt 5 [(1) (2)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList []) , testCase "concatMap on empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "concatMap (x : [(x) (x)]) []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "concatMap doubles elements" $ do - library <- evaluateFile "./lib/list.tri" let input = "concatMap (x : [(x) (x)]) [(1) (2)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 1, ofNumber 1, ofNumber 2, ofNumber 2] , testCase "find on empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "find (x : equal? x 2) []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "find finds element" $ do - library <- evaluateFile "./lib/list.tri" let input = "find (x : equal? x 2) [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (ofNumber 2) , testCase "find missing element" $ do - library <- evaluateFile "./lib/list.tri" let input = "find (x : equal? x 9) [(1) (2) (3)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "partition empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "partition (x : equal? x 2) []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (ofList []) (ofList []) , testCase "partition splits list" $ do - library <- evaluateFile "./lib/list.tri" let input = "partition (x : lt? 2 x) [(1) (2) (3) (4)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (ofList [ofNumber 3, ofNumber 4]) (ofList [ofNumber 1, ofNumber 2]) , testCase "zipWith on empty lists" $ do - library <- evaluateFile "./lib/list.tri" let input = "zipWith add [] []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "zipWith adds pairwise" $ do - library <- evaluateFile "./lib/list.tri" let input = "zipWith add [(1) (2)] [(10) (20)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 11, ofNumber 22] , testCase "zipWith truncates to shorter list" $ do - library <- evaluateFile "./lib/list.tri" let input = "zipWith add [(1) (2)] [(10)]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofNumber 11] , testCase "strLength" $ do - library <- evaluateFile "./lib/list.tri" let input = "strLength \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "strAppend" $ do - library <- evaluateFile "./lib/list.tri" let input = "strAppend \"hello\" \" world\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "hello world" , testCase "equal? equal strings" $ do - library <- evaluateFile "./lib/list.tri" let input = "equal? \"abc\" \"abc\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "equal? different strings" $ do - library <- evaluateFile "./lib/list.tri" let input = "equal? \"abc\" \"def\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "strEmpty? on empty" $ do - library <- evaluateFile "./lib/list.tri" let input = "strEmpty? \"\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "strEmpty? on non-empty" $ do - library <- evaluateFile "./lib/list.tri" let input = "strEmpty? \"a\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "startsWith? prefix matches" $ do - library <- evaluateFile "./lib/list.tri" let input = "startsWith? \"he\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "startsWith? prefix too long" $ do - library <- evaluateFile "./lib/list.tri" let input = "startsWith? \"hello\" \"he\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "startsWith? empty prefix" $ do - library <- evaluateFile "./lib/list.tri" let input = "startsWith? \"\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "endsWith? suffix matches" $ do - library <- evaluateFile "./lib/list.tri" let input = "endsWith? \"lo\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "endsWith? suffix too long" $ do - library <- evaluateFile "./lib/list.tri" let input = "endsWith? \"hello\" \"lo\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "endsWith? empty suffix" $ do - library <- evaluateFile "./lib/list.tri" let input = "endsWith? \"\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "contains? substring found" $ do - library <- evaluateFile "./lib/list.tri" let input = "contains? \"ell\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "contains? substring missing" $ do - library <- evaluateFile "./lib/list.tri" let input = "contains? \"xyz\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "contains? empty needle" $ do - library <- evaluateFile "./lib/list.tri" let input = "contains? \"\" \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "lines splits on newline" $ do - library <- evaluateFile "./lib/list.tri" let input = "lines \"a\\nb\\nc\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString "a", ofString "b", ofString "c"] , testCase "lines single line" $ do - library <- evaluateFile "./lib/list.tri" let input = "lines \"hello\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString "hello"] , testCase "lines empty string" $ do - library <- evaluateFile "./lib/list.tri" let input = "lines \"\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString ""] , testCase "lines trailing newline" $ do - library <- evaluateFile "./lib/list.tri" let input = "lines \"a\\n\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString "a", ofString ""] , testCase "unlines joins with newline" $ do - library <- evaluateFile "./lib/list.tri" let input = "unlines [(\"a\") (\"b\")]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "a\nb\n" , testCase "unlines empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "unlines []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "" , testCase "words splits on space" $ do - library <- evaluateFile "./lib/list.tri" let input = "words \"hello world\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString "hello", ofString "world"] , testCase "words empty string" $ do - library <- evaluateFile "./lib/list.tri" let input = "words \"\"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [] , testCase "words multiple spaces" $ do - library <- evaluateFile "./lib/list.tri" let input = "words \" hello world \"" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofList [ofString "hello", ofString "world"] , testCase "unwords joins with space" $ do - library <- evaluateFile "./lib/list.tri" let input = "unwords [(\"hello\") (\"world\")]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "hello world" , testCase "unwords single word" $ do - library <- evaluateFile "./lib/list.tri" let input = "unwords [(\"hello\")]" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "hello" , testCase "unwords empty list" $ do - library <- evaluateFile "./lib/list.tri" let input = "unwords []" - env = evalTricu library (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "" ] arithmeticTests :: TestTree arithmeticTests = testGroup "Arithmetic Tests" [ testCase "isZero? on 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "isZero? 0" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "isZero? on 5" $ do - base <- evaluateFile "./lib/base.tri" let input = "isZero? 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "add 0 3 = 3" $ do - base <- evaluateFile "./lib/base.tri" let input = "add 0 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 3 , testCase "add 3 0 = 3" $ do - base <- evaluateFile "./lib/base.tri" let input = "add 3 0" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 3 , testCase "add 2 3 = 5" $ do - base <- evaluateFile "./lib/base.tri" let input = "add 2 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "sub 5 2 = 3" $ do - base <- evaluateFile "./lib/base.tri" let input = "sub 5 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 3 , testCase "sub 2 5 = 0 (saturated)" $ do - base <- evaluateFile "./lib/base.tri" let input = "sub 2 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "sub 5 5 = 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "sub 5 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "lt? 2 3 = true" $ do - base <- evaluateFile "./lib/base.tri" let input = "lt? 2 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "lt? 3 2 = false" $ do - base <- evaluateFile "./lib/base.tri" let input = "lt? 3 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "lt? 2 2 = false" $ do - base <- evaluateFile "./lib/base.tri" let input = "lt? 2 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "lte? 2 3 = true" $ do - base <- evaluateFile "./lib/base.tri" let input = "lte? 2 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "lte? 3 2 = false" $ do - base <- evaluateFile "./lib/base.tri" let input = "lte? 3 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "lte? 2 2 = true" $ do - base <- evaluateFile "./lib/base.tri" let input = "lte? 2 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "mul 0 5 = 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 0 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "mul 5 0 = 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 5 0" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "mul 2 3 = 6" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 2 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 6 , testCase "mul 3 3 = 9" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 3 3" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 9 , testCase "pred 0 = 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "pred 0" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "pred 1 = 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "pred 1" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "pred 5 = 4" $ do - base <- evaluateFile "./lib/base.tri" let input = "pred 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 4 , testCase "add is commutative" $ do - base <- evaluateFile "./lib/base.tri" let input = "equal? (add 4 7) (add 7 4)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "add is associative" $ do - base <- evaluateFile "./lib/base.tri" let input = "equal? (add (add 2 3) 4) (add 2 (add 3 4))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "sub x 0 = x" $ do - base <- evaluateFile "./lib/base.tri" let input = "sub 7 0" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 7 , testCase "sub chained" $ do - base <- evaluateFile "./lib/base.tri" let input = "sub (sub 10 3) 2" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "mul identity 1" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 1 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "mul identity 2" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 5 1" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 5 , testCase "mul is commutative" $ do - base <- evaluateFile "./lib/base.tri" let input = "equal? (mul 3 4) (mul 4 3)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "mul is associative" $ do - base <- evaluateFile "./lib/base.tri" let input = "equal? (mul (mul 2 3) 4) (mul 2 (mul 3 4))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "mul distributes over add" $ do - base <- evaluateFile "./lib/base.tri" let input = "equal? (mul 2 (add 3 4)) (add (mul 2 3) (mul 2 4))" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "lt? reflexive is false" $ do - base <- evaluateFile "./lib/base.tri" let input = "lt? 5 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "lte? reflexive is true" $ do - base <- evaluateFile "./lib/base.tri" let input = "lte? 5 5" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "lt? transitivity" $ do - base <- evaluateFile "./lib/base.tri" let input = "and? (lt? 2 5) (lt? 5 7)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "add larger numbers" $ do - base <- evaluateFile "./lib/base.tri" let input = "add 12 15" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 27 , testCase "mul larger numbers" $ do - base <- evaluateFile "./lib/base.tri" let input = "mul 5 6" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 30 , testCase "isZero? on add 0 0" $ do - base <- evaluateFile "./lib/base.tri" let input = "isZero? (add 0 0)" - env = evalTricu base (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT ] @@ -1312,54 +1284,14 @@ fileEval = testGroup "File evaluation tests" res @?= Fork (Stem Leaf) Leaf , testCase "Mapping and Equality" $ do - library <- liftIO $ evaluateFile "./lib/list.tri" - fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri" + fEnv <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/map.tri" (mainResult fEnv) @?= Stem Leaf , testCase "Eval and decoding string" $ do - library <- liftIO $ evaluateFile "./lib/list.tri" - res <- liftIO $ evaluateFileWithContext library "./test/string.tri" + res <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/string.tri" decodeResult (result res) @?= "\"String test!\"" ] -modules :: TestTree -modules = testGroup "Test modules" - [ testCase "Detect cyclic dependencies" $ do - result <- try (liftIO $ evaluateFileResult "./test/cycle-1.tri") :: IO (Either SomeException T) - case result of - Left e -> do - let errorMsg = show e - if "Encountered cyclic import" `isInfixOf` errorMsg - then return () - else assertFailure $ "Unexpected error: " ++ errorMsg - Right _ -> assertFailure "Expected cyclic dependencies" - , testCase "Module imports and namespacing" $ do - res <- liftIO $ evaluateFileResult "./test/namespace-A.tri" - res @?= Leaf - , testCase "Multiple imports" $ do - res <- liftIO $ evaluateFileResult "./test/vars-A.tri" - res @?= Leaf - , testCase "Error on unresolved variable" $ do - result <- try (liftIO $ evaluateFileResult "./test/unresolved-A.tri") :: IO (Either SomeException T) - case result of - Left e -> do - let errorMsg = show e - if "undefinedVar" `isInfixOf` errorMsg - then return () - else assertFailure $ "Unexpected error: " ++ errorMsg - Right _ -> assertFailure "Expected unresolved variable error" - , testCase "Multi-level imports" $ do - res <- liftIO $ evaluateFileResult "./test/multi-level-A.tri" - res @?= Leaf - , testCase "Lambda expression namespaces" $ do - res <- liftIO $ evaluateFileResult "./test/lambda-A.tri" - res @?= Leaf - , testCase "Local namespace import chain" $ do - res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri" - res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf) - ] - - -- All of our demo tests are also module tests demos :: TestTree demos = testGroup "Test provided demo functionality" @@ -1574,6 +1506,486 @@ byteMarshallingTests = testGroup "Byte Marshalling Tests" treeBytesToHash t16 @?= Left "Expected exactly 32 byte elements for hash" ] +-- -------------------------------------------------------------------------- +-- Content store tests +-- -------------------------------------------------------------------------- + +contentStoreTests :: TestTree +contentStoreTests = testGroup "Content Store Tests" + [ testCase "Filesystem CAS: put/get object and sharded path" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + domain = Domain "test.object.v1" + payload = BS.pack [1, 2, 3, 4] + h <- putObject store domain payload + shardForHash h @?= take 3 (unpack h) + objectPath store h @?= dir "objects" take 3 (unpack h) unpack h + doesFileExist (objectPath store h) >>= (@?= True) + getObject store h >>= (@?= Just payload) + + , testCase "Filesystem CAS: idempotent object writes" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + domain = Domain "test.object.v1" + payload = BS.pack [9, 8, 7] + h1 <- putObject store domain payload + h2 <- putObject store domain payload + h1 @?= h2 + countStoredObjects store >>= (@?= 1) + + , testCase "Filesystem CAS: putTree/getTree round trip" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + term = Fork (Stem Leaf) (Fork Leaf (Stem Leaf)) + leafHash = nodeHash NLeaf + stemHash = nodeHash (NStem leafHash) + rightHash = nodeHash (NFork leafHash stemHash) + expectedRoot = nodeHash (NFork stemHash rightHash) + root <- putTree store term + root @?= expectedRoot + getTree store root >>= (@?= Just term) + + , testCase "Filesystem CAS: shared subtrees are deduplicated" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + shared = Stem Leaf + term = Fork shared shared + _ <- putTree store term + countStoredObjects store >>= (@?= 3) + + , testCase "Workspace aliases: write/read/list object refs" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + ref = ObjectRef "arboricx.tree-root.v1" "abc123" + writeAlias store NameAlias "main" ref + readAlias store NameAlias "main" >>= (@?= Just ref) + listAliases store NameAlias >>= (@?= [("main", ref)]) + + , testCase "Module manifests: deterministic encoding and hash" $ do + let manifest = ModuleManifest + [ ModuleReference "base" (ObjectRef (unDomain manifestDomain) "111") ] + [ ModuleExport + "main" + (ObjectRef (unDomain treeTermDomain) "222") + "arboricx.abi.tree.v1" + (Just (ObjectRef viewContractTypeKind "333")) + ] + encoded = encodeManifest manifest + decodeManifest encoded @?= Right manifest + hashObject manifestDomain encoded @?= "7c3cb85454744894a403d2d12c7ece6d391c0cfbeb4bf3adfc7e69ae70ec4f5c" + + , testCase "View Contract type artifacts: encode/decode round trip" $ do + let view = VTFn [VTList (VTName "String"), VTPair (VTName "Byte") (VTMaybe (VTRef 7))] + (VTResult (VTName "Byte") (VTName "Bool")) + decodeViewType (encodeViewType view) @?= Right view + + , testCase "View Contract type artifacts: encode/decode string refs" $ do + let view = VTFn [VTRefText "Nat"] (VTPair (VTRefText "Box") (VTName "String")) + decodeViewType (encodeViewType view) @?= Right view + + , testCase "View Contract type artifacts: encode/decode guarded views with opaque guard trees" $ do + let guardTree = Fork (Stem Leaf) Leaf + view = VTGuarded (VTRefText "UserId") guardTree + decodeViewType (encodeViewType view) @?= Right view + + , testCase "View-tree artifacts: encode/decode and put/get through CAS" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + viewTree = Fork (Stem Leaf) (Fork Leaf (Stem Leaf)) + decodeViewTree (encodeViewTree viewTree) @?= Right viewTree + ref <- putViewTree store viewTree + objectRefKind ref @?= viewTreeKind + getViewTree store ref >>= (@?= Right viewTree) + + , testCase "View Contract type artifacts: put/get through CAS" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + view = VTFn [VTName "Bool"] (VTName "String") + ref <- putViewType store view + objectRefKind ref @?= viewContractTypeKind + getViewType store ref >>= (@?= Right view) + + , testCase "Module manifests: put/get round trip through CAS" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + term = Fork Leaf (Stem Leaf) + manifestFor root = ModuleManifest [] + [ ModuleExport + "main" + (ObjectRef (unDomain treeTermDomain) root) + "arboricx.abi.tree.v1" + Nothing + ] + root <- putTreeTerm store term + h <- putManifest store (manifestFor root) + getManifest store h >>= (@?= Just (manifestFor root)) + + , testCase "ObjectResolver: resolves manifests and trees without filesystem coupling" $ do + let term = Fork Leaf (Stem Leaf) + leafH = nodeHash NLeaf + stemH = nodeHash (NStem leafH) + rootH = nodeHash (NFork leafH stemH) + termH = hashObject treeTermDomain (encodeTreeTerm term) + manifest = ModuleManifest [] + [ ModuleExport + "value" + (ObjectRef (unDomain treeTermDomain) termH) + "arboricx.abi.tree.v1" + Nothing + ] + manifestBytes = encodeManifest manifest + manifestH = hashObject manifestDomain manifestBytes + objects = Map.fromList + [ (("arboricx.merkle.node.v1", leafH), serializeNode NLeaf) + , (("arboricx.merkle.node.v1", stemH), serializeNode (NStem leafH)) + , (("arboricx.merkle.node.v1", rootH), serializeNode (NFork leafH stemH)) + , ((unDomain treeTermDomain, termH), encodeTreeTerm term) + , ((unDomain manifestDomain, manifestH), manifestBytes) + ] + hydrate objs h = case deserializeNode <$> Map.lookup ("arboricx.merkle.node.v1", h) objs of + Nothing -> return Nothing + Just NLeaf -> return (Just Leaf) + Just (NStem child) -> fmap Stem <$> hydrate objs child + Just (NFork left right) -> do + l <- hydrate objs left + r <- hydrate objs right + return $ Fork <$> l <*> r + resolver = ObjectResolver + { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo" + then Just (ObjectRef (unDomain manifestDomain) manifestH) + else Nothing + , resolverObject = \ref -> return $ Map.lookup (objectRefKind ref, objectRefHash ref) objects + , resolverManifest = \h -> return $ do + bytes <- Map.lookup (unDomain manifestDomain, h) objects + either (const Nothing) Just (decodeManifest bytes) + , resolverTree = hydrate objects + } + resolverAlias resolver ModuleAlias "demo" >>= (@?= Just (ObjectRef (unDomain manifestDomain) manifestH)) + resolveManifest resolver manifestH >>= (@?= Just manifest) + resolveTree resolver rootH >>= (@?= Just term) + + , testCase "Workspace modules: auto-build source module into manifest" $ + withSystemTempDirectory "tricu-workspace-module" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "value = t t\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.value\n" + env <- evaluateFileWithStore (Just store) mainPath + result env @?= Stem Leaf + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected workspace build to write util module alias" + Just ref -> do + objectRefKind ref @?= unDomain manifestDomain + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected workspace module manifest" + Just manifest -> case moduleManifestExports manifest of + [ex] -> do + objectRefKind (moduleExportObject ex) @?= viewTreeKind + loaded <- getViewTree store (moduleExportObject ex) + (loaded >>= viewTreeRootTerm) @?= Right (Stem Leaf) + other -> assertFailure $ "unexpected exports: " ++ show other + + , testCase "Workspace modules: attach direct View Contract type artifacts to annotated exports" $ + withSystemTempDirectory "tricu-workspace-export-views" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "id x@Bool =@Bool x\nplain = t\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.id t\n" + _ <- evaluateFileWithStore (Just store) mainPath + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected workspace build to write util module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected workspace module manifest" + Just manifest -> do + let exports = moduleManifestExports manifest + viewFor name = moduleExportView =<< findExport name exports + map moduleExportName exports @?= ["id", "plain"] + map (objectRefKind . moduleExportObject) exports @?= [viewTreeKind, viewTreeKind] + map moduleExportAbi exports @?= ["arboricx.abi.view-tree.v1", "arboricx.abi.view-tree.v1"] + case viewFor "id" of + Nothing -> assertFailure "expected annotated export view ref" + Just viewRef -> do + objectRefKind viewRef @?= viewContractTypeKind + getViewType store viewRef >>= (@?= Right (VTFn [VTRef 0] (VTRef 0))) + viewFor "plain" @?= Nothing + + , testCase "Workspace module checks: consumer imports use producer-checked view refs" $ + withSystemTempDirectory "tricu-workspace-consumer-check-ok" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "id x@Bool =@Bool x\n" + writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.id x\n" + output <- checkFileWithStore store mainPath + output @?= "ok" + + , testCase "Workspace module checks: consumer mismatches are judged from imported view refs" $ + withSystemTempDirectory "tricu-workspace-consumer-check-fail" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "toString x@Bool =@String \"ok\"\n" + writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.toString x\n" + output <- checkFileWithStore store mainPath + output @?= "symbol 3 (Util.toString application result) expected Bool but got String" + + , testCase "Workspace module checks: producer checks use imported view refs" $ + withSystemTempDirectory "tricu-workspace-producer-import-view-ok" $ \dir -> do + let store = StorePath (dir "store") + depPath = dir "dep.tri" + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n" + writeFile depPath "id x@Bool =@Bool x\n" + writeFile libPath "!import \"dep\" Dep\n\nuseId x@Bool =@Bool Dep.id x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.useId t\n" + _ <- evaluateFileWithStore (Just store) mainPath + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected producer-checked util module alias" + Just ref -> do + Just manifest <- getManifest store (objectRefHash ref) + case moduleExportView =<< findExport "useId" (moduleManifestExports manifest) of + Nothing -> assertFailure "expected imported-view-checked export view" + Just viewRef -> getViewType store viewRef >>= (@?= Right (VTFn [VTRef 0] (VTRef 0))) + + , testCase "Workspace module checks: producer rejects mismatches against imported view refs" $ + withSystemTempDirectory "tricu-workspace-producer-import-view-fail" $ \dir -> do + let store = StorePath (dir "store") + depPath = dir "dep.tri" + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n" + writeFile depPath "toString x@Bool =@String \"ok\"\n" + writeFile libPath "!import \"dep\" Dep\n\nuseString x@Bool =@Bool Dep.toString x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.useString t\n" + outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env) + case outcome of + Right _ -> assertFailure "expected producer-side imported view mismatch" + Left err -> show err `containsAll` + [ "Workspace module" + , "util" + , "failed View Contract check" + , "Dep.toString application result" + , "expected Bool but got String" + ] + mDepAlias <- readAlias store ModuleAlias "dep" + case mDepAlias of + Nothing -> assertFailure "expected dependency alias to be published" + Just _ -> pure () + readAlias store ModuleAlias "util" >>= (@?= Nothing) + + , testCase "Workspace module checks: imported exports without views remain checker-policy failures" $ + withSystemTempDirectory "tricu-workspace-consumer-check-missing-view" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "plain = t\n" + writeFile mainPath "!import \"util\" Util\n\nfoo =@Bool Util.plain\n" + output <- checkFileWithStore store mainPath + output @?= "symbol 1 (external Util.plain) expected Bool but got Any" + + , testCase "Workspace module checks: invalid imported view artifacts report artifact diagnostics" $ + withSystemTempDirectory "tricu-workspace-consumer-check-invalid-view" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "id x@Bool =@Bool x\n" + writeFile mainPath "!import \"util\" Util\n\nfoo x@Bool =@Bool Util.id x\n" + _ <- evaluateFileWithStore (Just store) mainPath + Just aliasRef <- readAlias store ModuleAlias "util" + Just manifest <- getManifest store (objectRefHash aliasRef) + let corruptRef = ObjectRef "not-a-view-contract-type.v1" "badbad" + corruptExport ex = ex { moduleExportView = Just corruptRef } + corruptManifest = manifest { moduleManifestExports = map corruptExport (moduleManifestExports manifest) } + corruptHash <- putManifest store corruptManifest + writeAlias store ModuleAlias "util" (ObjectRef (unDomain manifestDomain) corruptHash) + outcome <- try (checkFileWithStore store mainPath) :: IO (Either SomeException String) + case outcome of + Right _ -> assertFailure "expected invalid imported view artifact failure" + Left err -> show err `containsAll` + [ "View Contract artifact invalid" + , "Util.id" + , "not-a-view-contract-type.v1" + , "badbad" + , "unsupported View Contract type object kind" + ] + + , testCase "Workspace modules: reject annotated exports that fail producer-side View Contract checks" $ + withSystemTempDirectory "tricu-workspace-bad-export-view" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "bad x@String =@Bool x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.bad\n" + outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env) + case outcome of + Right _ -> assertFailure "expected producer-side View Contract failure" + Left err -> show err `containsAll` + [ "Workspace module" + , "util" + , "failed View Contract check" + , "expected Bool but got String" + ] + readAlias store ModuleAlias "util" >>= (@?= Nothing) + + , testCase "Unchecked workspace eval ignores bad annotations and publishes no view refs" $ + withSystemTempDirectory "tricu-workspace-unchecked-bad-export-view" $ \dir -> do + let store = StorePath (dir "store") + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile libPath "bad x@String =@Bool x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.bad \"hi\"\n" + env <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty mainPath + toString (mainResult env) @?= Right "hi" + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected unchecked eval to publish executable module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected unchecked module manifest" + Just manifest -> case moduleManifestExports manifest of + [ex] -> moduleExportView ex @?= Nothing + other -> assertFailure $ "unexpected exports: " ++ show other + + , testCase "Workspace modules: exported names are local top-level definitions only" $ + withSystemTempDirectory "tricu-workspace-local-exports" $ \dir -> do + let store = StorePath (dir "store") + depPath = dir "dep.tri" + libPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n" + writeFile depPath "helper = t t\n" + writeFile libPath "!import \"dep\" !Local\n\nvalue = helper\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.value\n" + env <- evaluateFileWithStore (Just store) mainPath + result env @?= Stem Leaf + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected workspace build to write util module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected workspace module manifest" + Just manifest -> map moduleExportName (moduleManifestExports manifest) @?= ["value"] + + , testCase "Module imports: resolve manifest exports from store" $ + withSystemTempDirectory "tricu-module-import" $ \dir -> do + let store = StorePath (dir "store") + sourcePath = dir "consumer.tri" + term = Fork Leaf (Stem Leaf) + manifestFor root = ModuleManifest [] + [ ModuleExport + "value" + (ObjectRef (unDomain treeTermDomain) root) + "arboricx.abi.tree.v1" + Nothing + ] + root <- putTreeTerm store term + manifestHash <- putManifest store (manifestFor root) + writeAlias store ModuleAlias "demo" (ObjectRef (unDomain manifestDomain) manifestHash) + writeFile sourcePath "!import \"demo\" Demo\n\nmain = Demo.value\n" + env <- evaluateFileWithStore (Just store) sourcePath + result env @?= term + + , testCase "Module resolver diagnostics: missing alias names workspace/module guidance" $ do + let resolver = filesystemResolver (StorePath "/tmp/tricu-test-missing-module-store") + outcome <- try (resolveModuleImport resolver "definitely-not-a-module" "Demo") :: IO (Either SomeException ResolvedModule) + case outcome of + Right _ -> assertFailure "expected missing module alias failure" + Left err -> show err `containsAll` ["Module alias not found", "definitely-not-a-module", "tricu.workspace", "ModuleAlias"] + + , testCase "Module resolver diagnostics: alias kind mismatch names expected kind" $ do + let resolver = ObjectResolver + { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo" + then Just (ObjectRef "arboricx.tree-root.v1" "abc123") + else Nothing + , resolverObject = \_ -> return Nothing + , resolverManifest = \_ -> return Nothing + , resolverTree = \_ -> return Nothing + } + outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule) + case outcome of + Right _ -> assertFailure "expected alias kind mismatch failure" + Left err -> show err `containsAll` ["Module alias", "demo", "unsupported object kind", "arboricx.tree-root.v1", "arboricx.module-manifest.v1"] + + , testCase "Module resolver diagnostics: missing tree term names export and hash" $ do + let root = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + manifest = ModuleManifest [] + [ ModuleExport "value" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing ] + resolver = ObjectResolver + { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo" + then Just (ObjectRef (unDomain manifestDomain) "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb") + else Nothing + , resolverObject = \_ -> return Nothing + , resolverManifest = \_ -> return (Just manifest) + , resolverTree = \_ -> return Nothing + } + outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule) + case outcome of + Right _ -> assertFailure "expected missing tree term failure" + Left err -> show err `containsAll` ["Module export", "value", "missing tree term", unpack root] + + , testCase "Arboricx bundle: unpack transport bundle into CAS tree terms" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + term = Fork (Stem Leaf) Leaf + bundle = buildBundle [("main", term)] + exports <- unpackBundleToStore store (encodeBundle bundle) + case exports of + [("main", root)] -> getTreeTerm store root >>= (@?= Just term) + other -> assertFailure $ "unexpected exports: " ++ show other + + , testCase "Arboricx bundle: pack CAS tree terms into transport bundle" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let store = StorePath dir + term = Fork Leaf (Stem Leaf) + root <- putTreeTerm store term + bundle <- packBundleFromStore store [("main", root)] + bundleRoots bundle @?= [2] + let terms = reconstructBundleTermsForTest (bundleNodes bundle) + case manifestExports (bundleManifest bundle) of + [exported] -> do + exportName exported @?= "main" + terms V.! fromIntegral (exportRoot exported) @?= term + other -> assertFailure $ "unexpected exports: " ++ show other + ] + +reconstructBundleTermsForTest :: Seq.Seq BundleNode -> V.Vector T +reconstructBundleTermsForTest nodes = V.fromList (go <$> Foldable.toList nodes) + where + built = V.fromList (go <$> Foldable.toList nodes) + go BNLeaf = Leaf + go (BNStem child) = Stem (built V.! fromIntegral child) + go (BNFork left right) = Fork (built V.! fromIntegral left) (built V.! fromIntegral right) + +findExport :: Text -> [ModuleExport] -> Maybe ModuleExport +findExport name = find ((== name) . moduleExportName) + +countStoredObjects :: StorePath -> IO Int +countStoredObjects store@(StorePath root) = do + ensureStore store + shards <- listDirectory (root "objects") + fmap sum $ forM shards $ \shard -> do + files <- listDirectory (root "objects" shard) + return (length files) + -- -------------------------------------------------------------------------- -- Wire module tests -- -------------------------------------------------------------------------- @@ -1676,16 +2088,16 @@ wireTests = testGroup "Wire Tests" Left err -> assertBool ("Expected duplicate error, got: " ++ err) ("duplicate" `isInfixOf` err) Right () -> assertFailure "Expected duplicate nodes to be rejected" - , testCase "Indexed bundle: import into content store" $ do - let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t" - bundle = buildBundle [("validateEmail", term)] - wireData = encodeBundle bundle - dstConn <- newContentStore - roots <- importBundle dstConn wireData - roots @?= ["validateEmail"] - loaded <- loadTerm dstConn "validateEmail" - loaded @?= Just term - close dstConn + , testCase "Indexed bundle: unpack into filesystem CAS" $ + withSystemTempDirectory "tricu-store" $ \dir -> do + let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t" + bundle = buildBundle [("validateEmail", term)] + wireData = encodeBundle bundle + store = StorePath dir + roots <- unpackBundleToStore store wireData + case roots of + [("validateEmail", root)] -> getTree store root >>= (@?= Just term) + other -> assertFailure $ "unexpected roots: " ++ show other , testCase "Indexed bundle: round-trip decode and verify" $ do let term = result $ evalTricu Map.empty $ parseTricu "x = t\ny = t x\nz = t y\nmain = z" @@ -1744,8 +2156,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests" [ testCase "Tricu reader parses indexed bundle (id fixture)" $ do bundleBytes <- BS.readFile "./test/fixtures/id.arboricx" let bundleT = ofBytes bundleBytes - readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri" - let env = Map.insert "testBundle" bundleT readerEnv + let env = Map.insert "testBundle" bundleT allTestLibsEnv tagExpr = parseTricu "pairFirst (runArboricx testBundle t)" tag = result (evalTricu env tagExpr) codeExpr = parseTricu "pairFirst (pairSecond (runArboricx testBundle t))" @@ -1755,8 +2166,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests" , testCase "Tricu reader parses indexed bundle (append fixture)" $ do bundleBytes <- BS.readFile "./test/fixtures/append.arboricx" let bundleT = ofBytes bundleBytes - readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri" - let env = Map.insert "testBundle" bundleT readerEnv + let env = Map.insert "testBundle" bundleT allTestLibsEnv tagExpr = parseTricu "pairFirst (runArboricx testBundle t)" tag = result (evalTricu env tagExpr) tag @?= trueT @@ -1765,8 +2175,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests" forM_ ["true", "false"] $ \name -> do bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx") let bundleT = ofBytes bundleBytes - readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri" - let env = Map.insert "testBundle" bundleT readerEnv + let env = Map.insert "testBundle" bundleT allTestLibsEnv tagExpr = parseTricu "pairFirst (runArboricx testBundle t)" tag = result (evalTricu env tagExpr) tag @?= trueT @@ -1902,176 +2311,147 @@ byteListUtilities :: TestTree byteListUtilities = testGroup "Byte List Utility Tests" [ testCase "isNil: empty list is nil" $ do let input = "bytesNil? []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "isNil: non-empty list is not nil" $ do let input = "bytesNil? [(1)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "head: empty list is nothing" $ do let input = "bytesHead []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "head: non-empty list returns first element" $ do let input = "bytesHead [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (byteT 1) , testCase "tail: empty list is nothing" $ do let input = "bytesTail []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= nothingT , testCase "tail: non-empty list returns rest" $ do let input = "bytesTail [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= justT (bytesT [2]) , testCase "length: empty list is zero" $ do let input = "bytesLength []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 0 , testCase "length: single element list is one" $ do let input = "bytesLength [(1)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 1 , testCase "length: three element list is three" $ do let input = "bytesLength [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofNumber 3 , testCase "append: empty ++ [1,2] = [1,2]" $ do let input = "bytesAppend [] [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2] , testCase "append: [1,2] ++ [3] = [1,2,3]" $ do let input = "bytesAppend [(1) (2)] [(3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2,3] , testCase "append: [1,2] ++ empty = [1,2]" $ do let input = "bytesAppend [(1) (2)] []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2] , testCase "take: take 0 any list = empty" $ do let input = "bytesTake 0 [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [] , testCase "take: take 2 [1,2,3] = [1,2]" $ do let input = "bytesTake 2 [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2] , testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do let input = "bytesTake 5 [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2] , testCase "drop: drop 0 any list = list" $ do let input = "bytesDrop 0 [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [1,2,3] , testCase "drop: drop 2 [1,2,3] = [3]" $ do let input = "bytesDrop 2 [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [3] , testCase "drop: drop 5 [1,2] = empty (overlong)" $ do let input = "bytesDrop 5 [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [] , testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do let input = "bytesSplitAt 0 [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT []) (bytesT [1,2]) , testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do let input = "bytesSplitAt 2 [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT [1,2]) (bytesT [3]) , testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do let input = "bytesSplitAt 5 [(1) (2)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT [1,2]) (bytesT []) , testCase "byteEq: equal bytes are equal" $ do let input = "equal? 1 1" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "byteEq: unequal bytes are not equal" $ do let input = "equal? 1 2" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "bytesEq: empty == empty" $ do let input = "bytesEq? [] []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "bytesEq: empty != [1]" $ do let input = "bytesEq? [] [(1)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "bytesEq: [1] != empty" $ do let input = "bytesEq? [(1)] []" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "bytesEq: equal lists are equal" $ do let input = "bytesEq? [(1) (2) (3)] [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT , testCase "bytesEq: different last element" $ do let input = "bytesEq? [(1) (2) (3)] [(1) (2) (4)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT , testCase "bytesEq: different lengths" $ do let input = "bytesEq? [(1) (2)] [(1) (2) (3)]" - library <- evaluateFile "./lib/bytes.tri" - let env = evalTricu library (parseTricu input) + let env = evalTricu allTestLibsEnv (parseTricu input) result env @?= falseT ] @@ -2088,108 +2468,817 @@ parserErr code rest = Fork falseT (Fork code rest) binaryParserTests :: TestTree binaryParserTests = testGroup "Binary Parser Tests" [ testCase "pureParser succeeds" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "pureParser 42 [(1) (2)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 42) (bytesT [1, 2]) , testCase "failParser fails" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "failParser 99 [(1) (2)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 99) (bytesT [1, 2]) , testCase "mapParser transforms value" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "mapParser succ readU8 [(1) (2)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 2) (bytesT [2]) , testCase "bindParser chains parsers" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "bindParser readU8 (x : readU8) [(1) (2)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 2) (bytesT []) , testCase "thenParser discards first result" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "thenParser readU8 readU8 [(1) (2)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 2) (bytesT []) , testCase "orParser tries second on first failure" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "orParser (failParser 1) readU8 [(5)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 5) (bytesT []) , testCase "orParser returns first on success" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "orParser readU8 (failParser 1) [(5)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 5) (bytesT []) , testCase "readWhile consumes matching bytes" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "readWhile (x : lt? x 3) [(1) (2) (3) (4)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4]) , testCase "readWhile leaves non-matching byte" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "bindParser (readWhile (x : lt? x 3)) (x : readU8) [(1) (2) (3)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 3) (bytesT []) , testCase "readUntil stops at matching byte" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "readUntil (x : equal? x 3) [(1) (2) (3) (4)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4]) , testCase "readRemaining returns all bytes" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "readRemaining [(1) (2) (3)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (bytesT [1, 2, 3]) (bytesT []) , testCase "peekU8 does not consume" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "bindParser peekU8 (x : readU8) [(7) (8)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofNumber 7) (bytesT [8]) , testCase "peekU8 second read gets same byte" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "bindParser peekU8 (x : bindParser peekU8 (y : pureParser (pair x y))) [(7)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7]) , testCase "eof? succeeds at empty input" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "eof? []" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk Leaf (bytesT []) , testCase "eof? fails on non-empty input" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "eof? [(1)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 1) (bytesT [1]) , testCase "expectAscii matches string" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "expectAscii \"hi\" [(104) (105) (106)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk Leaf (bytesT [106]) , testCase "expectAscii fails on mismatch" $ do - lib <- evaluateFile "./lib/binary.tri" let input = "expectAscii \"hi\" [(104) (99)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 2) (bytesT [104, 99]) ] +-- -------------------------------------------------------------------------- +-- View Contract tests +-- -------------------------------------------------------------------------- + +viewContractTests :: TestTree +viewContractTests = testGroup "View Contract Tests" + [ testCase "typedValue satisfies typedRequire" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(typedValue 0 (viewRef 10) t) (typedRequire 0 (viewRef 10) t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "ok" + + , testCase "typedApply infers result view from Fn" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 2 [(typedValue 0 (viewRef 10) t) (typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t) (typedRequire 2 (viewRef 10) t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "ok" + + , testCase "typedProgram carries abstract executable tree payloads" $ do + let input = unwords + [ "matchBool \"yes\" \"no\"" + , "(and?" + , " (equal?" + , " (checkedProgramTree (checkTypedProgramWith policyStrict" + , " (typedProgram 0 [(typedValue 0 (viewFn [(viewRef 10)] (viewRef 10)) (x : x))])))" + , " (x : x))" + , " (equal?" + , " (checkedProgramTree (checkTypedProgramWith policyStrict" + , " (typedProgram 2" + , " [(typedValue 0 (viewFn [(viewRef 10)] (viewRef 10)) (x : x))" + , " (typedValue 1 (viewRef 10) (t t))" + , " (typedApply 2 0 1 (t t))" + , " (typedRequire 2 (viewRef 10) (t t))])))" + , " (t t)))" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "checkTypedProgram returns checked-exec wrapper on success" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchBool \"yes\" \"no\" (equal? (recordTag exec) checkedExecTagPure)) (checkTypedProgram (typedProgram 0 [(typedValue 0 (viewRef 10) (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "guarded typedRequire injects checked guard on root success" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString (t t)) (typedRequire 0 (viewGuarded viewString (x : guardOk x)) (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "guarded typedRequire injects checked guard on root failure" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString (t t)) (typedRequire 0 (viewGuarded viewString (x : guardFail)) (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "root guarded observations compose in typed-node order" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"2\"))) \"x\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "x12" + + , testCase "guarded typedValue implies base evidence and composes with later guarded require" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedRequire 0 (viewGuarded viewString (x : guardOk (append x \"2\"))) \"x\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "x12" + + , testCase "guarded function argument injects before root application" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardOk x))] viewString) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "guarded function argument failure skips root application" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardFail))] viewString) (x : \"entered\")) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "guarded function argument failure renders application context" $ do + let input = "matchResult (diag env : renderDiagnostic diag) (exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewGuarded viewString (x : guardFail))] viewString) (x : \"entered\")) (typedValue 1 viewString (t t)) (typedApply 2 0 1 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String" + + , testCase "non-root guarded requirement composes before argument use" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : x)) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"1\"))) \"x\") (typedApply 2 0 1 \"x\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "x1" + + , testCase "non-root guarded requirement failure skips argument use" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"entered\")) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardFail)) \"x\") (typedApply 2 0 1 \"entered\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "guarded function result injects after root application success" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardOk x))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "guarded function result failure stops at checked boundary" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardFail))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "guarded function result failure renders application context" $ do + let input = "matchResult (diag env : renderDiagnostic diag) (exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] (viewGuarded viewString (x : guardFail))) (x : x)) (typedValue 1 viewString (t t)) (typedApply 2 0 1 (t t))]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed at result of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded String" + + , testCase "nested curried application injects guarded later argument" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewGuarded viewString (x : guardOk (append x \"!\")))] viewString) (x : y : y)) (typedValue 1 viewString \"a\") (typedApply 2 0 1 (y : y)) (typedValue 3 viewString \"b\") (typedApply 4 2 3 \"b\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "b!" + + , testCase "unreachable guarded symbol does not run guard" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewString \"root\") (typedValue 1 viewString \"unused\") (typedRequire 1 (viewGuarded viewString (x : guardFail)) \"unused\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "root" + + , testCase "later guarded require is a global symbol observation" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : x)) (typedValue 1 viewString \"x\") (typedApply 2 0 1 \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"!\"))) \"x\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "x!" + + , testCase "repeated reachable uses rerun symbol observations" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewString)] viewString) (x : y : append x y)) (typedValue 1 viewString \"x\") (typedRequire 1 (viewGuarded viewString (x : guardOk (append x \"!\"))) \"x\") (typedApply 2 0 1 (y : append \"x\" y)) (typedApply 4 2 1 \"xx\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "x!x!" + + , testCase "guarded callee symbol observation runs before application" $ do + let input = "checkedProgramTree (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"raw\")) (typedRequire 0 (viewGuarded (viewFn [(viewString)] viewString) (f : guardOk (x : \"guarded\"))) (x : \"raw\")) (typedValue 1 viewString \"arg\") (typedApply 2 0 1 \"raw\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guarded" + + , testCase "guarded callee symbol failure skips application" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 0 (viewFn [(viewString)] viewString) (x : \"entered\")) (typedRequire 0 (viewGuarded (viewFn [(viewString)] viewString) (f : guardFail)) (x : \"entered\")) (typedValue 1 viewString \"arg\") (typedApply 2 0 1 \"entered\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "nested curried guarded argument failure skips final callee" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (exec env : matchResult (runtimeDiag runtimeEnv : diagnosticMessage runtimeDiag) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 4 [(typedValue 0 (viewFn [(viewString) (viewGuarded viewString (x : guardFail))] viewString) (x : y : \"entered\")) (typedValue 1 viewString \"a\") (typedApply 2 0 1 (y : \"entered\")) (typedValue 3 viewString \"b\") (typedApply 4 2 3 \"entered\")]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "runChecked guard success unwraps and continues" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (value env : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked (checkedGuard viewString (x : guardOk x) (t t) (x : checkedPure x)))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "runChecked guard failure does not enter continuation" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedGuard viewString (x : guardFail) (t t) (x : checkedPure \"entered\")))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "checkedBind composes checked execution success" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (value env : matchBool \"yes\" \"no\" (equal? value (t t))) (runChecked (checkedBind (checkedPure (t t)) (x : checkedPure x)))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "checkedBind propagates checked execution failure" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedBind (checkedGuard viewString (x : guardFail) (t t) (x : checkedPure x)) (x : checkedPure \"entered\")))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "guard failed" + + , testCase "runChecked malformed guard result fails at checked-exec boundary" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (value env : value) (runChecked (checkedGuard viewString (x : record 99 t) (t t) (x : checkedPure x)))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "malformed guard result" + + , testCase "Strict policy rejects missing argument view for known Fn" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyStrict (typedProgram 2 [(typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "function argument view is not known" + + , testCase "Gradual policy trusts missing argument view for known Fn" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyGradual (typedProgram 2 [(typedValue 1 (viewFn [(viewRef 10)] (viewRef 10)) t) (typedApply 2 1 0 t) (typedRequire 0 (viewRef 10) t) (typedRequire 2 (viewRef 10) t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "ok" + + , testCase "Strict policy rejects explicit missing typedRequire" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyStrict (typedProgram 0 [(typedRequire 0 (viewRef 10) t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "required view is not known" + + , testCase "Gradual policy trusts explicit missing typedRequire" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith policyGradual (typedProgram 0 [(typedRequire 0 (viewRef 10) t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "ok" + + , testCase "typedApply leaves unknown callees gradual" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 2 [(typedApply 2 1 0 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "ok" + + , testCase "Malformed typed node is rejected before flow checking" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(record 99 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "malformed view program" + + , testCase "Raw numeric views are rejected before flow checking" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgram (typedProgram 0 [(typedValue 0 10 t)]))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "malformed view program" + + , testCase "Malformed policy is rejected before program checking" $ do + let input = "matchResult (diag env : diagnosticMessage diag) (env rest : \"ok\") (checkTypedProgramWith (pair 99 t) (typedProgram 0 t))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "malformed view policy" + + , testCase "Environment validator accepts only well-formed env entries" $ do + let input = "matchBool \"yes\" \"no\" (wellFormedEnv? [(envEntry 0 [(viewFact (viewRef 10) evidenceTagTrusted)])])" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "Portable View Contract self-tests all pass" $ do + let input = "viewContractSelfTests" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList (replicate 32 (ofString "ok")) + + , testCase "Structured diagnostic tag reports required-view failures" $ do + let input = "checkerResultErrorTag (checkTypedProgramWith policyStrict listMapWrongOutputContract)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 4 + + , testCase "Structured diagnostic payload reports actual argument view" $ do + let input = "matchResult (diag env : matchBool \"yes\" \"no\" (equal? (diagnosticActualView diag) (viewList viewString))) (env rest : \"unexpected-ok\") (checkTypedProgramWith policyStrict listMapWrongListArgContract)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "yes" + + , testCase "Rendered diagnostic explains expected and actual views" $ do + let input = "matchResult (diag env : renderDiagnostic diag) (env rest : \"unexpected-ok\") (checkTypedProgramWith policyStrict listMapWrongListArgContract)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "symbol 162 expected List Bool but got List String" + + , testCase "tricu check lowers annotated identity flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "id x@Bool =@Bool x\n" + output @?= "ok" + + , testCase "tricu check reports annotated body mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "id x@String =@Bool x\n" + output @?= "symbol 1 (x) expected Bool but got String" + + , testCase "tricu check lowers application flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "f x@Bool =@Bool g x\ng y@Bool =@Bool y\n" + output @?= "ok" + + , testCase "tricu check reports application argument mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "f x@String =@Bool g x\ng y@Bool =@Bool y\n" + output @?= "symbol 2 (x) expected Bool but got String" + + , testCase "tricu check maps phantom annotation to exposed lambda binder" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @Bool =@Bool (x : x)\n" + output @?= "ok" + + , testCase "tricu check reports phantom lambda body mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @String =@Bool (x : x)\n" + output @?= "symbol 1 (x) expected Bool but got String" + + , testCase "tricu check maps multiple phantoms to lambda spine" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @Bool @String =@String (x y : y)\n" + output @?= "ok" + + , testCase "tricu check leaves unconsumed phantoms as residual function requirement" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @Bool =@Bool bar\n" + output @?= "symbol 1 (external bar) expected Fn [Bool] Bool but got Any" + + , testCase "tricu check accepts trusted imported View Contract facts" $ do + let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))] + output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n" + output @?= "ok" + + , testCase "tricu check judges imported View Contract facts in checker" $ do + let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "String"))] + output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n" + output @?= "symbol 3 (Ext.id application result) expected Bool but got String" + + , testCase "tricu lower emits imported View Contract facts as view-tree nodes" $ do + let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))] + case lowerSourceWithImportedViews imported "foo x@Bool =@Bool Ext.id x\n" of + Left err -> assertFailure err + Right lowered -> lowered @?= "typedProgram 3 [(typedValue 1 (viewFn [(viewBool)] (viewBool)) t) (typedValue 0 (viewFn [(viewBool)] (viewBool)) t) (typedValue 2 (viewBool) t) (typedRequire 2 (viewBool) t) (typedApply 3 1 2 t) (typedRequire 3 (viewBool) t)]" + + , testCase "tricu lower emits symbolic View Contract refs in view-tree nodes" $ do + case lowerSource "foo x@(Ref \"UserId\") =@(Ref \"UserId\") x\n" of + Left err -> assertFailure err + Right lowered -> lowered @?= "typedProgram 1 [(typedValue 0 (viewFn [(viewRef \"UserId\")] (viewRef \"UserId\")) t) (typedValue 1 (viewRef \"UserId\") t) (typedRequire 1 (viewRef \"UserId\") t)]" + + , testCase "tricu check converts resolved module export views into imported facts" $ do + let viewRef = ObjectRef viewContractTypeKind "abc123" + resolvedExport = ResolvedExport + { resolvedExportSourceName = "id" + , resolvedExportLocalName = "Ext.id" + , resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456" + , resolvedExportAbi = "arboricx.abi.tree.v1" + , resolvedExportView = Just viewRef + , resolvedExportTerm = Leaf + } + resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport] + loadView ref = pure $ if ref == viewRef + then Just (VTFn [VTName "Bool"] (VTName "Bool")) + else Nothing + imported <- importedViewsFromResolvedModules loadView [resolvedModule] + imported @?= [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))] + output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n" + output @?= "ok" + + , testCase "tricu check reports missing resolved View Contract artifacts" $ do + let viewRef = ObjectRef viewContractTypeKind "abc123" + resolvedExport = ResolvedExport + { resolvedExportSourceName = "id" + , resolvedExportLocalName = "Ext.id" + , resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456" + , resolvedExportAbi = "arboricx.abi.tree.v1" + , resolvedExportView = Just viewRef + , resolvedExportTerm = Leaf + } + resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport] + outcome <- try (importedViewsFromResolvedModules (\_ -> pure Nothing) [resolvedModule]) :: IO (Either SomeException [ImportedView]) + case outcome of + Right _ -> assertFailure "expected missing view artifact failure" + Left err -> show err `containsAll` ["View Contract artifact invalid", "Ext.id", "arboricx.view-contract.type.v1", "abc123", "artifact not found"] + + , testCase "tricu check recognizes string literal views" $ do + output <- checkSourceWithEnv allTestLibsEnv "s =@String \"hi\"\n" + output @?= "ok" + + , testCase "tricu check recognizes byte literal views" $ do + output <- checkSourceWithEnv allTestLibsEnv "b =@Byte 42\n" + output @?= "ok" + + , testCase "tricu check recognizes unit literal views" $ do + output <- checkSourceWithEnv allTestLibsEnv "u =@Unit t\n" + output @?= "ok" + + , testCase "tricu check recognizes homogeneous list literal views" $ do + output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(\"a\") (\"b\")]\n" + output @?= "ok" + + , testCase "tricu check propagates let-bound literal views" $ do + output <- checkSourceWithEnv allTestLibsEnv "x =@(List String) let y = \"hi\" in [(y)]\n" + output @?= "ok" + + , testCase "tricu check uses binder views in list literals" $ do + output <- checkSourceWithEnv allTestLibsEnv "xs x@String =@(List String) [(x) (\"b\")]\n" + output @?= "ok" + + , testCase "tricu check consumes Fn return annotations through lambda spine" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [String] String) (x : x)\n" + output @?= "ok" + + , testCase "tricu check reports Fn return annotation lambda mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [String] Bool) (x : x)\n" + output @?= "symbol 1 (x) expected Bool but got String" + + , testCase "tricu check propagates application result views into list literals" $ do + output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@String y\n" + output @?= "ok" + + , testCase "tricu check reports application result view mismatches in list literals" $ do + output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@Bool y\n" + output @?= "symbol 3 (g application result) expected String but got Bool" + + , testCase "tricu check propagates phantom lambda binder views into list literals" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @String =@(List String) (x : [(x)])\n" + output @?= "ok" + + , testCase "tricu check reports phantom lambda binder list mismatches" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo @Byte =@(List String) (x : [(x)])\n" + output @?= "symbol 1 (x) expected String but got Byte" + + , testCase "tricu check checks lambda literals in expected Fn lists" $ do + output <- checkSourceWithEnv allTestLibsEnv "fs =@(List (Fn [String] String)) [((x : x))]\n" + output @?= "ok" + + , testCase "tricu check reports lambda literals in expected Fn list mismatches" $ do + output <- checkSourceWithEnv allTestLibsEnv "fs =@(List (Fn [String] Bool)) [((x : x))]\n" + output @?= "symbol 1 (x) expected Bool but got String" + + , testCase "tricu check propagates expected Fn through partial lambda application" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [Byte] String) (x y : x) \"hi\"\n" + output @?= "ok" + + , testCase "tricu check reports expected Fn mismatch through partial lambda application" $ do + output <- checkSourceWithEnv allTestLibsEnv "foo =@(Fn [Byte] Bool) (x y : x) \"hi\"\n" + output @?= "symbol 1 (string literal) expected Bool but got String" + + , testCase "tricu check lowers expected Pair constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String Byte) pair \"a\" 1\n" + output @?= "ok" + + , testCase "tricu check reports expected Pair constructor element mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String Byte) pair 1 \"a\"\n" + output @?= "symbol 1 (byte literal) expected String but got Byte" + + , testCase "tricu check lowers expected Maybe just constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) just \"a\"\n" + output @?= "ok" + + , testCase "tricu check reports expected Maybe just element mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) just 1\n" + output @?= "symbol 1 (byte literal) expected String but got Byte" + + , testCase "tricu check lowers expected Maybe nothing constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe String) nothing\n" + output @?= "ok" + + , testCase "tricu check lowers expected Result ok constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) ok \"a\" t\n" + output @?= "ok" + + , testCase "tricu check reports expected Result ok value mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) ok 1 t\n" + output @?= "symbol 1 (byte literal) expected String but got Byte" + + , testCase "tricu check lowers expected Result err constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) err 1 t\n" + output @?= "ok" + + , testCase "tricu check reports expected Result err value mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte String) err \"a\" t\n" + output @?= "symbol 1 (string literal) expected Byte but got String" + + , testCase "tricu check lowers nested Maybe List constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) just [(\"a\")]\n" + output @?= "ok" + + , testCase "tricu check reports nested Maybe List constructor element mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) just [(1)]\n" + output @?= "symbol 1 (byte literal) expected String but got Byte" + + , testCase "tricu check lowers nested Pair Maybe constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String (Maybe Byte)) pair \"a\" (just 1)\n" + output @?= "ok" + + , testCase "tricu check reports nested Pair Maybe constructor mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "p =@(Pair String (Maybe Byte)) pair \"a\" (just \"b\")\n" + output @?= "symbol 2 (string literal) expected Byte but got String" + + , testCase "tricu check lowers nested Result List constructor flow" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte (List String)) ok [(\"a\")] t\n" + output @?= "ok" + + , testCase "tricu check reports nested Result List constructor mismatch" $ do + output <- checkSourceWithEnv allTestLibsEnv "r =@(Result Byte (List String)) ok [(1)] t\n" + output @?= "symbol 1 (byte literal) expected String but got Byte" + + , testCase "tricu check propagates expected views through let into constructors" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) let xs = [(\"a\")] in just xs\n" + output @?= "ok" + + , testCase "tricu check reports let-bound constructor mismatches" $ do + output <- checkSourceWithEnv allTestLibsEnv "m =@(Maybe (List String)) let xs = [(1)] in just xs\n" + output @?= "symbol 2 expected List String but got List Byte" + + , testCase "tricu check does not use constructor lowering for shadowed pair" $ do + output <- checkSourceWithEnv allTestLibsEnv "pair x y = x\np =@(Pair String Byte) pair \"a\" 1\n" + output @?= "symbol 5 (pair application result) expected Pair String Byte but got Any" + + , testCase "tricu check does not use constructor lowering for shadowed just" $ do + output <- checkSourceWithEnv allTestLibsEnv "just x = x\nm =@(Maybe String) just \"a\"\n" + output @?= "symbol 3 (just application result) expected Maybe String but got Any" + + , testCase "tricu check documents do-block lowering with explicit bind operator" $ do + output <- checkSourceWithEnv allTestLibsEnv "pure x@String =@(Maybe String) just x\nbind m@(Maybe String) f@(Fn [String] (Maybe String)) =@(Maybe String) m\nm =@(Maybe String) do bind\n x <- pure \"a\"\n pure x\n" + output @?= "ok" + + , testCase "tricu check lowerSource emits expected constructor payload typed nodes" $ do + case lowerSource "m =@(Maybe String) just \"a\"\n" of + Left err -> assertFailure err + Right lowered -> do + assertBool "expected String payload requirement" $ + "typedRequire 1 (viewString)" `isInfixOf` lowered + assertBool "expected Maybe String constructor declaration" $ + "typedValue 2 (viewMaybe (viewString))" `isInfixOf` lowered + + , testCase "tricu check lowerSource emits expected Fn argument typed nodes" $ do + case lowerSource "f x@String =@String x\ny =@String f 1\n" of + Left err -> assertFailure err + Right lowered -> + assertBool "expected application argument requirement" $ + "typedRequire 3 (viewString)" `isInfixOf` lowered + + , testCase "tricu check lowerSource emits phantom-to-lambda typed nodes" $ do + case lowerSource "foo @String =@String (x : x)\n" of + Left err -> assertFailure err + Right lowered -> do + assertBool "expected lambda binder declaration" $ + "typedValue 1 (viewString) t" `isInfixOf` lowered + assertBool "expected lambda body requirement" $ + "typedRequire 1 (viewString) t" `isInfixOf` lowered + + , testCase "tricu check lowerSource emits list element requirements" $ do + case lowerSource "xs =@(List String) [(1)]\n" of + Left err -> assertFailure err + Right lowered -> do + assertBool "expected Byte evidence for literal element" $ + "typedValue 1 (viewByte)" `isInfixOf` lowered + assertBool "expected actual Byte tree payload for literal element" $ + "typedValue 1 (viewByte) (t (t t) t)" `isInfixOf` lowered + assertBool "expected String requirement for list element" $ + "typedRequire 1 (viewString)" `isInfixOf` lowered + + , testCase "tricu check lowerSource documents constructor shadowing fallback" $ do + case lowerSource "just x = x\nm =@(Maybe String) just \"a\"\n" of + Left err -> assertFailure err + Right lowered -> do + assertBool "expected normal application result requirement" $ + "typedRequire 3 (viewMaybe (viewString)) t" `isInfixOf` lowered + assertBool "shadowed just should not emit payload requirement" $ + not ("typedRequire 2 (viewString) t" `isInfixOf` lowered) + + , testCase "tricu check lowerSource emits do-block callback Fn typed nodes" $ do + case lowerSource "pure x@String =@(Maybe String) just x\nbind m@(Maybe String) f@(Fn [String] (Maybe String)) =@(Maybe String) m\nm =@(Maybe String) do bind\n x <- pure \"a\"\n pure x\n" of + Left err -> assertFailure err + Right lowered -> do + assertBool "expected callback lambda declaration" $ + "typedValue 12 (viewFn [(viewString)] (viewMaybe (viewString))) t" `isInfixOf` lowered + assertBool "expected bind application to declared callback" $ + "typedApply 13 9 12 t" `isInfixOf` lowered + + , testCase "tricu check lowerSourceWithDebug records top and binder names" $ do + case lowerSourceWithDebug "id x@String =@String x\n" of + Left err -> assertFailure err + Right (_, debugNames) -> do + Map.lookup 0 debugNames @?= Just "id" + Map.lookup 1 debugNames @?= Just "x" + + , testCase "tricu check lowerSourceWithDebug records literal and application labels" $ do + case lowerSourceWithDebug "f x@String =@String x\ny =@String f 1\n" of + Left err -> assertFailure err + Right (_, debugNames) -> do + Map.lookup 3 debugNames @?= Just "byte literal" + Map.lookup 4 debugNames @?= Just "f application result" + + , testCase "tricu check lowerSourceWithDebug records curried application head labels" $ do + case lowerSourceWithDebug "f x@String y@Byte =@String x\ny =@String f \"a\" 1\n" of + Left err -> assertFailure err + Right (_, debugNames) -> do + Map.lookup 5 debugNames @?= Just "f application result" + Map.lookup 7 debugNames @?= Just "f application result" + + , testCase "tricu check source syntax success demo" $ do + output <- checkFile "./demos/viewContracts/sourceSyntax/success.tri" + output @?= "ok" + + , testCase "tricu check source syntax labeled diagnostic demo" $ do + output <- checkFile "./demos/viewContracts/sourceSyntax/failure.tri" + output @?= "symbol 4 (x) expected Bool but got String" + + , testCase "tricu check annotations can reference local view aliases" $ + withSystemTempDirectory "tricu-local-view-alias" $ \dir -> do + let path = dir "alias.tri" + writeFile path "Nat = viewRef \"Nat\"\n\nidNat x@Nat =@Nat x\n" + output <- checkFile path + output @?= "ok" + + , testCase "tricu check annotations can reference guarded local view aliases" $ + withSystemTempDirectory "tricu-guarded-view-alias" $ \dir -> do + let path = dir "guarded-alias.tri" + writeFile path "userIdGuard = x : guardOk x\nUserId = viewGuarded (viewRef \"UserId\") userIdGuard\n\nidUser x@UserId =@UserId x\n" + output <- checkFile path + output @?= "ok" + + , testCase "tricu check runs source-level guarded root failure" $ + withSystemTempDirectory "tricu-guarded-root-failure" $ \dir -> do + let path = dir "guarded-root-failure.tri" + writeFile path "reject = x : guardFail\nRejectedString = viewGuarded viewString reject\n\nmain =@RejectedString \"x\"\n" + output <- checkFile path + output @?= "guard failed at root typedRequire symbol 3 for Guarded String" + + , testCase "tricu check runs source-level guarded root success" $ + withSystemTempDirectory "tricu-guarded-root-success" $ \dir -> do + let path = dir "guarded-root-success.tri" + writeFile path "accept = x : guardOk x\nAcceptedString = viewGuarded viewString accept\n\nmain =@AcceptedString \"x\"\n" + output <- checkFile path + output @?= "ok" + + , testCase "tricu check runs source-level guarded argument failure" $ + withSystemTempDirectory "tricu-guarded-argument-failure" $ \dir -> do + let path = dir "guarded-argument-failure.tri" + writeFile path "reject = x : guardFail\nRejectedString = viewGuarded viewString reject\n\nidRejected x@RejectedString =@String \"entered\"\nmain =@String idRejected \"x\"\n" + output <- checkFile path + output @?= "guard failed at typedRequire symbol 6 for Guarded String" + + , testCase "imported VTGuarded lowers to portable viewGuarded" $ do + let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)")) + imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))] + case lowerSourceWithImportedViews imported "main =@String Ext.id \"x\"\n" of + Left err -> assertFailure err + Right lowered -> assertBool "expected imported guarded view to survive lowering" $ "viewGuarded" `isInfixOf` lowered + + , testCase "tricu check runs imported guarded argument failure" $ do + let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)")) + imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))] + output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "main =@String Ext.id \"x\"\n" + output @?= "guard failed at typedRequire symbol 2 for Guarded String" + + , testCase "tricu check rejects malformed local view aliases" $ + withSystemTempDirectory "tricu-malformed-view-alias" $ \dir -> do + let path = dir "bad-alias.tri" + writeFile path "Bad = \"not a view\"\n\nidBad x@Bad =@Bad x\n" + output <- checkFile path + output @?= "malformed view program" + + , testCase "tricu check rejects malformed local view constructors" $ + withSystemTempDirectory "tricu-malformed-view-constructor" $ \dir -> do + let path = dir "bad-constructor.tri" + writeFile path "BadBox a = pair \"not\" a\n\nidBad x@(BadBox String) =@(BadBox String) x\n" + output <- checkFile path + output @?= "malformed view program" + + , testCase "tricu check annotations can apply user-defined view constructors" $ + withSystemTempDirectory "tricu-local-view-constructor" $ \dir -> do + let path = dir "constructor.tri" + writeFile path "Box a = viewPair (viewRef \"Box\") a\n\nidBox x@(Box String) =@(Box String) x\n" + output <- checkFile path + output @?= "ok" + + , testCase "Workspace modules publish resolved custom view aliases" $ + withSystemTempDirectory "tricu-workspace-custom-view-alias" $ \dir -> do + let store = StorePath (dir "store") + utilPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile utilPath "Nat = t 2 [(t 2 10)]\nidNat x@Nat =@Nat x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.idNat 1\n" + _ <- evaluateFileWithStore (Just store) mainPath + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected util module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected util module manifest" + Just manifest -> case find ((== "idNat") . unpack . moduleExportName) (moduleManifestExports manifest) of + Nothing -> assertFailure "expected idNat export" + Just ex -> case moduleExportView ex of + Nothing -> assertFailure "expected idNat view ref" + Just viewRef -> do + view <- getViewType store viewRef + view @?= Right (VTFn [VTRef 10] (VTRef 10)) + + , testCase "Workspace modules publish string custom view aliases" $ + withSystemTempDirectory "tricu-workspace-string-view-alias" $ \dir -> do + let store = StorePath (dir "store") + utilPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile utilPath "Nat = t 2 [(t 2 \"Nat\")]\nidNat x@Nat =@Nat x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.idNat 1\n" + _ <- evaluateFileWithStore (Just store) mainPath + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected util module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected util module manifest" + Just manifest -> case find ((== "idNat") . unpack . moduleExportName) (moduleManifestExports manifest) of + Nothing -> assertFailure "expected idNat export" + Just ex -> case moduleExportView ex of + Nothing -> assertFailure "expected idNat view ref" + Just viewRef -> do + view <- getViewType store viewRef + view @?= Right (VTFn [VTRefText "Nat"] (VTRefText "Nat")) + + , testCase "Workspace modules publish guarded custom view aliases" $ + withSystemTempDirectory "tricu-workspace-guarded-view-alias" $ \dir -> do + let store = StorePath (dir "store") + utilPath = dir "util.tri" + mainPath = dir "main.tri" + guardTerm = result (evalTricu viewTestEnv (parseTricu "(x : t 30 [(t 0 x)])")) + expectedView = VTFn [VTGuarded (VTRefText "UserId") guardTerm] (VTGuarded (VTRefText "UserId") guardTerm) + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile utilPath "UserId = t 7 [(t 8 (t 2 [(t 2 \"UserId\")])) (t 9 (x : t 30 [(t 0 x)]))]\nidUser x@UserId =@UserId x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.idUser 1\n" + _ <- evaluateFileWithStore (Just store) mainPath + mAlias <- readAlias store ModuleAlias "util" + case mAlias of + Nothing -> assertFailure "expected util module alias" + Just ref -> do + mManifest <- getManifest store (objectRefHash ref) + case mManifest of + Nothing -> assertFailure "expected util module manifest" + Just manifest -> case find ((== "idUser") . unpack . moduleExportName) (moduleManifestExports manifest) of + Nothing -> assertFailure "expected idUser export" + Just ex -> do + objectRefKind (moduleExportObject ex) @?= viewTreeKind + moduleExportAbi ex @?= "arboricx.abi.view-tree.v1" + loadedTree <- getViewTree store (moduleExportObject ex) + case moduleExportView ex of + Nothing -> assertFailure "expected idUser view ref" + Just viewRef -> do + objectRefKind viewRef @?= viewContractTypeKind + view <- getViewType store viewRef + view @?= Right expectedView + case loadedTree of + Left err -> assertFailure err + Right tree -> do + rootTerm <- either assertFailure pure (viewTreeRootTerm tree) + tree @?= singletonViewTree (Just expectedView) rootTerm + + , testCase "Workspace modules reject malformed custom view aliases" $ + withSystemTempDirectory "tricu-workspace-malformed-view-alias" $ \dir -> do + let store = StorePath (dir "store") + utilPath = dir "util.tri" + mainPath = dir "main.tri" + writeFile (dir "tricu.workspace") "module util = util.tri\n" + writeFile utilPath "Bad = \"not a view\"\nidBad x@Bad =@Bad x\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.idBad 1\n" + outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env) + case outcome of + Right _ -> assertFailure "expected malformed custom view alias rejection" + Left err -> show err `containsAll` + [ "Workspace module" + , "util" + , "failed View Contract check" + , "malformed view program" + ] + readAlias store ModuleAlias "util" >>= (@?= Nothing) + + , testCase "tricu check catches undersaturated annotated function calls via residual Fn view" $ do + output <- checkSourceWithEnv allTestLibsEnv "f x@String y@String =@String x\nmain =@String f \"a\"\n" + output @?= "symbol 5 (f application result) expected String but got Fn [String] String" + + , testCase "tricu check catches oversaturated annotated function calls via non-Fn result" $ do + output <- checkSourceWithEnv allTestLibsEnv "f x@String y@String =@String x\nmain =@String f \"a\" \"b\" \"c\"\n" + output @?= "symbol 9 (f application result) expected String but got Any" + + , testCase "tricu check source syntax demo includes callee-aware diagnostic" $ do + output <- checkSourceWithEnv allTestLibsEnv "xs =@(List String) [(g \"hi\")]\ng y@String =@Bool y\n" + output @?= "symbol 3 (g application result) expected String but got Bool" + ] + -- -------------------------------------------------------------------------- -- IO driver tests -- -------------------------------------------------------------------------- @@ -2197,7 +3286,62 @@ binaryParserTests = testGroup "Binary Parser Tests" ioDriverTests :: TestTree ioDriverTests = testGroup "IO driver tests" [ -- Existing behaviour tests - testCase "readFile through onReadFile returns file contents" $ + testCase "View Contract checked-exec can produce an IO interaction tree" $ do + final <- runIOSource $ + unlines + [ "Any = viewAny" + , "ioSentinel? = (value : and? (equal? (fst value) \"tricuIO\") (equal? (fst (snd value)) 1))" + , "requireIO = (value : lazyBool (_ : guardOk value) (_ : guardFail) (ioSentinel? value))" + , "viewIO = viewGuarded Any requireIO" + , "checkedIO = (action : matchResult (diag env : io (pure (renderDiagnostic diag))) (exec env : matchResult (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag))) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewIO action)])))" + , "main = checkedIO (io (pure \"checked hello\"))" + ] + final @?= ofString "checked hello" + + , testCase "View Contract IO guard rejects non-interaction-tree root" $ do + final <- runIOSource $ + unlines + [ "Any = viewAny" + , "ioSentinel? = (value : and? (equal? (fst value) \"tricuIO\") (equal? (fst (snd value)) 1))" + , "requireIO = (value : lazyBool (_ : guardOk value) (_ : guardFail) (ioSentinel? value))" + , "viewIO = viewGuarded Any requireIO" + , "checkedIO = (action : matchResult (diag env : io (pure (renderDiagnostic diag))) (exec env : matchResult (runtimeDiag runtimeEnv : io (pure (renderDiagnostic runtimeDiag))) (value runtimeEnv : value) (runChecked exec)) (checkTypedProgramWith policyStrict (typedProgram 0 [(typedValue 0 viewIO action)])))" + , "main = checkedIO \"not io\"" + ] + final @?= ofString "guard failed at root typedValue symbol 0 for Guarded Any" + + , testCase "source sugar enforces pure View Contracts inside IO continuations" $ do + final <- runIOSource $ + unlines + [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))" + , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty" + , "acceptNames xs@(NonEmptyList String) =@String \"accepted\"" + , "main = io (bind (pure []) (xs : pure (acceptNames xs)))" + ] + final @?= ofString "guard failed at argument 0 of application symbol 2 (callee symbol 0, arg symbol 1) for Guarded List String" + + , testCase "source sugar enforces nested pure View Contracts inside IO continuations" $ do + final <- runIOSource $ + unlines + [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))" + , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty" + , "acceptNames xs@(NonEmptyList String) =@String \"accepted\"" + , "main = io (bind (pure []) (xs : pure (append (acceptNames xs) \"!\")))" + ] + final @?= ofString "guard failed at typedValue symbol 2 for Guarded List String" + + , testCase "source sugar enforces higher-order View Contracts inside IO continuations" $ do + final <- runIOSource $ + unlines + [ "requireNonEmpty = (xs : lazyBool (_ : guardFail) (_ : guardOk xs) (emptyList? xs))" + , "NonEmptyList elem = viewGuarded (viewList elem) requireNonEmpty" + , "acceptNames xs@(NonEmptyList String) =@String \"accepted\"" + , "useHandler handler@(Fn [(NonEmptyList String)] String) xs@(List String) =@String handler xs" + , "main = io (bind (pure []) (xs : pure (useHandler acceptNames xs)))" + ] + final @?= ofString "guard failed at typedRequire symbol 1 for Guarded List String" + + , testCase "readFile through onReadFile returns file contents" $ withSystemTempDirectory "tricu-io-read" $ \dir -> do let sourcePath = dir ++ "/input.txt" writeFile sourcePath "abc123" @@ -3306,93 +4450,79 @@ httpParsingTests = testGroup "HTTP Parsing Tests" [ -- chomp / request-line reader testCase "chomp strips trailing CR" $ do - lib <- evaluateFile "./lib/http.tri" let input = "chomp [(104) (105) (13)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [104, 105] , testCase "chomp leaves line without CR" $ do - lib <- evaluateFile "./lib/http.tri" let input = "chomp [(104) (105)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [104, 105] , testCase "chomp empty list" $ do - lib <- evaluateFile "./lib/http.tri" let input = "chomp []" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= bytesT [] , testCase "readLineBytes with CRLF" $ do - lib <- evaluateFile "./lib/http.tri" let input = "readLineBytes [(104) (105) (13) (10) (120)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT [104, 105]) (bytesT [120]) , testCase "readLineBytes with bare LF" $ do - lib <- evaluateFile "./lib/http.tri" let input = "readLineBytes [(104) (105) (10) (120)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT [104, 105]) (bytesT [120]) , testCase "readLineBytes empty line" $ do - lib <- evaluateFile "./lib/http.tri" let input = "readLineBytes [(13) (10) (120)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT []) (bytesT [120]) , testCase "readLineBytes EOF mid-line returns line" $ do - lib <- evaluateFile "./lib/http.tri" let input = "readLineBytes [(104) (105)]" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= pairT (bytesT [104, 105]) (bytesT []) -- parseRequestLine , testCase "parseRequestLine GET slash" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1"))) (ofString "x") , testCase "parseRequestLine POST path" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1"))) (ofString "") , testCase "parseRequestLine too short" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine \"GET\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") , testCase "parseRequestLine no version" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine \"GET /foo\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") , testCase "parseRequestLine empty line" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine \"\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") , testCase "parseRequestLine rejects extra fields" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") -- parseHeaders , testCase "parseHeaders two headers lowercases names" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofList [ pairT (ofString "host") (ofString "localhost") @@ -3401,206 +4531,179 @@ httpParsingTests = testGroup "HTTP Parsing Tests" (ofString "x") , testCase "parseHeaders preserves colon in value" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofList [pairT (ofString "x-custom") (ofString "a: b")]) (ofString "x") , testCase "parseHeaders accepts empty value" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofList [pairT (ofString "x-empty") (ofString "")]) (ofString "x") , testCase "parseHeaders immediate blank" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseHeaders \"\\r\\nx\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (ofList []) (ofString "x") , testCase "parseHeaders rejects missing colon" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseHeaders \"Host\\r\\n\\r\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") , testCase "parseContentLengthValue accepts max body bytes" $ do - lib <- evaluateFile "./lib/http.tri" let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "ok" , testCase "parseContentLengthValue accepts shorter decimal below max" $ do - lib <- evaluateFile "./lib/http.tri" let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "ok" , testCase "parseContentLengthValue strips leading zeros before limit check" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseContentLengthValue \"0000000000001\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserOk (justT (ofNumber 1)) Leaf , testCase "parseContentLengthValue rejects body above max" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseContentLengthValue \"1048577\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n") , testCase "parseContentLengthValue rejects longer body above max" $ do - lib <- evaluateFile "./lib/http.tri" let input = "parseContentLengthValue \"2000000\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n") -- statusLine / headerLine , testCase "statusLine 200 OK" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusLine 200 \"OK\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 200 OK\r\n" , testCase "headerLine Content-Length" $ do - lib <- evaluateFile "./lib/http.tri" let input = "headerLine \"Content-Length\" \"42\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Content-Length: 42\r\n" -- statusPhrase , testCase "statusPhrase 200" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 200" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "OK" , testCase "statusPhrase 201" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 201" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Created" , testCase "statusPhrase 204" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 204" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "No Content" , testCase "statusPhrase 400" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 400" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Bad Request" , testCase "statusPhrase 404" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 404" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Not Found" , testCase "statusPhrase 405" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 405" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Method Not Allowed" , testCase "statusPhrase 431" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 431" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Request Header Fields Too Large" , testCase "statusPhrase 501" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 501" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Not Implemented" , testCase "statusPhrase 505" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 505" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP Version Not Supported" , testCase "statusPhrase 500" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 500" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Internal Server Error" , testCase "statusPhrase unknown" $ do - lib <- evaluateFile "./lib/http.tri" let input = "statusPhrase 999" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "Internal Server Error" -- buildResponse , testCase "buildResponse 200 no headers" $ do - lib <- evaluateFile "./lib/http.tri" let input = "buildResponse 200 [] \"hi\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi" , testCase "buildResponse 404 with header" $ do - lib <- evaluateFile "./lib/http.tri" let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found" -- convenience responses , testCase "okResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "okResponse \"hi\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi" , testCase "notFoundResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "notFoundResponse" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 10\r\nConnection: close\r\n\r\nNot found\n" , testCase "textResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "textResponse \"hi\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi" , testCase "jsonResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "jsonResponse \"{}\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}" , testCase "createdResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "createdResponse \"created\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 201 Created\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 8\r\nConnection: close\r\n\r\ncreated\n" , testCase "emptyResponse 204" $ do - lib <- evaluateFile "./lib/http.tri" let input = "emptyResponse 204" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n" , testCase "badRequestResponse" $ do - lib <- evaluateFile "./lib/http.tri" let input = "badRequestResponse \"Bad Request\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 12\r\nConnection: close\r\n\r\nBad Request\n" , testCase "errorResponse 405" $ do - lib <- evaluateFile "./lib/http.tri" let input = "errorResponse 405 \"Method Not Allowed\\n\"" - env = evalTricu lib (parseTricu input) + env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "HTTP/1.1 405 Method Not Allowed\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 19\r\nConnection: close\r\n\r\nMethod Not Allowed\n" ] +containsAll :: String -> [String] -> Assertion +containsAll text needles = + forM_ needles $ \needle -> + assertBool ("expected " ++ show needle ++ " in: " ++ text) (needle `isInfixOf` text) + withFreePort :: (Int -> IO a) -> IO a withFreePort action = bracket @@ -3614,10 +4717,10 @@ withFreePort action = runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T) runIOSourceWith perms readerEnv initialState source = do - ioEnv <- evaluateFile "./lib/io.tri" - sockEnv <- evaluateFile "./lib/socket.tri" - let combinedEnv = Map.union sockEnv ioEnv - evalEnv <- evalTricuWithStore Nothing combinedEnv (parseTricu source) + checkedAst <- case instrumentIOContinuations (parseTricu source) of + Left err -> assertFailure err + Right asts -> pure asts + let evalEnv = evalTricu allTestLibsEnv checkedAst let fullTree = mainResult evalEnv result <- runIOWith perms readerEnv initialState fullTree case result of diff --git a/test/cycle-1.tri b/test/cycle-1.tri deleted file mode 100644 index 40d9fa2..0000000 --- a/test/cycle-1.tri +++ /dev/null @@ -1,4 +0,0 @@ - -!import "cycle-2.tri" Cycle2 - -cycle1 = t Cycle2.cycle2 diff --git a/test/cycle-2.tri b/test/cycle-2.tri deleted file mode 100644 index 5336f1e..0000000 --- a/test/cycle-2.tri +++ /dev/null @@ -1,4 +0,0 @@ - -!import "cycle-1.tri" Cycle1 - -cycle2 = t Cycle1.cycle1 diff --git a/test/lambda-A.tri b/test/lambda-A.tri deleted file mode 100644 index 24a68a2..0000000 --- a/test/lambda-A.tri +++ /dev/null @@ -1 +0,0 @@ -main = (x : x) t diff --git a/test/local-ns/1.tri b/test/local-ns/1.tri deleted file mode 100644 index e461a5e..0000000 --- a/test/local-ns/1.tri +++ /dev/null @@ -1,4 +0,0 @@ - -!import "2.tri" Two - -main = Two.x diff --git a/test/local-ns/2.tri b/test/local-ns/2.tri deleted file mode 100644 index 729429b..0000000 --- a/test/local-ns/2.tri +++ /dev/null @@ -1,2 +0,0 @@ - -!import "3.tri" !Local diff --git a/test/local-ns/3.tri b/test/local-ns/3.tri deleted file mode 100644 index b95c23a..0000000 --- a/test/local-ns/3.tri +++ /dev/null @@ -1 +0,0 @@ -x = 3 diff --git a/test/multi-level-A.tri b/test/multi-level-A.tri deleted file mode 100644 index 3553c2c..0000000 --- a/test/multi-level-A.tri +++ /dev/null @@ -1,2 +0,0 @@ -!import "multi-level-B.tri" B -main = B.main diff --git a/test/multi-level-B.tri b/test/multi-level-B.tri deleted file mode 100644 index 115d591..0000000 --- a/test/multi-level-B.tri +++ /dev/null @@ -1,2 +0,0 @@ -!import "multi-level-C.tri" C -main = C.val diff --git a/test/multi-level-C.tri b/test/multi-level-C.tri deleted file mode 100644 index cc31fa8..0000000 --- a/test/multi-level-C.tri +++ /dev/null @@ -1 +0,0 @@ -val = t diff --git a/test/named-imports/1.tri b/test/named-imports/1.tri deleted file mode 100644 index 8fe9296..0000000 --- a/test/named-imports/1.tri +++ /dev/null @@ -1,7 +0,0 @@ - -!import "lib/base.tri" - -!import "test/named-imports/2.tri" -!import "test/named-imports/3.tri" ThreeRenamed - -main = equal? (equal? Two.x 2) (equal? ThreeRenamed.x 3) diff --git a/test/named-imports/2.tri b/test/named-imports/2.tri deleted file mode 100644 index 76ef185..0000000 --- a/test/named-imports/2.tri +++ /dev/null @@ -1,2 +0,0 @@ - -x = 2 diff --git a/test/named-imports/3.tri b/test/named-imports/3.tri deleted file mode 100644 index 6d16539..0000000 --- a/test/named-imports/3.tri +++ /dev/null @@ -1,2 +0,0 @@ - -x = 3 diff --git a/test/namespace-A.tri b/test/namespace-A.tri deleted file mode 100644 index 5d24219..0000000 --- a/test/namespace-A.tri +++ /dev/null @@ -1,2 +0,0 @@ -!import "namespace-B.tri" B -main = B.x diff --git a/test/namespace-B.tri b/test/namespace-B.tri deleted file mode 100644 index 38887fd..0000000 --- a/test/namespace-B.tri +++ /dev/null @@ -1 +0,0 @@ -x = t diff --git a/test/vars-A.tri b/test/vars-A.tri deleted file mode 100644 index 1f38f8d..0000000 --- a/test/vars-A.tri +++ /dev/null @@ -1,6 +0,0 @@ - -!import "vars-B.tri" B - -!import "vars-C.tri" C - -main = B.y (C.z) diff --git a/test/vars-B.tri b/test/vars-B.tri deleted file mode 100644 index 44bcb7b..0000000 --- a/test/vars-B.tri +++ /dev/null @@ -1 +0,0 @@ -y = x : x diff --git a/test/vars-C.tri b/test/vars-C.tri deleted file mode 100644 index 91c0288..0000000 --- a/test/vars-C.tri +++ /dev/null @@ -1 +0,0 @@ -z = t diff --git a/tricu.cabal b/tricu.cabal index ef8043e..0644862 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: tricu -version: 1.1.0 +version: 2.0.0 description: A language for exploring Tree Calculus author: James Eversole maintainer: james@eversole.co @@ -11,6 +11,7 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md + tricu.workspace executable tricu main-is: Main.hs @@ -52,7 +53,6 @@ executable tricu , memory , mtl , network - , sqlite-simple , stm , tasty , tasty-hunit @@ -62,11 +62,25 @@ executable tricu , vector , zlib other-modules: + Check + Check.Core + Check.IO ContentStore + ContentStore.Alias + ContentStore.Arboricx + ContentStore.Bundle + ContentStore.Filesystem + ContentStore.Object + ContentStore.Resolver + ContentStore.ViewTree + ContentStore.ViewContract Eval FileEval IODriver Lexer + Module.Manifest + Module.Resolver + Module.Workspace Parser Paths_tricu REPL @@ -99,7 +113,6 @@ benchmark tricu-bench , memory , mtl , network - , sqlite-simple , text , time , transformers @@ -109,10 +122,21 @@ benchmark tricu-bench other-modules: ApplyStats ContentStore + ContentStore.Alias + ContentStore.Arboricx + ContentStore.Bundle + ContentStore.Filesystem + ContentStore.Object + ContentStore.Resolver + ContentStore.ViewTree + ContentStore.ViewContract Eval FileEval IODriver Lexer + Module.Manifest + Module.Resolver + Module.Workspace Parser Paths_tricu Research @@ -145,7 +169,6 @@ test-suite tricu-tests , memory , mtl , network - , sqlite-simple , stm , tasty , tasty-hunit @@ -158,11 +181,25 @@ test-suite tricu-tests , zlib default-language: Haskell2010 other-modules: + Check + Check.Core + Check.IO ContentStore + ContentStore.Alias + ContentStore.Arboricx + ContentStore.Bundle + ContentStore.Filesystem + ContentStore.Object + ContentStore.Resolver + ContentStore.ViewTree + ContentStore.ViewContract Eval FileEval IODriver Lexer + Module.Manifest + Module.Resolver + Module.Workspace Parser Paths_tricu REPL diff --git a/tricu.workspace b/tricu.workspace new file mode 100644 index 0000000..7f22bad --- /dev/null +++ b/tricu.workspace @@ -0,0 +1,20 @@ +# tricu workspace module source map +module base = lib/base.tri +module list = lib/list.tri +module bytes = lib/bytes.tri +module conversions = lib/conversions.tri +module lazy = lib/lazy.tri +module prelude = lib/prelude.tri +module binary = lib/binary.tri +module patterns = lib/patterns.tri +module io = lib/io.tri +module socket = lib/socket.tri +module http = lib/http.tri +module view = lib/view.tri +module views.catalog = lib/views/catalog.tri +module arboricx.common = lib/arboricx/common.tri +module arboricx.nodes = lib/arboricx/nodes.tri +module arboricx.manifest = lib/arboricx/manifest.tri +module arboricx = lib/arboricx/arboricx.tri +module arboricx.dispatch = lib/arboricx/dispatch.tri +module arboricx.server = lib/arboricx/server.tri