commit cf7839ee92c469c284a7adf7ad192f072aa205f2
parent 98faf1318937a356e86868f4d1c16ed1dd6ae954
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 18:55:08 -0500
Migrate remaining behavior tests and remove recovery test bridges
Diffstat:
7 files changed, 1121 insertions(+), 1359 deletions(-)
diff --git a/docs/validation.md b/docs/validation.md
@@ -178,8 +178,10 @@ published fixture imports and a definition body. This test-only header adapter i
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.
+fallback. Useful library program tests use the same bounded portable compilation route
+with an explicit published prelude. `div` and `mod` zero-divisor expectations
+follow the checked numeric contract, not the retired host cohort's zero result.
+No test uses the historical frontend or reconstructs its ambient import scopes.
```sh
# Reference-source/bundle fingerprints only; no working-tree freshness claim.
diff --git a/test/InteractionInspectionTests.hs b/test/InteractionInspectionTests.hs
@@ -1,7 +1,7 @@
module InteractionInspectionTests (interactionInspectionTests) where
import InteractionInspection
-import Research (T(..), ofNumber, ofString, ofList)
+import Runtime (T(..), ofNumber, ofString, ofList)
import qualified Wire as W
import qualified Data.Sequence as S
import qualified Data.Text as Text
diff --git a/test/LibraryProgramTests.hs b/test/LibraryProgramTests.hs
@@ -0,0 +1,1005 @@
+-- Behavioral expectations survive the retirement of the historical frontend.
+-- Compile tiny test programs against published portable library interfaces only.
+module LibraryProgramTests (maybeTests, providedLibraries, contractsTests, arithmetic) where
+
+import Runtime
+import ReferenceFixtures (fixtureExports)
+import PortableTestCompiler (compileFixtureDefinitions)
+import qualified Data.Map as Map
+import Test.Tasty
+import Test.Tasty.HUnit
+
+runExpression :: String -> IO T
+runExpression expression = runProgram ("main = " ++ expression)
+
+runProgram :: String -> IO T
+runProgram source = do
+ env <- compileFixtureDefinitions (fixtureExports "prelude") source
+ maybe (assertFailure "library test program has no main" >> pure Leaf) pure (Map.lookup "main" env)
+
+trueT, falseT, nothingT :: T
+trueT = Stem Leaf
+falseT = Leaf
+nothingT = Leaf
+justT :: T -> T
+justT = Stem
+pairT :: T -> T -> T
+pairT = Fork
+
+maybeTests :: TestTree
+maybeTests = testGroup "Maybe Tests"
+ [ testCase "nothing is Leaf" $ do
+ let input = "nothing"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "just wraps value in Stem" $ do
+ let input = "just (t t)"
+ env <- runExpression input
+ env @?= Stem (Stem Leaf)
+
+ , testCase "matchMaybe on nothing returns default" $ do
+ let input = "matchMaybe \"empty\" (x : x) nothing"
+ env <- runExpression input
+ env @?= ofString "empty"
+
+ , testCase "matchMaybe on just extracts value" $ do
+ let input = "matchMaybe \"empty\" (x : x) (just (t t))"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+ , testCase "maybe applies f inside just" $ do
+ let input = "maybe 0 (x : succ x) (just 5)"
+ env <- runExpression input
+ env @?= ofNumber 6
+
+ , testCase "maybe returns default on nothing" $ do
+ let input = "maybe 0 (x : succ x) nothing"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "maybeMap transforms just value" $ do
+ let input = "maybeMap (x : succ x) (just 3)"
+ env <- runExpression input
+ env @?= justT (ofNumber 4)
+
+ , testCase "maybeMap returns nothing on nothing" $ do
+ let input = "maybeMap (x : succ x) nothing"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "maybeBind flattens just" $ do
+ let input = "maybeBind (just 3) (x : just (succ x))"
+ env <- runExpression input
+ env @?= justT (ofNumber 4)
+
+ , testCase "maybeBind returns nothing on nothing" $ do
+ let input = "maybeBind nothing (x : just (succ x))"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "maybeOr returns just value" $ do
+ let input = "maybeOr 99 (just 5)"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "maybeOr returns default on nothing" $ do
+ let input = "maybeOr 99 nothing"
+ env <- runExpression input
+ env @?= ofNumber 99
+
+ , testCase "maybe? on just is true" $ do
+ let input = "maybe? (just t)"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "maybe? on nothing is false" $ do
+ let input = "maybe? nothing"
+ env <- runExpression input
+ env @?= falseT
+ ]
+
+providedLibraries :: TestTree
+providedLibraries = testGroup "Library Tests"
+ [ testCase "Triage test Leaf" $ do
+ let input = "test t"
+ value <- runExpression input
+ let env = decodeResult value
+ env @?= "\"Leaf\""
+
+ , testCase "Triage test (Stem Leaf)" $ do
+ let input = "test (t t)"
+ value <- runExpression input
+ let env = decodeResult value
+ env @?= "\"Stem\""
+
+ , testCase "Triage test (Fork Leaf Leaf)" $ do
+ let input = "test (t t t)"
+ value <- runExpression input
+ let env = decodeResult value
+ env @?= "\"Fork\""
+
+ , testCase "Boolean NOT: true" $ do
+ let input = "not? true"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "Boolean NOT: false" $ do
+ let input = "not? false"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+
+ , testCase "Boolean AND TF" $ do
+ let input = "and? (t t) (t)"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "Boolean AND FT" $ do
+ let input = "and? (t) (t t)"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "Boolean AND FF" $ do
+ let input = "and? (t) (t)"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "Boolean AND TT" $ do
+ let input = "and? (t t) (t t)"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+ , testCase "List head" $ do
+ let input = "head [(t) (t t) (t t t)]"
+ env <- runExpression input
+ env @?= Leaf
+
+ , testCase "List tail" $ do
+ let input = "head (tail (tail [(t) (t t) (t t t)]))"
+ env <- runExpression input
+ env @?= Fork Leaf Leaf
+
+ , testCase "List map" $ do
+ let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))"
+ env <- runExpression input
+ env @?= Fork Leaf Leaf
+
+ , testCase "Empty list check" $ do
+ let input = "emptyList? []"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+ , testCase "Non-empty list check" $ do
+ let input = "not? (emptyList? [(1) (2) (3)])"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+ , testCase "Concatenate strings" $ do
+ let input = "append \"Hello, \" \"world!\""
+ value <- runExpression input
+ let env = decodeResult value
+ env @?= "\"Hello, world!\""
+
+ , testCase "Verifying Equality" $ do
+ let input = "equal? (t t t) (t t t)"
+ env <- runExpression input
+ env @?= Stem Leaf
+
+ , testCase "headMaybe on empty list" $ do
+ let input = "headMaybe []"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "headMaybe on non-empty list" $ do
+ let input = "headMaybe [(t) (t t)]"
+ env <- runExpression input
+ env @?= justT Leaf
+
+ , testCase "lastMaybe on empty list" $ do
+ let input = "lastMaybe []"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "lastMaybe on single element" $ do
+ let input = "lastMaybe [(t t)]"
+ env <- runExpression input
+ env @?= justT (Stem Leaf)
+
+ , testCase "lastMaybe on multi-element list" $ do
+ let input = "lastMaybe [(t) (t t) (t t t)]"
+ env <- runExpression input
+ env @?= justT (Fork Leaf Leaf)
+
+ , testCase "nthMaybe first element" $ do
+ let input = "nthMaybe 0 [(t) (t t)]"
+ env <- runExpression input
+ env @?= justT Leaf
+
+ , testCase "nthMaybe middle element" $ do
+ let input = "nthMaybe 1 [(t) (t t) (t t t)]"
+ env <- runExpression input
+ env @?= justT (Stem Leaf)
+
+ , testCase "nthMaybe out of bounds" $ do
+ let input = "nthMaybe 5 [(t) (t t)]"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "reverse empty list" $ do
+ let input = "reverse []"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "reverse non-empty list" $ do
+ let input = "reverse [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 3, ofNumber 2, ofNumber 1]
+
+ , testCase "take 0 any list = empty" $ do
+ let input = "take 0 [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "take 2 [1,2,3] = [1,2]" $ do
+ let input = "take 2 [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 1, ofNumber 2]
+
+ , testCase "take overlong returns whole list" $ do
+ let input = "take 5 [(1) (2)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 1, ofNumber 2]
+
+ , testCase "drop 0 any list = list" $ do
+ let input = "drop 0 [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 1, ofNumber 2, ofNumber 3]
+
+ , testCase "drop 2 [1,2,3] = [3]" $ do
+ let input = "drop 2 [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 3]
+
+ , testCase "drop overlong returns empty" $ do
+ let input = "drop 5 [(1) (2)]"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "splitAt 0 [1,2] = pair [] [1,2]" $ do
+ let input = "splitAt 0 [(1) (2)]"
+ env <- runExpression input
+ env @?= pairT (ofList []) (ofList [ofNumber 1, ofNumber 2])
+
+ , testCase "splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
+ let input = "splitAt 2 [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [ofNumber 3])
+
+ , testCase "splitAt overlong = pair [1,2] []" $ do
+ let input = "splitAt 5 [(1) (2)]"
+ env <- runExpression input
+ env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [])
+
+ , testCase "concatMap on empty list" $ do
+ let input = "concatMap (x : [(x) (x)]) []"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "concatMap doubles elements" $ do
+ let input = "concatMap (x : [(x) (x)]) [(1) (2)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 1, ofNumber 1, ofNumber 2, ofNumber 2]
+
+ , testCase "find on empty list" $ do
+ let input = "find (x : equal? x 2) []"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "find finds element" $ do
+ let input = "find (x : equal? x 2) [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= justT (ofNumber 2)
+
+ , testCase "find missing element" $ do
+ let input = "find (x : equal? x 9) [(1) (2) (3)]"
+ env <- runExpression input
+ env @?= nothingT
+
+ , testCase "partition empty list" $ do
+ let input = "partition (x : equal? x 2) []"
+ env <- runExpression input
+ env @?= pairT (ofList []) (ofList [])
+
+ , testCase "partition splits list" $ do
+ let input = "partition (x : lt? 2 x) [(1) (2) (3) (4)]"
+ env <- runExpression input
+ env @?= pairT (ofList [ofNumber 3, ofNumber 4]) (ofList [ofNumber 1, ofNumber 2])
+
+ , testCase "zipWith on empty lists" $ do
+ let input = "zipWith add [] []"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "zipWith adds pairwise" $ do
+ let input = "zipWith add [(1) (2)] [(10) (20)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 11, ofNumber 22]
+
+ , testCase "zipWith truncates to shorter list" $ do
+ let input = "zipWith add [(1) (2)] [(10)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 11]
+
+ , testCase "strLength" $ do
+ let input = "strLength \"hello\""
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "strAppend" $ do
+ let input = "strAppend \"hello\" \" world\""
+ env <- runExpression input
+ env @?= ofString "hello world"
+
+ , testCase "equal? equal strings" $ do
+ let input = "equal? \"abc\" \"abc\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "equal? different strings" $ do
+ let input = "equal? \"abc\" \"def\""
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "strEmpty? on empty" $ do
+ let input = "strEmpty? \"\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "strEmpty? on non-empty" $ do
+ let input = "strEmpty? \"a\""
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "startsWith? prefix matches" $ do
+ let input = "startsWith? \"he\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "startsWith? prefix too long" $ do
+ let input = "startsWith? \"hello\" \"he\""
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "startsWith? empty prefix" $ do
+ let input = "startsWith? \"\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "endsWith? suffix matches" $ do
+ let input = "endsWith? \"lo\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "endsWith? suffix too long" $ do
+ let input = "endsWith? \"hello\" \"lo\""
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "endsWith? empty suffix" $ do
+ let input = "endsWith? \"\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "contains? substring found" $ do
+ let input = "contains? \"ell\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "contains? substring missing" $ do
+ let input = "contains? \"xyz\" \"hello\""
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "contains? empty needle" $ do
+ let input = "contains? \"\" \"hello\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "lines splits on newline" $ do
+ let input = "lines \"a\\nb\\nc\""
+ env <- runExpression input
+ env @?= ofList [ofString "a", ofString "b", ofString "c"]
+
+ , testCase "lines single line" $ do
+ let input = "lines \"hello\""
+ env <- runExpression input
+ env @?= ofList [ofString "hello"]
+
+ , testCase "lines empty string" $ do
+ let input = "lines \"\""
+ env <- runExpression input
+ env @?= ofList [ofString ""]
+
+ , testCase "lines trailing newline" $ do
+ let input = "lines \"a\\n\""
+ env <- runExpression input
+ env @?= ofList [ofString "a", ofString ""]
+
+ , testCase "unlines joins with newline" $ do
+ let input = "unlines [(\"a\") (\"b\")]"
+ env <- runExpression input
+ env @?= ofString "a\nb\n"
+
+ , testCase "unlines empty list" $ do
+ let input = "unlines []"
+ env <- runExpression input
+ env @?= ofString ""
+
+ , testCase "words splits on space" $ do
+ let input = "words \"hello world\""
+ env <- runExpression input
+ env @?= ofList [ofString "hello", ofString "world"]
+
+ , testCase "words empty string" $ do
+ let input = "words \"\""
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "words multiple spaces" $ do
+ let input = "words \" hello world \""
+ env <- runExpression input
+ env @?= ofList [ofString "hello", ofString "world"]
+
+ , testCase "unwords joins with space" $ do
+ let input = "unwords [(\"hello\") (\"world\")]"
+ env <- runExpression input
+ env @?= ofString "hello world"
+
+ , testCase "unwords single word" $ do
+ let input = "unwords [(\"hello\")]"
+ env <- runExpression input
+ env @?= ofString "hello"
+
+ , testCase "unwords empty list" $ do
+ let input = "unwords []"
+ env <- runExpression input
+ env @?= ofString ""
+
+ , testCase "intercalate joins fields" $ do
+ let input = "intercalate \", \" [(\"a\") (\"b\") (\"c\")]"
+ env <- runExpression input
+ env @?= ofString "a, b, c"
+
+ , testCase "intercalate leaves a lone field alone" $ do
+ let input = "intercalate \", \" [(\"a\")]"
+ env <- runExpression input
+ env @?= ofString "a"
+
+ , testCase "intercalate empty list" $ do
+ let input = "intercalate \", \" []"
+ env <- runExpression input
+ env @?= ofString ""
+
+ , testCase "joinSuffix terminates every field" $ do
+ let input = "joinSuffix \"-\" [(\"a\") (\"b\")]"
+ env <- runExpression input
+ env @?= ofString "a-b-"
+
+ , testCase "splitOnByte splits on a byte" $ do
+ let input = "splitOnByte 58 \"a:b:c\""
+ env <- runExpression input
+ env @?= ofList [ofString "a", ofString "b", ofString "c"]
+
+ , testCase "splitOnByte keeps empty fields" $ do
+ let input = "splitOnByte 58 \"a::b\""
+ env <- runExpression input
+ env @?= ofList [ofString "a", ofString "", ofString "b"]
+
+ , testCase "splitOnByte trailing separator leaves an empty field" $ do
+ let input = "splitOnByte 58 \"a:\""
+ env <- runExpression input
+ env @?= ofList [ofString "a", ofString ""]
+
+ , testCase "splitOnByte without a match" $ do
+ let input = "splitOnByte 58 \"abc\""
+ env <- runExpression input
+ env @?= ofList [ofString "abc"]
+
+ , testCase "splitOnByte empty input" $ do
+ let input = "splitOnByte 58 \"\""
+ env <- runExpression input
+ env @?= ofList [ofString ""]
+
+ , testCase "intercalate round trips splitOnByte" $ do
+ let input = "equal? (intercalate \":\" (splitOnByte 58 \"a:b:c\")) \"a:b:c\""
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "takeWhile keeps the matching prefix" $ do
+ let input = "takeWhile (n : lt? n 3) [(1) (2) (3) (1)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 1, ofNumber 2]
+
+ , testCase "takeWhile stops at the first mismatch" $ do
+ let input = "takeWhile (n : lt? n 3) [(3) (1)]"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "dropWhile drops the matching prefix" $ do
+ let input = "dropWhile (n : lt? n 3) [(1) (2) (3) (1)]"
+ env <- runExpression input
+ env @?= ofList [ofNumber 3, ofNumber 1]
+
+ , testCase "dropWhile on an all matching list" $ do
+ let input = "dropWhile (n : lt? n 3) [(1) (2)]"
+ env <- runExpression input
+ env @?= ofList []
+
+ , testCase "trim strips surrounding spaces and tabs" $ do
+ let input = "trim \" \\ttrimmed \\t\""
+ env <- runExpression input
+ env @?= ofString "trimmed"
+
+ , testCase "trim leaves interior bytes alone" $ do
+ let input = "trim \" a b \""
+ env <- runExpression input
+ env @?= ofString "a b"
+
+ , testCase "trim all whitespace is empty" $ do
+ let input = "trim \" \\t \""
+ env <- runExpression input
+ env @?= ofString ""
+ ]
+
+contractsTests :: TestTree
+contractsTests = testGroup "Contracts library tests"
+ [ testCase "anyC passes any value" $ do
+ let input = "main = resultIsOk (checkContract anyC 7)"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "guardC rejects failures" $ do
+ let input = "main = resultIsErr (checkContract (guardC \"odd\" even?) 5)"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "andC combines contracts" $ do
+ let input = "main = resultIsOk (checkContract (andC (guardC \"odd\" odd?) (guardC \"gt0\" (n : gt? n 0))) 5)"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "listOf checks every element" $ do
+ let input = "main = resultIsOk (checkContract (listOf (guardC \"odd\" odd?)) [1 3 5])"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "fnContract wraps a function" $ do
+ let input = "main = resultIsOk (checkContract (fnContract (guardC \"odd\" odd?) anyC) (x : x))"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "runM reduces pureM" $ do
+ let input = "main = resultIsOk (runM (pureM 42))"
+ env <- runProgram input
+ env @?= trueT
+
+ , testCase "do notation chains checkM and pureM" $ do
+ let input = unlines
+ [ "program = (xs :"
+ , " do bindM"
+ , " n <- pureM (length xs)"
+ , " _ <- checkM (guardC \"positive\" (n : gte? n 1)) n"
+ , " pureM n)"
+ , "main = runM (program [1 2 3 4])"
+ ]
+ env <- runProgram input
+ decodeResult (env) @?= "[t t, 4]"
+
+ , testCase "handleM replaces exception with a new action" $ do
+ let input = unlines
+ [ "lookupConfig = (key defaultValue :"
+ , " exceptE \"missing\" key (resume : pureM defaultValue))"
+ , "pipeline = (xs :"
+ , " do bindM"
+ , " divisor <- lookupConfig \"divisor\" 1"
+ , " total <- pureM (sum xs)"
+ , " scaled <- liftM (x : div x divisor) total"
+ , " pureM scaled)"
+ , "handled = handleM \"missing\" (key k : pureM 2) (pipeline [10 20 30])"
+ , "main = runM handled"
+ ]
+ env <- runProgram input
+ decodeResult (env) @?= "[t t, 30]"
+
+ , testCase "=@ return annotation passes" $ do
+ let input = unlines
+ [ "five =@anyC 5"
+ , "main = five"
+ ]
+ env <- runProgram input
+ env @?= ofNumber 5
+
+ , testCase "=@ return annotation fails" $ do
+ let input = unlines
+ [ "boom =@(neverC \"boom\") 5"
+ , "main = boom"
+ ]
+ env <- runProgram input
+ decodeResult (env) @?= "[t, \"boom\"]"
+
+ , testCase "@ argument annotation passes" $ do
+ let input = unlines
+ [ "idNat x@anyC =@anyC x"
+ , "main = idNat 5"
+ ]
+ env <- runProgram input
+ env @?= ofNumber 5
+
+ , testCase "@ argument annotation fails" $ do
+ let input = unlines
+ [ "idNat x@(neverC \"bad\") =@anyC x"
+ , "main = idNat 5"
+ ]
+ env <- runProgram input
+ decodeResult (env) @?= "[t, \"bad\"]"
+ ]
+
+arithmetic :: TestTree
+arithmetic = testGroup "Arithmetic Tests"
+ [ testCase "isZero? on 0" $ do
+ let input = "isZero? 0"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "isZero? on 5" $ do
+ let input = "isZero? 5"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "add 0 3 = 3" $ do
+ let input = "add 0 3"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "add 3 0 = 3" $ do
+ let input = "add 3 0"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "add 2 3 = 5" $ do
+ let input = "add 2 3"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "sub 5 2 = 3" $ do
+ let input = "sub 5 2"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "sub 2 5 = 0 (saturated)" $ do
+ let input = "sub 2 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "sub 5 5 = 0" $ do
+ let input = "sub 5 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "lt? 2 3 = true" $ do
+ let input = "lt? 2 3"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "lt? 3 2 = false" $ do
+ let input = "lt? 3 2"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "lt? 2 2 = false" $ do
+ let input = "lt? 2 2"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "lte? 2 3 = true" $ do
+ let input = "lte? 2 3"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "lte? 3 2 = false" $ do
+ let input = "lte? 3 2"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "lte? 2 2 = true" $ do
+ let input = "lte? 2 2"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "mul 0 5 = 0" $ do
+ let input = "mul 0 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "mul 5 0 = 0" $ do
+ let input = "mul 5 0"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "mul 2 3 = 6" $ do
+ let input = "mul 2 3"
+ env <- runExpression input
+ env @?= ofNumber 6
+
+ , testCase "mul 3 3 = 9" $ do
+ let input = "mul 3 3"
+ env <- runExpression input
+ env @?= ofNumber 9
+
+ , testCase "pred 0 = 0" $ do
+ let input = "pred 0"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "pred 1 = 0" $ do
+ let input = "pred 1"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "pred 5 = 4" $ do
+ let input = "pred 5"
+ env <- runExpression input
+ env @?= ofNumber 4
+
+ , testCase "add is commutative" $ do
+ let input = "equal? (add 4 7) (add 7 4)"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "add is associative" $ do
+ let input = "equal? (add (add 2 3) 4) (add 2 (add 3 4))"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "sub x 0 = x" $ do
+ let input = "sub 7 0"
+ env <- runExpression input
+ env @?= ofNumber 7
+
+ , testCase "sub chained" $ do
+ let input = "sub (sub 10 3) 2"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "mul identity 1" $ do
+ let input = "mul 1 5"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "mul identity 2" $ do
+ let input = "mul 5 1"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "mul is commutative" $ do
+ let input = "equal? (mul 3 4) (mul 4 3)"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "mul is associative" $ do
+ let input = "equal? (mul (mul 2 3) 4) (mul 2 (mul 3 4))"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "mul distributes over add" $ do
+ let input = "equal? (mul 2 (add 3 4)) (add (mul 2 3) (mul 2 4))"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "lt? reflexive is false" $ do
+ let input = "lt? 5 5"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "lte? reflexive is true" $ do
+ let input = "lte? 5 5"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "lt? transitivity" $ do
+ let input = "and? (lt? 2 5) (lt? 5 7)"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "add larger numbers" $ do
+ let input = "add 12 15"
+ env <- runExpression input
+ env @?= ofNumber 27
+
+ , testCase "mul larger numbers" $ do
+ let input = "mul 5 6"
+ env <- runExpression input
+ env @?= ofNumber 30
+
+ , testCase "isZero? on add 0 0" $ do
+ let input = "isZero? (add 0 0)"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "div 10 3 = 3" $ do
+ let input = "div 10 3"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "div 12 4 = 3 (exact)" $ do
+ let input = "div 12 4"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "div 3 5 = 0 (divisor larger)" $ do
+ let input = "div 3 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "div 7 1 = 7 (identity)" $ do
+ let input = "div 7 1"
+ env <- runExpression input
+ env @?= ofNumber 7
+
+ , testCase "div 0 5 = 0" $ do
+ let input = "div 0 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "div rejects a zero divisor" $ do
+ let input = "div 5 0"
+ env <- runExpression input
+ env @?= Fork Leaf (Fork (ofString "non-zero") Leaf)
+
+ , testCase "mod 10 3 = 1" $ do
+ let input = "mod 10 3"
+ env <- runExpression input
+ env @?= ofNumber 1
+
+ , testCase "mod 12 4 = 0 (exact)" $ do
+ let input = "mod 12 4"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "mod 3 5 = 3 (divisor larger)" $ do
+ let input = "mod 3 5"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "mod 7 1 = 0" $ do
+ let input = "mod 7 1"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "mod rejects a zero divisor" $ do
+ let input = "mod 5 0"
+ env <- runExpression input
+ env @?= Fork Leaf (Fork (ofString "non-zero") Leaf)
+
+ , testCase "div mod consistency" $ do
+ let input = "equal? (add (mul 3 7) 4) 25"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "pow 2 0 = 1" $ do
+ let input = "pow 2 0"
+ env <- runExpression input
+ env @?= ofNumber 1
+
+ , testCase "pow 2 3 = 8" $ do
+ let input = "pow 2 3"
+ env <- runExpression input
+ env @?= ofNumber 8
+
+ , testCase "pow 3 2 = 9" $ do
+ let input = "pow 3 2"
+ env <- runExpression input
+ env @?= ofNumber 9
+
+ , testCase "pow 0 0 = 1" $ do
+ let input = "pow 0 0"
+ env <- runExpression input
+ env @?= ofNumber 1
+
+ , testCase "pow 0 5 = 0" $ do
+ let input = "pow 0 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "pow 1 10 = 1" $ do
+ let input = "pow 1 10"
+ env <- runExpression input
+ env @?= ofNumber 1
+
+ , testCase "pow 5 1 = 5" $ do
+ let input = "pow 5 1"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "min 3 7 = 3" $ do
+ let input = "min 3 7"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "min 7 3 = 3" $ do
+ let input = "min 7 3"
+ env <- runExpression input
+ env @?= ofNumber 3
+
+ , testCase "min 5 5 = 5" $ do
+ let input = "min 5 5"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "min 0 5 = 0" $ do
+ let input = "min 0 5"
+ env <- runExpression input
+ env @?= ofNumber 0
+
+ , testCase "max 3 7 = 7" $ do
+ let input = "max 3 7"
+ env <- runExpression input
+ env @?= ofNumber 7
+
+ , testCase "max 7 3 = 7" $ do
+ let input = "max 7 3"
+ env <- runExpression input
+ env @?= ofNumber 7
+
+ , testCase "max 5 5 = 5" $ do
+ let input = "max 5 5"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "max 0 5 = 5" $ do
+ let input = "max 0 5"
+ env <- runExpression input
+ env @?= ofNumber 5
+
+ , testCase "even? 0 = true" $ do
+ let input = "even? 0"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "even? 1 = false" $ do
+ let input = "even? 1"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "even? 2 = true" $ do
+ let input = "even? 2"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "even? 7 = false" $ do
+ let input = "even? 7"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "odd? 0 = false" $ do
+ let input = "odd? 0"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "odd? 1 = true" $ do
+ let input = "odd? 1"
+ env <- runExpression input
+ env @?= trueT
+
+ , testCase "odd? 2 = false" $ do
+ let input = "odd? 2"
+ env <- runExpression input
+ env @?= falseT
+
+ , testCase "odd? 7 = true" $ do
+ let input = "odd? 7"
+ env <- runExpression input
+ env @?= trueT
+ ]
+
diff --git a/test/PackageTests.hs b/test/PackageTests.hs
@@ -14,7 +14,7 @@ import qualified Data.Sequence as Seq
import qualified Data.ByteString as BS
import qualified Data.Text as T
import Wire (buildBundleShared, encodeBundle)
-import Research (T(..), ofNumber)
+import Runtime (T(..), ofNumber)
import System.IO.Temp (withSystemTempDirectory)
import System.FilePath ((</>))
import System.Directory (doesFileExist)
diff --git a/test/PatternLowering.hs b/test/PatternLowering.hs
@@ -1,7 +1,7 @@
-- Opt-in candidate controls. Built through Nix by pattern_lowering.py.
-- The reference compiler constructs independent authored oracles, never candidate expectations.
module Main where
-import Research
+import Runtime
import Wire
import TreeObservation
import qualified Data.ByteString as BS
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -2,17 +2,15 @@ module Main where
import ScriptedEffects (runScriptedEffects)
import IODriverTests (ioDriverTests)
-import Eval
+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 FileEval
-import Parser
import REPL
-import Research
+import Runtime
import TreeObservation (forceTreeShared)
import qualified NodeTable as Nodes
import Wire
@@ -21,7 +19,6 @@ import SupportFixture (canonicalEnvs, verifyReuseProviders, verifySupportSources
import ContentStore
import ContentStore.Bundle
import Module.Manifest
-import Module.Resolver
import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
import Control.Exception (bracket, evaluate, try, SomeException)
@@ -61,19 +58,6 @@ testStore :: StorePath
testStore = StorePath "/tmp/tricu-test-store"
{-# NOINLINE testStore #-}
-allTestLibsEnv :: Env
-allTestLibsEnv = unsafePerformIO $ do
- base <- recoveryFoundationEnv "base"
- bytes <- recoveryFoundationEnv "bytes"
- bin <- evaluateTestSupportFile "./lib/binary.tri"
- http <- evaluateTestSupportFile "./lib/http.tri"
- arbor <- evaluateTestSupportFile "./lib/arboricx/arboricx.tri"
- io <- recoveryFoundationEnv "io"
- sock <- evaluateTestSupportFile "./lib/socket.tri"
- intensional <- evaluateTestSupportFile "./lib/intensionalContracts.tri"
- pure (injectKernel (Map.unions [base, bytes, bin, http, arbor, io, sock, intensional]))
-{-# NOINLINE allTestLibsEnv #-}
-
tests :: TestTree
tests = testGroup "Tricu Tests"
[ runtimePresentationTests
@@ -273,11 +257,11 @@ artifactSafetyTests = testGroup "artifact safety" $
BS.writeFile (objectPath store h) (encodeTreeTerm (Stem Leaf))
resolverObject resolver (treeTermRef h) >>= (@?= Just (encodeTreeTerm Leaf))
blocked "digest mismatch" (resolverObject (filesystemResolver store) (treeTermRef h))
- , testCase "module imports verify bytes from custom resolver callbacks" $ fresh $ \store -> do
+ , 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" (resolveModuleImport resolver (unpack mh) "Demo")
+ blocked "digest mismatch" (resolveObjectByHash resolver (unDomain treeTermDomain) h)
, testGroup "execution contract"
[ testCase label $ do
let base = buildBundle [("first", Leaf), ("second", Stem Leaf)]
@@ -304,7 +288,7 @@ artifactSafetyTests = testGroup "artifact safety" $
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" (resolveModuleImport resolver (unpack mh) "Demo")
+ 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)
@@ -329,11 +313,8 @@ artifactSafetyTests = testGroup "artifact safety" $
h <- putTreeTerm store Leaf
resolver <- makeResolver store
blocked "digest mismatch" (resolverObject resolver (ObjectRef (unDomain manifestDomain) h))
- , testCase "unsupported module export ABI" $ fresh $ \store -> do
- h <- putTreeTerm store Leaf
- mh <- putManifest store (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "foreign.abi"])
- resolver <- makeResolver store
- blocked "unsupported export ABI" (resolveModuleImport resolver (unpack mh) "Demo")
+ -- 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"])
@@ -341,8 +322,8 @@ artifactSafetyTests = testGroup "artifact safety" $
resolver <- makeResolver store
resolveManifest resolver mh >>= (@?= Just (ModuleManifest [] [ModuleExport "x" (treeTermRef h) "arboricx.abi.tree.v1"]))
resolveTree resolver nh >>= (@?= Just (Stem Leaf))
- resolved <- resolveModuleImport resolver (unpack mh) "Demo"
- map resolvedExportTerm (resolvedModuleExports resolved) @?= [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)]
@@ -704,1006 +685,28 @@ sourceObjectCodecTests = testGroup "Portable tree object codec"
apply decoder encoded @?= Fork (Stem Leaf) (Fork tree Leaf)
]
-maybeTests :: TestTree
-maybeTests = testGroup "Maybe Tests"
- [ testCase "nothing is Leaf" $ do
- let input = "nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "just wraps value in Stem" $ do
- let input = "just (t t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem (Stem Leaf)
-
- , testCase "matchMaybe on nothing returns default" $ do
- let input = "matchMaybe \"empty\" (x : x) nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "empty"
-
- , testCase "matchMaybe on just extracts value" $ do
- let input = "matchMaybe \"empty\" (x : x) (just (t t))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "maybe applies f inside just" $ do
- let input = "maybe 0 (x : succ x) (just 5)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 6
-
- , testCase "maybe returns default on nothing" $ do
- let input = "maybe 0 (x : succ x) nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "maybeMap transforms just value" $ do
- let input = "maybeMap (x : succ x) (just 3)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (ofNumber 4)
-
- , testCase "maybeMap returns nothing on nothing" $ do
- let input = "maybeMap (x : succ x) nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "maybeBind flattens just" $ do
- let input = "maybeBind (just 3) (x : just (succ x))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (ofNumber 4)
-
- , testCase "maybeBind returns nothing on nothing" $ do
- let input = "maybeBind nothing (x : just (succ x))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "maybeOr returns just value" $ do
- let input = "maybeOr 99 (just 5)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "maybeOr returns default on nothing" $ do
- let input = "maybeOr 99 nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 99
-
- , testCase "maybe? on just is true" $ do
- let input = "maybe? (just t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "maybe? on nothing is false" $ do
- let input = "maybe? nothing"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
- ]
-
-providedLibraries :: TestTree
-providedLibraries = testGroup "Library Tests"
- [ testCase "Triage test Leaf" $ do
- let input = "test t"
- env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= "\"Leaf\""
-
- , testCase "Triage test (Stem Leaf)" $ do
- let input = "test (t t)"
- env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= "\"Stem\""
-
- , testCase "Triage test (Fork Leaf Leaf)" $ do
- let input = "test (t t t)"
- env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= "\"Fork\""
-
- , testCase "Boolean NOT: true" $ do
- let input = "not? true"
- env = result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= Leaf
-
- , testCase "Boolean NOT: false" $ do
- let input = "not? false"
- env = result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= Stem Leaf
-
-
- , testCase "Boolean AND TF" $ do
- let input = "and? (t t) (t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "Boolean AND FT" $ do
- let input = "and? (t) (t t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "Boolean AND FF" $ do
- let input = "and? (t) (t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "Boolean AND TT" $ do
- let input = "and? (t t) (t t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "List head" $ do
- let input = "head [(t) (t t) (t t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Leaf
-
- , testCase "List tail" $ do
- let input = "head (tail (tail [(t) (t t) (t t t)]))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Fork Leaf Leaf
-
- , testCase "List map" $ do
- let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Fork Leaf Leaf
-
- , testCase "Empty list check" $ do
- let input = "emptyList? []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "Non-empty list check" $ do
- let input = "not? (emptyList? [(1) (2) (3)])"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "Concatenate strings" $ do
- let input = "append \"Hello, \" \"world!\""
- env = decodeResult $ result $ evalTricu allTestLibsEnv (parseTricu input)
- env @?= "\"Hello, world!\""
-
- , testCase "Verifying Equality" $ do
- let input = "equal? (t t t) (t t t)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "headMaybe on empty list" $ do
- let input = "headMaybe []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "headMaybe on non-empty list" $ do
- let input = "headMaybe [(t) (t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT Leaf
-
- , testCase "lastMaybe on empty list" $ do
- let input = "lastMaybe []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "lastMaybe on single element" $ do
- let input = "lastMaybe [(t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (Stem Leaf)
-
- , testCase "lastMaybe on multi-element list" $ do
- let input = "lastMaybe [(t) (t t) (t t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (Fork Leaf Leaf)
-
- , testCase "nthMaybe first element" $ do
- let input = "nthMaybe 0 [(t) (t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT Leaf
-
- , testCase "nthMaybe middle element" $ do
- let input = "nthMaybe 1 [(t) (t t) (t t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (Stem Leaf)
-
- , testCase "nthMaybe out of bounds" $ do
- let input = "nthMaybe 5 [(t) (t t)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "reverse empty list" $ do
- let input = "reverse []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "reverse non-empty list" $ do
- let input = "reverse [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 3, ofNumber 2, ofNumber 1]
-
- , testCase "take 0 any list = empty" $ do
- let input = "take 0 [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "take 2 [1,2,3] = [1,2]" $ do
- let input = "take 2 [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 1, ofNumber 2]
-
- , testCase "take overlong returns whole list" $ do
- let input = "take 5 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 1, ofNumber 2]
-
- , testCase "drop 0 any list = list" $ do
- let input = "drop 0 [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 1, ofNumber 2, ofNumber 3]
-
- , testCase "drop 2 [1,2,3] = [3]" $ do
- let input = "drop 2 [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 3]
-
- , testCase "drop overlong returns empty" $ do
- let input = "drop 5 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "splitAt 0 [1,2] = pair [] [1,2]" $ do
- let input = "splitAt 0 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (ofList []) (ofList [ofNumber 1, ofNumber 2])
-
- , testCase "splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
- let input = "splitAt 2 [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [ofNumber 3])
-
- , testCase "splitAt overlong = pair [1,2] []" $ do
- let input = "splitAt 5 [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [])
-
- , testCase "concatMap on empty list" $ do
- let input = "concatMap (x : [(x) (x)]) []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "concatMap doubles elements" $ do
- let input = "concatMap (x : [(x) (x)]) [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 1, ofNumber 1, ofNumber 2, ofNumber 2]
-
- , testCase "find on empty list" $ do
- let input = "find (x : equal? x 2) []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "find finds element" $ do
- let input = "find (x : equal? x 2) [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (ofNumber 2)
-
- , testCase "find missing element" $ do
- let input = "find (x : equal? x 9) [(1) (2) (3)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "partition empty list" $ do
- let input = "partition (x : equal? x 2) []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (ofList []) (ofList [])
-
- , testCase "partition splits list" $ do
- let input = "partition (x : lt? 2 x) [(1) (2) (3) (4)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (ofList [ofNumber 3, ofNumber 4]) (ofList [ofNumber 1, ofNumber 2])
-
- , testCase "zipWith on empty lists" $ do
- let input = "zipWith add [] []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "zipWith adds pairwise" $ do
- let input = "zipWith add [(1) (2)] [(10) (20)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 11, ofNumber 22]
-
- , testCase "zipWith truncates to shorter list" $ do
- let input = "zipWith add [(1) (2)] [(10)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 11]
-
- , testCase "strLength" $ do
- let input = "strLength \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "strAppend" $ do
- let input = "strAppend \"hello\" \" world\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "hello world"
-
- , testCase "equal? equal strings" $ do
- let input = "equal? \"abc\" \"abc\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "equal? different strings" $ do
- let input = "equal? \"abc\" \"def\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "strEmpty? on empty" $ do
- let input = "strEmpty? \"\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "strEmpty? on non-empty" $ do
- let input = "strEmpty? \"a\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "startsWith? prefix matches" $ do
- let input = "startsWith? \"he\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "startsWith? prefix too long" $ do
- let input = "startsWith? \"hello\" \"he\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "startsWith? empty prefix" $ do
- let input = "startsWith? \"\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "endsWith? suffix matches" $ do
- let input = "endsWith? \"lo\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "endsWith? suffix too long" $ do
- let input = "endsWith? \"hello\" \"lo\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "endsWith? empty suffix" $ do
- let input = "endsWith? \"\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "contains? substring found" $ do
- let input = "contains? \"ell\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "contains? substring missing" $ do
- let input = "contains? \"xyz\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "contains? empty needle" $ do
- let input = "contains? \"\" \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "lines splits on newline" $ do
- let input = "lines \"a\\nb\\nc\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "a", ofString "b", ofString "c"]
-
- , testCase "lines single line" $ do
- let input = "lines \"hello\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "hello"]
-
- , testCase "lines empty string" $ do
- let input = "lines \"\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString ""]
-
- , testCase "lines trailing newline" $ do
- let input = "lines \"a\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "a", ofString ""]
-
- , testCase "unlines joins with newline" $ do
- let input = "unlines [(\"a\") (\"b\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "a\nb\n"
-
- , testCase "unlines empty list" $ do
- let input = "unlines []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString ""
-
- , testCase "words splits on space" $ do
- let input = "words \"hello world\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "hello", ofString "world"]
-
- , testCase "words empty string" $ do
- let input = "words \"\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "words multiple spaces" $ do
- let input = "words \" hello world \""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "hello", ofString "world"]
-
- , testCase "unwords joins with space" $ do
- let input = "unwords [(\"hello\") (\"world\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "hello world"
-
- , testCase "unwords single word" $ do
- let input = "unwords [(\"hello\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "hello"
-
- , testCase "unwords empty list" $ do
- let input = "unwords []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString ""
-
- , testCase "intercalate joins fields" $ do
- let input = "intercalate \", \" [(\"a\") (\"b\") (\"c\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "a, b, c"
-
- , testCase "intercalate leaves a lone field alone" $ do
- let input = "intercalate \", \" [(\"a\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "a"
-
- , testCase "intercalate empty list" $ do
- let input = "intercalate \", \" []"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString ""
-
- , testCase "joinSuffix terminates every field" $ do
- let input = "joinSuffix \"-\" [(\"a\") (\"b\")]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "a-b-"
-
- , testCase "splitOnByte splits on a byte" $ do
- let input = "splitOnByte 58 \"a:b:c\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "a", ofString "b", ofString "c"]
-
- , testCase "splitOnByte keeps empty fields" $ do
- let input = "splitOnByte 58 \"a::b\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "a", ofString "", ofString "b"]
-
- , testCase "splitOnByte trailing separator leaves an empty field" $ do
- let input = "splitOnByte 58 \"a:\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "a", ofString ""]
-
- , testCase "splitOnByte without a match" $ do
- let input = "splitOnByte 58 \"abc\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString "abc"]
-
- , testCase "splitOnByte empty input" $ do
- let input = "splitOnByte 58 \"\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofString ""]
-
- , testCase "intercalate round trips splitOnByte" $ do
- let input = "equal? (intercalate \":\" (splitOnByte 58 \"a:b:c\")) \"a:b:c\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "takeWhile keeps the matching prefix" $ do
- let input = "takeWhile (n : lt? n 3) [(1) (2) (3) (1)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 1, ofNumber 2]
-
- , testCase "takeWhile stops at the first mismatch" $ do
- let input = "takeWhile (n : lt? n 3) [(3) (1)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "dropWhile drops the matching prefix" $ do
- let input = "dropWhile (n : lt? n 3) [(1) (2) (3) (1)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList [ofNumber 3, ofNumber 1]
-
- , testCase "dropWhile on an all matching list" $ do
- let input = "dropWhile (n : lt? n 3) [(1) (2)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofList []
-
- , testCase "trim strips surrounding spaces and tabs" $ do
- let input = "trim \" \\ttrimmed \\t\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "trimmed"
-
- , testCase "trim leaves interior bytes alone" $ do
- let input = "trim \" a b \""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "a b"
-
- , testCase "trim all whitespace is empty" $ do
- let input = "trim \" \\t \""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString ""
- ]
-
-contractsTests :: TestTree
-contractsTests = testGroup "Contracts library tests"
- [ testCase "anyC passes any value" $ do
- let input = "main = resultIsOk (checkContract anyC 7)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "guardC rejects failures" $ do
- let input = "main = resultIsErr (checkContract (guardC \"odd\" even?) 5)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "andC combines contracts" $ do
- let input = "main = resultIsOk (checkContract (andC (guardC \"odd\" odd?) (guardC \"gt0\" (n : gt? n 0))) 5)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "listOf checks every element" $ do
- let input = "main = resultIsOk (checkContract (listOf (guardC \"odd\" odd?)) [1 3 5])"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "fnContract wraps a function" $ do
- let input = "main = resultIsOk (checkContract (fnContract (guardC \"odd\" odd?) anyC) (x : x))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "runM reduces pureM" $ do
- let input = "main = resultIsOk (runM (pureM 42))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "do notation chains checkM and pureM" $ do
- let input = unlines
- [ "program = (xs :"
- , " do bindM"
- , " n <- pureM (length xs)"
- , " _ <- checkM (guardC \"positive\" (n : gte? n 1)) n"
- , " pureM n)"
- , "main = runM (program [1 2 3 4])"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- decodeResult (result env) @?= "[t t, 4]"
-
- , testCase "handleM replaces exception with a new action" $ do
- let input = unlines
- [ "lookupConfig = (key defaultValue :"
- , " exceptE \"missing\" key (resume : pureM defaultValue))"
- , "pipeline = (xs :"
- , " do bindM"
- , " divisor <- lookupConfig \"divisor\" 1"
- , " total <- pureM (sum xs)"
- , " scaled <- liftM (x : div x divisor) total"
- , " pureM scaled)"
- , "handled = handleM \"missing\" (key k : pureM 2) (pipeline [10 20 30])"
- , "main = runM handled"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- decodeResult (result env) @?= "[t t, 30]"
-
- , testCase "=@ return annotation passes" $ do
- let input = unlines
- [ "five =@anyC 5"
- , "main = five"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "=@ return annotation fails" $ do
- let input = unlines
- [ "boom =@(neverC \"boom\") 5"
- , "main = boom"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- decodeResult (result env) @?= "[t, \"boom\"]"
-
- , testCase "@ argument annotation passes" $ do
- let input = unlines
- [ "idNat x@anyC =@anyC x"
- , "main = idNat 5"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "@ argument annotation fails" $ do
- let input = unlines
- [ "idNat x@(neverC \"bad\") =@anyC x"
- , "main = idNat 5"
- ]
- env = evalTricu allTestLibsEnv (parseTricu input)
- decodeResult (result env) @?= "[t, \"bad\"]"
- ]
-
-arithmetic :: TestTree
-arithmetic = testGroup "Arithmetic Tests"
- [ testCase "isZero? on 0" $ do
- let input = "isZero? 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "isZero? on 5" $ do
- let input = "isZero? 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "add 0 3 = 3" $ do
- let input = "add 0 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "add 3 0 = 3" $ do
- let input = "add 3 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "add 2 3 = 5" $ do
- let input = "add 2 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "sub 5 2 = 3" $ do
- let input = "sub 5 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "sub 2 5 = 0 (saturated)" $ do
- let input = "sub 2 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "sub 5 5 = 0" $ do
- let input = "sub 5 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "lt? 2 3 = true" $ do
- let input = "lt? 2 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "lt? 3 2 = false" $ do
- let input = "lt? 3 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "lt? 2 2 = false" $ do
- let input = "lt? 2 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "lte? 2 3 = true" $ do
- let input = "lte? 2 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "lte? 3 2 = false" $ do
- let input = "lte? 3 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "lte? 2 2 = true" $ do
- let input = "lte? 2 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "mul 0 5 = 0" $ do
- let input = "mul 0 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "mul 5 0 = 0" $ do
- let input = "mul 5 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "mul 2 3 = 6" $ do
- let input = "mul 2 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 6
-
- , testCase "mul 3 3 = 9" $ do
- let input = "mul 3 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 9
-
- , testCase "pred 0 = 0" $ do
- let input = "pred 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "pred 1 = 0" $ do
- let input = "pred 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "pred 5 = 4" $ do
- let input = "pred 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 4
-
- , testCase "add is commutative" $ do
- let input = "equal? (add 4 7) (add 7 4)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "add is associative" $ do
- let input = "equal? (add (add 2 3) 4) (add 2 (add 3 4))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "sub x 0 = x" $ do
- let input = "sub 7 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 7
-
- , testCase "sub chained" $ do
- let input = "sub (sub 10 3) 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "mul identity 1" $ do
- let input = "mul 1 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "mul identity 2" $ do
- let input = "mul 5 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "mul is commutative" $ do
- let input = "equal? (mul 3 4) (mul 4 3)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "mul is associative" $ do
- let input = "equal? (mul (mul 2 3) 4) (mul 2 (mul 3 4))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "mul distributes over add" $ do
- let input = "equal? (mul 2 (add 3 4)) (add (mul 2 3) (mul 2 4))"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "lt? reflexive is false" $ do
- let input = "lt? 5 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "lte? reflexive is true" $ do
- let input = "lte? 5 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "lt? transitivity" $ do
- let input = "and? (lt? 2 5) (lt? 5 7)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "add larger numbers" $ do
- let input = "add 12 15"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 27
-
- , testCase "mul larger numbers" $ do
- let input = "mul 5 6"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 30
-
- , testCase "isZero? on add 0 0" $ do
- let input = "isZero? (add 0 0)"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "div 10 3 = 3" $ do
- let input = "div 10 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "div 12 4 = 3 (exact)" $ do
- let input = "div 12 4"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "div 3 5 = 0 (divisor larger)" $ do
- let input = "div 3 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "div 7 1 = 7 (identity)" $ do
- let input = "div 7 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 7
-
- , testCase "div 0 5 = 0" $ do
- let input = "div 0 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "div 5 0 = 0 (div by zero)" $ do
- let input = "div 5 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "mod 10 3 = 1" $ do
- let input = "mod 10 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 1
-
- , testCase "mod 12 4 = 0 (exact)" $ do
- let input = "mod 12 4"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "mod 3 5 = 3 (divisor larger)" $ do
- let input = "mod 3 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "mod 7 1 = 0" $ do
- let input = "mod 7 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "mod 5 0 = 0 (mod by zero)" $ do
- let input = "mod 5 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "div mod consistency" $ do
- let input = "equal? (add (mul 3 7) 4) 25"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "pow 2 0 = 1" $ do
- let input = "pow 2 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 1
-
- , testCase "pow 2 3 = 8" $ do
- let input = "pow 2 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 8
-
- , testCase "pow 3 2 = 9" $ do
- let input = "pow 3 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 9
-
- , testCase "pow 0 0 = 1" $ do
- let input = "pow 0 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 1
-
- , testCase "pow 0 5 = 0" $ do
- let input = "pow 0 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "pow 1 10 = 1" $ do
- let input = "pow 1 10"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 1
-
- , testCase "pow 5 1 = 5" $ do
- let input = "pow 5 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "min 3 7 = 3" $ do
- let input = "min 3 7"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "min 7 3 = 3" $ do
- let input = "min 7 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "min 5 5 = 5" $ do
- let input = "min 5 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "min 0 5 = 0" $ do
- let input = "min 0 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "max 3 7 = 7" $ do
- let input = "max 3 7"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 7
-
- , testCase "max 7 3 = 7" $ do
- let input = "max 7 3"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 7
-
- , testCase "max 5 5 = 5" $ do
- let input = "max 5 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "max 0 5 = 5" $ do
- let input = "max 0 5"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 5
-
- , testCase "even? 0 = true" $ do
- let input = "even? 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "even? 1 = false" $ do
- let input = "even? 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "even? 2 = true" $ do
- let input = "even? 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "even? 7 = false" $ do
- let input = "even? 7"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "odd? 0 = false" $ do
- let input = "odd? 0"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "odd? 1 = true" $ do
- let input = "odd? 1"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "odd? 2 = false" $ do
- let input = "odd? 2"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "odd? 7 = true" $ do
- let input = "odd? 7"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
- ]
-
fileEval :: TestTree
-fileEval = testGroup "File evaluation tests"
- [ testCase "Forks" $ do
- res <- liftIO $ evaluateFileResult "./test/fork.tri"
- res @?= Fork Leaf Leaf
-
- , testCase "File ends with comment" $ do
- res <- liftIO $ evaluateFileResult "./test/comments-1.tri"
- res @?= Fork (Stem Leaf) Leaf
-
- , testCase "Mapping and Equality" $ do
- fEnv <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/map.tri"
- (mainResult fEnv) @?= Stem Leaf
-
- , testCase "Eval and decoding string" $ do
- res <- liftIO $ evaluateFileWithContext allTestLibsEnv "./test/string.tri"
- decodeResult (result res) @?= "\"String test!\""
+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 "Stable demo distinguishes structural from extensional equality" $ do
- env <- evaluateTestSupportFile "./demos/equality.tri"
+ env <- evaluateCompilerFile "./demos/equality.tri"
-- The former optimized fixture identified these trees. Stable lowering
-- does not: that intensional difference is observable, not a Boolean bug.
- mainResult env @?= Leaf
+ env Map.! "main" @?= Leaf
assertBool "stable lambda and hand-authored TC trees must differ"
(env Map.! "not_TC?" /= env Map.! "not_Lambda?")
forM_ ["not_TC?", "not_Lambda?"] $ \name -> do
@@ -1712,29 +715,29 @@ demos = testGroup "Test provided demo functionality"
env Map.! "bothTrueEqual?" @?= Stem Leaf
env Map.! "bothFalseEqual?" @?= Stem Leaf
, testCase "Convert values back to source code demo" $ do
- res <- liftIO $ (mainResult <$> evaluateTestSupportFile "./demos/toSource.tri")
+ 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 t))) (t t t)))\""
, testCase "Determining the size of stable-compiled functions" $ do
- env <- evaluateTestSupportFile "./demos/size.tri"
+ env <- evaluateCompilerFile "./demos/size.tri"
-- Count the actual executable independently of the compiled size worker.
- -- The old optimized demo was 1038; other source/recovery cohorts below
- -- have their own distinct intensional goldens.
+ -- 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")
-- Current stable native libraries; pre-modernization stable size was 1606.
actual @?= 1845
- mainResult env @?= ofNumber actual
+ env Map.! "main" @?= ofNumber actual
, testCase "Level Order Traversal demo" $ do
- res <- liftIO $ (mainResult <$> evaluateTestSupportFile "./demos/levelOrderTraversal.tri")
+ 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 $ (mainResult <$> evaluateTestSupportFile "./demos/contractEffects.tri")
+ res <- liftIO $ ((Map.! "main") <$> evaluateCompilerFile "./demos/contractEffects.tri")
decodeResult res @?= "[t t, 10]"
, testCase "Safe base wrappers demo" $ do
- res <- liftIO $ (mainResult <$> evaluateTestSupportFile "./demos/contractBasics.tri")
+ res <- liftIO $ ((Map.! "main") <$> evaluateCompilerFile "./demos/contractBasics.tri")
decodeResult res @?= "[3, t t, t, t t]"
]
@@ -1978,101 +981,6 @@ contentStoreTests = testGroup "Content Store Tests"
resolveManifest resolver manifestH >>= (@?= Just manifest)
resolveTree resolver rootH >>= (@?= Just term)
- , testCase "Workspace modules: exported names are local top-level definitions only" $
- withSystemTempDirectory "tricu-workspace-local-exports" $ \dir -> do
- let store = StorePath (dir </> "store")
- depPath = dir </> "dep.tri"
- libPath = dir </> "util.tri"
- mainPath = dir </> "main.tri"
- writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule util = util.tri\n"
- writeFile depPath "helper = t t\n"
- writeFile libPath "!import \"dep\" !Local\n\nvalue = helper\n"
- writeFile mainPath "!import \"util\" Util\n\nmain = Util.value\n"
- env <- evaluateFileWithStore (Just store) mainPath
- result env @?= Stem Leaf
- mAlias <- readAlias store ModuleAlias "util"
- case mAlias of
- Nothing -> assertFailure "expected workspace build to write util module alias"
- Just ref -> do
- mManifest <- getManifest store (objectRefHash ref)
- case mManifest of
- Nothing -> assertFailure "expected workspace module manifest"
- Just manifest -> map moduleExportName (moduleManifestExports manifest) @?= ["value"]
-
- , testCase "Workspace modules: contract annotations travel with exported definitions" $
- withSystemTempDirectory "tricu-workspace-contract-export" $ \dir -> do
- let store = StorePath (dir </> "store")
- libPath = dir </> "util.tri"
- mainPath = dir </> "main.tri"
- -- Exercise the real recovery resolver with an explicit temporary body
- -- fixture, not an attempt to parse native library headers as legacy.
- reference <- recoveryFoundationBody "base"
- writeFile (dir </> "base.tri") reference
- writeFile (dir </> "tricu.workspace") "module base = base.tri\nmodule util = util.tri\n"
- writeFile libPath "!import \"base\" !Local\n\nalwaysOk = (value rest : ok value rest)\n\nneverOk = (value rest : err \"nope\" rest)\n\nsafeId n@alwaysOk =@alwaysOk n\n\nbadId n@neverOk =@neverOk n\n"
- writeFile mainPath "!import \"util\" Util\n\nmain = Util.safeId 5\n"
- env <- evaluateFileWithStore (Just store) mainPath
- result env @?= ofNumber 5
- writeFile mainPath "!import \"util\" Util\n\nmain = Util.badId 5\n"
- envFail <- evaluateFileWithStore (Just store) mainPath
- decodeResult (result envFail) @?= "[t, \"nope\"]"
-
- , testCase "Module imports: resolve manifest exports from store" $
- withSystemTempDirectory "tricu-module-import" $ \dir -> do
- let store = StorePath (dir </> "store")
- sourcePath = dir </> "consumer.tri"
- term = Fork Leaf (Stem Leaf)
- manifestFor root = ModuleManifest []
- [ ModuleExport
- "value"
- (ObjectRef (unDomain treeTermDomain) root)
- "arboricx.abi.tree.v1"
- ]
- root <- putTreeTerm store term
- manifestHash <- putManifest store (manifestFor root)
- writeAlias store ModuleAlias "demo" (ObjectRef (unDomain manifestDomain) manifestHash)
- writeFile sourcePath "!import \"demo\" Demo\n\nmain = Demo.value\n"
- env <- evaluateFileWithStore (Just store) sourcePath
- result env @?= term
-
- , testCase "Module resolver diagnostics: missing alias names workspace/module guidance" $ do
- let resolver = filesystemResolver (StorePath "/tmp/tricu-test-missing-module-store")
- outcome <- try (resolveModuleImport resolver "definitely-not-a-module" "Demo") :: IO (Either SomeException ResolvedModule)
- case outcome of
- Right _ -> assertFailure "expected missing module alias failure"
- Left err -> show err `containsAll` ["Module alias not found", "definitely-not-a-module", "tricu.workspace", "ModuleAlias"]
-
- , testCase "Module resolver diagnostics: alias kind mismatch names expected kind" $ do
- let resolver = ObjectResolver
- { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
- then Just (ObjectRef "arboricx.tree-root.v1" "abc123")
- else Nothing
- , resolverObject = \_ -> return Nothing
- , resolverManifest = \_ -> return Nothing
- , resolverTree = \_ -> return Nothing
- }
- outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule)
- case outcome of
- Right _ -> assertFailure "expected alias kind mismatch failure"
- Left err -> show err `containsAll` ["Module alias", "demo", "unsupported object kind", "arboricx.tree-root.v1", "arboricx.module-manifest.v1"]
-
- , testCase "Module resolver diagnostics: missing tree term names export and hash" $ do
- let root = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
- manifest = ModuleManifest []
- [ ModuleExport "value" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" ]
- resolver = ObjectResolver
- { resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
- then Just (ObjectRef (unDomain manifestDomain) "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb")
- else Nothing
- , resolverObject = \_ -> return Nothing
- , resolverManifest = \_ -> return (Just manifest)
- , resolverTree = \_ -> return Nothing
- }
- outcome <- try (resolveModuleImport resolver "demo" "Demo") :: IO (Either SomeException ResolvedModule)
- case outcome of
- Right _ -> assertFailure "expected missing tree term failure"
- Left err -> show err `containsAll` ["Module export", "value", "missing tree term", unpack root]
-
, testCase "Arboricx bundle: unpack transport bundle into CAS tree terms" $
withSystemTempDirectory "tricu-store" $ \dir -> do
let store = StorePath dir
@@ -2238,7 +1146,7 @@ countStoredObjects store@(StorePath root) = do
wireTests :: TestTree
wireTests = testGroup "Wire Tests"
[ testCase "Indexed bundle: header and manifest declare indexed format" $ do
- let term = result $ evalTricu Map.empty $ parseTricu "id = a : a\nmain = id t"
+ let term = Leaf
bundle = buildBundle [("main", term)]
wireData = encodeBundle bundle
BS.take 8 wireData @?= BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58]
@@ -2265,13 +1173,13 @@ wireTests = testGroup "Wire Tests"
exports -> assertFailure $ "Expected one export, got: " ++ show exports
, testCase "Indexed bundle: deterministic encoding" $ do
- let term = result $ evalTricu Map.empty $ parseTricu "x = t t\nmain = t x"
+ 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 = result $ evalTricu Map.empty $ parseTricu "f = a : a\nmain = f t"
+ let term = Leaf
mainBundle = buildBundle [("main", term)]
renamedBundle = buildBundle [("validate", term)]
encodeBundle mainBundle /= encodeBundle renamedBundle @? "different export names should produce different bytes"
@@ -2333,7 +1241,7 @@ wireTests = testGroup "Wire Tests"
, testCase "Indexed bundle: unpack into filesystem CAS" $
withSystemTempDirectory "tricu-store" $ \dir -> do
- let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t"
+ let term = Leaf
bundle = buildBundle [("validateEmail", term)]
wireData = encodeBundle bundle
store = StorePath dir
@@ -2343,7 +1251,7 @@ wireTests = testGroup "Wire Tests"
other -> assertFailure $ "unexpected roots: " ++ show other
, testCase "Indexed bundle: round-trip decode and verify" $ do
- let term = result $ evalTricu Map.empty $ parseTricu "x = t\ny = t x\nz = t y\nmain = z"
+ let term = Stem (Stem Leaf)
bundle = buildBundle [("main", term)]
wireData = encodeBundle bundle
case decodeBundle wireData of
@@ -2396,33 +1304,15 @@ wireTests = testGroup "Wire Tests"
tricuReaderTests :: TestTree
tricuReaderTests = testGroup "Tricu Reader Tests"
- [ testCase "Tricu reader parses indexed bundle (id fixture)" $ do
- bundleBytes <- BS.readFile "./test/fixtures/id.arboricx"
- let bundleT = ofBytes bundleBytes
- let env = Map.insert "testBundle" bundleT allTestLibsEnv
- tagExpr = parseTricu "fst (runArboricx testBundle t)"
- tag = result (evalTricu env tagExpr)
- codeExpr = parseTricu "fst (snd (runArboricx testBundle t))"
- code = result (evalTricu env codeExpr)
- tag @?= trueT
-
- , testCase "Tricu reader parses indexed bundle (append fixture)" $ do
- bundleBytes <- BS.readFile "./test/fixtures/append.arboricx"
- let bundleT = ofBytes bundleBytes
- let env = Map.insert "testBundle" bundleT allTestLibsEnv
- tagExpr = parseTricu "fst (runArboricx testBundle t)"
- tag = result (evalTricu env tagExpr)
- tag @?= trueT
-
- , testCase "Tricu reader parses indexed bundle (bool fixtures)" $ do
- forM_ ["true", "false"] $ \name -> do
- bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
- let bundleT = ofBytes bundleBytes
- let env = Map.insert "testBundle" bundleT allTestLibsEnv
- tagExpr = parseTricu "fst (runArboricx testBundle t)"
- tag = result (evalTricu env tagExpr)
- tag @?= trueT
+ [ 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
@@ -2773,146 +1663,16 @@ gateLexerTests = testGroup "Feasibility-gate source lexer"
-- Single-expression feasibility-gate surface parser
-- --------------------------------------------------------------------------
-compiledModuleEnv :: String -> IO Env
-compiledModuleEnv legacy = do
- let (rows, exports) = compiledLibraries
- (alias, path) <- case [(alias, path) | (name, alias, path) <- rows, name == legacy] of
- [entry] -> pure entry
- _ -> error ("missing compiled compiler module: " ++ legacy)
- text <- readTestSource path
- imported <- compilerTestImports text
- let prefix = alias ++ "."
- owned = Map.fromList
- [ (drop (length prefix) name, tree)
- | (name, tree) <- Map.toList exports, prefix `isPrefixOf` name ]
- pure (injectKernel (Map.union owned imported))
-
-compilerTestImports :: String -> IO Env
-compilerTestImports text = do
- let legacyFor alias = case [legacy | (legacy, mapped, _) <- fst compiledLibraries,
- mapped == alias] of
- [legacy] -> legacy
- _ -> error ("unknown native compiler-test import: " ++ alias)
- modules <- forM [words line | line <- lines text, "!import " `isPrefixOf` line] $ \row ->
- case row of
- [_, encoded, namespace] | "\"" `isPrefixOf` encoded -> do
- -- Explicit recovery spelling, never native resolver fallback.
- env <- compiledModuleEnv (read encoded)
- pure $ if namespace == "!Local" then env
- else Map.mapKeys (\name -> namespace ++ "." ++ name) env
- [_, alias, "*"] -> compiledModuleEnv (legacyFor alias)
- [_, alias, "as", namespace] ->
- Map.mapKeys (\name -> namespace ++ "." ++ name) <$> compiledModuleEnv (legacyFor alias)
- [_, alias] ->
- Map.mapKeys (\name -> alias ++ "." ++ name) <$> compiledModuleEnv (legacyFor alias)
- _ -> error "unsupported compiler-test import"
- pure (Map.unions modules)
-
+-- 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] -> compiledModuleEnv legacy
+ [legacy] -> pure (fixtureExports legacy)
[] -> compileFixtureFile path
_ -> error "ambiguous compiler fixture module"
--- Explicit unit-test support bridge for portable libraries.
--- Compiler/parser and migrated support payloads come from fingerprinted portable
--- fixtures. The six foundational bodies have a SEPARATE, explicit Haskell
--- reference cohort for recovery/shape tests; this never supplies native compiler
--- libraries or portable applications. Still-legacy wrappers use that cohort.
--- This is not a production module resolver or a compilation-failure fallback.
-testSupportCache :: IORef (Map.Map FilePath Env)
-testSupportCache = unsafePerformIO (newIORef Map.empty)
-{-# NOINLINE testSupportCache #-}
-
-evaluateTestSupportFile :: FilePath -> IO Env
-evaluateTestSupportFile input = do
- let path = maybe input id (stripPrefix "./" input)
- cached <- Map.lookup path <$> readIORef testSupportCache
- case cached of
- Just env -> pure env
- Nothing -> do
- text <- readTestSource path
- let foundation = [name | name <- Map.keys recoveryFoundationDependencies,
- path == "lib/" ++ name ++ ".tri"]
- env <- if not (null foundation)
- then recoveryFoundationEnv (head foundation)
- else if any (\line -> any (`isPrefixOf` line) ["!source ", "!export "]) (lines text)
- then evaluateCompilerFile path
- else do
- imports <- forM [words line | line <- lines text, "!import " `isPrefixOf` line] $ \row ->
- case row of
- [_, encoded, namespace] -> do
- let name = read encoded :: String
- source = if name == "arboricx" then "lib/arboricx/arboricx.tri"
- else "lib/" ++ map (\c -> if c == '.' then '/' else c) name ++ ".tri"
- imported <- evaluateTestSupportFile source
- pure $ if namespace == "!Local" then imported
- else Map.mapKeys (\key -> namespace ++ "." ++ key) imported
- _ -> error "unsupported legacy unit-test support import"
- let body = unlines [line | line <- lines text, not (any (`isPrefixOf` line) ["!import ", "!export ", "!source "])]
- pure (evalTricu (injectKernel (Map.unions imports)) (parseTricu body))
- atomicModifyIORef' testSupportCache (\cache -> (Map.insert path env cache, ()))
- pure env
-
--- A deliberately restricted source-body reference, NOT a native module
--- implementation. Exact native headers are required; no namespaces, selective
--- imports/exports or arbitrary native sources can be interpreted here. These
--- six bodies are host-compiled only to preserve independent recovery semantics
--- (including intensional size goldens), while compiledModuleEnv stays artifact-only.
-recoveryFoundationDependencies :: Map.Map String [String]
-recoveryFoundationDependencies = Map.fromList
- [("base", []), ("bytes", ["base"]), ("conversions", ["base"]),
- ("prelude", ["base", "bytes", "conversions"]),
- ("patterns", ["prelude"]), ("io", ["prelude", "patterns"])]
-
--- Immutable pre-foundations cohort. These are authenticated source-object
--- digests already retained in reference-source, not current fixture metadata.
--- Native source publication must never teach the recovery parser new syntax
--- by accident or silently change its intensional reference goldens.
-recoveryFoundationSources :: Map.Map String String
-recoveryFoundationSources = Map.fromList
- [ ("base", "fc210e5cdd97d60ce7290b4ac4227adc51119e2786bcacb671b7ad9cb6cda427")
- , ("bytes", "da07ad9055f71d6a751659772f900cb06a7e7cd73ab953c5c374e776190a788e")
- , ("conversions", "3e1da4f0212f5016539a66f17c704389ebeaba2da1d4bea96d95023d3058c559")
- , ("prelude", "0c26a0142d15cc2a11a4317264491c797944e76ea8afa07a1efef240a70f4289")
- , ("patterns", "89381a44435f725ed9ac70b13855a1a86fee4db0c05c231c7940bafdc9c62518")
- , ("io", "687cd83bc56d246e2126875cf894e08a82e8e59c470debb56f11263e7fd9ceeb")
- ]
-
-recoveryFoundationEnv :: String -> IO Env
-recoveryFoundationEnv name = do
- deps <- maybe (error "unknown recovery reference foundation") pure
- (Map.lookup name recoveryFoundationDependencies)
- -- Force source-fingerprint verification before using any reference body.
- _ <- evaluate (length (fst compilerFixture))
- let key = "recovery-reference:" ++ name
- cached <- Map.lookup key <$> readIORef testSupportCache
- case cached of
- Just env -> pure env
- Nothing -> do
- body <- recoveryFoundationBody name
- imported <- mapM recoveryFoundationEnv deps
- let env = evalTricu (injectKernel (Map.unions imported)) (parseTricu body)
- atomicModifyIORef' testSupportCache (\cache -> (Map.insert key env cache, ()))
- pure env
-
-recoveryFoundationBody :: String -> IO String
-recoveryFoundationBody name = do
- deps <- maybe (error "unknown recovery reference foundation") pure
- (Map.lookup name recoveryFoundationDependencies)
- _ <- evaluate (length (fst compilerFixture))
- pin <- maybe (error "unknown pinned recovery reference source") pure
- (Map.lookup name recoveryFoundationSources)
- text <- unpack . decodeUtf8 <$> readPinnedSource "test/fixtures/reference-source" pin
- let headers = if name == "prelude"
- then "!export *" : map ("!export * from " ++) deps
- else map (\dep -> "!import " ++ dep ++ " *") deps ++ ["!export *"]
- (actual, body) = span ("!" `isPrefixOf`) (lines text)
- unless (actual == headers) $ error "unsupported recovery reference foundation headers"
- pure (unlines body)
-
-- 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 ()
@@ -3051,7 +1811,7 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
(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 <- compiledModuleEnv "base"
+ 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)
@@ -3172,7 +1932,7 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
verifySupportDependencies providers
(replicate 2 ["local","http","new-manifest","source"]) @?= Left "duplicate local dependency"
, testCase "native staging preserves namespaces and explicit exports" $ do
- env <- compiledModuleEnv "source.map"
+ env <- pure (fixtureExports "source.map")
let row = pairT (ofString "example") (pairT (ofString "example")
(pairT (ofString "example.tri")
(pairT (ofList [ofString "native_math"]) (ofString "native"))))
@@ -3181,9 +1941,9 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
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 (env Map.! "fst") (prepare (ofString bad)) @?= Leaf
+ apply (fixtureExports "base" Map.! "fst") (prepare (ofString bad)) @?= Leaf
, testCase "shared native header derives ordered deduplicated edges and masks positions" $ do
- env <- compiledModuleEnv "source.module"
+ 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
@@ -3194,25 +1954,25 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
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 <- compiledModuleEnv "source.module"
+ env <- pure (fixtureExports "source.module")
let bad sources = forM_ sources $ \source ->
- apply (env Map.! "fst") (apply (env Map.! "sourceModuleHeaderStage") (ofString source)) @?= Leaf
+ 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 (env Map.! "fst") (apply (env Map.! "snd") outcome)
- apply (env Map.! "parserDiagnosticLocation") problem @?= gatePosition 3 1 9
+ 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 <- compiledModuleEnv "math.native"
+ 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 <- compiledModuleEnv "prelude"
+ prelude <- pure (fixtureExports "prelude")
assertBool "general equality removed" (Map.member "equal?" prelude)
]
@@ -3488,7 +2248,7 @@ gateProgramEnv = fixtureExports "source.program"
gateProgramTests :: TestTree
gateProgramTests = testGroup "Feasibility-gate program parser"
- [ testCase "fresh-store import normalizes the definition parser" $ do
+ [ testCase "portable wrapper normalizes the definition parser" $ do
env <- evaluateCompilerFile
"./test/sourceGateProgramImport.tri"
Map.lookup "main" env @?= Just programResult
@@ -3566,7 +2326,7 @@ gateOrderingEnv = fixtureExports "source.order"
gateOrderingTests :: TestTree
gateOrderingTests = testGroup "Feasibility-gate definition ordering"
- [ testCase "fresh-store import orders forward references" $ do
+ [ testCase "portable wrapper orders forward references" $ do
env <- evaluateCompilerFile
"./test/sourceGateOrderImport.tri"
Map.lookup "main" env @?= Just (parserOk
@@ -3667,7 +2427,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
packCompilerFile
"./test/sourceGateUnitCompiler.tri" path [pack "matchesExpected"]
bytes <- BS.readFile path
- goldenEnv <- evaluateTestSupportFile "./test/sourceGateExpected.tri"
+ goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
let name = gateToken 2 (ofString "f")
(gatePosition 2 1 6) (gatePosition 2 2 7)
body = gateAst 1 Leaf
@@ -3826,7 +2586,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
packCompilerFile
"./test/sourceGateUnitCompiler.tri" path [pack "matchesOutput"]
bytes <- BS.readFile path
- goldenEnv <- evaluateTestSupportFile "./test/sourceGateExpected.tri"
+ goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
case decodeBundle bytes of
Left diagnostic -> assertFailure diagnostic
Right bundle -> do
@@ -3846,21 +2606,18 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
apply (apply artifact (ofString source)) expected @?= trueT
, testCase "output includes root and definitions in dependency order" $ do
let source = "main = value\nvalue = t"
- output = result (evalTricu gateUnitEnv
- (parseTricu ("compileGateProgramOutput [] " ++ show source)))
+ 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 "[]" source (parserOk Leaf Leaf)
+ check Leaf source (parserOk Leaf Leaf)
, testCase "empty output environment still carries the selected root" $
- result (evalTricu gateUnitEnv
- (parseTricu "compileGateProgramOutput [] \"t\"")) @?=
+ foldl apply (gateUnitEnv Map.! "compileGateProgramOutput") [Leaf, ofString "t"] @?=
parserOk (pairT Leaf Leaf) Leaf
, testCase "output entrypoint preserves structured diagnostics" $
- result (evalTricu gateUnitEnv
- (parseTricu "compileGateProgramOutput [] \"helper = t\"")) @?=
+ 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
@@ -3928,7 +2685,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
(ofList [pairT (ofString "main") root])) Leaf
let externalNames = ["map", "append", "equal?", "head", "y", "triage"]
external = ofList
- [ pairT (ofString name) (allTestLibsEnv Map.! name)
+ [ pairT (ofString name) (fixtureExports "base" Map.! name)
| name <- externalNames ]
stringSource <- readFile "./test/string.tri"
apply (apply artifact external) (ofString stringSource) @?=
@@ -3975,18 +2732,17 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
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 "[]" source (parserOk (ofNumber 42) Leaf)
+ check Leaf source (parserOk (ofNumber 42) Leaf)
, testCase "final expression selects root in absence of main" $
- check "[]" "id x = x\nid t" (parserOk Leaf Leaf)
+ check Leaf "id x = x\nid t" (parserOk Leaf Leaf)
, testCase "a local main wins over a final expression" $
- check "[]" "main = 2\n3" (parserOk (ofNumber 2) Leaf)
+ check Leaf "main = 2\n3" (parserOk (ofNumber 2) Leaf)
, testCase "provided environment is visible inside definitions" $
- check "[(pair \"host\" (t t))]" "main = host t"
+ 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 = result (evalTricu gateUnitEnv (parseTricu
- ("compileGateProgram [] " ++ show source)))
+ 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
@@ -3994,9 +2750,9 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, 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"
- input = "compileGateProgram [(pair \"y\" y)] " ++ show source
- env = evalTricu (Map.union gateUnitEnv gateCompileBaseEnv) (parseTricu input)
- case result env of
+ 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
@@ -4008,8 +2764,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
++ "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"
- input = "compileGateProgram [] " ++ show source
- compiled = result (evalTricu gateUnitEnv (parseTricu input))
+ compiled = foldl apply (gateUnitEnv Map.! "compileGateProgram") [Leaf, ofString source]
case compiled of
Fork tag (Fork fun Leaf) | tag == trueT -> do
apply fun Leaf @?= Leaf
@@ -4026,7 +2781,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, ("main =\n value\n where value = t", Leaf)
]
forM_ sources $ \(source, value) -> do
- check "[]" source (parserOk value Leaf)
+ check Leaf source (parserOk value Leaf)
, testCase "multiline grouped applications retain expected results" $ do
let sources =
[ ("main = (t\n t)", Stem Leaf)
@@ -4035,17 +2790,16 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, ("main = (x\n where x = t)", Leaf)
]
forM_ sources $ \(source, value) -> do
- check "[]" source (parserOk value Leaf)
+ 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
- expression = "parserReplyPayload (parseGateProgram "
- ++ show "main = do bind\nx <- 2\n x" ++ ")"
- in result (evalTricu (Map.union portableParserEnv gateProgramEnv)
- (parseTricu expression)) @?= diagnostic
+ 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 "[]" "f = 2\nf |> let id x = x in id"
+ 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 =
@@ -4056,7 +2810,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, "main = do bind\n x <- 2\n do bind\n y <- x\n y\nbind a f = f a"
]
forM_ sources $ \source -> do
- check "[]" source (parserOk (ofNumber 2) Leaf)
+ 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)
@@ -4069,8 +2823,8 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, ("main = 2 |>\n (x : x)", ofNumber 2)
]
forM_ sources $ \(source, value) -> do
- check "[]" source (parserOk value Leaf)
- , testCase "multiline local let/where layout matches the bootstrap" $ 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)
@@ -4082,7 +2836,7 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, ("main = let id x = x in\n id\n 2", ofNumber 2)
]
forM_ sources $ \(source, value) -> do
- check "[]" source (parserOk value Leaf)
+ 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)
@@ -4092,50 +2846,49 @@ gateUnitTests = testGroup "Feasibility-gate program compiler"
, ("main = let x = t in (y : x) 2", Leaf)
]
forM_ sources $ \(source, value) -> do
- check "[]" source (parserOk value Leaf)
+ check Leaf source (parserOk value Leaf)
, testCase "local binding value has no self-reference" $
- check "[]" "main = let x = x in x" (parserErr
+ 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 "[]" "main = local where local = t\nlocal = 2"
+ check Leaf "main = local where local = t\nlocal = 2"
(parserOk Leaf Leaf)
, testCase "local free names order forward-referenced definitions" $
- check "[]" "main = value where value = helper t\nhelper x = x"
+ check Leaf "main = value where value = helper t\nhelper x = x"
(parserOk Leaf Leaf)
, testCase "lists may refer to forward definitions" $
- check "[]" "main = [(id 2)]\nid x = x"
+ 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 "[]" source (parserOk Leaf Leaf)
+ check Leaf source (parserOk Leaf Leaf)
, testCase "missing multiline definition body is a structured diagnostic" $
- check "[]" "main =\n" (parserErr
+ 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 "[]" "main = let x =\n" (parserErr
+ check Leaf "main = let x =\n" (parserErr
(portableDiagnostic (ofNumber 40)
(ofString "local binding value") Leaf Leaf Leaf) Leaf)
- check "[]" "main = let x = t in\n" (parserErr
+ 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 "[]" "helper = t" (parserErr
+ check Leaf "helper = t" (parserErr
(portableDiagnostic (ofNumber 32) (ofString "main") Leaf Leaf Leaf)
Leaf)
, testCase "cycle fails before result selection" $
- check "[]" "a = b\nb = a\nmain = t" (parserErr
+ 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 =
- result (evalTricu gateUnitEnv
- (parseTricu ("compileGateProgram " ++ external ++ " " ++ show source)))
+ foldl apply (gateUnitEnv Map.! "compileGateProgram") [external, ofString source]
@?= expected
-- --------------------------------------------------------------------------
@@ -4271,7 +3024,7 @@ gateCompilationTests = testGroup "Feasibility-gate source compiler"
packCompilerFile "./test/sourceGateCompiler.tri"
path [pack "matchesExpected"]
bytes <- BS.readFile path
- goldenEnv <- evaluateTestSupportFile "./test/sourceGateExpected.tri"
+ goldenEnv <- evaluateCompilerFile "./test/sourceGateExpected.tri"
let unknown = parserErr
(portableDiagnostic (ofNumber 20) (ofString "u") Leaf
(gatePosition 1 1 0) Leaf)
@@ -4490,8 +3243,9 @@ runRegistryEffects readReply = go (100 :: Int)
registryContractTests :: TestTree
registryContractTests = testCase "Registry hash contract: values, bounded rejection and read effects" $
withSystemTempDirectory "registry-contract" $ \dir -> do
- env <- evaluateTestSupportFile "./lib/arboricx/server.tri"
+ 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"
@@ -4535,7 +3289,7 @@ registryContractTests = testCase "Registry hash contract: values, bounded reject
[root, ofString "GET", ofString ("/_arboricx/bundle/hash/" ++ value)]
router value = call "arboricxRouter"
[root, ofString "GET", ofString ("/_arboricx/bundle/hash/" ++ value), Leaf, Leaf]
- rejected = call "badRequestResponse" [diagnostic]
+ 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 ->
@@ -4549,9 +3303,9 @@ registryContractTests = testCase "Registry hash contract: values, bounded reject
forM_ [serve hash, route valid, router valid] $ \action -> do
runRegistryEffects present action >>= (@?= ([expectedPath], response))
runRegistryEffects missing action >>=
- (@?= ([expectedPath], call "errorResponse" [ofNumber 404, ofString "missing"]))
- forM_ [("/_arboricx/health", call "okResponse" [ofString "OK\n"]),
- ("/", call "htmlResponse" [env Map.! "htmlLandingPage"])] $ \(target, expected) ->
+ (@?= ([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))
@@ -4559,7 +3313,7 @@ registryContractTests = testCase "Registry hash contract: values, bounded reject
registryPipelineTests :: TestTree
registryPipelineTests = testGroup "Registry publication and startup"
[ testCase "complete effects: atomic upload, traversal rejection, init and socket failures" $ do
- env <- evaluateTestSupportFile "./lib/arboricx/server.tri"
+ env <- evaluateCompilerFile "./lib/arboricx/server.tri"
let call name = foldl apply (env Map.! name)
root = ofString "/registry"
bytes = ofBytes (BS.pack [0,255,1])
@@ -4600,7 +3354,7 @@ registryPipelineTests = testGroup "Registry publication and startup"
>>= (@?= prefix "denied")
, testCase "filesystem: initialization, binary publication, replacement and concurrent uploads" $
withSystemTempDirectory "registry-publication" $ \dir -> do
- env <- evaluateTestSupportFile "./lib/arboricx/server.tri"
+ env <- evaluateCompilerFile "./lib/arboricx/server.tri"
let call name = foldl apply (env Map.! name)
rootPath = dir </> "store"
root = ofString rootPath
@@ -4656,8 +3410,8 @@ localControlTests = testGroup "Local control construction and non-strictness"
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 <- evaluateTestSupportFile "./lib/arboricx/server.tri"
- math <- evaluateTestSupportFile "./lib/math/native.tri"
+ 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
@@ -4682,7 +3436,7 @@ localControlTests = testGroup "Local control construction and non-strictness"
compileLocalControl :: [(String, T)] -> String -> IO T
compileLocalControl bindings source = do
- unit <- evaluateTestSupportFile "./lib/source/unit.tri"
+ 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 = ()
diff --git a/tricu.cabal b/tricu.cabal
@@ -207,6 +207,7 @@ test-suite tricu-tests
Wire
SupportFixture
LibraryValueTests
+ LibraryProgramTests
ParserValueTests
PortableTestCompiler
IODriverTests
