Back out the worst of the unsound nonsense
This commit is contained in:
252
test/Spec.hs
252
test/Spec.hs
@@ -3234,30 +3234,6 @@ 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")
|
||||
@@ -3339,232 +3315,10 @@ viewContractTests = testGroup "View Contract Tests"
|
||||
]
|
||||
readAlias store ModuleAlias "util" >>= (@?= Nothing)
|
||||
|
||||
, testCase "tricu check lowers free View variables under explicit Forall" $ do
|
||||
, testCase "tricu check rejects polymorphic View variables" $ 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"
|
||||
Left err -> assertBool "expected unsupported polymorphism diagnostic" $ "polymorphic View variables are unsupported" `isInfixOf` err
|
||||
Right _ -> assertFailure "expected polymorphic View rejection"
|
||||
|
||||
, 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"
|
||||
|
||||
Reference in New Issue
Block a user