commit 52c81f51df59e3897e6a8c65478438d376a1f633
parent 78b6c3ae61805a259764418d7f33187f00ed19a1
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 17:53:49 -0500
Compile conformance wrappers with the retained portable compiler
Diffstat:
4 files changed, 166 insertions(+), 80 deletions(-)
diff --git a/docs/validation.md b/docs/validation.md
@@ -162,8 +162,14 @@ independent of the compiled implementations. Mixed-cohort reuse verification in
artifact invocation does not remove that separate provenance dependency.
This avoids recompiling libraries on every unit run without silently treating old
-executable trees as new source. Ordinary test wrappers may use the Haskell
-frontend; production module resolution does not fall back to those wrappers.
+executable trees as new source. Compiler conformance wrappers use
+`test/PortableTestCompiler.hs`: the retained stable unit compiler receives explicit
+published fixture imports and a definition body. This test-only header adapter is
+not native module resolution; it returns local definitions, not imported names.
+Preparation has a 30-second deadline and checks Result/list/name structure without
+forcing unused definition values. Invalid source and import shadowing fail without
+fallback. Remaining recovery-specific tests still use the historical frontend;
+production module resolution never does.
```sh
# Reference-source/bundle fingerprints only; no working-tree freshness claim.
diff --git a/test/PortableTestCompiler.hs b/test/PortableTestCompiler.hs
@@ -0,0 +1,61 @@
+-- Small test-only adapter for retained compiler fixtures. Not a module resolver:
+-- imports select published fixture interfaces, and the caller selects definitions
+-- to inspect/pack. No recursive source loading, injected kernels or fallback.
+module PortableTestCompiler (compileFixtureDefinitions, compileFixtureFile) where
+
+import Runtime
+import ReferenceFixtures (compiledLibraries, fixtureExports)
+import SupportFixture (readTestSource)
+import Control.Exception (evaluate)
+import Control.Monad (foldM)
+import Data.List (isPrefixOf)
+import qualified Data.Map as Map
+import System.Timeout (timeout)
+import Text.Read (readMaybe)
+
+-- Preserve lazy definition values (including unused divergent bodies). Only the
+-- Result/list/name spine is validated, under a fixed preparation deadline.
+compileFixtureDefinitions :: Env -> String -> IO Env
+compileFixtureDefinitions external source = do
+ prepared <- timeout (30 * 1000000) $ do
+ let bindings = ofList [Fork (ofString name) value | (name, value) <- Map.toList external]
+ answer = foldl apply (fixtureExports "source.unit" Map.! "compileStableModuleDefinitions")
+ [bindings, ofString source]
+ decode Leaf env = pure env
+ decode (Fork (Fork name value) rest) env = do
+ key <- either (fail . ("invalid compiled name: " ++)) pure (toString name)
+ if Map.member key env
+ then fail ("duplicate compiled definition: " ++ key)
+ else decode rest (Map.insert key value env)
+ decode _ _ = fail "malformed compiled definition list"
+ case answer of
+ Fork (Stem Leaf) (Fork definitions Leaf) -> decode definitions Map.empty >>= evaluate
+ other -> fail ("portable test compilation failed: " ++ show other)
+ maybe (fail "portable test compilation exceeded 30 seconds") pure prepared
+
+compileFixtureFile :: FilePath -> IO Env
+compileFixtureFile path = do
+ source <- readTestSource path
+ let rows = map words (lines source)
+ legacyFor alias = case [legacy | (legacy, mapped, _) <- fst compiledLibraries, mapped == alias] of
+ [legacy] -> pure legacy
+ _ -> fail ("unknown fixture import: " ++ alias)
+ select legacy namespace =
+ let exports = fixtureExports legacy
+ in pure $ maybe exports (\prefix -> Map.mapKeys ((prefix ++ ".") ++) exports) namespace
+ imported row = case row of
+ ["!import", encoded, namespace] | Just legacy <- readMaybe encoded ->
+ select legacy (if namespace == "!Local" then Nothing else Just namespace)
+ ["!import", alias, "*"] -> legacyFor alias >>= \legacy -> select legacy Nothing
+ ["!import", alias, "as", namespace] -> legacyFor alias >>= \legacy -> select legacy (Just namespace)
+ ["!import", alias] -> legacyFor alias >>= \legacy -> select legacy (Just alias)
+ _ -> fail ("unsupported fixture test import: " ++ unwords row)
+ merge env row = do
+ next <- imported row
+ if Map.null (Map.intersection env next)
+ then pure (Map.union env next)
+ else fail "overlapping fixture test imports"
+ body = unlines [line | line <- lines source,
+ not (any (`isPrefixOf` line) ["!import ", "!export ", "!source "])]
+ external <- foldM merge Map.empty [row | row@(first : _) <- rows, first == "!import"]
+ compileFixtureDefinitions external body
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -3,6 +3,7 @@ module Main where
import Eval
import qualified ParserValueTests
import qualified LibraryValueTests
+import PortableTestCompiler (compileFixtureFile, compileFixtureDefinitions)
import ReferenceFixtures
import PackageTests (packageTests)
import InteractionInspectionTests (interactionInspectionTests)
@@ -3270,7 +3271,7 @@ locatedLexerTests = testGroup "Located character-scanning library"
-- --------------------------------------------------------------------------
gateLexerEnv :: Env
-gateLexerEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/lexer.tri"
+gateLexerEnv = fixtureExports "source.lexer"
{-# NOINLINE gateLexerEnv #-}
gatePosition :: Integer -> Integer -> Integer -> T
@@ -3445,7 +3446,7 @@ gateLexerTests = testGroup "Feasibility-gate source lexer"
]
where
check input expected =
- result (evalTricu gateLexerEnv (parseTricu ("lexGateSource " ++ show input))) @?= expected
+ apply (gateLexerEnv Map.! "lexGateSource") (ofString input) @?= expected
-- --------------------------------------------------------------------------
-- Single-expression feasibility-gate surface parser
@@ -3491,11 +3492,7 @@ evaluateCompilerFile path =
case [legacy | (legacy, _, source) <- fst compiledLibraries,
source == maybe path id (stripPrefix "./" path)] of
[legacy] -> compiledModuleEnv legacy
- [] -> do
- text <- readTestSource path
- imported <- compilerTestImports text
- let body = unlines [line | line <- lines text, not (any (`isPrefixOf` line) ["!import ", "!export ", "!source "])]
- pure (evalTricu (injectKernel imported) (parseTricu body))
+ [] -> compileFixtureFile path
_ -> error "ambiguous compiler fixture module"
-- Explicit unit-test support bridge for portable libraries.
@@ -3595,8 +3592,8 @@ recoveryFoundationBody name = do
unless (actual == headers) $ error "unsupported recovery reference foundation headers"
pure (unlines body)
--- Only ordinary test-wrapper lambdas are host-compiled; library payloads come
--- from the checked self-built fixture. Native packing remains a host mechanism.
+-- 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
@@ -3682,6 +3679,27 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
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
@@ -3858,7 +3876,7 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
]
gateParserEnv :: Env
-gateParserEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/parser.tri"
+gateParserEnv = fixtureExports "source.parser"
{-# NOINLINE gateParserEnv #-}
gateAst :: Integer -> T -> T -> T -> T
@@ -4056,14 +4074,14 @@ gateParserTests = testGroup "Feasibility-gate source parser"
]
where
check input expected =
- result (evalTricu gateParserEnv (parseTricu ("parseGateSource " ++ show input))) @?= expected
+ apply (gateParserEnv Map.! "parseGateSource") (ofString input) @?= expected
-- --------------------------------------------------------------------------
-- Program-level feasibility-gate parsing (definitions and final expression)
-- --------------------------------------------------------------------------
equationHelperEnv :: Env
-equationHelperEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/equations.tri"
+equationHelperEnv = fixtureExports "source.equations"
{-# NOINLINE equationHelperEnv #-}
equationHelperTests :: TestTree
@@ -4095,7 +4113,7 @@ equationHelperTests = testGroup "Equation helper pattern adoption"
, 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 (allTestLibsEnv Map.! "fst")
+ apply (fixtureExports "base" Map.! "fst")
(call "sourceEquationList" [Leaf, Fork (ofNumber 23)
(error "unused suffix demanded")]) @?= ofNumber 23
]
@@ -4124,7 +4142,7 @@ equationHelperTests = testGroup "Equation helper pattern adoption"
list value = call "sourceEquationList" [value, nil]
gateProgramEnv :: Env
-gateProgramEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/program.tri"
+gateProgramEnv = fixtureExports "source.program"
{-# NOINLINE gateProgramEnv #-}
gateProgramTests :: TestTree
@@ -4171,15 +4189,14 @@ gateProgramTests = testGroup "Feasibility-gate program parser"
in portableReply True
(pairT (ofList [pairT name body]) (Stem expression)) Leaf True False
check input expected =
- result (evalTricu gateProgramEnv
- (parseTricu ("parseGateProgram " ++ show input))) @?= expected
+ apply (gateProgramEnv Map.! "parseGateProgram") (ofString input) @?= expected
-- --------------------------------------------------------------------------
-- Portable, stable dependency ordering and cycle witnesses
-- --------------------------------------------------------------------------
sourceGraphEnv :: Env
-sourceGraphEnv = unsafePerformIO $ evaluateCompilerFile "./lib/graph.tri"
+sourceGraphEnv = fixtureExports "graph"
{-# NOINLINE sourceGraphEnv #-}
sourceGraphTests :: TestTree
@@ -4189,23 +4206,24 @@ sourceGraphTests = testGroup "Source dependency graph"
Map.lookup "main" env @?= Just
(parserOk (ofList (map ofString ["leaf", "inner", "outer"])) Leaf)
, testCase "sort preserves source order among simultaneously ready nodes" $
- check "[(pair \"b\" []) (pair \"a\" [])]"
+ check [("b", []), ("a", [])]
(parserOk (ofList [ofString "b", ofString "a"]) Leaf)
, testCase "cycle witness is in the cycle, not just a dependent" $
- check "[(pair \"outside\" [\"inside\"]) (pair \"inside\" [\"last\"]) (pair \"last\" [\"inside\"])]"
+ check [("outside", ["inside"]), ("inside", ["last"]), ("last", ["inside"])]
(parserErr (ofString "inside") Leaf)
]
where
check entries expected =
- result (evalTricu sourceGraphEnv
- (parseTricu ("graphSort " ++ 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 = unsafePerformIO $ evaluateCompilerFile "./lib/source/order.tri"
+gateOrderingEnv = fixtureExports "source.order"
{-# NOINLINE gateOrderingEnv #-}
gateOrderingTests :: TestTree
@@ -4216,16 +4234,16 @@ gateOrderingTests = testGroup "Feasibility-gate definition ordering"
Map.lookup "main" env @?= Just (parserOk
(ofList [ofString "f", ofString "main"]) Leaf)
, testCase "unused definitions still have their names checked" $
- check "[]" "main = t\nbroken = u" (parserErr
+ 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 "[(pair \"x\" t)]" "x = t\nf x = x" (parserOk
+ 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 "[]" "f = f" (parserErr
+ check Leaf "f = f" (parserErr
(portableDiagnostic (ofNumber 31) (ofString "acyclic")
(ofString "f") (gatePosition 1 1 0)
(ofList [ofString "f"])) Leaf)
@@ -4234,12 +4252,12 @@ gateOrderingTests = testGroup "Feasibility-gate definition ordering"
(gatePosition 2 1 6) (gatePosition 2 2 7)
body = gateAst 1 Leaf
(gatePosition 2 5 10) (gatePosition 2 6 11)
- in check "[]" "f = t\nf = t" (parserErr
+ 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 "[]" "f = t\nu" (parserErr
+ check Leaf "f = t\nu" (parserErr
(portableDiagnostic (ofNumber 20) (ofString "u") Leaf
(gatePosition 2 1 6) Leaf)
(gateAst 2 (ofString "u")
@@ -4247,8 +4265,7 @@ gateOrderingTests = testGroup "Feasibility-gate definition ordering"
]
where
check environment source expected =
- result (evalTricu gateOrderingEnv
- (parseTricu ("orderGateSource " ++ environment ++ " " ++ show source)))
+ foldl apply (gateOrderingEnv Map.! "orderGateSource") [environment, ofString source]
@?= expected
-- --------------------------------------------------------------------------
@@ -4536,17 +4553,22 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
env <- evaluateCompilerFile
"./test/sourcePublicCompiler.tri"
Map.member "matchesSource" env @?= True
- let compile environment source = result (evalTricu
- (Map.union env allTestLibsEnv)
- (parseTricu ("compileSource " ++ environment ++ " " ++ show source)))
- compile "[]" "main = value\nvalue = t" @?=
- parserOk (pairT Leaf (ofList
- [pairT (ofString "value") Leaf, pairT (ofString "main") Leaf])) Leaf
- compile "[(pair \"host\" (t t))]" "host" @?=
- parserOk (pairT (Stem Leaf) Leaf) Leaf
- compile "[]" "helper = t" @?=
- parserErr (portableDiagnostic (ofNumber 32)
- (ofString "main") Leaf Leaf Leaf) Leaf
+ 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"
@@ -4828,7 +4850,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
-- --------------------------------------------------------------------------
gateResolveEnv :: Env
-gateResolveEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/resolve.tri"
+gateResolveEnv = fixtureExports "source.resolve"
{-# NOINLINE gateResolveEnv #-}
gateCore :: Integer -> T -> T -> T -> T
@@ -4843,12 +4865,12 @@ gateResolutionTests = testGroup "Feasibility-gate resolution"
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 "[]" "x : x" (parserOk
+ 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 "[]" "x : y : x" (parserOk
+ 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
@@ -4857,7 +4879,7 @@ gateResolutionTests = testGroup "Feasibility-gate resolution"
(gatePosition 1 14 13) (gatePosition 1 15 14)
scoped = gateCore 4 bound
(gatePosition 1 1 0) (gatePosition 1 15 14)
- in check "[]" "let x = t in x" (parserOk
+ 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" $
@@ -4865,24 +4887,24 @@ gateResolutionTests = testGroup "Feasibility-gate resolution"
(gatePosition 1 6 5) (gatePosition 1 7 6)
argument = gateCore 6 (ofNumber 2)
(gatePosition 1 1 0) (gatePosition 1 2 1)
- in check "[(pair \"f\" (t t))]" "2 |> f" (parserOk
+ 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 "[]" "42" (parserOk
+ 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 "[]" "\"hi\"" (parserOk
+ 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 "[]" "[t 2]" (parserOk
+ 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 "[]" "[u]" (parserErr
+ check Leaf "[u]" (parserErr
(portableDiagnostic (ofNumber 20) (ofString "u") Leaf
(gatePosition 1 2 1) Leaf)
(gateAst 2 (ofString "u")
@@ -4891,37 +4913,36 @@ gateResolutionTests = testGroup "Feasibility-gate resolution"
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 "[(pair \"f\" (t t))]" "f t" (parserOk
+ 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 "[(pair \"x\" (t t))]" "x : x" (parserOk
+ 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 "[]" "u" (parserErr
+ 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 "[]" "(t)" (parserOk
+ check Leaf "(t)" (parserOk
(gateCore 1 Leaf (gatePosition 1 1 0) (gatePosition 1 4 3)) Leaf)
]
where
check environment input expected =
- result (evalTricu gateResolveEnv
- (parseTricu ("resolveGateSource " ++ environment ++ " " ++ show input))) @?= expected
+ foldl apply (gateResolveEnv Map.! "resolveGateSource") [environment, ofString input] @?= expected
-- --------------------------------------------------------------------------
-- Reference S/K/I compiler for the feasibility gate
-- --------------------------------------------------------------------------
gateCompileEnv :: Env
-gateCompileEnv = unsafePerformIO $ evaluateCompilerFile "./lib/source/compile.tri"
+gateCompileEnv = fixtureExports "source.compile"
{-# NOINLINE gateCompileEnv #-}
gateCompileBaseEnv :: Env
-gateCompileBaseEnv = unsafePerformIO $ recoveryFoundationEnv "base"
+gateCompileBaseEnv = fixtureExports "base"
{-# NOINLINE gateCompileBaseEnv #-}
gateCompilationTests :: TestTree
@@ -5065,15 +5086,13 @@ gateCompilationTests = testGroup "Feasibility-gate source compiler"
, 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 var = "sourceTermVariable 0 t"
- leaf = "sourceTermLiteral t t"
- terms = [ var, leaf
- , "sourceTermApply (" ++ var ++ ") (" ++ leaf ++ ") t"
- , "sourceTermApply (" ++ leaf ++ ") (" ++ var ++ ") t"
- , "sourceTermApply (" ++ var ++ ") (" ++ var ++ ") t"
- ]
- compiled method term = result (evalTricu gateCompileEnv (parseTricu
- ("sourceRunTerm (" ++ method ++ " (" ++ term ++ "))")))
+ 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
@@ -5084,10 +5103,10 @@ gateCompilationTests = testGroup "Feasibility-gate source compiler"
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 = result (evalTricu gateCompileEnv (parseTricu
- ("lazyResult (diagnostic rest : err diagnostic rest) "
- ++ "(core rest : " ++ method ++ " core) "
- ++ "(resolveGateSource [] " ++ show source ++ ")")))
+ 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)
@@ -5110,15 +5129,15 @@ gateCompilationTests = testGroup "Feasibility-gate source compiler"
, 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" $
- let input = "compileGateSource [(pair \"f\" (t t))] \"f t\""
- in result (evalTricu gateCompileEnv (parseTricu input)) @?=
+ 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"
- input = "compileGateSource [(pair \"y\" y) (pair \"triage\" triage)] "
- ++ show source
- env = evalTricu (Map.union gateCompileEnv gateCompileBaseEnv) (parseTricu input)
- case result env of
+ 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
@@ -5134,8 +5153,7 @@ gateCompilationTests = testGroup "Feasibility-gate source compiler"
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 = result (evalTricu gateCompileEnv
- (parseTricu ("compileGateSource [] " ++ show input)))
+ 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
diff --git a/tricu.cabal b/tricu.cabal
@@ -208,4 +208,5 @@ test-suite tricu-tests
SupportFixture
LibraryValueTests
ParserValueTests
+ PortableTestCompiler
ReferenceFixtures
