James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Useful but limited polymorphism

Browse Source
This commit is contained in:
James Eversole
2026-05-25 17:54:04 -05:00
parent fdebb6c13d
commit a4fcc1cb36
18 changed files with 1781 additions and 130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

354
test/Spec.hs
View File

@@ -25,7 +25,7 @@ import System.FilePath ((</>))
import Data.Bits (xor)
import Data.Char (digitToInt)
import Data.List (find, isInfixOf)
import Data.Text (Text, unpack)
import Data.Text (Text, unpack, pack)
import Data.Word (Word8)
import Test.Tasty
import Test.Tasty.HUnit
@@ -77,25 +77,25 @@ allTestLibsEnv = unsafePerformIO $ do
tests :: TestTree
tests = testGroup "Tricu Tests"
[ lexer
, parser
, simpleEvaluation
, lambdas
, providedLibraries
, maybeTests
, fileEval
, demos
, decoding
, elimLambdaSingle
, stressElimLambda
, byteMarshallingTests
, wireTests
, tricuReaderTests
, byteListUtilities
, binaryParserTests
, httpParsingTests
, contentStoreTests
--, parser
--, simpleEvaluation
--, lambdas
--, providedLibraries
--, maybeTests
--, fileEval
--, demos
--, decoding
--, elimLambdaSingle
--, stressElimLambda
--, byteMarshallingTests
--, wireTests
--, tricuReaderTests
--, byteListUtilities
--, binaryParserTests
--, httpParsingTests
--, contentStoreTests
, viewContractTests
, ioDriverTests
--, ioDriverTests
]
lexer :: TestTree
@@ -1569,10 +1569,11 @@ contentStoreTests = testGroup "Content Store Tests"
(ObjectRef (unDomain treeTermDomain) "222")
"arboricx.abi.tree.v1"
(Just (ObjectRef viewContractTypeKind "333"))
(Just ViewChecked)
]
encoded = encodeManifest manifest
decodeManifest encoded @?= Right manifest
hashObject manifestDomain encoded @?= "7c3cb85454744894a403d2d12c7ece6d391c0cfbeb4bf3adfc7e69ae70ec4f5c"
hashObject manifestDomain encoded @?= "1392e0d406d5d1f2e013b0bff27ec3def4f68c045c75780ccb0380a1995f42c7"
, testCase "View Contract type artifacts: encode/decode round trip" $ do
let view = VTFn [VTList (VTName "String"), VTPair (VTName "Byte") (VTMaybe (VTRef 7))]
@@ -1583,6 +1584,11 @@ contentStoreTests = testGroup "Content Store Tests"
let view = VTFn [VTRefText "Nat"] (VTPair (VTRefText "Box") (VTName "String"))
decodeViewType (encodeViewType view) @?= Right view
, testCase "View Contract type artifacts: encode/decode quantified views" $ do
let view = VTForall [0] (VTFn [VTVar 0] (VTVar 0))
decodeViewType (encodeViewType view) @?= Right view
treeToViewType (viewTypeToTree view) @?= Right view
, testCase "View Contract type artifacts: encode/decode guarded views with opaque guard trees" $ do
let guardTree = Fork (Stem Leaf) Leaf
view = VTGuarded (VTRefText "UserId") guardTree
@@ -1615,6 +1621,7 @@ contentStoreTests = testGroup "Content Store Tests"
(ObjectRef (unDomain treeTermDomain) root)
"arboricx.abi.tree.v1"
Nothing
Nothing
]
root <- putTreeTerm store term
h <- putManifest store (manifestFor root)
@@ -1632,6 +1639,7 @@ contentStoreTests = testGroup "Content Store Tests"
(ObjectRef (unDomain treeTermDomain) termH)
"arboricx.abi.tree.v1"
Nothing
Nothing
]
manifestBytes = encodeManifest manifest
manifestH = hashObject manifestDomain manifestBytes
@@ -1896,6 +1904,7 @@ contentStoreTests = testGroup "Content Store Tests"
(ObjectRef (unDomain treeTermDomain) root)
"arboricx.abi.tree.v1"
Nothing
Nothing
]
root <- putTreeTerm store term
manifestHash <- putManifest store (manifestFor root)
@@ -1928,7 +1937,7 @@ contentStoreTests = testGroup "Content Store Tests"
, testCase "Module resolver diagnostics: missing tree term names export and hash" $ do
let root = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
manifest = ModuleManifest []
[ ModuleExport "value" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing ]
[ ModuleExport "value" (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1" Nothing Nothing ]
resolver = ObjectResolver
{ resolverAlias = \kind name -> return $ if kind == ModuleAlias && name == "demo"
then Just (ObjectRef (unDomain manifestDomain) "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb")
@@ -2762,7 +2771,7 @@ viewContractTests = testGroup "View Contract Tests"
, testCase "Portable View Contract self-tests all pass" $ do
let input = "viewContractSelfTests"
env = evalTricu allTestLibsEnv (parseTricu input)
result env @?= ofList (replicate 32 (ofString "ok"))
result env @?= ofList (replicate 35 (ofString "ok"))
, testCase "Structured diagnostic tag reports required-view failures" $ do
let input = "checkerResultErrorTag (checkTypedProgramWith policyStrict listMapWrongOutputContract)"
@@ -2812,25 +2821,25 @@ viewContractTests = testGroup "View Contract Tests"
output @?= "symbol 1 (external bar) expected Fn [Bool] Bool but got Any"
, testCase "tricu check accepts trusted imported View Contract facts" $ do
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool")) ViewChecked]
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
output @?= "ok"
, testCase "tricu check judges imported View Contract facts in checker" $ do
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "String"))]
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "String")) ViewChecked]
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
output @?= "symbol 3 (Ext.id application result) expected Bool but got String"
, testCase "tricu lower emits imported View Contract facts as view-tree nodes" $ do
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
let imported = [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool")) ViewChecked]
case lowerSourceWithImportedViews imported "foo x@Bool =@Bool Ext.id x\n" of
Left err -> assertFailure err
Right lowered -> lowered @?= "typedProgram 3 [(typedValue 1 (viewFn [(viewBool)] (viewBool)) t) (typedValue 0 (viewFn [(viewBool)] (viewBool)) t) (typedValue 2 (viewBool) t) (typedRequire 2 (viewBool) t) (typedApply 3 1 2 t) (typedRequire 3 (viewBool) t)]"
Right lowered -> lowered @?= "typedProgram 3 [(typedValueWithProvenance 1 (viewFn [(viewBool)] (viewBool)) t viewProvenanceChecked) (typedValueWithProvenance 0 (viewFn [(viewBool)] (viewBool)) t viewProvenanceChecked) (typedValueWithProvenance 2 (viewBool) t viewProvenanceChecked) (typedRequire 2 (viewBool) t) (typedApply 3 1 2 t) (typedRequire 3 (viewBool) t)]"
, testCase "tricu lower emits symbolic View Contract refs in view-tree nodes" $ do
case lowerSource "foo x@(Ref \"UserId\") =@(Ref \"UserId\") x\n" of
Left err -> assertFailure err
Right lowered -> lowered @?= "typedProgram 1 [(typedValue 0 (viewFn [(viewRef \"UserId\")] (viewRef \"UserId\")) t) (typedValue 1 (viewRef \"UserId\") t) (typedRequire 1 (viewRef \"UserId\") t)]"
Right lowered -> lowered @?= "typedProgram 1 [(typedValueWithProvenance 0 (viewFn [(viewRef \"UserId\")] (viewRef \"UserId\")) t viewProvenanceChecked) (typedValueWithProvenance 1 (viewRef \"UserId\") t viewProvenanceChecked) (typedRequire 1 (viewRef \"UserId\") t)]"
, testCase "tricu check converts resolved module export views into imported facts" $ do
let viewRef = ObjectRef viewContractTypeKind "abc123"
@@ -2840,6 +2849,7 @@ viewContractTests = testGroup "View Contract Tests"
, resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456"
, resolvedExportAbi = "arboricx.abi.tree.v1"
, resolvedExportView = Just viewRef
, resolvedExportProvenance = Just ViewChecked
, resolvedExportTerm = Leaf
}
resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport]
@@ -2847,10 +2857,28 @@ viewContractTests = testGroup "View Contract Tests"
then Just (VTFn [VTName "Bool"] (VTName "Bool"))
else Nothing
imported <- importedViewsFromResolvedModules loadView [resolvedModule]
imported @?= [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool"))]
imported @?= [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool")) ViewChecked]
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "foo x@Bool =@Bool Ext.id x\n"
output @?= "ok"
, testCase "tricu check marks missing import provenance as unchecked" $ do
let viewRef = ObjectRef viewContractTypeKind "abc123"
resolvedExport = ResolvedExport
{ resolvedExportSourceName = "id"
, resolvedExportLocalName = "Ext.id"
, resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456"
, resolvedExportAbi = "arboricx.abi.tree.v1"
, resolvedExportView = Just viewRef
, resolvedExportProvenance = Nothing
, resolvedExportTerm = Leaf
}
resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport]
loadView ref = pure $ if ref == viewRef
then Just (VTFn [VTName "Bool"] (VTName "Bool"))
else Nothing
imported <- importedViewsFromResolvedModules loadView [resolvedModule]
imported @?= [ImportedView "Ext.id" (VTFn [VTName "Bool"] (VTName "Bool")) ViewUnchecked]
, testCase "tricu check reports missing resolved View Contract artifacts" $ do
let viewRef = ObjectRef viewContractTypeKind "abc123"
resolvedExport = ResolvedExport
@@ -2859,6 +2887,7 @@ viewContractTests = testGroup "View Contract Tests"
, resolvedExportObject = ObjectRef (unDomain treeTermDomain) "def456"
, resolvedExportAbi = "arboricx.abi.tree.v1"
, resolvedExportView = Just viewRef
, resolvedExportProvenance = Just ViewChecked
, resolvedExportTerm = Leaf
}
resolvedModule = ResolvedModule "ext" "Ext" "manifest-hash" [resolvedExport]
@@ -3018,7 +3047,7 @@ viewContractTests = testGroup "View Contract Tests"
assertBool "expected String payload requirement" $
"typedRequire 1 (viewString)" `isInfixOf` lowered
assertBool "expected Maybe String constructor declaration" $
"typedValue 2 (viewMaybe (viewString))" `isInfixOf` lowered
"typedValueWithProvenance 2 (viewMaybe (viewString))" `isInfixOf` lowered
, testCase "tricu check lowerSource emits expected Fn argument typed nodes" $ do
case lowerSource "f x@String =@String x\ny =@String f 1\n" of
@@ -3032,7 +3061,7 @@ viewContractTests = testGroup "View Contract Tests"
Left err -> assertFailure err
Right lowered -> do
assertBool "expected lambda binder declaration" $
"typedValue 1 (viewString) t" `isInfixOf` lowered
"typedValueWithProvenance 1 (viewString) t viewProvenanceChecked" `isInfixOf` lowered
assertBool "expected lambda body requirement" $
"typedRequire 1 (viewString) t" `isInfixOf` lowered
@@ -3041,9 +3070,9 @@ viewContractTests = testGroup "View Contract Tests"
Left err -> assertFailure err
Right lowered -> do
assertBool "expected Byte evidence for literal element" $
"typedValue 1 (viewByte)" `isInfixOf` lowered
"typedValueWithProvenance 1 (viewByte)" `isInfixOf` lowered
assertBool "expected actual Byte tree payload for literal element" $
"typedValue 1 (viewByte) (t (t t) t)" `isInfixOf` lowered
"typedValueWithProvenance 1 (viewByte) (t (t t) t) viewProvenanceChecked" `isInfixOf` lowered
assertBool "expected String requirement for list element" $
"typedRequire 1 (viewString)" `isInfixOf` lowered
@@ -3061,7 +3090,7 @@ viewContractTests = testGroup "View Contract Tests"
Left err -> assertFailure err
Right lowered -> do
assertBool "expected callback lambda declaration" $
"typedValue 12 (viewFn [(viewString)] (viewMaybe (viewString))) t" `isInfixOf` lowered
"typedValueWithProvenance 12 (viewFn [(viewString)] (viewMaybe (viewString))) t viewProvenanceChecked" `isInfixOf` lowered
assertBool "expected bind application to declared callback" $
"typedApply 13 9 12 t" `isInfixOf` lowered
@@ -3131,14 +3160,14 @@ viewContractTests = testGroup "View Contract Tests"
, testCase "imported VTGuarded lowers to portable viewGuarded" $ do
let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)"))
imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))]
imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String")) ViewChecked]
case lowerSourceWithImportedViews imported "main =@String Ext.id \"x\"\n" of
Left err -> assertFailure err
Right lowered -> assertBool "expected imported guarded view to survive lowering" $ "viewGuarded" `isInfixOf` lowered
, testCase "tricu check runs imported guarded argument failure" $ do
let failGuard = result (evalTricu allTestLibsEnv (parseTricu "(x : guardFail)"))
imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String"))]
imported = [ImportedView "Ext.id" (VTFn [VTGuarded (VTName "String") failGuard] (VTName "String")) ViewChecked]
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "main =@String Ext.id \"x\"\n"
output @?= "guard failed at typedRequire symbol 2 for Guarded String"
@@ -3187,6 +3216,30 @@ viewContractTests = testGroup "View Contract Tests"
view <- getViewType store viewRef
view @?= Right (VTFn [VTRef 10] (VTRef 10))
, testCase "Workspace modules publish explicitly quantified polymorphic views" $
withSystemTempDirectory "tricu-workspace-polymorphic-view" $ \dir -> do
let store = StorePath (dir </> "store")
utilPath = dir </> "util.tri"
mainPath = dir </> "main.tri"
writeFile (dir </> "tricu.workspace") "module util = util.tri\n"
writeFile utilPath "idP x@_a =@_a x\n"
writeFile mainPath "!import \"util\" Util\n\nmain =@String Util.idP \"hi\"\n"
_ <- evaluateFileWithStore (Just store) mainPath
mAlias <- readAlias store ModuleAlias "util"
case mAlias of
Nothing -> assertFailure "expected util module alias"
Just ref -> do
mManifest <- getManifest store (objectRefHash ref)
case mManifest of
Nothing -> assertFailure "expected util module manifest"
Just manifest -> case find ((== "idP") . unpack . moduleExportName) (moduleManifestExports manifest) of
Nothing -> assertFailure "expected idP export"
Just ex -> case moduleExportView ex of
Nothing -> assertFailure "expected idP view ref"
Just viewRef -> do
view <- getViewType store viewRef
view @?= Right (VTForall [0] (VTFn [VTVar 0] (VTVar 0)))
, testCase "Workspace modules publish string custom view aliases" $
withSystemTempDirectory "tricu-workspace-string-view-alias" $ \dir -> do
let store = StorePath (dir </> "store")
@@ -3234,6 +3287,7 @@ viewContractTests = testGroup "View Contract Tests"
Just ex -> do
objectRefKind (moduleExportObject ex) @?= viewTreeKind
moduleExportAbi ex @?= "arboricx.abi.view-tree.v1"
moduleExportViewProvenance ex @?= Just ViewChecked
loadedTree <- getViewTree store (moduleExportObject ex)
case moduleExportView ex of
Nothing -> assertFailure "expected idUser view ref"
@@ -3245,7 +3299,8 @@ viewContractTests = testGroup "View Contract Tests"
Left err -> assertFailure err
Right tree -> do
rootTerm <- either assertFailure pure (viewTreeRootTerm tree)
tree @?= singletonViewTree (Just expectedView) rootTerm
viewTreeRootViewFact tree @?= Right (Just (expectedView, ViewChecked))
tree @?= singletonViewTreeWithProvenance (Just (expectedView, ViewChecked)) rootTerm
, testCase "Workspace modules reject malformed custom view aliases" $
withSystemTempDirectory "tricu-workspace-malformed-view-alias" $ \dir -> do
@@ -3266,6 +3321,233 @@ viewContractTests = testGroup "View Contract Tests"
]
readAlias store ModuleAlias "util" >>= (@?= Nothing)
, testCase "tricu check lowers free View variables under explicit Forall" $ do
case lowerSource "idP x@_a =@_a x\n" of
Left err -> assertFailure err
Right lowered -> do
assertBool "expected polymorphic declaration to be explicitly quantified" $ "viewForall [(0)]" `isInfixOf` lowered
assertBool "expected quantified identity function body" $ "viewFn [(viewVar 0)] (viewVar 0)" `isInfixOf` lowered
, testCase "tricu check supports first-order polymorphic identity View variables" $ do
output <- checkSourceWithEnv allTestLibsEnv "idP x@_a =@_a x\nmain =@String idP \"hi\"\n"
output @?= "ok"
, testCase "tricu check propagates first-order polymorphic result relationships" $ do
output <- checkSourceWithEnv allTestLibsEnv "constP x@_a y@_b =@_a x\nmain =@String constP \"hi\" 1\n"
output @?= "ok"
, testCase "tricu check instantiates quantified Views at higher-order boundaries" $ do
output <- checkSourceWithEnv allTestLibsEnv "idP x@_a =@_a x\ncomposeP f@(Fn [_b] _c) g@(Fn [_a] _b) x@_a =@_c f (g x)\nmain =@String composeP idP idP \"hi\"\n"
output @?= "ok"
, testCase "tricu check matches quantified values against concrete Fn requirements" $ do
output <- checkSourceWithEnv allTestLibsEnv "idP x@_a =@_a x\nacceptSS f@(Fn [String] String) =@String f \"hi\"\nmain =@String acceptSS idP\n"
output @?= "ok"
, testCase "tricu check propagates nested polymorphic List relationships" $ do
output <- checkSourceWithEnv allTestLibsEnv "idList xs@(List _a) =@(List _a) xs\nmain =@(List String) idList [(\"hi\")]\n"
output @?= "ok"
, testCase "tricu check keeps polymorphic instantiation acyclic for reciprocal higher-order constraints" $ do
output <- checkSourceWithEnv allTestLibsEnv "idP x@_a =@_a x\nrel f@(Fn [_a] _b) g@(Fn [_b] _a) =@String \"ok\"\nmain =@String rel idP idP\n"
output @?= "ok"
, testCase "tricu check supports first-principles parametric stdlib island shapes" $ do
output <- checkSourceWithEnv allTestLibsEnv "idV x@_a =@_a x\nconstV x@_a y@_b =@_a x\ncomposeV f@(Fn [_b] _c) g@(Fn [_a] _b) x@_a =@_c f (g x)\nmain =@String composeV idV (constV \"hi\") 1\n"
output @?= "ok"
, testCase "tricu check rejects raw triage in parametric annotated definitions" $ do
output <- checkSourceWithEnv allTestLibsEnv "bad x@_a =@String triage \"leaf\" (_ : \"stem\") (_ _ : \"fork\") x\n"
output `containsAll` ["parametric View definition \"bad\"", "uses raw triage directly", "trusted eliminator boundary"]
, testCase "tricu check rejects raw t in parametric annotated definitions" $ do
output <- checkSourceWithEnv allTestLibsEnv "bad x@_a =@_a t\n"
output `containsAll` ["parametric View definition \"bad\"", "uses raw t directly", "trusted eliminator boundary"]
, testCase "tricu check rejects parametric definitions depending on local raw helpers" $ do
output <- checkSourceWithEnv allTestLibsEnv "raw x = triage \"leaf\" (_ : \"stem\") (_ _ : \"fork\") x\nbad x@_a =@String raw x\n"
output `containsAll` ["parametric View definition \"bad\"", "raw-tainted local helper \"raw\"", "uses raw triage directly"]
, testCase "tricu check rejects parametric definitions depending on unchecked imported facts" $ do
let imported = [ImportedView "Ext.raw" (VTFn [VTVar 0] (VTName "String")) ViewUnchecked]
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv imported "bad x@_a =@String Ext.raw x\n"
output `containsAll` ["parametric View definition \"bad\"", "unchecked or unknown external name \"Ext.raw\""]
, testCase "tricu check accepts parametric code through value-level trusted stdlib facts" $ do
facts <- either assertFailure pure (valueViewFactsFromEnv allTestLibsEnv)
let source = "idP x@_a =@_a x\nmaybeOrV default@_a m@(Maybe _a) =@_a matchMaybe default idP m\n"
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv facts source
output @?= "ok"
, testCase "unused value-level trusted facts do not perturb root selection" $ do
facts <- either assertFailure pure (valueViewFactsFromEnv allTestLibsEnv)
output <- checkSourceWithEnvAndImportedViews allTestLibsEnv facts "idP x@_a =@_a x\n"
output @?= "ok"
, testCase "value-level trusted stdlib facts lower with Trusted provenance" $ do
facts <- either assertFailure pure (valueViewFactsFromEnv allTestLibsEnv)
case lowerSourceWithImportedViews facts "notV x@Bool =@Bool matchBool false true x\n" of
Left err -> assertFailure err
Right lowered -> assertBool "expected trusted provenance in lowered view tree" $ "typedValueWithProvenance" `isInfixOf` lowered && "viewProvenanceTrusted" `isInfixOf` lowered
, testCase "tricu check uses annotated id const compose through re-export modules" $
withSystemTempDirectory "tricu-stdlib-prelude-views" $ \dir -> do
let store = StorePath (dir </> "store")
basePath = dir </> "mybase.tri"
preludePath = dir </> "myprelude.tri"
mainPath = dir </> "main.tri"
writeFile (dir </> "tricu.workspace") "module mybase = mybase.tri\nmodule myprelude = myprelude.tri\n"
writeFile basePath "id a@_a =@_a a\nconst a@_a b@_b =@_a a\ncompose f@(Fn [_b] _c) g@(Fn [_a] _b) x@_a =@_c f (g x)\n"
writeFile preludePath "!import \"mybase\" !Local\n"
writeFile mainPath "!import \"myprelude\" !Local\nmain =@String compose id (const \"hi\") 1\n"
output <- checkFileWithStore store mainPath
output @?= "ok"
, testCase "Workspace value-level viewFacts export and re-export Trusted provenance" $
withSystemTempDirectory "tricu-workspace-value-view-facts" $ \dir -> do
let store = StorePath (dir </> "store")
depPath = dir </> "dep.tri"
shimPath = dir </> "shim.tri"
mainPath = dir </> "main.tri"
factBlock = unlines
[ "factsPair = t"
, "factsFact name provenance view = factsPair name (factsPair provenance view)"
, "factsTrusted = 1"
, "factsField tag value = factsPair tag value"
, "factsRecord tag fields = factsPair tag fields"
, "factsVar id = factsRecord 8 [(factsField 10 id)]"
, "factsForall binders body = factsRecord 9 [(factsField 11 binders) (factsField 12 body)]"
, "factsFn args result = factsRecord 1 [(factsField 0 args) (factsField 1 result)]"
, "viewFacts = [(factsFact \"rawId\" factsTrusted (factsForall [0] (factsFn [(factsVar 0)] (factsVar 0))))]"
]
expected = VTForall [0] (VTFn [VTVar 0] (VTVar 0))
writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule shim = shim.tri\n"
writeFile depPath ("rawId x = x\n" ++ factBlock)
writeFile shimPath "!import \"dep\" !Local\n"
writeFile mainPath "!import \"shim\" Shim\nmain x@_a =@_a Shim.rawId x\n"
output <- checkFileWithStore store mainPath
output @?= "ok"
forM_ [("dep", "rawId"), ("shim", "rawId")] $ \(moduleName, exportName) -> do
mAlias <- readAlias store ModuleAlias (pack moduleName)
case mAlias of
Nothing -> assertFailure ("expected " ++ moduleName ++ " module alias")
Just ref -> do
mManifest <- getManifest store (objectRefHash ref)
case mManifest of
Nothing -> assertFailure ("expected " ++ moduleName ++ " module manifest")
Just manifest -> do
assertBool ("viewFacts should not be exported from " ++ moduleName) $
all ((/= "viewFacts") . unpack . moduleExportName) (moduleManifestExports manifest)
case find ((== exportName) . unpack . moduleExportName) (moduleManifestExports manifest) of
Nothing -> assertFailure ("expected " ++ exportName ++ " export from " ++ moduleName)
Just ex -> do
moduleExportViewProvenance ex @?= Just ViewTrusted
case moduleExportView ex of
Nothing -> assertFailure "expected trusted value-level view ref"
Just viewRef -> do
view <- getViewType store viewRef
view @?= Right expected
, testCase "value-level viewFacts decoder reports malformed fact context" $ do
let env = evalTricu Map.empty (parseTricu "viewFacts = [(t \"bad\" (t 9 t))]\n")
case valueViewFactsFromEnv env of
Right _ -> assertFailure "expected malformed provenance error"
Left err -> err `containsAll` ["viewFacts[0]", "bad", "invalid provenance", "unknown provenance tag 9"]
, testCase "value-level viewFacts decoder reports malformed View context" $ do
let env = evalTricu Map.empty (parseTricu "viewFacts = [(t \"bad\" (t 1 (t 9 [])))]\n")
case valueViewFactsFromEnv env of
Right _ -> assertFailure "expected malformed View error"
Left err -> err `containsAll` ["viewFacts[0]", "bad", "malformed View"]
, testCase "value-level viewFacts decoder rejects duplicate fact names" $ do
let env = evalTricu Map.empty (parseTricu "v = t 9 [(t 11 []) (t 12 (t 0 []))]\nviewFacts = [(t \"dup\" (t 1 v)) (t \"dup\" (t 1 v))]\n")
case valueViewFactsFromEnv env of
Right _ -> assertFailure "expected duplicate viewFacts error"
Left err -> err `containsAll` ["duplicate viewFacts entry", "dup"]
, testCase "Workspace modules reject viewFacts for non-exported names" $
withSystemTempDirectory "tricu-workspace-view-facts-nonexport" $ \dir -> do
let store = StorePath (dir </> "store")
depPath = dir </> "dep.tri"
mainPath = dir </> "main.tri"
writeFile (dir </> "tricu.workspace") "module dep = dep.tri\n"
writeFile depPath "rawId x = x\nv = t 9 [(t 11 []) (t 12 (t 0 []))]\nviewFacts = [(t \"missing\" (t 1 v))]\n"
writeFile mainPath "!import \"dep\" Dep\nmain = Dep.rawId t\n"
outcome <- try (evaluateFileWithStore (Just store) mainPath) :: IO (Either SomeException Env)
case outcome of
Right _ -> assertFailure "expected non-exported viewFacts rejection"
Left err -> show err `containsAll` ["viewFacts for non-exported name", "missing"]
, testCase "stdlib list value-level facts publish Trusted contracts" $
withSystemTempDirectory "tricu-stdlib-list-view-facts" $ \dir -> do
let store = StorePath (dir </> "store")
basePath = dir </> "base.tri"
listPath = dir </> "list.tri"
mainPath = dir </> "main.tri"
baseSource <- readFile "./lib/base.tri"
listSource <- readFile "./lib/list.tri"
writeFile (dir </> "tricu.workspace") "module base = base.tri\nmodule list = list.tri\n"
writeFile basePath baseSource
writeFile listPath listSource
writeFile mainPath "!import \"list\" L\ninc x@Byte =@Byte x\nmain xs@(List Byte) =@(List Byte) L.map inc xs\n"
output <- checkFileWithStore store mainPath
output @?= "ok"
mAlias <- readAlias store ModuleAlias (pack "list")
case mAlias of
Nothing -> assertFailure "expected list module alias"
Just ref -> do
mManifest <- getManifest store (objectRefHash ref)
case mManifest of
Nothing -> assertFailure "expected list module manifest"
Just manifest -> do
let trustedNames =
[ "emptyList?", "tail", "append", "lExist?", "map", "filter"
, "foldl", "foldr", "length", "reverse", "snoc", "count"
, "all?", "any?", "intersect", "headMaybe", "lastMaybe"
, "nthMaybe", "take", "drop", "splitAt", "concatMap", "find"
, "partition", "strLength", "strAppend", "strEq?", "strEmpty?"
, "startsWith?", "endsWith?", "contains?", "lines", "unlines"
, "words", "unwords", "zipWith"
]
forM_ trustedNames $ \exportName ->
case find ((== exportName) . unpack . moduleExportName) (moduleManifestExports manifest) of
Nothing -> assertFailure ("expected " ++ exportName ++ " export")
Just ex -> moduleExportViewProvenance ex @?= Just ViewTrusted
, testCase "Workspace re-export-only modules preserve imported View Contracts" $
withSystemTempDirectory "tricu-workspace-reexport-views" $ \dir -> do
let store = StorePath (dir </> "store")
depPath = dir </> "dep.tri"
shimPath = dir </> "shim.tri"
mainPath = dir </> "main.tri"
writeFile (dir </> "tricu.workspace") "module dep = dep.tri\nmodule shim = shim.tri\n"
writeFile depPath "idP x@_a =@_a x\n"
writeFile shimPath "!import \"dep\" !Local\n"
writeFile mainPath "!import \"shim\" Shim\nmain =@String Shim.idP \"hi\"\n"
output <- checkFileWithStore store mainPath
output @?= "ok"
mAlias <- readAlias store ModuleAlias "shim"
case mAlias of
Nothing -> assertFailure "expected shim module alias"
Just ref -> do
mManifest <- getManifest store (objectRefHash ref)
case mManifest of
Nothing -> assertFailure "expected shim module manifest"
Just manifest -> case find ((== "idP") . unpack . moduleExportName) (moduleManifestExports manifest) of
Nothing -> assertFailure "expected idP re-export"
Just ex -> do
moduleExportViewProvenance ex @?= Just ViewChecked
case moduleExportView ex of
Nothing -> assertFailure "expected idP re-export view ref"
Just viewRef -> do
view <- getViewType store viewRef
view @?= Right (VTForall [0] (VTFn [VTVar 0] (VTVar 0)))
, testCase "tricu check rejects inconsistent first-order polymorphic View bindings" $ do
output <- checkSourceWithEnv allTestLibsEnv "same x@_a y@_a =@_a x\nmain =@String same \"hi\" 1\n"
output @?= "symbol 6 (byte literal) expected String but got Byte"
, testCase "tricu check catches undersaturated annotated function calls via residual Fn view" $ do
output <- checkSourceWithEnv allTestLibsEnv "f x@String y@String =@String x\nmain =@String f \"a\"\n"
output @?= "symbol 5 (f application result) expected String but got Fn [String] String"