commit 78b6c3ae61805a259764418d7f33187f00ed19a1
parent 69b0da8c8068c2d88e97024643d7242494468cdd
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 17:21:14 -0500
Retire recovery compilation from parser tests and benchmark execution
Diffstat:
10 files changed, 518 insertions(+), 421 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -76,7 +76,9 @@ observations as historical evidence.
**tricu** (pronounced "tree-shoe") is a programming-language experiment written primarily in Haskell.
-Core types are in `src/Research.hs`.
+Runtime trees and reduction are in `src/Runtime/Tree.hs`; `src/Runtime.hs` is the
+source-free host API. `src/Research.hs` is a recovery-only frontend facade for
+unmigrated tests.
### File extensions
diff --git a/bench/ApplyStats.hs b/bench/ApplyStats.hs
@@ -11,7 +11,7 @@ module ApplyStats
, printApplyStats
) where
-import Research
+import Runtime
import qualified Data.Map.Strict as M
import qualified Data.List as L
import Data.Ord (comparing)
diff --git a/bench/Bench.hs b/bench/Bench.hs
@@ -1,80 +1,70 @@
-{-# LANGUAGE BangPatterns #-}
module Main where
import Control.Exception (evaluate)
import Control.Monad (forM_, unless)
import Criterion.Main
+import Crypto.Hash (hash, Digest, SHA256)
+import Runtime
+import TreeObservation (forceTreeShared)
+import Wire
+import qualified Data.ByteString as BS
import qualified Data.Map as Map
+import qualified Data.Text as Text
+import qualified Data.Vector as V
+import System.Environment (getArgs, withArgs)
+import System.Exit (die)
+import System.Timeout (timeout)
-import Eval
-import FileEval
-import Parser
-import Research
-
--- These libraries own list operations, contracts and structural predicates.
--- Keep checked examples here rather than depending on a separate guarded library.
-cases :: [(String, String, T)]
+-- Runtime inputs and complete expectations are independent of worker compilation.
+-- These replace the historical parsing/evaluation timings, not reproduce them.
+cases :: [(String, String, T, T)]
cases =
- [ ("unchecked head", "matchList t (h _ : h) [1 2 3 4 5]", ofNumber 1)
- , ("head (explicit check)",
- "bindResult (checkContract (nonEmptyListOf anyC) [1 2 3 4 5]) (xs _ : ok (matchList t (h _ : h) xs) t)",
- okT (ofNumber 1))
- , ("div (library guards)", "div 10 2", ofNumber 5)
- , ("div (nonzero boundary)",
- "bindResult (checkContract nonZero? 2) (n _ : ok (div 10 n) t)",
- okT (ofNumber 5))
- , ("div failure (zero boundary)",
- "bindResult (checkContract nonZero? 0) (n _ : ok (div 10 n) t)",
- errT "non-zero")
- , ("sorted maximum",
- "bindResult (checkContract (sortedList? nat?) [1 2 3 4 5]) (xs _ : ok (foldl max 0 xs) t)",
- okT (ofNumber 5))
- , ("half (even boundary)",
- "bindResult (checkContract evenC? 8) (n _ : ok (div n 2) t)",
- okT (ofNumber 4))
- , ("sortedList? success",
- "bindResult (withContract (sortedList? nat?) [1 2 3 4 5]) (xs _ : ok (sum xs) t)",
- okT (ofNumber 15))
- , ("sortedList? failure",
- "bindResult (withContract (sortedList? nat?) [5 1 3]) (xs _ : ok (sum xs) t)",
- errT "not sorted")
- , ("listOf nat? success",
- "bindResult (withContract (listOf nat?) [1 2 3 4 5]) (xs _ : ok (sum xs) t)",
- okT (ofNumber 15))
- , ("fn2 apply add",
- "bindResult (fn2 nat? nat? nat? add t) (f _ : bindResult (f 3 t) (g _ : g 5 t))",
- okT (ofNumber 8))
- , ("fnContract apply identity",
- "bindResult (fnContract nat? nat? (x : x) t) (f _ : f 7 t)",
- okT (ofNumber 7))
+ [ ("unchecked head", "uncheckedHead", numbers [1..5], ofNumber 1)
+ , ("head (explicit check)", "checkedHead", numbers [1..5], ok (ofNumber 1))
+ , ("div (library guards)", "guardedDiv", ofNumber 2, ofNumber 5)
+ , ("div (nonzero boundary)", "checkedDiv", ofNumber 2, ok (ofNumber 5))
+ , ("div failure (zero boundary)", "checkedDiv", Leaf, err "non-zero")
+ , ("sorted maximum", "sortedMaximum", numbers [1..5], ok (ofNumber 5))
+ , ("half (even boundary)", "evenHalf", ofNumber 8, ok (ofNumber 4))
+ , ("sortedList? success", "sortedSum", numbers [1..5], ok (ofNumber 15))
+ , ("sortedList? failure", "sortedSum", numbers [5,1,3], err "not sorted")
+ , ("listOf nat? success", "naturalSum", numbers [1..5], ok (ofNumber 15))
+ , ("fn2 apply add", "checkedAdd", ofNumber 3, ok (ofNumber 8))
+ , ("fnContract apply identity", "checkedIdentity", ofNumber 7, ok (ofNumber 7))
]
where
- okT value = Fork (Stem Leaf) (Fork value Leaf)
- errT message = Fork Leaf (Fork (ofString message) Leaf)
+ numbers = ofList . map ofNumber
+ ok value = Fork (Stem Leaf) (Fork value Leaf)
+ err message = Fork Leaf (Fork (ofString message) Leaf)
--- Criterion applies an already compiled worker to a runtime argument. Forcing
--- the host Bool observes the complete canonical Boolean, not just a Result tag
--- in WHNF. Inputs are prepared once; no parsing/importing is inside the timer.
-{-# NOINLINE observeBoundary #-}
-observeBoundary :: T -> T -> Bool
-observeBoundary worker input = apply worker input == Stem Leaf
+-- The runtime argument remains outside the timed closure. Observing this Bool
+-- demands the entire expected canonical result, rather than only its outer tag.
+{-# NOINLINE observeResult #-}
+observeResult :: T -> T -> T -> Bool
+observeResult worker expected input = apply worker input == expected
-forceTree :: T -> ()
-forceTree Leaf = ()
-forceTree (Stem x) = forceTree x
-forceTree (Fork x y) = forceTree x `seq` forceTree y
+loadWorkers :: FilePath -> String -> IO Env
+loadWorkers path expected = do
+ unless (length expected == 64 && all (`elem` ("0123456789abcdef" :: String)) expected) $
+ die "expected a lowercase whole-bundle SHA256"
+ bytes <- BS.readFile path
+ unless (show (hash bytes :: Digest SHA256) == expected) $ die "worker bundle SHA256 mismatch"
+ bundle <- either die pure (decodeBundle bytes)
+ either die pure (verifyBundle bundle)
+ let terms = reconstructBundleTerms (bundleNodes bundle)
+ entries = manifestExports (bundleManifest bundle)
+ env = Map.fromList [(Text.unpack (exportName entry), terms V.! fromIntegral (exportRoot entry)) | entry <- entries]
+ wanted = Map.fromList [(name, ()) | (_, name, _, _) <- cases] `Map.union`
+ Map.fromList [(name, ()) | name <- ["uncheckedHash", "inlineHash", "contractHash"]]
+ unless (Map.size env == length entries && Map.keysSet env == Map.keysSet wanted) $
+ die "worker bundle must have exactly the benchmark export interface"
+ -- Loaded trees are inert/shared. Fully construct all workers before timing.
+ mapM_ forceTreeShared (Map.elems env)
+ pure env
-registryBenches :: IO Benchmark
-registryBenches = do
- server <- evaluateFile "lib/arboricx/server.tri"
- base <- evaluateFile "lib/base.tri"
- let env = Map.union server base
- compile = result . evalTricu env . parseTricu
- workers =
- [ ("unchecked", compile "hash : true")
- , ("inline", env Map.! "bundleHashValid?")
- , ("contract", compile "hash : resultIsOk (checkContract bundleHashC hash)")
- ]
+prepare :: Env -> IO [Benchmark]
+prepare env = do
+ let worker name = env Map.! name
valid = concat (replicate 4 "0123456789abcdef")
inputs =
[ ("valid", ofString valid, True)
@@ -83,31 +73,38 @@ registryBenches = do
, ("oversized-65", ofString (replicate 65 'a'), False)
, ("oversized-65536", ofString (replicate 65536 'a'), False)
]
+ hashWorkers = [("unchecked", "uncheckedHash"), ("inline", "inlineHash"), ("contract", "contractHash")]
+ expectedHash name validInput = if name == "unchecked" || validInput then Stem Leaf else Leaf
+ forM_ cases $ \(label, name, input, expected) -> do
+ forceTreeShared input
+ forceTreeShared expected
+ validCase <- evaluate (observeResult (worker name) expected input)
+ unless validCase $ die ("invalid contract benchmark: " ++ label)
forM_ inputs $ \(_, input, expected) -> do
- -- Force the input before timing, including the oversized suffix.
- _ <- evaluate (forceTree input)
- forM_ workers $ \(label, worker) ->
- unless (observeBoundary worker input == (label == "unchecked" || expected)) $
- error ("invalid registry boundary benchmark: " ++ label)
- pure $ bgroup "registry-hash"
- [ bgroup name
- [ bench label $ whnf (observeBoundary worker) input
- | (label, worker) <- workers ]
- | (name, input, _) <- inputs ]
+ forceTreeShared input
+ forM_ hashWorkers $ \(label, name) -> do
+ validCase <- evaluate (observeResult (worker name) (expectedHash label expected) input)
+ unless validCase $ die ("invalid registry boundary benchmark: " ++ label)
+ pure
+ [ bgroup "contracts"
+ [ bench label $ whnf (observeResult (worker name) expected) input
+ | (label, name, input, expected) <- cases ]
+ , bgroup "registry-hash"
+ [ bgroup label
+ [ bench workerLabel $ whnf (observeResult (worker name) (expectedHash workerLabel expected)) input
+ | (workerLabel, name) <- hashWorkers ]
+ | (label, input, expected) <- inputs ]
+ ]
main :: IO ()
main = do
- !baseLib <- evaluateFile "lib/base.tri"
- !intLib <- evaluateFile "lib/intensionalContracts.tri"
- let !env = Map.union intLib baseLib
- run = result . evalTricu env . parseTricu
- -- Refuse to time missing names or obsolete contract application shapes.
- forM_ cases $ \(label, source, expected) ->
- unless (run source == expected) $
- error $ "invalid contract benchmark: " ++ label
- registry <- registryBenches
- defaultMain
- [ bgroup "contracts"
- [ bench label $ whnf run source | (label, source, _) <- cases ]
- , registry
- ]
+ args <- getArgs
+ case args of
+ path : digest : criterionArgs -> do
+ prepared <- timeout (120 * 1000000) (loadWorkers path digest >>= prepare)
+ benchmarks <- maybe (die "benchmark loading/validation exceeded 120 seconds") pure prepared
+ putStrLn ("Worker bundle SHA256: " ++ digest)
+ if criterionArgs == ["--verify-only"]
+ then putStrLn "All 27 benchmark cases validated; no timings collected."
+ else withArgs criterionArgs (defaultMain benchmarks)
+ _ -> die "usage: tricu-bench WORKERS.arboricx SHA256 [--verify-only | CRITERION_OPTIONS]"
diff --git a/bench/workers.tri b/bench/workers.tri
@@ -0,0 +1,19 @@
+!import base *
+!import intensional *
+!import server as Registry
+!export *
+
+uncheckedHead input = matchList t (h _ : h) input
+checkedHead input = bindResult (checkContract (nonEmptyListOf anyC) input) (xs _ : ok (matchList t (h _ : h) xs) t)
+guardedDiv input = div 10 input
+checkedDiv input = bindResult (checkContract nonZero? input) (n _ : ok (div 10 n) t)
+sortedMaximum input = bindResult (checkContract (sortedList? nat?) input) (xs _ : ok (foldl max 0 xs) t)
+evenHalf input = bindResult (checkContract evenC? input) (n _ : ok (div n 2) t)
+sortedSum input = bindResult (withContract (sortedList? nat?) input) (xs _ : ok (sum xs) t)
+naturalSum input = bindResult (withContract (listOf nat?) input) (xs _ : ok (sum xs) t)
+checkedAdd input = bindResult (fn2 nat? nat? nat? add t) (f _ : bindResult (f input t) (g _ : g 5 t))
+checkedIdentity input = bindResult (fnContract nat? nat? (x : x) t) (f _ : f input t)
+
+uncheckedHash input = true
+inlineHash input = Registry.bundleHashValid? input
+contractHash input = resultIsOk (checkContract Registry.bundleHashC input)
diff --git a/docs/compiler.md b/docs/compiler.md
@@ -184,7 +184,7 @@ The production host imports `Runtime`, whose implementation is split into
`Runtime.Tree` (trees/reduction), `Runtime.Value` (canonical values),
`Runtime.Presentation` (display), and `Runtime.Merkle` (native DAG helpers).
`Research` is a recovery-only facade containing the historical Haskell frontend
-syntax. Tests and benchmarks still use it; the installed executable does not.
+syntax. Unmigrated tests still use it; the installed and benchmark executables do not.
The `ast` display format renders tree constructors directly, without constructing
source ASTs.
diff --git a/docs/validation.md b/docs/validation.md
@@ -10,7 +10,8 @@ For representation-sensitive work, see [Compiler architecture](compiler.md.html)
The normal Nix host package builds from inputs that exclude `Research`, the
Haskell lexer/parser/compiler/source loader, and recovery workspace resolution.
This makes accidental production dependencies on the recovery frontend build
-failures. The test and benchmark components retain those inputs during migration.
+failures. The test component retains those inputs during migration; the benchmark executable
+also builds without recovery sources.
The runtime-presentation tests compare constructor display with the recovery AST
oracle and an independently written golden; runtime demand tests exercise the
same extracted reducer used by production.
@@ -24,8 +25,41 @@ The historical executable preparation paths in `test/stable_bundle.py` and
`test/stable_costs.py` are retired: they depended on implicit recovery compilation
and have no verified native-support input route. Their CLIs fail before writes;
`stable_bundle`'s pure importable wire helpers remain supported. Do not bypass the
-guard by trusting old support/cache stamps. No replacement benchmark route or new
-measurements are claimed.
+guard by trusting old support/cache stamps. Those retired harnesses have no replacement route. The separate artifact-based
+Criterion runner below does not revive them or establish new performance measurements.
+
+### Artifact-based Criterion benchmarks (opt-in)
+
+```sh
+nix build .#tricu-bench -o result-bench
+nix build .#benchmarkWorkers -o result-benchmark-workers
+nix build .#benchmarkSmoke --no-link
+result-bench/bin/tricu-bench result-benchmark-workers/workers.arboricx \
+ "$(cat result-benchmark-workers/sha256)" --verify-only
+# Omit --verify-only for Criterion, or use --list / --help.
+```
+
+`benchmarkWorkers` builds `bench/workers.tri` and its explicit current-source
+library dependencies with the packaged stable compiler. It retains the staged
+sources, compiler metadata, CAS/receipts, bundle and whole-bundle SHA256. Preparation
+is bounded to 900 seconds compiling, 930 seconds externally, and an 8 GiB managed
+heap. It is an application build, not a compiler generation or fixture publication.
+
+The Haskell runner requires an explicit bundle and expected digest; it never reads
+library source or invokes either compiler. Loading validates bundle structure,
+execution ABI and the exact export interface. A 120-second deadline covers loading
+and checking all 27 cases against independent complete expected values. Workers,
+inputs and expected values are fully constructed before timing; use external
+process/heap limits for actual timing runs. A digest authenticates selected bytes,
+not the behavior of arbitrary caller-selected workers.
+
+The contract group measures precompiled application plus complete result equality;
+the registry group observes canonical Booleans in the same way. Parsing, compilation
+and publication are excluded. Historical contract benchmarks included recovery
+parsing/evaluation and are **not comparable**. This is a new workload definition,
+not a speedup claim. `benchmarkSmoke` checks expected results, wrong hashes,
+malformed bundles, incorrect interfaces, Criterion listing, and a one-iteration
+invocation of every case; it is not a statistically meaningful performance run.
### Interaction-tree inspection
@@ -120,7 +154,9 @@ remain live test inputs. Bundle, receipt, namespace, kernel, and ABI checks rema
`test/ReferenceFixtures.hs` owns authenticated artifact loading and direct
published-interface selection. `test/LibraryValueTests.hs` invokes byte-list and
HTTP exports with host-constructed inputs, without source wrappers or recovery
-compilation. HTTP framing/error expectations and no-socket-access controls remain
+compilation. `test/ParserValueTests.hs` does the same for binary and finite-stream
+parser protocols, including consumed/committed flags, rollback, zero-width
+repetition, and poisoned-field controls. HTTP framing/error expectations and no-socket-access controls remain
independent of the compiled implementations. Mixed-cohort reuse verification in
`SupportFixture` still depends on recovery parsing/free-variable analysis; direct
artifact invocation does not remove that separate provenance dependency.
diff --git a/flake.nix b/flake.nix
@@ -29,7 +29,7 @@
};
# The installed host must build with recovery frontend files absent.
- # Tests/benchmarks deliberately retain them until their migration finishes.
+ # Tests deliberately retain them until their migration finishes.
runtimeSource = pkgs.lib.cleanSourceWith {
src = tricuSource;
filter = path: type:
@@ -109,17 +109,41 @@
'';
tricuBench =
- hsLib.overrideCabal
- (hsLib.doBenchmark (
- haskellPackages.callCabal2nix packageName tricuSource {}
- ))
+ (hsLib.overrideCabal
+ (hsLib.doBenchmark (hsLib.dontCheck (
+ haskellPackages.callCabal2nix packageName runtimeSource {}
+ )))
(oldAttrs: {
postInstall = (oldAttrs.postInstall or "") + ''
mkdir -p $out/bin
cp dist/build/tricu-bench/tricu-bench $out/bin/
'';
+ })).overrideAttrs (_: {
+ # No implicit timing run without a caller-selected worker bundle.
+ benchmarkPhase = "true";
});
+ # Opt-in application build, never part of the fast gate. Retain the exact
+ # sources, compiler metadata and receipts beside the worker bundle.
+ benchmarkWorkers = pkgs.runCommand "tricu-benchmark-workers" {
+ nativeBuildInputs = [ tricuPackage ];
+ } ''
+ mkdir -p $out/workspace
+ ${pkgs.lib.concatMapStringsSep "\n" (name:
+ "cp ${./lib}/${name}.tri $out/workspace/${name}.tri") [
+ "base" "prelude" "bytes" "conversions" "io" "parser" "http" "socket"
+ ]}
+ cp ${./lib/math/native.tri} $out/workspace/native_math.tri
+ cp ${./lib/intensionalContracts.tri} $out/workspace/intensional.tri
+ cp ${./lib/arboricx/server.tri} $out/workspace/server.tri
+ cp ${./bench/workers.tri} $out/workspace/workers.tri
+ cp ${./bootstrap/stable-compiler.json} $out/compiler.json
+ timeout 930 tricu arboricx compile --file $out/workspace/workers.tri \
+ --store $out/store --output $out/workers.arboricx --compile-timeout 900 \
+ +RTS -N1 -M8192m -RTS
+ sha256sum $out/workers.arboricx | cut -d ' ' -f 1 > $out/sha256
+ '';
+
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
@@ -319,6 +343,36 @@
packages.tricu-static = tricuMuslStatic;
packages.tricu-static-upx = tricuStatic;
packages.tricu-bench = tricuBench;
+ packages.benchmarkWorkers = benchmarkWorkers;
+ packages.benchmarkSmoke = pkgs.runCommand "tricu-benchmark-smoke" {} ''
+ ${tricuBench}/bin/tricu-bench ${benchmarkWorkers}/workers.arboricx \
+ "$(cat ${benchmarkWorkers}/sha256)" --verify-only +RTS -N1 -M8192m -RTS
+ if ${tricuBench}/bin/tricu-bench ${benchmarkWorkers}/workers.arboricx \
+ "$(printf '%064d' 0)" --verify-only >bad-hash.log 2>&1; then
+ echo "benchmark accepted a wrong digest" >&2; exit 1
+ fi
+ grep -q 'SHA256 mismatch' bad-hash.log
+ if ${tricuBench}/bin/tricu-bench ${./test/fixtures/id.arboricx} \
+ "$(sha256sum ${./test/fixtures/id.arboricx} | cut -d ' ' -f 1)" \
+ --verify-only >bad-interface.log 2>&1; then
+ echo "benchmark accepted the wrong interface" >&2; exit 1
+ fi
+ grep -q 'exactly the benchmark export interface' bad-interface.log
+ printf 'not a bundle' > malformed.arboricx
+ if ${tricuBench}/bin/tricu-bench malformed.arboricx \
+ "$(sha256sum malformed.arboricx | cut -d ' ' -f 1)" \
+ --verify-only >malformed.log 2>&1; then
+ echo "benchmark accepted authenticated malformed bytes" >&2; exit 1
+ fi
+ ${tricuBench}/bin/tricu-bench ${benchmarkWorkers}/workers.arboricx \
+ "$(cat ${benchmarkWorkers}/sha256)" --list >names
+ test "$(grep -c '^contracts/' names)" -eq 12
+ test "$(grep -c '^registry-hash/' names)" -eq 15
+ ${tricuBench}/bin/tricu-bench ${benchmarkWorkers}/workers.arboricx \
+ "$(cat ${benchmarkWorkers}/sha256)" --iters 1 +RTS -N1 -M8192m -RTS
+ mkdir -p $out
+ '';
+
packages.tricu-zig = tricuZig;
packages.tricu-zig-tests = tricuZigTests;
packages.tricu-php = tricuPhp;
diff --git a/test/ParserValueTests.hs b/test/ParserValueTests.hs
@@ -0,0 +1,305 @@
+-- Parser protocols tested by applying authenticated trees to explicit values.
+-- Expected replies are independently constructed, including rest/progress flags.
+module ParserValueTests (portableParserTests, binaryParserTests) where
+
+import Runtime
+import ContentStore.Arboricx (encodeTreeTerm)
+import Control.Exception (evaluate)
+import Control.Monad (forM_)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import Test.Tasty
+import Test.Tasty.HUnit
+
+trueT, falseT :: T
+trueT = Stem Leaf
+falseT = Leaf
+pairT :: T -> T -> T
+pairT = Fork
+bytesT :: [Integer] -> T
+bytesT = ofList . map ofNumber
+parserOk, parserErr :: T -> T -> T
+parserOk value rest = Fork trueT (Fork value rest)
+parserErr code rest = Fork falseT (Fork code rest)
+
+portableReply :: Bool -> T -> T -> Bool -> Bool -> T
+portableReply success payload rest consumed committed =
+ pairT (if success then trueT else falseT)
+ (pairT payload (pairT rest (pairT
+ (if consumed then trueT else falseT)
+ (if committed then trueT else falseT))))
+
+portableDiagnostic :: T -> T -> T -> T -> T -> T
+portableDiagnostic code expected found location contexts =
+ pairT code (pairT expected (pairT found (pairT location contexts)))
+
+portableCode :: Integer -> T
+portableCode code = portableDiagnostic (ofNumber code) Leaf Leaf Leaf Leaf
+
+portableFound :: Integer -> T -> T -> T
+portableFound code expected found =
+ portableDiagnostic (ofNumber code) expected found Leaf Leaf
+
+portableParserTests :: Env -> Env -> TestTree
+portableParserTests parser base = testGroup "Portable parser protocol"
+ [ testCase "constructed reply matcher ignores poisoned fields and unselected handlers" $ do
+ let matcher = parser Map.! "parserMatchReply"
+ constant n = iterate (Fork Leaf) (ofNumber n) !! 4
+ failed = constant (11 :: Integer)
+ succeeded = constant (22 :: Integer)
+ poison = error "parser matcher demanded an ignored field/handler"
+ _ <- evaluate (BS.length (encodeTreeTerm matcher))
+ foldl apply matcher [failed, poison, Fork Leaf poison] @?= ofNumber 11
+ forM_ [Stem Leaf, Fork Leaf Leaf, Stem (Stem Leaf)] $ \status ->
+ foldl apply matcher [poison, succeeded, Fork status poison] @?= ofNumber 22
+ , testCase "pure preserves input" $
+ check (p "parserPure" [ofNumber 9, bytesT [1, 2]])
+ (portableReply True (ofNumber 9) (bytesT [1, 2]) False False)
+ , testCase "any consumes one token" $
+ check (p "parserAny" [bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [2]) True False)
+ , testCase "any reports EOF without consumption" $
+ check (p "parserAny" [ofList []])
+ (portableReply False (portableCode 1) (bytesT []) False False)
+ , testCase "satisfy mismatch does not consume" $
+ check (p "parserExpect" [ofNumber 3, bytesT [1, 2]])
+ (portableReply False (portableFound 2 (ofNumber 3) (ofNumber 1)) (bytesT [1, 2]) False False)
+ , testCase "sequencing propagates consumption through failure" $
+ check (p "parserBind" [p "parserAny" [], ignoreFailure7, bytesT [1, 2]])
+ (portableReply False (portableCode 7) (bytesT [2]) True False)
+ , testCase "alternative does not retry consumed failure" $
+ check (p "parserOr" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], p "parserAny" [], bytesT [1, 2]])
+ (portableReply False (portableCode 7) (bytesT [2]) True False)
+ , testCase "alternative retries unconsumed failure" $
+ check (p "parserOr" [p "parserExpect" [ofNumber 3], p "parserAny" [], bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [2]) True False)
+ , testCase "commit without consumption prevents fallback" $
+ check (p "parserOr" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], p "parserAny" [], bytesT [1, 2]])
+ (portableReply False (portableCode 7) (bytesT [1, 2]) False True)
+ , testCase "successful commit propagates through sequencing" $
+ check (p "parserThen" [p "parserCommit" [], p "parserAny" [], bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [2]) True True)
+ , testCase "attempt leaves success flags unchanged" $
+ check (p "parserAttempt" [p "parserThen" [p "parserCommit" [], p "parserAny" []], bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [2]) True True)
+ , testCase "attempt rolls back consumed and committed failure" $
+ check (p "parserOr" [p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]]], p "parserAny" [], bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [2]) True False)
+ , testCase "attempt cannot clear prior outer commitment" $
+ check (p "parserThen" [p "parserCommit" [], p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]], bytesT [1, 2]])
+ (portableReply False (portableCode 7) (bytesT [1, 2]) False True)
+ , testCase "map preserves flags" $
+ check (p "parserMap" [pairWithLeaf, p "parserAny" [], bytesT [1, 2]])
+ (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False)
+ , testCase "peek leaves stream and flags unchanged" $
+ check (p "parserPeek" [bytesT [1, 2]])
+ (portableReply True (ofNumber 1) (bytesT [1, 2]) False False)
+ , testCase "peek reports EOF without consumption" $
+ check (p "parserPeek" [ofList []])
+ (portableReply False (portableCode 1) (bytesT []) False False)
+ , testCase "apply sequences a parsed function and argument" $
+ check (p "parserApply" [p "parserPure" [pairWithLeaf], p "parserAny" [], bytesT [1, 2]])
+ (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False)
+ , testCase "EOF succeeds only at end" $ do
+ check (p "parserEof" [ofList []])
+ (portableReply True Leaf (bytesT []) False False)
+ check (p "parserEof" [bytesT [1]])
+ (portableReply False (portableFound 2 Leaf (ofNumber 1)) (bytesT [1]) False False)
+ , testCase "optional restores unmatched input" $
+ check (p "parserOptional" [p "parserExpect" [ofNumber 3], bytesT [1]])
+ (portableReply True Leaf (bytesT [1]) False False)
+ , testCase "optional does not hide committed failure" $
+ check (p "parserOptional" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], bytesT [1]])
+ (portableReply False (portableCode 7) (bytesT [1]) False True)
+ , testCase "many stops without consuming the failing token" $
+ check (p "parserMany" [p "parserExpect" [ofNumber 1], bytesT [1, 1, 2]])
+ (portableReply True (bytesT [1, 1]) (bytesT [2]) True False)
+ , testCase "many at EOF" $
+ check (p "parserMany" [p "parserAny" [], ofList []])
+ (portableReply True (bytesT []) (bytesT []) False False)
+ , testCase "some at EOF" $
+ check (p "parserSome" [p "parserAny" [], ofList []])
+ (portableReply False (portableCode 1) (bytesT []) False False)
+ , testCase "some parses nonempty prefix" $
+ check (p "parserSome" [p "parserExpect" [ofNumber 1], bytesT [1, 2]])
+ (portableReply True (bytesT [1]) (bytesT [2]) True False)
+ , testCase "many rejects zero-width success, including commitment" $ do
+ check (p "parserMany" [p "parserPure" [ofNumber 9], bytesT [1]])
+ (portableReply False (portableCode 3) (bytesT [1]) False False)
+ check (p "parserMany" [p "parserCommit" [], bytesT [1]])
+ (portableReply False (portableCode 3) (bytesT [1]) False True)
+ , testCase "some rejects zero-width success" $
+ check (p "parserSome" [p "parserPure" [ofNumber 9], bytesT [1]])
+ (portableReply False (portableCode 3) (bytesT [1]) False False)
+ , testCase "many propagates consumed failure" $
+ check (p "parserMany" [p "parserThen" [p "parserAny" [], p "parserExpect" [ofNumber 7]], bytesT [1, 2]])
+ (portableReply False (portableFound 2 (ofNumber 7) (ofNumber 2)) (bytesT [2]) True False)
+ , testCase "many propagates committed failure" $
+ check (p "parserMany" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], bytesT [1]])
+ (portableReply False (portableCode 7) (bytesT [1]) False True)
+ , testCase "many preserves prior progress when later iteration commits" $
+ check (p "parserMany" [p "parserOr" [p "parserExpect" [ofNumber 1], p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]], bytesT [1, 2]])
+ (portableReply False (portableCode 7) (bytesT [2]) True True)
+ , testCase "before discards second value but propagates flags" $
+ check (p "parserBefore" [p "parserAny" [], p "parserCommit" [], bytesT [1]])
+ (portableReply True (ofNumber 1) (bytesT []) True True)
+ , testCase "takeWhile consumes a prefix" $
+ check (p "parserTakeWhile" [equalsOne, bytesT [1, 1, 2]])
+ (portableReply True (bytesT [1, 1]) (bytesT [2]) True False)
+ , testCase "takeWhile1 requires a match" $
+ check (p "parserTakeWhile1" [equalsOne, bytesT [2]])
+ (portableReply False (portableFound 2 Leaf (ofNumber 2)) (bytesT [2]) False False)
+ , testCase "takeWhile handles a longer finite stream" $
+ check (p "parserTakeWhile" [equalsOne, bytesT (replicate 64 1 ++ [2])])
+ (portableReply True (bytesT (replicate 64 1)) (bytesT [2]) True False)
+ , testCase "expected token survives EOF" $
+ check (p "parserExpect" [ofNumber 4, ofList []])
+ (portableReply False (portableFound 1 (ofNumber 4) Leaf) (bytesT []) False False)
+ , testCase "label and nested contexts preserve found and location" $
+ check (p "parserContext" [ofNumber 4, p "parserContext" [ofNumber 5, p "parserLabel" [ofNumber 8, p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, ofNumber 6, ofNumber 9, Leaf]]]], ofList []])
+ (portableReply False
+ (portableDiagnostic (ofNumber 7) (ofNumber 8) (ofNumber 6)
+ (ofNumber 9) (bytesT [4, 5])) (bytesT []) False False)
+ , testCase "attempt preserves diagnostic location on rollback" $
+ check (p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, ofNumber 9, Leaf]]], bytesT [1]])
+ (portableReply False
+ (portableDiagnostic (ofNumber 7) Leaf Leaf (ofNumber 9) Leaf)
+ (bytesT [1]) False False)
+ , testCase "between consumes both delimiters" $
+ check (p "parserBetween" [p "parserExpect" [ofNumber 1], p "parserAny" [], p "parserExpect" [ofNumber 3], bytesT [1, 2, 3, 4]])
+ (portableReply True (ofNumber 2) (bytesT [4]) True False)
+ , testCase "sepBy accepts empty list" $
+ check (p "parserSepBy" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [3]])
+ (portableReply True (bytesT []) (bytesT [3]) False False)
+ , testCase "sepBy1 parses separated elements" $
+ check (p "parserSepBy1" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [1, 2, 1, 3]])
+ (portableReply True (bytesT [1, 1]) (bytesT [3]) True False)
+ , testCase "sepBy rejects trailing separator" $
+ check (p "parserSepBy" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [1, 2]])
+ (portableReply False (portableFound 1 (ofNumber 1) Leaf) (bytesT []) True False)
+ , testCase "sepBy rejects zero-width element and separator" $
+ check (p "parserSepBy" [p "parserPure" [ofNumber 1], p "parserPure" [ofNumber 2], ofList []])
+ (portableReply False (portableCode 3) (bytesT []) False False)
+ ]
+ where
+ check actual expected = actual @?= expected
+ p name = foldl apply (parser Map.! name)
+ ignoreFailure7 = Fork Leaf (p "parserFailure" [portableCode 7])
+ equalsOne = apply (base Map.! "equal?") (ofNumber 1)
+ -- S t (K t): x -> Fork x Leaf, independent of a source frontend.
+ pairWithLeaf = Fork (Stem Leaf) (Fork Leaf Leaf)
+
+binaryParserTests :: Env -> Env -> Env -> TestTree
+binaryParserTests binary parser base = testGroup "Binary Parser Tests"
+ [ testCase "binary support exposes Result byte reader" $ do
+ Map.member "readU8" binary @?= True
+ b "readU8" [bytesT [7]] @?=
+ parserOk (ofNumber 7) Leaf
+ , testCase "generic byte reader records progress and EOF" $ do
+ p "parserAny" [bytesT [7, 8]] @?=
+ portableReply True (ofNumber 7) (bytesT [8]) True False
+ p "parserAny" [ofList []] @?=
+ portableReply False (portableCode 1) Leaf False False
+ , testCase "generic expect records mismatch without consuming" $ do
+ p "parserExpect" [ofNumber 7, bytesT [8]] @?=
+ portableReply False
+ (portableFound 2 (ofNumber 7) (ofNumber 8))
+ (bytesT [8]) False False
+ p "parserExpect" [ofNumber 7, ofList []] @?=
+ portableReply False
+ (portableDiagnostic (ofNumber 1) (ofNumber 7) Leaf Leaf Leaf)
+ Leaf False False
+ , testCase "byte expectations retain numeric codes and rollback" $ do
+ let check input expected =
+ input @?= expected
+ check (b "readU8" [ofList []]) (parserErr (ofNumber 1) Leaf)
+ check (b "peekU8" [ofList []]) (parserErr (ofNumber 1) Leaf)
+ check (b "expectU8" [ofNumber 7, bytesT [8, 9]])
+ (parserErr (ofNumber 3) (bytesT [8, 9]))
+ check (b "expectU8" [ofNumber 7, ofList []]) (parserErr (ofNumber 1) Leaf)
+ check (b "expectU8" [ofNumber 7, bytesT [7, 9]])
+ (parserOk Leaf (bytesT [9]))
+ check (b "expectBytes" [bytesT [104, 105], bytesT [104]])
+ (parserErr (ofNumber 1) (bytesT [104]))
+ check (b "expectBytes" [bytesT [104, 105], bytesT [104, 99]])
+ (parserErr (ofNumber 2) (bytesT [104, 99]))
+ check (b "orParser" [b "bindParser" [b "readU8" [], ignoreFailure77], b "readU8" [], bytesT [5, 6]])
+ (parserOk (ofNumber 5) (bytesT [6]))
+ , testCase "Result rollback and consumption-aware alternatives remain distinct" $ do
+ let input = bytesT [5, 6]
+ failure = p "parserBind" [p "parserAny" [], Fork Leaf (p "parserFailure" [portableCode 77])]
+ b "bindParser" [b "readU8" [], ignoreFailure77, input] @?=
+ parserErr (ofNumber 77) (bytesT [6])
+ b "orParser" [b "bindParser" [b "readU8" [], ignoreFailure77], b "readU8" [], input] @?=
+ parserOk (ofNumber 5) (bytesT [6])
+ p "parserOr" [failure, p "parserAny" [], input] @?=
+ portableReply False (portableCode 77) (bytesT [6]) True False
+ , testCase "pureParser succeeds" $ do
+ b "pureParser" [ofNumber 42, bytesT [1, 2]] @?= parserOk (ofNumber 42) (bytesT [1, 2])
+
+ , testCase "failParser fails" $ do
+ b "failParser" [ofNumber 99, bytesT [1, 2]] @?= parserErr (ofNumber 99) (bytesT [1, 2])
+
+ , testCase "mapParser transforms value" $ do
+ b "mapParser" [base Map.! "succ", b "readU8" [], bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT [2])
+
+ , testCase "bindParser chains parsers" $ do
+ b "bindParser" [b "readU8" [], ignoreRead, bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT [])
+
+ , testCase "thenParser discards first result" $ do
+ b "thenParser" [b "readU8" [], b "readU8" [], bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT [])
+
+ , testCase "orParser tries second on first failure" $ do
+ b "orParser" [b "failParser" [ofNumber 1], b "readU8" [], bytesT [5]] @?= parserOk (ofNumber 5) (bytesT [])
+
+ , testCase "orParser returns first on success" $ do
+ b "orParser" [b "readU8" [], b "failParser" [ofNumber 1], bytesT [5]] @?= parserOk (ofNumber 5) (bytesT [])
+
+ , testCase "readWhile consumes matching bytes" $ do
+ b "readWhile" [lessThanThree, bytesT [1, 2, 3, 4]] @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
+
+ , testCase "readWhile leaves non-matching byte" $ do
+ b "bindParser" [b "readWhile" [lessThanThree], ignoreRead, bytesT [1, 2, 3]] @?= parserOk (ofNumber 3) (bytesT [])
+
+ , testCase "readUntil stops at matching byte" $ do
+ b "readUntil" [equalsThree, bytesT [1, 2, 3, 4]] @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
+
+ , testCase "readRemaining returns all bytes" $ do
+ b "readRemaining" [bytesT [1, 2, 3]] @?= parserOk (bytesT [1, 2, 3]) (bytesT [])
+
+ , testCase "peekU8 does not consume" $ do
+ b "bindParser" [b "peekU8" [], ignoreRead, bytesT [7, 8]] @?= parserOk (ofNumber 7) (bytesT [8])
+
+ , testCase "peekU8 second read gets same byte" $ do
+ b "bindParser" [b "peekU8" [], capturePeek, bytesT [7]] @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7])
+
+ , testCase "eof? succeeds at empty input" $ do
+ b "eof?" [ofList []] @?= parserOk Leaf (bytesT [])
+
+ , testCase "eof? rejects non-empty input and preserves its remainder" $ do
+ -- The old reference uses EOF code 1; current candidate code 2 is checked
+ -- independently by bundle_batch.py, not inferred from this fixture.
+ case b "eof?" [bytesT [1]] of
+ Fork flag (Fork _ rest) -> do
+ flag @?= falseT
+ rest @?= bytesT [1]
+ other -> assertFailure ("Expected failure Result, got " ++ show other)
+
+ , testCase "expectAscii matches string" $ do
+ b "expectAscii" [ofString "hi", bytesT [104, 105, 106]] @?= parserOk Leaf (bytesT [106])
+
+ , testCase "expectAscii fails on mismatch" $ do
+ b "expectAscii" [ofString "hi", bytesT [104, 99]] @?= parserErr (ofNumber 2) (bytesT [104, 99])
+ ]
+ where
+ b name = foldl apply (binary Map.! name)
+ p name = foldl apply (parser Map.! name)
+ compose f g = foldl apply (base Map.! "compose") [f, g]
+ ignoreFailure77 = Fork Leaf (b "failParser" [ofNumber 77])
+ ignoreRead = Fork Leaf (b "readU8" [])
+ -- Canonical numeric predicates; these tests exercise parser consumption.
+ lessThanThree = apply (base Map.! "gt?") (ofNumber 3)
+ equalsThree = apply (base Map.! "equal?") (ofNumber 3)
+ -- x -> bindParser peekU8 (y -> pureParser (Fork x y)).
+ capturePeek = compose (b "bindParser" [b "peekU8" []])
+ (compose (apply (base Map.! "compose") (b "pureParser" [])) Leaf)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,6 +1,7 @@
module Main where
import Eval
+import qualified ParserValueTests
import qualified LibraryValueTests
import ReferenceFixtures
import PackageTests (packageTests)
@@ -104,8 +105,8 @@ tests = testGroup "Tricu Tests"
, wireTests
, tricuReaderTests
, LibraryValueTests.byteListUtilities (fixtureExports "bytes") (fixtureExports "base")
- , binaryParserTests
- , portableParserTests
+ , ParserValueTests.binaryParserTests (fixtureExports "binary") (fixtureExports "parser") (fixtureExports "base")
+ , ParserValueTests.portableParserTests (fixtureExports "parser") (fixtureExports "base")
, locatedLexerTests
, compilerFixtureTests
, digestHexTests
@@ -3235,151 +3236,6 @@ portableFound :: Integer -> T -> T -> T
portableFound code expected found =
portableDiagnostic (ofNumber code) expected found Leaf Leaf
-portableParserTests :: TestTree
-portableParserTests = testGroup "Portable parser protocol"
- [ testCase "constructed reply matcher ignores poisoned fields and unselected handlers" $ do
- let matcher = portableParserEnv Map.! "parserMatchReply"
- constant n = result (evalTricu portableParserEnv
- (parseTricu ("(_ _ _ _ : " ++ show n ++ ")")))
- failed = constant (11 :: Integer)
- succeeded = constant (22 :: Integer)
- poison = error "parser matcher demanded an ignored field/handler"
- _ <- evaluate (BS.length (encodeTreeTerm matcher))
- foldl apply matcher [failed, poison, Fork Leaf poison] @?= ofNumber 11
- forM_ [Stem Leaf, Fork Leaf Leaf, Stem (Stem Leaf)] $ \status ->
- foldl apply matcher [poison, succeeded, Fork status poison] @?= ofNumber 22
- , testCase "pure preserves input" $
- check "parserPure 9 [(1) (2)]"
- (portableReply True (ofNumber 9) (bytesT [1, 2]) False False)
- , testCase "any consumes one token" $
- check "parserAny [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [2]) True False)
- , testCase "any reports EOF without consumption" $
- check "parserAny []"
- (portableReply False (portableCode 1) (bytesT []) False False)
- , testCase "satisfy mismatch does not consume" $
- check "parserExpect 3 [(1) (2)]"
- (portableReply False (portableFound 2 (ofNumber 3) (ofNumber 1)) (bytesT [1, 2]) False False)
- , testCase "sequencing propagates consumption through failure" $
- check "parserBind parserAny (x : parserFailure (parserDiagnostic 7 t t t t)) [(1) (2)]"
- (portableReply False (portableCode 7) (bytesT [2]) True False)
- , testCase "alternative does not retry consumed failure" $
- check "parserOr (parserThen parserAny (parserFailure (parserDiagnostic 7 t t t t))) parserAny [(1) (2)]"
- (portableReply False (portableCode 7) (bytesT [2]) True False)
- , testCase "alternative retries unconsumed failure" $
- check "parserOr (parserExpect 3) parserAny [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [2]) True False)
- , testCase "commit without consumption prevents fallback" $
- check "parserOr (parserThen parserCommit (parserFailure (parserDiagnostic 7 t t t t))) parserAny [(1) (2)]"
- (portableReply False (portableCode 7) (bytesT [1, 2]) False True)
- , testCase "successful commit propagates through sequencing" $
- check "parserThen parserCommit parserAny [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [2]) True True)
- , testCase "attempt leaves success flags unchanged" $
- check "parserAttempt (parserThen parserCommit parserAny) [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [2]) True True)
- , testCase "attempt rolls back consumed and committed failure" $
- check "parserOr (parserAttempt (parserThen parserAny (parserThen parserCommit (parserFailure (parserDiagnostic 7 t t t t))))) parserAny [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [2]) True False)
- , testCase "attempt cannot clear prior outer commitment" $
- check "parserThen parserCommit (parserAttempt (parserThen parserAny (parserFailure (parserDiagnostic 7 t t t t)))) [(1) (2)]"
- (portableReply False (portableCode 7) (bytesT [1, 2]) False True)
- , testCase "map preserves flags" $
- check "parserMap (x : pair x t) parserAny [(1) (2)]"
- (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False)
- , testCase "peek leaves stream and flags unchanged" $
- check "parserPeek [(1) (2)]"
- (portableReply True (ofNumber 1) (bytesT [1, 2]) False False)
- , testCase "peek reports EOF without consumption" $
- check "parserPeek []"
- (portableReply False (portableCode 1) (bytesT []) False False)
- , testCase "apply sequences a parsed function and argument" $
- check "parserApply (parserPure (x : pair x t)) parserAny [(1) (2)]"
- (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False)
- , testCase "EOF succeeds only at end" $ do
- check "parserEof []"
- (portableReply True Leaf (bytesT []) False False)
- check "parserEof [(1)]"
- (portableReply False (portableFound 2 Leaf (ofNumber 1)) (bytesT [1]) False False)
- , testCase "optional restores unmatched input" $
- check "parserOptional (parserExpect 3) [(1)]"
- (portableReply True Leaf (bytesT [1]) False False)
- , testCase "optional does not hide committed failure" $
- check "parserOptional (parserThen parserCommit (parserFailure (parserDiagnostic 7 t t t t))) [(1)]"
- (portableReply False (portableCode 7) (bytesT [1]) False True)
- , testCase "many stops without consuming the failing token" $
- check "parserMany (parserExpect 1) [(1) (1) (2)]"
- (portableReply True (bytesT [1, 1]) (bytesT [2]) True False)
- , testCase "many at EOF" $
- check "parserMany parserAny []"
- (portableReply True (bytesT []) (bytesT []) False False)
- , testCase "some at EOF" $
- check "parserSome parserAny []"
- (portableReply False (portableCode 1) (bytesT []) False False)
- , testCase "some parses nonempty prefix" $
- check "parserSome (parserExpect 1) [(1) (2)]"
- (portableReply True (bytesT [1]) (bytesT [2]) True False)
- , testCase "many rejects zero-width success, including commitment" $ do
- check "parserMany (parserPure 9) [(1)]"
- (portableReply False (portableCode 3) (bytesT [1]) False False)
- check "parserMany parserCommit [(1)]"
- (portableReply False (portableCode 3) (bytesT [1]) False True)
- , testCase "some rejects zero-width success" $
- check "parserSome (parserPure 9) [(1)]"
- (portableReply False (portableCode 3) (bytesT [1]) False False)
- , testCase "many propagates consumed failure" $
- check "parserMany (parserThen parserAny (parserExpect 7)) [(1) (2)]"
- (portableReply False (portableFound 2 (ofNumber 7) (ofNumber 2)) (bytesT [2]) True False)
- , testCase "many propagates committed failure" $
- check "parserMany (parserThen parserCommit (parserFailure (parserDiagnostic 7 t t t t))) [(1)]"
- (portableReply False (portableCode 7) (bytesT [1]) False True)
- , testCase "many preserves prior progress when later iteration commits" $
- check "parserMany (parserOr (parserExpect 1) (parserThen parserCommit (parserFailure (parserDiagnostic 7 t t t t)))) [(1) (2)]"
- (portableReply False (portableCode 7) (bytesT [2]) True True)
- , testCase "before discards second value but propagates flags" $
- check "parserBefore parserAny parserCommit [(1)]"
- (portableReply True (ofNumber 1) (bytesT []) True True)
- , testCase "takeWhile consumes a prefix" $
- check "parserTakeWhile (x : equal? x 1) [(1) (1) (2)]"
- (portableReply True (bytesT [1, 1]) (bytesT [2]) True False)
- , testCase "takeWhile1 requires a match" $
- check "parserTakeWhile1 (x : equal? x 1) [(2)]"
- (portableReply False (portableFound 2 Leaf (ofNumber 2)) (bytesT [2]) False False)
- , testCase "takeWhile handles a longer finite stream" $
- check ("parserTakeWhile (x : equal? x 1) [" ++ concat (replicate 64 "(1) ") ++ "(2)]")
- (portableReply True (bytesT (replicate 64 1)) (bytesT [2]) True False)
- , testCase "expected token survives EOF" $
- check "parserExpect 4 []"
- (portableReply False (portableFound 1 (ofNumber 4) Leaf) (bytesT []) False False)
- , testCase "label and nested contexts preserve found and location" $
- check "parserContext 4 (parserContext 5 (parserLabel 8 (parserFailure (parserDiagnostic 7 t 6 9 t)))) []"
- (portableReply False
- (portableDiagnostic (ofNumber 7) (ofNumber 8) (ofNumber 6)
- (ofNumber 9) (bytesT [4, 5])) (bytesT []) False False)
- , testCase "attempt preserves diagnostic location on rollback" $
- check "parserAttempt (parserThen parserAny (parserFailure (parserDiagnostic 7 t t 9 t))) [(1)]"
- (portableReply False
- (portableDiagnostic (ofNumber 7) Leaf Leaf (ofNumber 9) Leaf)
- (bytesT [1]) False False)
- , testCase "between consumes both delimiters" $
- check "parserBetween (parserExpect 1) parserAny (parserExpect 3) [(1) (2) (3) (4)]"
- (portableReply True (ofNumber 2) (bytesT [4]) True False)
- , testCase "sepBy accepts empty list" $
- check "parserSepBy (parserExpect 1) (parserExpect 2) [(3)]"
- (portableReply True (bytesT []) (bytesT [3]) False False)
- , testCase "sepBy1 parses separated elements" $
- check "parserSepBy1 (parserExpect 1) (parserExpect 2) [(1) (2) (1) (3)]"
- (portableReply True (bytesT [1, 1]) (bytesT [3]) True False)
- , testCase "sepBy rejects trailing separator" $
- check "parserSepBy (parserExpect 1) (parserExpect 2) [(1) (2)]"
- (portableReply False (portableFound 1 (ofNumber 1) Leaf) (bytesT []) True False)
- , testCase "sepBy rejects zero-width element and separator" $
- check "parserSepBy (parserPure 1) (parserPure 2) []"
- (portableReply False (portableCode 3) (bytesT []) False False)
- ]
- where
- check input expected = result (evalTricu portableParserEnv (parseTricu input)) @?= expected
-
-- --------------------------------------------------------------------------
-- Reusable, located character-scanning primitives
-- --------------------------------------------------------------------------
@@ -5295,150 +5151,6 @@ parserOk val rest = Fork trueT (Fork val rest)
parserErr :: T -> T -> T
parserErr code rest = Fork falseT (Fork code rest)
-binaryParserTests :: TestTree
-binaryParserTests = testGroup "Binary Parser Tests"
- [ testCase "binary support exposes Result byte reader" $ do
- env <- evaluateTestSupportFile "./lib/binary.tri"
- Map.member "readU8" env @?= True
- result (evalTricu env (parseTricu "readU8 [(7)]")) @?=
- parserOk (ofNumber 7) Leaf
- , testCase "generic byte reader records progress and EOF" $ do
- let env = evalTricu portableParserEnv
- result (env (parseTricu "parserAny [(7) (8)]")) @?=
- portableReply True (ofNumber 7) (bytesT [8]) True False
- result (env (parseTricu "parserAny []")) @?=
- portableReply False (portableCode 1) Leaf False False
- , testCase "generic expect records mismatch without consuming" $ do
- let env = evalTricu portableParserEnv
- result (env (parseTricu "parserExpect 7 [(8)]")) @?=
- portableReply False
- (portableFound 2 (ofNumber 7) (ofNumber 8))
- (bytesT [8]) False False
- result (env (parseTricu "parserExpect 7 []")) @?=
- portableReply False
- (portableDiagnostic (ofNumber 1) (ofNumber 7) Leaf Leaf Leaf)
- Leaf False False
- , testCase "byte expectations retain numeric codes and rollback" $ do
- let check input expected =
- result (evalTricu allTestLibsEnv (parseTricu input)) @?= expected
- check "readU8 []" (parserErr (ofNumber 1) Leaf)
- check "peekU8 []" (parserErr (ofNumber 1) Leaf)
- check "expectU8 7 [(8) (9)]"
- (parserErr (ofNumber 3) (bytesT [8, 9]))
- check "expectU8 7 []" (parserErr (ofNumber 1) Leaf)
- check "expectU8 7 [(7) (9)]"
- (parserOk Leaf (bytesT [9]))
- check "expectBytes [(104) (105)] [(104)]"
- (parserErr (ofNumber 1) (bytesT [104]))
- check "expectBytes [(104) (105)] [(104) (99)]"
- (parserErr (ofNumber 2) (bytesT [104, 99]))
- check "orParser (bindParser readU8 (x : failParser 77)) readU8 [(5) (6)]"
- (parserOk (ofNumber 5) (bytesT [6]))
- , testCase "Result rollback and consumption-aware alternatives remain distinct" $ do
- let env = Map.union allTestLibsEnv portableParserEnv
- failure = "(parserBind parserAny "
- ++ "(x : parserFailure (parserDiagnostic 77 t t t t)))"
- input = "[(5) (6)]"
- check expr expected =
- assertEqual expr expected (result (evalTricu env (parseTricu expr)))
- check ("bindParser readU8 (x : failParser 77) " ++ input)
- (parserErr (ofNumber 77) (bytesT [6]))
- check ("orParser (bindParser readU8 (x : failParser 77)) readU8 " ++ input)
- (parserOk (ofNumber 5) (bytesT [6]))
- check ("parserOr " ++ failure ++ " parserAny " ++ input)
- (portableReply False (portableCode 77) (bytesT [6]) True False)
- , testCase "pureParser succeeds" $ do
- let input = "pureParser 42 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 42) (bytesT [1, 2])
-
- , testCase "failParser fails" $ do
- let input = "failParser 99 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 99) (bytesT [1, 2])
-
- , testCase "mapParser transforms value" $ do
- let input = "mapParser succ readU8 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 2) (bytesT [2])
-
- , testCase "bindParser chains parsers" $ do
- let input = "bindParser readU8 (x : readU8) [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 2) (bytesT [])
-
- , testCase "thenParser discards first result" $ do
- let input = "thenParser readU8 readU8 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 2) (bytesT [])
-
- , testCase "orParser tries second on first failure" $ do
- let input = "orParser (failParser 1) readU8 [(5)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 5) (bytesT [])
-
- , testCase "orParser returns first on success" $ do
- let input = "orParser readU8 (failParser 1) [(5)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 5) (bytesT [])
-
- , testCase "readWhile consumes matching bytes" $ do
- let input = "readWhile (x : lt? x 3) [(1) (2) (3) (4)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
-
- , testCase "readWhile leaves non-matching byte" $ do
- let input = "bindParser (readWhile (x : lt? x 3)) (x : readU8) [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 3) (bytesT [])
-
- , testCase "readUntil stops at matching byte" $ do
- let input = "readUntil (x : equal? x 3) [(1) (2) (3) (4)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
-
- , testCase "readRemaining returns all bytes" $ do
- let input = "readRemaining [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (bytesT [1, 2, 3]) (bytesT [])
-
- , testCase "peekU8 does not consume" $ do
- let input = "bindParser peekU8 (x : readU8) [(7) (8)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofNumber 7) (bytesT [8])
-
- , testCase "peekU8 second read gets same byte" $ do
- let input = "bindParser peekU8 (x : bindParser peekU8 (y : pureParser (pair x y))) [(7)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7])
-
- , testCase "eof? succeeds at empty input" $ do
- let input = "eof? []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk Leaf (bytesT [])
-
- , testCase "eof? rejects non-empty input and preserves its remainder" $ do
- -- The old reference uses EOF code 1; current candidate code 2 is checked
- -- independently by bundle_batch.py, not inferred from this fixture.
- let input = "eof? [(1)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- case result env of
- Fork flag (Fork _ rest) -> do
- flag @?= falseT
- rest @?= bytesT [1]
- other -> assertFailure ("Expected failure Result, got " ++ show other)
-
- , testCase "expectAscii matches string" $ do
- let input = "expectAscii \"hi\" [(104) (105) (106)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk Leaf (bytesT [106])
-
- , testCase "expectAscii fails on mismatch" $ do
- let input = "expectAscii \"hi\" [(104) (99)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 2) (bytesT [104, 99])
- ]
-
-- --------------------------------------------------------------------------
-- IO driver tests
-- --------------------------------------------------------------------------
diff --git a/tricu.cabal b/tricu.cabal
@@ -103,51 +103,22 @@ benchmark tricu-bench
MultiWayIf
OverloadedStrings
ScopedTypeVariables
+ ghc-options: -threaded -rtsopts
build-depends:
base >=4.7
- , ansi-terminal
, base16-bytestring
, base64-bytestring
, bytestring
, containers
, criterion
, cryptonite
- , directory
- , exceptions
- , filepath
- , megaparsec
, memory
- , mtl
- , network
- , stm
, text
- , time
- , transformers
- , unix
, vector
, zlib
default-language: Haskell2010
other-modules:
ApplyStats
- ContentStore
- ContentStore.Alias
- ContentStore.Arboricx
- NodeTable
- ContentStore.Bundle
- ContentStore.Filesystem
- ContentStore.Object
- ContentStore.Resolver
- Eval
- FileEval
- Frontend.ContractDesugar
- IODriver
- Lexer
- Module.Manifest
- Module.Resolver
- Module.Workspace
- Parser
- Paths_tricu
- Research
Runtime
Runtime.Tree
Runtime.Value
@@ -236,4 +207,5 @@ test-suite tricu-tests
Wire
SupportFixture
LibraryValueTests
+ ParserValueTests
ReferenceFixtures
