tricu

Spec.hs (183643B)

---

 module Main where
 
 import WorkspaceTests (workspaceTests)
 import IOBoundaryTests (ioBoundaryTests)
 import PortableCompilerTests (portableCompilerTests)
 import ExecutableLoadingTests (executableLoadingTests)
 import ScriptedEffects (runScriptedEffects)
 import IODriverTests (ioDriverTests)
 import LibraryProgramTests (maybeTests, providedLibraries, contractsTests, arithmetic)
 import qualified ParserValueTests
 import qualified LibraryValueTests
 import PortableTestCompiler (compileFixtureFile, compileFixtureDefinitions)
 import ReferenceFixtures
 import PackageTests (packageTests)
 import InteractionInspectionTests (interactionInspectionTests)
 import REPL
 import Runtime
 import TreeObservation (forceTreeShared)
 import qualified NodeTable as Nodes
 import Wire
 import SupportFixture (canonicalEnvs, verifyReuseProviders, verifySupportSources, verifyRelocatedSupportSources,
   verifySupportExports, verifySupportDependencies, readFixtureSourceBytes, readTestSource, readPinnedSource)
 import ContentStore
 import ContentStore.Bundle
 import Module.Manifest
 import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
 
 import Control.Exception      (bracket, evaluate, try, SomeException)
 import Control.Concurrent     (forkIO, newEmptyMVar, putMVar, takeMVar)
 import System.IO.Unsafe       (unsafePerformIO)
 import System.Mem.StableName (makeStableName)
 import Data.IORef (IORef, newIORef, modifyIORef', readIORef, atomicModifyIORef')
 import Control.Monad         (foldM, forM, forM_, unless)
 import Control.Monad.IO.Class (liftIO)
 import System.IO.Temp         (withSystemTempDirectory)
 import qualified System.Timeout as Timeout
 import System.Directory      (createDirectory, createFileLink, doesFileExist, doesDirectoryExist, listDirectory)
 import System.FilePath       ((</>))
 import Data.Bits              (xor)
 import Data.List              (find, isInfixOf, isPrefixOf, stripPrefix)
 import Data.Text              (Text, unpack, pack)
 import Data.Text.Encoding     (decodeUtf8, encodeUtf8)
 import Data.Word              (Word8)
 import Test.Tasty
 import Test.Tasty.HUnit
 
 import Data.ByteString (ByteString)
 import qualified Data.Foldable as Foldable
 import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
 import qualified Data.Vector as V
 
 main :: IO ()
 main = do
   putStrLn "Reference-artifact tests: authenticated compiler/support snapshots, not working-tree candidate coverage."
   defaultMain tests
 
 tests :: TestTree
 tests = testGroup "Tricu Tests"
   [ workspaceTests
   , ioBoundaryTests
   , portableCompilerTests
   , executableLoadingTests
   , runtimePresentationTests
   , interactionInspectionTests
   , packageTests
   , evaluationDemandTests
   , arithmetic
   , providedLibraries
   , contractsTests
   , maybeTests
   , fileEval
   , demos
   , decoding
   , byteMarshallingTests
   , sourceObjectCodecTests
   , sharedTreeDecodingTests
   , verifiedTreeLoadingTests
   , indexedTreeTransportTests
   , verifiedTreePublicationTests
   , wireTests
   , tricuReaderTests
   , LibraryValueTests.byteListUtilities (fixtureExports "bytes") (fixtureExports "base")
   , ParserValueTests.binaryParserTests (fixtureExports "binary") (fixtureExports "parser") (fixtureExports "base")
   , ParserValueTests.portableParserTests (fixtureExports "parser") (fixtureExports "base")
   , locatedLexerTests
   , compilerFixtureTests
   , digestHexTests
   , gateLexerTests
   , gateParserTests
   , gateProgramTests
   , equationHelperTests
   , sourceGraphTests
   , gateOrderingTests
   , gateUnitTests
   , gateResolutionTests
   , gateCompilationTests
   , LibraryValueTests.httpParsingTests (fixtureExports "http")
   , httpPipelineTests
   , registryContractTests
   , registryPipelineTests
   , localControlTests
   , contentStoreTests
   , artifactSafetyTests
   , ioDriverTests
   ]
 
 
 -- Constructor display is a runtime presentation format, not a frontend AST.
 runtimePresentationTests :: TestTree
 runtimePresentationTests = testGroup "Runtime presentation"
   [ testCase "AST leaf constructor golden" $ formatT AST Leaf @?= "TLeaf"
   , testCase "AST stem constructor golden" $ formatT AST (Stem Leaf) @?= "TStem TLeaf"
   , testCase "AST nested constructor golden" $
       formatT AST (Fork (Stem Leaf) (Fork Leaf Leaf)) @?=
         "TFork (TStem TLeaf) (TFork TLeaf TLeaf)"
   ]
 
 -- Demand uses exceptions rather than unbounded divergent reductions.
 -- Physical sharing checks the Haskell implementation, not a tree ABI promise.
 evaluationDemandTests :: TestTree
 evaluationDemandTests = localOption (mkTimeout 30000000) $ testGroup "Evaluation demand boundaries"
   [ testCase "constant application discards its argument" $
       apply (Fork Leaf (ofNumber 23)) poison @?= ofNumber 23
   , testCase "constructor application exposes only the outer constructor" $ do
       case apply Leaf poison of
         Stem _ -> pure ()
         _ -> assertFailure "expected Stem"
       case apply (Stem poison) poison of
         Fork _ _ -> pure ()
         _ -> assertFailure "expected Fork"
   , testCase "triage demands shape but not unused handlers or children" $ do
       let value = ofNumber 23
           constant = Fork Leaf value
       apply (Fork (Fork value poison) poison) Leaf @?= value
       apply (Fork (Fork poison constant) poison) (Stem poison) @?= value
       apply (Fork (Fork poison poison) (Fork Leaf constant))
         (Fork poison poison) @?= value
       demanded (evaluate (apply (Fork (Fork Leaf Leaf) Leaf) poison))
   , testCase "distribution retains the duplicated argument's physical sharing" $ do
       -- t (t t) t c -> t c (t c). Both occurrences reference c.
       input <- newIORef (Fork (ofNumber 23) (ofNumber 24)) >>= readIORef
       case apply (Fork (Stem Leaf) Leaf) input of
         Fork left (Stem right) -> do
           a <- evaluate left >>= makeStableName
           b <- evaluate right >>= makeStableName
           assertBool "distribution copied the argument" (a == b)
         _ -> assertFailure "unexpected distribution result"
   , testCase "host list decoding checks the whole spine but not elements" $ do
       fmap length (toList (Fork poison Leaf)) @?= Right 1
       demanded (evaluate (toList (Fork Leaf poison)))
   , testCase "complete flat serialization demands hidden children" $
       demanded (evaluate (BS.length (encodeTreeTerm (Fork Leaf poison))))
   , testCase "complete indexed serialization demands hidden children" $
       demanded (buildBundleShared [("root", Fork Leaf poison)])
   , testCase "full observation visits a shared depth-80 DAG within a bounded interval" $ do
       let tower 0 = Leaf
           tower n = let child = tower (n - 1) in Fork child child
       outcome <- Timeout.timeout 2000000 (forceTreeShared (tower (80 :: Int)))
       outcome @?= Just ()
   , testCase "full observation demands hidden children and does not retain failures" $ do
       demanded (forceTreeShared (Fork Leaf poison))
       forceTreeShared (Fork Leaf (Stem Leaf))
   , testCase "full observation handles deep trees without expanding a recursive call stack" $ do
       let chain = foldr (\_ child -> Stem child) Leaf [1..65536 :: Int]
       outcome <- Timeout.timeout 2000000 (forceTreeShared chain)
       outcome @?= Just ()
   , testCase "stable local bindings and ordinary applications discard unused inputs" $ do
       forM_ ["main input = (ignored : 23) input",
              "main input = let unused = input in 23"] $ \source -> do
         function <- compileLocalControl [] source
         apply function poison @?= ofNumber 23
   , testCase "stable function consumes a finite prefix of an infinite producer" $ do
       function <- compileLocalControl [] $ unlines
         [ "main input = (let rec ones x = t x (ones x) in case (ones input) of"
         , "  [head | _] = head"
         , "  _ = 0)" ]
       apply function (ofNumber 23) @?= ofNumber 23
   ]
   where
     poison = error "evaluation-demand sentinel" :: T
     demanded :: IO a -> Assertion
     demanded action = do
       outcome <- try (action >> pure ()) :: IO (Either SomeException ())
       case outcome of
         Left err -> assertBool (show err) ("evaluation-demand sentinel" `isInfixOf` show err)
         Right () -> assertFailure "expected the observer to demand the poisoned subtree"
 
 -- Host-only negative controls: no source compiler or retained toolchain needed.
 artifactSafetyTests :: TestTree
 artifactSafetyTests = testGroup "artifact safety" $
   [ testGroup "alias components"
       [ testCase (show name) $ withSystemTempDirectory "tricu-alias-safety" $ \dir -> do
           let store = StorePath (dir </> "store")
               ref = treeTermRef (hashObject treeTermDomain (encodeTreeTerm Leaf))
           forM_ [NameAlias, ModuleAlias, PackageAlias] $ \kind -> do
             blocked "invalid alias name" (writeAlias store kind name ref)
             blocked "invalid alias name" (readAlias store kind name)
           doesDirectoryExist (unStorePath store) >>= (@?= False)
       | name <- ["", ".", "..", "../escape", "a/../../escape", "/absolute",
                  "a\\b", "C:escape", "C:\\escape", "a\NULb", "a\nb", "a\rb"]
       ]
   , testCase "flat import counts exponential DAGs without expansion" $ do
       let base = buildBundle [("root", Leaf)]
           graph = base { bundleNodes = Seq.fromList (BNLeaf : [BNFork (i-1) (i-1) | i <- [1..10000]])
                        , bundleRoots = [10000]
                        , bundleManifest = (bundleManifest base) { manifestRoots = [BundleRoot 10000 "default"],
                            manifestExports = [BundleExport "root" 10000 "term" "arboricx.abi.tree.v1"] } }
       case checkFlatImportSize defaultFlatImportLimit graph of
         Left err -> assertBool err ("flat import byte limit exceeded" `isInfixOf` err)
         Right () -> assertFailure "expanded size was not bounded"
   , testCase "flat byte accounting matches exact small serializations" $
       forM_ [Leaf, Stem Leaf, Fork (Stem Leaf) (Stem Leaf)] $ \tree -> do
         let bundle = buildBundle [("a", tree), ("b", tree)]
             size = 2 * fromIntegral (BS.length (encodeTreeTerm tree))
         checkFlatImportSize size bundle @?= Right ()
         assertBool "one byte under budget must fail" (either (const True) (const False) (checkFlatImportSize (size-1) bundle))
   , testCase "duplicate export names rejected by bundle and stored manifest readers" $ do
       let bundle = buildBundle [("same", Leaf), ("same", Stem Leaf)]
           manifest = ModuleManifest [] [ModuleExport "same" (treeTermRef (nodeHash NLeaf)) "arboricx.abi.tree.v1",
                                         ModuleExport "same" (treeTermRef (nodeHash NLeaf)) "arboricx.abi.tree.v1"]
       verifyBundle bundle @?= Left "duplicate export name"
       decodeManifest (encodeManifest manifest) @?= Left "duplicate export name"
   , testCase "qualified and symbolic aliases remain usable" $
       withSystemTempDirectory "tricu-alias-valid" $ \dir -> do
         let store = StorePath dir
             ref = treeTermRef (hashObject treeTermDomain (encodeTreeTerm Leaf))
         forM_ ["native_math.isNat?", "++", "hello world", "λ", ".hidden", "a..b"] $ \name -> do
           writeAlias store NameAlias name ref
           readAlias store NameAlias name >>= (@?= Just ref)
   , testCase "alias absolute paths cannot read or overwrite an outside sentinel" $
       withSystemTempDirectory "tricu-alias-sentinel" $ \dir -> do
         let store = StorePath (dir </> "store")
             outside = dir </> "sentinel"
             name = pack outside
             ref = treeTermRef (hashObject treeTermDomain (encodeTreeTerm Leaf))
         BS.writeFile outside "unchanged"
         blocked "invalid alias name" (writeAlias store NameAlias name ref)
         blocked "invalid alias name" (readAlias store NameAlias name)
         BS.readFile outside >>= (@?= "unchanged")
   , testGroup "object path hashes"
       [ testCase (show h) $ withSystemTempDirectory "tricu-hash-safety" $ \dir ->
           do
             blocked "invalid object hash" (getObject (StorePath dir) h)
             blocked "invalid object hash" (evaluate (objectPath (StorePath dir) h))
       | h <- ["", "../escape", "../../escape", "/absolute", "abc", pack (replicate 64 'A'),
               pack (replicate 63 'a'), pack (replicate 65 'a'), pack (replicate 64 'g')]
       ]
   , testCase "object paths cannot read an absolute outside sentinel" $
       withSystemTempDirectory "tricu-hash-sentinel" $ \dir -> do
         let outside = dir </> "sentinel"
         BS.writeFile outside "not a CAS object"
         blocked "invalid object hash" (getObject (StorePath (dir </> "store")) (pack outside))
   , testCase "cached authenticated objects are immutable snapshots" $ fresh $ \store -> do
       h <- putTreeTerm store Leaf
       resolver <- cachedFilesystemResolver store
       resolverObject resolver (treeTermRef h) >>= (@?= Just (encodeTreeTerm Leaf))
       BS.writeFile (objectPath store h) (encodeTreeTerm (Stem Leaf))
       resolverObject resolver (treeTermRef h) >>= (@?= Just (encodeTreeTerm Leaf))
       blocked "digest mismatch" (resolverObject (filesystemResolver store) (treeTermRef h))
   , testCase "object resolution verifies bytes from custom resolver callbacks" $ fresh $ \store -> do
       h <- putTreeTerm store Leaf
       mh <- putManifest store (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"])
       let resolver = (filesystemResolver store) { resolverObject = \_ -> pure (Just (encodeTreeTerm (Stem Leaf))) }
       blocked "digest mismatch" (resolveObjectByHash resolver (unDomain treeTermDomain) h)
   , testGroup "execution contract"
       [ testCase label $ do
           let base = buildBundle [("first", Leaf), ("second", Stem Leaf)]
               bundle = base { bundleManifest = change (bundleManifest base), bundleManifestBytes = BS.empty }
           case verifyBundle bundle of
             Left err -> assertBool err (needle `isInfixOf` err)
             Right () -> assertFailure "unsupported execution contract accepted"
       | (label, needle, change) <-
           [("evaluation", "runtime evaluation", \m -> m { manifestRuntime = (manifestRuntime m) { runtimeEvaluation = "call-by-value" } }),
            ("export kind", "export kind", \m -> m { manifestExports = map (\e -> e { exportKind = "foreign" }) (manifestExports m) }),
            ("second export ABI", "export ABI", \m -> m { manifestExports = case manifestExports m of
                [a,b] -> [a,b { exportAbi = "foreign.abi" }]; es -> es })]
       ]
   ] ++
   [ testGroup label
       [ testCase "tampered manifest" $ fresh $ \store -> do
           h <- putManifest store (ModuleManifest [] [])
           BS.writeFile (objectPath store h) (encodeManifest (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"]))
           resolver <- makeResolver store
           blocked "digest mismatch" (resolveManifest resolver h)
           blocked "digest mismatch" (getManifest store h)
       , testCase "tampered exported term" $ fresh $ \store -> do
           h <- putTreeTerm store Leaf
           mh <- putManifest store (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"])
           BS.writeFile (objectPath store h) (encodeTreeTerm (Stem Leaf))
           resolver <- makeResolver store
           blocked "digest mismatch" (resolveObjectByHash resolver (unDomain treeTermDomain) h)
           blocked "digest mismatch" (getTreeTerm store h)
       , testCase "tampered Merkle child" $ fresh $ \store -> do
           h <- putTree store (Stem Leaf)
           BS.writeFile (objectPath store (nodeHash NLeaf)) (serializeNode (NStem (pack (replicate 64 '0'))))
           resolver <- makeResolver store
           blocked "digest mismatch" (resolveTree resolver h)
           blocked "digest mismatch" (getTree store h)
       , testCase "tampered self-cycle rejected before hydration" $ fresh $ \store -> do
           h <- putTree store Leaf
           BS.writeFile (objectPath store h) (serializeNode (NStem h))
           resolver <- makeResolver store
           completed <- Timeout.timeout 1000000 (blocked "digest mismatch" (resolveTree resolver h))
           completed @?= Just ()
       , testCase "failed verification never poisons the cache" $ fresh $ \store -> do
           h <- putTreeTerm store Leaf
           resolver <- makeResolver store
           BS.writeFile (objectPath store h) (encodeTreeTerm (Stem Leaf))
           blocked "digest mismatch" (resolverObject resolver (treeTermRef h))
           BS.writeFile (objectPath store h) (encodeTreeTerm Leaf)
           resolverObject resolver (treeTermRef h) >>= (@?= Just (encodeTreeTerm Leaf))
       , testCase "wrong object domain" $ fresh $ \store -> do
           h <- putTreeTerm store Leaf
           resolver <- makeResolver store
           blocked "digest mismatch" (resolverObject resolver (ObjectRef (unDomain manifestDomain) h))
       -- Export ABI rejection is exercised against the production executable in
       -- executable_arguments.py, not the retired source-module resolver.
       , testCase "valid objects and genuine missing objects" $ fresh $ \store -> do
           h <- putTreeTerm store (Stem Leaf)
           mh <- putManifest store (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"])
           nh <- putTree store (Stem Leaf)
           resolver <- makeResolver store
           resolveManifest resolver mh >>= (@?= Just (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"]))
           resolveTree resolver nh >>= (@?= Just (Stem Leaf))
           resolveObjectByHash resolver (unDomain treeTermDomain) h >>= (@?= Just (encodeTreeTerm (Stem Leaf)))
           loadExecutableObject store (treeTermRef h) >>= (@?= Stem Leaf)
           resolverObject resolver (treeTermRef (pack (replicate 64 '0'))) >>= (@?= Nothing)
       ]
       | (label, makeResolver) <- [("filesystem integrity", pure . filesystemResolver), ("cached integrity", cachedFilesystemResolver)]
   ]
   where
     treeTermRef = ObjectRef (unDomain treeTermDomain)
     fresh f = withSystemTempDirectory "tricu-integrity" (f . StorePath)
     blocked needle action = do
       outcome <- try (action >> pure ()) :: IO (Either SomeException ())
       case outcome of
         Left err -> assertBool (show err) (needle `isInfixOf` show err)
         Right () -> assertFailure ("expected rejection: " ++ needle)
 
 sharedTreeDecodingTests :: TestTree
 sharedTreeDecodingTests = testGroup "shared inert tree decoding"
   [ testCase "small trees preserve exact structure and canonical bytes" $
       forM_ (trees 3) $ \tree -> do
         let bytes = encodeTreeTerm tree
         decodeTreeTermShared bytes @?= Right tree
         fmap encodeTreeTerm (decodeTreeTermShared bytes) @?= Right bytes
   , testCase "integer interning distinguishes constructors, pair order and wide IDs" $ do
       let keys = [Nodes.LeafKey] ++ map Nodes.StemKey values ++
                  [Nodes.ForkKey a b | a <- values, b <- values]
           values = [minBound, -1, 0, 1, 65535, maxBound] ++
                    map fromInteger [2147483647, 2147483648, 4294967295, 4294967296]
           entries = zip keys [(0 :: Int)..]
           table = foldl (\acc (key, value) -> Nodes.insert key value acc) Nodes.empty entries
           expected = Map.fromList entries
       forM_ (Map.toList expected) $ \(key, value) ->
         Nodes.lookup key table @?= Just value
       Nodes.lookup (Nodes.ForkKey 17 19) table @?= Nothing
       Nodes.lookup (Nodes.StemKey 17) table @?= Nothing
       let updated = Nodes.insert (Nodes.ForkKey 0 1) 999 table
       Nodes.lookup (Nodes.ForkKey 0 1) updated @?= Just 999
       Nodes.lookup (Nodes.ForkKey 1 0) updated @?= Map.lookup (Nodes.ForkKey 1 0) expected
   , testCase "deep shared decoding preserves bytes without recursive reference decoding" $ do
       let bytes = BS.replicate 65536 1 <> BS.singleton 0
       decoded <- either assertFailure pure (decodeTreeTermShared bytes)
       encodeTreeTerm decoded @?= bytes
   , testCase "malformed bytes retain ordinary decoder errors" $
       forM_ (concat [sequence (replicate n [0, 1, 2, 255]) | n <- [0..4]]) $ \tags ->
         decodeTreeTermShared (BS.pack tags) @?= decodeTreeTerm (BS.pack tags)
   , testCase "repeated branches regain physical sharing without application" $ do
       let tower 0 = Fork (Stem Leaf) Leaf
           tower n = let child = tower (n - 1) in Fork child child
           value = tower (14 :: Int)
       decoded <- either assertFailure pure (decodeTreeTermShared (encodeTreeTerm value))
       let check (Fork left right) = do
             a <- evaluate left >>= makeStableName
             b <- evaluate right >>= makeStableName
             assertBool "equal branches were separately allocated" (a == b)
           check _ = assertFailure "missing fork"
       check decoded
       case decoded of
         Fork left _ -> check left
         _ -> assertFailure "missing root"
   ]
   where
     trees 0 = [Leaf]
     trees n = let children = trees (n - 1)
               in Leaf : map Stem children ++ [Fork a b | a <- children, b <- children]
 
 -- Indexed IO transports inert normal forms. The tiny exponential logical tree
 -- is deliberately never unfolded for equality/encoding by these controls.
 indexedTreeTransportTests :: TestTree
 indexedTreeTransportTests = testGroup "indexed tree transport"
   [ testCase "canonical bytes agree with independent ordinary writer" $
       forM_ (trees 2) $ \tree -> do
         encoded <- encodeIndexedTree tree
         encoded @?= encodeBundle (buildBundle [("root", tree)])
         decodeIndexedTree encoded @?= Right tree
   , testCase "shared depth-80 tree encodes within a bounded interval" $ do
       let tower 0 = Leaf
           tower n = let child = tower (n - 1) in Fork child child
       measured <- Timeout.timeout 2000000 $ do
         payload <- encodeIndexedTree (tower (80 :: Int))
         size <- evaluate (BS.length payload)
         assertBool "DAG unexpectedly expanded" (size < 2048)
         bundle <- either assertFailure pure (decodeBundle payload)
         Seq.length (bundleNodes bundle) @?= 81
         value <- either assertFailure pure (decodeIndexedTree payload)
         case value of
           Fork left right -> do
             a <- evaluate left >>= makeStableName
             b <- evaluate right >>= makeStableName
             assertBool "decoded branches lost sharing" (a == b)
           _ -> assertFailure "missing fork"
       measured @?= Just ()
   , testCase "shared writer is name-neutral and byte-identical to indexed import" $
       withSystemTempDirectory "tricu-indexed-import" $ \dir -> do
         let tree = Fork (Stem Leaf) (Stem Leaf)
         encoded <- encodeIndexedTree tree
         [(name, pin)] <- unpackIndexedBundleToStore (StorePath dir)
           (encodeBundle (buildBundle [("publicName", tree)]))
         name @?= "publicName"
         pin @?= hashObject indexedTreeDomain encoded
   , testCase "hash, no-replace publication, repeat and read exact inert tree" $
       withSystemTempDirectory "tricu-indexed-io" $ \dir -> do
         let tree = Fork (Stem (Fork Leaf Leaf)) (Fork Leaf (Stem Leaf))
             path = dir </> "object"
         payload <- encodeIndexedTree tree
         let pin = hashObject indexedTreeDomain payload
         action unsafePerms 51 tree >>= (@?= Right (ioOkResult (ofString (unpack pin))))
         writeIndexed unsafePerms path pin tree >>= (@?= Right (ioOkResult (Stem Leaf)))
         BS.readFile path >>= (@?= payload)
         writeIndexed unsafePerms path pin tree >>= (@?= Right (ioOkResult Leaf))
         readIndexed unsafePerms path pin >>= (@?= Right (ioOkResult tree))
   , testCase "read checks permission, canonical digest, and domain" $
       withSystemTempDirectory "tricu-indexed-denied" $ \dir -> do
         let path = dir </> "object"
         payload <- encodeIndexedTree Leaf
         BS.writeFile path payload
         let pin = hashObject indexedTreeDomain payload
         readIndexed defaultPerms path pin >>= (@?= Right (ioErrResult "permission denied"))
         readIndexed unsafePerms path "BAD" >>= (@?= Right (ioErrResult "invalid CAS digest"))
         readIndexed unsafePerms path (hashObject treeTermDomain payload)
           >>= (@?= Right (ioErrResult "CAS digest mismatch"))
   , testCase "verification precedes malformed indexed payload decoding" $
       withSystemTempDirectory "tricu-indexed-bad" $ \dir -> do
         let path = dir </> "object"
             payload = "bad bundle"
         BS.writeFile path payload
         readIndexed unsafePerms path (pack (replicate 64 '0'))
           >>= (@?= Right (ioErrResult "CAS digest mismatch"))
         readIndexed unsafePerms path (hashObject indexedTreeDomain payload)
           >>= (@?= Right (ioErrResult "invalid indexed tree"))
         let named = encodeBundle (buildBundle [("other", Leaf)])
         BS.writeFile path named
         readIndexed unsafePerms path (hashObject indexedTreeDomain named)
           >>= (@?= Right (ioErrResult "invalid indexed tree"))
   , testCase "publication needs both permissions and never overwrites corruption" $
       withSystemTempDirectory "tricu-indexed-publish" $ \dir -> do
         let path = dir </> "object"
         payload <- encodeIndexedTree Leaf
         let pin = hashObject indexedTreeDomain payload
         forM_ [defaultPerms { allowRead = [dir] }, defaultPerms { allowWrite = [dir] }] $ \perms ->
           writeIndexed perms path pin Leaf >>= (@?= Right (ioErrResult "permission denied"))
         doesFileExist path >>= (@?= False)
         writeIndexed unsafePerms path (pack (replicate 64 '0')) Leaf
           >>= (@?= Right (ioErrResult "CAS digest mismatch"))
         doesFileExist path >>= (@?= False)
         BS.writeFile path "existing corruption"
         writeIndexed unsafePerms path pin Leaf
           >>= (@?= Right (ioErrResult "CAS object exists with different bytes"))
         BS.readFile path >>= (@?= "existing corruption")
   ]
   where
     trees 0 = [Leaf]
     trees n = let xs = trees (n - 1) in Leaf : map Stem xs ++ [Fork a b | a <- xs, b <- xs]
     action perms tag payload = runIO perms $
       Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber tag) payload))
     readIndexed perms path pin = action perms 50 (Fork (ofString path) (ofString (unpack pin)))
     writeIndexed perms path pin tree = action perms 52
       (Fork (ofString path) (Fork (ofString (unpack pin)) tree))
 
 -- Small host/unit codec gate, not compiler-closure compilation. Raw trees
 -- must be inspected/encoded without invoking them as functions.
 verifiedTreeLoadingTests :: TestTree
 verifiedTreeLoadingTests = testGroup "verified tree loading"
   [ testCase "exact inert tree, including function-shaped forks" $
       withSystemTempDirectory "tricu-tree-load" $ \dir -> do
         let value = Fork (Stem (Fork Leaf Leaf)) (Fork Leaf (Stem Leaf))
             payload = encodeTreeTerm value
             path = dir </> "object"
         BS.writeFile path payload
         readTerm (defaultPerms { allowRead = [dir] }) path
           (unpack (hashObject treeTermDomain payload)) >>= (@?= Right (ioOkResult value))
   , testCase "read denied even with write permission" $
       withSystemTempDirectory "tricu-tree-denied" $ \dir -> do
         let payload = BS.singleton 0
             path = dir </> "object"
         BS.writeFile path payload
         readTerm (defaultPerms { allowWrite = [dir] }) path
           (unpack (hashObject treeTermDomain payload)) >>= (@?= Right (ioErrResult "permission denied"))
   , testCase "symlink does not bypass read permission" $
       withSystemTempDirectory "tricu-tree-link" $ \dir -> do
         let allowed = dir </> "allowed"
             denied = dir </> "outside"
             link = allowed </> "link"
             payload = BS.singleton 0
         createDirectory allowed
         BS.writeFile denied payload
         createFileLink denied link
         readTerm (defaultPerms { allowRead = [allowed] }) link
           (unpack (hashObject treeTermDomain payload)) >>= (@?= Right (ioErrResult "permission denied"))
   , testCase "missing file" $
       withSystemTempDirectory "tricu-tree-missing" $ \dir ->
         readTerm (defaultPerms { allowRead = [dir] }) (dir </> "missing")
           (replicate 64 '0') >>= (@?= Right (ioErrResult "does not exist"))
   , testCase "mismatched digest precedes decoding" $
       withSystemTempDirectory "tricu-tree-mismatch" $ \dir -> do
         let path = dir </> "object"
         BS.writeFile path (BS.singleton 255)
         readTerm unsafePerms path (replicate 64 '0') >>= (@?= Right (ioErrResult "CAS digest mismatch"))
   , testCase "wrong domain rejected" $
       withSystemTempDirectory "tricu-tree-domain" $ \dir -> do
         let payload = BS.singleton 0
             path = dir </> "object"
         BS.writeFile path payload
         readTerm unsafePerms path (unpack (hashObject (Domain "wrong.domain") payload))
           >>= (@?= Right (ioErrResult "CAS digest mismatch"))
   , testCase "digest must be canonical lowercase hexadecimal" $
       forM_ ["bad", replicate 64 'G', replicate 64 'A', replicate 63 '0'] $ \digest ->
         readTerm unsafePerms "/definitely-missing" digest >>= (@?= Right (ioErrResult "invalid CAS digest"))
   , testCase "malformed canonical payloads rejected after valid digest" $
       withSystemTempDirectory "tricu-tree-malformed" $ \dir ->
         forM_ [BS.empty, BS.pack [1], BS.pack [2,0], BS.pack [3], BS.pack [0,0]] $ \payload -> do
           let path = dir </> "object"
           BS.writeFile path payload
           readTerm unsafePerms path (unpack (hashObject treeTermDomain payload))
             >>= (@?= Right (ioErrResult "invalid canonical tree-term"))
   , testCase "invalid argument strings" $ do
       runAction unsafePerms (Stem Leaf) (ofString (replicate 64 '0'))
         >>= (@?= Right (ioErrResult "invalid string"))
   , testCase "readTreeTerm library constructor" $
       withSystemTempDirectory "tricu-tree-constructor" $ \dir -> do
         let value = Stem Leaf
             payload = encodeTreeTerm value
             path = dir </> "object"
         BS.writeFile path payload
         let io = fixtureExports "io"
             action = apply (io Map.! "io") (foldl apply (io Map.! "readTreeTerm")
               [ofString path, ofString (unpack (hashObject treeTermDomain payload))])
         runIO (defaultPerms { allowRead = [dir] }) action >>= (@?= Right (ioOkResult value))
   ]
   where
     readTerm perms path digest = runAction perms (ofString path) (ofString digest)
     runAction perms path digest = runIO perms $
       Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 34) (Fork path digest)))
 
 verifiedTreePublicationTests :: TestTree
 verifiedTreePublicationTests = testGroup "verified tree publication"
   [ testCase "canonical hashing agrees with independent bytes" $ do
       let value = Fork (Stem Leaf) (Fork Leaf (Stem Leaf))
           golden = BS.pack [2,1,0,2,0,1,0]
       encodeTreeTerm value @?= golden
       hashTerm value >>= (@?= Right (ioOkResult (ofString (unpack (hashObject treeTermDomain golden)))))
   , testCase "new publication has exact bytes and no temporary residue" $
       withSystemTempDirectory "tricu-tree-publish" $ \dir -> do
         let path = dir </> "object"
             tree = Fork (Stem Leaf) Leaf
             payload = BS.pack [2,1,0,0]
         publish (permissions dir) path (digest payload) tree >>= (@?= Right (ioOkResult (Stem Leaf)))
         BS.readFile path >>= (@?= payload)
         listDirectory dir >>= (@?= ["object"])
   , testCase "existing identical object returns false" $
       withSystemTempDirectory "tricu-tree-existing" $ \dir -> do
         let path = dir </> "object"
             tree = Stem Leaf
             payload = BS.pack [1,0]
         BS.writeFile path payload
         publish (permissions dir) path (digest payload) tree >>= (@?= Right (ioOkResult Leaf))
         BS.readFile path >>= (@?= payload)
   , testCase "corrupt winner is not replaced" $
       withSystemTempDirectory "tricu-tree-corrupt" $ \dir -> do
         let path = dir </> "object"
             old = BS.pack [255]
         BS.writeFile path old
         publish (permissions dir) path (digest (BS.singleton 0)) Leaf
           >>= (@?= Right (ioErrResult "CAS object exists with different bytes"))
         BS.readFile path >>= (@?= old)
         listDirectory dir >>= (@?= ["object"])
   , testCase "mismatch fails before publication" $
       withSystemTempDirectory "tricu-tree-wrong" $ \dir -> do
         publish (permissions dir) (dir </> "object") (replicate 64 '0') Leaf
           >>= (@?= Right (ioErrResult "CAS digest mismatch"))
         listDirectory dir >>= (@?= [])
   , testCase "write denied without forcing tree" $
       withSystemTempDirectory "tricu-tree-write-denied" $ \dir -> do
         publish (defaultPerms { allowRead = [dir] }) (dir </> "object")
           (digest (BS.singleton 0)) (error "denied write must not force tree")
           >>= (@?= Right (ioErrResult "permission denied"))
         listDirectory dir >>= (@?= [])
   , testCase "read denied without forcing tree" $
       withSystemTempDirectory "tricu-tree-read-denied" $ \dir -> do
         publish (defaultPerms { allowWrite = [dir] }) (dir </> "object")
           (digest (BS.singleton 0)) (error "denied read must not force tree")
           >>= (@?= Right (ioErrResult "permission denied"))
         listDirectory dir >>= (@?= [])
   , testCase "symlink does not bypass write permission" $
       withSystemTempDirectory "tricu-tree-write-link" $ \dir -> do
         let allowed = dir </> "allowed"
             outside = dir </> "outside"
             link = allowed </> "link"
             payload = BS.singleton 0
         createDirectory allowed
         BS.writeFile outside payload
         createFileLink outside link
         publish (permissions allowed) link (digest payload) Leaf
           >>= (@?= Right (ioErrResult "permission denied"))
         BS.readFile outside >>= (@?= payload)
   , testCase "invalid digest fails without filesystem effects" $
       withSystemTempDirectory "tricu-tree-bad-digest" $ \dir -> do
         forM_ ["bad", replicate 64 'G', replicate 64 'A'] $ \bad ->
           publish (permissions dir) (dir </> "object") bad Leaf
             >>= (@?= Right (ioErrResult "invalid CAS digest"))
         listDirectory dir >>= (@?= [])
   , testCase "parent creation remains explicit" $
       withSystemTempDirectory "tricu-tree-parent" $ \dir -> do
         publish (permissions dir) (dir </> "missing" </> "object") (digest (BS.singleton 0)) Leaf
           >>= (@?= Right (ioErrResult "does not exist"))
         listDirectory dir >>= (@?= [])
   , testCase "concurrent publishers have one winner" $
       withSystemTempDirectory "tricu-tree-race" $ \dir -> do
         let tree = iterate (\t -> Fork t t) Leaf !! 12
             bytes = encodeTreeTerm tree
             path = dir </> "object"
             action = publish (permissions dir) path (digest bytes) tree
         a <- newEmptyMVar
         b <- newEmptyMVar
         _ <- forkIO (action >>= putMVar a)
         _ <- forkIO (action >>= putMVar b)
         results <- sequence [takeMVar a, takeMVar b]
         length (filter (== Right (ioOkResult (Stem Leaf))) results) @?= 1
         length (filter (== Right (ioOkResult Leaf)) results) @?= 1
         BS.readFile path >>= (@?= bytes)
         listDirectory dir >>= (@?= ["object"])
   , testCase "sourceObjectPutTree creates canonical shards and reuses objects" $
       withSystemTempDirectory "tricu-tree-library" $ \dir -> do
         env <- evaluateCompilerFile "./lib/source/object.tri"
         let root = dir </> "cas"
             tree = Fork Leaf (Stem Leaf)
             payload = encodeBundle (buildBundle [("root", tree)])
             expected = unpack (hashObject indexedTreeDomain payload)
             action = sentinel (apply (apply (env Map.! "sourceObjectPutTree") (ofString root)) tree)
             path = root </> "objects" </> take 3 expected </> expected
         runIO (permissions dir) action >>= (@?= Right (ioOkResult (ofString expected)))
         runIO (permissions dir) action >>= (@?= Right (ioOkResult (ofString expected)))
         BS.readFile path >>= (@?= payload)
   ]
   where
     digest = unpack . hashObject treeTermDomain
     permissions dir = defaultPerms { allowRead = [dir], allowWrite = [dir] }
     sentinel action = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
     hashTerm tree = runIO defaultPerms (sentinel (Fork (ofNumber 35) tree))
     publish perms path expected tree = runIO perms $
       sentinel (Fork (ofNumber 36) (Fork (ofString path) (Fork (ofString expected) tree)))
 
 sourceObjectCodecTests :: TestTree
 sourceObjectCodecTests = testGroup "Portable tree object codec"
   [ testCase "canonical preorder bytes, suffix law and complete round trip" $
       withSystemTempDirectory "source-object-codec" $ \dir -> do
         env <- evaluateCompilerFile "./lib/source/object.tri"
         let encoder = env Map.! "sourceObjectEncode"
             fixed = env Map.! "sourceObjectEncodeOnto"
             decoder = env Map.! "sourceObjectDecodeComplete"
             suffix = BS.pack [7, 0, 255]
             seeds = [Leaf, Stem Leaf, Fork Leaf Leaf]
             small = seeds ++ [Fork l r | l <- seeds, r <- seeds]
             leftHeavy = iterate (\tree -> Fork tree Leaf) Leaf !! 64
             rightHeavy = iterate (Fork Leaf) Leaf !! 64
             balanced = iterate (\tree -> Fork tree tree) Leaf !! 8
         forM_ (small ++ [leftHeavy, rightHeavy, balanced]) $ \tree -> do
           let bytes = encodeTreeTerm tree
               encoded = apply encoder tree
           toBytes encoded @?= Right bytes
           toBytes (apply (apply fixed tree) (ofBytes suffix)) @?=
             Right (bytes <> suffix)
           apply decoder encoded @?= Fork (Stem Leaf) (Fork tree Leaf)
   ]
 
 fileEval :: TestTree
 fileEval = testGroup "Portable source file tests"
   [ testCase "Forks" $ check "./test/fork.tri" (Fork Leaf Leaf)
   , testCase "File ends with comment" $ check "./test/comments-1.tri" (Fork (Stem Leaf) Leaf)
   , testCase "Mapping and Equality" $ check "./test/map.tri" (Stem Leaf)
   , testCase "Eval and decoding string" $ check "./test/string.tri" (ofString "String test!")
   ]
   where
     check path expected = do
       source <- readFile path
       let external = ofList [Fork (ofString name) value | (name,value) <- Map.toList (fixtureExports "prelude")]
       foldl apply (fixtureExports "source.unit" Map.! "compileGateProgram")
         [external, ofString source] @?= parserOk expected Leaf
 
 -- All of our demo tests are also module tests
 demos :: TestTree
 demos = testGroup "Test provided demo functionality"
   [ testCase "Constructor-safe lowering matches the authored Boolean not tree" $ do
       env <- evaluateCompilerFile "./demos/equality.tri"
       -- Constructor-only K pruning intentionally changes inspectable function
       -- trees. This specimen now equals its authored TC form; that is not a
       -- structural-equivalence promise for arbitrary extensional functions.
       env Map.! "main" @?= Stem Leaf
       env Map.! "not_TC?" @?=
         Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork Leaf (Fork Leaf Leaf))
       env Map.! "not_Lambda?" @?= env Map.! "not_TC?"
       forM_ ["not_TC?", "not_Lambda?"] $ \name -> do
         apply (env Map.! name) Leaf @?= Stem Leaf
         apply (env Map.! name) (Stem Leaf) @?= Leaf
       env Map.! "bothTrueEqual?" @?= Stem Leaf
       env Map.! "bothFalseEqual?" @?= Stem Leaf
   , testCase "Convert values back to source code demo" $ do
       res     <- liftIO $ ((Map.! "main") <$> evaluateCompilerFile "./demos/toSource.tri")
       -- Native portable foundation trees, not the Haskell recovery cohort.
       decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
   , testCase "Determining the size of stable-compiled functions" $ do
       env <- evaluateCompilerFile "./demos/size.tri"
       -- Count the actual executable independently of the compiled size worker.
       -- This is a representation check of the retained stable artifact,
       -- not a parity requirement across compiler backends.
       let nodes Leaf = 1 :: Integer
           nodes (Stem child) = 1 + nodes child
           nodes (Fork left right) = 1 + nodes left + nodes right
           actual = nodes (env Map.! "size")
       -- Constructor-K publication: the independent host count changes from
       -- 1845 to 1233; the compiled worker must still count its actual tree.
       actual @?= 1233
       env Map.! "main" @?= ofNumber actual
   , testCase "Level Order Traversal demo" $ do
       res     <- liftIO $ ((Map.! "main") <$> evaluateCompilerFile "./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 $ ((Map.! "main") <$> evaluateCompilerFile "./demos/contractEffects.tri")
       decodeResult res @?= "[t t, 10]"
   , testCase "Safe base wrappers demo" $ do
       res     <- liftIO $ ((Map.! "main") <$> evaluateCompilerFile "./demos/contractBasics.tri")
       decodeResult res @?= "[3, t t, t, t t]"
   ]
 
 decoding :: TestTree
 decoding = testGroup "Decoding Tests"
   [ testCase "Decode Leaf" $ do
       decodeResult Leaf @?= "t"
 
   , testCase "Decode list of non-ASCII numbers" $ do
       let input = ofList [ofNumber 1, ofNumber 14, ofNumber 6]
       decodeResult input @?= "[1, 14, 6]"
 
   , testCase "Decode list of ASCII numbers as a string" $ do
       let input = ofList [ofNumber 97, ofNumber 98, ofNumber 99]
       decodeResult input @?= "\"abc\""
 
   , testCase "Decode small number" $ do
       decodeResult (ofNumber 42) @?= "42"
 
   , testCase "Decode large number" $ do
       decodeResult (ofNumber 9999) @?= "9999"
 
   , testCase "Decode string in list" $ do
       let input = ofList [ofString "hello", ofString "world"]
       decodeResult input @?= "[\"hello\", \"world\"]"
 
   , testCase "Decode mixed list with strings" $ do
       let input = ofList [ofString "hello", ofNumber 42, ofString "world"]
       decodeResult input @?= "[\"hello\", 42, \"world\"]"
 
   , testCase "Decode nested lists with strings" $ do
       let input = ofList [ofList [ofString "nested"], ofString "string"]
       decodeResult input @?= "[[\"nested\"], \"string\"]"
   ]
 
 -- --------------------------------------------------------------------------
 -- Byte marshalling tests
 -- --------------------------------------------------------------------------
 
 byteMarshallingTests :: TestTree
 byteMarshallingTests = testGroup "Byte Marshalling Tests"
   [ testCase "ofByte / toByte round-trip: 0" $ do
       let w8 = (0 :: Word8)
       toByte (ofByte w8) @?= Right w8
 
   , testCase "ofByte / toByte round-trip: 1" $ do
       let w8 = (1 :: Word8)
       toByte (ofByte w8) @?= Right w8
 
   , testCase "ofByte / toByte round-trip: 127" $ do
       let w8 = (127 :: Word8)
       toByte (ofByte w8) @?= Right w8
 
   , testCase "ofByte / toByte round-trip: 128" $ do
       let w8 = (128 :: Word8)
       toByte (ofByte w8) @?= Right w8
 
   , testCase "ofByte / toByte round-trip: 255" $ do
       let w8 = (255 :: Word8)
       toByte (ofByte w8) @?= Right w8
 
   , testCase "toByte rejects value > 255" $ do
       -- ofNumber 256 = Fork Leaf (Fork Leaf Leaf) — value 256
       toByte (ofNumber 256) @?= Left "Byte value out of range: 256"
 
   , testCase "toByte accepts Leaf" $ do
       toByte (Leaf) @?= Right 0
 
   , testCase "toByte rejects non-number tree" $ do
       toByte (Stem Leaf) @?= Left "Invalid Tree Calculus number"
       toByte (Stem (Stem Leaf)) @?= Left "Invalid Tree Calculus number"
 
   , testCase "ofBytes / toBytes round-trip: empty ByteString" $ do
       toBytes (ofBytes BS.empty) @?= Right BS.empty
 
   , testCase "ofBytes / toBytes round-trip: [0x00]" $ do
       toBytes (ofBytes (BS.pack [0x00])) @?= Right (BS.pack [0x00])
 
   , testCase "ofBytes / toBytes round-trip: [0xff]" $ do
       toBytes (ofBytes (BS.pack [0xff])) @?= Right (BS.pack [0xff])
 
   , testCase "ofBytes / toBytes round-trip: mixed bytes" $ do
       let bytes = BS.pack [0x00, 0x01, 0x7f, 0x80, 0xff, 0x41, 0x42, 0x43]
       toBytes (ofBytes bytes) @?= Right bytes
 
   , testCase "toBytes rejects non-list tree" $ do
       -- Leaf is a valid list (empty), so this won't work.
       -- Stem Leaf is not a list.
       toBytes (Stem Leaf) @?= Left "Invalid Tree Calculus list"
 
   , testCase "toBytes rejects list containing invalid byte (>255)" $ do
       -- [ofNumber 256, ofNumber 1] — first element is > 255
       let badList = ofList [ofNumber 256, ofNumber 1]
       toBytes badList @?= Left "Byte value out of range: 256"
 
   , testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Leaf payload" $ do
       -- Leaf payload is 0x00 (1 byte)
       let payload = BS.pack [0x00]
       treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
 
   , testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Stem payload" $ do
       -- Stem payload: 0x01 || 32-byte hash = 33 bytes
       let payload = BS.pack (0x01 : replicate 32 0x42)
       treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
 
   , testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Fork payload" $ do
       -- Fork payload: 0x02 || 32-byte hash || 32-byte hash = 65 bytes
       let payload = BS.pack (0x02 : replicate 64 0x42)
       treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
 
   , testCase "hashToTreeBytes / treeBytesToHash round-trip" $ do
       -- Use a known 32-byte hash (SHA256 of "")
       let hashStr :: MerkleHash
           hashStr = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
       case hashToTreeBytes hashStr of
         Left err -> assertFailure $ "hashToTreeBytes failed: " ++ err
         Right tree -> treeBytesToHash tree @?= Right hashStr
 
   , testCase "hashToTreeBytes rejects invalid hex hash" $ do
       hashToTreeBytes "not-a-hash" @?= Left "Invalid hex MerkleHash"
 
   , testCase "hashToTreeBytes rejects non-32-byte hash" $ do
       -- "00" decodes to 1 byte, not 32
       hashToTreeBytes "00" @?= Left "Hash raw bytes must be 32 bytes"
 
   , testCase "treeBytesToHash rejects wrong byte count" $ do
       -- Only 16 bytes, not 32
       let t16 = ofBytes (BS.pack [0x41 | _ <- [1..16]])
       treeBytesToHash t16 @?= Left "Expected exactly 32 byte elements for hash"
   ]
 
 -- --------------------------------------------------------------------------
 -- Content store tests
 -- --------------------------------------------------------------------------
 
 contentStoreTests :: TestTree
 contentStoreTests = testGroup "Content Store Tests"
   [ testCase "Filesystem CAS: put/get object and sharded path" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             domain = Domain "test.object.v1"
             payload = BS.pack [1, 2, 3, 4]
         h <- putObject store domain payload
         shardForHash h @?= take 3 (unpack h)
         objectPath store h @?= dir </> "objects" </> take 3 (unpack h) </> unpack h
         doesFileExist (objectPath store h) >>= (@?= True)
         getObject store h >>= (@?= Just payload)
 
   , testCase "Filesystem CAS: idempotent object writes" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             domain = Domain "test.object.v1"
             payload = BS.pack [9, 8, 7]
         h1 <- putObject store domain payload
         h2 <- putObject store domain payload
         h1 @?= h2
         countStoredObjects store >>= (@?= 1)
 
   , testCase "Filesystem CAS: putTree/getTree round trip" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             term = Fork (Stem Leaf) (Fork Leaf (Stem Leaf))
             leafHash = nodeHash NLeaf
             stemHash = nodeHash (NStem leafHash)
             rightHash = nodeHash (NFork leafHash stemHash)
             expectedRoot = nodeHash (NFork stemHash rightHash)
         root <- putTree store term
         root @?= expectedRoot
         getTree store root >>= (@?= Just term)
 
   , testCase "Filesystem CAS: shared subtrees are deduplicated" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             shared = Stem Leaf
             term = Fork shared shared
         _ <- putTree store term
         countStoredObjects store >>= (@?= 3)
 
   , testCase "Workspace aliases: write/read/list object refs" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             ref = ObjectRef "arboricx.tree-root.v1" "abc123"
         writeAlias store NameAlias "main" ref
         readAlias store NameAlias "main" >>= (@?= Just ref)
         listAliases store NameAlias >>= (@?= [("main", ref)])
 
   , testCase "Module manifests: put/get round trip through CAS" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             term = Fork Leaf (Stem Leaf)
             manifestFor root = ModuleManifest []
               [ ModuleExport
                   "main"
                   (ObjectRef (unDomain treeTermDomain) root)
                   "arboricx.abi.tree.v1"
               ]
         root <- putTreeTerm store term
         h <- putManifest store (manifestFor root)
         getManifest store h >>= (@?= Just (manifestFor root))
 
   , testCase "ObjectResolver: resolves manifests and trees without filesystem coupling" $ do
       let term = Fork Leaf (Stem Leaf)
           leafH = nodeHash NLeaf
           stemH = nodeHash (NStem leafH)
           rootH = nodeHash (NFork leafH stemH)
           termH = hashObject treeTermDomain (encodeTreeTerm term)
           manifest = ModuleManifest []
             [ ModuleExport
                 "value"
                 (ObjectRef (unDomain treeTermDomain) termH)
                 "arboricx.abi.tree.v1"
               ]
           manifestBytes = encodeManifest manifest
           manifestH = hashObject manifestDomain manifestBytes
           objects = Map.fromList
             [ (("arboricx.merkle.node.v1", leafH), serializeNode NLeaf)
             , (("arboricx.merkle.node.v1", stemH), serializeNode (NStem leafH))
             , (("arboricx.merkle.node.v1", rootH), serializeNode (NFork leafH stemH))
             , ((unDomain treeTermDomain, termH), encodeTreeTerm term)
             , ((unDomain manifestDomain, manifestH), manifestBytes)
             ]
           hydrate objs h = case deserializeNode <$> Map.lookup ("arboricx.merkle.node.v1", h) objs of
             Nothing -> return Nothing
             Just NLeaf -> return (Just Leaf)
             Just (NStem child) -> fmap Stem <$> hydrate objs child
             Just (NFork left right) -> do
               l <- hydrate objs left
               r <- hydrate objs right
               return $ Fork <$> l <*> r
           resolver = ObjectResolver
             { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
                 then Just (ObjectRef (unDomain manifestDomain) manifestH)
                 else Nothing
             , resolverObject = \ref -> return $ Map.lookup (objectRefKind ref, objectRefHash ref) objects
             , resolverManifest = \h -> return $ do
                 bytes <- Map.lookup (unDomain manifestDomain, h) objects
                 either (const Nothing) Just (decodeManifest bytes)
             , resolverTree = hydrate objects
             }
       resolverAlias resolver ModuleAlias "demo" >>= (@?= Just (ObjectRef (unDomain manifestDomain) manifestH))
       resolveManifest resolver manifestH >>= (@?= Just manifest)
       resolveTree resolver rootH >>= (@?= Just term)
 
   , testCase "Arboricx bundle: unpack transport bundle into CAS tree terms" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             term = Fork (Stem Leaf) Leaf
             bundle = buildBundle [("main", term)]
         exports <- unpackBundleToStore store (encodeBundle bundle)
         case exports of
           [("main", root)] -> getTreeTerm store root >>= (@?= Just term)
           other -> assertFailure $ "unexpected exports: " ++ show other
 
   , testCase "Indexed CAS: extract roots without labels or unrelated nodes affecting identity" $ do
       let term = Fork (Stem Leaf) (Stem Leaf)
           first = buildBundle [("alpha", term)]
           second = buildBundle [("unrelated", ofNumber 99), ("beta", term)]
           [ex] = manifestExports (bundleManifest first)
           [_, other] = manifestExports (bundleManifest second)
       a <- either assertFailure pure (extractBundleRoot first $ exportRoot ex)
       b <- either assertFailure pure (extractBundleRoot second $ exportRoot other)
       encodeBundle a @?= encodeBundle b
       decodeIndexedTree (encodeBundle a) @?= Right term
       hashObject indexedTreeDomain (encodeBundle a) /= hashObject treeTermDomain (encodeTreeTerm term) @? "distinct object identities"
 
   , testCase "Indexed CAS: exponentially shared logical tree stays an indexed graph" $ do
       let base = buildBundle [("unused", Leaf)]
           graph = base { bundleNodes = Seq.fromList
             (BNLeaf : [BNFork (i - 1) (i - 1) | i <- [1..80]]) }
       root <- either assertFailure pure (extractBundleRoot graph 80)
       Seq.length (bundleNodes root) @?= 81
       BS.length (encodeBundle root) < 2048 @? "graph storage must not expand 2^81-1 logical nodes"
       case decodeIndexedTree (encodeBundle root) of
         Right (Fork _ _) -> pure ()
         other -> assertFailure $ "expected shared fork, got " ++ either id (const "non-fork") other
 
   , testCase "Indexed CAS: multiple exports become independently loadable objects" $
       withSystemTempDirectory "tricu-indexed-store" $ \dir -> do
         let store = StorePath dir
             terms = [("left", ofNumber 23), ("right", ofNumber 24)]
         roots <- unpackIndexedBundleToStore store (encodeBundle $ buildBundle terms)
         map fst roots @?= map fst terms
         forM_ (zip roots terms) $ \((_, digest), (_, term)) -> do
           payload <- getObject store digest >>= maybe (assertFailure "missing indexed object" >> pure BS.empty) pure
           hashObject indexedTreeDomain payload @?= digest
           decodeIndexedTree payload @?= Right term
 
   , testCase "Indexed CAS: reject malformed graphs and ambiguous root containers" $ do
       let leaf = buildBundle [("root", Leaf)]
           forward = leaf { bundleNodes = Seq.singleton (BNStem 0) }
           multiple = buildBundle [("a", Leaf), ("b", Stem Leaf)]
       case extractBundleRoot forward 0 of
         Left _ -> pure ()
         Right _ -> assertFailure "accepted cyclic node"
       case extractBundleRoot leaf 1 of
         Left _ -> pure ()
         Right _ -> assertFailure "accepted out-of-range root"
       case decodeIndexedTree (encodeBundle multiple) of
         Left _ -> pure ()
         Right _ -> assertFailure "accepted multiple root container"
 
   , testCase "Streaming pack: exact legacy bundle bytes across chunk boundaries" $ do
       let terms = [(pack ("value" ++ show n), ofNumber n) | n <- [0..128]] ++
                   [("alias", ofNumber 97), ("tree", Fork (Stem Leaf) (Fork Leaf Leaf))]
           packed chunkSize = do
             builder <- foldM (appendTerm chunkSize) emptyTreeTermBundle terms
             pure (finishTreeTermBundle builder)
           appendTerm chunkSize builder (name, term) = do
             let chunks bytes | BS.null bytes = []
                              | otherwise = let (first, rest) = BS.splitAt chunkSize bytes
                                            in first : chunks rest
             cursor <- foldM (flip feedTreeTerm) (startTreeTerm builder) (chunks (encodeTreeTerm term))
             endTreeTerm name cursor
       forM_ [1, 2, 3, 7, 65536] $ \chunkSize -> do
         actual <- either assertFailure pure (packed chunkSize)
         encodeBundle actual @?= encodeBundle (buildBundle terms)
         verifyBundle actual @?= Right ()
       encodeBundle (finishTreeTermBundle emptyTreeTermBundle) @?= encodeBundle (buildBundle [])
 
   , testCase "Streaming pack: rejects truncated, unknown and trailing tree bytes" $ do
       let parse bytes = feedTreeTerm bytes (startTreeTerm emptyTreeTermBundle) >>= endTreeTerm "main"
           failure bytes expected = case parse bytes of
             Left problem -> problem @?= expected
             Right _ -> assertFailure "accepted malformed canonical tree"
       forM_ [[], [1], [2,0], [2,1,0]] $ \bytes ->
         failure (BS.pack bytes) "unexpected end of tree term"
       failure (BS.pack [3]) "unknown tree term tag: 3"
       failure (BS.pack [0,0]) "trailing bytes after tree term"
       failure (BS.pack [1,0,3]) "trailing bytes after tree term"
 
   , testCase "Streaming pack: deep input does not need recursive tree construction" $ do
       let depth = 16384
       cursor <- either assertFailure pure $
         feedTreeTerm (BS.replicate depth 1 <> BS.singleton 0) (startTreeTerm emptyTreeTermBundle)
       builder <- either assertFailure pure (endTreeTerm "main" cursor)
       let bundle = finishTreeTermBundle builder
       Seq.length (bundleNodes bundle) @?= depth + 1
       bundleRoots bundle @?= [fromIntegral depth]
       verifyBundle bundle @?= Right ()
 
   , testCase "Streaming pack: CAS digest verification and byte-equivalent shared exports" $
       withSystemTempDirectory "tricu-streaming-pack" $ \dir -> do
         let store = StorePath dir
             terms = [("a", Fork (Stem Leaf) (Stem Leaf)), ("b", Stem Leaf),
                      ("alias", Fork (Stem Leaf) (Stem Leaf))]
         roots <- forM terms $ \(name, term) -> (,) name <$> putTreeTerm store term
         bundle <- packBundleFromStore store roots
         encodeBundle bundle @?= encodeBundle (buildBundle terms)
         -- Cross the actual file reader's 64 KiB boundary with unfinished frames.
         let depth = 65537
         deep <- putObject store treeTermDomain (BS.replicate depth 1 <> BS.singleton 0)
         deepBundle <- packBundleFromStore store [("deep", deep), ("alias", deep)]
         Seq.length (bundleNodes deepBundle) @?= depth + 1
         bundleRoots deepBundle @?= replicate 2 (fromIntegral depth)
         verifyBundle deepBundle @?= Right ()
         let root = snd (head roots)
         BS.writeFile (objectPath store root) (encodeTreeTerm Leaf)
         outcome <- try (packBundleFromStore store roots) :: IO (Either SomeException Bundle)
         case outcome of
           Left problem -> show problem `containsAll` ["Executable tree digest mismatch", unpack root]
           Right _ -> assertFailure "packed corrupted CAS bytes"
         forM_ [BS.empty, BS.pack [2,0], BS.pack [3], BS.pack [0,0]] $ \bytes -> do
           malformed <- putObject store treeTermDomain bytes
           rejected <- try (packBundleFromStore store [("bad", malformed)]) :: IO (Either SomeException Bundle)
           case rejected of
             Left _ -> pure ()
             Right _ -> assertFailure "packed malformed but correctly hashed CAS bytes"
 
   , testCase "Arboricx bundle: pack CAS tree terms into transport bundle" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let store = StorePath dir
             term = Fork Leaf (Stem Leaf)
         root <- putTreeTerm store term
         bundle <- packBundleFromStore store [("main", root)]
         bundleRoots bundle @?= [2]
         let terms = reconstructBundleTermsForTest (bundleNodes bundle)
         case manifestExports (bundleManifest bundle) of
           [exported] -> do
             exportName exported @?= "main"
             terms V.! fromIntegral (exportRoot exported) @?= term
           other -> assertFailure $ "unexpected exports: " ++ show other
   ]
 
 reconstructBundleTermsForTest :: Seq.Seq BundleNode -> V.Vector T
 reconstructBundleTermsForTest nodes = V.fromList (go <$> Foldable.toList nodes)
   where
     built = V.fromList (go <$> Foldable.toList nodes)
     go BNLeaf = Leaf
     go (BNStem child) = Stem (built V.! fromIntegral child)
     go (BNFork left right) = Fork (built V.! fromIntegral left) (built V.! fromIntegral right)
 
 countStoredObjects :: StorePath -> IO Int
 countStoredObjects store@(StorePath root) = do
   ensureStore store
   shards <- listDirectory (root </> "objects")
   fmap sum $ forM shards $ \shard -> do
     files <- listDirectory (root </> "objects" </> shard)
     return (length files)
 
 -- --------------------------------------------------------------------------
 -- Wire module tests
 -- --------------------------------------------------------------------------
 
 -- | Helper: create a temporary file-backed DB, store a term, return the
 
 wireTests :: TestTree
 wireTests = testGroup "Wire Tests"
   [ testCase "Indexed bundle: header and manifest declare indexed format" $ do
       let term = Leaf
           bundle = buildBundle [("main", term)]
           wireData = encodeBundle bundle
       BS.take 8 wireData @?= BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58]
       case decodeBundle wireData of
         Left err -> assertFailure $ "decodeBundle failed: " ++ err
         Right decoded -> do
           let manifest = bundleManifest decoded
               tree = manifestTree manifest
               hashSpec = treeNodeHash tree
           manifestSchema manifest @?= "arboricx.bundle.manifest.v1"
           manifestBundleType manifest @?= "tree-calculus-executable-object"
           manifestClosure manifest @?= ClosureComplete
           treeCalculus tree @?= "tree-calculus.v1"
           treeNodePayload tree @?= "arboricx.indexed.payload.v1"
           nodeHashAlgorithm hashSpec @?= "indexed"
           nodeHashDomain hashSpec @?= "arboricx.indexed.node.v1"
           bundleRoots decoded @?= bundleRoots bundle
           case manifestExports manifest of
             [exported] -> do
               exportName exported @?= "main"
               exportRoot exported @?= head (bundleRoots bundle)
               exportKind exported @?= "term"
               exportAbi exported @?= "arboricx.abi.tree.v1"
             exports -> assertFailure $ "Expected one export, got: " ++ show exports
 
   , testCase "Indexed bundle: deterministic encoding" $ do
       let term = Stem (Stem Leaf)
           bundle1 = buildBundle [("main", term)]
           bundle2 = buildBundle [("main", term)]
       encodeBundle bundle1 @?= encodeBundle bundle2
 
   , testCase "Indexed bundle: renaming export changes bytes" $ do
       let term = Leaf
           mainBundle = buildBundle [("main", term)]
           renamedBundle = buildBundle [("validate", term)]
       encodeBundle mainBundle /= encodeBundle renamedBundle @? "different export names should produce different bytes"
       -- But nodes are identical
       bundleNodes mainBundle @?= bundleNodes renamedBundle
 
   , testCase "Indexed bundle: verify rejects out-of-bounds root" $ do
       let term = Leaf
           bundle = buildBundle [("main", term)]
           badBundle = bundle { bundleRoots = [99] }
       case verifyBundle badBundle of
         Left err -> assertBool ("Expected bounds error, got: " ++ err) ("out of bounds" `isInfixOf` err)
         Right () -> assertFailure "Expected out-of-bounds root to be rejected"
 
   , testCase "Indexed bundle: verify rejects out-of-bounds child index" $ do
       let bundle = Bundle
             { bundleVersion = 1000
             , bundleRoots = [1]
             , bundleNodes = Seq.fromList [BNLeaf, BNStem 99]
             , bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
                 { manifestRoots = [BundleRoot 1 "default"]
                 , manifestExports = [BundleExport "main" 1 "term" "arboricx.abi.tree.v1"]
                 }
             , bundleManifestBytes = BS.empty
             }
       case verifyBundle bundle of
         Left err -> assertBool ("Expected bounds error, got: " ++ err) ("references child 99" `isInfixOf` err)
         Right () -> assertFailure "Expected out-of-bounds child to be rejected"
 
   , testCase "Indexed bundle: verify rejects acyclic (forward reference)" $ do
       let bundle = Bundle
             { bundleVersion = 1000
             , bundleRoots = [1]
             , bundleNodes = Seq.fromList [BNStem 1, BNLeaf]  -- index 0 refers to 1 (forward)
             , bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
                 { manifestRoots = [BundleRoot 1 "default"]
                 , manifestExports = [BundleExport "main" 1 "term" "arboricx.abi.tree.v1"]
                 }
             , bundleManifestBytes = BS.empty
             }
       case verifyBundle bundle of
         Left err -> assertBool ("Expected acyclicity error, got: " ++ err) ("references child 1" `isInfixOf` err)
         Right () -> assertFailure "Expected forward reference to be rejected"
 
   , testCase "Indexed bundle: verify rejects duplicate nodes" $ do
       let bundle = Bundle
             { bundleVersion = 1000
             , bundleRoots = [0]
             , bundleNodes = Seq.fromList [BNLeaf, BNLeaf]
             , bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
                 { manifestRoots = [BundleRoot 0 "default"]
                 , manifestExports = [BundleExport "main" 0 "term" "arboricx.abi.tree.v1"]
                 }
             , bundleManifestBytes = BS.empty
             }
       case verifyBundle bundle of
         Left err -> assertBool ("Expected duplicate error, got: " ++ err) ("duplicate" `isInfixOf` err)
         Right () -> assertFailure "Expected duplicate nodes to be rejected"
 
   , testCase "Indexed bundle: unpack into filesystem CAS" $
       withSystemTempDirectory "tricu-store" $ \dir -> do
         let term = Leaf
             bundle = buildBundle [("validateEmail", term)]
             wireData = encodeBundle bundle
             store = StorePath dir
         roots <- unpackBundleToStore store wireData
         case roots of
           [("validateEmail", root)] -> getTreeTerm store root >>= (@?= Just term)
           other -> assertFailure $ "unexpected roots: " ++ show other
 
   , testCase "Indexed bundle: round-trip decode and verify" $ do
       let term = Stem (Stem Leaf)
           bundle = buildBundle [("main", term)]
           wireData = encodeBundle bundle
       case decodeBundle wireData of
         Left err -> assertFailure $ "decodeBundle failed: " ++ err
         Right decoded -> case verifyBundle decoded of
           Left err -> assertFailure $ "verifyBundle failed: " ++ err
           Right () -> do
             bundleRoots decoded @?= bundleRoots bundle
             Seq.length (bundleNodes decoded) @?= Seq.length (bundleNodes bundle)
 
   , testCase "Indexed bundle: unsupported manifest semantics rejected" $ do
       let term = Leaf
           bundle = buildBundle [("main", term)]
           manifest = bundleManifest bundle
           partialBundle = bundle
             { bundleManifest = manifest { manifestClosure = ClosurePartial }
             , bundleManifestBytes = BS.empty
             }
           capabilityBundle = bundle
             { bundleManifest = manifest
                 { manifestRuntime = (manifestRuntime manifest)
                     { runtimeCapabilities = ["host.io"] }
                 }
             , bundleManifestBytes = BS.empty
             }
           wrongHashBundle = bundle
             { bundleManifest = manifest
                 { manifestTree = (manifestTree manifest)
                     { treeNodeHash = (treeNodeHash $ manifestTree manifest)
                         { nodeHashAlgorithm = "blake3" }
                     }
                 }
             , bundleManifestBytes = BS.empty
             }
       case verifyBundle partialBundle of
         Left err -> assertBool ("Expected closure error, got: " ++ err) ("closure = complete" `isInfixOf` err)
         Right () -> assertFailure "Expected partial closure to be rejected"
       case verifyBundle capabilityBundle of
         Left err -> assertBool ("Expected capability error, got: " ++ err) ("capabilities" `isInfixOf` err)
         Right () -> assertFailure "Expected runtime capabilities to be rejected"
       case verifyBundle wrongHashBundle of
         Left err -> assertBool ("Expected hash algorithm error, got: " ++ err) ("node hash algorithm" `isInfixOf` err)
         Right () -> assertFailure "Expected unsupported node hash algorithm to be rejected"
     ]
 
 -- --------------------------------------------------------------------------
 -- Tricu reader tests
 -- Smoke-test the tricu-native Arboricx reader against indexed bundles.
 -- --------------------------------------------------------------------------
 
 tricuReaderTests :: TestTree
 tricuReaderTests = testGroup "Tricu Reader Tests"
   [ testCase "Tricu reader parses indexed bundle (id fixture)" $ check "id"
   , testCase "Tricu reader parses indexed bundle (append fixture)" $ check "append"
   , testCase "Tricu reader parses indexed bundle (bool fixtures)" $ mapM_ check ["true", "false"]
   ]
   where
     check name = do
       bytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
       let reply = foldl apply (fixtureExports "arboricx" Map.! "runArboricx") [ofBytes bytes, Leaf]
       apply (fixtureExports "base" Map.! "fst") reply @?= trueT
 
 -- --------------------------------------------------------------------------
 -- Byte-list utility tests
 -- Expected values built with canonical Haskell-side T constructors.
 -- --------------------------------------------------------------------------
 
 -- | Helpers for byte-list test expectations.
 
 trueT  :: T
 trueT  = Stem Leaf
 
 falseT :: T
 falseT = Leaf
 
 pairT :: T -> T -> T
 pairT = Fork
 
 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)))
 
 -- --------------------------------------------------------------------------
 -- Reusable, located character-scanning primitives
 -- --------------------------------------------------------------------------
 
 locatedLexerTests :: TestTree
 locatedLexerTests = testGroup "Located character-scanning library"
   [ testCase "checked native scanner handles abstract input" $ do
         env <- evaluateCompilerFile "./test/lexerScanImport.tri"
         case Map.lookup "scanner" env of
           Nothing -> assertFailure "missing portable scanner"
           Just scanner -> do
             apply scanner (ofString "aa!") @?=
               portableReply True
                 (pairT (ofList [ofNumber 97, ofNumber 97])
                   (gatePosition 1 3 2))
                 (ofString "!") True False
             apply scanner Leaf @?=
               portableReply True (pairT Leaf (gatePosition 1 1 0)) Leaf False False
             apply scanner (ofString "a\nx") @?=
               portableReply True
                 (pairT (ofList [ofNumber 97]) (gatePosition 1 2 1))
                 (ofString "\nx") True False
         case Map.lookup "dispatch" env of
           Nothing -> assertFailure "missing ordered dispatch"
           Just dispatch -> do
             apply dispatch (ofNumber 97) @?= ofNumber 1
             apply dispatch (ofNumber 98) @?= ofNumber 3
   ]
 
 -- --------------------------------------------------------------------------
 -- Single-expression feasibility-gate source lexer
 -- --------------------------------------------------------------------------
 
 gateLexerEnv :: Env
 gateLexerEnv = fixtureExports "source.lexer"
 {-# NOINLINE gateLexerEnv #-}
 
 gatePosition :: Integer -> Integer -> Integer -> T
 gatePosition line column offset =
   pairT (ofNumber line) (pairT (ofNumber column) (ofNumber offset))
 
 gateToken :: Integer -> T -> T -> T -> T
 gateToken kind payload start end =
   pairT (ofNumber kind) (pairT payload (pairT start end))
 
 gateLexerTests :: TestTree
 gateLexerTests = testGroup "Feasibility-gate source lexer"
   [ testCase "module export normalizes under abstract source input" $
       withSystemTempDirectory "gate-lexer-import" $ \dir -> do
         env <- evaluateCompilerFile "./test/sourceLexerImport.tri"
         Map.lookup "main" env @?= Just Leaf
   , testCase "keyword, identifiers, and punctuation carry spans" $ do
       check "t (foo : turtle)"
         (portableReply True
           (ofList
             [ gateToken 1 (ofString "t") (gatePosition 1 1 0) (gatePosition 1 2 1)
             , gateToken 3 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
             , gateToken 2 (ofString "foo") (gatePosition 1 4 3) (gatePosition 1 7 6)
             , gateToken 5 Leaf (gatePosition 1 8 7) (gatePosition 1 9 8)
             , gateToken 2 (ofString "turtle") (gatePosition 1 10 9) (gatePosition 1 16 15)
             , gateToken 4 Leaf (gatePosition 1 16 15) (gatePosition 1 17 16)
             ]) Leaf True False)
   , testCase "decimal digits accumulate and retain leading-zero span" $ do
       check "009 x" (portableReply True
         (ofList
           [ gateToken 7 (ofNumber 9) (gatePosition 1 1 0) (gatePosition 1 4 3)
           , gateToken 2 (ofString "x") (gatePosition 1 5 4) (gatePosition 1 6 5)
           ]) Leaf True False)
   , testCase "quoted string decodes escapes and retains raw source span" $ do
       let input = "\"a\\n\\\"b\""
       check input (portableReply True
         (ofList [gateToken 8 (ofString "a\n\"b")
           (gatePosition 1 1 0) (gatePosition 1 9 8)]) Leaf True False)
   , testCase "source string escape repertoire is preserved" $ do
       let input = "\"\\t\\r\\f\\b\\\\\\'\""
           decoded = "\t\r\f\b\\'"
           width = fromIntegral (length input)
       check input (portableReply True
         (ofList [gateToken 8 (ofString decoded)
           (gatePosition 1 1 0) (gatePosition 1 (width + 1) width)])
         Leaf True False)
   , testCase "bracket punctuation retains both half-open spans" $ do
       check "[t]" (portableReply True
         (ofList
           [ gateToken 9 Leaf (gatePosition 1 1 0) (gatePosition 1 2 1)
           , gateToken 1 (ofString "t") (gatePosition 1 2 1) (gatePosition 1 3 2)
           , gateToken 10 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
           ]) Leaf True False)
   , testCase "equation commas are located tokens, not expression-list syntax" $
       check "[t, t]" (portableReply True (ofList
         [ gateToken 9 Leaf (gatePosition 1 1 0) (gatePosition 1 2 1)
         , gateToken 1 (ofString "t") (gatePosition 1 2 1) (gatePosition 1 3 2)
         , gateToken 20 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
         , gateToken 1 (ofString "t") (gatePosition 1 5 4) (gatePosition 1 6 5)
         , gateToken 10 Leaf (gatePosition 1 6 5) (gatePosition 1 7 6)
         ]) Leaf True False)
   , testCase "comment delimiters inside strings remain literal" $
       check "\"--|-\"" (portableReply True
         (ofList [gateToken 8 (ofString "--|-")
           (gatePosition 1 1 0) (gatePosition 1 7 6)]) Leaf True False)
   , testCase "invalid and unfinished string escapes return diagnostics" $ do
       check "\"\\q\"" (portableReply False
         (portableDiagnostic (ofNumber 6) (ofNumber 34) (ofNumber 113)
           (gatePosition 1 3 2) Leaf) (ofString "\\q\"") True False)
       check "\"hi" (portableReply False
         (portableDiagnostic (ofNumber 5) (ofNumber 34) Leaf
           (gatePosition 1 1 0) Leaf) Leaf True False)
   , testCase "line comment preserves newline token and locations" $ do
       check "t --hello\nx" (portableReply True
         (ofList
           [ gateToken 1 (ofString "t") (gatePosition 1 1 0) (gatePosition 1 2 1)
           , gateToken 6 Leaf (gatePosition 1 10 9) (gatePosition 2 1 10)
           , gateToken 2 (ofString "x") (gatePosition 2 1 10) (gatePosition 2 2 11)
           ]) Leaf True False)
   , testCase "block comment consumes internal newlines but preserves end span" $ do
       let input = "t |-ab\nc-| t"
       check input (portableReply True
         (ofList
           [ gateToken 1 (ofString "t") (gatePosition 1 1 0) (gatePosition 1 2 1)
           , gateToken 1 (ofString "t") (gatePosition 2 5 11) (gatePosition 2 6 12)
           ]) Leaf True False)
   , testCase "empty block comment consumes both delimiters" $
       check "|- -|t" (portableReply True
         (ofList [gateToken 1 (ofString "t")
           (gatePosition 1 6 5) (gatePosition 1 7 6)]) Leaf True False)
   , testCase "unterminated block comment returns a structured diagnostic" $
       check "t |-oops" (portableReply False
         (portableDiagnostic (ofNumber 5) (ofString "-|") Leaf
           (gatePosition 1 3 2) Leaf) Leaf True False)
   , testCase "comment at EOF leaves no phantom token" $
       check "t --bye" (portableReply True
         (ofList [gateToken 1 (ofString "t")
           (gatePosition 1 1 0) (gatePosition 1 2 1)]) Leaf True False)
   , testCase "lone dash remains a located lexical error" $
       check "-" (portableReply False
         (portableDiagnostic (ofNumber 4) Leaf (ofNumber 45)
           (gatePosition 1 1 0) Leaf) (ofString "-") False False)
   , testCase "newline advances source position" $ do
       check "t\nfoo"
         (portableReply True
           (ofList
             [ gateToken 1 (ofString "t") (gatePosition 1 1 0) (gatePosition 1 2 1)
             , gateToken 6 Leaf (gatePosition 1 2 1) (gatePosition 2 1 2)
             , gateToken 2 (ofString "foo") (gatePosition 2 1 2) (gatePosition 2 4 5)
             ]) Leaf True False)
   , testCase "invalid character returns structured diagnostic at actual input" $
       check "t #"
         (portableReply False
           (portableDiagnostic (ofNumber 4) Leaf (ofNumber 35)
             (gatePosition 1 3 2) Leaf) (ofString "#") True False)
   , testCase "explicit scalar BOM is rejected, matching browser character input" $
       apply (gateLexerEnv Map.! "lexGateSource") (ofString "\xfeff\&t") @?=
         portableReply False
           (portableDiagnostic (ofNumber 4) Leaf (ofNumber 65279)
             (gatePosition 1 1 0) Leaf) (ofString "\xfeff\&t") False False
   , testCase "empty input yields empty tokens and no consumption" $
       check ""
         (portableReply True Leaf Leaf False False)
   , testCase "tab is rejected at its source position" $
       check "t\tfoo"
         (portableReply False
           (portableDiagnostic (ofNumber 4) Leaf (ofNumber 9)
             (gatePosition 1 2 1) Leaf) (ofString "\tfoo") True False)
   , testCase "pipe operators retain token kinds and two-character spans" $ do
       check "<| |>" (portableReply True
         (ofList
           [ gateToken 15 Leaf (gatePosition 1 1 0) (gatePosition 1 3 2)
           , gateToken 16 Leaf (gatePosition 1 4 3) (gatePosition 1 6 5)
           ]) Leaf True False)
   , testCase "do and bind arrow have independent located token kinds" $ do
       check "do <-" (portableReply True
         (ofList
           [ gateToken 17 (ofString "do")
               (gatePosition 1 1 0) (gatePosition 1 3 2)
           , gateToken 18 Leaf (gatePosition 1 4 3) (gatePosition 1 6 5)
           ]) Leaf True False)
   , testCase "ASCII letter/digit range boundaries remain recognized" $ do
       check "AZaz09" (portableReply True
         (ofList [gateToken 2 (ofString "AZaz09")
           (gatePosition 1 1 0) (gatePosition 1 7 6)]) Leaf True False)
   , testCase "longer ASCII identifier scans without discarding suffix" $
       let name = replicate 32 'a'
       in check (name ++ " t")
         (portableReply True
           (ofList
             [ gateToken 2 (ofString name) (gatePosition 1 1 0) (gatePosition 1 33 32)
             , gateToken 1 (ofString "t") (gatePosition 1 34 33) (gatePosition 1 35 34)
             ]) Leaf True False)
   ]
   where
     check input expected =
       apply (gateLexerEnv Map.! "lexGateSource") (ofString input) @?= expected
 
 -- --------------------------------------------------------------------------
 -- Single-expression feasibility-gate surface parser
 -- --------------------------------------------------------------------------
 
 -- Library paths select authenticated published interfaces. Unmapped test units
 -- use the portable compiler; neither path interprets historical frontend syntax.
 evaluateCompilerFile :: FilePath -> IO Env
 evaluateCompilerFile path =
   case [legacy | (legacy, _, source) <- fst compiledLibraries,
                source == maybe path id (stripPrefix "./" path)] of
     [legacy] -> pure (fixtureExports legacy)
     [] -> compileFixtureFile path
     _ -> error "ambiguous compiler fixture module"
 
 -- Test wrappers are compiled by the retained portable stable unit API; library
 -- payloads come from authenticated fixtures. Packing remains a host mechanism.
 packCompilerFile :: FilePath -> FilePath -> [Text] -> IO ()
 packCompilerFile input output names = do
   env <- evaluateCompilerFile input
   let selected = [(name, env Map.! unpack name) | name <- names]
   BS.writeFile output (encodeBundle (buildBundle selected))
 
 -- Immutable pre-optimization worker from the accepted d7b3c37 generation.
 -- No source compilation or fresh module builds enter the fast gate. Keeping
 -- this separate from the current compiler fixture makes fallback comparisons
 -- independent of the implementation under test.
 hashHexReference :: Env
 hashHexReference = unsafePerformIO $ do
   bytes <- BS.readFile "test/fixtures/hash-hex-reference.arboricx"
   let digest = unpack (hashObject (Domain "tricu.hash-hex-reference.v1") bytes)
   unless (digest == "b5419c577b5a3e8a4458261bfa6934a43cce40eb86e24326aa9a33d6d0552e81") $
     error "hash-hex reference fixture changed; do not refresh it from the candidate"
   bundle <- either error pure (decodeBundle bytes)
   either error pure (verifyBundle bundle)
   let terms = reconstructBundleTerms (bundleNodes bundle)
   pure $ Map.fromList
     [(unpack (exportName entry), terms V.! fromIntegral (exportRoot entry)) |
       entry <- manifestExports (bundleManifest bundle)]
 {-# NOINLINE hashHexReference #-}
 
 digestHexTests :: TestTree
 digestHexTests = testGroup "guarded digest hex"
   [ testCase "all canonical byte values match integer oracle and old kernel" $
       forM_ [0..255] $ \value -> do
         let input = ofList [ofNumber value]
             expected = if (value >= 48 && value <= 57) ||
                           (value >= 97 && value <= 102) then Stem Leaf else Leaf
         apply old input @?= expected
         apply current input @?= expected
   , testCase "wider, noncanonical and malformed trees retain old behavior" $
       forM_ unusual $ \input -> apply current input @?= apply old input
   , testCase "complete digests and late invalid bytes retain old behavior" $
       forM_ strings $ \input -> apply current (ofString input) @?= apply old (ofString input)
   , testCase "public digest length and alphabet checks remain exact" $ do
       let valid = snd compilerFixture Map.! "source_object.sourceObjectHashValid"
       forM_ [0,1,63,64,65] $ \size ->
         apply valid (ofString (replicate size 'a')) @?= if size == 64 then Stem Leaf else Leaf
       forM_ ['A','G','/', '\NUL', '\255'] $ \byte ->
         apply valid (ofString (replicate 63 'a' ++ [byte])) @?= Leaf
   ]
   where
     fix = hashHexReference Map.! "fix"
     old = apply fix (hashHexReference Map.! "worker")
     current = snd compilerFixture Map.! "source_object.sourceObjectHashHex"
     pad Leaf count = foldr (\_ rest -> Fork Leaf rest) Leaf [1..count]
     pad (Fork bit rest) count = Fork bit (pad rest count)
     pad other _ = other
     unusual =
       map (ofList . (:[]) . ofNumber) [256,257,511,512,65535] ++
       [ofList [pad (ofNumber value) count] |
         value <- [0,1,47,48,49,57,58,96,97,102,103,255], count <- [1,2]] ++
       map (ofList . (:[]))
         [Stem Leaf, Stem (Stem Leaf), Fork (Fork Leaf Leaf) Leaf,
          Fork (Stem (Stem Leaf)) Leaf, Fork Leaf (Stem Leaf)] ++
       [Leaf, Stem Leaf, Stem (Stem Leaf),
        Fork (ofNumber 97) (Stem Leaf), Fork (ofNumber 103) (Stem Leaf)]
     strings = ["0123456789abcdef", replicate 64 'a', replicate 64 '0',
       replicate 64 'f', concat (replicate 4 "0123456789abcdef"),
       'A' : replicate 63 'a', replicate 63 'a' ++ "G",
       replicate 31 'a' ++ "\NUL" ++ replicate 32 'a',
       replicate 31 'a' ++ "\255" ++ replicate 32 'a']
 
 compilerFixtureTests :: TestTree
 compilerFixtureTests = testGroup "self-built reference compiler fixture"
   [ testCase "matches all recorded reference source inputs" $ do
       length (fst compilerFixture) @?= 28
       assertBool "fixture-only patterns still in compiler closure"
         (all (\(_, alias, _) -> alias /= "patterns") (fst compilerFixture))
       assertBool "patterns missing from support cohort"
         (any (\(_, alias, _) -> alias == "patterns") (fst supportFixture))
       assertBool "missing name index exports"
         (all (`Map.member` snd compilerFixture)
           ["source_index.sourceIndexBuild", "source_index.sourceIndexGet", "source_index.sourceIndexPut"])
       assertBool "missing unit compiler export"
         (Map.member "source_unit.compileSource" (snd compilerFixture))
   , testCase "direct fixture interfaces exclude imports and reject unknown modules" $ do
       let http = fixtureExports "http"
       assertBool "missing owned HTTP export" (Map.member "parseHeaders" http)
       forM_ ["append", "kernel", "source_unit.compileSource"] $ \name ->
         assertBool ("leaked imported/injected name: " ++ name) (Map.notMember name http)
       rejected <- try (evaluate (Map.size (fixtureExports "missing.fixture"))) :: IO (Either SomeException Int)
       case rejected of
         Left _ -> pure ()
         Right _ -> assertFailure "unknown fixture module silently accepted"
   , testCase "portable wrapper compilation keeps unused definitions lazy" $ do
       env <- compileFixtureDefinitions Map.empty
         "unused = (x : x x) (x : x x)\nmain = t"
       Map.keys env @?= ["main", "unused"]
       Map.lookup "main" env @?= Just Leaf
   , testCase "portable wrapper compilation rejects invalid source without fallback" $ do
       forM_ ["main = missing", "main = t\nmain = t", "t", "main = #"] $ \source -> do
         rejected <- try (compileFixtureDefinitions Map.empty source) :: IO (Either SomeException Env)
         case rejected of
           Left err -> assertBool "expected portable diagnostic"
             ("portable test compilation failed" `isInfixOf` show err)
           Right _ -> assertFailure ("accepted invalid wrapper: " ++ source)
   , testCase "portable wrapper compilation uses only explicit externals" $ do
       env <- compileFixtureDefinitions (Map.singleton "outside" (Stem Leaf)) "main = outside t"
       Map.keys env @?= ["main"]
       Map.lookup "main" env @?= Just (Fork Leaf Leaf)
       rejected <- try (compileFixtureDefinitions (Map.singleton "outside" Leaf) "outside = t")
         :: IO (Either SomeException Env)
       case rejected of
         Left _ -> pure ()
         Right _ -> assertFailure "wrapper shadows an imported name"
   , testCase "every reference compiler module authors native headers" $ do
       forM_ (fst compilerFixture) $ \(_, _, path) -> do
         source <- readTestSource path
         assertBool ("missing native export: " ++ path)
           (any ("!export " `isPrefixOf`) (lines source))
         assertBool ("legacy import: " ++ path)
           (not (any ("!import \"" `isPrefixOf`) (lines source)))
   , testCase "reference source rejects corrupt bytes and unsafe digests" $
       withSystemTempDirectory "tricu-reference-source" $ \dir -> do
         let bytes = BS.pack [120,32,61,32,116,10]
             pin = unpack (hashObject (Domain (pack "arboricx.source.v1")) bytes)
             path = dir </> (pin ++ ".tri")
             rejected action = do
               result <- try action :: IO (Either SomeException BS.ByteString)
               case result of
                 Left _ -> pure ()
                 Right _ -> assertFailure "invalid reference source accepted"
         rejected (readPinnedSource dir pin)
         BS.writeFile path bytes
         readPinnedSource dir pin >>= (@?= bytes)
         BS.writeFile path (bytes <> BS.singleton 32)
         rejected (readPinnedSource dir pin)
         rejected (readPinnedSource dir "../source")
   , testCase "native prelude retains exactly its dependency re-exports" $ do
       let exports = snd compilerFixture
           owned alias = Map.fromList
             [(drop (length alias + 1) name, tree) | (name, tree) <- Map.toList exports,
               (alias ++ ".") `isPrefixOf` name]
       owned "prelude" @?= Map.unions (map owned ["base", "bytes", "conversions"])
   , testCase "native base effect interpreter and guard use the rebuilt kernels" $ do
       env <- pure (fixtureExports "base")
       let pureValue value = Fork (ofNumber 0) value
           success value rest = Fork (Stem Leaf) (Fork value rest)
           failure value = Fork Leaf (Fork value Leaf)
           value = ofNumber 42
           exception = Fork (ofNumber 99)
             (Fork (ofString "wanted") (Fork value Leaf))
           handler = apply (env Map.! "const")
             (apply (env Map.! "const") (pureValue (ofNumber 9)))
           handled = foldl apply (env Map.! "handleM") [ofString "wanted", handler, exception]
           predicate = apply (env Map.! "const") (Fork Leaf Leaf)
       apply (env Map.! "runM") (pureValue value) @?= success value Leaf
       apply (env Map.! "runM") exception @?= failure value
       apply (env Map.! "runM") (Stem Leaf) @?= Stem Leaf
       handled @?= pureValue (ofNumber 9)
       foldl apply (env Map.! "guardC") [ofString "bad", predicate, value, ofNumber 7]
         @?= success value (ofNumber 7)
   , testCase "mixed support reuse requires all provider trees, including unused ones" $ do
       let before = Map.fromList [("P.used",1),("P.unused",2)]
           source = "!import P as X\n!export f\nf x = X.used x\n"
       verifyReuseProviders before before source @?= Right ()
       forM_ ["P.used", "P.unused"] $ \name ->
         verifyReuseProviders before (Map.insert name 3 before) source @?=
           Left "provider kernels changed: P"
       forM_ [Map.insert "P.extra" 4 before, Map.delete "P.unused" before, Map.empty] $ \after ->
         verifyReuseProviders before after source @?= Left "full export set changed: P"
       verifyReuseProviders Map.empty before source @?= Left "missing original provider: P"
   , testCase "mixed support reuse no longer exempts shadowed imports" $ do
       let before = Map.fromList [("P.used",1),("P.unused",2)]
           shadowed = "!import P as X\n!export f\nf used = used\n"
       verifyReuseProviders before before shadowed @?= Right ()
       verifyReuseProviders before (Map.insert "P.used" 4 before) shadowed @?=
         Left "provider kernels changed: P"
   , testCase "mixed support reuse checks standalone reexports and all import forms" $ do
       let before = Map.fromList [("P.used",1),("P.unused",2),("PQ.other",3)]
       forM_ ["!import P", "!import P *", "!import P as X", "!export * from P",
              "  !import P *", "!import P *\n!export * from P"] $ \header -> do
         let source = header ++ "\n!export f\nf x = x\n"
         verifyReuseProviders before before source @?= Right ()
         verifyReuseProviders before (Map.insert "PQ.other" 4 before) source @?= Right ()
         verifyReuseProviders before (Map.insert "P.used" 4 before) source @?=
           Left "provider kernels changed: P"
       verifyReuseProviders before before "!export * from Missing\n" @?=
         Left "missing original provider: Missing"
   , testCase "mixed support reuse rejects changed namespace collision outcomes" $ do
       let before = Map.fromList [("P.used",1),("Q.used",1)]
           source = "!import P *\n!import Q *\n!export f\nf x = x\n"
       verifyReuseProviders before before source @?= Right ()
       verifyReuseProviders before (Map.insert "Q.used" 2 before) source @?=
         Left "provider kernels changed: Q"
   , testCase "mixed support reuse rejects unsupported dependency directives" $ do
       let before = Map.singleton "P.used" 1
       forM_ ["!import", "!import P as", "!import P * extra", "!import P as *",
              "!import \"P\" *", "!export * from", "!export * from P extra",
              "!source P", "!unknown P", "!import " ++ replicate 64 'a' ++ " *"] $ \header ->
         assertBool ("accepted unsupported reuse header: " ++ header)
           (case verifyReuseProviders before before (header ++ "\n") of Left _ -> True; _ -> False)
   , testCase "mixed support reuse compares canonical trees, not bundle-local node indices" $ do
       let original = buildBundle [("P.used", Stem Leaf), ("P.unused", Fork Leaf Leaf)]
           reordered = buildBundle [("Q.extra", ofNumber 42), ("P.unused", Fork Leaf Leaf),
                                    ("P.used", Stem Leaf)]
           changed = buildBundle [("P.used", Stem Leaf), ("P.unused", Fork Leaf (Stem Leaf))]
       forM_ [original, reordered, changed] $ \bundle -> verifyBundle bundle @?= Right ()
       case canonicalEnvs [original, reordered, changed] of
         [before, same, different] -> do
           verifyReuseProviders before same "!import P *\n" @?= Right ()
           verifyReuseProviders before different "!import P *\n" @?=
             Left "provider kernels changed: P"
         _ -> assertFailure "incorrect canonical environment count"
   , testCase "mixed support reuse permits provider-free unchanged programs" $
       verifyReuseProviders Map.empty Map.empty "-- no dependencies\n!export main\nmain = t\n" @?= Right ()
   , testCase "support publication allows new rebuilt sources, not relabeled retained sources" $ do
       let old = [["module","http","http","lib/http.tri","old-source"]]
           new = [["module","http","http","lib/http.tri","new-source"]]
       verifySupportSources old new (Set.singleton "http") @?= Right ()
       verifySupportSources old old Set.empty @?= Right ()
       verifySupportSources old new Set.empty @?=
         Left "retained source fingerprint changed: http"
       verifySupportSources old [["module","other","http","lib/http.tri","new-source"]]
         (Set.singleton "http") @?= Left "support cohort identity changed"
   , testCase "compiler-to-support relocation requires exact identity and a rebuild" $ do
       let old = [["module","http","http","lib/http.tri","old-source"]]
           added = ["module","patterns","patterns","lib/patterns.tri","new-source"]
           declared = ["relocated","compiler-library","patterns","patterns","lib/patterns.tri"]
           current = old ++ [added, declared]
       verifyRelocatedSupportSources old current (Set.singleton "patterns") @?= Right ()
       forM_ [old ++ [added], old ++ [added, declared, declared],
              old ++ [added, declared, ["module","extra","extra","lib/extra.tri","pin"]],
              old ++ [["module","patterns","patterns","lib/other.tri","pin"], declared]] $ \bad ->
         assertBool "unauthorized relocation accepted"
           (case verifyRelocatedSupportSources old bad (Set.singleton "patterns") of Left _ -> True; _ -> False)
       verifyRelocatedSupportSources old current Set.empty @?= Left "invalid patterns cohort relocation"
       verifySupportSources old current (Set.singleton "patterns") @?= Left "support cohort identity changed"
   , testCase "rebuilt export sets follow the new manifest, not the old interface" $ do
       let manifest kind names = unlines ("arboricx.module-manifest.v1" :
             ["export " ++ name ++ " " ++ kind ++ " hash arboricx.abi.tree.v1" | name <- names])
           names = Set.fromList ["parseHeaders", "httpAsciiBit"]
       forM_ ["arboricx.tree-term.v1", "arboricx.indexed-tree.v1"] $ \kind -> do
         verifySupportExports names (manifest kind (Set.toList names)) @?= Right ()
         forM_ [["parseHeaders"], ["parseHeaders", "httpAsciiBit", "byte7BitsOr"],
                ["parseHeaders", "httpAsciiBit", "httpAsciiBit"]] $ \bad ->
           verifySupportExports names (manifest kind bad) @?= Left "rebuilt manifest export set mismatch"
       verifySupportExports names (manifest "unknown-kind" (Set.toList names))
         @?= Left "rebuilt manifest export set mismatch"
       verifySupportExports names (unlines ["arboricx.module-manifest.v1",
         "export parseHeaders arboricx.tree-term.v1 hash arboricx.abi.tree.v1",
         "export httpAsciiBit arboricx.indexed-tree.v1 hash arboricx.abi.tree.v1"])
         @?= Left "rebuilt manifest export set mismatch"
   , testCase "rebuilt consumers reject stale support provider manifests" $ do
       let providers = Map.singleton "http" "new-manifest"
           rows pin = [["local","http",pin,"facade-source"],
                       ["pin","http",pin,"parseHeaders","tree"]]
       verifySupportDependencies providers (rows "new-manifest") @?= Right ()
       verifySupportDependencies providers (rows "old-manifest") @?=
         Left "stale support dependency: http"
       verifySupportDependencies providers
         [["local","http","new-manifest","source"], ["pin","http","old-manifest","f","tree"]]
         @?= Left "stale support dependency: http"
       verifySupportDependencies providers
         (replicate 2 ["local","http","new-manifest","source"]) @?= Left "duplicate local dependency"
   , testCase "native staging preserves namespaces and explicit exports" $ do
       env <- pure (fixtureExports "source.map")
       let row = pairT (ofString "example") (pairT (ofString "example")
                   (pairT (ofString "example.tri")
                     (pairT (ofList [ofString "native_math"]) (ofString "native"))))
           source = ofString "!import native_math as N\n!export main\nmain = N.add 2 3\n"
           prepare text = apply (apply (apply (env Map.! "sourceMapPrepareBody") row) text) Leaf
       prepare source @?= pairT (Stem Leaf) (pairT source Leaf)
       apply (apply (env Map.! "sourceMapOverlay") row) source @?= source
       forM_ ["", "!source other\n", "!source extra\n"] $ \bad ->
         apply (fixtureExports "base" Map.! "fst") (prepare (ofString bad)) @?= Leaf
   , testCase "shared native header derives ordered deduplicated edges and masks positions" $ do
       env <- pure (fixtureExports "source.module")
       let header = "-- lead\r\n!import math\n!export * from base\n!import math as M\n!source build_only\n!export main\n"
           body = "main = missing\n"
           masked = map (\c -> if c == '\n' || c == '\r' then c else ' ') header ++ body
           wordsT = ofList . map ofString
           staged = pairT (wordsT ["math", "base", "build_only"])
             (pairT (ofList [wordsT ["math"], wordsT ["math", "as", "M"]])
               (pairT (ofList [wordsT ["*", "from", "base"], wordsT ["main"]]) (ofString masked)))
       apply (env Map.! "sourceModuleHeaderStage") (ofString (header ++ body)) @?=
         pairT (Stem Leaf) (pairT staged Leaf)
   , testCase "native header rejects redundant edges and bare hashes at original locations" $ do
       env <- pure (fixtureExports "source.module")
       let bad sources = forM_ sources $ \source ->
             apply (fixtureExports "base" Map.! "fst") (apply (env Map.! "sourceModuleHeaderStage") (ofString source)) @?= Leaf
       bad ["!source dep\n!import dep\n", "!import dep\n!source dep\n",
            "!source dep\n!export * from dep\n", "!source dep\n!source dep\n",
            "!import " ++ replicate 64 'a' ++ "\n", "!use dep *\n", "!import \"dep\" !Local\n"]
       let outcome = apply (env Map.! "sourceModuleHeaderStage")
             (ofString "-- lead\n\n!use dep *\n")
           problem = apply (fixtureExports "base" Map.! "fst") (apply (fixtureExports "base" Map.! "snd") outcome)
       apply (fixtureExports "parser" Map.! "parserDiagnosticLocation") problem @?= gatePosition 3 1 9
   , testCase "native math exports are public only and general equality remains" $ do
       env <- pure (fixtureExports "math.native")
       assertBool "missing math decimal" (Map.member "decimal" env)
       let owned = [name | name <- Map.keys (snd compilerFixture), "native_math." `isPrefixOf` name]
       length owned @?= 27
       forM_ ["divMod", "quotient", "remainder", "power"] $ \name ->
         assertBool ("missing native arithmetic export: " ++ name) (Map.member name env)
       assertBool "private math helper exported" (not ("native_math.compareStep" `elem` owned))
       prelude <- pure (fixtureExports "prelude")
       assertBool "general equality removed" (Map.member "equal?" prelude)
   ]
 
 gateParserEnv :: Env
 gateParserEnv = fixtureExports "source.parser"
 {-# NOINLINE gateParserEnv #-}
 
 gateAst :: Integer -> T -> T -> T -> T
 gateAst kind payload start end =
   pairT (ofNumber kind) (pairT payload (pairT start end))
 
 gateParserTests :: TestTree
 gateParserTests = testGroup "Feasibility-gate source parser"
   [ testCase "self-built parser export executes through its wrapper" $ do
       env <- evaluateCompilerFile "./test/sourceGateParserImport.tri"
       Map.lookup "main" env @?= Just
         (portableReply True
           (gateAst 1 Leaf (gatePosition 1 1 0) (gatePosition 1 2 1))
           Leaf True False)
   , testCase "leaf retains its source span" $
       check "t" (portableReply True
         (gateAst 1 Leaf (gatePosition 1 1 0) (gatePosition 1 2 1))
         Leaf True False)
   , testCase "decimal integer is a located value" $
       check "007" (portableReply True
         (gateAst 6 (ofNumber 7) (gatePosition 1 1 0) (gatePosition 1 4 3))
         Leaf True False)
   , testCase "string is a located decoded value" $
       check "\"hi\"" (portableReply True
         (gateAst 7 (ofString "hi") (gatePosition 1 1 0) (gatePosition 1 5 4))
         Leaf True False)
   , testCase "empty list retains its brackets and canonical empty payload" $
       check "[]" (portableReply True
         (gateAst 8 Leaf (gatePosition 1 1 0) (gatePosition 1 3 2))
         Leaf True False)
   , testCase "list elements are separate atoms, not an application" $
       let leaf1 = gateAst 1 Leaf (gatePosition 1 2 1) (gatePosition 1 3 2)
           leaf2 = gateAst 1 Leaf (gatePosition 1 4 3) (gatePosition 1 5 4)
       in check "[t t]" (portableReply True
         (gateAst 8 (ofList [leaf1, leaf2])
           (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf True False)
   , testCase "nested lists and grouped applications retain distinct spans" $
       let innerLeaf = gateAst 1 Leaf
             (gatePosition 1 3 2) (gatePosition 1 4 3)
           innerList = gateAst 8 (ofList [innerLeaf])
             (gatePosition 1 2 1) (gatePosition 1 5 4)
           left = gateAst 1 Leaf (gatePosition 1 7 6) (gatePosition 1 8 7)
           right = gateAst 1 Leaf (gatePosition 1 9 8) (gatePosition 1 10 9)
           app = gateAst 3 (pairT left right)
             (gatePosition 1 7 6) (gatePosition 1 10 9)
           group = gateAst 5 app (gatePosition 1 6 5) (gatePosition 1 11 10)
       in check "[[t] (t t)]" (portableReply True
         (gateAst 8 (ofList [innerList, group])
           (gatePosition 1 1 0) (gatePosition 1 12 11)) Leaf True False)
   , testCase "unclosed list reports the expected closing bracket" $
       check "[t" (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 10) Leaf Leaf Leaf)
         Leaf True False)
   , testCase "unexpected separator retains its token and location" $
       check "[t : t]" (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 10) (ofNumber 5)
           (gatePosition 1 4 3) Leaf)
         (ofList
           [ gateToken 5 Leaf (gatePosition 1 4 3) (gatePosition 1 5 4)
           , gateToken 1 (ofString "t")
               (gatePosition 1 6 5) (gatePosition 1 7 6)
           , gateToken 10 Leaf (gatePosition 1 7 6) (gatePosition 1 8 7)
           ]) True False)
   , testCase "application is left associative" $
       let name = gateAst 2 (ofString "f") (gatePosition 1 1 0) (gatePosition 1 2 1)
           arg1 = gateAst 1 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
           arg2 = gateAst 1 Leaf (gatePosition 1 5 4) (gatePosition 1 6 5)
           first = gateAst 3 (pairT name arg1) (gatePosition 1 1 0) (gatePosition 1 4 3)
       in check "f t t" (portableReply True
         (gateAst 3 (pairT first arg2) (gatePosition 1 1 0) (gatePosition 1 6 5))
         Leaf True False)
   , testCase "let retains binding, value, body, and complete span" $
       let name = gateToken 2 (ofString "x")
             (gatePosition 1 5 4) (gatePosition 1 6 5)
           value = gateAst 1 Leaf (gatePosition 1 9 8) (gatePosition 1 10 9)
           body = gateAst 2 (ofString "x")
             (gatePosition 1 14 13) (gatePosition 1 15 14)
       in check "let x = t in x" (portableReply True
         (gateAst 9 (pairT name (pairT value body))
           (gatePosition 1 1 0) (gatePosition 1 15 14)) Leaf True False)
   , testCase "where retains the span of the whole expression" $
       let name = gateToken 2 (ofString "x")
             (gatePosition 1 9 8) (gatePosition 1 10 9)
           value = gateAst 1 Leaf (gatePosition 1 13 12) (gatePosition 1 14 13)
           body = gateAst 2 (ofString "x")
             (gatePosition 1 1 0) (gatePosition 1 2 1)
       in check "x where x = t" (portableReply True
         (gateAst 9 (pairT name (pairT value body))
           (gatePosition 1 1 0) (gatePosition 1 14 13)) Leaf True False)
   , testCase "a top-level newline does not silently join application operands" $
       check "t\n t" (portableReply False
         (portableDiagnostic (ofNumber 2) Leaf (ofNumber 6)
           (gatePosition 1 2 1) Leaf)
         (ofList
           [ gateToken 6 Leaf
               (gatePosition 1 2 1) (gatePosition 2 1 2)
           , gateToken 1 (ofString "t")
               (gatePosition 2 2 3) (gatePosition 2 3 4)
           ]) True False)
   , testCase "parentheses permit multiline application with original spans" $
       let left = gateAst 1 Leaf
             (gatePosition 1 2 1) (gatePosition 1 3 2)
           right = gateAst 1 Leaf
             (gatePosition 2 2 4) (gatePosition 2 3 5)
           application = gateAst 3 (pairT left right)
             (gatePosition 1 2 1) (gatePosition 2 3 5)
       in check "(t\n t)" (portableReply True
         (gateAst 5 application
           (gatePosition 1 1 0) (gatePosition 2 4 6)) Leaf True False)
   , testCase "pipe retains source order and direction before elaboration" $
       let value = gateAst 6 (ofNumber 2)
             (gatePosition 1 1 0) (gatePosition 1 2 1)
           name = gateAst 2 (ofString "f")
             (gatePosition 1 6 5) (gatePosition 1 7 6)
       in check "2 |> f" (portableReply True
         (gateAst 10 (pairT (ofNumber 16) (pairT value name))
           (gatePosition 1 1 0) (gatePosition 1 7 6)) Leaf True False)
   , testCase "do retains operator, located binders, and statements" $
       let op = gateAst 2 (ofString "b")
             (gatePosition 1 4 3) (gatePosition 1 5 4)
           name = gateToken 2 (ofString "x")
             (gatePosition 2 3 7) (gatePosition 2 4 8)
           action = gateAst 6 (ofNumber 2)
             (gatePosition 2 8 12) (gatePosition 2 9 13)
           body = gateAst 2 (ofString "x")
             (gatePosition 3 3 16) (gatePosition 3 4 17)
       in check "do b\n  x <- 2\n  x" (portableReply True
         (gateAst 11 (pairT op (ofList
           [pairT (Stem name) action, pairT Leaf body]))
           (gatePosition 1 1 0) (gatePosition 3 4 17)) Leaf True False)
   , testCase "single-argument lambda preserves binder and body" $
       let body = gateAst 2 (ofString "x") (gatePosition 1 5 4) (gatePosition 1 6 5)
       in check "x : x" (portableReply True
         (gateAst 4 (pairT (ofString "x") body)
           (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf True False)
   , testCase "multiple same-line lambda binders elaborate in source order" $
       let body = gateAst 2 (ofString "a")
             (gatePosition 1 7 6) (gatePosition 1 8 7)
           inner = gateAst 4 (pairT (ofString "b") body)
             (gatePosition 1 3 2) (gatePosition 1 8 7)
       in check "a b : a" (portableReply True
         (gateAst 4 (pairT (ofString "a") inner)
           (gatePosition 1 1 0) (gatePosition 1 8 7)) Leaf True False)
   , testCase "lambda body may start on a later line" $
       let body = gateAst 2 (ofString "x")
             (gatePosition 2 3 6) (gatePosition 2 4 7)
       in check "x :\n  x" (portableReply True
         (gateAst 4 (pairT (ofString "x") body)
           (gatePosition 1 1 0) (gatePosition 2 4 7)) Leaf True False)
   , testCase "nested lambdas associate to the right" $
       let body = gateAst 2 (ofString "x") (gatePosition 1 9 8) (gatePosition 1 10 9)
           inner = gateAst 4 (pairT (ofString "y") body)
             (gatePosition 1 5 4) (gatePosition 1 10 9)
       in check "x : y : x" (portableReply True
         (gateAst 4 (pairT (ofString "x") inner)
           (gatePosition 1 1 0) (gatePosition 1 10 9)) Leaf True False)
   , testCase "grouping preserves its outer span" $
       let leaf = gateAst 1 Leaf (gatePosition 1 2 1) (gatePosition 1 3 2)
           group = gateAst 5 leaf (gatePosition 1 1 0) (gatePosition 1 4 3)
           arg = gateAst 1 Leaf (gatePosition 1 5 4) (gatePosition 1 6 5)
       in check "(t) t" (portableReply True
         (gateAst 3 (pairT group arg)
           (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf True False)
   , testCase "empty input reports expected atom" $
       check "" (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 7) Leaf Leaf Leaf)
         Leaf False False)
   , testCase "opened group fails after consumption" $
       check "t (" (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 7) Leaf Leaf Leaf)
         Leaf True False)
   , testCase "missing lambda body is a consumed parse failure" $
       check "x : " (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 7) Leaf Leaf Leaf)
         Leaf True False)
   , testCase "unmatched close paren retains its span" $
       check "t)" (portableReply False
         (portableDiagnostic (ofNumber 2) Leaf (ofNumber 4)
           (gatePosition 1 2 1) Leaf)
         (ofList [gateToken 4 Leaf (gatePosition 1 2 1) (gatePosition 1 3 2)])
         True False)
   , testCase "lexical error passes through the source parser" $
       check "t #" (portableReply False
         (portableDiagnostic (ofNumber 4) Leaf (ofNumber 35)
           (gatePosition 1 3 2) Leaf)
         (ofString "#") True False)
   , testCase "newline does not turn into application whitespace" $
       check "t\nfoo" (portableReply False
         (portableDiagnostic (ofNumber 2) Leaf (ofNumber 6)
           (gatePosition 1 2 1) Leaf)
         (ofList
           [ gateToken 6 Leaf (gatePosition 1 2 1) (gatePosition 2 1 2)
           , gateToken 2 (ofString "foo") (gatePosition 2 1 2) (gatePosition 2 4 5)
           ]) True False)
   ]
   where
     check input expected =
       apply (gateParserEnv Map.! "parseGateSource") (ofString input) @?= expected
 
 -- --------------------------------------------------------------------------
 -- Program-level feasibility-gate parsing (definitions and final expression)
 -- --------------------------------------------------------------------------
 
 equationHelperEnv :: Env
 equationHelperEnv = fixtureExports "source.equations"
 {-# NOINLINE equationHelperEnv #-}
 
 equationHelperTests :: TestTree
 equationHelperTests = testGroup "Equation helper pattern adoption"
   [ testCase "expected token consumes one cell and preserves suffix" $
       expect 7 input @?= portableReply True token suffix True False
   , testCase "wrong token preserves full input and original location" $
       expect 2 input @?= portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 2) (ofNumber 7) start Leaf)
         input False False
   , testCase "empty token input has unchanged end diagnostic" $
       expect 2 Leaf @?= endReply 2 Leaf
   , testCase "non-list token input has unchanged end diagnostic" $
       expect 2 (Stem Leaf) @?= endReply 2 (Stem Leaf)
   , testCase "labelled error preserves token kind span and full remainder" $
       labelled input @?= portableReply False
         (portableDiagnostic (ofNumber 48) label (ofNumber 7) start Leaf)
         input False False
   , testCase "labelled empty error retains protocol flags" $
       labelled Leaf @?= labelledEnd Leaf
   , testCase "labelled non-list error retains original input" $
       labelled (Stem Leaf) @?= labelledEnd (Stem Leaf)
   , testCase "empty pattern prefix returns supplied terminator" $
       list Leaf @?= nil
   , testCase "non-list pattern prefix returns supplied terminator" $
       list (Stem Leaf) @?= nil
   , testCase "pattern prefix has independent nested payload and span golden" $
       list (ofList [left, right]) @?= joined left (joined right nil)
   , testCase "improper pattern suffix retains prior non-list termination" $
       list (Fork left (Stem Leaf)) @?= joined left nil
   , testCase "empty pattern list retains an opaque supplied tail" $
       apply (fixtureExports "base" Map.! "fst")
         (call "sourceEquationList" [Leaf, Fork (ofNumber 23)
           (error "unused suffix demanded")]) @?= ofNumber 23
   ]
   where
     call name args = foldl apply (equationHelperEnv Map.! name) args
     start = gatePosition 2 3 5
     end = gatePosition 2 4 6
     token = gateToken 7 (ofNumber 23) start end
     suffix = ofList [Leaf]
     input = Fork token suffix
     label = ofString "pattern"
     expect kind value = call "sourceEquationExpect" [ofNumber kind, value]
     labelled value = call "sourceEquationError" [label, value]
     endReply kind value = portableReply False
       (portableDiagnostic (ofNumber 2) (ofNumber kind) Leaf Leaf Leaf)
       value False False
     labelledEnd value = portableReply False
       (portableDiagnostic (ofNumber 48) label Leaf Leaf Leaf) value False False
     patternNode tag payload a b = gateAst 13 (pairT (ofNumber tag) payload) a b
     nil = patternNode 1 Leaf (gatePosition 2 7 9) (gatePosition 2 8 10)
     left = patternNode 4 (ofString "x") start end
     right = patternNode 4 (ofString "y") (gatePosition 2 5 7) (gatePosition 2 6 8)
     joined a b = patternNode 3 (pairT a b)
       (case a of Fork _ (Fork _ (Fork x _)) -> x; _ -> error "invalid golden")
       (gatePosition 2 8 10)
     list value = call "sourceEquationList" [value, nil]
 
 gateProgramEnv :: Env
 gateProgramEnv = fixtureExports "source.program"
 {-# NOINLINE gateProgramEnv #-}
 
 gateProgramTests :: TestTree
 gateProgramTests = testGroup "Feasibility-gate program parser"
   [ testCase "portable wrapper normalizes the definition parser" $ do
       env <- evaluateCompilerFile
         "./test/sourceGateProgramImport.tri"
       Map.lookup "main" env @?= Just programResult
   , testCase "definition arguments elaborate to located lambdas" $ do
       check "id x = x\nid t" programResult
   , testCase "an identifier-led expression without assignment stays an expression" $
       let name = gateAst 2 (ofString "f")
             (gatePosition 1 1 0) (gatePosition 1 2 1)
           leaf = gateAst 1 Leaf
             (gatePosition 1 3 2) (gatePosition 1 4 3)
           expression = gateAst 3 (pairT name leaf)
             (gatePosition 1 1 0) (gatePosition 1 4 3)
       in check "f t" (portableReply True
            (pairT Leaf (Stem expression)) Leaf True False)
   , testCase "unfinished definition fails after consuming the assignment" $
       check "id x =" (portableReply False
         (portableDiagnostic (ofNumber 2) (ofNumber 7) Leaf Leaf Leaf)
         Leaf True False)
   , testCase "an empty unit has no definitions or final expression" $
       check "" (portableReply True (pairT Leaf Leaf) Leaf False False)
   ]
   where
     programResult =
       let name = gateToken 2 (ofString "id")
             (gatePosition 1 1 0) (gatePosition 1 3 2)
           bodyName = gateAst 2 (ofString "x")
             (gatePosition 1 8 7) (gatePosition 1 9 8)
           body = gateAst 4 (pairT (ofString "x") bodyName)
             (gatePosition 1 4 3) (gatePosition 1 9 8)
           expressionName = gateAst 2 (ofString "id")
             (gatePosition 2 1 9) (gatePosition 2 3 11)
           leaf = gateAst 1 Leaf
             (gatePosition 2 4 12) (gatePosition 2 5 13)
           expression = gateAst 3 (pairT expressionName leaf)
             (gatePosition 2 1 9) (gatePosition 2 5 13)
       in portableReply True
            (pairT (ofList [pairT name body]) (Stem expression)) Leaf True False
     check input expected =
       apply (gateProgramEnv Map.! "parseGateProgram") (ofString input) @?= expected
 
 -- --------------------------------------------------------------------------
 -- Portable, stable dependency ordering and cycle witnesses
 -- --------------------------------------------------------------------------
 
 sourceGraphEnv :: Env
 sourceGraphEnv = fixtureExports "graph"
 {-# NOINLINE sourceGraphEnv #-}
 
 sourceGraphTests :: TestTree
 sourceGraphTests = testGroup "Source dependency graph"
   [ testCase "checked native graph sorts dependencies before dependents" $ do
         env <- evaluateCompilerFile "./test/sourceGraphImport.tri"
         Map.lookup "main" env @?= Just
           (parserOk (ofList (map ofString ["leaf", "inner", "outer"])) Leaf)
   , testCase "sort preserves source order among simultaneously ready nodes" $
       check [("b", []), ("a", [])]
         (parserOk (ofList [ofString "b", ofString "a"]) Leaf)
   , testCase "cycle witness is in the cycle, not just a dependent" $
       check [("outside", ["inside"]), ("inside", ["last"]), ("last", ["inside"])]
         (parserErr (ofString "inside") Leaf)
   ]
   where
     check entries expected =
       apply (sourceGraphEnv Map.! "graphSort")
         (ofList [Fork (ofString name) (ofList (map ofString dependencies))
                 | (name, dependencies) <- entries]) @?= expected
 
 -- --------------------------------------------------------------------------
 -- Program-level free names and dependency ordering
 -- --------------------------------------------------------------------------
 
 gateOrderingEnv :: Env
 gateOrderingEnv = fixtureExports "source.order"
 {-# NOINLINE gateOrderingEnv #-}
 
 gateOrderingTests :: TestTree
 gateOrderingTests = testGroup "Feasibility-gate definition ordering"
   [ testCase "portable wrapper orders forward references" $ do
       env <- evaluateCompilerFile
         "./test/sourceGateOrderImport.tri"
       Map.lookup "main" env @?= Just (parserOk
         (ofList [ofString "f", ofString "main"]) Leaf)
   , testCase "unused definitions still have their names checked" $
       check Leaf "main = t\nbroken = u" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
           (gatePosition 2 10 18) Leaf)
         (gateAst 2 (ofString "u")
           (gatePosition 2 10 18) (gatePosition 2 11 19)))
   , testCase "lexical binder shadows a definition and external name" $
       check (ofList [Fork (ofString "x") Leaf]) "x = t\nf x = x" (parserOk
         (ofList [ofString "x", ofString "f"]) Leaf)
   , testCase "top-level self reference returns a cycle witness" $
       check Leaf "f = f" (parserErr
         (portableDiagnostic (ofNumber 31) (ofString "acyclic")
           (ofString "f") (gatePosition 1 1 0)
           (ofList [ofString "f"])) Leaf)
   , testCase "duplicate definition reports the later name location" $
       let name = gateToken 2 (ofString "f")
             (gatePosition 2 1 6) (gatePosition 2 2 7)
           body = gateAst 1 Leaf
             (gatePosition 2 5 10) (gatePosition 2 6 11)
       in check Leaf "f = t\nf = t" (parserErr
            (portableDiagnostic (ofNumber 30) (ofString "f")
              (ofString "f") (gatePosition 2 1 6) Leaf)
            (pairT name body))
   , testCase "a final expression also checks unresolved names" $
       check Leaf "f = t\nu" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
           (gatePosition 2 1 6) Leaf)
         (gateAst 2 (ofString "u")
           (gatePosition 2 1 6) (gatePosition 2 2 7)))
   ]
   where
     check environment source expected =
       foldl apply (gateOrderingEnv Map.! "orderGateSource") [environment, ofString source]
         @?= expected
 
 -- --------------------------------------------------------------------------
 -- End-to-end program compilation through ordered definitions
 -- --------------------------------------------------------------------------
 
 gateUnitEnv :: Env
 gateUnitEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/unit.tri"
 {-# NOINLINE gateUnitEnv #-}
 
 gateUnitTests :: TestTree
 gateUnitTests = testGroup "Feasibility-gate program compiler"
   [ testCase "real source files compile without rewriting or relexing" $ do
       let corpus =
             [ ("./test/fork.tri", [], Fork Leaf Leaf)
             , ("./test/comments-1.tri", [], Fork (Stem Leaf) Leaf)
             , ("./test/map.tri", ["map", "append", "equal?", "head"], trueT)
             ]
       forM_ corpus $ \(path, names, expected) -> do
         source <- readFile path
         let external = ofList [Fork (ofString name) (fixtureExports "base" Map.! name) | name <- names]
         foldl apply (fixtureExports "source.unit" Map.! "compileGateProgram")
           [external, ofString source] @?= parserOk expected Leaf
   , testCase "portable size counts leaf, stem, and fork arguments" $ do
       source <- readFile "./test/size.tri"
       let definitions = unlines (init (lines source))
           external = ofList [Fork (ofString name) (fixtureExports "base" Map.! name)
                             | name <- ["y", "triage"]]
       forM_ [("t", 1), ("t t", 2), ("t t t", 3)] $ \(argument, count) -> do
         let input = definitions ++ "size (" ++ argument ++ ")\n"
         foldl apply (fixtureExports "source.unit" Map.! "compileGateProgram")
           [external, ofString input] @?= parserOk (ofNumber count) Leaf
   , testCase "real file inputs match the natively packed self-built artifact" $
       withSystemTempDirectory "gate-file-corpus" $ \dir -> do
         let path = dir </> "file-matches.arboricx"
             corpus =
               [ ("./test/fork.tri", parserOk (Fork Leaf Leaf) Leaf)
               , ("./test/comments-1.tri",
                   parserOk (Fork (Stem Leaf) Leaf) Leaf)
               , ("./test/map.tri", parserOk trueT Leaf)
               , -- Optimized unit lowering with constructor-K-compiled y/triage.
               -- Independently counted the emitted size tree on the host: 500
               -- nodes (formerly 680 with the old support representations).
               ("./test/size.tri", parserOk (ofNumber 500) Leaf)
               ]
         packCompilerFile
           "./test/sourceGateFileCompiler.tri" path [pack "matchesFile"]
         bytes <- BS.readFile path
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
             forM_ corpus $ \(fixture, expected) -> do
               source <- readFile fixture
               apply (apply artifact (ofString source)) expected @?= trueT
   , testCase "self-built local binding compiler executes through its wrapper" $ do
       env <- evaluateCompilerFile
         "./test/sourceGateLocalImport.tri"
       Map.lookup "main" env @?= Just (parserOk Leaf Leaf)
   , testCase "independent program goldens match the Haskell bundle" $
       withSystemTempDirectory "gate-unit-goldens" $ \dir -> do
         let path = dir </> "program-matches.arboricx"
         packCompilerFile
           "./test/sourceGateUnitCompiler.tri" path [pack "matchesExpected"]
         bytes <- BS.readFile path
         goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
         let name = gateToken 2 (ofString "f")
               (gatePosition 2 1 6) (gatePosition 2 2 7)
             body = gateAst 1 Leaf
               (gatePosition 2 5 10) (gatePosition 2 6 11)
             cycleError = parserErr
               (portableDiagnostic (ofNumber 31) (ofString "acyclic")
                 (ofString "a") (gatePosition 1 1 0)
                 (ofList [ofString "a"])) Leaf
             cases =
               [ ("main = id 42\nid x = x", "goldenFortyTwo",
                   parserOk (ofNumber 42) Leaf)
               , ("id x = x\nid 42", "goldenFortyTwo",
                   parserOk (ofNumber 42) Leaf)
               , ("main = 2\n3", "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = [(id 2)]\nid x = x", "goldenProgramList",
                   parserOk (ofList [ofNumber 2]) Leaf)
               , ("helper = t", "goldenMissingRoot", parserErr
                   (portableDiagnostic (ofNumber 32) (ofString "main")
                     Leaf Leaf Leaf) Leaf)
               , ("a = b\nb = a\nmain = t", "goldenProgramCycle", cycleError)
               , ("f = t\nf = t", "goldenProgramDuplicate", parserErr
                   (portableDiagnostic (ofNumber 30) (ofString "f")
                     (ofString "f") (gatePosition 2 1 6) Leaf)
                   (pairT name body))
               , ("main = u", "goldenProgramUnknown", parserErr
                   (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
                     (gatePosition 1 8 7) Leaf)
                   (gateAst 2 (ofString "u")
                     (gatePosition 1 8 7) (gatePosition 1 9 8)))
               , ("unused = (x : x x) (x : x x)\nmain = t", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main = let x = t in x", "goldenLeaf", parserOk Leaf Leaf)
               , ("main = x where x = t", "goldenLeaf", parserOk Leaf Leaf)
               , ("main = let id x = x in id 2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = value where value = helper t\nhelper x = x",
                   "goldenLeaf", parserOk Leaf Leaf)
               , ("main = let x = x in x", "goldenLocalMissing", parserErr
                   (portableDiagnostic (ofNumber 20) (ofString "x") Leaf
                     (gatePosition 1 16 15) Leaf)
                   (gateAst 2 (ofString "x")
                     (gatePosition 1 16 15) (gatePosition 1 17 16)))
               , ("main = let x = t x", "goldenLetMissingIn", parserErr
                   (portableDiagnostic (ofNumber 2) (ofNumber 13)
                     Leaf Leaf Leaf) Leaf)
               , ("main = (t\n t)", "goldenMultilineGroup",
                   parserOk (Stem Leaf) Leaf)
               , ("main = [(t\n t)]", "goldenMultilineList",
                   parserOk (ofList [Stem Leaf]) Leaf)
               , ("main = (x\n where x = t)", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main =\n  t", "goldenLeaf", parserOk Leaf Leaf)
               , ("main =\nt", "goldenLeaf", parserOk Leaf Leaf)
               , ("main =\n  (x : x)\n    2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main =\n  id\n    t\nid x = x", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main = value\nwhere value = t", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main =\n  value\n  where value = t", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main =\n", "goldenMissingDefinitionBody", parserErr
                   (portableDiagnostic (ofNumber 40)
                     (ofString "definition body") Leaf Leaf Leaf) Leaf)
               , ("main = let x =\n  2\nin x", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = let x = t in\n  x", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main = let\n  id x =\n    x\nin id 2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main =\n  let x =\n    t\n  in x", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main = t where x =\n  2", "goldenLeaf",
                   parserOk Leaf Leaf)
               , ("main = id 2 where\n  id x =\n    x", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = let x =\n  (y : y)\n    2\nin x", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = let id x = x in\n  id\n    2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = let x =\n", "goldenMissingLocalValue", parserErr
                   (portableDiagnostic (ofNumber 40)
                     (ofString "local binding value") Leaf Leaf Leaf) Leaf)
               , ("main = let x = t in\n", "goldenMissingLocalBody", parserErr
                   (portableDiagnostic (ofNumber 40)
                     (ofString "local binding body") Leaf Leaf Leaf) Leaf)
               , ("main = 2 |> (x : x)", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = (x : x) <| 2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = 2 |> (x : x) |> (x : x)", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = t <| t t", "goldenPipeApplication",
                   parserOk (Stem (Stem Leaf)) Leaf)
               , ("main = 2 |> id\nid x = x", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = 2 |> id where id x = x", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = 2 |> missing", "goldenPipeUnknown", parserErr
                   (portableDiagnostic (ofNumber 20) (ofString "missing")
                     Leaf (gatePosition 1 13 12) Leaf)
                   (gateAst 2 (ofString "missing")
                     (gatePosition 1 13 12) (gatePosition 1 20 19)))
               , ("main = 2 |>", "goldenPipeMissingOperand", parserErr
                   (portableDiagnostic (ofNumber 2) (ofNumber 7)
                     Leaf Leaf Leaf) Leaf)
               , ("f = 2\nf |> let id x = x in id", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = 2\n  |> (x : x)", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = 2 |>\n  (x : x)", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = do bind\n  x <- 2\n  x\nbind a f = f a",
                   "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = do unused\n  2", "goldenTwo",
                   parserOk (ofNumber 2) Leaf)
               , ("main = do bind\n  1\n  2\nbind a f = f a",
                   "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = do bind\n  x <- 2\n  y <- x\n  y\nbind a f = f a",
                   "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = do bind\n  x <- 2\n  do bind\n    y <- x\n    y\nbind a f = f a",
                   "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = do bind\n  x <- (y : y)\n         2\n  x\nbind a f = f a",
                   "goldenTwo", parserOk (ofNumber 2) Leaf)
               , ("main = let _ = 42 in do bind\n  1\n  _\nbind a f = f a",
                   "goldenOne", parserOk (ofNumber 1) Leaf)
               , ("main = do bind\n  x <- 2", "goldenDoMissingFinal", parserErr
                   (portableDiagnostic (ofNumber 40)
                     (ofString "do final expression") Leaf
                     (gatePosition 2 3 17) Leaf) Leaf)
               , ("main = do bind\n  x <- missing\n  x\nbind a f = f a",
                   "goldenDoUnboundAction", parserErr
                     (portableDiagnostic (ofNumber 20) (ofString "missing")
                       Leaf (gatePosition 2 8 22) Leaf)
                     (gateAst 2 (ofString "missing")
                       (gatePosition 2 8 22) (gatePosition 2 15 29)))
               ]
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
             forM_ cases $ \(source, goldenName, expected) -> do
               Map.lookup goldenName goldenEnv @?= Just expected
               assertBool ("program golden mismatch: " ++ goldenName
                 ++ " for " ++ show source)
                 (apply (apply artifact (ofString source)) expected == trueT)
             case Map.lookup "goldenProgramCycleWrongPosition" goldenEnv of
               Nothing -> assertFailure "missing program wrong-position control"
               Just wrong ->
                 apply (apply artifact (ofString "a = b\nb = a\nmain = t")) wrong
                   @?= falseT
   , testCase "output goldens match the portable Haskell bundle" $
       withSystemTempDirectory "gate-unit-output-goldens" $ \dir -> do
         let path = dir </> "output-matches.arboricx"
         packCompilerFile
           "./test/sourceGateUnitCompiler.tri" path [pack "matchesOutput"]
         bytes <- BS.readFile path
         goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
                 cases =
                   [ ("main = value\nvalue = t", "goldenOutputForward",
                       parserOk (pairT Leaf (ofList
                         [ pairT (ofString "value") Leaf
                         , pairT (ofString "main") Leaf
                         ])) Leaf)
                   , ("2", "goldenOutputExpression",
                       parserOk (pairT (ofNumber 2) Leaf) Leaf)
                   ]
             forM_ cases $ \(source, goldenName, expected) -> do
               Map.lookup goldenName goldenEnv @?= Just expected
               apply (apply artifact (ofString source)) expected @?= trueT
   , testCase "output includes root and definitions in dependency order" $ do
       let source = "main = value\nvalue = t"
           output = foldl apply (gateUnitEnv Map.! "compileGateProgramOutput") [Leaf, ofString source]
           definitions = ofList
             [ pairT (ofString "value") Leaf
             , pairT (ofString "main") Leaf
             ]
       output @?= parserOk (pairT Leaf definitions) Leaf
       check Leaf source (parserOk Leaf Leaf)
   , testCase "empty output environment still carries the selected root" $
       foldl apply (gateUnitEnv Map.! "compileGateProgramOutput") [Leaf, ofString "t"] @?=
           parserOk (pairT Leaf Leaf) Leaf
   , testCase "output entrypoint preserves structured diagnostics" $
       foldl apply (gateUnitEnv Map.! "compileGateProgramOutput") [Leaf, ofString "helper = t"] @?=
           parserErr (portableDiagnostic (ofNumber 32)
             (ofString "main") Leaf Leaf Leaf) Leaf
   , testCase "public compileSource normalizes with abstract environment and source" $ do
       env <- evaluateCompilerFile
         "./test/sourcePublicCompiler.tri"
       Map.member "matchesSource" env @?= True
       let check environment source expected = do
             foldl apply (fixtureExports "source.unit" Map.! "compileSource")
               [environment, ofString source] @?= expected
             foldl apply (env Map.! "matchesSource")
               [environment, ofString source, expected] @?= trueT
       assertBool "test wrapper leaked imported compiler" (Map.notMember "compileSource" env)
       check Leaf "main = value\nvalue = t"
         (parserOk (pairT Leaf (ofList
           [pairT (ofString "value") Leaf, pairT (ofString "main") Leaf])) Leaf)
       check (ofList [Fork (ofString "host") (Stem Leaf)]) "host"
         (parserOk (pairT (Stem Leaf) Leaf) Leaf)
       check Leaf "helper = t"
         (parserErr (portableDiagnostic (ofNumber 32)
           (ofString "main") Leaf Leaf Leaf) Leaf)
       foldl apply (env Map.! "matchesSource")
         [Leaf, ofString "main = t", parserOk (pairT (Stem Leaf) Leaf) Leaf] @?= falseT
   , testCase "public compileSource is an exportable two-argument bundle" $
       withSystemTempDirectory "public-source-artifact" $ \dir -> do
         let path = dir </> "compile-source.arboricx"
         packCompilerFile
           "./lib/source/unit.tri" path [pack "compileSource"]
         bytes <- BS.readFile path
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
                 cases =
                   [ (Leaf, "2", parserOk (pairT (ofNumber 2) Leaf) Leaf)
                   , (Leaf, "main = value\nvalue = t", parserOk
                       (pairT Leaf (ofList [pairT (ofString "value") Leaf,
                         pairT (ofString "main") Leaf])) Leaf)
                   , (ofList [pairT (ofString "host") (Stem Leaf)],
                       "host", parserOk (pairT (Stem Leaf) Leaf) Leaf)
                   , (Leaf, "helper = t", parserErr
                       (portableDiagnostic (ofNumber 32)
                         (ofString "main") Leaf Leaf Leaf) Leaf)
                   , (Leaf, "#", parserErr
                       (portableDiagnostic (ofNumber 4) Leaf (ofNumber 35)
                         (gatePosition 1 1 0) Leaf) (ofString "#"))
                   , (Leaf, "!import \"x\" NS", parserErr
                       (portableDiagnostic (ofNumber 4) Leaf (ofNumber 33)
                         (gatePosition 1 1 0) Leaf)
                       (ofString "!import \"x\" NS"))
                   ]
             forM_ cases $ \(environment, source, expected) -> do
               let compiled = apply (apply artifact environment) (ofString source)
               compiled @?= expected
               -- Repeated fixed inputs have structurally identical complete
               -- outputs, not merely the same selected root.
               apply (apply artifact environment) (ofString source) @?= compiled
             forM_
               [ ("./test/fork.tri", Fork Leaf Leaf)
               , ("./test/comments-1.tri", Fork (Stem Leaf) Leaf)
               ] $ \(fixture, root) -> do
                 source <- readFile fixture
                 apply (apply artifact Leaf) (ofString source) @?=
                   parserOk (pairT root
                     (ofList [pairT (ofString "main") root])) Leaf
             let externalNames = ["map", "append", "equal?", "head", "y", "triage"]
                 external = ofList
                   [ pairT (ofString name) (fixtureExports "base" Map.! name)
                   | name <- externalNames ]
             stringSource <- readFile "./test/string.tri"
             apply (apply artifact external) (ofString stringSource) @?=
               parserOk (pairT (ofString "String test!") Leaf) Leaf
             mapSource <- readFile "./test/map.tri"
             apply (apply artifact external) (ofString mapSource) @?=
               parserOk (pairT trueT (ofList
                 [ pairT (ofString "x")
                     (ofList [ofString "Successfully concatenated two strings!"])
                 , pairT (ofString "main") trueT
                 ])) Leaf
   , testCase "public bundle functions agree by application, not tree shape" $
       withSystemTempDirectory "public-source-functions" $ \dir -> do
         let path = dir </> "compile-source.arboricx"
         packCompilerFile
           "./lib/source/unit.tri" path [pack "compileSource"]
         bytes <- BS.readFile path
         comparatorEnv <- evaluateCompilerFile "./test/sourcePublicCompiler.tri"
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let compiler = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
                 comparator = comparatorEnv Map.! "matchesSourceApplicationArtifact"
                 cases =
                   [ ("main x = x", ofNumber 2, ofNumber 2)
                   , ("main x = t", Stem Leaf, Leaf)
                   , ("main x = let id a = a in id x", Stem Leaf, Stem Leaf)
                   , ("main x = do bind\n  y <- x\n  y\nbind a f = f a",
                       ofNumber 2, ofNumber 2)
                   ]
             forM_ cases $ \(source, input, expected) -> do
               foldl apply comparator
                 [compiler, Leaf, ofString source, input, expected] @?= trueT
             let rootComparator = comparatorEnv Map.! "matchesSourceRootArtifact"
                 unused = "unused = (x : x x) (x : x x)\nmain = t"
             unusedRoot <- Timeout.timeout (30 * 1000000) $
               evaluate (foldl apply rootComparator
                 [compiler, Leaf, ofString unused, Leaf] == trueT)
             unusedRoot @?= Just True
   , testCase "self-built compiler wrapper handles a forward reference" $ do
       env <- evaluateCompilerFile
         "./test/sourceGateUnitImport.tri"
       Map.lookup "main" env @?= Just (parserOk Leaf Leaf)
   , testCase "forward definitions with arguments evaluate before main" $ do
       let source = "main = id 42\nid x = x"
       check Leaf source (parserOk (ofNumber 42) Leaf)
   , testCase "final expression selects root in absence of main" $
       check Leaf "id x = x\nid t" (parserOk Leaf Leaf)
   , testCase "a local main wins over a final expression" $
       check Leaf "main = 2\n3" (parserOk (ofNumber 2) Leaf)
   , testCase "provided environment is visible inside definitions" $
       check (ofList [Fork (ofString "host") (Stem Leaf)]) "main = host t"
         (parserOk (Fork Leaf Leaf) Leaf)
   , testCase "multiple definition arguments preserve binder order" $
       let source = "main x y = x"
           program = foldl apply (gateUnitEnv Map.! "compileGateProgram") [Leaf, ofString source]
       in case program of
            Fork tag (Fork fun Leaf) | tag == trueT ->
              apply (apply fun Leaf) (Stem Leaf) @?= Leaf
            other -> assertFailure ("Expected compiled two-argument function, got " ++ show other)
   , testCase "recursive top-level function and triage compile from source" $ do
       let source = "triage leaf stem fork = t (t leaf stem) fork\n"
             ++ "main xs = y (self : rest : triage t (h : self h) (a : b : self a) rest) xs"
           external = ofList [Fork (ofString "y") (gateCompileBaseEnv Map.! "y")]
           compiled = foldl apply (gateUnitEnv Map.! "compileGateProgram") [external, ofString source]
       case compiled of
         Fork tag (Fork fun Leaf) | tag == trueT -> do
           apply fun Leaf @?= Leaf
           apply fun (Stem Leaf) @?= Leaf
           apply fun (Fork (Stem Leaf) Leaf) @?= Leaf
         other -> assertFailure ("Expected recursive source function, got " ++ show other)
   , testCase "recursive function, y, and triage compile entirely from source" $ do
       let source = "y = ((mut : wait : fun : wait mut (x : fun (wait mut x))) "
             ++ "(x : x x) (a0 : a1 : a2 : t (t a0) (t t a2) a1))\n"
             ++ "triage leaf stem fork = t (t leaf stem) fork\n"
             ++ "main xs = y (self : rest : triage t (h : self h) "
             ++ "(a : b : self a) rest) xs"
           compiled = foldl apply (gateUnitEnv Map.! "compileGateProgram") [Leaf, ofString source]
       case compiled of
         Fork tag (Fork fun Leaf) | tag == trueT -> do
           apply fun Leaf @?= Leaf
           apply fun (Stem Leaf) @?= Leaf
           apply fun (Fork (Stem Leaf) Leaf) @?= Leaf
         other -> assertFailure ("Expected fully sourced recursive function, got " ++ show other)
   , testCase "indented definition bodies preserve continuation layout" $ do
       let sources =
             [ ("main =\n  t", Leaf)
             , ("main =\nt", Leaf)
             , ("main =\n  (x : x)\n    2", ofNumber 2)
             , ("main =\n  id\n    t\nid x = x", Leaf)
             , ("main = value\nwhere value = t", Leaf)
             , ("main =\n  value\n  where value = t", Leaf)
             ]
       forM_ sources $ \(source, value) -> do
         check Leaf source (parserOk value Leaf)
   , testCase "multiline grouped applications retain expected results" $ do
       let sources =
             [ ("main = (t\n t)", Stem Leaf)
             , ("main = [(t\n t)]", ofList [Stem Leaf])
             , ("main = (let x = t in x\n t)", Stem Leaf)
             , ("main = (x\n where x = t)", Leaf)
             ]
       forM_ sources $ \(source, value) -> do
         check Leaf source (parserOk value Leaf)
   , testCase "an unindented do block has a located diagnostic" $
       let diagnostic = portableDiagnostic (ofNumber 40)
             (ofString "indented do block") (ofNumber 2)
             (gatePosition 2 1 15) Leaf
           reply = apply (gateProgramEnv Map.! "parseGateProgram")
             (ofString "main = do bind\nx <- 2\n  x")
       in apply (fixtureExports "parser" Map.! "parserReplyPayload") reply @?= diagnostic
   , testCase "pipe followed by a local assignment stays a final expression" $
       check Leaf "f = 2\nf |> let id x = x in id"
         (parserOk (ofNumber 2) Leaf)
   , testCase "explicit-bind do with nested statements retains expected results" $ do
       let sources =
             [ "main = do bind\n  x <- 2\n  x\nbind a f = f a"
             , "main = do unused\n  2"
             , "main = do bind\n  1\n  2\nbind a f = f a"
             , "main = do bind\n  x <- 2\n  y <- x\n  y\nbind a f = f a"
             , "main = do bind\n  x <- 2\n  do bind\n    y <- x\n    y\nbind a f = f a"
             ]
       forM_ sources $ \source -> do
         check Leaf source (parserOk (ofNumber 2) Leaf)
   , testCase "pipe directions, precedence, and local names retain expected results" $ do
       let sources =
             [ ("main = 2 |> (x : x)", ofNumber 2)
             , ("main = (x : x) <| 2", ofNumber 2)
             , ("main = 2 |> (x : x) |> (x : x)", ofNumber 2)
             , ("main = t <| t t", Stem (Stem Leaf))
             , ("main = 2 |> id\nid x = x", ofNumber 2)
             , ("main = 2 |> id where id x = x", ofNumber 2)
             , ("main = 2\n  |> (x : x)", ofNumber 2)
             , ("main = 2 |>\n  (x : x)", ofNumber 2)
             ]
       forM_ sources $ \(source, value) -> do
         check Leaf source (parserOk value Leaf)
   , testCase "multiline local let/where layout retains expected results" $ do
       let sources =
             [ ("main = let x =\n  2\nin x", ofNumber 2)
             , ("main = let x = t in\n  x", Leaf)
             , ("main = let\n  id x =\n    x\nin id 2", ofNumber 2)
             , ("main =\n  let x =\n    t\n  in x", Leaf)
             , ("main = t where x =\n  2", Leaf)
             , ("main = id 2 where\n  id x =\n    x", ofNumber 2)
             , ("main = let x =\n  (y : y)\n    2\nin x", ofNumber 2)
             , ("main = let id x = x in\n  id\n    2", ofNumber 2)
             ]
       forM_ sources $ \(source, value) -> do
         check Leaf source (parserOk value Leaf)
   , testCase "local bindings preserve lexical scope and argument order" $ do
       let sources =
             [ ("main = let x = 2 in x", ofNumber 2)
             , ("main = let id x = x in id 2", ofNumber 2)
             , ("main = id 2 where id x = x", ofNumber 2)
             , ("result where result = t", Leaf)
             , ("main = let x = t in (y : x) 2", Leaf)
             ]
       forM_ sources $ \(source, value) -> do
         check Leaf source (parserOk value Leaf)
   , testCase "local binding value has no self-reference" $
       check Leaf "main = let x = x in x" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "x") Leaf
           (gatePosition 1 16 15) Leaf)
         (gateAst 2 (ofString "x")
           (gatePosition 1 16 15) (gatePosition 1 17 16)))
   , testCase "a local binder shadows a top-level definition" $
       check Leaf "main = local where local = t\nlocal = 2"
         (parserOk Leaf Leaf)
   , testCase "local free names order forward-referenced definitions" $
       check Leaf "main = value where value = helper t\nhelper x = x"
         (parserOk Leaf Leaf)
   , testCase "lists may refer to forward definitions" $
       check Leaf "main = [(id 2)]\nid x = x"
         (parserOk (ofList [ofNumber 2]) Leaf)
   , testCase "unused divergent body is checked but not demanded" $ do
       let source = "unused = (x : x x) (x : x x)\nmain = t"
       check Leaf source (parserOk Leaf Leaf)
   , testCase "missing multiline definition body is a structured diagnostic" $
       check Leaf "main =\n" (parserErr
         (portableDiagnostic (ofNumber 40) (ofString "definition body")
           Leaf Leaf Leaf) Leaf)
   , testCase "missing local value or body returns a structured diagnostic" $ do
       check Leaf "main = let x =\n" (parserErr
         (portableDiagnostic (ofNumber 40)
           (ofString "local binding value") Leaf Leaf Leaf) Leaf)
       check Leaf "main = let x = t in\n" (parserErr
         (portableDiagnostic (ofNumber 40)
           (ofString "local binding body") Leaf Leaf Leaf) Leaf)
   , testCase "no root is a structured diagnostic" $
       check Leaf "helper = t" (parserErr
         (portableDiagnostic (ofNumber 32) (ofString "main") Leaf Leaf Leaf)
         Leaf)
   , testCase "cycle fails before result selection" $
       check Leaf "a = b\nb = a\nmain = t" (parserErr
         (portableDiagnostic (ofNumber 31) (ofString "acyclic")
           (ofString "a") (gatePosition 1 1 0)
           (ofList [ofString "a"])) Leaf)
   ]
   where
     check external source expected =
       foldl apply (gateUnitEnv Map.! "compileGateProgram") [external, ofString source]
         @?= expected
 
 -- --------------------------------------------------------------------------
 -- Single-expression feasibility-gate name resolution
 -- --------------------------------------------------------------------------
 
 gateResolveEnv :: Env
 gateResolveEnv = fixtureExports "source.resolve"
 {-# NOINLINE gateResolveEnv #-}
 
 gateCore :: Integer -> T -> T -> T -> T
 gateCore = gateAst
 
 gateResolutionTests :: TestTree
 gateResolutionTests = testGroup "Feasibility-gate resolution"
   [ testCase "self-built resolver export executes through its wrapper" $ do
       env <- evaluateCompilerFile "./test/sourceGateResolveImport.tri"
       let bound = gateCore 2 (ofNumber 0) (gatePosition 1 5 4) (gatePosition 1 6 5)
           lam = gateCore 4 bound (gatePosition 1 1 0) (gatePosition 1 6 5)
       Map.lookup "main" env @?= Just (parserOk lam Leaf)
   , testCase "nearest lexical binder has index zero" $
       let bound = gateCore 2 (ofNumber 0) (gatePosition 1 5 4) (gatePosition 1 6 5)
       in check Leaf "x : x" (parserOk
         (gateCore 4 bound (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf)
   , testCase "outer lexical binder has index one" $
       let bound = gateCore 2 (ofNumber 1) (gatePosition 1 9 8) (gatePosition 1 10 9)
           inner = gateCore 4 bound (gatePosition 1 5 4) (gatePosition 1 10 9)
       in check Leaf "x : y : x" (parserOk
         (gateCore 4 inner (gatePosition 1 1 0) (gatePosition 1 10 9)) Leaf)
   , testCase "local binding lowers to an applied scoped lambda" $
       let value = gateCore 1 Leaf
             (gatePosition 1 9 8) (gatePosition 1 10 9)
           bound = gateCore 2 (ofNumber 0)
             (gatePosition 1 14 13) (gatePosition 1 15 14)
           scoped = gateCore 4 bound
             (gatePosition 1 1 0) (gatePosition 1 15 14)
       in check Leaf "let x = t in x" (parserOk
         (gateCore 3 (pairT scoped value)
           (gatePosition 1 1 0) (gatePosition 1 15 14)) Leaf)
   , testCase "forward pipe elaborates to reversed core application" $
       let function = gateCore 5 (Stem Leaf)
             (gatePosition 1 6 5) (gatePosition 1 7 6)
           argument = gateCore 6 (ofNumber 2)
             (gatePosition 1 1 0) (gatePosition 1 2 1)
       in check (ofList [Fork (ofString "f") (Stem Leaf)]) "2 |> f" (parserOk
         (gateCore 3 (pairT function argument)
           (gatePosition 1 1 0) (gatePosition 1 7 6)) Leaf)
   , testCase "number becomes a resolved tree literal" $
       check Leaf "42" (parserOk
         (gateCore 6 (ofNumber 42) (gatePosition 1 1 0) (gatePosition 1 3 2)) Leaf)
   , testCase "string becomes a resolved tree literal" $
       check Leaf "\"hi\"" (parserOk
         (gateCore 7 (ofString "hi") (gatePosition 1 1 0) (gatePosition 1 5 4)) Leaf)
   , testCase "list elements become individually resolved core nodes" $
       let leaf = gateCore 1 Leaf (gatePosition 1 2 1) (gatePosition 1 3 2)
           number = gateCore 6 (ofNumber 2)
             (gatePosition 1 4 3) (gatePosition 1 5 4)
       in check Leaf "[t 2]" (parserOk
         (gateCore 8 (ofList [leaf, number])
           (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf)
   , testCase "unresolved list element preserves its own span" $
       check Leaf "[u]" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
           (gatePosition 1 2 1) Leaf)
         (gateAst 2 (ofString "u")
           (gatePosition 1 2 1) (gatePosition 1 3 2)))
   , testCase "supplied external tree becomes a core value" $
       let external = gateCore 5 (Stem Leaf)
             (gatePosition 1 1 0) (gatePosition 1 2 1)
           leaf = gateCore 1 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
       in check (ofList [Fork (ofString "f") (Stem Leaf)]) "f t" (parserOk
         (gateCore 3 (pairT external leaf)
           (gatePosition 1 1 0) (gatePosition 1 4 3)) Leaf)
   , testCase "lexical binder shadows an external value" $
       let bound = gateCore 2 (ofNumber 0) (gatePosition 1 5 4) (gatePosition 1 6 5)
       in check (ofList [Fork (ofString "x") (Stem Leaf)]) "x : x" (parserOk
         (gateCore 4 bound (gatePosition 1 1 0) (gatePosition 1 6 5)) Leaf)
   , testCase "unresolved name reports its original position" $
       check Leaf "u" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
           (gatePosition 1 1 0) Leaf)
         (gateAst 2 (ofString "u") (gatePosition 1 1 0) (gatePosition 1 2 1)))
   , testCase "grouping carries its span into the core" $
       check Leaf "(t)" (parserOk
         (gateCore 1 Leaf (gatePosition 1 1 0) (gatePosition 1 4 3)) Leaf)
   ]
   where
     check environment input expected =
       foldl apply (gateResolveEnv Map.! "resolveGateSource") [environment, ofString input] @?= expected
 
 -- --------------------------------------------------------------------------
 -- Reference S/K/I compiler for the feasibility gate
 -- --------------------------------------------------------------------------
 
 gateCompileEnv :: Env
 gateCompileEnv = fixtureExports "source.compile"
 {-# NOINLINE gateCompileEnv #-}
 
 gateCompileBaseEnv :: Env
 gateCompileBaseEnv = fixtureExports "base"
 {-# NOINLINE gateCompileBaseEnv #-}
 
 gateCompilationTests :: TestTree
 gateCompilationTests = testGroup "Feasibility-gate source compiler"
   [ testCase "Haskell reducer executes the exported conformance artifact" $
       withSystemTempDirectory "gate-conforms-bundle" $ \dir -> do
         let path = dir </> "conforms.arboricx"
         packCompilerFile "./test/sourceGateCompiler.tri"
           path [pack "conforms"]
         bytes <- BS.readFile path
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
                 corpus =
                   [ ("t", "t", trueT)
                   , ("t t", "t", falseT)
                   , ("t t t", "t t t", trueT)
                   , ("(x : x) t", "t", trueT)
                   , ("(x : t) (t t)", "t", trueT)
                   , ("u", "u", trueT)
                   , ("u", "t", falseT)
                   , (nestedIdentity 16, "t", trueT)
                   , (nestedBinders 16, "t", trueT)
                   ]
             forM_ corpus $ \(source, expectedSource, expected) ->
               apply (apply artifact (ofString source)) (ofString expectedSource)
                 @?= expected
   , testCase "independent golden results match the Haskell artifact" $
       withSystemTempDirectory "gate-golden-bundle" $ \dir -> do
         let path = dir </> "matches.arboricx"
         packCompilerFile "./test/sourceGateCompiler.tri"
           path [pack "matchesExpected"]
         bytes <- BS.readFile path
         goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
         let unknown = parserErr
               (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
                 (gatePosition 1 1 0) Leaf)
               (gateAst 2 (ofString "u") (gatePosition 1 1 0) (gatePosition 1 2 1))
             unsupported = parserErr
               (portableDiagnostic (ofNumber 4) Leaf (ofNumber 35)
                 (gatePosition 1 1 0) Leaf)
               (ofString "#")
             badEscape = parserErr
               (portableDiagnostic (ofNumber 6) (ofNumber 34) (ofNumber 113)
                 (gatePosition 1 3 2) Leaf)
               (ofString "\\q\"")
             unfinishedString = parserErr
               (portableDiagnostic (ofNumber 5) (ofNumber 34) Leaf
                 (gatePosition 1 1 0) Leaf) Leaf
             unfinishedBlock = parserErr
               (portableDiagnostic (ofNumber 5) (ofString "-|") Leaf
                 (gatePosition 1 1 0) Leaf) Leaf
             unknownInList = parserErr
               (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
                 (gatePosition 1 2 1) Leaf)
               (gateAst 2 (ofString "u")
                 (gatePosition 1 2 1) (gatePosition 1 3 2))
             missingListClose = parserErr
               (portableDiagnostic (ofNumber 2) (ofNumber 10) Leaf Leaf Leaf)
               Leaf
             comma = parserErr
               (portableDiagnostic (ofNumber 2) (ofNumber 10) (ofNumber 20)
                 (gatePosition 1 3 2) Leaf)
               (ofList
                 [ gateToken 20 Leaf (gatePosition 1 3 2) (gatePosition 1 4 3)
                 , gateToken 1 (ofString "t") (gatePosition 1 5 4) (gatePosition 1 6 5)
                 , gateToken 10 Leaf (gatePosition 1 6 5) (gatePosition 1 7 6)
                 ])
             golden =
               [ ("t", "goldenLeaf", parserOk Leaf Leaf)
               , ("t t", "goldenStem", parserOk (Stem Leaf) Leaf)
               , ("t t t", "goldenFork", parserOk (Fork Leaf Leaf) Leaf)
               , ("(x : x) t", "goldenLeaf", parserOk Leaf Leaf)
               , ("42", "goldenFortyTwo", parserOk (ofNumber 42) Leaf)
               , ("\"hi\"", "goldenHi", parserOk (ofString "hi") Leaf)
               , ("|-note-| \"hi\"", "goldenHi", parserOk (ofString "hi") Leaf)
               , ("u", "goldenUnknown", unknown)
               , ("#", "goldenUnsupported", unsupported)
               , ("\"\\q\"", "goldenBadEscape", badEscape)
               , ("\"hi", "goldenUnfinishedString", unfinishedString)
               , ("|-oops", "goldenUnfinishedBlock", unfinishedBlock)
               , ("[]", "goldenLeaf", parserOk Leaf Leaf)
               , ("[t 2]", "goldenListTwo",
                   parserOk (ofList [Leaf, ofNumber 2]) Leaf)
               , ("[t\n2]", "goldenListTwo",
                   parserOk (ofList [Leaf, ofNumber 2]) Leaf)
               , ("[[t] (t t)]", "goldenNestedList",
                   parserOk (ofList [ofList [Leaf], Stem Leaf]) Leaf)
               , ("[u]", "goldenUnknownInList", unknownInList)
               , ("[t", "goldenMissingListClose", missingListClose)
               , ("[t, t]", "goldenComma", comma)
               ]
         case decodeBundle bytes of
           Left diagnostic -> assertFailure diagnostic
           Right bundle -> do
             let artifact = reconstructBundleTerms (bundleNodes bundle)
                   V.! fromIntegral (head (bundleRoots bundle))
             forM_ golden $ \(source, name, expected) -> do
               Map.lookup name goldenEnv @?= Just expected
               apply (apply artifact (ofString source)) expected @?= trueT
             case Map.lookup "goldenUnknownWrongPosition" goldenEnv of
               Nothing -> assertFailure "missing incorrect-position control"
               Just wrong -> do
                 apply (apply artifact (ofString "u")) wrong @?= falseT
                 apply (apply artifact (ofString "t t"))
                   (parserOk Leaf Leaf) @?= falseT
   , testCase "self-built resolver export executes through its wrapper" $ do
       env <- evaluateCompilerFile "./test/sourceGateCompileImport.tri"
       Map.lookup "main" env @?= Just (parserOk Leaf Leaf)
   , testCase "leaf compiles to raw Leaf" $
       check "t" (parserOk Leaf Leaf)
   , testCase "decimal literal compiles to the canonical number tree" $ do
       check "42" (parserOk (ofNumber 42) Leaf)
       check "000" (parserOk Leaf Leaf)
   , testCase "list element boundaries distinguish atoms from grouped applications" $ do
       check "[t t]" (parserOk (ofList [Leaf, Leaf]) Leaf)
       check "[(t t)]" (parserOk (ofList [Stem Leaf]) Leaf)
       check "[t\n2]" (parserOk (ofList [Leaf, ofNumber 2]) Leaf)
   , testCase "lists compile to canonical Fork cells" $ do
       check "[]" (parserOk Leaf Leaf)
       check "[t 2]" (parserOk (ofList [Leaf, ofNumber 2]) Leaf)
       check "[[t] (t t)]" (parserOk
         (ofList [ofList [Leaf], Stem Leaf]) Leaf)
       check "[t\n2]" (parserOk (ofList [Leaf, ofNumber 2]) Leaf)
       check "(x : [x]) t" (parserOk (ofList [Leaf]) Leaf)
   , testCase "string literal compiles to the canonical character list" $ do
       check "\"hi\"" (parserOk (ofString "hi") Leaf)
       check "(x : x) \"hi\"" (parserOk (ofString "hi") Leaf)
   , testCase "comments and literals compose without a special host lexer" $ do
       check "42 --ok" (parserOk (ofNumber 42) Leaf)
       check "|-note-| \"hi\"" (parserOk (ofString "hi") Leaf)
   , testCase "application evaluates to raw Stem and Fork" $ do
       check "t t" (parserOk (Stem Leaf) Leaf)
       check "t t t" (parserOk (Fork Leaf Leaf) Leaf)
   , testCase "identity behaves correctly under arguments" $
       checkFunction "x : x" [ofNumber 5] (ofNumber 5)
   , testCase "constant behaves correctly under arguments" $
       checkFunction "x : t" [ofNumber 5] Leaf
   , testCase "nested lambdas preserve the outer argument" $
       checkFunction "x : y : x" [ofNumber 5, ofNumber 8] (ofNumber 5)
   , testCase "pruned bracket agrees with the retained reference" $ do
       let term kind payload = Fork (ofNumber kind) (Fork payload Leaf)
           var = term 2 Leaf
           leaf = term 1 Leaf
           app f x = term 3 (Fork f x)
           terms = [var, leaf, app var leaf, app leaf var, app var var]
           compiled method value = apply (gateCompileEnv Map.! "sourceRunTerm")
             (apply (gateCompileEnv Map.! method) value)
       forM_ terms $ \term ->
         case (compiled "sourceBracketReference" term,
               compiled "sourceBracket" term) of
           (Fork referenceTag (Fork reference Leaf),
            Fork optimizedTag (Fork optimized Leaf))
             | referenceTag == trueT && optimizedTag == trueT ->
                 forM_ [Leaf, Stem Leaf] $ \argument ->
                   apply optimized argument @?= apply reference argument
           other -> assertFailure ("Expected two bracketed trees, got " ++ show other)
   , testCase "star eta and retained B/C reference agree when applied" $ do
       let compiled method source =
             case foldl apply (gateResolveEnv Map.! "resolveGateSource") [Leaf, ofString source] of
               Fork tag (Fork core Leaf) | tag == trueT -> apply (gateCompileEnv Map.! method) core
               other -> error ("reference corpus failed resolution: " ++ show other)
           corpus =
             [ ("x : x", [ofNumber 5], ofNumber 5)
             , ("x y : x", [ofNumber 5, ofNumber 8], ofNumber 5)
             , ("x y : y", [ofNumber 5, ofNumber 8], ofNumber 8)
             , ("x : x x", [Stem Leaf], Fork Leaf (Stem Leaf))
             , ("f x : f x", [Stem Leaf, Leaf], Fork Leaf Leaf)
             , ("f x y : f (x y)", [Stem Leaf, Stem Leaf, Leaf],
                 Fork Leaf (Fork Leaf Leaf))
             , ("x : [x 2]", [Leaf], ofList [Leaf, ofNumber 2])
             , ("a : (a : a)", [Leaf, Stem Leaf], Stem Leaf)
             ]
       forM_ corpus $ \(source, arguments, expected) ->
         forM_ ["sourceCompileCoreReference", "sourceCompileCore",
                 "sourceCompileCoreKiselyov"] $ \method ->
           case compiled method source of
             Fork tag (Fork fn Leaf) | tag == trueT ->
               foldl apply fn arguments @?= expected
             other -> assertFailure ("Failed to compile " ++ method ++ " "
               ++ source ++ ": " ++ show other)
   , testCase "application inside a lambda behaves correctly" $
       checkFunction "f : x : f x" [Stem Leaf, ofNumber 8] (Fork Leaf (ofNumber 8))
   , testCase "external tree is applied without host lookup" $
       foldl apply (gateCompileEnv Map.! "compileGateSource")
         [ofList [Fork (ofString "f") (Stem Leaf)], ofString "f t"] @?=
           parserOk (Fork Leaf Leaf) Leaf
   , testCase "backend compiles a recursive source function" $ do
       let source = "xs : y (self : rest : triage t (h : self h) (a : b : self a) rest) xs"
           external = ofList [Fork (ofString name) (gateCompileBaseEnv Map.! name)
                             | name <- ["y", "triage"]]
           compiled = foldl apply (gateCompileEnv Map.! "compileGateSource") [external, ofString source]
       case compiled of
         Fork tag (Fork compiled Leaf) | tag == trueT -> do
           apply compiled Leaf @?= Leaf
           apply compiled (Stem Leaf) @?= Leaf
           apply compiled (Fork (Stem Leaf) Leaf) @?= Leaf
         other -> assertFailure ("Expected compiled recursive function, got " ++ show other)
   , testCase "unresolved name stays a diagnostic" $
       check "u" (parserErr
         (portableDiagnostic (ofNumber 20) (ofString "u") Leaf
           (gatePosition 1 1 0) Leaf)
         (gateAst 2 (ofString "u") (gatePosition 1 1 0) (gatePosition 1 2 1)))
   ]
   where
     nestedIdentity depth = iterate (\body -> "(x : x) (" ++ body ++ ")") "t" !! depth
     nestedBinders depth = "(" ++ concatMap (\i -> "x" ++ show i ++ " : ")
       [0 .. depth - 1] ++ "x0) " ++ unwords (replicate depth "t")
     compile input = foldl apply (gateCompileEnv Map.! "compileGateSource") [Leaf, ofString input]
     check input expected = compile input @?= expected
     checkFunction input args expected = case compile input of
       Fork tag (Fork fn Leaf) | tag == trueT -> foldl apply fn args @?= expected
       other -> assertFailure ("Expected compiled function, got " ++ show other)
 
 -- --------------------------------------------------------------------------
 -- Binary parser combinator tests
 -- --------------------------------------------------------------------------
 
 parserOk :: T -> T -> T
 parserOk val rest = Fork trueT (Fork val rest)
 
 parserErr :: T -> T -> T
 parserErr code rest = Fork falseT (Fork code rest)
 
 -- --------------------------------------------------------------------------
 -- IO driver tests
 -- --------------------------------------------------------------------------
 
 -- A deliberately small interpreter: it records every read request, even if
 -- the supplied host reply is a failure. Unknown effects fail the test rather
 -- than being silently ignored. No filesystem or socket effects are executed.
 runRegistryEffects :: T -> T -> IO ([String], T)
 runRegistryEffects readReply = go (100 :: Int)
   where
     go 0 _ = assertFailure "registry effect trace exceeded fuel" >> pure ([], Leaf)
     go fuel (Fork tag payload) = case toNumber tag of
       Right 0 -> pure ([], payload)
       Right 1 -> case payload of
         Fork action continuation -> do
           (before, value) <- go (fuel - 1) action
           (after, answer) <- go (fuel - 1) (apply continuation value)
           pure (before ++ after, answer)
         _ -> assertFailure "malformed Bind" >> pure ([], Leaf)
       Right 20 -> case toString payload of
         Right path -> pure ([path], readReply)
         Left message -> assertFailure message >> pure ([], Leaf)
       other -> assertFailure ("unexpected registry effect: " ++ show other) >> pure ([], Leaf)
     go _ _ = assertFailure "malformed registry action" >> pure ([], Leaf)
 
 registryContractTests :: TestTree
 registryContractTests = testCase "Registry hash contract: values, bounded rejection and read effects" $
   withSystemTempDirectory "registry-contract" $ \dir -> do
     env <- evaluateCompilerFile "./lib/arboricx/server.tri"
     let call name = foldl apply (env Map.! name)
         http name = foldl apply (fixtureExports "http" Map.! name)
         valid = concat (replicate 4 "0123456789abcdef")
         hash = ofString valid
         diagnostic = ofString "expected 64 lowercase hexadecimal hash characters"
         ok value rest = Fork (Stem Leaf) (Fork value rest)
         err value rest = Fork Leaf (Fork value rest)
         root = ofString "/registry"
         expectedPath = "/registry/objects/012/" ++ valid ++ ".arboricx"
         invalid = ["", replicate 63 'a', replicate 65 'a', replicate 64 'A',
                    'g' : tail valid, take 32 valid ++ "g" ++ drop 33 valid,
                    take 63 valid ++ "g", "../secret", "abc/../../secret",
                    take 63 valid ++ "/", replicate 65536 'a']
     -- All host byte values, not only selected examples.
     forM_ [0..255] $ \byte -> do
       let expected = if byte `elem` map (toInteger . fromEnum) "0123456789abcdef"
                      then Stem Leaf else Leaf
       call "bundleHexByte?" [ofNumber byte] @?= expected
     forM_ ("0123456789abcdef" :: String) $ \digit ->
       call "bundleHashValid?" [ofString (replicate 64 digit)] @?= Stem Leaf
     call "bundleHashC" [hash, ofNumber 7] @?= ok hash (ofNumber 7)
     forM_ invalid $ \bad ->
       call "bundleHashC" [ofString bad, ofNumber 7] @?= err diagnostic (ofNumber 7)
     -- Arbitrary malformed trees are rejected as well as canonical byte lists.
     forM_ [Stem Leaf, Fork (Stem Leaf) Leaf,
            foldr Fork (Stem Leaf) (replicate 64 (ofNumber 97)),
            Fork (Fork (Fork Leaf Leaf) Leaf) (ofString (tail valid))] $ \bad ->
       call "bundleHashValid?" [bad] @?= Leaf
     -- A 65th cons is sufficient evidence: neither its byte nor tail is forced.
     let oversized = foldr Fork
           (Fork (error "65th byte inspected") (error "oversized suffix inspected"))
           (replicate 64 (ofNumber 97))
     call "bundleHashValid?" [oversized] @?= Leaf
     let malformedByte = foldr Fork
           (Fork (error "extra byte bit inspected") (error "extra byte suffix inspected"))
           [Stem Leaf, Leaf, Leaf, Leaf, Leaf, Stem Leaf, Stem Leaf]
     call "bundleHexByte?" [malformedByte] @?= Leaf
     let missing = err (ofString "missing") Leaf
         present = ok (ofString "bundle") Leaf
         get value = call "getBundleByHash" [root, value]
         serve value = call "serveBundleHash" [root, value]
         route value = call "getBundleRoute"
           [root, ofString "GET", ofString ("/_arboricx/bundle/hash/" ++ value)]
         router value = call "arboricxRouter"
           [root, ofString "GET", ofString ("/_arboricx/bundle/hash/" ++ value), Leaf, Leaf]
         rejected = http "badRequestResponse" [diagnostic]
     forM_ invalid $ \bad -> do
       runRegistryEffects present (get (ofString bad)) >>= (@?= ([], err (ofNumber 400) diagnostic))
       forM_ [serve (ofString bad), route bad, router bad] $ \action ->
         runRegistryEffects present action >>= (@?= ([], rejected))
     runRegistryEffects present (get hash) >>= (@?= ([expectedPath], present))
     runRegistryEffects missing (get hash) >>=
       (@?= ([expectedPath], err (ofNumber 404) (ofString "missing")))
     let response = ofString $ "HTTP/1.1 200 OK\r\n" ++
           "Content-Type: application/vnd.arboricx.bundle\r\n" ++
           "Content-Length: 6\r\nConnection: close\r\n\r\nbundle"
     forM_ [serve hash, route valid, router valid] $ \action -> do
       runRegistryEffects present action >>= (@?= ([expectedPath], response))
       runRegistryEffects missing action >>=
         (@?= ([expectedPath], http "errorResponse" [ofNumber 404, ofString "missing"]))
     forM_ [("/_arboricx/health", http "okResponse" [ofString "OK\n"]),
            ("/", http "htmlResponse" [env Map.! "htmlLandingPage"])] $ \(target, expected) ->
       runRegistryEffects present
         (call "arboricxRouter" [root, ofString "GET", ofString target, Leaf, Leaf]) >>=
         (@?= ([], expected))
 
 registryPipelineTests :: TestTree
 registryPipelineTests = testGroup "Registry publication and startup"
   [ testCase "complete effects: atomic upload, traversal rejection, init and socket failures" $ do
       env <- evaluateCompilerFile "./lib/arboricx/server.tri"
       let call name = foldl apply (env Map.! name)
           root = ofString "/registry"
           bytes = ofBytes (BS.pack [0,255,1])
           hash = "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
           primitive tag payload = Fork (ofNumber tag) payload
           ok = parserOk Leaf Leaf
           failed = parserErr (ofString "denied") (ofNumber 9)
           digest = primitive 28 bytes
           mkdir = primitive 25 (ofString "/registry/objects/47f")
           publish = primitive 33 (Fork (ofString ("/registry/objects/47f/" ++ hash ++ ".arboricx")) bytes)
           put = call "putBundle" [root, bytes]
           prefix message = parserErr (ofString message) Leaf
       forM_ ["putBundleWithHash", "putBundleWrite", "bundleTmpPath"] $ \name ->
         assertBool ("unchecked/obsolete writer still exported: " ++ name) (Map.notMember name env)
       runScriptedEffects put [(digest, parserOk (ofString hash) Leaf), (mkdir, ok), (publish, ok)]
         >>= (@?= parserOk (ofString hash) Leaf)
       runScriptedEffects put [(digest, failed)] >>= (@?= prefix "sha256Hex: denied")
       runScriptedEffects put [(digest, parserOk (ofString hash) Leaf), (mkdir, failed)]
         >>= (@?= prefix "createDirectory: denied")
       runScriptedEffects put [(digest, parserOk (ofString hash) Leaf), (mkdir, ok), (publish, failed)]
         >>= (@?= prefix "atomicWriteBytes: denied")
       forM_ [ofString "../../../secret", ofString "/etc/passwd", ofString (replicate 65 'a'), Stem Leaf] $ \bad ->
         runScriptedEffects put [(digest, parserOk bad Leaf)] >>=
           (@?= prefix "sha256Hex: expected 64 lowercase hexadecimal hash characters")
       runScriptedEffects (call "ensureStore" [root]) [(primitive 25 root, failed)]
         >>= (@?= prefix "createDirectory: denied")
       let sock = ofNumber 7
           create = primitive 70 Leaf
           bindSocket = primitive 72 (Fork sock (Fork (ofString "127.0.0.1") (ofNumber 9050)))
           listen = primitive 73 (Fork sock (ofNumber 128))
           close = primitive 71 sock
           server = call "arboricxServer" [root, ofString "127.0.0.1", ofNumber 9050]
       runScriptedEffects server [(create, failed)] >>= (@?= prefix "denied")
       forM_ [ok, failed] $ \closed -> do
         runScriptedEffects server [(create, parserOk sock Leaf), (bindSocket, failed), (close, closed)]
           >>= (@?= prefix "denied")
         runScriptedEffects server [(create, parserOk sock Leaf), (bindSocket, ok), (listen, failed), (close, closed)]
           >>= (@?= prefix "denied")
   , testCase "filesystem: initialization, binary publication, replacement and concurrent uploads" $
       withSystemTempDirectory "registry-publication" $ \dir -> do
         env <- evaluateCompilerFile "./lib/arboricx/server.tri"
         let call name = foldl apply (env Map.! name)
             rootPath = dir </> "store"
             root = ofString rootPath
             payload = BS.pack [0,255,1]
             hash = "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
             shard = rootPath </> "objects" </> "47f"
             path = shard </> (hash ++ ".arboricx")
             perms = defaultPerms { allowRead = [dir], allowWrite = [dir] }
             run action = runIO perms (Fork (ofString "tricuIO") (Fork (ofNumber 1) action))
             upload = run (call "putBundle" [root, ofBytes payload])
             expected = Right (parserOk (ofString hash) Leaf)
         run (call "ensureStore" [root]) >>= (@?= Right (parserOk Leaf Leaf))
         run (call "ensureStore" [root]) >>= (@?= Right (parserOk Leaf Leaf))
         upload >>= (@?= expected)
         BS.readFile path >>= (@?= payload)
         run (call "getBundleByHash" [root, ofString hash]) >>= (@?= Right (parserOk (ofBytes payload) Leaf))
         -- Replacement is deliberate, not write-if-absent/corrupt-winner policy.
         BS.writeFile path (BS.pack [7])
         upload >>= (@?= expected)
         BS.readFile path >>= (@?= payload)
         outputs <- forM [1,2 :: Int] $ \_ -> do
           output <- newEmptyMVar
           _ <- forkIO ((try upload :: IO (Either SomeException (Either String T))) >>= putMVar output)
           pure output
         completed <- Timeout.timeout 10000000 (mapM takeMVar outputs)
         case completed of
           Nothing -> assertFailure "concurrent registry uploads timed out"
           Just results -> forM_ results $ \result -> case result of
             Left problem -> assertFailure (show problem)
             Right value -> value @?= expected
         BS.readFile path >>= (@?= payload)
         listDirectory shard >>= (@?= [hash ++ ".arboricx"])
         listDirectory (rootPath </> "tmp") >>= (@?= [])
         -- An existing file cannot masquerade as an initialized directory.
         let blocked = dir </> "blocked"
         BS.writeFile blocked BS.empty
         result <- run (call "ensureStore" [ofString blocked])
         result @?= Right (parserErr (ofString "createDirectory: already exists") Leaf)
   ]
 
 -- Tiny source probes run through the authenticated portable compiler fixture.
 -- Force complete generated trees before applying deliberately partial host data.
 localControlTests :: TestTree
 localControlTests = testGroup "Local control construction and non-strictness"
   [ testCase "case constructs code, skips unselected work and preserves wildcard laziness" $ do
       selected <- compileLocalControl [] $ unlines
         [ "main input = case input of"
         , "  t = 23"
         , "  _ = let rec loop x = loop x in loop t" ]
       apply selected Leaf @?= ofNumber 23
       ignored <- compileLocalControl [] "main input = case input of\n  _ = 23"
       apply ignored (error "wildcard forced its subject") @?= ofNumber 23
       first <- compileLocalControl [] "main input = case input of\n  (head, _) = head\n  _ = t"
       apply first (Fork (ofNumber 23) (error "case forced an ignored sibling")) @?= ofNumber 23
   , testCase "local recursive hash worker rejects poisoned byte/tail with bounded inspection" $ do
       server <- evaluateCompilerFile "./lib/arboricx/server.tri"
       math <- evaluateCompilerFile "./lib/math/native.tri"
       function <- compileLocalControl
         [("true", Stem Leaf), ("false", Leaf),
          ("hex", server Map.! "bundleHexByte?"), ("subtract", math Map.! "subtract")] $ unlines
         [ "main hash = (let rec"
         , "  walk [] 0 = true"
         , "  walk _ 0 = false"
         , "  walk [byte | rest] remaining = case (hex byte) of"
         , "    ^true = walk rest (subtract remaining 1)"
         , "    _ = false"
         , "  walk _ _ = false"
         , "  in walk hash 64)" ]
       apply function (ofString (replicate 64 'a')) @?= Stem Leaf
       let oversized = foldr Fork
             (Fork (error "local worker inspected byte 65") (error "local worker inspected suffix"))
             (replicate 64 (ofNumber 97))
           malformedByte = foldr Fork
             (Fork (error "local worker inspected extra bit") (error "local worker inspected numeral suffix"))
             [Stem Leaf, Leaf, Leaf, Leaf, Leaf, Stem Leaf, Stem Leaf]
       apply function oversized @?= Leaf
       apply function (Fork malformedByte (error "local worker continued after malformed byte")) @?= Leaf
   ]
 
 compileLocalControl :: [(String, T)] -> String -> IO T
 compileLocalControl bindings source = do
   unit <- evaluateCompilerFile "./lib/source/unit.tri"
   let external = ofList [Fork (ofString name) value | (name,value) <- bindings]
       answer = apply (apply (unit Map.! "compileStableModuleDefinitions") external) (ofString source)
       forceTree Leaf = ()
       forceTree (Stem child) = forceTree child
       forceTree (Fork left right) = forceTree left `seq` forceTree right
   case answer of
     Fork (Stem Leaf) (Fork (Fork (Fork name function) Leaf) Leaf) -> do
       name @?= ofString "main"
       evaluate (forceTree function)
       pure function
     other -> assertFailure ("local control compilation failed: " ++ show other) >> pure Leaf
 
 httpPipelineTests :: TestTree
 httpPipelineTests = testCase "HTTP reference pipeline: buffers, EOF, receive errors and cleanup" $ do
   let env = fixtureExports "http"
       call name = foldl apply (env Map.! name)
       sock = ofNumber 7
       recv size = pairT (ofNumber 76) (pairT sock (ofNumber size))
       send bytes = pairT (ofNumber 77) (pairT sock (ofString bytes))
       close = pairT (ofNumber 71) sock
       ok = parserOk Leaf Leaf
       failed = parserErr (ofString "broken") Leaf
       bad message = parserErr (ofNumber 400) (ofString message)
   call "statusPhrase" [ofNumber 413] @?= ofString "Content Too Large"
   forM_ [(0, "abc", "", "abc"), (2, "abc", "ab", "c")] $ \(count, input, body, rest) ->
     runScriptedEffects (call "readBodyExact" [sock, ofNumber count, ofString input]) [] >>=
       (@?= parserOk (ofString body) (ofString rest))
   runScriptedEffects (call "readBodyExact" [sock, ofNumber 3, ofString "a"])
     [(recv 1, parserOk (ofString "b") Leaf), (recv 1, parserOk (ofString "c") Leaf)] >>=
       (@?= parserOk (ofString "abc") Leaf)
   -- Exact-length invariant, including short reads and oversized initial buffers.
   forM_ [0..8 :: Int] $ \count ->
     forM_ [0..count+2] $ \initialSize -> do
       let bytes = "AbCdEfGhIjK"
           initial = take initialSize bytes
           chunks = take (count - initialSize) (drop initialSize bytes)
           script = [(recv 1, parserOk (ofString [byte]) Leaf) | byte <- chunks]
       runScriptedEffects (call "readBodyExact" [sock, ofNumber (fromIntegral count), ofString initial]) script >>=
         (@?= parserOk (ofString (take count bytes)) (ofString (drop count initial)))
   runScriptedEffects (call "readBodyExact" [sock, ofNumber 3, ofString "a"])
     [(recv 1, parserOk Leaf Leaf)] >>= (@?= bad "Unexpected end of request body\n")
   runScriptedEffects (call "readBodyExact" [sock, ofNumber 3, Leaf])
     [(recv 1, failed)] >>= (@?= bad "recv failed while reading body: broken")
   runScriptedEffects (call "recvUntilMax" [sock, ofString "\r\n\r\n", ofNumber 20])
     [(recv 4096, parserOk (ofString "abc") Leaf), (recv 4096, failed)] >>=
       (@?= parserErr (ofNumber 400) (ofString "abc"))
   let message = "Request Header Fields Too Large\n"
       response431 = "HTTP/1.1 431 Request Header Fields Too Large\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: " ++
         show (length message) ++ "\r\nConnection: close\r\n\r\n" ++ message
   runScriptedEffects (call "httpHandleReceived" [Leaf, sock, parserErr (ofNumber 431) (ofString "raw")])
     [(send response431, ok), (close, ok)] >>= (@?= ok)
   forM_ [ok, failed, parserErr (ofString "broken") (ofString "context")] $ \sent ->
     forM_ [ok, failed] $ \closed ->
       runScriptedEffects (call "respondAndClose" [sock, ofString "response"])
         [(send "response", sent), (close, closed)] >>= (@?= sent)
   -- Host-side negative controls for missing, wrong and leftover effects.
   forM_ [(recv 1, []), (recv 1, [(close, ok)]), (pairT (ofNumber 0) Leaf, [(close, ok)])] $ \(action, script) -> do
     observed <- try (runScriptedEffects action script) :: IO (Either SomeException T)
     case observed of
       Left _ -> pure ()
       Right _ -> assertFailure "HTTP effect interpreter accepted a mismatched script"
 
 containsAll :: String -> [String] -> Assertion
 containsAll text needles =
   forM_ needles $ \needle ->
     assertBool ("expected " ++ show needle ++ " in: " ++ text) (needle `isInfixOf` text)
 
 
 ioOkResult :: T -> T
 ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
 
 ioErrResult :: String -> T
 ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)