From d9a69513d7408ef7590ba1b6aada941e2fcc8b35 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 31 Aug 2026 15:24:19 -0500 Subject: [PATCH] Begin removing view related code and docs --- AGENTS.md | 20 + README.md | 23 +- bench/Bench.hs | 147 +- demos/contractBasics.tri | 43 + demos/contractEffects.tri | 66 + demos/viewContracts.tri | 190 -- demos/viewContracts/README.md | 137 -- demos/viewContracts/complete.tri | 119 -- demos/viewContracts/diagnostic.tri | 9 - .../viewContracts/frontendEmission/README.md | 116 -- .../filter-wrong-predicate.emitted.tri | 17 - .../frontendEmission/map-success.emitted.tri | 20 - .../map-wrong-list.emitted.tri | 19 - demos/viewContracts/io-continuation.tri | 30 - demos/viewContracts/io.tri | 51 - demos/viewContracts/modules/README.md | 17 - demos/viewContracts/modules/failure.tri | 3 - demos/viewContracts/modules/success.tri | 3 - demos/viewContracts/modules/tricu.workspace | 1 - demos/viewContracts/modules/util.tri | 2 - demos/viewContracts/selfTests.tri | 3 - demos/viewContracts/sourceSyntax/failure.tri | 9 - demos/viewContracts/sourceSyntax/success.tri | 10 - demos/viewContracts/stdlibContracts.tri | 10 - docs/content-store-and-module-format.md | 147 +- docs/contracts.md | 326 ++++ docs/guard-injection.md | 371 ---- docs/module-system-design.md | 115 +- docs/view-contract-syntax.md | 582 ------ docs/view-contracts.md | 384 ---- lib/base.tri | 98 +- lib/contracts.tri | 240 +++ lib/guardedBase.tri | 24 + lib/intensionalContracts.tri | 55 + lib/lazy.tri | 30 - lib/list.tri | 131 +- lib/prelude.tri | 1 - lib/view.tri | 1656 ----------------- lib/views/catalog.tri | 267 --- notes/view-contract-trust-provenance.md | 95 - src/Check.hs | 42 - src/Check/Core.hs | 846 --------- src/Check/IO.hs | 422 ----- src/ContentStore.hs | 4 - src/ContentStore/ViewContract.hs | 265 --- src/ContentStore/ViewTree.hs | 192 -- src/Eval.hs | 30 +- src/FileEval.hs | 154 +- src/Frontend/ContractDesugar.hs | 84 + src/Lexer.hs | 4 + src/Main.hs | 57 +- src/Module/Manifest.hs | 64 +- src/Module/Resolver.hs | 28 +- src/Parser.hs | 16 +- src/REPL.hs | 63 +- src/Research.hs | 40 +- test/Spec.hs | 1519 +++++---------- tricu.cabal | 16 +- tricu.workspace | 6 +- 59 files changed, 1739 insertions(+), 7700 deletions(-) create mode 100644 demos/contractBasics.tri create mode 100644 demos/contractEffects.tri delete mode 100644 demos/viewContracts.tri delete mode 100644 demos/viewContracts/README.md delete mode 100644 demos/viewContracts/complete.tri delete mode 100644 demos/viewContracts/diagnostic.tri delete mode 100644 demos/viewContracts/frontendEmission/README.md delete mode 100644 demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri delete mode 100644 demos/viewContracts/frontendEmission/map-success.emitted.tri delete mode 100644 demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri delete mode 100644 demos/viewContracts/io-continuation.tri delete mode 100644 demos/viewContracts/io.tri delete mode 100644 demos/viewContracts/modules/README.md delete mode 100644 demos/viewContracts/modules/failure.tri delete mode 100644 demos/viewContracts/modules/success.tri delete mode 100644 demos/viewContracts/modules/tricu.workspace delete mode 100644 demos/viewContracts/modules/util.tri delete mode 100644 demos/viewContracts/selfTests.tri delete mode 100644 demos/viewContracts/sourceSyntax/failure.tri delete mode 100644 demos/viewContracts/sourceSyntax/success.tri delete mode 100644 demos/viewContracts/stdlibContracts.tri create mode 100644 docs/contracts.md delete mode 100644 docs/guard-injection.md delete mode 100644 docs/view-contract-syntax.md delete mode 100644 docs/view-contracts.md create mode 100644 lib/contracts.tri create mode 100644 lib/guardedBase.tri create mode 100644 lib/intensionalContracts.tri delete mode 100644 lib/lazy.tri delete mode 100644 lib/view.tri delete mode 100644 lib/views/catalog.tri delete mode 100644 notes/view-contract-trust-provenance.md delete mode 100644 src/Check.hs delete mode 100644 src/Check/Core.hs delete mode 100644 src/Check/IO.hs delete mode 100644 src/ContentStore/ViewContract.hs delete mode 100644 src/ContentStore/ViewTree.hs create mode 100644 src/Frontend/ContractDesugar.hs diff --git a/AGENTS.md b/AGENTS.md index cf47efe..d7eb73d 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -16,6 +16,26 @@ nix build .# > **Rule of thumb:** if it builds, links, or tests, it goes through `nix`. +### Write and test, don't mentally trace + +`nix flake check` finishes quickly. Use it. + +tricu's minimalism makes it easy to build a confident-sounding but wrong +mental model of evaluation order, branch selection (`matchBool` arg order), +or number encoding. A quick test replaces many minutes of uncertain reasoning. + +Prefer: + +1. Write a candidate implementation. +2. Run the tests or a probe. +3. Fix what's wrong. + +Over: + +1. Reason about semantics across multiple files. +2. Build up a chain of inference. +3. Write code that assumes the chain was correct. + ## Project Overview **tricu** (pronounced "tree-shoe") is a programming-language experiment written primarily in Haskell. diff --git a/README.md b/README.md index f34e84b..592305d 100644 --- a/README.md +++ b/README.md @@ -62,20 +62,8 @@ tricu eval --format decode program.tri tricu eval --output result.txt 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. - -```sh -tricu eval --unchecked program.tri -``` - -Check View Contract annotations explicitly: - -```sh -tricu check program.tri -tricu check --store ./.tricu-store program.tri -``` +Annotations are parsed but currently ignored at runtime; the contract layer +is not yet wired into evaluation or workspace module auto-builds. Compile/import/export Arboricx bundles: @@ -101,13 +89,10 @@ 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. +`!load` supports filename tab completion. Normal REPL input also supports tab +completion for names currently in the REPL environment. diff --git a/bench/Bench.hs b/bench/Bench.hs index 8a978ea..0aac87b 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -2,124 +2,63 @@ module Main where import Criterion.Main -import qualified Data.ByteString as BS import qualified Data.Map as Map -import ApplyStats (runApplyCounted, runApplyGlobalCounted, printApplyStats) import Eval import FileEval import Parser import Research --- | Pre-process a demo file and return its AST. -loadDemo :: FilePath -> IO [TricuAST] -loadDemo = preprocessFile - --- | Evaluate a pre-processed demo to its result term. -runDemo :: [TricuAST] -> T -runDemo ast = result (evalTricu Map.empty ast) - -- | Build an environment from a library file. loadLib :: FilePath -> IO Env loadLib = evaluateFile main :: IO () main = do - !equalityAst <- loadDemo "demos/equality.tri" - !sizeAst <- loadDemo "demos/size.tri" - !toSourceAst <- loadDemo "demos/toSource.tri" - !levelOrderAst <- loadDemo "demos/levelOrderTraversal.tri" - !patternAst <- loadDemo "demos/patternMatching.tri" - !listLib <- loadLib "lib/list.tri" - - -- Stress benchmark environment: Arboricx parser + size + toSource - !arboricxLib <- loadLib "lib/arboricx/dispatch.tri" - !sizeEnv <- evaluateFileWithContext arboricxLib "demos/size.tri" - !toSourceEnv <- evaluateFileWithContext sizeEnv "demos/toSource.tri" - - -- Print apply stats for toSource not? - let Just toSource = Map.lookup "toSource" toSourceEnv - Just notTerm = Map.lookup "not?" toSourceEnv - (_result, stats) = runApplyCounted toSource notTerm - printApplyStats stats - - -- Print apply stats for readArboricxContainer against id.arboricx - !idBundleBytes <- BS.readFile "test/fixtures/id.arboricx" - let Just readContainer = Map.lookup "readArboricxContainer" sizeEnv - bundleTree = ofBytes idBundleBytes - (_result2, stats2) <- runApplyGlobalCounted 100000 1000000 readContainer bundleTree - printApplyStats stats2 + !baseLib <- loadLib "lib/base.tri" + !listLib <- loadLib "lib/list.tri" + !contractsLib <- loadLib "lib/contracts.tri" + !intLib <- loadLib "lib/intensionalContracts.tri" + !guardedLib <- loadLib "lib/guardedBase.tri" + let !env = Map.unions [baseLib, listLib, contractsLib, intLib, guardedLib] defaultMain - [ bgroup "demos" - [ bench "equality" $ whnf runDemo equalityAst - , bench "size" $ whnf runDemo sizeAst - , bench "toSource" $ whnf runDemo toSourceAst - , bench "levelOrderTraversal" $ whnf runDemo levelOrderAst - , bench "patternMatching" $ whnf runDemo patternAst + [ bgroup "contracts" + [ bench "raw head" $ whnf + (result . evalTricu env . parseTricu) + "head [1 2 3 4 5]" + , bench "safeHead (checked)" $ whnf + (result . evalTricu env . parseTricu) + "safeHead [1 2 3 4 5]" + , bench "raw div" $ whnf + (result . evalTricu env . parseTricu) + "div 10 2" + , bench "safeDiv (checked)" $ whnf + (result . evalTricu env . parseTricu) + "safeDiv 10 2" + , bench "safeDiv failure (div by zero)" $ whnf + (result . evalTricu env . parseTricu) + "safeDiv 10 0" + , bench "sortedMax on sorted list" $ whnf + (result . evalTricu env . parseTricu) + "sortedMax [1 2 3 4 5]" + , bench "safeHalf (even check)" $ whnf + (result . evalTricu env . parseTricu) + "safeHalf 8" + , bench "sortedList? success" $ whnf + (result . evalTricu env . parseTricu) + "withContract (sortedList? nat?) [1 2 3 4 5] (xs : sum xs) (msg : 0)" + , bench "sortedList? failure" $ whnf + (result . evalTricu env . parseTricu) + "withContract (sortedList? nat?) [5 1 3] (xs : sum xs) (msg : 0)" + , bench "listOf nat? success" $ whnf + (result . evalTricu env . parseTricu) + "withContract (listOf nat?) [1 2 3 4 5] (xs : sum xs) (msg : 0)" + , bench "fn2 apply add" $ whnf + (result . evalTricu env . parseTricu) + "(fn2 nat? nat? nat? add) 3 5" + , bench "fnContract apply identity" $ whnf + (result . evalTricu env . parseTricu) + "(fnContract nat? nat? (x : x)) 7" ] - - , bgroup "lib/list.tri" - [ bench "append strings" $ whnf - (result . evalTricu listLib . parseTricu) - "append \"Hello, \" \"world!\"" - , bench "map over 3 elements" $ whnf - (result . evalTricu listLib . parseTricu) - "head (tail (map (a : (t t t)) [(t) (t) (t)]))" - , bench "equal? same" $ whnf - (result . evalTricu listLib . parseTricu) - "equal? (t t t) (t t t)" - , bench "equal? different" $ whnf - (result . evalTricu listLib . parseTricu) - "equal? (t t) (t t t)" - , bench "triage Leaf" $ whnf - (result . evalTricu listLib . parseTricu) - "test t" - , bench "triage Stem" $ whnf - (result . evalTricu listLib . parseTricu) - "test (t t)" - , bench "triage Fork" $ whnf - (result . evalTricu listLib . parseTricu) - "test (t t t)" - , bench "not? true" $ whnf - (result . evalTricu listLib . parseTricu) - "not? (t t)" - , bench "not? false" $ whnf - (result . evalTricu listLib . parseTricu) - "not? t" - ] - - , bgroup "stress" - [ bench "size runArboricxTyped" $ whnf - (result . evalTricu sizeEnv . parseTricu) - "size runArboricxTyped" - , bench "equal? runArboricxTyped runArboricxTyped" $ whnf - (result . evalTricu sizeEnv . parseTricu) - "equal? runArboricxTyped runArboricxTyped" - , bench "size readArboricxBundle" $ whnf - (result . evalTricu sizeEnv . parseTricu) - "size readArboricxBundle" - , bench "equal? readArboricxBundle readArboricxBundle" $ whnf - (result . evalTricu sizeEnv . parseTricu) - "equal? readArboricxBundle readArboricxBundle" - ] - - , bgroup "raw-apply" - [ bench "rule-1 (Fork Leaf a) b" $ whnf - (\n -> apply (Fork Leaf (ofNumber n)) (ofNumber 42)) - 1000 - , bench "rule-2 (Fork (Stem a) b) c" $ whnf - (\n -> apply (Fork (Stem (ofNumber n)) (ofNumber n)) (ofNumber 42)) - 1000 - , bench "rule-3a (Fork (Fork a b) c) Leaf" $ whnf - (\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) Leaf) - 1000 - , bench "rule-3b (Fork (Fork a b) c) (Stem u)" $ whnf - (\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) (Stem Leaf)) - 1000 - , bench "rule-3c (Fork (Fork a b) c) (Fork u v)" $ whnf - (\n -> apply (Fork (Fork (ofNumber n) (ofNumber n)) (ofNumber n)) (Fork Leaf Leaf)) - 1000 - ] - ] diff --git a/demos/contractBasics.tri b/demos/contractBasics.tri new file mode 100644 index 0000000..893e9bb --- /dev/null +++ b/demos/contractBasics.tri @@ -0,0 +1,43 @@ +!import "base" !Local +!import "list" !Local +!import "contracts" !Local + +-- A custom 'and' combinator written directly against base.matchResult. +-- It succeeds only when *both* contracts succeed, threading the checked value +-- from the first into the second. This makes the Result pair structure explicit. +myAndC = (c1 c2 value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : c2 v rest) + (c1 value rest)) + +-- Plain predicates lifted into contracts with a diagnostic message. +natural? = guardC "natural" (n : gte? n 0) +nonZero? = guardC "non-zero" (n : not? (isZero? n)) + +-- Safe wrappers around partial base / list functions. +-- The frontend desugars @ and =@ into runtime withContract applications. +safeDiv a@natural? b@(myAndC natural? nonZero?) =@natural? div a b + +safeHead xs@(nonEmptyListOf anyC) =@anyC head xs +safeTail xs@(nonEmptyListOf anyC) =@(listOf anyC) tail xs + +-- A higher-order wrapper: the supplied function must satisfy a contract, +-- the input list must satisfy a contract, and the result list is guaranteed. +checkedMap f@(fnContract anyC natural?) xs@(listOf anyC) =@(listOf natural?) map f xs + +-- Advertise the safe wrappers in the module manifest with their own contracts. +!export safeDiv : fn2 natural? nonZero? natural? +!export safeHead : fnContract (nonEmptyListOf anyC) anyC +!export checkedMap : fn2 (fnContract anyC natural?) (listOf anyC) (listOf natural?) + +-- A small interaction-tree pipeline that uses contracts as recoverable effects. +pipeline = (input : + do bindM + scaled <- checkM natural? (mul input 2) + half <- handleM "contract" + (_ : pureM 1) + (checkM nonZero? (sub scaled 4)) + pureM (div scaled half)) + +main = runM (pipeline 5) diff --git a/demos/contractEffects.tri b/demos/contractEffects.tri new file mode 100644 index 0000000..ecd2b8a --- /dev/null +++ b/demos/contractEffects.tri @@ -0,0 +1,66 @@ +!import "base" !Local +!import "list" !Local +!import "contracts" !Local + +-- --------------------------------------------------------------------------- +-- Contracts + interaction trees with `do` notation +-- +-- The `do` keyword takes a monadic bind operator. Here we use `bindM` from +-- `lib/contracts.tri` to sequence pure, contract-checked computations. +-- +-- checkM contract value -- lift a contract failure into the tree +-- exceptE tag value k -- a resumable failure carrying a continuation +-- handleM tag handler tree -- rewrite matching exceptions +-- runM tree -- interpret the tree into a Result +-- +-- A handler receives the exception value and the resumption continuation `k`. +-- It may resume by calling `k value`, or it may replace the failing action with +-- a new tree of its own. +-- --------------------------------------------------------------------------- + +positive? = guardC "expected positive integer" (n : gte? n 1) +nonEmpty? = guardC "expected non-empty list" (xs : not? (emptyList? xs)) + +-- Average a list. Fails with a contract exception if the list is empty. +average = (xs : + do bindM + _ <- checkM nonEmpty? xs + n <- pureM (length xs) + _ <- checkM positive? n + total <- pureM (sum xs) + pureM (div total n)) + +-- A resumable config lookup. When the key is missing, callers can supply a +-- value by handling the "missing" exception. +lookupConfig = (key defaultValue : + exceptE "missing" key (resume : pureM defaultValue)) + +-- A pipeline that averages a list and divides by a configured divisor. +pipeline = (xs : + do bindM + divisor <- lookupConfig "divisor" 1 + avg <- average xs + scaled <- liftM (x : div x divisor) avg + pureM scaled) + +-- Without a handler the missing-key exception reaches runM. +unhandled = runM (pipeline [10 20 30]) +-- < unhandled +-- > [t, "divisor"] + +-- With a handler we replace the missing divisor with 2, so 20 / 2 = 10. +withHandler = runM (handleM "missing" (key k : pureM 2) (pipeline [10 20 30])) +-- < withHandler +-- > [t t, 10] + +-- Handler can also use the original default by calling the resumption. +withResume = runM (handleM "missing" (key k : k 2) (pipeline [10 20 30])) +-- < withResume +-- > [t t, 20] + +-- Contract failures still propagate through handlers for other tags. +bothFail = runM (handleM "missing" (key k : pureM 2) (pipeline [])) +-- < bothFail +-- > [t, "expected non-empty list"] + +main = withHandler diff --git a/demos/viewContracts.tri b/demos/viewContracts.tri deleted file mode 100644 index 141002c..0000000 --- a/demos/viewContracts.tri +++ /dev/null @@ -1,190 +0,0 @@ -!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 deleted file mode 100644 index 8045465..0000000 --- a/demos/viewContracts/README.md +++ /dev/null @@ -1,137 +0,0 @@ -# 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 deleted file mode 100644 index f5e9bda..0000000 --- a/demos/viewContracts/complete.tri +++ /dev/null @@ -1,119 +0,0 @@ -!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 deleted file mode 100644 index b0c27e1..0000000 --- a/demos/viewContracts/diagnostic.tri +++ /dev/null @@ -1,9 +0,0 @@ -!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 deleted file mode 100644 index 6494a5d..0000000 --- a/demos/viewContracts/frontendEmission/README.md +++ /dev/null @@ -1,116 +0,0 @@ -# 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 deleted file mode 100644 index 0f8d58f..0000000 --- a/demos/viewContracts/frontendEmission/filter-wrong-predicate.emitted.tri +++ /dev/null @@ -1,17 +0,0 @@ -!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 deleted file mode 100644 index 2341529..0000000 --- a/demos/viewContracts/frontendEmission/map-success.emitted.tri +++ /dev/null @@ -1,20 +0,0 @@ -!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 deleted file mode 100644 index 06aeda4..0000000 --- a/demos/viewContracts/frontendEmission/map-wrong-list.emitted.tri +++ /dev/null @@ -1,19 +0,0 @@ -!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 deleted file mode 100644 index 0437e95..0000000 --- a/demos/viewContracts/io-continuation.tri +++ /dev/null @@ -1,30 +0,0 @@ -!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 deleted file mode 100644 index b453af6..0000000 --- a/demos/viewContracts/io.tri +++ /dev/null @@ -1,51 +0,0 @@ -!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 deleted file mode 100644 index 3e6f203..0000000 --- a/demos/viewContracts/modules/README.md +++ /dev/null @@ -1,17 +0,0 @@ -# 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 deleted file mode 100644 index 5e581fc..0000000 --- a/demos/viewContracts/modules/failure.tri +++ /dev/null @@ -1,3 +0,0 @@ -!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 deleted file mode 100644 index 2bc3809..0000000 --- a/demos/viewContracts/modules/success.tri +++ /dev/null @@ -1,3 +0,0 @@ -!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 deleted file mode 100644 index dc33128..0000000 --- a/demos/viewContracts/modules/tricu.workspace +++ /dev/null @@ -1 +0,0 @@ -module vc.demo.util = util.tri diff --git a/demos/viewContracts/modules/util.tri b/demos/viewContracts/modules/util.tri deleted file mode 100644 index 18e3b9e..0000000 --- a/demos/viewContracts/modules/util.tri +++ /dev/null @@ -1,2 +0,0 @@ -id x@Bool =@Bool x -toString x@Bool =@String "ok" diff --git a/demos/viewContracts/selfTests.tri b/demos/viewContracts/selfTests.tri deleted file mode 100644 index 8d8d7bb..0000000 --- a/demos/viewContracts/selfTests.tri +++ /dev/null @@ -1,3 +0,0 @@ -!import "views.catalog" !Local - -main = viewCatalogSelfTests diff --git a/demos/viewContracts/sourceSyntax/failure.tri b/demos/viewContracts/sourceSyntax/failure.tri deleted file mode 100644 index 64ccf93..0000000 --- a/demos/viewContracts/sourceSyntax/failure.tri +++ /dev/null @@ -1,9 +0,0 @@ --- 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 deleted file mode 100644 index 8493fd5..0000000 --- a/demos/viewContracts/sourceSyntax/success.tri +++ /dev/null @@ -1,10 +0,0 @@ --- 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 deleted file mode 100644 index 1aea06d..0000000 --- a/demos/viewContracts/stdlibContracts.tri +++ /dev/null @@ -1,10 +0,0 @@ -!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 index f004322..82d4b4c 100644 --- a/docs/content-store-and-module-format.md +++ b/docs/content-store-and-module-format.md @@ -17,7 +17,7 @@ This document specifies the first target shape for: - 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. +- Contract artifact attachment to module exports. It does not specify: @@ -37,7 +37,7 @@ 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 +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. @@ -280,7 +280,7 @@ It exists to support: - reproducible import resolution; - executable export discovery; -- View Contract lookup for imported symbols; +- Contract lookup for imported symbols; - module-to-module reference tracking; - transport/store interop. @@ -301,12 +301,9 @@ moduleManifestV1: kind: hash: abi: - view: optional - kind: - hash: - catalog: optional - kind: - hash: + contract: optional + kind: arboricx.tree-term.v1 + hash: metadata: optional human-facing fields ``` @@ -343,7 +340,7 @@ object: abi: arboricx.abi.tree.v1 ``` -Export with View Contract: +Export with Contract: ```text name: "map" @@ -351,15 +348,15 @@ object: kind: arboricx.tree-term.v1 hash: abi: arboricx.abi.tree.v1 -view: - kind: arboricx.view-contract.type.v1 - hash: +contract: + kind: arboricx.tree-term.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. +checking receive direct contract term refs. ### 8.6 Metadata @@ -375,112 +372,68 @@ createdBy Metadata is not source provenance and is not required for execution or checking. -## 9. View Contract Artifacts +## 9. 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. +Contracts are ordinary `tricu` functions `Tree -> Result Tree Tree`. They are +stored and referenced as ordinary `arboricx.tree-term.v1` objects. There is no +separate contract object kind. -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 -``` +A contract object is a complete Tree Calculus term. Any implementation that can +evaluate Tree Calculus terms can apply it. The contract standard defines only the +result convention and the boundary helpers; it does not define a binary contract +grammar. ### 9.1 Export-level pairing -The module manifest is the canonical pairing of an executable export and its -advertised contract: +The module manifest pairs each export with an optional contract object: ```text -export name -> tree-term hash + optional view artifact hash +name: "map" +object: + kind: arboricx.tree-term.v1 + hash: + abi: arboricx.abi.tree.v1 +contract: + kind: arboricx.tree-term.v1 + hash: ``` -This avoids drift such as: - -```text -map -> tree A -map.view -> contract B -``` - -where aliases might be retargeted independently. +This prevents the executable and its advertised contract from drifting apart. ### 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: +When a source file imports a contracted export, the frontend loads the contract +object and applies it at the boundary using the standard contract helpers. For +example: ```text -imported List.map has view Fn [...] +imported List.map has contract ``` -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. +For locally built workspace modules, advertised export contracts may be checked +before the manifest is published. For external or prebuilt manifests, the +advertised contract is a trusted boundary declaration; the consumer may insert +guard wrappers as needed. -Correct split: +The contract term itself is the authority. There is no separate checker binary +format and no typed-program evidence graph. -```text -local checker symbol: 3 -presentation label: "List.map" -resolved object: sha256:... -exported view: Fn [...] -``` +### 9.3 Execution hydration versus contract checking -### 9.3 Execution hydration versus contract evidence - -Execution imports should use a narrow, demand-driven path: +Execution imports use a narrow 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: +Contract-aware imports use a slightly broader path: ```text -module import -> selected exports -> exported view type refs -> typed-program evidence +module import -> selected exports -> exported contract term refs -> apply at boundary ``` -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. +Because contract objects are ordinary tree terms, they can be reused, composed, +and stored with the same tools as any other value. ## 10. Workspace Aliases @@ -528,7 +481,7 @@ This design intentionally preserves existing conventions where they already fit: - 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. +- Contract terms as portable Tree Calculus data. It replaces or demotes conventions that do not fit: @@ -550,7 +503,7 @@ A staged implementation can proceed as follows: 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. +10. Attach exported contract terms to module exports. 11. Gradually migrate existing `!import` users. ## 13. Deferred Decisions @@ -584,13 +537,13 @@ 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 + immutable manifests pairing export names with object refs and optional + contract term refs Workspace: mutable aliases from human names to immutable content hashes ``` This keeps the store portable, preserves Arboricx's compact transport role, -restores Merkle DAGs as the persistence model, and gives View Contracts a stable +restores Merkle DAGs as the persistence model, and gives contracts a stable module/export attachment point without making the store `tricu`-specific. diff --git a/docs/contracts.md b/docs/contracts.md new file mode 100644 index 0000000..40dc435 --- /dev/null +++ b/docs/contracts.md @@ -0,0 +1,326 @@ +# Contracts + +Contracts are the portable runtime boundary-checking layer for `tricu`. A +contract is an ordinary `tricu` function that inspects a value and returns a +standard `Result`. + +Contracts are not a type system. Tree Calculus is intensional: every value is a +tree and can be inspected by any function. A contract can only observe a value +and fail when it does not satisfy the advertised predicate. It cannot hide a +value's representation or prove that an opaque function behaves correctly for +all inputs. + +Static typing for Tree Calculus is an area of active research. This document +describes the dynamic-contract layer that exists today and the guarantees it +can honestly claim. + +## 1. The contract type + +A contract is a function: + +```tri +contract : Tree -> Tree -> Result Tree Tree +``` + +The second argument is the conventional `rest` slot. It takes a value and a rest +and returns one of the standard `Result` shapes from `lib/base.tri`: + +```tri +ok value rest = pair true (pair value rest) +err msg rest = pair false (pair msg rest) +``` + +In contract contexts the `rest` slot is conventionally `t`. Two helpers make +this explicit: + +```tri +contractOk = (value : (rest : ok value rest)) +contractErr = (msg : (rest : err msg rest)) +``` + +- On success, a contract returns the checked value. This may be the original + value or a transformed/normalized value. +- On failure, it returns a reason. The reason is an arbitrary tree, often a + string or a structured diagnostic. + +Because a contract is just a tree-valued function, any Tree Calculus +implementation can apply it. No special contract object format is required. + +## 2. Core boundary wrappers + +### 2.1 Explicit check + +`checkContract` applies a contract with the conventional `t` rest slot and +returns the raw `Result`: + +```tri +checkContract = (contract value : contract value t) +``` + +This is the most flexible form. The caller decides what to do with failure. + +### 2.2 Direct boundary abort + +`withContract` applies a contract with the conventional `t` rest slot and +continues on success, or calls a failure continuation on failure: + +```tri +withContract = (contract value onOk onFail : + matchResult + (msg _ : onFail msg) + (checked _ : onOk checked) + (contract value t)) +``` + +The failure continuation is supplied by the host or by the surrounding program. +It may abort, log, return a default, or raise an effect. The core contract +standard does not prescribe the failure behavior. + +### 2.3 Example: a simple contract + +```tri +isZero? = n : + equal? n 0 + +nat? = guardC "not a natural number" (n : gte? n 0) + +-- explicit check +result = checkContract nat? 5 + +-- boundary abort +five = withContract nat? 5 (x : x) (msg : 0) +``` + +Real contract predicates are usually more interesting than `isZero?`; this +illustrates only the shape. + +## 3. Contract combinators + +Contracts compose using ordinary `tricu` functions. A few common patterns: + +```tri +andC = (c1 c2 value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : c2 v rest) + (c1 value rest)) + +mapC = (f c value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : contractOk (f v) rest) + (c value rest)) + +listOf = (c xs rest : ...) -- checks spine and element contract +pairOf = (c1 c2 p rest : ...) +``` + +These are library code, not core standard. A contract library can provide +`listOf`, `pairOf`, `fnContract`, and similar helpers. + +## 4. Higher-order contracts + +A contract for a function value returns a wrapped proxy. The proxy itself is a +contract: it checks arguments on the way in and results on the way out. + +```tri +fnContract = (argC resC f rest : + contractOk + (x : (rest1 : + withContract argC x + (x' : + withContract resC (f x') + (y : contractOk y rest1) + (msg : contractErr msg rest1)) + (msg : contractErr msg rest1))) + rest) +``` + +This does not prove that `f` is well-behaved internally; it only catches +violations at observed calls. + +## 5. Interaction-tree contract effects + +The core contract layer returns `Result`. For code that wants catchable, +composable contract failures without threading `Result` through every function, +contracts can be lifted into an interaction tree. + +### 5.1 Interaction-tree constructors + +These reuse the same `pure`/`bind` tags already used for `tricu` IO: + +```tri +pureE value = pair 0 value +bindE action k = pair 1 (pair action k) +exceptE tag value k = pair 2 (pair tag (pair value k)) +``` + +`exceptE` is resumable: `k` is the continuation. A handler may resume with +`k replacement` or abort by ignoring `k`. Contract failures usually abort; the +resumable shape is provided for generality and for richer effect handlers. + +### 5.2 Lifting a contract + +```tri +checkM contract value = + matchResult + (msg _ : exceptE "contract" msg (\_ : pureE t)) + (checked _ : pureE checked) + (contract value t) +``` + +`pureM` and `bindM` are aliases for `pureE` and `bindE`: + +```tri +pureM = pureE +bindM = bindE +``` + +### 5.3 Lifting pure functions + +```tri +liftM f = (x : pureE (f x)) +``` + +### 5.4 Example + +```tri +halfM n = + bindM (checkM even? n) + (\n' : pureM (div n' 2)) + +use = + handleM "contract" + (\msg k : pureM 0) + (halfM 5) +``` + +`handleM` is a pure tree-to-tree function that interprets `exceptE` nodes, +either resuming with a replacement value or returning a failure tree. + +### 5.5 Running a pure interaction tree + +```tri +runM tree = + -- interprets pureE, bindE, and exceptE nodes + -- returns a Result or a residual effect tree + ... +``` + +If the tree contains no IO or other host effects, `runM` can be written +entirely in `tricu`. + +## 6. Source syntax + +Source annotations are frontend sugar for inserting contract boundaries. They do +not change the runtime semantics of ordinary code; they tell the frontend where +to emit contract checks. + +### 6.1 Argument and result assertions + +```tri +idNat x@Nat =@Nat x +``` + +`x@Nat` inserts a `Nat` contract check on the argument. `=@Nat` inserts a check +on the result. + +### 6.2 Compound contracts + +```tri +sum xs@(List Nat) =@Nat ... +useHandler f@(Fn [(NonEmptyList String)] String) =@String ... +``` + +Compound annotations must be parenthesized when they contain application. + +### 6.3 Phantom arguments + +```tri +map @A @B =@(Fn [(Fn [A] B) (List A)] (List B)) ... +``` + +A phantom argument contributes a contract to the function boundary without +introducing a term binder. + +### 6.4 Missing annotations + +Unannotated binders in a contract-bearing head default to `Any`. A missing +return annotation defaults to `Any`. + +```tri +foo x y@Bool = body -- foo : Fn [Any Bool] Any, y : Bool +``` + +### 6.5 Export contracts + +A module export may advertise a contract: + +```tri +!export factorial : Fn [Nat] Nat +``` + +The advertised contract travels with the export in the module manifest. + +## 7. Module and content-store integration + +Contracts attach to module exports as ordinary content-addressed tree terms. +There is no special contract object kind. The manifest references the contract +with the same object kind as any other tree term: + +```text +name: "factorial" +object: + kind: arboricx.tree-term.v1 + hash: +contract: + kind: arboricx.tree-term.v1 + hash: +``` + +The earlier `arboricx.view-contract.type.v1` object kind is removed. A +contract is just a tree term. + +For locally built modules, advertised export contracts may be checked before the +manifest is published. For imported modules, the advertised contract is a +boundary assumption. The local checker may insert guard wrappers when a +contracted import is used. + +See `docs/module-system-design.md` and +`docs/content-store-and-module-format.md` for the full store, manifest, and +bundle conventions. + +## 8. Guarantees + +The contract layer honestly claims only: + +1. A contract applied to a value returns a standard `Result` shape. +2. `withContract` and `checkM` invoke the contract at the represented boundary. +3. A failed contract invokes the supplied failure continuation or `exceptE` + node. +4. Content-addressed references prevent an attached contract from silently + drifting to a different stored object. +5. Provenance labels record where a contract assertion came from. + +Only the contract function itself observes the runtime value. The rest is +metadata plumbing. + +## 9. Limitations + +- Contracts do not establish parametricity or representation independence. +- They do not prove that opaque recursive or primitive code satisfies its + contract for every input. +- They do not remove the need for tests, careful API design, or future static + analysis. +- Higher-order contract wrapping has the usual costs and proxy-like behavior + of dynamic contract systems. + +## 10. Summary + +- A contract is an ordinary `tricu` function: `Tree -> Result Tree Tree`. +- `withContract` aborts at a boundary; `checkContract` returns the raw + `Result`. +- The interaction-tree layer (`checkM`, `bindM`, `handleM`) adds catchable, + composable failures on top of the same core contracts. +- Contracts attach to module exports as ordinary tree-term objects. +- Provenance labels record source and blame, but do not prove truth. diff --git a/docs/guard-injection.md b/docs/guard-injection.md deleted file mode 100644 index 601d256..0000000 --- a/docs/guard-injection.md +++ /dev/null @@ -1,371 +0,0 @@ -# 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 index c0d6866..a73c613 100644 --- a/docs/module-system-design.md +++ b/docs/module-system-design.md @@ -50,26 +50,21 @@ content identity from ergonomic naming and namespace organization. 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 +complete tree terms, and direct Contract terms. Lower-level Merkle/bundle formats exist for transport and DAG tooling, but the store core should treat all objects as content-addressed bytes with formats/media types. `tricu` and Haskell are clients/tooling. They are not the semantic owners of the store. -### 2.3 View Contracts are portable enough to integrate +### 2.3 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 store may integrate with Contracts because a contract is itself an ordinary +Tree Calculus term. Contracts are not a Haskell-private or `tricu`-private +semantic layer. -The module resolver may emit typed-program evidence, but checker semantics remain -unchanged: - -```text -Haskell emits evidence. -tricu judges evidence. -``` +A module manifest may reference a contract object, but the contract is evaluated +by ordinary Tree Calculus reduction, not by a special checker. ### 2.4 Modules should reflect definitions as they actually exist @@ -95,11 +90,11 @@ Arboricx CAS / Merkle Store Arboricx Bundle compact indexed transport/execution format -View Contract Artifact - portable evidence/checker data over tree artifacts +Contract Term + ordinary tree-valued contract function, applied by reduction Module Manifest - immutable export map from names to content objects and optional contracts + immutable export map from names to content objects and optional contract terms Workspace mutable aliases, selected versions, package pins, and user-facing names @@ -109,8 +104,8 @@ tricu ``` The content store stores objects. Arboricx defines important object formats. -View Contracts define portable checking artifacts. `tricu` produces and consumes -those formats. +Contracts are ordinary tree-valued functions; `tricu` produces and consumes those +formats. ### 3.1 Execution imports versus contract checking @@ -122,30 +117,29 @@ 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: +Contract checking is a runtime boundary check. It may load exported contract term +objects for the symbols that participate in a boundary. That slower path remains +separate from execution hydration: ```text -Haskell emits evidence. -tricu judges evidence. +Haskell loads contract terms. +tricu applies them by reduction. ``` -Reusable view catalogs are ordinary tricu libraries/tree terms, not a separate +Reusable contract 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 +For locally built workspace modules, advertised direct export contracts may be +checked before the manifest alias is written. Producer checking includes +advertised contracts from any imported modules used by that source, so a module cannot publish a local annotated export that contradicts a dependency's exported -view. If producer checking fails, the module alias is not written. +contract. 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`. +Consumer checking then resolves selected module exports and loads their exported +contract term objects. Those contracts are applied at the import boundary using +the standard contract helpers. For external or prebuilt manifests, the advertised +contract is a trusted boundary declaration; the consumer may still re-apply it at +the boundary. ## 4. Content Store Direction @@ -167,11 +161,11 @@ Current module/check object kinds: ```text arboricx.module-manifest.v1 arboricx.tree-term.v1 -arboricx.view-contract.type.v1 +arboricx.tree-term.v1 ``` Merkle nodes and indexed bundles remain lower-level Arboricx transport/DAG -formats, but they are not the module/eval storage model. typed programs and view +formats, but they are not the module/eval storage model. typed programs and contract catalogs are ordinary tree terms unless a future external tooling use case proves that they need their own object kind. @@ -295,7 +289,7 @@ metadata: license createdBy optional: - view contract artifact refs + contract artifact refs ABI/media type info source/provenance refs ``` @@ -312,7 +306,7 @@ name: "map" object: sha256:... kind: arboricx.tree-term.v1 abi: arboricx.abi.tree.v1 -view: sha256:... -- optional View Contract artifact +contract: sha256:... -- optional contract term source: sha256:... -- optional source/provenance object ``` @@ -343,7 +337,7 @@ The future pipeline should be: parse source resolve imports/names to module exports and content refs lower source using resolved refs -emit a view-tree artifact +emit a contract artifact check evidence when requested store/export artifacts ``` @@ -392,36 +386,37 @@ This is the right identity for: ### 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. +name with its compiled tree term and an optional contract term reference. The content store should not require extra definition/source/provenance objects, and fully untyped Tree Calculus code must remain valid. -## 9. View Contract Integration +## 9. Contract Integration -View Contracts should attach to modules/exports as portable artifacts. +Contracts attach to modules/exports as ordinary tree-term objects. A contract is +a `tricu` function `Tree -> Result Tree Tree`; it is not a special artifact +kind and it does not require a separate checker binary. -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. +A module manifest pairs each export name with its compiled tree term and an +optional contract term reference. The importer loads the contract object and +applies it at the boundary. -This is the intended split: +An imported definition can be assigned a local name while lowering source. Its +global identity remains a content hash or module export ref. The intended split +is: ```text -typed program local symbol: 3 -Debug label: "List.map" -Resolved object: sha256:... -Exported view: Fn [...] +Local source name: "List.map" +Resolved object: sha256:... +Exported contract: sha256:... ``` -De Bruijn-style integer symbols are still appropriate inside a typed program. They -are local evidence identifiers, not global content identity. +There is no typed-program evidence graph and no local numeric checker symbols. +The contract term itself is the authority. -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. +Untyped code remains valid with no contract artifact. If a boundary has no +contract information, it simply performs no runtime check. We should not pretend +that untyped functions have an implicit `Any -> Any -> ...` contract. ## 10. Import Syntax Direction @@ -457,7 +452,7 @@ A plausible migration path: 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. +7. Attach contract terms to module exports. 8. Gradually migrate existing `lib/` and `demos/` imports. Compatibility shims may keep existing `!import` working during migration. @@ -496,9 +491,9 @@ Modules: 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 +Contracts: + ordinary tree-valued functions attached to exports and applied by pure Tree + Calculus reduction at boundaries ``` The key architectural rule is that hashes provide stable identity, while names diff --git a/docs/view-contract-syntax.md b/docs/view-contract-syntax.md deleted file mode 100644 index 6fd929d..0000000 --- a/docs/view-contract-syntax.md +++ /dev/null @@ -1,582 +0,0 @@ -# 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 deleted file mode 100644 index b5aea41..0000000 --- a/docs/view-contracts.md +++ /dev/null @@ -1,384 +0,0 @@ -# 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. Soundness Boundary - -Views are descriptive boundary metadata, not types and not proofs about opaque -Tree Calculus terms. In particular, the checker does not claim parametricity, -representation independence, or existential abstraction. - -Raw Tree Calculus observation can distinguish values by their tree -representation. A term advertised as `Fn [A] A` can inspect its argument and -choose a representation-dependent result; a metadata-only checker cannot rule -that out. The same issue applies transitively through higher-order arguments and -dynamically constructed observers. - -The checker therefore accepts only monomorphic Views. Legacy `Var`, `Forall`, -and `Exists` tags remain reserved so old artifacts fail deterministically, but -they are not well-formed checker inputs. - -The guarantees retained here are narrower: - -- View and typed-program envelopes are structurally well formed. -- Declared monomorphic Views flow consistently across explicit typed nodes. -- Guarded Views execute their predicates at represented boundaries. -- Artifact references bind metadata to particular stored objects. - -These guarantees do not establish that an opaque payload has an unguarded -structural View such as `List` or `Fn`. Such Views are conventions/assertions -used to place and compose checks. Only an executed guard observes the value. - -See [the intensionality analysis](../notes/view-contract-trust-provenance.md) for -the rationale and remaining limitations. - -## 5. 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. - -## 6. 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. - -View facts may carry per-fact provenance: - -```text -Checked -Trusted -Unchecked -``` - -These labels are retained for artifact compatibility and auditing. They identify -the source of an assertion; they do not prove semantic membership, parametricity, -or abstraction. An absent label is interpreted conservatively as `Unchecked`. - -The former value-level polymorphic `viewFacts` catalogs and frontend -raw-intensionality taint pass have been removed. Monomorphic imported facts may -still be attached to exports, but consumers must treat them as assertions unless -an executable guard enforces the relevant property. - -## 7. 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 -``` - -## 8. 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. - -## 9. 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. - -## 10. 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. - -## 11. 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. -``` - -## 12. 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. - -## 13. 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/base.tri b/lib/base.tri index f138f56..d3e7775 100644 --- a/lib/base.tri +++ b/lib/base.tri @@ -119,6 +119,47 @@ maybeBind m f = matchMaybe nothing f m maybeOr default m = matchMaybe default id m maybe? = matchMaybe false (_ : true) +-- --------------------------------------------------------------------------- +-- Lazy eliminators +-- +-- A strict eliminator evaluates both branches because they are ordinary +-- arguments. Give a branch that recurses, looks something up, or builds +-- structure to one of these instead: it becomes a thunk and only the selected +-- branch is ever applied. +-- --------------------------------------------------------------------------- + +lazyBool = (thenK elseK cond : + ((chosen : chosen t) + (matchBool + thenK + elseK + cond))) + +-- This module has no list matcher, so `triage` is used directly: a cons is a +-- Fork, which is why the cons case sits in the fork slot, exactly as in +-- `matchList` in lib/list.tri. +lazyList = (nilK consK xs : + ((chosen : chosen t) + (triage + nilK + _ + (h r : (_ : consK h r)) + xs))) + +lazyMaybe = (noneK someK m : + ((chosen : chosen t) + (matchMaybe + noneK + (x : (_ : someK x)) + m))) + +lazyResult = (errK okK result : + ((chosen : chosen t) + (matchResult + (code rest : (_ : errK code rest)) + (value rest : (_ : okK value rest)) + result))) + -- --------------------------------------------------------------------------- -- Basic arithmetic -- --------------------------------------------------------------------------- @@ -137,18 +178,15 @@ andLazy? = (a bK : pred = y (self : triage 0 - (_ : 0) + 0 (bit rest : - matchBool - (matchBool + ifLazy + bit + (_ : matchBool + (t t rest) 0 - (pair 0 rest) - (equal? rest 0)) - (matchBool - 0 - (pair 1 (self rest)) - (equal? rest 0)) - bit)) + rest) + (_ : t (t t) (self rest)))) isZero? = triage true (_ : false) (_ _ : false) @@ -190,6 +228,42 @@ mul = y (self a b : (_ : 0) (_ : add a (self a (pred b)))) +div = y (self a b : + ifLazy + (isZero? b) + (_ : 0) + (_ : ifLazy + (lt? a b) + (_ : 0) + (_ : succ (self (sub a b) b)))) + +mod = y (self a b : + ifLazy + (isZero? b) + (_ : 0) + (_ : ifLazy + (lt? a b) + (_ : a) + (_ : self (sub a b) b))) + +pow = y (self a b : + ifLazy + (isZero? b) + (_ : 1) + (_ : mul a (self a (pred b)))) + +even? n = (triage + true + (_ : false) + (bit _ : isZero? bit) + n) + +odd? = (n : not? (even? n)) + +min = (a b : ifLazy (lte? a b) (_ : a) (_ : b)) + +max = (a b : ifLazy (lte? a b) (_ : b) (_ : a)) + -- --------------------------------------------------------------------------- -- Result combinators -- --------------------------------------------------------------------------- @@ -217,7 +291,3 @@ resultMapErr = (f result : (code rest : err (f code) rest) (value rest : ok value rest) result) - --- --------------------------------------------------------------------------- --- View facts --- --------------------------------------------------------------------------- diff --git a/lib/contracts.tri b/lib/contracts.tri new file mode 100644 index 0000000..fe62e78 --- /dev/null +++ b/lib/contracts.tri @@ -0,0 +1,240 @@ +!import "base" !Local +!import "list" !Local + +-- --------------------------------------------------------------------------- +-- Core contract type +-- +-- A contract is an ordinary tricu function: Tree -> Tree -> Result Tree Tree. +-- The second argument is the conventional "rest" slot. On success a contract +-- returns the checked value wrapped in the standard ok shape; on failure it +-- returns a diagnostic wrapped in the standard err shape. +-- --------------------------------------------------------------------------- + +contractOk = (value : (rest : ok value rest)) +contractErr = (msg : (rest : err msg rest)) + +-- Apply a contract with the conventional rest slot and return the raw Result. +checkContract = (contract value : contract value t) + +-- Apply a contract and continue with either the onOk or onFail branch. +withContract = (contract value onOk onFail : + matchResult + (msg _ : onFail msg) + (checked _ : onOk checked) + (contract value t)) + +-- --------------------------------------------------------------------------- +-- Basic contracts +-- --------------------------------------------------------------------------- + +-- Any value passes. +anyC = (value : contractOk value) + +-- Always fails with the supplied message. +neverC = (msg : (value : contractErr msg)) + +-- Build a contract from a predicate that inspects only the value. +guardC = (msg predicate value rest : + lazyBool + (_ : contractOk value rest) + (_ : contractErr msg rest) + (predicate value)) + +-- Natural number contract. +nat? = guardC "not a natural number" (n : gte? n 0) + +-- Non-zero number contract. +nonZero? = guardC "non-zero" (n : not? (isZero? n)) + +-- Boolean contract. +bool? = guardC "not a boolean" (b : or? (equal? b true) (equal? b false)) + +-- --------------------------------------------------------------------------- +-- Contract combinators +-- --------------------------------------------------------------------------- + +andC = (c1 c2 value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : c2 v rest) + (c1 value rest)) + +orC = (c1 c2 value rest : + matchResult + (msg _ : c2 value rest) + (v _ : contractOk v rest) + (c1 value rest)) + +notC = (c value rest : + matchResult + (msg _ : contractOk value rest) + (_ _ : contractErr "notC: predicate succeeded" rest) + (c value rest)) + +mapC = (f c value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : contractOk (f v) rest) + (c value rest)) + +bindC = (c f value rest : + matchResult + (msg _ : contractErr msg rest) + (v _ : f v value rest) + (c value rest)) + +-- --------------------------------------------------------------------------- +-- Collection contracts +-- --------------------------------------------------------------------------- + +listOf = (c value rest : + y (self orig xs : + matchList + (contractOk orig rest) + (h r : + matchResult + (msg _ : contractErr msg rest) + (_ _ : self orig r) + (c h rest)) + xs) value value) + +nonEmptyListOf = (c : + andC (guardC "empty list" (xs : not? (emptyList? xs))) (listOf c)) + +pairOf = (c1 c2 p rest : + matchPair + (a b : + matchResult + (msg _ : contractErr msg rest) + (a' _ : + matchResult + (msg _ : contractErr msg rest) + (b' _ : contractOk (pair a' b') rest) + (c2 b rest)) + (c1 a rest)) + p) + +-- --------------------------------------------------------------------------- +-- Higher-order function contracts +-- +-- These return a Result-wrapped proxy. The proxy itself is a contract: it +-- checks arguments on the way in and results on the way out. +-- --------------------------------------------------------------------------- + +fnContract = (argC resC f rest : + contractOk + (x : (rest1 : + withContract argC x + (x' : + withContract resC (f x') + (y : contractOk y rest1) + (msg : contractErr msg rest1)) + (msg : contractErr msg rest1))) + rest) + +fn2 = (arg1C arg2C resC f rest : + contractOk + (x : (rest1 : + withContract arg1C x + (x' : + contractOk + (y : (rest2 : + withContract arg2C y + (y' : + withContract resC (f x' y') + (z : contractOk z rest2) + (msg : contractErr msg rest2)) + (msg : contractErr msg rest2))) + rest1) + (msg : contractErr msg rest1))) + rest) + +-- --------------------------------------------------------------------------- +-- Interaction-tree effect layer +-- +-- These constructors and combinators layer catchable, composable failures on +-- top of the core Result contracts. They reuse the same tags as tricu IO: +-- 0 = pureE +-- 1 = bindE +-- 2 = exceptE +-- --------------------------------------------------------------------------- + +pureE = (value : pair 0 value) +bindE = (action k : pair 1 (pair action k)) +exceptE = (tag value k : pair 2 (pair tag (pair value k))) + +pureM = pureE +bindM = bindE + +-- Lift a contract failure into an interaction tree. +checkM = (contract value : + matchResult + (msg _ : exceptE "contract" msg (_ : pureE t)) + (checked _ : pureE checked) + (contract value t)) + +-- Lift a pure function into the interaction tree. +liftM = (f : (x : pureE (f x))) + +-- Interpret a pure interaction tree into a Result. +runM = (tree : + run tree + where run = + y (self tree : + matchPair + (op payload : + matchBool + -- pureE + (contractOk (snd tree) t) + (matchBool + -- bindE + (matchPair + (action k : + matchResult + (msg _ : contractErr msg t) + (v _ : self (k v)) + (self action)) + payload) + -- exceptE + (matchPair + (tag pair : + matchPair + (value k : + contractErr value t) + pair) + payload) + (equal? op 1)) + (equal? op 0)) + tree)) + +-- Handle matching exceptE nodes by applying the handler to the value and the +-- resumption continuation. Non-matching exceptions are left in place. +handleM = (tag handler tree : + handle tree + where handle = + y (self tree : + matchPair + (op payload : + matchBool + -- pureE + tree + (matchBool + -- bindE + (matchPair + (action k : + bindE (self action) (v : self (k v))) + payload) + -- exceptE + (matchPair + (et pair : + matchPair + (value k : + matchBool + (self (handler value k)) + tree + (equal? et tag)) + pair) + payload) + (equal? op 1)) + (equal? op 0)) + tree)) diff --git a/lib/guardedBase.tri b/lib/guardedBase.tri new file mode 100644 index 0000000..d002be3 --- /dev/null +++ b/lib/guardedBase.tri @@ -0,0 +1,24 @@ +!import "base" !Local +!import "list" !Local +!import "contracts" !Local +!import "intensional" !Local + +-- Runtime-guarded wrappers around partial or structurally-sensitive base/list +-- functions. Each wrapper uses the frontend @ / =@ desugaring and is exported +-- with an advertised contract so manifests carry the contract terms. + +safeHead xs@(nonEmptyListOf anyC) =@anyC head xs +safeTail xs@(nonEmptyListOf anyC) =@(listOf anyC) tail xs + +safeDiv a@nat? b@(andC nat? nonZero?) =@nat? div a b + +safeHalf n@(andC nat? evenC?) =@nat? div n 2 + +-- last is only guaranteed to return the maximum if the input list is sorted. +sortedMax xs@(sortedList? nat?) =@nat? last xs + +!export safeHead : fnContract (nonEmptyListOf anyC) anyC +!export safeTail : fnContract (nonEmptyListOf anyC) (listOf anyC) +!export safeDiv : fn2 nat? nonZero? nat? +!export safeHalf : fnContract (andC nat? evenC?) nat? +!export sortedMax : fnContract (sortedList? nat?) nat? diff --git a/lib/intensionalContracts.tri b/lib/intensionalContracts.tri new file mode 100644 index 0000000..ab70021 --- /dev/null +++ b/lib/intensionalContracts.tri @@ -0,0 +1,55 @@ +!import "base" !Local +!import "list" !Local +!import "contracts" !Local + +-- Structural contracts that exploit Tree Calculus's intensional nature. +-- These are not simple type tags; they recursively inspect the tree shape. + +-- Any value that is not Leaf. +nonEmptyTree? = guardC "empty tree" (x : not? (isZero? x)) + +-- Every internal node is a Fork with two children; Stems are not allowed. +fullTree? = guardC "not a full binary tree" + (y (self x : + triage + true + (_ : false) + (l r : and? (self l) (self r)) + x)) + +-- Even and odd number contracts that inspect the LSB bit tree. +evenC? = guardC "not even" even? +oddC? = guardC "not odd" odd? + +-- A power of two has exactly one '1' bit in its LSB encoding. +powerOfTwo? = guardC "not a power of two" + (y (self n : + triage + false + true + (bit rest : + matchBool + (self rest) + false + (isZero? bit)) + n)) + +-- A string (list of numbers) where every code point is in the ASCII range. +asciiString? = listOf + (guardC "non-ascii byte" (n : and? (gte? n 0) (lte? n 127))) + +-- Check that a list of numbers is sorted in ascending order. +-- The element contract parameter is applied separately by listOf. +isSorted_ = (self xs : + matchList + true + (h r : + matchBool + (self r) + false + (matchList true (h2 _ : lte? h h2) r)) + xs) + +isSorted = y isSorted_ + +sortedList? = (c : andC (listOf c) (guardC "not sorted" isSorted)) diff --git a/lib/lazy.tri b/lib/lazy.tri deleted file mode 100644 index dfe04c5..0000000 --- a/lib/lazy.tri +++ /dev/null @@ -1,30 +0,0 @@ -!import "base" !Local -!import "list" !Local - -lazyBool = (thenK elseK cond : - ((chosen : chosen t) - (matchBool - thenK - elseK - cond))) - -lazyList = (nilK consK xs : - ((chosen : chosen t) - (matchList - nilK - (h r : (_ : consK h r)) - xs))) - -lazyMaybe = (noneK someK m : - ((chosen : chosen t) - (matchMaybe - noneK - (x : (_ : someK x)) - m))) - -lazyResult = (errK okK result : - ((chosen : chosen t) - (matchResult - (code rest : (_ : errK code rest)) - (value rest : (_ : okK value rest)) - result))) diff --git a/lib/list.tri b/lib/list.tri index 191fc64..94cd5b1 100644 --- a/lib/list.tri +++ b/lib/list.tri @@ -232,54 +232,103 @@ contains?_ self needle haystack = (startsWith? needle haystack) contains? = needle haystack : y contains?_ needle haystack -linesFinish current accRev = - reverse (pair (reverse current) accRev) +sum = foldl (acc x : add x acc) 0 +product = foldl (acc x : mul x acc) 1 -lines_ self str accRev current = - matchList - (linesFinish current accRev) +-- --------------------------------------------------------------------------- +-- Generic separators +-- +-- `lines`, `unlines`, `words` and `unwords` at the bottom of this section are +-- the byte-valued special cases of these primitives. +-- +-- Joining takes any separator; splitting takes one byte. Separators are removed +-- rather than kept, and empty fields are preserved. +-- +-- The workers below follow notes/tricu-normalization-rules.md: consumed data +-- first, lazy eliminators around every recursive branch, `y` only inside the +-- public wrapper, and `pair`-only state updates. +-- --------------------------------------------------------------------------- + +takeWhile_ self xs f = + lazyList + (_ : t) (h r : - matchBool - (self r (pair (reverse current) accRev) t) - (self r accRev (pair h current)) - (equal? h 10)) - str -lines = str : y lines_ str t t + lazyBool + (_ : pair h (self r f)) + (_ : t) + (f h)) + xs +takeWhile = f xs : y takeWhile_ xs f -unlines_ self lines = - matchList - "" - (h r : append h (append "\n" (self r))) - lines -unlines = lines : y unlines_ lines - -wordsAdd current accRev = - matchBool - accRev - (pair (reverse current) accRev) - (emptyList? current) - -words_ self str accRev current = - matchList - (reverse (wordsAdd current accRev)) +dropWhile_ self xs f = + lazyList + (_ : t) (h r : - matchBool - (self r (wordsAdd current accRev) t) - (self r accRev (pair h current)) - (equal? h 32)) - str -words = str : y words_ str t t + lazyBool + (_ : self r f) + (_ : pair h r) + (f h)) + xs +dropWhile = f xs : y dropWhile_ xs f -unwords_ self words = - matchList - "" +-- Byte-level whitespace only: space and horizontal tab (HTTP OWS). +spaceByte? = b : equal? b 32 +tabByte? = b : equal? b 9 +trimByte? = b : or? (spaceByte? b) (tabByte? b) + +trim = xs : dropWhile trimByte? (reverse (dropWhile trimByte? (reverse xs))) + +intercalate_ self xs sep = + lazyList + (_ : t) (h r : - matchBool - h - (append h (append " " (self r))) + lazyBool + (_ : h) + (_ : append h (append sep (self r sep))) (emptyList? r)) - words -unwords = words : y unwords_ words + xs +intercalate = sep xs : y intercalate_ xs sep + +-- Separator after every field, including the last one. Line-oriented formats +-- want this: `joinSuffix "\n" xs` terminates the final line while +-- `intercalate "\n" xs` does not. +joinSuffix_ self xs sep = + lazyList + (_ : t) + (h r : append (append h sep) (self r sep)) + xs +joinSuffix = sep xs : y joinSuffix_ xs sep + +-- Split on a single byte. A separator byte is never stored, so the state +-- updates stay `pair`s and every recursive argument is a variable: the input is +-- walked exactly once and the fields are reversed back once, when it ends. +-- +-- Splitting on a multi-byte separator is deliberately not here. Detecting a +-- separator longer than a byte means re-walking the remaining input at every +-- split point (or splicing the field), which is quadratic in the best case and +-- blew up when tried. `http.tri` wants CRLF and `:` splits; that wants a shape +-- where the separator drives the recursion instead of the input. +-- +-- Empty fields are preserved: `splitOnByte 58 "a::b"` is ["a" "" "b"]. +splitByte_ self str byte acc current = + lazyList + (_ : map reverse (reverse (pair current acc))) + (h r : + lazyBool + (_ : self r byte (pair current acc) t) + (_ : self r byte acc (pair h current)) + (equal? h byte)) + str +splitOnByte = byte str : y splitByte_ str byte t t + +-- Every one of these keeps its arguments bound: partially applying a +-- multi-argument function at the top level leaves a fixed point exposed. +lines = str : splitOnByte 10 str +unlines = xs : joinSuffix "\n" xs + +-- Runs of separators collapse: empty fields are dropped. +words = str : filter (w : not? (emptyList? w)) (splitOnByte 32 str) +unwords = xs : intercalate " " xs zipWith_ self f xs ys = matchList diff --git a/lib/prelude.tri b/lib/prelude.tri index 02d404c..3421c1d 100644 --- a/lib/prelude.tri +++ b/lib/prelude.tri @@ -3,5 +3,4 @@ !import "base" !Local !import "list" !Local !import "bytes" !Local -!import "lazy" !Local !import "conversions" !Local diff --git a/lib/view.tri b/lib/view.tri deleted file mode 100644 index 9ba1df5..0000000 --- a/lib/view.tri +++ /dev/null @@ -1,1656 +0,0 @@ -!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 -viewTagVar = 8 -viewTagForall = 9 -viewTagExists = 10 -viewFieldArgs = 0 -viewFieldResult = 1 -viewFieldRef = 2 -viewFieldElem = 3 -viewFieldLeft = 4 -viewFieldRight = 5 -viewFieldErr = 6 -viewFieldOk = 7 -viewFieldBase = 8 -viewFieldGuard = 9 -viewFieldVar = 10 -viewFieldBinders = 11 -viewFieldBody = 12 - --- 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 -typedNodeFieldProvenance = 5 - -viewProvenanceChecked = 0 -viewProvenanceTrusted = 1 -viewProvenanceUnchecked = 2 - --- 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)] -viewVar name = record viewTagVar [(field viewFieldVar name)] -viewForall binders body = - record viewTagForall [(field viewFieldBinders binders) (field viewFieldBody body)] -viewExists binders body = - record viewTagExists [(field viewFieldBinders binders) (field viewFieldBody body)] - -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) -varView? = (view : equal? (viewTag view) viewTagVar) -forallView? = (view : equal? (viewTag view) viewTagForall) -existsView? = (view : equal? (viewTag view) viewTagExists) -guardedViewBase = (view : field0 (viewPayload view)) -guardedViewGuard = (view : field1 (viewPayload view)) -viewVarName = (view : field0 (viewPayload view)) -viewBinderNames = (view : field0 (viewPayload view)) -viewQuantifiedBody = (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) - --- Tags 8-10 remain reserved so old artifacts decode deterministically, but --- quantified/variable Views are no longer accepted by the checker. They --- implied abstraction and parametricity that raw Tree Calculus cannot enforce. -wellFormedVarView? = (_ : false) - -wellFormedQuantifiedView? = (_ : false) - -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)) - (_ : - lazyBool - (_ : wellFormedVarView? view) - (_ : - lazyBool - (_ : - lazyBool - (_ : self (viewQuantifiedBody view)) - (_ : false) - (wellFormedQuantifiedView? view)) - (_ : - lazyBool - (_ : self (viewQuantifiedBody view)) - (_ : false) - (wellFormedQuantifiedView? view)) - (forallView? view)) - (varView? view)) - (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)) - -typedValueWithProvenance = (symbol view term provenance : - record typedNodeTagValue - [(field typedNodeFieldSymbol symbol) - (field typedNodeFieldView view) - (field typedNodeFieldTerm term) - (field typedNodeFieldProvenance provenance)]) - -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)]) - -typedRequireWithProvenance = (symbol view term provenance : - record typedNodeTagRequire - [(field typedNodeFieldSymbol symbol) - (field typedNodeFieldView view) - (field typedNodeFieldTerm term) - (field typedNodeFieldProvenance provenance)]) - -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))))) - -wellFormedViewProvenance? = (provenance : - or? - (or? (equal? provenance viewProvenanceChecked) (equal? provenance viewProvenanceTrusted)) - (equal? provenance viewProvenanceUnchecked)) - -wellFormedTypedViewFactFields? = (fields : - or? - (fields3? fields typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm) - (and? - (fields4? fields typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm typedNodeFieldProvenance) - (wellFormedViewProvenance? (field3 fields)))) - -wellFormedTypedValue? = (node : - lazyBool - (_ : wellFormedView? (typedNodeView node)) - (_ : false) - (wellFormedTypedViewFactFields? (recordFields node))) - -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) - (wellFormedTypedViewFactFields? (recordFields node))) - -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 - -renderBinders_ self binders = - lazyList - (_ : "") - (binder rest : - lazyBool - (_ : binder) - (_ : append binder (append ", " (self rest))) - (emptyList? rest)) - binders - -renderBinders = (binders : y renderBinders_ binders) - -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))) - (_ : - lazyBool - (_ : append "$" (showNumber (viewVarName view))) - (_ : - lazyBool - (_ : append "forall [" (append (renderBinders (viewBinderNames view)) (append "] " (self (viewQuantifiedBody view)))) ) - (_ : - lazyBool - (_ : append "exists [" (append (renderBinders (viewBinderNames view)) (append "] " (self (viewQuantifiedBody view)))) ) - (_ : "View") - (existsView? view)) - (forallView? view)) - (varView? 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 (not? (wellFormedView? (viewVar 0)))) - (viewContractProbe (not? (wellFormedView? (viewForall [(0)] (viewFn [(viewVar 0)] (viewVar 0)))))) - (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 (viewVar 0)) "$0")) - (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 deleted file mode 100644 index c35ddd3..0000000 --- a/lib/views/catalog.tri +++ /dev/null @@ -1,267 +0,0 @@ -!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/notes/view-contract-trust-provenance.md b/notes/view-contract-trust-provenance.md deleted file mode 100644 index ff6bc87..0000000 --- a/notes/view-contract-trust-provenance.md +++ /dev/null @@ -1,95 +0,0 @@ -# View Contracts at the intensionality boundary - -## Conclusion - -Tree Calculus does not support the abstraction theorem that the former -parametric View design assumed. Views can remain useful as boundary metadata and -as instructions for runtime guard placement, but they must not be presented as -types, proofs of parametricity, or representation-hiding abstraction. - -## Fundamental conflicts - -### Raw observation defeats representation independence - -A parametric contract such as: - -```text -forall a. a -> a -``` - -normally relies on code being unable to learn anything about `a`. A Tree -Calculus term can inspect the tree supplied at `a`, distinguish -representations, and return a representation-dependent value. The View variable -does not hide or seal that tree. - -The same breaks existential abstraction. Advertising a payload as -`exists repr. ...` changes no operational capability: a client can still -inspect the representation directly. - -### Opaque payloads are asserted, not checked - -A typed-value node carries an executable tree beside a View. Metadata validation -deliberately treats that executable field as opaque. Consequently, accepting a -node proves that the envelope and View are well formed; it does not prove that -the tree denotes the advertised `Fn`, `List`, `Maybe`, or other structural -View. - -Provenance labels do not change this. `Checked` and `Trusted` record where an -assertion came from, but neither is a derivation that another implementation can -replay to establish the assertion. - -### Syntactic taint is not a semantic parametricity proof - -Rejecting direct uses of `t` or `triage` is neither complete nor a stable -soundness boundary: - -- an observer can be assembled after reduction; -- observation can arrive through higher-order or dynamically selected code; -- unknown external code can hide observation; -- absence of a rule-3 redex is not reduction-closed; -- exact detection would subsume non-trivial termination/reachability questions. - -A conservative taint pass can define a programming convention, but it cannot -justify the parametric or abstraction guarantees previously attached to Views. - -### Flow checking only checks represented flow - -The checker sees frontend-emitted value, application, and requirement nodes. It -can check consistency among those nodes, but it cannot establish that the graph -faithfully represents every use performed by the opaque executable payload. -This is useful artifact validation, not whole-program typing. - -## Retained contract - -The reduced checker may soundly claim only: - -1. View, node, and program envelopes satisfy their declared data schemas. -2. Explicit monomorphic View facts are propagated consistently through the - represented application graph. -3. A `Guarded` View causes its executable predicate to run at represented - boundaries, and guard failure prevents checked execution. -4. Content-addressed references prevent an attached View artifact from silently - drifting to a different stored object. - -Items 1, 2, and 4 establish metadata integrity, not semantic membership in an -unguarded View. Item 3 is the only retained mechanism that observes an ordinary -runtime value. - -## Code direction - -The initial rollback therefore: - -- removes View-variable instantiation, substitution, and unification from the - portable checker; -- rejects `Var`, `Forall`, and `Exists` as checker inputs while reserving - their legacy tags for deterministic decoding; -- removes the frontend raw-intensionality taint pass; -- removes polymorphic stdlib annotations and value-level View facts; -- retains monomorphic View flow, artifact plumbing, diagnostics, and executable - guards. - -Further simplification should treat unguarded structural Views as descriptive -labels. If stronger guarantees are desired later, they require an operational -mechanism such as runtime recognizers/seals or a genuinely restricted language -whose evaluator enforces the restriction. Metadata provenance alone is -insufficient. diff --git a/src/Check.hs b/src/Check.hs deleted file mode 100644 index 36035b0..0000000 --- a/src/Check.hs +++ /dev/null @@ -1,42 +0,0 @@ -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 deleted file mode 100644 index 37570dc..0000000 --- a/src/Check/Core.hs +++ /dev/null @@ -1,846 +0,0 @@ -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 Data.Maybe (mapMaybe) -import qualified Data.Map as Map -import qualified Data.Set as Set -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 - , importedViewProvenance :: ViewProvenance - } 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 (maybe ViewUnchecked id (resolvedExportProvenance ex))] - - 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 _ _ asts - | not (any isAnnotatedDefinition asts) = pure "ok" - where - isAnnotatedDefinition SDefAnn {} = True - isAnnotatedDefinition _ = False -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 - -astFreeRefs :: Set.Set String -> TricuAST -> [String] -astFreeRefs candidates ast = case ast of - SVar name _ | name `Set.member` candidates -> [name] - SVar _ _ -> [] - SInt _ -> [] - SStr _ -> [] - SList items -> concatMap (astFreeRefs candidates) items - SDef _ args body -> astFreeRefs (foldr Set.delete candidates args) body - SDefAnn _ args _ body -> astFreeRefs (foldr Set.delete candidates (defArgNames args)) body - SApp fn arg -> astFreeRefs candidates fn ++ astFreeRefs candidates arg - TLeaf -> [] - TStem inner -> astFreeRefs candidates inner - TFork left right -> astFreeRefs candidates left ++ astFreeRefs candidates right - SLambda args body -> astFreeRefs (foldr Set.delete candidates args) body - SLet name val body -> astFreeRefs candidates val ++ astFreeRefs (Set.delete name candidates) body - SEmpty -> [] - SImport _ _ -> [] - -defArgNames :: [DefArg] -> [String] -defArgNames = mapMaybe defArgName - where - defArgName (DefBinder name _) = Just name - defArgName (DefPhantom _) = Nothing - -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 - importCandidates = Set.fromList (map importedViewName imports) `Set.difference` Set.fromList topNames - usedImportNames = Set.fromList (concatMap (astFreeRefs importCandidates) asts) - activeImports = filter (\imported -> importedViewName imported `Set.member` usedImportNames) imports - importedSyms = Map.fromList - [ (importedViewName imported, fromIntegral (topCount + idx)) - | (idx, imported) <- zip [0..] activeImports - ] - topDebug = Map.fromList [ (sym, name) | (name, sym) <- Map.toList tops ] - importDebug = Map.fromList - [ (sym, "imported " ++ name) - | (name, sym) <- Map.toList importedSyms - ] - localFactByName = Map.fromList [(importedViewName imported, imported) | imported <- imports, importedViewName imported `elem` topNames] - trustedLocalFacts = - [ (sym, viewTypeToExpr (importedViewType imported), importedViewProvenance imported) - | (name, sym) <- Map.toList tops - , Just imported <- [Map.lookup name localFactByName] - , importedViewProvenance imported `elem` [ViewChecked, ViewTrusted] - ] - trustedLocalKnown = Map.fromList [(sym, view) | (sym, view, _) <- trustedLocalFacts] - importKnown = Map.fromList - [ (sym, viewTypeToExpr (importedViewType imported)) - | imported <- activeImports - , 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 = Map.union trustedLocalKnown importKnown - , nodePayloads = payloads - , debugNames = Map.union topDebug importDebug - } - (localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState - trustedLocalNodes <- mapM (lowerImportedView (nodePayloads finalState)) trustedLocalFacts - importNodes <- mapM (lowerImportedView (nodePayloads finalState)) - [ (sym, viewTypeToExpr (importedViewType imported), importedViewProvenance imported) - | imported <- activeImports - , Just sym <- [Map.lookup (importedViewName imported) importedSyms] - ] - let nodes = trustedLocalNodes ++ 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, ViewProvenance) -> Either String String -lowerImportedView payloadsBySym (sym, view, provenance) = do - viewExpr <- lowerViewExpr view - let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym) - pure $ "typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance - -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 - let (_, _, declaredView) = canonicalDefinitionViews args ret - sym <- symbolForTop name - recordKnown sym declaredView - node <- typedValueNode sym declaredView - pure [node] -lowerDefinitionDeclaration _ = liftEither (Left "internal check error: expected annotated definition") - -lowerDefinitionFlow :: TricuAST -> LowerM [String] -lowerDefinitionFlow (SDefAnn _ args ret body) = withDefinitionScope args $ do - let (flowArgs, flowRet, _) = canonicalDefinitionViews args ret - binderNodes <- concat <$> mapM lowerBinderDeclaration flowArgs - let phantomViews = map lowerPhantomArgType (phantomArgs flowArgs) - (returnArgs, returnResult) <- lowerReturnObligation flowRet - bodyNodes <- lowerBodyWithPhantoms (phantomViews ++ returnArgs) returnResult body - pure (binderNodes ++ bodyNodes) -lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotated definition") - -viewAnyType :: ViewExpr -viewAnyType = VEName "Any" - -canonicalDefinitionViews :: [DefArg] -> Maybe ViewExpr -> ([DefArg], Maybe ViewExpr, ViewExpr) -canonicalDefinitionViews args ret = (args, ret, declaredDefinitionView args ret) - -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 = typedValueNodeWithProvenance sym view ViewChecked - -typedValueNodeWithProvenance :: Integer -> ViewExpr -> ViewProvenance -> LowerM String -typedValueNodeWithProvenance sym view provenance = do - viewExpr <- liftEither (lowerViewExpr view) - payload <- payloadSourceFor sym - pure ("typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance) - -typedRequireNode :: Integer -> ViewExpr -> LowerM String -typedRequireNode sym view = do - viewExpr <- liftEither (lowerViewExpr view) - payload <- payloadSourceFor sym - pure ("typedRequire " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload) - -viewProvenanceSource :: ViewProvenance -> String -viewProvenanceSource ViewChecked = "viewProvenanceChecked" -viewProvenanceSource ViewTrusted = "viewProvenanceTrusted" -viewProvenanceSource ViewUnchecked = "viewProvenanceUnchecked" - -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 - (SLet name value body, _) -> do - (valueSym, valueNodes, _) <- lowerExprKnown value - recordDebugName valueSym name - bodyResult <- withLocalAlias name valueSym (lowerExprKnownAgainst body expected) - let (bodySym, bodyNodes, bodyKnown) = bodyResult - pure (bodySym, valueNodes ++ bodyNodes, bodyKnown) - -- Hand-written immediately-applied lambda (not compiler output; let/where - -- now emit SLet). Kept for source that relies on alias semantics. - (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 (SLet name value body) = do - (valueSym, valueNodes, _) <- lowerExprKnown value - recordDebugName valueSym name - bodyResult <- withLocalAlias name valueSym (lowerExprKnown body) - let (bodySym, bodyNodes, bodyKnown) = bodyResult - pure (bodySym, valueNodes ++ bodyNodes, bodyKnown) --- Hand-written immediately-applied lambda (not compiler output; let/where --- now emit SLet). Kept for source that relies on alias semantics. -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 : _, _) - | containsViewVar argView -> lowerExprKnown arg - | otherwise -> lowerExprKnownAgainst arg argView - _ -> lowerExprKnown arg -lowerApplicationArgument _ arg = - lowerExprKnown arg - -containsViewVar :: ViewExpr -> Bool -containsViewVar view = case view of - VEVar _ -> True - VEVarId _ -> True - VEList items -> any containsViewVar items - VEApp f a -> containsViewVar f || containsViewVar a - VEForall _ body -> containsViewVar body - VEExists _ body -> containsViewVar body - _ -> False - -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 - VTVar varId -> VEVarId varId - 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)) - VTForall binders body -> VEForall binders (viewTypeToExpr body) - VTExists binders body -> VEExists binders (viewTypeToExpr body) - 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 (VEForall _ body) = viewExprFnParts body -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) - VEVar _ -> Nothing - VEVarId varId -> Just (VTVar varId) - 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 - VEForall binders body -> VTForall binders <$> viewExprAsType body - VEExists binders body -> VTExists binders <$> viewExprAsType body - _ -> 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 - VEVar name -> Left $ "polymorphic View variables are unsupported: " ++ show name - VEVarId varId -> Left $ "polymorphic View variables are unsupported: " ++ show varId - 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 - VEForall _ _ -> Left "quantified View contracts are unsupported" - VEExists _ _ -> Left "existential View contracts are unsupported" - 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 deleted file mode 100644 index 2005667..0000000 --- a/src/Check/IO.hs +++ /dev/null @@ -1,422 +0,0 @@ -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 (VEForall _ body) = viewExprFnParts body -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) - VEVar _ -> Nothing - VEVarId varId -> Just (VTVar varId) - 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 - VEForall binders body -> VTForall binders <$> viewExprAsType body - VEExists binders body -> VTExists binders <$> viewExprAsType body - _ -> Nothing - -viewTypeToExpr :: ViewType -> ViewExpr -viewTypeToExpr view = case view of - VTName name -> VEName name - VTVar varId -> VEVarId varId - 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)) - VTForall binders body -> VEForall binders (viewTypeToExpr body) - VTExists binders body -> VEExists binders (viewTypeToExpr body) - 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 - SLet name val body -> SLet name <$> transformExpr val <*> 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 - SLet name val body -> SLet name <$> transformIOAction val <*> 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 - SLet _ val body -> mentionsContractedName contracts val || 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) - SLet name val body -> SLet name (substAst subst val) (substAst (Map.delete name subst) 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) - SLet name val body -> parens ("let " ++ name ++ " = " ++ astSource val ++ " in " ++ 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 cccbb55..3f8c2b5 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -4,8 +4,6 @@ module ContentStore , module ContentStore.Arboricx , module ContentStore.Alias , module ContentStore.Resolver - , module ContentStore.ViewTree - , module ContentStore.ViewContract ) where import ContentStore.Arboricx @@ -13,5 +11,3 @@ import ContentStore.Alias import ContentStore.Filesystem import ContentStore.Object import ContentStore.Resolver -import ContentStore.ViewTree -import ContentStore.ViewContract diff --git a/src/ContentStore/ViewContract.hs b/src/ContentStore/ViewContract.hs deleted file mode 100644 index 2591cd7..0000000 --- a/src/ContentStore/ViewContract.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# 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 (VTVar varId) = BS.cons 0x08 (putU32 (fromIntegral varId)) - 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 (VTForall binders body) = BS.cons 0x09 (putIntegerList binders <> go body) - go (VTExists binders body) = BS.cons 0x0a (putIntegerList binders <> go body) - 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) - VTVar varId -> record 8 [field 10 (ofNumber varId)] - 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] - VTForall binders body -> record 9 [field 11 (ofList (map ofNumber binders)), field 12 (viewTypeToTree body)] - VTExists binders body -> record 10 [field 11 (ofList (map ofNumber binders)), field 12 (viewTypeToTree body)] - 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 - 8 -> VTVar <$> (fieldValueAt 10 fields >>= toNumber) - 9 -> VTForall <$> (fieldValueAt 11 fields >>= integerListFromTree) <*> (fieldValueAt 12 fields >>= treeToViewType) - 10 -> VTExists <$> (fieldValueAt 11 fields >>= integerListFromTree) <*> (fieldValueAt 12 fields >>= treeToViewType) - _ -> 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" - - integerListFromTree tree = toList tree >>= mapM toNumber - - 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) - 0x08 -> do - (varId, afterVarId) <- getU32 rest - pure (VTVar (fromIntegral varId), afterVarId) - 0x09 -> do - (binders, afterBinders) <- getIntegerList rest - (body, afterBody) <- getViewTypeBytes afterBinders - pure (VTForall binders body, afterBody) - 0x0a -> do - (binders, afterBinders) <- getIntegerList rest - (body, afterBody) <- getViewTypeBytes afterBinders - pure (VTExists binders body, afterBody) - _ -> 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) - -putIntegerList :: [Integer] -> BS.ByteString -putIntegerList items = putU32 (length items) <> mconcat (map (putU32 . fromIntegral) items) - -getIntegerList :: BS.ByteString -> Either String ([Integer], BS.ByteString) -getIntegerList bs = do - (count, afterCount) <- getU32 bs - go count afterCount [] - where - go 0 rest acc = Right (reverse acc, rest) - go n rest acc = do - (varId, afterVarId) <- getU32 rest - go (n - 1) afterVarId (fromIntegral varId : 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 deleted file mode 100644 index 39df0ca..0000000 --- a/src/ContentStore/ViewTree.hs +++ /dev/null @@ -1,192 +0,0 @@ -module ContentStore.ViewTree - ( viewTreeKind - , viewTreeDomain - , encodeViewTree - , decodeViewTree - , singletonViewTree - , singletonViewTreeWithProvenance - , viewTreeRootTerm - , viewTreeRootViewFact - , 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 (treeToViewType, viewTypeToTree) -import Research (T(..), ViewProvenance(..), 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 = singletonViewTreeWithProvenance (fmap (\view -> (view, ViewUnchecked)) mView) term - -singletonViewTreeWithProvenance :: Maybe (ViewType, ViewProvenance) -> T -> T -singletonViewTreeWithProvenance mViewFact term = - record typedProgramTag - [ field typedProgramFieldRoot (ofNumber 0) - , field typedProgramFieldNodes (ofList [typedValueNode 0 (maybe viewAnyTree (viewTypeToTree . fst) mViewFact) term (fmap snd mViewFact)]) - ] - --- | 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 - -viewTreeRootViewFact :: T -> Either String (Maybe (ViewType, ViewProvenance)) -viewTreeRootViewFact 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 nodeViewFact node - else lookupRoot root rest - - nodeViewFact node = do - tag <- recordTag node - case tag of - 21 -> do - view <- fieldValue typedNodeFieldView node >>= treeToViewType - provenance <- maybe (Right ViewUnchecked) treeToViewProvenance (fieldValueMaybe typedNodeFieldProvenance node) - Right (Just (view, provenance)) - 23 -> do - view <- fieldValue typedNodeFieldView node >>= treeToViewType - provenance <- maybe (Right ViewUnchecked) treeToViewProvenance (fieldValueMaybe typedNodeFieldProvenance node) - Right (Just (view, provenance)) - 22 -> Right Nothing - _ -> 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 -> Maybe ViewProvenance -> T -typedValueNode sym view term mProvenance = - record typedNodeTagValue $ - [ field typedNodeFieldSymbol (ofNumber sym) - , field typedNodeFieldView view - , field typedNodeFieldTerm term - ] ++ maybe [] (\provenance -> [field typedNodeFieldProvenance (viewProvenanceToTree provenance)]) mProvenance - -viewProvenanceToTree :: ViewProvenance -> T -viewProvenanceToTree ViewChecked = ofNumber 0 -viewProvenanceToTree ViewTrusted = ofNumber 1 -viewProvenanceToTree ViewUnchecked = ofNumber 2 - -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 - -fieldValueMaybe :: Integer -> T -> Maybe T -fieldValueMaybe expected recordTree = do - fields <- either (const Nothing) Just (recordFields recordTree) - values <- either (const Nothing) Just (mapM fieldParts fields) - lookup expected values - -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, typedNodeFieldProvenance :: Integer -typedNodeTagValue = 21 -typedNodeFieldSymbol = 0 -typedNodeFieldView = 1 -typedNodeFieldTerm = 2 -typedNodeFieldProvenance = 5 - -treeToViewProvenance :: T -> Either String ViewProvenance -treeToViewProvenance tree = do - tag <- toNumber tree - case tag of - 0 -> Right ViewChecked - 1 -> Right ViewTrusted - 2 -> Right ViewUnchecked - _ -> Left $ "unknown view-tree View Contract provenance tag: " ++ show tag - -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 fb3e64c..f73a18a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -1,5 +1,6 @@ module Eval where +import Frontend.ContractDesugar import Parser import Research @@ -63,7 +64,7 @@ evalSingle env term in Map.insert "!result" res env evalTricu :: Env -> [TricuAST] -> Env -evalTricu env x = go env (reorderDefs env (map recoverParams x)) +evalTricu env x = go env (reorderDefs env (map recoverParams (desugarContracts x))) where go env' [] = env' go env' [def] = @@ -195,12 +196,37 @@ freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs) freeVars (SLet name val body) = Set.union (freeVars val) (Set.delete name (freeVars body)) freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params) -freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args)) +freeVars (SDefAnn _ args ret body) = + Set.difference + (Set.unions + [ freeVars body + , freeVarsDefArgs args + , maybe Set.empty freeVarsViewExpr ret + , Set.singleton "withContract" + ]) + (Set.fromList (annotatedBinders args)) +freeVars (SExport _ Nothing) = Set.empty +freeVars (SExport _ (Just c)) = freeVarsViewExpr c freeVars (TStem t) = freeVars t freeVars (TFork t u) = Set.union (freeVars t) (freeVars u) freeVars (SList xs) = foldMap freeVars xs freeVars _ = Set.empty +freeVarsViewExpr :: ViewExpr -> Set String +freeVarsViewExpr (VEName s) = Set.singleton s +freeVarsViewExpr (VEVar s) = Set.singleton s +freeVarsViewExpr (VEApp f a) = Set.union (freeVarsViewExpr f) (freeVarsViewExpr a) +freeVarsViewExpr (VEList es) = Set.unions (map freeVarsViewExpr es) +freeVarsViewExpr (VEForall _ e) = freeVarsViewExpr e +freeVarsViewExpr (VEExists _ e) = freeVarsViewExpr e +freeVarsViewExpr _ = Set.empty + +freeVarsDefArgs :: [DefArg] -> Set String +freeVarsDefArgs = Set.unions . map go + where + go (DefBinder _ mAnn) = maybe Set.empty freeVarsViewExpr mAnn + go (DefPhantom ann) = freeVarsViewExpr ann + reorderDefs :: Env -> [TricuAST] -> [TricuAST] reorderDefs env defs | not (null missingDeps) = diff --git a/src/FileEval.hs b/src/FileEval.hs index e1a2d57..170a086 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -1,6 +1,5 @@ module FileEval - ( ContractMode(..) - , LoadedSource(..) + ( LoadedSource(..) , preprocessFile , preprocessFileWithStore , preprocessFileWithResolver @@ -8,23 +7,17 @@ module FileEval , evaluateFileWithStore , evaluateFileWithContext , evaluateFileWithContextWithStore - , evaluateFileWithContextWithStoreAndMode , evaluateFileResult , compileFile , compileFileWithStore , loadFileWithStore - , loadFileWithStoreMode + , loadFileWithResolver , defaultStorePath ) where -import Check.Core - ( ImportedView(..) - , checkProgramWithEnvAndImportedViews - , importedViewsFromResolvedModulesEither - , lowerViewExpr - ) import ContentStore import Eval (evalASTSync, evalTricu, freeVars, result) +import Frontend.ContractDesugar (viewExprToAst) import Lexer import Module.Manifest import Module.Resolver @@ -52,11 +45,6 @@ extractMain env = Just evalResult -> Right evalResult Nothing -> Left "No `main` function detected" -data ContractMode - = EnforceContracts - | IgnoreContracts - deriving (Eq, Show) - data LoadedSource = LoadedSource { loadedImports :: Env , loadedAst :: [TricuAST] @@ -67,7 +55,6 @@ data LoadContext = LoadContext { loadResolver :: ObjectResolver , loadStore :: Maybe StorePath , loadWorkspace :: Workspace - , loadContracts :: ContractMode } processImports :: [TricuAST] -> ([TricuAST], [(String, String)]) @@ -100,14 +87,10 @@ evaluateFileWithContext :: Env -> FilePath -> IO Env evaluateFileWithContext = evaluateFileWithContextWithStore Nothing evaluateFileWithContextWithStore :: Maybe StorePath -> Env -> FilePath -> IO Env -evaluateFileWithContextWithStore mStore = - evaluateFileWithContextWithStoreAndMode EnforceContracts mStore - -evaluateFileWithContextWithStoreAndMode :: ContractMode -> Maybe StorePath -> Env -> FilePath -> IO Env -evaluateFileWithContextWithStoreAndMode mode mStore env filePath = do +evaluateFileWithContextWithStore mStore env filePath = do loaded <- case mStore of - Nothing -> loadFileMode mode filePath - Just store -> loadFileWithStoreMode mode store filePath + Nothing -> loadFile filePath + Just store -> loadFileWithStore store filePath pure $ evalTricu (Map.union (loadedImports loaded) env) (loadedAst loaded) preprocessFile :: FilePath -> IO [TricuAST] @@ -120,26 +103,20 @@ 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 +loadFile p = do store <- defaultStorePath - loadFileWithStoreMode mode store p + loadFileWithStore store p loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource -loadFileWithStore = loadFileWithStoreMode EnforceContracts - -loadFileWithStoreMode :: ContractMode -> StorePath -> FilePath -> IO LoadedSource -loadFileWithStoreMode mode store p = do +loadFileWithStore store p = do workspace <- findWorkspaceFor p resolver <- cachedFilesystemResolver store - let ctx = LoadContext resolver (Just store) workspace mode + let ctx = LoadContext resolver (Just store) workspace loadFile' ctx p loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource loadFileWithResolver resolver p = do - let ctx = LoadContext resolver Nothing emptyWorkspace EnforceContracts + let ctx = LoadContext resolver Nothing emptyWorkspace loadFile' ctx p loadFile' :: LoadContext -> FilePath -> IO LoadedSource @@ -181,65 +158,37 @@ 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 + env = evalTricu (loadedImports loaded) asts + explicitExports = topLevelExports 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 - importedViews <- importedViewsFromResolvedModulesEither (getViewType store) (loadedModules loaded) - let localViewFacts = Map.map (\view -> (view, ViewChecked)) resolvedLocalViews - importedViewFacts = Map.fromList [(importedViewName iv, (importedViewType iv, importedViewProvenance iv)) | iv <- importedViews] - exportViewFacts = Map.union localViewFacts importedViewFacts - exports <- mapM (buildExport env exportViewFacts) names + names = if not (null explicitExports) + then explicitExports + else if null localNames + then map (\n -> (n, Nothing)) (filter (/= "!result") (Map.keys env)) + else map (\n -> (n, Nothing)) localNames + exports <- mapM (buildExport env) names manifestHash <- putManifest store (ModuleManifest [] exports) writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash) where - buildExport env viewFacts name = case Map.lookup name env of - Nothing -> errorWithoutStackTrace $ "Workspace module export not found after evaluation: " ++ name + buildExport env (name, mContract) = case Map.lookup name env of + Nothing -> errorWithoutStackTrace $ + "Workspace module export not found after evaluation: " ++ name Just term -> do - let exportFact = Map.lookup name viewFacts - exportView = fmap fst exportFact - exportProvenance = fmap snd exportFact - rootRef <- putViewTree store (singletonViewTreeWithProvenance exportFact term) - viewRef <- mapM (putViewType store) exportView + rootRef <- putTreeTerm store term + mContractRef <- case mContract of + Nothing -> return Nothing + Just c -> do + cterm <- evaluateContract env c + chash <- putTreeTerm store cterm + return (Just (ObjectRef (unDomain treeTermDomain) chash)) return ModuleExport { moduleExportName = T.pack name - , moduleExportObject = rootRef - , moduleExportAbi = "arboricx.abi.view-tree.v1" - , moduleExportView = viewRef - , moduleExportViewProvenance = exportProvenance + , moduleExportObject = ObjectRef (unDomain treeTermDomain) rootRef + , moduleExportAbi = "arboricx.abi.tree.v1" + , moduleExportContract = mContractRef } -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 - -isAnnotatedDefinition :: TricuAST -> Bool -isAnnotatedDefinition SDefAnn {} = True -isAnnotatedDefinition _ = False + evaluateContract env c = return $ evalASTSync env (viewExprToAst c) topLevelDefinitions :: [TricuAST] -> [String] topLevelDefinitions = mapMaybe go @@ -248,43 +197,12 @@ topLevelDefinitions = mapMaybe go go (SDefAnn name _ _ _) = Just name go _ = Nothing -topLevelDefinitionViews :: [TricuAST] -> Map.Map String ViewExpr -topLevelDefinitionViews asts = Map.fromList (mapMaybe go asts) +topLevelExports :: [TricuAST] -> [(String, Maybe ViewExpr)] +topLevelExports = mapMaybe go where - go (SDefAnn name args resultView _) = Just (name, definitionView args resultView) + go (SExport name mContract) = Just (name, mContract) go _ = Nothing -resolveDefinitionViews :: Env -> Map.Map String ViewExpr -> Either String (Map.Map String ViewType) -resolveDefinitionViews env = mapM (resolveViewExpression env) - -resolveViewExpression :: Env -> ViewExpr -> Either String ViewType -resolveViewExpression checkerEnv view = do - expr <- lowerViewExpr view - let term = evalASTSync checkerEnv (head (parseTricu expr)) - probeEnv = Map.insert "__candidateView" term checkerEnv - probe = evalTricu probeEnv (parseTricu "viewContractProbe (wellFormedView? __candidateView)") - case toString (result probe) of - Right "ok" -> treeToViewType term - Right other -> Left $ "malformed view expression " ++ show expr ++ ": " ++ other - Left err -> Left $ "could not validate view expression " ++ show expr ++ ": " ++ err - -definitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr -definitionView args resultView = - case argViews of - [] -> finalView - _ -> VEApp (VEApp (VEName "Fn") (VEList argViews)) finalView - where - argViews = map defArgView args - finalView = maybe exportedViewAny id resultView - -defArgView :: DefArg -> ViewExpr -defArgView (DefBinder _ Nothing) = exportedViewAny -defArgView (DefBinder _ (Just ty)) = ty -defArgView (DefPhantom ty) = ty - -exportedViewAny :: ViewExpr -exportedViewAny = VEName "Any" - defaultStorePath :: IO StorePath defaultStorePath = do home <- getHomeDirectory diff --git a/src/Frontend/ContractDesugar.hs b/src/Frontend/ContractDesugar.hs new file mode 100644 index 0000000..f812eb2 --- /dev/null +++ b/src/Frontend/ContractDesugar.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE LambdaCase #-} + +module Frontend.ContractDesugar + ( desugarContracts + , viewExprToAst + , withContractE + ) where + +import Research + +-- | Convert source-level contract annotations into runtime boundary checks. +-- +-- A definition such as +-- +-- addPos x@positive? y@positive? =@positive? (add x y) +-- +-- is desugared to a plain definition whose body wraps every annotated +-- argument and the result with 'withContract' from the contract library: +-- +-- addPos = \x -> withContract positive? x +-- (\x -> \y -> withContract positive? y +-- (\y -> withContract positive? (add x y) +-- (\r -> r) +-- (\msg _ -> msg)) +-- (\msg _ -> msg)) +-- (\msg _ -> msg) +-- +-- This makes annotated source depend on the existing 'withContract' helper, +-- which is an ordinary 'tricu' function from 'lib/contracts.tri'. Files that +-- use annotations should import the contract library (or another library that +-- re-exports 'withContract'). +desugarContracts :: [TricuAST] -> [TricuAST] +desugarContracts asts = map desugarTopItem asts + where + desugarTopItem (SDefAnn name args ret body) = desugarDefAnn name args ret body + desugarTopItem other = other + +desugarDefAnn :: String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> TricuAST +desugarDefAnn name args ret body = SDef name [] (wrapArgs args body') + where + body' = wrapReturn ret body + + wrapReturn Nothing b = b + wrapReturn (Just c) b = + withContractE (viewExprToAst c) b (SLambda ["r"] (SVar "r" Nothing)) errCont + + wrapArgs [] b = b + wrapArgs (DefBinder nm Nothing : rest) b = SLambda [nm] (wrapArgs rest b) + wrapArgs (DefBinder nm (Just c) : rest) b = + SLambda [nm] $ + withContractE (viewExprToAst c) (SVar nm Nothing) + (SLambda [nm] (wrapArgs rest b)) + errCont + wrapArgs (DefPhantom _ : _) _ = + error "phantom contract arguments are not yet supported by the frontend" + + errCont = SLambda ["msg"] (SVar "msg" Nothing) + +-- | Turn a source annotation expression into an ordinary AST expression. +-- Contract annotations are written with the same surface syntax as terms, +-- so the mapping is mostly structural. +viewExprToAst :: ViewExpr -> TricuAST +viewExprToAst = \case + VEName s -> SVar s Nothing + VEVar s -> SVar s Nothing + VEInt i -> SInt i + VEString s -> SStr s + VEList es -> SList (map viewExprToAst es) + VEApp f a -> SApp (viewExprToAst f) (viewExprToAst a) + VERaw s -> SStr s + VEVarId _ -> error "view variable ids are not supported by the frontend" + VEForall _ _ -> error "forall annotations are not supported by the frontend" + VEExists _ _ -> error "exists annotations are not supported by the frontend" + +-- | Build an application of 'withContract' from the contract library. +withContractE :: TricuAST -> TricuAST -> TricuAST -> TricuAST -> TricuAST +withContractE contract value onOk onFail = + SApp + (SApp + (SApp + (SApp (SVar "withContract" Nothing) contract) + value) + onOk) + onFail diff --git a/src/Lexer.hs b/src/Lexer.hs index ef58f13..8014e7f 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -36,6 +36,7 @@ tricuLexer = do , try dot , try identifierWithHash , try keywordT + , try lExport , try identifier , try namespace , try integerLiteral @@ -130,6 +131,9 @@ lImport = do name <- importAlias return (LImport path name) +lExport :: Lexer LToken +lExport = string "!export" *> notFollowedBy alphaNumChar $> LExport + importAlias :: Lexer String importAlias = string "!Local" <|> do first <- letterChar <|> char '_' diff --git a/src/Main.hs b/src/Main.hs index 30ce69e..d3d9947 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,18 +1,16 @@ module Main where -import Check (checkFile, checkFileWithStore, instrumentIOContinuations) import ContentStore import ContentStore.Bundle import Module.Manifest import System.Exit (die) import Eval (evalTricu, mainResult, result) import FileEval - ( ContractMode(..) - , LoadedSource(..) + ( LoadedSource(..) , defaultStorePath - , evaluateFileWithContextWithStoreAndMode + , evaluateFileWithContextWithStore , evaluateFileWithStore - , loadFileWithStoreMode + , loadFileWithStore , compileFileWithStore ) import IODriver (IOPermissions(..), runIO) @@ -47,16 +45,11 @@ data AppArgs = AppArgs data TricuArgs = Repl - | Check - { checkInput :: FilePath - , checkStore :: Maybe FilePath - } | Eval { evalFiles :: [FilePath] , evalStore :: Maybe FilePath , evalFormat :: EvaluatedForm , evalOutput :: FilePath - , evalUnchecked :: Bool , evalIo :: Bool , evalAllowRead :: [FilePath] , evalAllowWrite :: [FilePath] @@ -112,16 +105,6 @@ 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...")) @@ -145,10 +128,6 @@ evalParser = Eval <> value "" <> help "Write output to file instead of stdout" ) - <*> 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" @@ -325,9 +304,7 @@ tricuParser = AppArgs <**> infoOption versionStr (long "version" <> help "Show version")) where topCommands = mconcat - [ command "check" (info (checkParser <**> helper) - (progDesc "Check View Contract annotations and report ok or diagnostics")) - , command "eval" (info (evalParser <**> helper) + [ 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")) @@ -374,7 +351,6 @@ main = do args = applyGlobalStore mGlobalStore (appCommand appArgs) case args of Repl -> runReplWithStore mGlobalStore - Check {} -> runCheck args Eval {} -> runEval args ArboricxCompile {} -> runCompile args ArboricxImport {} -> runImport args @@ -390,7 +366,6 @@ main = do applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs applyGlobalStore mGlobal args = case args of Repl -> Repl - Check {} -> args { checkStore = preferLocal (checkStore args) } Eval {} -> args { evalStore = preferLocal (evalStore args) } ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) } ArboricxImport {} -> args { importStore = preferLocal (importStore args) } @@ -413,22 +388,6 @@ runReplWithStore mStore = do Nothing -> repl Just store -> replWithStore (StorePath store) -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 @@ -441,12 +400,7 @@ runEval opts = do return $ result env _ -> do 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 + finalEnv <- foldM (evaluateFileWithContextWithStore mStoreOpt) Map.empty files return $ mainResult finalEnv finalT <- if evalIo opts then do @@ -489,7 +443,6 @@ runImport opts = do (treeTermRef root) "arboricx.abi.tree.v1" Nothing - Nothing | (name, root) <- roots ] moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts) diff --git a/src/Module/Manifest.hs b/src/Module/Manifest.hs index 2b5ad81..ce339f2 100644 --- a/src/Module/Manifest.hs +++ b/src/Module/Manifest.hs @@ -12,7 +12,6 @@ module Module.Manifest import ContentStore.Filesystem (getObject, putObject) import ContentStore.Object import ContentStore.Alias (ObjectRef(..)) -import Research (ViewProvenance(..)) import Data.ByteString (ByteString) import Data.Text (Text) @@ -36,13 +35,13 @@ data ModuleReference = ModuleReference , moduleReferenceRef :: ObjectRef } deriving (Eq, Ord, Show) --- | Exported executable artifact plus optional direct View Contract type. +-- | Exported executable artifact. Optional contract terms are ordinary tree +-- terms referenced from elsewhere in the store, not a special artifact kind. data ModuleExport = ModuleExport - { moduleExportName :: Text - , moduleExportObject :: ObjectRef - , moduleExportAbi :: Text - , moduleExportView :: Maybe ObjectRef - , moduleExportViewProvenance :: Maybe ViewProvenance + { moduleExportName :: Text + , moduleExportObject :: ObjectRef + , moduleExportAbi :: Text + , moduleExportContract :: Maybe ObjectRef } deriving (Eq, Ord, Show) manifestDomain :: Domain @@ -60,16 +59,17 @@ encodeManifest manifest = encodeUtf8 $ Text.unlines $ , 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) - , maybe "-" encodeProvenance (moduleExportViewProvenance ex) - ] + encodeExport ex = + let base = Text.intercalate "\t" + [ "export" + , esc (moduleExportName ex) + , esc (objectRefKind $ moduleExportObject ex) + , esc (objectRefHash $ moduleExportObject ex) + , esc (moduleExportAbi ex) + ] + in case moduleExportContract ex of + Nothing -> base + Just ref -> base <> "\t" <> esc (objectRefKind ref) <> "\t" <> esc (objectRefHash ref) -- | Parse the canonical manifest encoding. decodeManifest :: ByteString -> Either String ModuleManifest @@ -87,27 +87,19 @@ decodeManifest bs = do ["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 - -- Legacy manifests predate explicit View Contract provenance. Keep - -- the decoded field absent; checker import code treats absent - -- provenance as ViewUnchecked/Assumed at the use boundary. - view <- optionalRef viewKind viewHash + ["export", name, kind, hash, abi] -> do ex <- ModuleExport <$> unesc name <*> (ObjectRef <$> unesc kind <*> unesc hash) <*> unesc abi - <*> pure view <*> pure Nothing Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] } - ["export", name, kind, hash, abi, viewKind, viewHash, provenanceText] -> do - view <- optionalRef viewKind viewHash - provenance <- optionalProvenance provenanceText + ["export", name, kind, hash, abi, ckind, chash] -> do ex <- ModuleExport <$> unesc name <*> (ObjectRef <$> unesc kind <*> unesc hash) <*> unesc abi - <*> pure view - <*> pure provenance + <*> (Just <$> (ObjectRef <$> unesc ckind <*> unesc chash)) Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] } _ -> Left $ "invalid module manifest row: " ++ Text.unpack line @@ -123,22 +115,6 @@ getManifest store h = do 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) - -encodeProvenance :: ViewProvenance -> Text -encodeProvenance ViewChecked = "checked" -encodeProvenance ViewTrusted = "trusted" -encodeProvenance ViewUnchecked = "unchecked" - -optionalProvenance :: Text -> Either String (Maybe ViewProvenance) -optionalProvenance "-" = Right Nothing -optionalProvenance "checked" = Right (Just ViewChecked) -optionalProvenance "trusted" = Right (Just ViewTrusted) -optionalProvenance "unchecked" = Right (Just ViewUnchecked) -optionalProvenance other = Left $ "invalid View Contract provenance: " ++ Text.unpack other - esc :: Text -> Text esc = Text.concatMap $ \c -> case c of '%' -> "%25" diff --git a/src/Module/Resolver.hs b/src/Module/Resolver.hs index 5920162..22e9a01 100644 --- a/src/Module/Resolver.hs +++ b/src/Module/Resolver.hs @@ -9,7 +9,6 @@ module Module.Resolver import ContentStore.Alias import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain) -import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm) import ContentStore.Object import ContentStore.Resolver import Module.Manifest @@ -20,15 +19,14 @@ 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. +-- The executable term is loaded directly; contract terms are not interpreted by +-- the resolver. data ResolvedExport = ResolvedExport { resolvedExportSourceName :: T.Text , resolvedExportLocalName :: String , resolvedExportObject :: ObjectRef , resolvedExportAbi :: T.Text - , resolvedExportView :: Maybe ObjectRef - , resolvedExportProvenance :: Maybe ViewProvenance + , resolvedExportContract :: Maybe ObjectRef , resolvedExportTerm :: T } deriving (Show, Eq) @@ -86,23 +84,14 @@ resolveModuleExport resolver namespace ex = do , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName) , resolvedExportObject = ref , resolvedExportAbi = moduleExportAbi ex - , resolvedExportView = moduleExportView ex - , resolvedExportProvenance = moduleExportViewProvenance ex + , resolvedExportContract = moduleExportContract 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" + bytes <- requireObject case decodeTreeTerm bytes of Left err -> errorWithoutStackTrace $ "Module export " ++ show (T.unpack sourceName) @@ -112,16 +101,15 @@ resolveExportTerm resolver sourceName ref | 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)) + ++ "; expected " ++ show (T.unpack (unDomain treeTermDomain)) where - requireObject label = do + requireObject = 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) + ++ " references missing tree term " ++ T.unpack (objectRefHash ref) ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")" resolvedModulesEnv :: [ResolvedModule] -> Env diff --git a/src/Parser.hs b/src/Parser.hs index 56f0a93..94add63 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -69,9 +69,12 @@ manyItemsP = do topItemP :: TokParser TricuAST topItemP = do toks <- getInput - case definitionHeadTop toks of - Just _ -> definitionP - Nothing -> exprTopP + case toks of + LExport : _ -> exportP + _ -> + case definitionHeadTop toks of + Just _ -> definitionP + Nothing -> exprTopP definitionHeadTop :: [LToken] -> Maybe (String, [String]) definitionHeadTop toks = @@ -218,6 +221,13 @@ importP = do isImport (LImport _ _) = True isImport _ = False +exportP :: TokParser TricuAST +exportP = do + void (tok (== LExport) "export") + name <- identifierNameP + mContract <- optional (tok (== LColon) ":" *> annotationTypeP) + pure (SExport name mContract) + exprTopP :: TokParser TricuAST exprTopP = do toks <- getInput diff --git a/src/REPL.hs b/src/REPL.hs index d3666b9..0740b6e 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -1,12 +1,10 @@ module REPL where -import Check (checkFileWithStore) import Eval (evalTricu, result) import FileEval - ( ContractMode(..) - , LoadedSource(..) + ( LoadedSource(..) , defaultStorePath - , loadFileWithStoreMode + , loadFileWithStore ) import Parser (parseTricu) import Research (EvaluatedForm(..), Env, formatT) @@ -35,14 +33,12 @@ import qualified Data.Map as Map import qualified Data.Text 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. +-- CLI. data REPLState = REPLState - { replForm :: EvaluatedForm - , replEnv :: Env - , replStore :: StorePath - , replContracts :: ContractMode - , replEnvRef :: IORef Env + { replForm :: EvaluatedForm + , replEnv :: Env + , replStore :: StorePath + , replEnvRef :: IORef Env } repl :: IO () @@ -56,7 +52,7 @@ replWithStore store = do , historyFile = Just "~/.local/state/tricu/history" , autoAddHistory = True } - runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef)) + runInputT settings (loop (REPLState Decode Map.empty store envRef)) where loop :: REPLState -> InputT IO () @@ -78,12 +74,10 @@ replWithStore store = do "!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) | "!use" `isPrefixOf` s -> handleUse state (strip $ drop 4 s) | "!name" `isPrefixOf` s -> handleName state (strip $ drop 5 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) @@ -102,9 +96,7 @@ replWithStore store = do outputStrLn " !load FILE - Load and evaluate a .tri file into the environment" outputStrLn " !use MODULE [NS] - Load a module alias/manifest from the store (NS defaults to !Local)" outputStrLn " !name NAME [LOCAL] - Load a name alias/tree-term hash from the store" - 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 () @@ -135,24 +127,12 @@ replWithStore store = do if not exists then outputStrLn ("File not found: " ++ path) >> loop state else do - loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path + loaded <- liftIO $ loadFileWithStore (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 - handleUse :: REPLState -> String -> InputT IO () handleUse state arg = case words arg of [] -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state @@ -205,23 +185,6 @@ replWithStore store = do outputStrLn $ "Store changed to: " ++ path loop state { replStore = StorePath path } - handleUnchecked :: REPLState -> String -> InputT IO () - handleUnchecked state arg = setUnchecked state arg - - setUnchecked :: REPLState -> String -> InputT IO () - setUnchecked state arg = case arg of - "" -> reportContracts state >> loop state - "on" -> setMode IgnoreContracts - "off" -> setMode EnforceContracts - _ -> outputStrLn "Usage: !unchecked [on|off]" >> loop state - where - setMode mode = do - outputStrLn $ contractModeMessage mode - loop state { replContracts = mode } - - reportContracts :: REPLState -> InputT IO () - reportContracts state = outputStrLn $ contractModeMessage (replContracts state) - handleEnv :: REPLState -> InputT IO () handleEnv state = case sort (Map.keys (replEnv state)) of @@ -263,12 +226,10 @@ completeRepl envRef input@(left, _right) , "!load" , "!use" , "!name" - , "!check" , "!store" - , "!unchecked" , "!env" ] - commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "] + commandWantsFile inputLine = "!load " `isPrefixOf` inputLine termBreakChars = " \t\n\r()[]{}\"'" outputFormats :: [EvaluatedForm] @@ -286,10 +247,6 @@ readEvaluatedForm s = case s of "string" -> Just StringLit _ -> Nothing -contractModeMessage :: ContractMode -> String -contractModeMessage EnforceContracts = "Contracts: on" -contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)" - storePathString :: StorePath -> FilePath storePathString (StorePath path) = path diff --git a/src/Research.hs b/src/Research.hs index 68501d3..5eb64c5 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -19,40 +19,10 @@ 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 ViewProvenance - = ViewChecked - | ViewTrusted - | ViewUnchecked - deriving (Show, Eq, Ord) - -data ViewType - = VTName String - | VTVar Integer - | VTRefRaw ViewRef - | VTList ViewType - | VTMaybe ViewType - | VTPair ViewType ViewType - | VTResult ViewType ViewType - | VTGuarded ViewType T - | VTForall [Integer] ViewType - | VTExists [Integer] ViewType - | 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, VTVar, VTRef, VTRefText, VTList, VTMaybe, VTPair, VTResult, VTGuarded, VTForall, VTExists, VTFn #-} - +-- Contract source annotations +-- ViewType, ViewRef, and ViewProvenance were removed with the old View Contract +-- checker. Source annotations are still parsed into ViewExpr but are not +-- interpreted by a separate static checker. data ViewExpr = VEName String | VEVar String @@ -91,6 +61,7 @@ data TricuAST | SLet String TricuAST TricuAST | SEmpty | SImport String String + | SExport String (Maybe ViewExpr) deriving (Show, Eq, Ord) -- Lexer Tokens @@ -100,6 +71,7 @@ data LToken | LKeywordT | LNamespace String | LImport String String + | LExport | LAssign | LAssignAt | LAt diff --git a/test/Spec.hs b/test/Spec.hs index ccfa5c1..21c7554 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,5 @@ module Main where -import Check import Eval import FileEval import Lexer @@ -49,16 +48,6 @@ 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" @@ -69,9 +58,10 @@ allTestLibsEnv = unsafePerformIO $ do 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]) + contracts <- evaluateFile "./lib/contracts.tri" + intensional <- evaluateFile "./lib/intensionalContracts.tri" + guarded <- evaluateFile "./lib/guardedBase.tri" + pure (Map.unions [base, list, bytes, bin, http, arbor, io, sock, contracts, intensional, guarded]) {-# NOINLINE allTestLibsEnv #-} tests :: TestTree @@ -80,22 +70,23 @@ tests = testGroup "Tricu Tests" , parser , simpleEvaluation , lambdas + , arithmetic , providedLibraries + , contractsTests , maybeTests , fileEval , demos - --, decoding - --, elimLambdaSingle - --, stressElimLambda - --, byteMarshallingTests - --, wireTests - --, tricuReaderTests - --, byteListUtilities - --, binaryParserTests - --, httpParsingTests - --, contentStoreTests - --, viewContractTests - --, ioDriverTests + , decoding + , elimLambdaSingle + , stressElimLambda + , byteMarshallingTests + , wireTests + , tricuReaderTests + , byteListUtilities + , binaryParserTests + , httpParsingTests + , contentStoreTests + , ioDriverTests ] lexer :: TestTree @@ -317,8 +308,14 @@ parser = testGroup "Parser Tests" (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 "Evaluate annotated definition applies runtime contract boundary" $ do + let input = unlines + [ "bool? = guardC \"not a boolean\" (b : or? (equal? b true) (equal? b false))" + , "id x@bool? =@bool? x" + , "main = id true" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT , testCase "Reject named binders after phantom annotations" $ do let tokens = lexTricu "foo @Bool x@Bool =@Bool x" @@ -1106,10 +1103,188 @@ providedLibraries = testGroup "Library Tests" let input = "unwords []" env = evalTricu allTestLibsEnv (parseTricu input) result env @?= ofString "" + + , testCase "intercalate joins fields" $ do + let input = "intercalate \", \" [(\"a\") (\"b\") (\"c\")]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "a, b, c" + + , testCase "intercalate leaves a lone field alone" $ do + let input = "intercalate \", \" [(\"a\")]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "a" + + , testCase "intercalate empty list" $ do + let input = "intercalate \", \" []" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "" + + , testCase "joinSuffix terminates every field" $ do + let input = "joinSuffix \"-\" [(\"a\") (\"b\")]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "a-b-" + + , testCase "splitOnByte splits on a byte" $ do + let input = "splitOnByte 58 \"a:b:c\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofString "a", ofString "b", ofString "c"] + + , testCase "splitOnByte keeps empty fields" $ do + let input = "splitOnByte 58 \"a::b\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofString "a", ofString "", ofString "b"] + + , testCase "splitOnByte trailing separator leaves an empty field" $ do + let input = "splitOnByte 58 \"a:\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofString "a", ofString ""] + + , testCase "splitOnByte without a match" $ do + let input = "splitOnByte 58 \"abc\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofString "abc"] + + , testCase "splitOnByte empty input" $ do + let input = "splitOnByte 58 \"\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofString ""] + + , testCase "intercalate round trips splitOnByte" $ do + let input = "equal? (intercalate \":\" (splitOnByte 58 \"a:b:c\")) \"a:b:c\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "takeWhile keeps the matching prefix" $ do + let input = "takeWhile (n : lt? n 3) [(1) (2) (3) (1)]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofNumber 1, ofNumber 2] + + , testCase "takeWhile stops at the first mismatch" $ do + let input = "takeWhile (n : lt? n 3) [(3) (1)]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [] + + , testCase "dropWhile drops the matching prefix" $ do + let input = "dropWhile (n : lt? n 3) [(1) (2) (3) (1)]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [ofNumber 3, ofNumber 1] + + , testCase "dropWhile on an all matching list" $ do + let input = "dropWhile (n : lt? n 3) [(1) (2)]" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofList [] + + , testCase "trim strips surrounding spaces and tabs" $ do + let input = "trim \" \\ttrimmed \\t\"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "trimmed" + + , testCase "trim leaves interior bytes alone" $ do + let input = "trim \" a b \"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "a b" + + , testCase "trim all whitespace is empty" $ do + let input = "trim \" \\t \"" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "" ] -arithmeticTests :: TestTree -arithmeticTests = testGroup "Arithmetic Tests" +contractsTests :: TestTree +contractsTests = testGroup "Contracts library tests" + [ testCase "anyC passes any value" $ do + let input = "main = resultIsOk (checkContract anyC 7)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "guardC rejects failures" $ do + let input = "main = resultIsErr (checkContract (guardC \"odd\" even?) 5)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "andC combines contracts" $ do + let input = "main = resultIsOk (checkContract (andC (guardC \"odd\" odd?) (guardC \"gt0\" (n : gt? n 0))) 5)" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "listOf checks every element" $ do + let input = "main = resultIsOk (checkContract (listOf (guardC \"odd\" odd?)) [1 3 5])" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "fnContract wraps a function" $ do + let input = "main = resultIsOk (checkContract (fnContract (guardC \"odd\" odd?) anyC) (x : x))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "runM reduces pureM" $ do + let input = "main = resultIsOk (runM (pureM 42))" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "do notation chains checkM and pureM" $ do + let input = unlines + [ "program = (xs :" + , " do bindM" + , " n <- pureM (length xs)" + , " _ <- checkM (guardC \"positive\" (n : gte? n 1)) n" + , " pureM n)" + , "main = runM (program [1 2 3 4])" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + decodeResult (result env) @?= "[t t, 4]" + + , testCase "handleM replaces exception with a new action" $ do + let input = unlines + [ "lookupConfig = (key defaultValue :" + , " exceptE \"missing\" key (resume : pureM defaultValue))" + , "pipeline = (xs :" + , " do bindM" + , " divisor <- lookupConfig \"divisor\" 1" + , " total <- pureM (sum xs)" + , " scaled <- liftM (x : div x divisor) total" + , " pureM scaled)" + , "handled = handleM \"missing\" (key k : pureM 2) (pipeline [10 20 30])" + , "main = runM handled" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + decodeResult (result env) @?= "[t t, 30]" + + , testCase "=@ return annotation passes" $ do + let input = unlines + [ "five =@anyC 5" + , "main = five" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "=@ return annotation fails" $ do + let input = unlines + [ "boom =@(neverC \"boom\") 5" + , "main = boom" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "boom" + + , testCase "@ argument annotation passes" $ do + let input = unlines + [ "idNat x@anyC =@anyC x" + , "main = idNat 5" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "@ argument annotation fails" $ do + let input = unlines + [ "idNat x@(neverC \"bad\") =@anyC x" + , "main = idNat 5" + ] + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofString "bad" + ] + +arithmetic :: TestTree +arithmetic = testGroup "Arithmetic Tests" [ testCase "isZero? on 0" $ do let input = "isZero? 0" env = evalTricu allTestLibsEnv (parseTricu input) @@ -1289,6 +1464,181 @@ arithmeticTests = testGroup "Arithmetic Tests" let input = "isZero? (add 0 0)" env = evalTricu allTestLibsEnv (parseTricu input) result env @?= trueT + + , testCase "div 10 3 = 3" $ do + let input = "div 10 3" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 3 + + , testCase "div 12 4 = 3 (exact)" $ do + let input = "div 12 4" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 3 + + , testCase "div 3 5 = 0 (divisor larger)" $ do + let input = "div 3 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "div 7 1 = 7 (identity)" $ do + let input = "div 7 1" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 7 + + , testCase "div 0 5 = 0" $ do + let input = "div 0 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "div 5 0 = 0 (div by zero)" $ do + let input = "div 5 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "mod 10 3 = 1" $ do + let input = "mod 10 3" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 1 + + , testCase "mod 12 4 = 0 (exact)" $ do + let input = "mod 12 4" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "mod 3 5 = 3 (divisor larger)" $ do + let input = "mod 3 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 3 + + , testCase "mod 7 1 = 0" $ do + let input = "mod 7 1" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "mod 5 0 = 0 (mod by zero)" $ do + let input = "mod 5 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "div mod consistency" $ do + let input = "equal? (add (mul 3 7) 4) 25" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "pow 2 0 = 1" $ do + let input = "pow 2 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 1 + + , testCase "pow 2 3 = 8" $ do + let input = "pow 2 3" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 8 + + , testCase "pow 3 2 = 9" $ do + let input = "pow 3 2" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 9 + + , testCase "pow 0 0 = 1" $ do + let input = "pow 0 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 1 + + , testCase "pow 0 5 = 0" $ do + let input = "pow 0 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "pow 1 10 = 1" $ do + let input = "pow 1 10" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 1 + + , testCase "pow 5 1 = 5" $ do + let input = "pow 5 1" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "min 3 7 = 3" $ do + let input = "min 3 7" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 3 + + , testCase "min 7 3 = 3" $ do + let input = "min 7 3" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 3 + + , testCase "min 5 5 = 5" $ do + let input = "min 5 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "min 0 5 = 0" $ do + let input = "min 0 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 0 + + , testCase "max 3 7 = 7" $ do + let input = "max 3 7" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 7 + + , testCase "max 7 3 = 7" $ do + let input = "max 7 3" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 7 + + , testCase "max 5 5 = 5" $ do + let input = "max 5 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "max 0 5 = 5" $ do + let input = "max 0 5" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= ofNumber 5 + + , testCase "even? 0 = true" $ do + let input = "even? 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "even? 1 = false" $ do + let input = "even? 1" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= falseT + + , testCase "even? 2 = true" $ do + let input = "even? 2" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "even? 7 = false" $ do + let input = "even? 7" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= falseT + + , testCase "odd? 0 = false" $ do + let input = "odd? 0" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= falseT + + , testCase "odd? 1 = true" $ do + let input = "odd? 1" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT + + , testCase "odd? 2 = false" $ do + let input = "odd? 2" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= falseT + + , testCase "odd? 7 = true" $ do + let input = "odd? 7" + env = evalTricu allTestLibsEnv (parseTricu input) + result env @?= trueT ] fileEval :: TestTree @@ -1325,6 +1675,12 @@ demos = testGroup "Test provided demo functionality" , testCase "Level Order Traversal demo" $ do res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri" decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \"" + , testCase "Contract effect demo with do notation" $ do + res <- liftIO $ evaluateFileResult "./demos/contractEffects.tri" + decodeResult res @?= "[t t, 10]" + , testCase "Safe base wrappers demo" $ do + res <- liftIO $ evaluateFileResult "./demos/safeBaseWrappers.tri" + decodeResult res @?= "[t t, 1]" ] decoding :: TestTree @@ -1579,56 +1935,6 @@ contentStoreTests = testGroup "Content Store Tests" 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")) - (Just ViewChecked) - ] - encoded = encodeManifest manifest - decodeManifest encoded @?= Right manifest - hashObject manifestDomain encoded @?= "1392e0d406d5d1f2e013b0bff27ec3def4f68c045c75780ccb0380a1995f42c7" - - , 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 quantified views" $ do - let view = VTForall [0] (VTFn [VTVar 0] (VTVar 0)) - decodeViewType (encodeViewType view) @?= Right view - treeToViewType (viewTypeToTree 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 @@ -1639,7 +1945,6 @@ contentStoreTests = testGroup "Content Store Tests" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing - Nothing ] root <- putTreeTerm store term h <- putManifest store (manifestFor root) @@ -1657,7 +1962,6 @@ contentStoreTests = testGroup "Content Store Tests" (ObjectRef (unDomain treeTermDomain) termH) "arboricx.abi.tree.v1" Nothing - Nothing ] manifestBytes = encodeManifest manifest manifestH = hashObject manifestDomain manifestBytes @@ -1690,206 +1994,6 @@ contentStoreTests = testGroup "Content Store Tests" 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") @@ -1911,6 +2015,33 @@ contentStoreTests = testGroup "Content Store Tests" Nothing -> assertFailure "expected workspace module manifest" Just manifest -> map moduleExportName (moduleManifestExports manifest) @?= ["value"] + , testCase "Workspace modules: explicit !export with contract" $ + withSystemTempDirectory "tricu-workspace-explicit-export" $ \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 "alwaysOk = (x : x)\n\naddOne x = x\n!export addOne : alwaysOk\n" + writeFile mainPath "!import \"util\" Util\n\nmain = Util.addOne 5\n" + env <- evaluateFileWithStore (Just store) mainPath + result env @?= ofNumber 5 + 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 + map moduleExportName (moduleManifestExports manifest) @?= ["addOne"] + case moduleManifestExports manifest of + [ex] -> do + assertBool "expected contract ref" (moduleExportContract ex /= Nothing) + case moduleExportContract ex of + Just cref -> objectRefKind cref @?= unDomain treeTermDomain + Nothing -> assertFailure "expected contract ref" + _ -> assertFailure "expected exactly one export" + , testCase "Module imports: resolve manifest exports from store" $ withSystemTempDirectory "tricu-module-import" $ \dir -> do let store = StorePath (dir "store") @@ -1922,7 +2053,6 @@ contentStoreTests = testGroup "Content Store Tests" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing - Nothing ] root <- putTreeTerm store term manifestHash <- putManifest store (manifestFor root) @@ -1955,7 +2085,7 @@ contentStoreTests = testGroup "Content Store Tests" , 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 Nothing ] + [ 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") @@ -2002,9 +2132,6 @@ reconstructBundleTermsForTest nodes = V.fromList (go <$> Foldable.toList nodes) 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 @@ -2580,759 +2707,6 @@ binaryParserTests = testGroup "Binary Parser Tests" 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 35 (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")) ViewChecked] - 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")) ViewChecked] - 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")) ViewChecked] - case lowerSourceWithImportedViews imported "foo x@Bool =@Bool Ext.id x\n" of - Left err -> assertFailure err - Right lowered -> lowered @?= "typedProgram 3 [(typedValueWithProvenance 1 (viewFn [(viewBool)] (viewBool)) t viewProvenanceChecked) (typedValueWithProvenance 0 (viewFn [(viewBool)] (viewBool)) t viewProvenanceChecked) (typedValueWithProvenance 2 (viewBool) t viewProvenanceChecked) (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 [(typedValueWithProvenance 0 (viewFn [(viewRef \"UserId\")] (viewRef \"UserId\")) t viewProvenanceChecked) (typedValueWithProvenance 1 (viewRef \"UserId\") t viewProvenanceChecked) (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 - , resolvedExportProvenance = Just ViewChecked - , 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")) ViewChecked] - output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n" - output @?= "ok" - - , testCase "tricu check marks missing import provenance as unchecked" $ 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 - , resolvedExportProvenance = Nothing - , 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")) ViewUnchecked] - - , 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 - , resolvedExportProvenance = Just ViewChecked - , 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" $ - "typedValueWithProvenance 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" $ - "typedValueWithProvenance 1 (viewString) t viewProvenanceChecked" `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" $ - "typedValueWithProvenance 1 (viewByte)" `isInfixOf` lowered - assertBool "expected actual Byte tree payload for literal element" $ - "typedValueWithProvenance 1 (viewByte) (t (t t) t) viewProvenanceChecked" `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" $ - "typedValueWithProvenance 12 (viewFn [(viewString)] (viewMaybe (viewString))) t viewProvenanceChecked" `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")) ViewChecked] - 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")) ViewChecked] - 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" - moduleExportViewProvenance ex @?= Just ViewChecked - 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) - viewTreeRootViewFact tree @?= Right (Just (expectedView, ViewChecked)) - tree @?= singletonViewTreeWithProvenance (Just (expectedView, ViewChecked)) 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 rejects polymorphic View variables" $ do - case lowerSource "idP x@_a =@_a x\n" of - Left err -> assertBool "expected unsupported polymorphism diagnostic" $ "polymorphic View variables are unsupported" `isInfixOf` err - Right _ -> assertFailure "expected polymorphic View rejection" - - , 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 -- -------------------------------------------------------------------------- @@ -3340,62 +2714,7 @@ viewContractTests = testGroup "View Contract Tests" ioDriverTests :: TestTree ioDriverTests = testGroup "IO driver tests" [ -- Existing behaviour tests - 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" $ + testCase "readFile through onReadFile returns file contents" $ withSystemTempDirectory "tricu-io-read" $ \dir -> do let sourcePath = dir ++ "/input.txt" writeFile sourcePath "abc123" @@ -4771,11 +4090,9 @@ withFreePort action = runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T) runIOSourceWith perms readerEnv initialState source = do - checkedAst <- case instrumentIOContinuations (parseTricu source) of - Left err -> assertFailure err - Right asts -> pure asts - let evalEnv = evalTricu allTestLibsEnv checkedAst - let fullTree = mainResult evalEnv + let asts = parseTricu source + evalEnv = evalTricu allTestLibsEnv asts + fullTree = mainResult evalEnv result <- runIOWith perms readerEnv initialState fullTree case result of Left err -> assertFailure ("IO runtime error: " ++ err) diff --git a/tricu.cabal b/tricu.cabal index 0644862..40488d6 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -62,9 +62,6 @@ executable tricu , vector , zlib other-modules: - Check - Check.Core - Check.IO ContentStore ContentStore.Alias ContentStore.Arboricx @@ -72,10 +69,9 @@ executable tricu ContentStore.Filesystem ContentStore.Object ContentStore.Resolver - ContentStore.ViewTree - ContentStore.ViewContract Eval FileEval + Frontend.ContractDesugar IODriver Lexer Module.Manifest @@ -113,6 +109,7 @@ benchmark tricu-bench , memory , mtl , network + , stm , text , time , transformers @@ -128,10 +125,9 @@ benchmark tricu-bench ContentStore.Filesystem ContentStore.Object ContentStore.Resolver - ContentStore.ViewTree - ContentStore.ViewContract Eval FileEval + Frontend.ContractDesugar IODriver Lexer Module.Manifest @@ -181,9 +177,6 @@ test-suite tricu-tests , zlib default-language: Haskell2010 other-modules: - Check - Check.Core - Check.IO ContentStore ContentStore.Alias ContentStore.Arboricx @@ -191,10 +184,9 @@ test-suite tricu-tests ContentStore.Filesystem ContentStore.Object ContentStore.Resolver - ContentStore.ViewTree - ContentStore.ViewContract Eval FileEval + Frontend.ContractDesugar IODriver Lexer Module.Manifest diff --git a/tricu.workspace b/tricu.workspace index 7f22bad..e48bc96 100644 --- a/tricu.workspace +++ b/tricu.workspace @@ -3,15 +3,15 @@ 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 contracts = lib/contracts.tri +module intensional = lib/intensionalContracts.tri +module guarded = lib/guardedBase.tri module arboricx.common = lib/arboricx/common.tri module arboricx.nodes = lib/arboricx/nodes.tri module arboricx.manifest = lib/arboricx/manifest.tri