From 82328890108bae64b372b8d58620ebc62699de76 Mon Sep 17 00:00:00 2001 From: adelon <22380201+adelon@users.noreply.github.com> Date: Thu, 6 Aug 2026 17:54:00 +0200 Subject: Migrate to `Felix` namespace --- source/Felix/Test/All.hs | 14 + source/Felix/Test/Golden.hs | 86 + source/Felix/Test/Unit.hs | 52 + source/Felix/Test/Unit/Abstract.hs | 114 + source/Felix/Test/Unit/Backend.hs | 752 +++ source/Felix/Test/Unit/CommandLine.hs | 799 +++ source/Felix/Test/Unit/Concrete.hs | 221 + source/Felix/Test/Unit/Core.hs | 670 ++ source/Felix/Test/Unit/Declaration.hs | 3596 +++++++++++ source/Felix/Test/Unit/Foundation.hs | 284 + source/Felix/Test/Unit/Html.hs | 225 + source/Felix/Test/Unit/HtmlLayout.hs | 478 ++ source/Felix/Test/Unit/HtmlOutput.hs | 560 ++ source/Felix/Test/Unit/Identity.hs | 802 +++ source/Felix/Test/Unit/Kernel.hs | 858 +++ source/Felix/Test/Unit/Lexicon.hs | 333 + source/Felix/Test/Unit/Materialization.hs | 357 ++ source/Felix/Test/Unit/Meaning.hs | 1119 ++++ source/Felix/Test/Unit/Module.hs | 9759 +++++++++++++++++++++++++++++ source/Felix/Test/Unit/OutputPlan.hs | 236 + source/Felix/Test/Unit/Provers.hs | 1159 ++++ source/Felix/Test/Unit/Semantic.hs | 437 ++ source/Felix/Test/Unit/Source.hs | 2581 ++++++++ source/Felix/Test/Unit/Store.hs | 1675 +++++ source/Felix/Test/Unit/Token.hs | 285 + 25 files changed, 27452 insertions(+) create mode 100644 source/Felix/Test/All.hs create mode 100644 source/Felix/Test/Golden.hs create mode 100644 source/Felix/Test/Unit.hs create mode 100644 source/Felix/Test/Unit/Abstract.hs create mode 100644 source/Felix/Test/Unit/Backend.hs create mode 100644 source/Felix/Test/Unit/CommandLine.hs create mode 100644 source/Felix/Test/Unit/Concrete.hs create mode 100644 source/Felix/Test/Unit/Core.hs create mode 100644 source/Felix/Test/Unit/Declaration.hs create mode 100644 source/Felix/Test/Unit/Foundation.hs create mode 100644 source/Felix/Test/Unit/Html.hs create mode 100644 source/Felix/Test/Unit/HtmlLayout.hs create mode 100644 source/Felix/Test/Unit/HtmlOutput.hs create mode 100644 source/Felix/Test/Unit/Identity.hs create mode 100644 source/Felix/Test/Unit/Kernel.hs create mode 100644 source/Felix/Test/Unit/Lexicon.hs create mode 100644 source/Felix/Test/Unit/Materialization.hs create mode 100644 source/Felix/Test/Unit/Meaning.hs create mode 100644 source/Felix/Test/Unit/Module.hs create mode 100644 source/Felix/Test/Unit/OutputPlan.hs create mode 100644 source/Felix/Test/Unit/Provers.hs create mode 100644 source/Felix/Test/Unit/Semantic.hs create mode 100644 source/Felix/Test/Unit/Source.hs create mode 100644 source/Felix/Test/Unit/Store.hs create mode 100644 source/Felix/Test/Unit/Token.hs (limited to 'source/Felix/Test') diff --git a/source/Felix/Test/All.hs b/source/Felix/Test/All.hs new file mode 100644 index 0000000..7cdc49c --- /dev/null +++ b/source/Felix/Test/All.hs @@ -0,0 +1,14 @@ +module Felix.Test.All where + + +import Base +import Felix.Test.Golden +import Felix.Test.Unit +import Test.Tasty + + +runTests :: IO () +runTests = defaultMain =<< tests + +tests :: IO TestTree +tests = testGroup "all tests" <$> sequence [goldenTests, return unitTests] diff --git a/source/Felix/Test/Golden.hs b/source/Felix/Test/Golden.hs new file mode 100644 index 0000000..905ff73 --- /dev/null +++ b/source/Felix/Test/Golden.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +module Felix.Test.Golden where + + +import Base +import Felix.Workspace qualified as Workspace + +import Data.Text.Lazy.IO qualified as LazyTextIO +import System.Directory +import System.FilePath +import Test.Tasty +import Test.Tasty.Golden (goldenVsFile, findByExtension) +import Text.Pretty.Simple (pShowNoColor) +import UnliftIO +goldenTests :: IO TestTree +goldenTests = goldenTestGroup + +goldenTestGroup :: MonadUnliftIO io => io TestTree +goldenTestGroup = testGroup "golden tests" <$> sequence + [ tokenizing + , scanning + , parsing + ] + + +-- | A testing triple consists of a an 'input' file, which is proccesed, resulting +-- in 'output' file, which is then compared to a 'golden' file. +data Triple = Triple + { input :: FilePath + , output :: FilePath + , golden :: FilePath + } + deriving (Show, Eq) + + +-- | Gathers all the files for the test. We test all examples and everything in @test/pass/@. +-- The golden files for all tests are stored in @test/pass/@, so we need to adjust the filepath +-- of the files from @examples/@. +gatherTriples :: MonadIO io => String -> io [Triple] +gatherTriples stage = do + inputs <- liftIO (findByExtension [".tex"] "test/examples") + pure $ + [ Triple{..} + | input <- inputs + , let input' = "test" "golden" takeBaseName input stage + , let golden = input' <.> "golden" + , let output = input' <.> "out" + ] + +createTripleDirectoriesIfMissing :: MonadIO io => Triple -> io () +createTripleDirectoriesIfMissing Triple{..} = liftIO $ + createDirectoryIfMissing True (takeDirectory output) + +makeGoldenTest :: MonadUnliftIO io => String -> (Triple -> io ()) -> io TestTree +makeGoldenTest stage action = do + triples <- gatherTriples stage + for triples createTripleDirectoriesIfMissing + runInIO <- askRunInIO + pure $ testGroup stage + [ goldenVsFile + (takeBaseName input) -- test name + golden + output + (runInIO (action triple)) + | triple@Triple{..} <- triples + ] + +tokenizing :: MonadUnliftIO io => io TestTree +tokenizing = makeGoldenTest "tokenizing" $ \Triple{..} -> do + tokenStream <- liftIO (Workspace.tokenize input) + liftIO + (LazyTextIO.writeFile output + (pShowNoColor (Workspace.simpleStream tokenStream))) + + +scanning :: MonadUnliftIO io => io TestTree +scanning = makeGoldenTest "scanning" $ \Triple{..} -> do + lexicalItems <- liftIO (Workspace.scan input) + liftIO (LazyTextIO.writeFile output (pShowNoColor lexicalItems)) + +parsing :: MonadUnliftIO io => io TestTree +parsing = makeGoldenTest "parsing" $ \Triple{..} -> do + parseResult <- liftIO (Workspace.parse input) + liftIO (LazyTextIO.writeFile output (pShowNoColor parseResult)) diff --git a/source/Felix/Test/Unit.hs b/source/Felix/Test/Unit.hs new file mode 100644 index 0000000..f11d21f --- /dev/null +++ b/source/Felix/Test/Unit.hs @@ -0,0 +1,52 @@ +module Felix.Test.Unit where + + +import Felix.Test.Unit.Abstract qualified as Abstract +import Felix.Test.Unit.Backend qualified as Backend +import Felix.Test.Unit.CommandLine qualified as CommandLine +import Felix.Test.Unit.Concrete qualified as Concrete +import Felix.Test.Unit.Core qualified as Core +import Felix.Test.Unit.Declaration qualified as Declaration +import Felix.Test.Unit.Foundation qualified as Foundation +import Felix.Test.Unit.Html qualified as Html +import Felix.Test.Unit.HtmlLayout qualified as HtmlLayout +import Felix.Test.Unit.HtmlOutput qualified as HtmlOutput +import Felix.Test.Unit.Identity qualified as Identity +import Felix.Test.Unit.Kernel qualified as Kernel +import Felix.Test.Unit.Lexicon qualified as Lexicon +import Felix.Test.Unit.Materialization qualified as Materialization +import Felix.Test.Unit.Meaning qualified as Meaning +import Felix.Test.Unit.Module qualified as Module +import Felix.Test.Unit.OutputPlan qualified as OutputPlan +import Felix.Test.Unit.Provers qualified as Provers +import Felix.Test.Unit.Semantic qualified as Semantic +import Felix.Test.Unit.Source qualified as Source +import Felix.Test.Unit.Store qualified as Store +import Felix.Test.Unit.Token qualified as Token +import Test.Tasty + +unitTests :: TestTree +unitTests = testGroup "unit tests" + [ Abstract.unitTests + , Backend.unitTests + , CommandLine.unitTests + , Concrete.unitTests + , Core.unitTests + , Declaration.unitTests + , Foundation.unitTests + , Identity.unitTests + , Html.unitTests + , HtmlLayout.unitTests + , HtmlOutput.unitTests + , Kernel.unitTests + , Lexicon.unitTests + , Meaning.unitTests + , Materialization.unitTests + , Module.unitTests + , OutputPlan.unitTests + , Provers.unitTests + , Semantic.unitTests + , Source.unitTests + , Store.unitTests + , Token.unitTests + ] diff --git a/source/Felix/Test/Unit/Abstract.hs b/source/Felix/Test/Unit/Abstract.hs new file mode 100644 index 0000000..c487c2a --- /dev/null +++ b/source/Felix/Test/Unit/Abstract.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Abstract (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Abstract + +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.Hedgehog (testPropertyNamed) + +unitTests :: TestTree +unitTests = + testGroup "Abstract syntax" + [ testPropertyNamed + "noun phrase ordering obeys the Ord laws" + "prop_nounPhraseOrd" + prop_nounPhraseOrd + , testCase + "noun phrase fields survive ordered deduplication" + nounPhraseFieldsRemainDistinct + ] + +prop_nounPhraseOrd :: Property +prop_nounPhraseOrd = withTests 100 . property $ do + x <- forAll nounPhrase + y <- forAll nounPhrase + z <- forAll nounPhrase + + (compare x y == EQ) === (x == y) + compare x y === oppositeOrdering (compare y x) + assert (not (x <= y && y <= z) || x <= z) + +nounPhraseFieldsRemainDistinct :: Assertion +nounPhraseFieldsRemainDistinct = + assertEqual + "one value per base and changed field" + 6 + (length + (nubOrd + [ sampleNounPhrase False False False False False + , sampleNounPhrase True False False False False + , sampleNounPhrase False True False False False + , sampleNounPhrase False False True False False + , sampleNounPhrase False False False True False + , sampleNounPhrase False False False False True + ])) + +nounPhrase :: Gen (NounPhraseOf Maybe Int) +nounPhrase = + sampleNounPhrase + <$> Gen.bool + <*> Gen.bool + <*> Gen.bool + <*> Gen.bool + <*> Gen.bool + +sampleNounPhrase + :: Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> NounPhraseOf Maybe Int +sampleNounPhrase hasLeft otherNoun hasName hasRight hasSuchThat = + NounPhrase + [AdjL Nowhere leftAdjective [1] | hasLeft] + (Noun + Nowhere + (if otherNoun then secondNoun else firstNoun) + [2]) + (NamedVar "x" <$ guardMaybe hasName) + [AdjR Nowhere rightAdjective [3] | hasRight] + (truthStatement <$ guardMaybe hasSuchThat) + where + guardMaybe condition = + if condition then Just () else Nothing + +leftAdjective :: LexicalItem +leftAdjective = + mkLexicalItem [Just (Word "left")] "left" + +rightAdjective :: LexicalItem +rightAdjective = + mkLexicalItem [Just (Word "right")] "right" + +firstNoun :: LexicalItemSgPl +firstNoun = + mkLexicalItemSgPl + (SgPl + [Just (Word "first")] + [Just (Word "firsts")]) + "first" + +secondNoun :: LexicalItemSgPl +secondNoun = + mkLexicalItemSgPl + (SgPl + [Just (Word "second")] + [Just (Word "seconds")]) + "second" + +truthStatement :: Stmt +truthStatement = + StmtFormula (PropositionalConstant Nowhere IsTop) + +oppositeOrdering :: Ordering -> Ordering +oppositeOrdering = \case + LT -> GT + EQ -> EQ + GT -> LT diff --git a/source/Felix/Test/Unit/Backend.hs b/source/Felix/Test/Unit/Backend.hs new file mode 100644 index 0000000..384d21b --- /dev/null +++ b/source/Felix/Test/Unit/Backend.hs @@ -0,0 +1,752 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Backend (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Backend.Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Provers +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Test.Tasty +import Test.Tasty.HUnit + + +data TestGlobal + = FirstOrderPredicate + | HigherOrderPredicate + deriving (Show, Eq, Ord) + +testGlobalType :: TestGlobal -> Maybe CoreType +testGlobalType = \case + FirstOrderPredicate -> + Just (TySet `TyArrow` TyProp) + HigherOrderPredicate -> + Just + ((TySet `TyArrow` TyProp) + `TyArrow` TyProp) + +data TestLocal + = ObjectLocal + | PredicateLocal + deriving (Show, Eq, Ord) + +unitTests :: TestTree +unitTests = + testGroup "Typed backend problem" + [ testCase + "projects proposition equality as equivalence" + classifiesPropositionEquality + , testCase + "projects exact ambient support" + projectsExactAmbientSupport + , testCase + "routes implicit, explicit, and local-only problems" + routesCompleteProblems + , testCase + "admits only checked implicit set constructions" + admitsImplicitSetConstructions + , testCase + "renders checked FOF and TH0 problems" + rendersCheckedProblems + ] + +classifiesPropositionEquality :: Assertion +classifiesPropositionEquality = do + proposition <- + checkedProposition + Vector.empty + (CEq TyProp CFalsum CFalsum) + capability <- + either + (assertFailure . show) + pure + (classifySupportedProposition + testGlobalType + proposition) + case capability of + FofProjectable{} -> + pure () + RequiresTh0 exclusions -> + assertFailure + ("proposition equality was not projected: " + <> show exclusions) + +projectsExactAmbientSupport :: Assertion +projectsExactAmbientSupport = do + let term :: CanonicalTerm Void + term = + CForall TySet + (CEq TySet + (CBound 1) + (CBound 3)) + scoped <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + (const Nothing) + [TySet, TySet, TySet] + term) + projected <- + either + (assertFailure . show) + pure + (projectSupportedProposition + (const Nothing) + (Vector.fromList + [ (0 :: Int, TySet) + , (1, TySet) + , (2, TySet) + ]) + scoped) + assertEqual + "unused middle support is removed" + (Vector.fromList + [ (0 :: Int, TySet) + , (2, TySet) + ]) + (supportedPropositionSupport projected) + assertEqual + "indices are remapped below nested binders" + (CForall TySet + (CEq TySet + (CBound 1) + (CBound 2))) + (supportedPropositionTerm projected) + +routesCompleteProblems :: Assertion +routesCompleteProblems = do + fofFact <- + checkedBackendFact + (0 :: Int) + firstOrderClaim + th0Fact <- + checkedBackendFact + (1 :: Int) + higherOrderClaim + let fofFacts = + Vector.singleton fofFact + th0Facts = + Vector.singleton th0Fact + claim <- + checkedProposition + (Vector.singleton + (ObjectLocal, TySet)) + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0)) + firstOrderLocal <- + checkedLocalPremise + 0 + "first-order local" + claim + higherOrderLocalProposition <- + checkedProposition + (Vector.singleton + (PredicateLocal, + TySet `TyArrow` TyProp)) + (CApp + (CGlobal HigherOrderPredicate) + (CBound 0)) + higherOrderLocal <- + checkedLocalPremise + 1 + "higher-order local" + higherOrderLocalProposition + + implicit <- + planned + fofFacts + claim + [higherOrderLocal, firstOrderLocal] + [] + FirstOrderLocals + ImplicitConstructionJustification + assertEqual "implicit route" RouteFof + (typedProblemRoute implicit) + assertEqual "implicit FOF globals" [0] + (typedBackendFactReference + <$> toList + (typedProblemGlobalPremises + implicit)) + assertEqual "first-order local only" [0] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises + implicit)) + + explicitFof <- + planned + fofFacts + claim + [higherOrderLocal, firstOrderLocal] + [] + FirstOrderLocals + ExplicitHigherOrderJustification + assertEqual "explicit FOF route" RouteFof + (typedProblemRoute explicitFof) + assertEqual "explicit FOF references retain only FOF locals" [0] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises explicitFof)) + + explicitTh0 <- + planned + th0Facts + claim + [higherOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification + assertEqual "explicit TH0 route" RouteTh0 + (typedProblemRoute explicitTh0) + assertEqual "explicit TH0 references retain complete locals" [0, 1] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises explicitTh0)) + + localOnly <- + planned + Vector.empty + claim + [higherOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification + assertEqual "local-only TH0 route" RouteTh0 + (typedProblemRoute localOnly) + assertEqual "local order restored" [0, 1] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises + localOnly)) + assertEqual + "complete ambient local inventory" + (Map.fromList + [ (ObjectLocal, TySet) + , (PredicateLocal, + TySet `TyArrow` TyProp) + ]) + (typedProblemLocalTypes localOnly) + + case planTypedProblem + testGlobalType + Vector.empty + claim + [firstOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification of + Left + (TypedProblemDuplicateLocalPremiseOrdinal + duplicateOrdinal) -> + assertEqual + "duplicate local ordinal" + 0 + (localPremiseOrdinalValue + duplicateOrdinal) + result -> + assertFailure + ("expected duplicate local ordinal error, got " + <> showProblemResult result) + + higherOrderClaimProposition <- + checkedProposition + Vector.empty + higherOrderClaim + case planTypedProblem + testGlobalType + fofFacts + higherOrderClaimProposition + [] + [] + FirstOrderLocals + ImplicitConstructionJustification of + Left + TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + result -> + assertFailure + ("expected explicit higher-order error, got " + <> showProblemResult result) + checkedFoundationValue <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + case planTypedProblem + testGlobalType + fofFacts + claim + [] + [typedFoundationAuxiliaryInput + checkedFoundationValue + Foundation.SeparationCharacteristic] + FirstOrderLocals + ImplicitConstructionJustification of + Left + TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + result -> + assertFailure + ("expected implicit higher-order auxiliary error, got " + <> showProblemResult result) + unusedContext <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet `TyArrow` TyProp] + firstOrderClaim) + case supportedProposition + (Vector.singleton + (PredicateLocal, + TySet `TyArrow` TyProp)) + unusedContext of + Left (UnusedSupportedLocal PredicateLocal) -> + pure () + Left err -> + assertFailure + ("unexpected exact-support error: " + <> show err) + Right _ -> + assertFailure + "unused ambient local entered exact support" + where + planned selectedFacts claim locals auxiliaries localPolicy higherOrderPolicy = + either + (assertFailure . show) + pure + (planTypedProblem + testGlobalType + selectedFacts + claim + locals + auxiliaries + localPolicy + higherOrderPolicy) + + showProblemResult = \case + Left err -> + show err + Right problem -> + show (typedProblemRoute problem) + +admitsImplicitSetConstructions :: Assertion +admitsImplicitSetConstructions = do + checkedFoundationValue <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + let separation = + CApp + (CApp + (CIntrinsic Sep) + (CIntrinsic Empty)) + (CLam TySet + (CApp + (CGlobal HigherOrderPredicate) + (CLam TySet CFalsum))) + separationClaim = + CEq TySet separation separation + filteredDomain = + CApp + (CApp + (CIntrinsic Sep) + (CBound 0)) + (CLam TySet + (CEq TySet (CBound 0) (CBound 0))) + innerReplacement = + CApp + (CApp (CIntrinsic Repl) filteredDomain) + (CLam TySet (CBound 0)) + functionalReplacement = + CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp + (CIntrinsic Repl) + (CIntrinsic Empty)) + (CLam TySet innerReplacement)) + replacementClaim = + CEq TySet functionalReplacement functionalReplacement + replacementTags = + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ] + auxiliary tag = + typedFoundationAuxiliaryInput + checkedFoundationValue tag + plan selected claim locals tags = + planTypedProblem + testGlobalType + selected + claim + locals + (auxiliary <$> tags) + FirstOrderLocals + ImplicitConstructionJustification + + separationProposition <- + checkedProposition Vector.empty separationClaim + separationProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + separationProposition + [] + [Foundation.SeparationCharacteristic]) + assertEqual "separation implicit route" RouteTh0 + (typedProblemRoute separationProblem) + assertEqual "separation characteristic only" + [Foundation.SeparationCharacteristic] + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries separationProblem)) + assertEqual "separation selects no global premise" + 0 + (Vector.length (typedProblemGlobalPremises separationProblem)) + + replacementProposition <- + checkedProposition Vector.empty replacementClaim + replacementProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + replacementProposition + [] + replacementTags) + assertEqual "functional replacement implicit route" RouteTh0 + (typedProblemRoute replacementProblem) + assertEqual "functional replacement exact helper set" + replacementTags + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries replacementProblem)) + + firstOrderProposition <- + checkedProposition Vector.empty firstOrderClaim + firstOrderLocal <- + checkedLocalPremise 0 "first-order" firstOrderProposition + separationLocal <- + checkedLocalPremise 2 "separation" separationProposition + unrelatedLocalProposition <- + checkedProposition + (Vector.singleton + (PredicateLocal, TySet `TyArrow` TyProp)) + (CApp + (CGlobal HigherOrderPredicate) + (CBound 0)) + unrelatedLocal <- + checkedLocalPremise 1 "unrelated higher-order" unrelatedLocalProposition + separationWithLocals <- + either + (assertFailure . show) + pure + (plan + Vector.empty + separationProposition + [unrelatedLocal, firstOrderLocal] + [Foundation.SeparationCharacteristic]) + assertEqual "inline separation keeps unrelated HO local out" RouteTh0 + (typedProblemRoute separationWithLocals) + assertEqual "inline separation retains only FOF local" [0] + ( localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList (typedProblemLocalPremises separationWithLocals) + ) + assertEqual "excluded HO local adds no auxiliary" + [Foundation.SeparationCharacteristic] + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries separationWithLocals)) + localProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + firstOrderProposition + [unrelatedLocal, separationLocal, firstOrderLocal] + []) + assertEqual "implicit construction local remains excluded" RouteFof + (typedProblemRoute localProblem) + assertEqual "unrelated higher-order local remains unselected" + [0] + ( localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList (typedProblemLocalPremises localProblem) + ) + + higherOrderFact <- checkedBackendFact (1 :: Int) higherOrderClaim + expectImplicitHigherOrderRejection + "implicit higher-order global remains forbidden" + (plan + (Vector.singleton higherOrderFact) + separationProposition + [] + [Foundation.SeparationCharacteristic]) + + ordinaryHigherOrder <- + checkedProposition Vector.empty + (CEq TySet + (CApp + (CIntrinsic SetChoose) + (CLam TySet CFalsum)) + (CIntrinsic Empty)) + expectImplicitHigherOrderRejection + "ordinary implicit higher-order target remains forbidden" + (plan Vector.empty ordinaryHigherOrder [] []) + mixedHigherOrder <- + checkedProposition Vector.empty + (CImp + separationClaim + (supportedPropositionTerm ordinaryHigherOrder)) + expectImplicitHigherOrderRejection + "construction does not admit another higher-order intrinsic" + (plan + Vector.empty + mixedHigherOrder + [] + [Foundation.SeparationCharacteristic]) + + expectImplicitHigherOrderRejection + "auxiliary tag alone grants no construction permission" + (plan + Vector.empty + firstOrderProposition + [] + [Foundation.SeparationCharacteristic]) + where + expectImplicitHigherOrderRejection label = \case + Left TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + Left err -> + assertFailure (label <> ": unexpected error " <> show err) + Right problem -> + assertFailure + (label <> ": unexpectedly routed " + <> show (typedProblemRoute problem)) + +rendersCheckedProblems :: Assertion +rendersCheckedProblems = do + fofFact <- + checkedBackendFact + (0 :: Int) + firstOrderClaim + th0Fact <- + checkedBackendFact + (1 :: Int) + higherOrderClaim + claim <- + checkedProposition + (Vector.singleton + (ObjectLocal, TySet)) + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0)) + fofProblem <- + planned + (Vector.singleton fofFact) + claim + FirstOrderLocals + ImplicitConstructionJustification + th0Problem <- + planned + (Vector.singleton th0Fact) + claim + CompleteLocals + ExplicitHigherOrderJustification + preparedFof <- + either + (assertFailure . show) + pure + (prepareTypedTptpProblem + fofProblem) + preparedTh0 <- + either + (assertFailure . show) + pure + (prepareTypedTptpProblem + th0Problem) + proverTask <- + either + (assertFailure . show) + pure + (prepareTypedProverTask + DirectTask + th0Problem) + assertEqual "FOF route" RouteFof + (preparedTypedTptpRoute preparedFof) + assertBool "FOF formulas" + ("fof(tg_h0,axiom," + `Text.isInfixOf` + preparedTypedTptpText + preparedFof) + assertBool "FOF has no TH0 declarations" + (not + ("thf(" + `Text.isInfixOf` + preparedTypedTptpText + preparedFof)) + assertEqual "TH0 route" RouteTh0 + (preparedTypedTptpRoute preparedTh0) + assertEqual "TH0 request dialect" + VerificationTh0 + (preparedVerificationDialect + (preparedTypedProverRequest + proverTask)) + assertEqual "request preserves exact prepared text" + (preparedTypedTptpText preparedTh0) + (preparedVerificationText + (preparedTypedProverRequest + proverTask)) + for_ + [ "thf(tg_h0,axiom," + , "^ [V0:$i]" + , "thf(tg_q0,conjecture," + ] + \fragment -> + assertBool + ("TH0 contains " <> Text.unpack fragment) + (fragment + `Text.isInfixOf` + preparedTypedTptpText + preparedTh0) + for_ + (Map.keys + (preparedTypedTptpNameOrigins + preparedTh0)) + \target -> + assertBool + ("valid generated name " <> Text.unpack target) + (if "V" `Text.isPrefixOf` target + then Tptp.isProperVariable target + else Tptp.isProperAtomicWord target) + where + planned selectedFacts claim localPolicy higherOrderPolicy = + either + (assertFailure . show) + pure + (planTypedProblem + testGlobalType + selectedFacts + claim + [] + [] + localPolicy + higherOrderPolicy) + +firstOrderClaim :: CanonicalTerm TestGlobal +firstOrderClaim = + CApp + (CGlobal FirstOrderPredicate) + (CIntrinsic Empty) + +higherOrderClaim :: CanonicalTerm TestGlobal +higherOrderClaim = + CApp + (CGlobal HigherOrderPredicate) + (CLam TySet + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0))) + +checkedProposition + :: Vector (TestLocal, CoreType) + -> CanonicalTerm TestGlobal + -> IO + (SupportedProposition + TestLocal + TestGlobal) +checkedProposition support term = do + checked <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + (snd <$> Vector.toList support) + term) + either + (assertFailure . show) + pure + (supportedProposition support checked) + +checkedClosedProposition + :: CanonicalTerm TestGlobal + -> IO + (SupportedProposition + Void + TestGlobal) +checkedClosedProposition term = do + checked <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + term) + either + (assertFailure . show) + pure + (supportedProposition + Vector.empty + checked) + +checkedBackendFact + :: ref + -> CanonicalTerm TestGlobal + -> IO (TypedBackendFact ref TestGlobal) +checkedBackendFact reference term = do + proposition <- + checkedClosedProposition term + capability <- + either + (assertFailure . show) + pure + (classifySupportedProposition + testGlobalType + proposition) + pure + (typedBackendFact + reference + proposition + capability) + +checkedLocalPremise + :: Natural + -> Text + -> SupportedProposition TestLocal TestGlobal + -> IO + (TypedLocalPremise + TestLocal + Text + TestGlobal) +checkedLocalPremise ordinal premiseOrigin proposition = + either + (assertFailure . show) + pure + (typedLocalPremise + testGlobalType + (localPremiseOrdinal ordinal) + premiseOrigin + proposition) diff --git a/source/Felix/Test/Unit/CommandLine.hs b/source/Felix/Test/Unit/CommandLine.hs new file mode 100644 index 0000000..f2a4a10 --- /dev/null +++ b/source/Felix/Test/Unit/CommandLine.hs @@ -0,0 +1,799 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.CommandLine (unitTests) where + +import Base +import Felix.CommandLine +import Felix.Output.Atomic qualified as Atomic +import Felix.Source (safeRelativePath) +import Felix.Store qualified as Store +import Felix.Verification qualified as Verification +import Felix.Provers qualified as Provers +import Felix.Render.Html.Output qualified as HtmlOutput +import Felix.Report.Location (pattern Nowhere) + +import Control.Exception (IOException, bracket) +import Control.Exception qualified as Exception +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Options.Applicative (ParserResult(..)) +import Options.Applicative qualified as Options +import System.Directory qualified as Directory +import System.Environment (getEnvironment) +import System.Exit (ExitCode(..)) +import System.FilePath.Posix (()) +import System.Process + ( CreateProcess(..) + , proc + , readCreateProcessWithExitCode + ) +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = + testGroup "Command line" + [ testCase "parses the closed command model" + parsesClosedCommands + , testCase "rejects conflicting command options" + rejectsConflictingOptions + , testCase "maps structured outcomes to process status" do + for_ outcomeCases \(outcome, expectedExitCode) -> + commandOutcomeExitCode outcome + `shouldBe` expectedExitCode + , testCase "reports the committed HTML prefix" + reportsCommittedHtmlPrefix + , testCase "removes an unpublished dump temporary" + removesFailedDumpTemporary + , testGroup "process boundary" + [ testCase "version needs no input or store" + versionNeedsNoInputOrStore + , testCase "parse-only uses no store or Vampire" + parseOnlyUsesNoAuthority + , testCase "malformed source has a stable failure class" + malformedSourceHasStableFailure + , testCase "invalid output needs no source pass or store startup" + invalidOutputPrecedesStoreStartup + , testCase "nested HTML routes fail before store startup" + nestedHtmlRoutesPrecedeStoreStartup + , testCase "verified theorem exits successfully" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for cli'" + , "exit 0" + ] + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` "Verification successful." + , testCase "omitted proof reports a located explicit gap" do + (exitCode, stdout, stderr) <- + runCliWithSourceAndConfiguredVampire + cliGapSource + writeNonExecutableFile + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` + "Verification completed with explicit proof gaps." + stderr `shouldContain` "1 explicit proof gap" + stderr `shouldContain` "input.tex 5:5" + , testCase "countermodel exits as verification rejection" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + , "exit 0" + ] + exitCode `shouldBe` ExitFailure 1 + stdout `shouldBe` "" + stderr `shouldContain` + "Verification failed: prover found countermodel" + , testCase "failed prover exits as infrastructure failure" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for cli'" + , "exit 7" + ] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` + "UnsuccessfulVampireExit (ExitFailure 7)" + , testCase "prover launch failure exits as infrastructure failure" do + (exitCode, stdout, stderr) <- + runCliWithConfiguredVampire writeNonExecutableFile + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "ProverLaunchFailed" + , testCase "dumps the exact executed request once" + dumpsExactExecutedRequest + , testCase "launch failure dumps no request" + launchFailureDumpsNoRequest + , testCase "failed verification retains its executed dump subset" + dumpsOnlyExecutedPrefix + , testCase "dump and HTML share one verification" + dumpAndHtmlVerifyOnce + , testCase "semantic failure publishes no HTML" + semanticFailurePublishesNoHtml + , testCase "fresh and cached presentation publish equal HTML" + freshAndCachedPresentationAgree + , testCase "missing renderer data is a typed failure" + missingRendererDataIsTyped + , testCase + "post-verification HTML failure retains authorization report" + htmlFailureRetainsAuthorizationReport + ] + ] + +parsesClosedCommands :: Assertion +parsesClosedCommands = do + case parseCommandArguments ["--version"] of + Success Version -> + pure () + other -> + assertFailure + ("unexpected version parse: " <> showParserResult other) + case parseCommandArguments ["input.tex", "--parseonly"] of + Success (ParseOnly (Input "input.tex")) -> + pure () + other -> + assertFailure + ("unexpected parse-only parse: " <> showParserResult other) + case parseCommandArguments ["input.tex"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationStoreSelection = + Store.DefaultStore + }) -> + pure () + other -> + assertFailure + ("unexpected default verify parse: " + <> showParserResult other) + case parseCommandArguments ["input.tex", "--jobs", "3"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationJobsOverride = Just jobs + }) -> + Provers.effectiveJobsValue jobs `shouldBe` 3 + other -> + assertFailure + ("unexpected jobs parse: " <> showParserResult other) + case parseCommandArguments ["input.tex", "--fresh"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationStoreSelection = + Store.FreshTemporaryStore + }) -> + pure () + other -> + assertFailure + ("unexpected verify parse: " <> showParserResult other) + +rejectsConflictingOptions :: Assertion +rejectsConflictingOptions = do + for_ + [ ["input.tex", "--parseonly", "--fresh"] + , ["input.tex", "--parseonly", "--jobs", "2"] + , ["input.tex", "--parseonly", "--dump", "dump"] + , ["input.tex", "--parseonly", "--html"] + , ["input.tex", "--store", "store.sqlite", "--fresh"] + ] + \arguments -> + case parseCommandArguments arguments of + Failure _failure -> + pure () + other -> + assertFailure + ("conflicting options were accepted: " + <> show arguments + <> " as " + <> showParserResult other) + case parseCommandArguments ["input.tex", "--jobs", "0"] of + Failure _failure -> pure () + other -> + assertFailure + ("non-positive jobs were accepted as " + <> showParserResult other) + +showParserResult :: ParserResult Command -> String +showParserResult = \case + Success selected -> + show selected + Failure failure -> + fst (Options.renderFailure failure "felix") + CompletionInvoked _completion -> + "completion invoked" + +versionNeedsNoInputOrStore :: Assertion +versionNeedsNoInputOrStore = + withCliFixture cliSource \fixture -> do + (exitCode, stdout, stderr) <- + runCliFixture fixture ["--version"] + exitCode `shouldBe` ExitSuccess + stdout `shouldContain` "Version 0.3.0.0" + stderr `shouldBe` "" + assertNoDefaultStore fixture + +parseOnlyUsesNoAuthority :: Assertion +parseOnlyUsesNoAuthority = + withCliFixture cliPreludeSyntaxSource \fixture -> do + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, stdout, stderr) <- + runCliFixture + fixture + ["input.tex", "--parseonly"] + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldBe` "" + assertNoDefaultStore fixture + +malformedSourceHasStableFailure :: Assertion +malformedSourceHasStableFailure = + withCliFixture malformedCliSource \fixture -> do + (exitCode, stdout, stderr) <- + runCliFixture + fixture + ["input.tex", "--parseonly"] + exitCode `shouldBe` ExitFailure 1 + stdout `shouldBe` "" + stderr `shouldContain` "Parsing failed: project:input.tex" + stderr `shouldContain` "input.tex 2:5" + stderr `shouldContain` "unconsumed word" + assertBool "does not print an internal error constructor" + (not ("SourceParseError" `List.isInfixOf` stderr)) + assertNoDefaultStore fixture + +invalidOutputPrecedesStoreStartup :: Assertion +invalidOutputPrecedesStoreStartup = + withCliFixture cliSource \fixture -> do + let dump = cliFixtureRoot fixture "dump" + Directory.removeFile + (cliFixtureRoot fixture "input.tex") + Directory.createDirectory dump + writeFile (dump "stale.p") "stale" + (exitCode, stdout, stderr) <- + runCliFixture fixture + ["input.tex", "--dump", "dump"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "Verification output preflight failed:" + stderr `shouldContain` (Text.pack (show dump)) + stderr `shouldContain` "choose an absent or empty directory" + stderr `shouldContain` "stale.p" + assertNoDefaultStore fixture + +reportsCommittedHtmlPrefix :: Assertion +reportsCommittedHtmlPrefix = do + first <- checkedRelative "a.html" + second <- checkedRelative "nested/b.html" + failed <- checkedRelative "nested/c.html" + assertEqual + "deterministic committed prefix" + [ "HTML publication failed at \"nested/c.html\": disk full" + , "HTML files published before the failure: \"a.html\", \"nested/b.html\"" + ] + (HtmlOutput.renderHtmlPublicationError + (HtmlOutput.IncompleteHtmlPublication + [first, second] + failed + "disk full")) + where + checkedRelative path = + case safeRelativePath path of + Left problem -> + assertFailure + ("invalid test route " <> show path <> ": " <> show problem) + >> fail "unreachable" + Right relative -> + pure relative + +nestedHtmlRoutesPrecedeStoreStartup :: Assertion +nestedHtmlRoutesPrecedeStoreStartup = + withCliFixture nestedHtmlRootSource \fixture -> do + let root = cliFixtureRoot fixture + nested = root "a.html" + Directory.createDirectory nested + writeFile (root "a.tex") cliSource + writeFile (nested "b.tex") cliSource + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "HTML route planning failed:" + stderr `shouldContain` "\"a.html\"" + stderr `shouldContain` "\"a.html/b.html\"" + assertNoDefaultStore fixture + +removesFailedDumpTemporary :: Assertion +removesFailedDumpTemporary = + withTemporaryDirectory "felix-dump-atomic" \root -> do + let destination = root "1.p" + Directory.createDirectory destination + result <- Exception.try + (Atomic.writeBytesAtomically + destination + (TextEncoding.encodeUtf8 "complete request")) + :: IO (Either IOException ()) + case result of + Left _failure -> + pure () + Right () -> + assertFailure "dump publication unexpectedly succeeded" + contents <- List.sort <$> Directory.listDirectory root + assertEqual + "only the pre-existing final target remains" + ["1.p"] + contents + +dumpsExactExecutedRequest :: Assertion +dumpsExactExecutedRequest = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + let captured = cliFixtureRoot fixture "captured.p" + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat > " <> show captured + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitSuccess + stderr `shouldContain` "Verification successful." + dumped <- ByteString.readFile + (cliFixtureRoot fixture "dump" "1-1.p") + sent <- ByteString.readFile captured + assertEqual "dump is the exact process input" sent dumped + assertBool "request is dumped only once" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture "dump" "1-2.p") + +launchFailureDumpsNoRequest :: Assertion +launchFailureDumpsNoRequest = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitFailure 2 + stderr `shouldContain` "ProverLaunchFailed" + assertBool "no request was dumped before process launch" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture "dump" "1-1.p") + +dumpsOnlyExecutedPrefix :: Assertion +dumpsOnlyExecutedPrefix = + withCliFixture cliTwoSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitFailure 1 + stderr `shouldContain` "prover found countermodel" + assertBool "executed request was dumped" + =<< Directory.doesFileExist + (cliFixtureRoot fixture "dump" "1-1.p") + -- Prospective execution may start a source-later request before the + -- admission cursor observes this first rejection. Dump ownership is + -- therefore the actual executed subset, not a semantic prefix. + +dumpAndHtmlVerifyOnce :: Assertion +dumpAndHtmlVerifyOnce = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + let countPath = cliFixtureRoot fixture "vampire-runs" + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' run >> " <> show countPath + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + , "--html" + ] + exitCode `shouldBe` ExitSuccess + stderr `shouldContain` "Verification successful." + runs <- List.lines <$> readFile countPath + assertEqual "one semantic verification" ["run"] runs + assertBool "request dump was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture "dump" "1-1.p") + assertBool "root HTML page was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture "html" "input.html") + assertBool "HTML support asset was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture + "html" + "_static" + "naproche-html.js") + +semanticFailurePublishesNoHtml :: Assertion +semanticFailurePublishesNoHtml = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + , "--html" + ] + exitCode `shouldBe` ExitFailure 1 + stderr `shouldContain` "prover found countermodel" + assertBool "semantic failure retains the executed request dump" + =<< Directory.doesFileExist + (cliFixtureRoot fixture "dump" "1-1.p") + assertBool "semantic failure publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture "html") + +freshAndCachedPresentationAgree :: Assertion +freshAndCachedPresentationAgree = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (freshExit, _freshStdout, freshStderr) <- + runCliFixture fixture ["input.tex", "--html"] + freshExit `shouldBe` ExitSuccess + freshStderr `shouldContain` "Verification successful." + let htmlRoot = cliFixtureRoot fixture "html" + page = htmlRoot "input.html" + support = + htmlRoot "_static" "naproche-html.js" + freshPage <- ByteString.readFile page + freshSupport <- ByteString.readFile support + Directory.removePathForcibly htmlRoot + writeNonExecutableFile (cliFixtureVampire fixture) + (warmExit, _warmStdout, warmStderr) <- + runCliFixture fixture ["input.tex", "--html"] + warmExit `shouldBe` ExitSuccess + warmStderr `shouldContain` "Verification successful." + warmPage <- ByteString.readFile page + warmSupport <- ByteString.readFile support + assertEqual "fresh/cache-hit page bytes" freshPage warmPage + assertEqual "fresh/cache-hit support bytes" + freshSupport warmSupport + +missingRendererDataIsTyped :: Assertion +missingRendererDataIsTyped = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + Directory.removeFile + (cliFixtureRoot fixture "library" "lexicon.tsv") + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "HTML preparation failed:" + stderr `shouldContain` "renderer data \"lexicon.tsv\" was not found" + assertBool "does not expose an ErrorCall" + (not ("ErrorCall" `List.isInfixOf` stderr)) + assertBool "failed preparation publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture "html") + +htmlFailureRetainsAuthorizationReport :: Assertion +htmlFailureRetainsAuthorizationReport = + withCliFixture cliGapSource \fixture -> do + seedPackagedPreludeCache fixture + Directory.removeFile + (cliFixtureRoot fixture "library" "lexicon.tsv") + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` + "Verification succeeded, but HTML preparation failed:" + stderr `shouldContain` + "Direct source authorization summary: 0 source axioms, 1 explicit proof gap." + stderr `shouldContain` "Explicit proof gap at input.tex 5:5" + assertBool "failed output publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture "html") + +outcomeCases :: [(CommandOutcome, ExitCode)] +outcomeCases = + [ (CommandCompleted, ExitSuccess) + , (VerificationSucceeded emptyReport emptySlowReport, ExitSuccess) + , (VerificationCompletedWithGaps emptyReport emptySlowReport, ExitSuccess) + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.CountermodelFailure "")) + emptySlowReport + , ExitFailure 1 + ) + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.IndeterminateFailure "")) + emptySlowReport + , ExitFailure 2 + ) + , ( VerificationCheckingRejected + emptyReport + (Verification.VerificationModuleSchedulerInvariant "test") + emptySlowReport + , ExitFailure 2 + ) + ] + +emptyReport :: Verification.VerificationReport +emptyReport = + Verification.VerificationReport + { Verification.verificationDirectEscapes = [] + } + +emptySlowReport :: Provers.SlowAtpReport +emptySlowReport = Provers.SlowAtpReport 0 [] + +runCliWithFakeVampire + :: [String] + -> IO (ExitCode, String, String) +runCliWithFakeVampire scriptLines = + runCliWithConfiguredVampire \vampirePath -> do + writeExecutableScript vampirePath + (["cat >/dev/null"] <> scriptLines) + +runCliWithConfiguredVampire + :: (FilePath -> IO ()) + -> IO (ExitCode, String, String) +runCliWithConfiguredVampire = + runCliWithSourceAndConfiguredVampire cliSource + +runCliWithSourceAndConfiguredVampire + :: String + -> (FilePath -> IO ()) + -> IO (ExitCode, String, String) +runCliWithSourceAndConfiguredVampire source prepareVampire = + withCliFixture source \fixture -> do + seedPackagedPreludeCache fixture + prepareVampire (cliFixtureVampire fixture) + runCliFixture fixture ["input.tex"] + +data CliFixture = CliFixture + { cliFixtureRoot :: !FilePath + , cliFixtureExecutable :: !FilePath + , cliFixtureVampire :: !FilePath + , cliFixtureCacheRoot :: !FilePath + , cliFixtureEnvironment :: ![(String, String)] + } + +withCliFixture + :: String + -> (CliFixture -> IO value) + -> IO value +withCliFixture source action = + withTemporaryDirectory "felix-cli" \temp -> do + felixExecutable <- requireFelixExecutable + repositoryRoot <- Directory.getCurrentDirectory + let sourcePath = temp "input.tex" + vampirePath = temp "vampire" + libraryPath = temp "library" + debugPath = temp "debug" + cacheRoot = temp "cache" + Directory.createDirectory libraryPath + Directory.createDirectory debugPath + Directory.createDirectory cacheRoot + writeFile sourcePath source + ByteString.readFile + (repositoryRoot "library" "lexicon.tsv") + >>= ByteString.writeFile + (libraryPath "lexicon.tsv") + inheritedEnvironment <- getEnvironment + let processEnvironment = + setEnvironmentVariable + "XDG_CACHE_HOME" + cacheRoot + (setEnvironmentVariable + "FELIX_VAMPIRE" + vampirePath + (setEnvironmentVariable + "NAPROCHE_LIB" + libraryPath + inheritedEnvironment)) + action + CliFixture + { cliFixtureRoot = temp + , cliFixtureExecutable = felixExecutable + , cliFixtureVampire = vampirePath + , cliFixtureCacheRoot = cacheRoot + , cliFixtureEnvironment = processEnvironment + } + +runCliFixture + :: CliFixture + -> [String] + -> IO (ExitCode, String, String) +runCliFixture fixture arguments = + readCreateProcessWithExitCode + ((proc + (cliFixtureExecutable fixture) + arguments) + { cwd = Just (cliFixtureRoot fixture) + , env = Just (cliFixtureEnvironment fixture) + }) + "" + +-- | Populate only the packaged final-prelude root. Process-boundary tests +-- can then exercise the requested ordinary module outcome without making +-- their fake prover depend on the prelude's private obligation count. +seedPackagedPreludeCache :: CliFixture -> Assertion +seedPackagedPreludeCache fixture = do + let sourcePath = cliFixtureRoot fixture "input.tex" + original <- ByteString.readFile sourcePath + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for prelude seed'" + ] + (exitCode, stdout, stderr) <- + (do + writeFile sourcePath "% cache the packaged final prelude\n" + runCliFixture fixture ["input.tex"]) + `Exception.finally` ByteString.writeFile sourcePath original + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` "Verification successful." + +assertNoDefaultStore :: CliFixture -> Assertion +assertNoDefaultStore fixture = + assertBool "default store was not created" + . not + =<< Directory.doesPathExist + (cliFixtureCacheRoot fixture "felix") + +writeExecutableScript :: FilePath -> [String] -> IO () +writeExecutableScript path scriptLines = do + writeFile path + (unlines (["#!/bin/sh"] <> scriptLines)) + permissions <- Directory.getPermissions path + Directory.setPermissions path + (Directory.setOwnerExecutable True permissions) + +writeNonExecutableFile :: FilePath -> IO () +writeNonExecutableFile path = do + exists <- Directory.doesPathExist path + if exists + then Directory.removeFile path + else pure () + writeFile path "not executable" + +requireFelixExecutable :: IO FilePath +requireFelixExecutable :: IO FilePath + = do + executable <- Directory.findExecutable "felix" + case executable of + Just path -> + pure path + Nothing -> do + assertFailure "felix build tool is not available on PATH" + pure "felix" + +setEnvironmentVariable + :: String + -> String + -> [(String, String)] + -> [(String, String)] +setEnvironmentVariable name value environment = + (name, value) : List.filter ((/= name) . fst) environment + +cliSource :: String +cliSource = + unlines + [ "\\begin{proposition}\\label{cli_test}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + ] + +cliPreludeSyntaxSource :: String +cliPreludeSyntaxSource = + unlines + [ "\\begin{proposition}\\label{parse_prelude_syntax}" + , " For all $x$ we have $\\preludeSuccessor{x} = \\preludeSuccessor{x}$." + , "\\end{proposition}" + ] + +cliGapSource :: String +cliGapSource = + unlines + [ "\\begin{proposition}\\label{cli_gap}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Omitted." + , "\\end{proof}" + ] + +cliTwoSource :: String +cliTwoSource = + unlines + [ "\\begin{proposition}\\label{cli_first}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + , "\\begin{proposition}\\label{cli_second}" + , " $\\forall y. y = y$." + , "\\end{proposition}" + ] + +malformedCliSource :: String +malformedCliSource = + unlines + [ "\\begin{proposition}\\label{malformed}" + , " This is not a proposition." + , "\\end{proposition}" + ] + +nestedHtmlRootSource :: String +nestedHtmlRootSource = + unlines + [ "\\import{a.tex}" + , "\\import{a.html/b.tex}" + ] + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +shouldContain :: String -> Text -> Assertion +shouldContain actual expected = + assertBool + ("expected " <> show actual <> " to contain " <> show expected) + (expected `Text.isInfixOf` Text.pack actual) + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = + flip (assertEqual "") diff --git a/source/Felix/Test/Unit/Concrete.hs b/source/Felix/Test/Unit/Concrete.hs new file mode 100644 index 0000000..7eac7df --- /dev/null +++ b/source/Felix/Test/Unit/Concrete.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Concrete (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Concrete (grammar) +import Felix.Syntax.Lexicon (builtins) +import Felix.Syntax.Token (runLexer) + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.Earley (fullParses, parser) +import Text.Megaparsec (errorBundlePretty) + +unitTests :: TestTree +unitTests = + testGroup "Parser" + [ testCase + "textual connectives follow symbolic precedence" + textualConnectivePrecedence + , testCase + "transfinite induction precedes its continuation" + transfiniteInductionContinuation + ] + +data StatementShape + = Truth + | Falsity + | Connected Raw.Connective StatementShape StatementShape + | Scoped StatementShape + deriving (Show, Eq) + +textualConnectivePrecedence :: Assertion +textualConnectivePrecedence = do + for_ cases \(label, statement, expected) -> + assertEqual label (Right expected) (statementShape =<< parseStatement statement) + + assertBool + "chained iff is rejected" + (case parseStatement "$\\top$ iff $\\bot$ iff $\\top$" of + Left _ -> True + Right _ -> False) + + assertEqual + "textual and symbolic connective trees agree" + (statementShape + =<< parseStatement + "$\\top \\land \\bot \\lor \\top$") + (statementShape + =<< parseStatement + "$\\top$ and $\\bot$ or $\\top$") + where + cases = + [ ( "and binds tighter than following or" + , "$\\top$ and $\\bot$ or $\\top$" + , Connected Raw.Disjunction + (Connected Raw.Conjunction Truth Falsity) + Truth + ) + , ( "and binds tighter than preceding or" + , "$\\top$ or $\\bot$ and $\\top$" + , Connected Raw.Disjunction + Truth + (Connected Raw.Conjunction Falsity Truth) + ) + , ( "and associates left" + , "$\\top$ and $\\bot$ and $\\top$" + , Connected Raw.Conjunction + (Connected Raw.Conjunction Truth Falsity) + Truth + ) + , ( "or associates left" + , "$\\top$ or $\\bot$ or $\\top$" + , Connected Raw.Disjunction + (Connected Raw.Disjunction Truth Falsity) + Truth + ) + , ( "either is accepted after ordinary or" + , "$\\top$ or either $\\bot$ or $\\top$" + , Connected Raw.Disjunction + Truth + (Connected Raw.ExclusiveOr Falsity Truth) + ) + , ( "implication associates right" + , "if $\\top$ then if $\\bot$ then $\\top$" + , Connected Raw.Implication + Truth + (Connected Raw.Implication Falsity Truth) + ) + , ( "a quantified implication antecedent ends at then" + , "if for all $x$ we have $\\top$ then $\\bot$" + , Connected Raw.Implication + (Scoped Truth) + Falsity + ) + , ( "parentheses override precedence" + , "($\\top$ or $\\bot$) and $\\top$" + , Connected Raw.Conjunction + (Connected Raw.Disjunction Truth Falsity) + Truth + ) + , ( "a quantified right operand scopes over its continuation" + , "$\\top$ iff there exists $x$ such that $\\bot$ and $\\top$" + , Connected Raw.Equivalence + Truth + (Scoped + (Connected Raw.Conjunction Falsity Truth)) + ) + ] + +parseStatement :: Text -> Either String Raw.Stmt +parseStatement statement = do + chunks <- case runLexer + (FileId 46) + "textual-connectives.tex" + (Text.unlines + [ "\\begin{axiom}\\label{textual_connectives}" + , statement <> "." + , "\\end{axiom}" + ]) of + Left err -> + Left (errorBundlePretty err) + Right (_imports, chunks') -> + Right chunks' + tokens <- case chunks of + [tokens'] -> + Right tokens' + _ -> + Left ("expected one source chunk, got " <> show (length chunks)) + case fullParses (parser (grammar builtins)) tokens of + ( [Raw.BlockAxiom + _location + _title + _marker + (Raw.Axiom [] statement')] + , _report + ) -> + Right statement' + (blocks, report) -> + Left + ( "expected one axiom, got " + <> show blocks + <> " with " + <> show report + ) + +statementShape :: Raw.Stmt -> Either String StatementShape +statementShape = \case + Raw.StmtConnected conn _ left right -> + Connected conn + <$> statementShape left + <*> statementShape right + Raw.StmtFormula formula -> + formulaShape formula + Raw.SymbolicQuantified _ _ _ _ _ statement -> + Scoped <$> statementShape statement + statement -> + Left ("unsupported statement in precedence test: " <> show statement) + +formulaShape :: Raw.Formula -> Either String StatementShape +formulaShape = \case + Raw.PropositionalConstant _ Raw.IsTop -> + Right Truth + Raw.PropositionalConstant _ Raw.IsBottom -> + Right Falsity + Raw.Connected _ conn left right -> + Connected conn + <$> formulaShape left + <*> formulaShape right + formula -> + Left ("unsupported formula in precedence test: " <> show formula) + +transfiniteInductionContinuation :: Assertion +transfiniteInductionContinuation = + case runLexer + (FileId 45) + "transfinite-induction.tex" + sourceText of + Left err -> + assertFailure (errorBundlePretty err) + Right (_imports, [tokens]) -> + case fullParses (parser (grammar builtins)) tokens of + ( [ Raw.BlockProof + _start + (Raw.ByOrdInduction methodLocation + (Raw.Qed + (Just continuationLocation) + Raw.JustificationEmpty)) + _end + ] + , _report + ) -> do + assertEqual + "method header line" + 2 + (locLine methodLocation) + assertEqual + "continuation line" + 3 + (locLine continuationLocation) + (blocks, report) -> + assertFailure + ( "expected one transfinite-induction proof, got " + <> show blocks + <> " with " + <> show report + ) + Right (_imports, chunks) -> + assertFailure + ("expected one proof chunk, got " <> show (length chunks)) + where + sourceText = + Text.unlines + [ "\\begin{proof}" + , "[proof by transfinite induction]" + , "Trivial." + , "\\end{proof}" + ] diff --git a/source/Felix/Test/Unit/Core.hs b/source/Felix/Test/Unit/Core.hs new file mode 100644 index 0000000..0388c7f --- /dev/null +++ b/source/Felix/Test/Unit/Core.hs @@ -0,0 +1,670 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Core (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.SetConstruction + +import Control.DeepSeq (NFData(..), force) +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.Hedgehog (testPropertyNamed) + + +data TestGlobal + = TestGlobal + | TestPairGlobal + deriving (Show, Eq, Ord) + +instance NFData TestGlobal where + rnf _global = + () + +testGlobalType :: TestGlobal -> Maybe CoreType +testGlobalType TestGlobal = + Just TySet +testGlobalType TestPairGlobal = + Just (TySet `TyArrow` (TySet `TyArrow` TySet)) + +unitTests :: TestTree +unitTests = + testGroup "Checked core" + [ testCase + "freezes explicit binder positions" + freezesExplicitBinderPositions + , testCase + "freezes generalized substitution without capture" + freezesGeneralizedSubstitution + , testCase + "rejects ill-typed and open terms" + rejectsInvalidTerms + , testCase + "rechecks canonical terms without unchecked construction" + rechecksCanonicalTerms + , testCase + "checks scoped canonical weakening and substitution" + checksScopedCanonicalOperations + , testCase + "builds set-induction hypotheses from the complete property" + buildsSetInductionHypotheses + , testCase + "specializes the checked separation characteristic" + specializesCheckedSeparationCharacteristic + , testCase + "specializes the checked replacement characteristic" + specializesCheckedReplacementCharacteristic + , testCase + "derives named construction views from checked components" + derivesNamedConstructionViews + , testCase + "thaws checked closed terms without changing them" + thawsCheckedClosedTerms + , testPropertyNamed + "optimized freeze agrees with bounded reference" + "prop_freezeAgreesWithReference" + prop_freezeAgreesWithReference + ] + +freezesExplicitBinderPositions :: Assertion +freezesExplicitBinderPositions = do + let x = 0 :: Int + y = 1 :: Int + freeze body = do + checked <- + either + (assertFailure . show) + pure + (checkClosedCore + testGlobalType + (coreLambda TySet x + (coreLambda TyProp y body))) + either + (assertFailure . show) + (pure . frozenCoreTerm) + (freezeClosed checked) + nearest <- + freeze (coreLocal y) + outer <- + freeze (coreLocal x) + global <- + freeze (coreGlobal TestGlobal) + assertEqual + "nearest binder" + (CLam TySet (CLam TyProp (CBound 0))) + nearest + assertEqual + "outer binder" + (CLam TySet (CLam TyProp (CBound 1))) + outer + assertEqual + "global with both vacuous binders" + (CLam TySet (CLam TyProp (CGlobal TestGlobal))) + global + +freezesGeneralizedSubstitution :: Assertion +freezesGeneralizedSubstitution = do + let outer = 0 :: Int + inner = 1 :: Int + placeholder = 2 :: Int + innerTerm = + coreLambda TySet inner (coreLocal placeholder) + substituted = + innerTerm >>= \local -> + if local == placeholder + then coreLocal outer + else coreLocal local + term = + coreLambda TyProp outer substituted + checked <- + either + (assertFailure . show) + pure + (checkClosedCore testGlobalType term) + optimized <- + either + (assertFailure . show) + pure + (freezeClosed checked) + reference <- + either + (assertFailure . show) + pure + (referenceFreezeClosed checked) + assertEqual "reference result" reference optimized + assertEqual + "outer variable remains outside the inner binder" + (CLam TyProp (CLam TySet (CBound 1))) + (frozenCoreTerm optimized) + +rejectsInvalidTerms :: Assertion +rejectsInvalidTerms = do + assertEqual + "free local" + (Left UnboundCoreLocal) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreLocal (0 :: Int))) + assertEqual + "application argument" + (Left + (ApplicationArgumentTypeMismatch + TySet + TyProp)) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreApply + (coreIntrinsic FamilyUnion) + coreFalsum)) + assertEqual + "equality operand" + (Left + (EqualityOperandTypeMismatch + TySet + TyProp)) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreEquality + TySet + coreFalsum + (coreGlobal TestGlobal))) + +rechecksCanonicalTerms :: Assertion +rechecksCanonicalTerms = do + let term = + CForall TySet + (CEq TySet + (CBound 0) + (CBound 0)) + assertEqual + "well-typed canonical proposition" + (Right (TyProp, term)) + ( (\checked -> + ( frozenCoreType checked + , frozenCoreTerm checked + )) + <$> checkCanonicalCore testGlobalType term + ) + assertEqual + "out-of-scope de Bruijn index" + (Left (UnboundCoreIndex 1)) + (frozenCoreType + <$> checkCanonicalCore + testGlobalType + (CForall TySet (CBound 1))) + assertEqual + "canonical application still checks argument types" + (Left + (ApplicationArgumentTypeMismatch + TySet + TyProp)) + (frozenCoreType + <$> checkCanonicalCore + testGlobalType + (CApp + (CIntrinsic FamilyUnion) + CFalsum)) + +checksScopedCanonicalOperations :: Assertion +checksScopedCanonicalOperations = do + scoped <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet] + (CBound 0)) + weakened <- + either + (assertFailure . show) + pure + (weakenScopedCore + testGlobalType + TyProp + scoped) + assertEqual + "nearest binder insertion shifts the prior local" + ( [TyProp, TySet] + , TySet + , CBound 1 + ) + ( scopedCoreContext weakened + , scopedCoreType weakened + , scopedCoreTerm weakened + ) + assertEqual + "top-level binder substitution removes its index" + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + (instantiateCanonical + (CIntrinsic Empty + :: CanonicalTerm TestGlobal) + (CEq TySet + (CBound 0) + (CBound 0))) + root <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + (CGlobal TestGlobal)) + assertEqual + "empty scoped context closes" + (Just + (TySet, CGlobal TestGlobal)) + ( (\closed -> + ( frozenCoreType closed + , frozenCoreTerm closed + )) + <$> closeScopedCore root + ) + +buildsSetInductionHypotheses :: Assertion +buildsSetInductionHypotheses = do + let propertyTerm = + CImp + (CEq TySet + (CBound 0) + (CIntrinsic Empty)) + (CEq TySet + (CBound 0) + (CBound 0)) + claimProperty <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet] + propertyTerm) + (predicate, hypothesis, step, result) <- + maybe + (assertFailure "set-induction instance was not constructed") + pure + (scopedSetInductionInstance 0 claimProperty) + let abstractedProperty = + CImp + (CEq TySet + (CBound 0) + (CIntrinsic Empty)) + (CEq TySet + (CBound 0) + (CBound 0)) + memberHypothesis = + CForall TySet + (CImp + (CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + (CBound 1)) + abstractedProperty) + assertEqual + "set induction abstracts the selected property once" + (CLam TySet abstractedProperty) + (scopedCoreTerm predicate) + assertEqual + "antecedent and goal are both generalized over the member" + memberHypothesis + (scopedCoreTerm hypothesis) + assertEqual + "set-induction step owns its member-wise hypothesis" + (CForall TySet + (CImp memberHypothesis abstractedProperty)) + (scopedCoreTerm step) + assertEqual + "set-induction result closes the complete property" + (CForall TySet abstractedProperty) + (scopedCoreTerm result) + +specializesCheckedSeparationCharacteristic :: Assertion +specializesCheckedSeparationCharacteristic = do + foundation <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + let bound = CIntrinsic Empty + predicate = + CLam TySet + (CEq TySet (CBound 0) (CBound 0)) + separation = + CApp + (CApp (CIntrinsic Sep) bound) + predicate + body <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + separation) + definition <- + maybe + (assertFailure "separation did not form a set definition") + pure + (scopedSetDefinition + (Foundation.foundationAxiomFrozen + foundation + Foundation.SeparationCharacteristic) + body) + let generated = + instantiateCanonical + separation + (scopedCoreTerm definition) + expected = + betaNormalize + (specializeForall predicate + (specializeForall bound + (mapCanonicalGlobals absurd + (frozenCoreTerm + (Foundation.foundationAxiomFrozen + foundation + Foundation.SeparationCharacteristic))))) + assertEqual + "local characteristic is the checked rule specialization" + expected + generated + +specializesCheckedReplacementCharacteristic :: Assertion +specializesCheckedReplacementCharacteristic = do + foundation <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + pair <- checked [] (CGlobal TestPairGlobal) + domain <- checked [] (CIntrinsic Empty) + value <- checked [TySet] (CBound 0) + (graph, checkedDomain, function) <- + maybe + (assertFailure "checked values did not form a replacement graph") + pure + (scopedReplacementGraph pair domain value) + definition <- + maybe + (assertFailure "replacement graph did not form a definition") + pure + (scopedCharacteristicDefinition + (Foundation.foundationAxiomFrozen + foundation + Foundation.ReplacementCharacteristic) + graph + (checkedDomain :| [function])) + let generated = + instantiateCanonical + (scopedCoreTerm graph) + (scopedCoreTerm definition) + expected = + betaNormalize + (specializeForall (scopedCoreTerm function) + (specializeForall (scopedCoreTerm checkedDomain) + (mapCanonicalGlobals absurd + (frozenCoreTerm + (Foundation.foundationAxiomFrozen + foundation + Foundation.ReplacementCharacteristic))))) + assertEqual + "local graph characteristic is the checked rule specialization" + expected + generated + where + checked context term = + either + (assertFailure . show) + pure + (checkScopedCanonicalCore testGlobalType context term) + +derivesNamedConstructionViews :: Assertion +derivesNamedConstructionViews = do + foundation <- + either (assertFailure . show) pure Foundation.checkedFoundation + bound <- checked [] (CIntrinsic Empty) + predicate <- checked [TySet] (CEq TySet (CBound 0) (CBound 0)) + separation <- + maybe + (assertFailure "checked separation descriptor failed") + pure + (checkedSeparationConstruction testGlobalType bound predicate) + (separationView, separationEquation) <- + maybe + (assertFailure "checked separation views failed") + pure + (namedSetConstructionLocalViews + (checkedFoundationSetConstruction foundation) + separation) + expectedSeparationView <- + maybe + (assertFailure "checked separation characteristic failed") + pure + (scopedSetDefinition + (Foundation.foundationAxiomFrozen foundation + Foundation.SeparationCharacteristic) + (namedSetConstructionTerm separation)) + assertEqual "separation view is the checked specialization" + expectedSeparationView separationView + assertEqual "separation view is first-order" + (Set.singleton Foundation.EmptyCharacteristic) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm separationView)) + assertEqual "separation equation retains exact construction" + (Set.fromList + [ Foundation.EmptyCharacteristic + , Foundation.SeparationCharacteristic + ]) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm separationEquation)) + + firstDomain <- checked [] (CIntrinsic Empty) + singleValue <- checked [TySet] (CBound 0) + singleCondition <- checked [TySet] + (CEq TySet (CBound 0) (CBound 0)) + singleReplacement <- + maybe + (assertFailure "checked one-domain replacement failed") + pure + (checkedFunctionalReplacementConstruction + testGlobalType + (firstDomain :| []) + singleValue + (Just singleCondition)) + assertEqual "one-domain replacement has one canonical term" + (CApp + (CApp + (CIntrinsic Repl) + (CApp + (CApp (CIntrinsic Sep) (CIntrinsic Empty)) + (CLam TySet + (CEq TySet (CBound 0) (CBound 0))))) + (CLam TySet (CBound 0))) + (scopedCoreTerm + (namedSetConstructionTerm singleReplacement)) + + secondDomain <- checked [TySet] (CBound 0) + value <- checked [TySet, TySet] (CBound 0) + condition <- checked [TySet, TySet] + (CEq TySet (CBound 0) (CBound 0)) + replacement <- + maybe + (assertFailure "checked replacement descriptor failed") + pure + (checkedFunctionalReplacementConstruction + testGlobalType + (firstDomain :| [secondDomain]) + value + (Just condition)) + (replacementView, replacementEquation) <- + maybe + (assertFailure "checked replacement views failed") + pure + (namedSetConstructionLocalViews + (checkedFoundationSetConstruction foundation) + replacement) + let terminal = + andP + (CEq TySet (CBound 0) (CBound 0)) + (CEq TySet (CBound 2) (CBound 0)) + secondWitness = + existsP + (andP + (memberP (CBound 0) (CBound 1)) + terminal) + firstWitness = + existsP + (andP + (memberP (CBound 0) (CIntrinsic Empty)) + secondWitness) + expectedReplacementTerm = + CForall TySet + (CEq TyProp + (memberP (CBound 0) (CBound 1)) + firstWitness) + expectedReplacementView <- checked [TySet] expectedReplacementTerm + assertEqual "replacement view preserves bounds and condition" + expectedReplacementView replacementView + assertEqual "flattened replacement view is first-order" + (Set.singleton Foundation.EmptyCharacteristic) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm replacementView)) + assertEqual "replacement equation retains every helper" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.EmptyCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm replacementEquation)) + where + checked context term = + either + (assertFailure . show) + pure + (checkScopedCanonicalCore testGlobalType context term) + + memberP element set = + CApp (CApp (CIntrinsic Member) element) set + + notP proposition = CImp proposition CFalsum + + andP left right = + notP (CImp left (notP right)) + + existsP proposition = + notP (CForall TySet (notP proposition)) + +specializeForall + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +specializeForall argument = \case + CForall _binderType body -> + instantiateCanonical argument body + _ -> + error "the checked characteristic lost a binder" + +betaNormalize :: CanonicalTerm global -> CanonicalTerm global +betaNormalize = \case + CApp function argument -> + case betaNormalize function of + CLam _binderType body -> + betaNormalize + (instantiateCanonical + (betaNormalize argument) + body) + normalizedFunction -> + CApp normalizedFunction (betaNormalize argument) + CLam binderType body -> + CLam binderType (betaNormalize body) + CImp premise conclusion -> + CImp + (betaNormalize premise) + (betaNormalize conclusion) + CEq operandType left right -> + CEq operandType + (betaNormalize left) + (betaNormalize right) + CForall binderType body -> + CForall binderType (betaNormalize body) + term -> term + +thawsCheckedClosedTerms :: Assertion +thawsCheckedClosedTerms = do + let source = + coreLambda TySet (0 :: Int) + (coreForall TySet 1 + (coreEquality + TySet + (coreLocal 0) + (coreLocal 1))) + freeze syntax = do + checked <- + either + (assertFailure . show) + pure + (checkClosedCore testGlobalType syntax) + either + (assertFailure . show) + pure + (freezeClosed checked) + original <- + freeze source + roundTrip <- + freeze (thawFrozenCore original) + assertEqual "frozen term" original roundTrip + assertEqual + "global inventory" + mempty + (frozenCoreGlobals original) + +prop_freezeAgreesWithReference :: Property +prop_freezeAgreesWithReference = property do + depth <- + forAll (Gen.int (Range.linear 1 10)) + binderTypes <- + forAll + (Gen.list + (Range.singleton depth) + (Gen.element + [ TyProp + , TySet + , TySet `TyArrow` TySet + ])) + selected <- + forAll + (Gen.maybe + (Gen.int (Range.linear 0 (depth - 1)))) + let binders = + zip [0 :: Int ..] binderTypes + body = + maybe + (coreGlobal TestGlobal) + coreLocal + selected + term = + foldr + (\(local, binderType) -> + coreLambda binderType local) + body + binders + checked <- + evalEither + (checkClosedCore testGlobalType term) + optimized <- + evalEither (force <$> freezeClosed checked) + reference <- + evalEither (force <$> referenceFreezeClosed checked) + optimized === reference diff --git a/source/Felix/Test/Unit/Declaration.hs b/source/Felix/Test/Unit/Declaration.hs new file mode 100644 index 0000000..f3d9be7 --- /dev/null +++ b/source/Felix/Test/Unit/Declaration.hs @@ -0,0 +1,3596 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Declaration (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Vocabulary qualified as Vocabulary +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Kernel.Derivation qualified as Kernel +import Felix.Checking.SetConstruction qualified as SetConstruction +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Math.Codec +import Felix.Module +import Felix.Source +import Felix.Store qualified as Store +import Felix.Meaning qualified as Meaning +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon + +import Data.List.NonEmpty qualified as NonEmpty +import Data.IORef qualified as IORef +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad.Except (runExceptT) +import Control.Monad.State (evalState) +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Typed declaration seam" + [ testCase "enforces staged candidate order" + enforcesStagedCandidateOrder + , testCase "retains only appended declaration prefixes" + retainsOnlyAppendedPrefixes + , testCase "makes declaration failures terminal" + makesDeclarationFailuresTerminal + , testCase "propagates unsafe authority through local claims" + propagatesUnsafeAuthorityThroughLocalClaims + , testCase "aggregates exact Vampire obligations" + aggregatesExactVampireObligations + , testCase "validates complete resolver batches before rejection" + validatesCompleteResolverBatchesBeforeRejection + , testCase "rejects retained-plan admission drift fatally" + rejectsRetainedPlanAdmissionDrift + , testCase "preserves source-axiom safety through Vampire validation" + preservesSourceAxiomSafetyThroughVampireValidation + , testCase "materializes a sealed import with fresh authority" + materializesSealedImport + , testCase "reconstructs exact imported global bindings" + reconstructsImportedGlobalBindings + , testCase "elaborates scoped exact propositions" + elaboratesScopedExactPropositions + , testCase "lowers fixed equality aliases without global support" + lowersFixedEqualityAliases + , testCase "scopes quantified proposition terms" + scopesQuantifiedPropositionTerms + , testCase "prepares exact claim envelopes" + preparesExactClaimEnvelopes + , testCase "lowers exact separation comprehensions" + lowersExactSeparationComprehensions + , testCase "lowers exact replacement telescopes" + lowersExactReplacementTelescopes + , testCase "lowers exact finite sets" + lowersExactFiniteSets + , testCase "lowers exact ordinary declarations" + lowersExactOrdinaryDeclarations + , testCase "folds transitive and diamond import evidence" + foldsTransitiveAndDiamondEvidence + , testCase "validates exact kernel construction descriptors" + validatesExactKernelConstructionDescriptors + , testCase "authorizes exact datatype compilation families" + authorizesExactDatatypeCompilationFamilies + , testCase "reuses exact compiled declaration validation" + reusesExactCompiledDeclarationValidation + , testCase "keeps fatal validation lookup failures out of declarations" + keepsFatalValidationLookupFailuresOutOfDeclarations + ] + +data FatalValidationLookup = FatalValidationLookup + deriving (Show) + +instance Exception.Exception FatalValidationLookup + +keepsFatalValidationLookupFailuresOutOfDeclarations :: Assertion +keepsFatalValidationLookupFailuresOutOfDeclarations = do + fixture <- makeFixture + prepared <- makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let lookup = proofOnlyValidationLookup + (const (Exception.throwIO FatalValidationLookup)) + action = Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "fatal-validation-lookup") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "fatal-validation-lookup") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + result <- Exception.try + (runDriverWithValidation fixture lookup action) + :: IO + (Either + FatalValidationLookup + (Declaration.DriverResult + Void + ((), Declaration.CommittedDeclarationBatch))) + case result of + Left FatalValidationLookup -> pure () + Right _ -> + assertFailure "fatal validation lookup became a driver result" + +enforcesStagedCandidateOrder :: Assertion +enforcesStagedCandidateOrder = do + fixture <- makeFixture + accepted <- runSuccessful fixture do + result <- Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "staged-success") do + first <- Declaration.reserveCandidate + (factSpec fixture "first") + later <- Declaration.reserveCandidateBatch + ( factSpec fixture "later-a" + :| [factSpec fixture "later-b"] + ) + Declaration.authorizeCompiledDeclaration do + Declaration.authorizeSourceAxiomCandidate first + traverse_ + (\candidate -> + Declaration.authorizeKernelProofCandidate + candidate do + premise <- + Declaration.useStagedCandidate first + pure + (Kernel.importedFactDerivation premise)) + later + pure result + let (_value, batch) = accepted + assertEqual + "all source-ordered candidates appended" + 3 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch))) + + provenance <- runDriver fixture (priorDeclarationUse fixture) + case provenance of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.CandidateOutsideDeclaration slot)) + prefix -> do + assertEqual + "cross-declaration staged premise" + (localFact fixture 0) + slot + assertSingleCompletedPrefix prefix + _other -> + assertFailure + "cross-declaration staged provenance was not rejected" + + traverse_ + (\(label, action, expectedPremise, expectedCandidate) -> do + result <- runDriver fixture action + case result of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.StagedPremiseNotEarlier + premiseSlot premiseStage + candidateSlot candidateStage)) + _prefix -> do + assertEqual (label <> " premise slot") + expectedPremise premiseSlot + assertEqual (label <> " candidate slot") + expectedCandidate candidateSlot + assertBool (label <> " rejected non-earlier stage") + (premiseStage >= candidateStage) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) + _prefix -> + assertFailure + (label <> ": unexpected error " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) + _prefix -> + assertFailure + (label <> ": unexpected ordinary driver failure") + Declaration.DriverSucceeded{} -> + assertFailure (label <> ": invalid staged use succeeded") + Declaration.DriverSealFailed{} -> + assertFailure (label <> ": invalid staged use reached sealing")) + [ ( "self" + , selfUse fixture + , localFact fixture 0 + , localFact fixture 0 + ) + , ( "same stage" + , sameStageUse fixture + , localFact fixture 1 + , localFact fixture 0 + ) + , ( "forward" + , forwardUse fixture + , localFact fixture 1 + , localFact fixture 0 + ) + ] + where + localFact fixture ordinal = + Semantic.factSlot + (fixtureOwner fixture) + (localFactOrdinal ordinal) + + selfUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "self") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "self") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate candidate do + premise <- Declaration.useStagedCandidate candidate + pure (Kernel.importedFactDerivation premise)) + + sameStageUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "same-stage") do + candidates <- Declaration.reserveCandidateBatch + ( factSpec fixture "same-a" + :| [factSpec fixture "same-b"] + ) + let first = NonEmpty.head candidates + second = NonEmpty.last candidates + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate first do + premise <- Declaration.useStagedCandidate second + pure (Kernel.importedFactDerivation premise)) + + forwardUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "forward") do + first <- Declaration.reserveCandidate + (factSpec fixture "forward-a") + second <- Declaration.reserveCandidate + (factSpec fixture "forward-b") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate first do + premise <- Declaration.useStagedCandidate second + pure (Kernel.importedFactDerivation premise)) + + priorDeclarationUse fixture = do + (premise, _batch) <- Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "prior-stage") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "prior-stage") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeSourceAxiomCandidate candidate) + pure candidate + void + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "later-stage") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "later-stage") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate candidate do + imported <- + Declaration.useStagedCandidate premise + pure (Kernel.importedFactDerivation imported))) + +retainsOnlyAppendedPrefixes :: Assertion +retainsOnlyAppendedPrefixes = do + fixture <- makeFixture + outcome <- runDriver fixture do + (_value, _firstBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "accepted") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "accepted") + Declaration.authorizeSourceAxiomCandidate candidate + Declaration.failModuleDriver + ("later checker failure" :: Text) + case outcome of + Declaration.DriverFailed + (Declaration.DriverActionFailed reason) prefix -> do + assertEqual + "driver reports the later ordinary failure" + "later checker failure" + reason + assertSingleCompletedPrefix prefix + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed err) _prefix -> + assertFailure + ("unexpected declaration failure: " <> show err) + Declaration.DriverSucceeded{} -> + assertFailure "ordinary driver failure was lost" + Declaration.DriverSealFailed{} -> + assertFailure "ordinary driver failure became a seal failure" + +makesDeclarationFailuresTerminal :: Assertion +makesDeclarationFailuresTerminal = do + fixture <- makeFixture + outcome <- runDriver fixture do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "accepted-before-failure") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "accepted-before-failure") + Declaration.authorizeSourceAxiomCandidate candidate) + void + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "rolled-back") do + void + (Declaration.reserveCandidate + (factSpec fixture "uncommitted"))) + -- This declaration must be unreachable after the terminal failure. + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "must-not-publish") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "must-not-publish") + Declaration.authorizeSourceAxiomCandidate candidate) + case outcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DeclarationHasUnauthorizedCandidates) + prefix -> + assertSingleCompletedPrefix prefix + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected declaration failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "failed declaration was skipped" + Declaration.DriverSealFailed{} -> + assertFailure "failed declaration reached sealing" + +assertSingleCompletedPrefix + :: Declaration.PendingModulePrefix + -> Assertion +assertSingleCompletedPrefix prefix = do + let batches = + Declaration.pendingModulePrefixBatches prefix + assertEqual "one completed envelope survives" 1 (length batches) + case batches of + [batch] -> do + let expected = + Declaration.committedBatchNextPrefix batch + assertEqual + "failed declaration did not advance the prefix" + expected + (Declaration.pendingModulePrefixCurrent prefix) + assertEqual + "retained envelope ends at the exposed prefix" + expected + (Declaration.committedBatchNextPrefix batch) + _ -> pure () + +propagatesUnsafeAuthorityThroughLocalClaims :: Assertion +propagatesUnsafeAuthorityThroughLocalClaims = do + fixture <- makeFixture + result <- runSuccessful fixture do + (_sourceValue, sourceBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source") + Declaration.authorizeSourceAxiomCandidate candidate + sourceOccurrence <- requireSingleOccurrence sourceBatch + let + sourceFingerprint = + Semantic.semanticFactFingerprint sourceOccurrence + (_derivedValue, derivedBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "local-claim") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "derived") + Declaration.authorizeKernelProofCandidate candidate do + sourcePremise <- + Declaration.useAuthorizedFact sourceFingerprint + claim <- Declaration.proveLocalKernelClaim + (fixtureProposition fixture) + (Kernel.importedFactDerivation sourcePremise) + claimPremise <- Declaration.useLocalClaim claim + pure (Kernel.importedFactDerivation claimPremise) + pure derivedBatch + occurrence <- + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta result) of + [single] -> pure single + facts -> + assertFailure + ("unexpected fact count: " <> show (length facts)) + >> fail "unreachable" + let authority = Semantic.semanticFactAuthority occurrence + assertEqual + "local claim cannot erase source-axiom safety" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom)) + (Authority.factAuthoritySafety authority) + case Declaration.committedBatchProofValidations result of + [record] -> + assertEqual + "local support is absent from the compact direct authorization" + (Authority.CheckedSourceProof []) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected proof validation count: " + <> show (length records)) + +aggregatesExactVampireObligations :: Assertion +aggregatesExactVampireObligations = + withTemporaryDirectory "felix-declaration-vampire" \root -> do + fixture <- makeFixture + let executable = root Posix. "vampire" + writeAcceptedVampire executable + first <- makePreparedObligation + fixture + Foundation.EmptyCharacteristic + second <- makePreparedObligation + fixture + Foundation.PairSetCharacteristic + let exactResolver = acceptedResolver executable + freshOutcome <- + (runDriverWithResolver fixture exactResolver do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + :: IO + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch)) + (batch, freshPrefix) <- + case freshOutcome of + Declaration.DriverSucceeded value _ prefix _closure -> + pure (value, prefix) + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh Vampire fixture failed: " <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh Vampire fixture did not seal: " + <> show failure) + >> fail "unreachable" + let expectedRequests = + Provers.preparedVerificationRequestId + (Provers.preparedTypedProverRequest first) + : [Provers.preparedVerificationRequestId + (Provers.preparedTypedProverRequest second)] + case Declaration.committedBatchProofValidations batch of + [record] -> + assertEqual + "accepted requests retain source order" + (Authority.CheckedSourceProof expectedRequests) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected proof validation count: " + <> show (length records)) + + cachedRecord <- + case Declaration.committedBatchProofValidations batch of + [record] -> pure record + records -> + assertFailure + ("unexpected cached proof records: " + <> show (length records)) + >> fail "unreachable" + cachedLookupKey <- IORef.newIORef Nothing + cached <- runSuccessfulWithValidation fixture + (proofOnlyValidationLookup + (\key -> do + IORef.writeIORef cachedLookupKey (Just key) + pure (Just cachedRecord))) do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + publishedRecord <- + case Declaration.committedBatchProofValidations cached of + [record] -> pure record + records -> + assertFailure + ("unexpected cached validation records: " + <> show (length records)) + >> fail "unreachable" + assertEqual + "cached authorization preserves the exact direct proof" + (Authority.CheckedSourceProof expectedRequests) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate publishedRecord)) + assertEqual + "lookup and publication retain the same validation key" + (Semantic.proofValidationRecordKey cachedRecord) + (Semantic.proofValidationRecordKey publishedRecord) + assertEqual + "one proof syntax key governs lookup and publication" + (Just + (Semantic.proofValidationRecordKey cachedRecord)) + =<< IORef.readIORef cachedLookupKey + + missLookups <- IORef.newIORef (0 :: Int) + missRuns <- IORef.newIORef (0 :: Int) + let missLookup = proofOnlyValidationLookup \_key -> do + IORef.modifyIORef' missLookups (+ 1) + pure Nothing + missResolver = Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' missRuns (+ 1) + resolveAccepted executable prepared + miss <- runDriverWithValidationAndResolver + fixture + missLookup + missResolver + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + case miss of + Declaration.DriverSucceeded{} -> pure () + _ -> + assertFailure "warm miss failed" + assertEqual "warm miss performs one exact lookup" + 1 + =<< IORef.readIORef missLookups + assertEqual "warm miss runs every reached Vampire request" + 2 + =<< IORef.readIORef missRuns + + mismatchRuns <- IORef.newIORef (0 :: Int) + let editedSyntax = + Semantic.proofSyntaxId "edited-proof-syntax" + cachedCertificate = + Semantic.proofValidationRecordCertificate cachedRecord + corruptedKey = + Semantic.proofValidationKey + (Identity.theoremId + (Authority.factAuthorityTheorem + (Authority.validationTarget + cachedCertificate))) + editedSyntax + (Declaration.committedBatchPreviousPrefix batch) + corruptedRecord = + Semantic.proofValidationRecord + corruptedKey + cachedCertificate + mismatchResolver = Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' mismatchRuns (+ 1) + resolveAccepted executable prepared + mismatchingLookup = proofOnlyValidationLookup + (const (pure (Just corruptedRecord))) + mismatching <- Exception.try + (runDriverWithValidationAndResolver + fixture + mismatchingLookup + mismatchResolver + do + Declaration.commitProofDeclaration editedSyntax do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first)) + :: IO + (Either + Declaration.ValidationIntegrityError + (Declaration.DriverResult + Text + ((), Declaration.CommittedDeclarationBatch))) + case mismatching of + Left Declaration.CachedValidationIntegrityError{} -> + pure () + Right _ -> + assertFailure "mismatching hit did not abort as corruption" + assertEqual "mismatching hit does not fall back to Vampire" + 0 + =<< IORef.readIORef mismatchRuns + + withOpenedStore fixture root \store -> do + expectRightIO + (Store.writePendingModulePrefix store freshPrefix) + warmCalls <- IORef.newIORef (0 :: Int) + let storeLookup = proofOnlyValidationLookup \key -> do + IORef.modifyIORef' warmCalls (+ 1) + Store.loadProofValidation store key >>= expectRight + warm <- runSuccessfulWithValidation fixture + storeLookup + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + assertEqual "warm lookup executes once through the store" + 1 + =<< IORef.readIORef warmCalls + assertEqual "warm path retains cached request IDs" + (Authority.CheckedSourceProof expectedRequests) + (case Declaration.committedBatchProofValidations warm of + [record] -> + Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) + records -> + error + ("unexpected warm validation records: " + <> show (length records))) + + emptyProof <- runDriver fixture do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "empty-vampire-proof") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "empty-vampire-proof") + Declaration.authorizeVampireCandidate candidate + (pure ()) + case emptyProof of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireProofHasNoAcceptedObligations) + prefix -> + assertEqual + "empty Vampire proof publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected empty-proof failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "empty Vampire proof was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "empty Vampire proof reached sealing" + + invalidClosure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId (fixtureFoundation fixture)) + []) + invalidTarget <- expectRight + (Identity.validatePropositionContent + invalidClosure + (Core.CImp Core.CFalsum Core.CFalsum)) + invalidCalls <- IORef.newIORef (0 :: Int) + let invalidResolver = + Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' invalidCalls (+ 1) + resolveAccepted executable prepared + invalid <- runDriverWithResolver fixture invalidResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "invalid-vampire-target") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + invalidTarget + Semantic.SearchEligible + [Semantic.semanticName + "invalid-vampire-target"]) + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first) + assertEqual + "invalid prepared problem does not invoke Vampire" + 0 + =<< IORef.readIORef invalidCalls + case invalid of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireTargetMismatch) + prefix -> + assertEqual + "invalid prepared problem publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected prepared-problem failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "invalid prepared problem was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "invalid prepared problem reached sealing" + + let mismatchedResolver = + Declaration.vampireResolver \_prepared -> + resolveAccepted executable second + mismatch <- runDriverWithResolver fixture mismatchedResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "mismatched-vampire-request") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "mismatched-vampire-request") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first) + case mismatch of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireRequestMismatch) + prefix -> + assertEqual + "mismatch publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected mismatch failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "mismatched request was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "mismatched request reached sealing" + + unrecorded <- runDriver fixture do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "unrecorded-omission") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "unrecorded-omission") + Declaration.authorizeOmittedCandidate candidate + (pure ()) + case unrecorded of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.OmittedProofDidNotRecordUse) + prefix -> + assertEqual + "unrecorded omission publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected unrecorded-omission failure: " + <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "unrecorded omission was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "unrecorded omission reached sealing" + + calls <- IORef.newIORef (0 :: Int) + let countingResolver = + Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' calls (+ 1) + resolveAccepted executable prepared + omittedBatch <- runSuccessfulWithResolver fixture countingResolver do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "omitted-after-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "omitted-after-obligations") + Declaration.authorizeOmittedCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + Declaration.recordOmittedUse + pure committed + assertEqual + "omitted proof still checks preceding obligations" + 2 + =<< IORef.readIORef calls + case Declaration.committedBatchProofValidations omittedBatch of + [record] -> + assertEqual + "omitted direct authorization discards request IDs" + Authority.OmittedAuthorization + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected omitted validation count: " + <> show (length records)) + +validatesCompleteResolverBatchesBeforeRejection :: Assertion +validatesCompleteResolverBatchesBeforeRejection = + withTemporaryDirectory "felix-declaration-batch-integrity" \root -> do + fixture <- makeFixture + let executable = root Posix. "vampire" + firstLocation = mkLocation (FileId 76) 1 1 + secondLocation = mkLocation (FileId 76) 2 1 + writeAcceptedVampire executable + mismatchedTask <- + makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let integrityResolver = + Declaration.vampireBatchResolver \_tasks -> do + mismatched <- resolveAccepted executable mismatchedTask + pure + ( Right (Provers.CounterSatisfiable "earlier") + :| [mismatched] + ) + integrityOutcome <- + (runDriverWithResolver fixture integrityResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "batch-integrity-priority") do + candidates <- Declaration.reserveCandidateBatch + ( factSpec fixture "batch-integrity-first" + :| [factSpec fixture "batch-integrity-second"] + ) + Declaration.authorizeVampireCandidateBatch + ( ( firstLocation + , NonEmpty.head candidates + , Declaration.prepareCurrentCandidateVampire + ) + :| [ ( secondLocation + , NonEmpty.last candidates + , Declaration.prepareCurrentCandidateVampire + ) + ] + ) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + case integrityOutcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireRequestMismatch)) + prefix -> do + assertEqual + "later request mismatch retains its location" + secondLocation + location + assertEqual + "integrity failure rolls back the complete declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected batch-integrity failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure + "earlier ordinary rejection concealed no integrity failure" + Declaration.DriverSealFailed{} -> + assertFailure "invalid batch reached module sealing" + + prepared <- + makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let excessResolver = + Declaration.vampireBatchResolver \_tasks -> + pure + ( Right (Provers.CounterSatisfiable "first") + :| [Right (Provers.CounterSatisfiable "excess")] + ) + excessOutcome <- + (runDriverWithResolver fixture excessResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "singleton-excess-result") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "singleton-excess-result") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + case excessOutcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.VampireResolverBatchSizeMismatch 1 2)) + prefix -> + assertEqual + "malformed singleton response publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected singleton-cardinality failure: " + <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "singleton resolver ignored an excess result" + Declaration.DriverSealFailed{} -> + assertFailure "malformed singleton reached module sealing" + +rejectsRetainedPlanAdmissionDrift :: Assertion +rejectsRetainedPlanAdmissionDrift = do + fixture <- makeFixture + let checked = + Declaration.checkedProofDeclaration + (Semantic.proofSyntaxId "planned-admission-drift") + [] + [] + [] + [] + [ Declaration.checkedCandidate + (factSpec fixture "planned-admission-drift") + Declaration.checkedSourceAxiomPlanning + :| [] + ] + () + action = do + planned <- + Declaration.runProspectiveLoweringDriver + (Declaration.planCheckedDeclaration checked) + >>= either Declaration.failDeclarationDriver pure + Declaration.admitPlannedCheckedDeclaration planned + (\() stages -> + case concatMap toList stages of + [candidate] -> + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + _ -> error "planned drift fixture candidate shape") + outcome <- + Exception.try (runDriver fixture action) + :: IO + (Either + Declaration.PlanningIntegrityError + (Declaration.DriverResult + Void + Declaration.CommittedDeclarationBatch)) + case outcome of + Left (Declaration.PlanningIntegrityError diagnostic) -> + assertBool "fatal mismatch identifies prospective contract drift" + ("prospective contract" `Text.isInfixOf` diagnostic) + Right _ -> + assertFailure + "a changed admitted authority was accepted against its plan" + +preservesSourceAxiomSafetyThroughVampireValidation :: Assertion +preservesSourceAxiomSafetyThroughVampireValidation = + withTemporaryDirectory "felix-declaration-source-axiom" \root -> do + fixture <- makeFixture + let executable = root Posix. "vampire" + writeAcceptedVampire executable + prepared <- + makePreparedObligationWithPremise + fixture + (fixtureSourceAxiomFingerprint fixture) + freshCalls <- IORef.newIORef (0 :: Int) + let freshResolver = Declaration.vampireResolver \task -> do + IORef.modifyIORef' freshCalls (+ 1) + resolveAccepted executable task + freshOutcome <- + (runDriverWithResolver fixture freshResolver + (sourceAxiomThenVampire fixture prepared) + :: IO + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch)) + assertEqual + "fresh source-axiom theorem invokes Vampire once" + 1 + =<< IORef.readIORef freshCalls + freshBatch <- + case freshOutcome of + Declaration.DriverSucceeded batch _ _ _closure -> + pure batch + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh source-axiom driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh source-axiom driver did not seal: " + <> show failure) + >> fail "unreachable" + let freshRecord = singleProofValidation freshBatch + assertEqual + "fresh theorem retains source-axiom safety" + sourceAxiomSafety + (Authority.factAuthoritySafety + (Authority.validationTarget + (Semantic.proofValidationRecordCertificate freshRecord))) + separationCalls <- IORef.newIORef (0 :: Int) + let separationResolver = Declaration.vampireResolver \task -> do + IORef.modifyIORef' separationCalls (+ 1) + resolveAccepted executable task + separated <- + (runDriverWithResolver fixture separationResolver do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom") + Declaration.authorizeSourceAxiomCandidate candidate) + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "atp-does-not-import") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "atp-does-not-import") + Declaration.authorizeKernelProofCandidate candidate do + Declaration.acceptVampireObligation prepared + pure + (Kernel.importedFactDerivation + (Kernel.importIx 0)) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + assertEqual "mixed proof executes its ATP obligation" + 1 + =<< IORef.readIORef separationCalls + case separated of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.KernelCompletionFailed + (Kernel.KernelReplayImportOutOfBounds index))) + prefix -> do + assertEqual "ATP premise is absent from kernel imports" + (Kernel.importIx 0) + index + assertEqual "failed mixed proof retains only its prefix" + 1 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected mixed-proof failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "ATP premise entered the kernel import inventory" + Declaration.DriverSealFailed{} -> + assertFailure "mixed proof unexpectedly reached sealing" + withOpenedStore fixture root \store -> do + freshPrefix <- + case freshOutcome of + Declaration.DriverSucceeded _ _ prefix _closure -> + pure prefix + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh source-axiom driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh source-axiom driver did not seal: " + <> show failure) + >> fail "unreachable" + expectRightIO + (Store.writePendingModulePrefix store freshPrefix) + warmCalls <- IORef.newIORef (0 :: Int) + let storeLookup = proofOnlyValidationLookup \key -> do + IORef.modifyIORef' warmCalls (+ 1) + Store.loadProofValidation store key >>= expectRight + warmBatch <- runSuccessfulWithValidation fixture + storeLookup + (sourceAxiomThenVampire fixture prepared) + assertEqual + "warm source-axiom theorem performs one store lookup" + 1 + =<< IORef.readIORef warmCalls + assertEqual + "warm theorem retains source-axiom safety" + sourceAxiomSafety + (Authority.factAuthoritySafety + (Authority.validationTarget + (Semantic.proofValidationRecordCertificate + (singleProofValidation warmBatch)))) + where + sourceAxiomSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + + singleProofValidation batch = + case Declaration.committedBatchProofValidations batch of + [record] -> record + records -> + error + ("unexpected proof validation count: " + <> show (length records)) + +sourceAxiomThenVampire + :: Fixture + -> Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId + -> Declaration.ModuleDriver failure + Declaration.CommittedDeclarationBatch +sourceAxiomThenVampire fixture prepared = do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom") + Declaration.authorizeSourceAxiomCandidate candidate) + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom-vampire") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom-vampire") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + pure batch + +fixtureSourceAxiomFingerprint + :: Fixture + -> Semantic.SemanticFactOccurrenceFingerprint +fixtureSourceAxiomFingerprint fixture = + Semantic.semanticFactOccurrenceFingerprint + (Semantic.factSlot + (fixtureOwner fixture) + (localFactOrdinal 0)) + (Authority.factAuthority + (Identity.theoremRef + (Identity.theoryId (fixtureFoundation fixture)) + (Identity.checkedPropositionId + (fixtureProposition fixture))) + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom))) + +makePreparedObligationWithPremise + :: Fixture + -> Semantic.SemanticFactOccurrenceFingerprint + -> IO + (Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId) +makePreparedObligationWithPremise fixture fingerprint = do + claim <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + factProposition <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + capability <- expectRight + (Backend.classifySupportedProposition + (const Nothing) + factProposition) + problem <- expectRight + (Backend.planTypedProblem + (const Nothing) + (Vector.singleton + (Backend.typedBackendFact + fingerprint + factProposition + capability)) + claim + [] + [] + Backend.FirstOrderLocals + Backend.ExplicitHigherOrderJustification) + expectRight + (Provers.prepareTypedProverTask + Provers.DirectTask + problem) + +makePreparedObligation + :: Fixture + -> Foundation.FoundationAxiomTag + -> IO + (Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId) +makePreparedObligation fixture tag = do + claim <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + problem <- expectRight + (Backend.planTypedProblem + (const Nothing) + Vector.empty + claim + [] + [Backend.typedFoundationAuxiliaryInput + (fixtureFoundation fixture) + tag] + Backend.CompleteLocals + Backend.ExplicitHigherOrderJustification) + expectRight + (Provers.prepareTypedProverTask + Provers.DirectTask + problem) + +acceptedResolver :: FilePath -> Declaration.VampireResolver +acceptedResolver executable = + Declaration.vampireResolver (resolveAccepted executable) + +resolveAccepted + :: FilePath + -> Provers.PreparedTypedProverTask + ref local origin global + -> IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer) +resolveAccepted executable prepared = + Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared + +writeAcceptedVampire :: FilePath -> IO () +writeAcceptedVampire executable = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for typed'" + ]) + permissions <- Directory.getPermissions executable + Directory.setPermissions executable + (Directory.setOwnerExecutable True permissions) + +validatesExactKernelConstructionDescriptors :: Assertion +validatesExactKernelConstructionDescriptors = do + fixture <- makeFixture + proposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + let declaredObject = opaqueFixtureObject fixture + run descriptor = + runDriver fixture + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + "kernel-construction-descriptor") do + Declaration.addDeclarationObject declaredObject + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName "kernel-construction"]) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelConstructionCandidate + descriptor + candidate + (pure + (Kernel.foundationFactDerivation + Foundation.EmptyCharacteristic)))) + success <- run + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + case success of + Declaration.DriverSucceeded (_value, batch) _interface _prefix _closure -> do + assertEqual + "new object is included in the checked declaration batch" + 1 + (length (Declaration.committedBatchObjects batch)) + case Declaration.committedBatchDeclarationValidation batch of + Just record -> + case Semantic.declarationValidationRecordCertificates + record of + [certificate] -> + assertEqual + "exact kernel descriptor is retained" + (Authority.CheckedKernelConstruction + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic)) + (Authority.validationDirectAuthorization + certificate) + certificates -> + assertFailure + ("unexpected kernel certificate count: " + <> show (length certificates)) + Nothing -> + assertFailure "missing declaration validation" + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed failure) _prefix -> + assertFailure + ("valid kernel descriptor failed: " <> show failure) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) + + traverse_ + (\(label, descriptor) -> do + outcome <- run descriptor + case outcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.KernelConstructionDescriptorMismatch) + prefix -> + assertEqual + (label <> " publishes no declaration") + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) + _prefix -> + assertFailure + (label <> ": unexpected error " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) + _prefix -> + assertFailure (label <> ": ordinary driver failure") + Declaration.DriverSucceeded{} -> + assertFailure (label <> ": mismatch was accepted") + Declaration.DriverSealFailed{} -> + assertFailure (label <> ": mismatch reached sealing")) + [ ( "wrong foundation leaf" + , Authority.FoundationLeaf + Foundation.PairSetCharacteristic + ) + , ( "wrong construction family" + , Authority.GuardedFoundationRules + (Authority.guardedRuleSet + (Foundation.SetLfpBound :| [])) + ) + ] + +authorizesExactDatatypeCompilationFamilies :: Assertion +authorizesExactDatatypeCompilationFamilies = do + fixture <- makeFixture + firstProposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + secondProposition <- foundationProposition + fixture + Foundation.PairSetCharacteristic + let carrier = datatypeFixtureObject fixture 0 + constructor = datatypeFixtureObject fixture 1 + carrierId = Identity.assertedObjectId carrier + constructorId = Identity.assertedObjectId constructor + references = + fmap + (Identity.theoremRef + (Identity.theoryId + (fixtureFoundation fixture)) + . Identity.checkedPropositionId) + [firstProposition, secondProposition] + descriptor = + Authority.datatypeCompilationDescriptor + carrierId + (constructorId :| []) + references + action + :: Authority.DatatypeCompilationDescriptor + -> Declaration.ModuleDriver Text + ((), Declaration.CommittedDeclarationBatch) + action suppliedDescriptor = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "datatype-compilation") do + traverse_ Declaration.addDeclarationObject + [carrier, constructor] + candidates <- + Declaration.reserveCandidateBatch + ( Declaration.candidateSpec + firstProposition + Semantic.SearchEligible + [Semantic.semanticName "datatype-first"] + :| [ Declaration.candidateSpec + secondProposition + Semantic.SearchEligible + [Semantic.semanticName "datatype-second"] + ] + ) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeDatatypeCompilationCandidates + suppliedDescriptor + carrierId + (constructorId :| []) + candidates) + + (_value, batch) <- runSuccessful fixture (action descriptor) + assertEqual "complete object family was published" + [carrier, constructor] + (Declaration.committedBatchObjects batch) + case Declaration.committedBatchDeclarationValidation batch of + Just record -> do + let certificates = + Semantic.declarationValidationRecordCertificates record + assertEqual "complete fact family was authorized" 2 + (length certificates) + traverse_ + (\certificate -> do + assertEqual "datatype authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget certificate)) + assertEqual "one descriptor protects every member" + (Authority.TrustedCompilation + (Authority.DatatypeCompilation descriptor)) + (Authority.validationDirectAuthorization certificate)) + certificates + Nothing -> + assertFailure "datatype compilation omitted validation" + + let mismatched = + Authority.datatypeCompilationDescriptor + carrierId + (constructorId :| []) + (reverse references) + rejected <- runDriver fixture (action mismatched) + case rejected of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DatatypeCompilationDescriptorMismatch) + prefix -> + assertEqual "mismatched family publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected datatype-family failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "mismatched datatype family was authorized" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("mismatched datatype family reached sealing: " + <> show failure) + +reusesExactCompiledDeclarationValidation :: Assertion +reusesExactCompiledDeclarationValidation = do + fixture <- makeFixture + proposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + let declaredObject = opaqueFixtureObject fixture + syntax = + Semantic.declarationSyntaxId + "cached-kernel-construction" + action derivationTag = + Declaration.commitCompiledDeclaration syntax do + Declaration.addDeclarationObject declaredObject + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName + "cached-kernel-construction"]) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelConstructionCandidate + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + candidate + (pure + (Kernel.foundationFactDerivation + derivationTag))) + freshBatch <- runSuccessful fixture + (snd <$> action Foundation.EmptyCharacteristic) + freshRecord <- + case Declaration.committedBatchDeclarationValidation freshBatch of + Just record -> pure record + Nothing -> + assertFailure "fresh compiled declaration omitted validation" + >> fail "unreachable" + + missLookups <- IORef.newIORef (0 :: Int) + missBatch <- runSuccessfulWithValidation fixture + (compiledOnlyValidationLookup \_key -> do + IORef.modifyIORef' missLookups (+ 1) + pure Nothing) + (snd <$> action Foundation.EmptyCharacteristic) + assertEqual "compiled warm miss performs one exact lookup" + 1 + =<< IORef.readIORef missLookups + assertBool "compiled miss publishes fresh validation" + (isJust + (Declaration.committedBatchDeclarationValidation missBatch)) + + hitLookups <- IORef.newIORef [] + hitBatch <- runSuccessfulWithValidation fixture + (compiledOnlyValidationLookup \key -> do + IORef.modifyIORef' hitLookups (key :) + pure (Just freshRecord)) + (snd <$> action Foundation.PairSetCharacteristic) + assertEqual "compiled warm hit performs one exact lookup" + [Semantic.declarationValidationRecordKey freshRecord] + . reverse + =<< IORef.readIORef hitLookups + case Declaration.committedBatchDeclarationValidation hitBatch of + Just record -> + assertEqual + "compiled hit republishes the exact validation" + freshRecord + record + Nothing -> + assertFailure "compiled hit omitted validation" + +foundationProposition + :: Fixture + -> Foundation.FoundationAxiomTag + -> IO Identity.CheckedPropositionContent +foundationProposition fixture tag = do + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId (fixtureFoundation fixture)) + []) + expectRight + (Identity.validatePropositionContent + closure + (Core.frozenCoreTerm + (Core.mapFrozenGlobals + absurd + (Foundation.foundationAxiomFrozen + (fixtureFoundation fixture) + tag)))) + +opaqueFixtureObject :: Fixture -> Identity.AssertedObject +opaqueFixtureObject fixture = + let theory = Identity.theoryId (fixtureFoundation fixture) + seed = + Identity.opaqueDeclarationSeed + (fixtureOwner fixture) + (localDeclarationOrdinal 0) + SignatureDeclaration + (generatedObjectSlot 0) + identity = + Identity.opaqueObjectId + theory + seed + Core.TySet + in Identity.assertedObject + identity + (Identity.OpaqueObjectContent + theory + seed + Core.TySet) + +datatypeFixtureObject + :: Fixture + -> Natural + -> Identity.AssertedObject +datatypeFixtureObject fixture slot = + let theory = Identity.theoryId (fixtureFoundation fixture) + seed = + Identity.opaqueDeclarationSeed + (fixtureOwner fixture) + (localDeclarationOrdinal 0) + DatatypeDeclaration + (generatedObjectSlot slot) + identity = + Identity.opaqueObjectId theory seed Core.TySet + in Identity.assertedObject + identity + (Identity.OpaqueObjectContent theory seed Core.TySet) + + +data Fixture = Fixture + { fixtureFoundation :: !Foundation.CheckedFoundation + , fixtureOwner :: !ModuleName + , fixtureProposition :: !Identity.CheckedPropositionContent + } + +makeFixture :: IO Fixture +makeFixture = + makeNamedFixture "root" + +makeNamedFixture :: Text -> IO Fixture +makeNamedFixture name = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "declaration-test-namespace" + [TextEncoding.encodeUtf8 name]) + relative <- expectRight + (safeRelativePath + (Text.unpack name <> ".tex")) + let theory = Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + closure <- expectRight + (Identity.validateObjectClosure theory []) + proposition <- expectRight + (Identity.validatePropositionContent closure Core.CFalsum) + pure + Fixture + { fixtureFoundation = foundation + , fixtureOwner = owner + , fixtureProposition = proposition + } + +factSpec :: Fixture -> Text -> Declaration.CandidateSpec +factSpec fixture alias = + Declaration.candidateSpec + (fixtureProposition fixture) + Semantic.SearchEligible + [Semantic.semanticName alias] + +runDriver + :: Fixture + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriver fixture = + runDriverWithResolver fixture unavailableVampireResolver + +runDriverWithResolver + :: Fixture + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithResolver fixture resolver action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [] + resolver + Declaration.FreshValidation + action + expectRight result + +runDriverWithValidation + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithValidation fixture lookup action = do + runDriverWithValidationAndResolver + fixture + lookup + unavailableVampireResolver + action + +runDriverWithValidationAndResolver + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithValidationAndResolver fixture lookup resolver action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [] + resolver + (Declaration.WarmValidation lookup) + action + expectRight result + +proofOnlyValidationLookup + :: (Semantic.ProofValidationKey + -> IO (Maybe Semantic.ProofValidationRecord)) + -> Declaration.ValidationLookup +proofOnlyValidationLookup lookupProof = + Declaration.validationLookup + lookupProof + (const (pure Nothing)) + +compiledOnlyValidationLookup + :: (Semantic.DeclarationValidationKey + -> IO (Maybe Semantic.DeclarationValidationRecord)) + -> Declaration.ValidationLookup +compiledOnlyValidationLookup lookupDeclaration = + Declaration.validationLookup + (const (pure Nothing)) + lookupDeclaration + +runDriverWithDirect + :: Fixture + -> [Semantic.SemanticInterfaceId] + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithDirect fixture direct action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + direct + unavailableVampireResolver + Declaration.FreshValidation + action + expectRight result + +unavailableVampireResolver :: Declaration.VampireResolver +unavailableVampireResolver = + Declaration.vampireResolver \_prepared -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "Vampire resolver was not expected")) + +runSuccessful + :: Fixture + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessful fixture = + runSuccessfulWithResolver fixture unavailableVampireResolver + +runSuccessfulWithResolver + :: Fixture + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessfulWithResolver fixture resolver action = do + outcome <- runDriverWithResolver fixture resolver action + case outcome of + Declaration.DriverSucceeded value _interface _prefix _closure -> + pure value + Declaration.DriverFailed _failure _prefix -> + assertFailure "unexpected driver failure" >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) >> fail "unreachable" + +runSuccessfulWithValidation + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessfulWithValidation fixture lookup action = do + outcome <- runDriverWithValidation fixture lookup action + case outcome of + Declaration.DriverSucceeded value _interface _prefix _closure -> + pure value + Declaration.DriverFailed _failure _prefix -> + assertFailure "unexpected driver failure" >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) >> fail "unreachable" + +materializesSealedImport :: Assertion +materializesSealedImport = do + fixture <- makeFixture + producer <- runDriver fixture do + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "sealed-import-producer") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "producer-fact") + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure batch + (producerInterface, evidence, fingerprint) <- + case producer of + Declaration.DriverSucceeded _ interface prefix _closure -> + let imported = + Declaration.freshImportedModuleEvidence + [] interface prefix + in case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations interface) of + [occurrence] -> + pure + ( interface + , imported + , Semantic.semanticFactFingerprint occurrence + ) + occurrences -> + assertFailure + ("unexpected producer facts: " + <> show (length occurrences)) + >> fail "unreachable" + Declaration.DriverFailed failure _prefix -> + assertFailure + ("producer failed: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("producer did not seal: " <> show failure) + >> fail "unreachable" + consumerNamespace <- expectRight + (hashCanonicalFields + "declaration-import-consumer" + ["consumer"]) + consumerPath <- expectRight (safeRelativePath "consumer.tex") + let consumerFixture = + fixture + { fixtureOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest consumerNamespace) + consumerPath + } + consumer <- runDriverWithDirect consumerFixture + [Semantic.semanticInterfaceAssertedId producerInterface] + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "sealed-import-consumer") do + Declaration.importSealedModule evidence + candidate <- Declaration.reserveCandidate + (factSpec fixture "consumer-fact") + Declaration.authorizeOmittedCandidate candidate do + _ <- Declaration.useAuthorizedFact fingerprint + Declaration.recordOmittedUse + pure committed + case consumer of + Declaration.DriverSucceeded committed _ _ _ -> do + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta committed) of + [localOccurrence] -> do + assertEqual + "the first local fact keeps ordinal zero" + (localFactOrdinal 0) + (Semantic.factSlotOrdinal + (Semantic.semanticFactSlot localOccurrence)) + assertEqual + "the local fact belongs to the consumer" + (fixtureOwner consumerFixture) + (Semantic.factSlotModule + (Semantic.semanticFactSlot localOccurrence)) + facts -> + assertFailure + ("unexpected consumer fact count: " + <> show (length facts)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("consumer failed: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("consumer did not seal: " <> show failure) + +elaboratesScopedExactPropositions :: Assertion +elaboratesScopedExactPropositions = do + fixture <- makeNamedFixture "exact-scoped-proposition" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (x :| [y]) + Raw.Unbounded + Nothing + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar x :| []) + Raw.Positive + (Raw.Relation + Nowhere + Raw.EqSymbol + []) + (Raw.ExprVar y :| [])))) + action + :: Declaration.ModuleDriver Text + (Either + Exact.ExactCompileError + Exact.PreparedExactProposition) + action = + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactProposition + Exact.emptyExactBinderContext + statement) + outcome <- runDriver fixture action + case outcome of + Declaration.DriverSucceeded (Right prepared) _interface _prefix _closure -> + assertEqual + "source-order universal binders" + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0)))) + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Declaration.DriverSucceeded (Left failure) _interface _prefix _closure -> + assertFailure + ("scoped exact elaboration failed: " + <> Text.unpack (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("scoped exact driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("scoped exact driver did not seal: " <> show failure) + +lowersFixedEqualityAliases :: Assertion +lowersFixedEqualityAliases = do + fixture <- makeNamedFixture "fixed-equality-aliases" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + term variable = Raw.TermExpr (Raw.ExprVar variable) + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (Raw.ExprVar right :| []))) + quantified variables statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + variables + Raw.Unbounded + Nothing + statement + adjective = + Raw.Adj + Nowhere + Lexicon.builtinEqualityRightAdjective + [term y] + copular = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPAdj (adjective :| [])) + rightAttribute = + Raw.StmtNoun + (term x :| []) + (Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [ Raw.AdjR + Nowhere + Lexicon.builtinEqualityRightAdjective + [term y] + ] + Nothing) + rightAttributeExpected = + Raw.StmtNoun + (term x :| []) + (Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [] + (Just (equality x y))) + verb argument = + Raw.Verb + Nowhere + Lexicon.builtinEqualityVerb + [term argument] + singular = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerb (verb y)) + negated = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerbNot (verb y)) + coordinated = + Raw.StmtVerbPhrase + (term x :| [term y]) + (Raw.VPVerb (verb z)) + coordinatedExpected = + Raw.StmtConnected + Raw.Conjunction + Nothing + (equality x z) + (equality y z) + comparisons = + [ ( "copular adjective" + , quantified (x :| [y]) copular + , quantified (x :| [y]) (equality x y) + ) + , ( "right adjective" + , quantified (x :| [y]) rightAttribute + , quantified (x :| [y]) rightAttributeExpected + ) + , ( "singular verb" + , quantified (x :| [y]) singular + , quantified (x :| [y]) (equality x y) + ) + , ( "negated verb" + , quantified (x :| [y]) negated + , quantified + (x :| [y]) + (Raw.StmtNeg Nowhere (equality x y)) + ) + , ( "quantified coordinated verb" + , quantified (x :| [y, z]) coordinated + , quantified (x :| [y, z]) coordinatedExpected + ) + ] + action + :: Declaration.ModuleDriver Text + [ ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + ] + action = + Declaration.runProspectiveLoweringDriver + (traverse + (\(_label, alias, symbolic) -> + (,) + <$> Exact.prepareExactProposition + Exact.emptyExactBinderContext alias + <*> Exact.prepareExactProposition + Exact.emptyExactBinderContext symbolic) + comparisons) + runDriver fixture action >>= \case + Declaration.DriverSucceeded results _interface _prefix _closure -> + for_ (zip comparisons results) \((label, _alias, _symbolic), result) -> + case result of + (Right alias, Right symbolic) -> do + let aliasTerm = + Core.scopedCoreTerm + (Exact.preparedExactPropositionCore alias) + symbolicTerm = + Core.scopedCoreTerm + (Exact.preparedExactPropositionCore symbolic) + assertEqual + (label <> " checked core") + symbolicTerm + aliasTerm + assertEqual + (label <> " global support") + Set.empty + (Core.canonicalTermGlobals aliasTerm) + assertEqual + (label <> " foundation support") + Set.empty + (Foundation.foundationAxiomDependencies aliasTerm) + (Left failure, _) -> + assertFailure + (label <> " alias failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + (_, Left failure) -> + assertFailure + (label <> " symbolic comparison failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("fixed equality driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("fixed equality driver did not seal: " <> show failure) + + let internalEquality = + Internal.FormulaVerb + Nowhere + (Internal.EmptySet Nowhere) + Lexicon.builtinEqualityVerb + [Internal.EmptySet Nowhere] + internalResult + :: Either + Typed.TypedInductiveError + (Core.FrozenCheckedCore Void) + internalResult = + Typed.prepareTypedClosedFormula + absurd + (const Nothing) + internalEquality + case internalResult of + Right checked -> do + assertEqual + "internal fixed verb core" + (Core.CEq + Core.TySet + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty)) + (Core.frozenCoreTerm checked) + assertEqual + "internal fixed verb global support" + Set.empty + (Core.frozenCoreGlobals checked) + Left failure -> + assertFailure + ("internal fixed verb failed: " <> show failure) + +scopesQuantifiedPropositionTerms :: Assertion +scopesQuantifiedPropositionTerms = do + fixture <- makeNamedFixture "quantified-proposition-terms" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + term variable = Raw.TermExpr (Raw.ExprVar variable) + zero = Raw.TermExpr (Raw.ExprInteger Nowhere 0) + setNoun = Raw.Noun Nowhere Lexicon.builtinSetNoun [] + setPhrase named = Raw.NounPhrase [] setNoun named [] Nothing + quantified quantifier variable = + Raw.TermQuantified + quantifier Nowhere (setPhrase (Just variable)) + equalityVerb argument = + Raw.Verb Nowhere Lexicon.builtinEqualityVerb [argument] + equalityAdjective argument = + Raw.Adj + Nowhere Lexicon.builtinEqualityRightAdjective [argument] + equality left right = Core.CEq Core.TySet left right + notP proposition = Core.CImp proposition Core.CFalsum + andP left right = notP (Core.CImp left (notP right)) + existsP body = notP (Core.CForall Core.TySet (notP body)) + truth = Core.CImp Core.CFalsum Core.CFalsum + member left right = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) left) + right + soleSubject = + Raw.StmtNoun + (quantified Raw.Universally x :| []) + (setPhrase Nothing) + explicitSubject = + Raw.SymbolicQuantified + Nowhere Raw.Universally (x :| []) Raw.Unbounded Nothing + (Raw.StmtNoun (term x :| []) (setPhrase Nothing)) + multipleSubjects = + Raw.StmtVerbPhrase + ( quantified Raw.Universally x + :| [quantified Raw.Existentially y] + ) + (Raw.VPVerb (equalityVerb zero)) + adjectiveArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPAdj + (equalityAdjective + (quantified Raw.Universally x) :| [])) + nounArgument = + Raw.StmtNoun + (zero :| []) + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun + [quantified Raw.Universally x]) + Nothing [] Nothing) + negatedSubject = + Raw.StmtVerbPhrase + (quantified Raw.Universally x :| []) + (Raw.VPVerbNot (equalityVerb zero)) + negatedArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPVerbNot + (equalityVerb (quantified Raw.Universally x))) + nonexistentialArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPVerb + (equalityVerb (quantified Raw.Nonexistentially x))) + negatedStatement = + Raw.StmtNeg Nowhere soleSubject + siblingConstraints = + Raw.StmtNoun + (zero :| []) + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun + [quantified Raw.Universally x]) + Nothing + [Raw.AdjR + Nowhere Lexicon.builtinEqualityRightAdjective + [quantified Raw.Universally y]] + Nothing) + constrainedSubject = + Raw.TermQuantified Raw.Universally Nowhere + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun [term x]) + (Just x) + [Raw.AdjR + Nowhere Lexicon.builtinEqualityRightAdjective [term x]] + (Just + (Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerb (equalityVerb (term x)))))) + constrainedStatement = + Raw.StmtVerbPhrase + (constrainedSubject :| []) + (Raw.VPVerb (equalityVerb (term x))) + xEqualsX = equality (Core.CBound 0) (Core.CBound 0) + cases = + [ ( "sole quantified subject" + , soleSubject + , Core.CForall Core.TySet truth + ) + , ( "explicit sole quantified subject" + , explicitSubject + , Core.CForall Core.TySet truth + ) + , ( "multiple quantified subjects" + , multipleSubjects + , Core.CForall Core.TySet + (existsP + (andP + (equality + (Core.CBound 1) (Core.COpaqueInteger 0)) + (equality + (Core.CBound 0) (Core.COpaqueInteger 0)))) + ) + , ( "quantified adjective argument" + , adjectiveArgument + , Core.CForall Core.TySet + (equality (Core.COpaqueInteger 0) (Core.CBound 0)) + ) + , ( "quantified noun argument" + , nounArgument + , Core.CForall Core.TySet + (member (Core.COpaqueInteger 0) (Core.CBound 0)) + ) + , ( "quantified subject outside negation" + , negatedSubject + , Core.CForall Core.TySet + (notP + (equality + (Core.CBound 0) (Core.COpaqueInteger 0))) + ) + , ( "quantified argument inside negation" + , negatedArgument + , notP + (Core.CForall Core.TySet + (equality + (Core.COpaqueInteger 0) (Core.CBound 0))) + ) + , ( "nonexistential quantified verb argument" + , nonexistentialArgument + , notP + (existsP + (equality + (Core.COpaqueInteger 0) + (Core.CBound 0))) + ) + , ( "statement recursion bounds a quantified subject" + , negatedStatement + , notP (Core.CForall Core.TySet truth) + ) + , ( "sibling constraints own their argument quantifiers" + , siblingConstraints + , andP + (Core.CForall Core.TySet + (member + (Core.COpaqueInteger 0) + (Core.CBound 0))) + (Core.CForall Core.TySet + (equality + (Core.COpaqueInteger 0) + (Core.CBound 0))) + ) + , ( "quantified noun constraints share their binder" + , constrainedStatement + , Core.CForall Core.TySet + (Core.CImp + (andP + (member (Core.CBound 0) (Core.CBound 0)) + (andP xEqualsX xEqualsX)) + xEqualsX) + ) + ] + prepare context statement = + Exact.prepareExactProposition context statement + activeContext <- expectRight + (Exact.extendExactBinderContext + ((Exact.exactLocalId 0, x) :| []) + Exact.emptyExactBinderContext) + let action + :: Declaration.ModuleDriver Text + ( [ Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ] + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + action = + Declaration.runProspectiveLoweringDriver do + compiled <- traverse + (\(_label, statement, _expected) -> + prepare Exact.emptyExactBinderContext statement) + cases + collision <- prepare activeContext soleSubject + pure (compiled, collision) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (compiled, collision) _interface _prefix _closure -> do + for_ (zip cases compiled) \ + ((label, _statement, expected), result) -> + case result of + Right prepared -> + assertEqual label expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Left failure -> + assertFailure + (label <> " failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + case collision of + Left (Exact.ExactDuplicateLocalBinder _location variable) -> + assertEqual "quantified binder collision" x variable + Left failure -> + assertFailure + ("unexpected quantified-binder collision: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Right{} -> + assertFailure "an active quantified binder was shadowed" + case compiled of + Right sole : Right explicit : _ -> + assertEqual + "sole-subject lowering remains byte-for-byte identical" + (Exact.preparedExactPropositionCore sole) + (Exact.preparedExactPropositionCore explicit) + _ -> + assertFailure + "sole-subject equality comparison did not compile" + Declaration.DriverFailed failure _prefix -> + assertFailure + ("quantified proposition-term driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("quantified proposition-term driver did not seal: " + <> show failure) + +preparesExactClaimEnvelopes :: Assertion +preparesExactClaimEnvelopes = do + fixture <- makeNamedFixture "exact-claim-envelope" + let bLocation = mkLocation (FileId 78) 2 11 + aLocation = mkLocation (FileId 78) 2 15 + xLocation = mkLocation (FileId 78) 3 9 + b = Raw.NamedVarAt bLocation "b" + a = Raw.NamedVarAt aLocation "a" + x = Raw.NamedVarAt xLocation "x" + c = Raw.NamedVarAt Nowhere "c" + d = Raw.NamedVarAt Nowhere "d" + z = Raw.NamedVarAt Nowhere "z" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (Raw.ExprVar right :| []))) + quantified variable body = + Raw.SymbolicQuantified + (locate variable) + Raw.Universally + (variable :| []) + Raw.Unbounded + Nothing + body + sourceAssumptions = [Raw.AsmSuppose (equality b a)] + sourceConclusion = quantified x (equality x b) + alphaAssumptions = [Raw.AsmSuppose (equality c d)] + alphaConclusion = quantified z (equality z c) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactClaimEnvelope + , Either + Exact.ExactCompileError + Exact.PreparedExactClaimEnvelope + ) + action = + Declaration.runProspectiveLoweringDriver do + source <- Exact.prepareExactClaimEnvelope + sourceAssumptions sourceConclusion + alpha <- Exact.prepareExactClaimEnvelope + alphaAssumptions alphaConclusion + pure (source, alpha) + expected = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0)) + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 2))))) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (Right source, Right alpha) + _interface _prefix _closure -> do + let sourceTarget = Exact.preparedExactClaimTarget source + alphaTarget = Exact.preparedExactClaimTarget alpha + assertEqual "closed claim envelope core" + expected + (Core.scopedCoreTerm sourceTarget) + assertEqual "claim envelope is closed" + [] + (Core.scopedCoreContext sourceTarget) + assertEqual "first semantic occurrence binder order" + [bLocation, aLocation] + (locate <$> Exact.preparedExactClaimVariables source) + assertEqual "explicit binders are not generalized" + 2 + (length (Exact.preparedExactClaimVariables source)) + assertEqual "header antecedent count" + 1 + (Exact.preparedExactClaimAntecedentCount source) + assertEqual "alpha-renaming preserves the checked target" + sourceTarget alphaTarget + assertEqual "alpha-renaming preserves proposition identity" + (Identity.propositionIdOf + (Core.scopedCoreTerm sourceTarget)) + (Identity.propositionIdOf + (Core.scopedCoreTerm alphaTarget)) + Declaration.DriverSucceeded result _interface _prefix _closure -> + assertFailure + ("exact claim envelope preparation failed: " + <> case result of + (Left failure, _) -> + Text.unpack + (Exact.renderExactCompileError failure) + (_, Left failure) -> + Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("claim envelope driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("claim envelope driver did not seal: " <> show failure) + +lowersExactSeparationComprehensions :: Assertion +lowersExactSeparationComprehensions = do + fixture <- makeNamedFixture "exact-separation-comprehension" + let binderLocation = mkLocation (FileId 73) 2 7 + ambientLocation = mkLocation (FileId 73) 2 18 + boundOccurrenceLocation = mkLocation (FileId 73) 3 14 + x = Raw.NamedVarAt binderLocation "x" + a = Raw.NamedVarAt ambientLocation "A" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + separation bound = + Raw.ExprSep + binderLocation + x + bound + (equality (Raw.ExprVar x) (Raw.ExprVar a)) + validStatement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| []) + Raw.Unbounded + Nothing + (equality + (separation (Raw.ExprVar a)) + (Raw.ExprVar a)) + boundOccurrence = + Raw.NamedVarAt boundOccurrenceLocation "x" + invalidStatement = + equality + (separation (Raw.ExprVar boundOccurrence)) + (Raw.ExprVar a) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + action = + Declaration.runProspectiveLoweringDriver do + valid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + validStatement + invalid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + invalidStatement + pure (valid, invalid) + outcome <- runDriver fixture action + case outcome of + Declaration.DriverSucceeded + (Right prepared, Left failure) _interface _prefix _closure -> do + assertEqual + "separation comprehension core" + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (Core.CBound 0)) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 1)))) + (Core.CBound 0))) + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "separation proposition type" + Core.TyProp + (Core.scopedCoreType + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "the separation binder is unavailable in its bound" + (Exact.ExactFreeVariable + boundOccurrenceLocation + boundOccurrence) + failure + Declaration.DriverSucceeded result _interface _prefix _closure -> + case result of + (Left validFailure, _) -> + assertFailure + ("valid separation failed: " + <> Text.unpack + (Exact.renderExactCompileError validFailure)) + (_, Right{}) -> + assertFailure "invalid separation was accepted" + Declaration.DriverFailed failure _prefix -> + assertFailure ("separation exact driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("separation exact driver did not seal: " <> show failure) + +lowersExactReplacementTelescopes :: Assertion +lowersExactReplacementTelescopes = do + fixture <- makeNamedFixture "exact-replacement-telescope" + let location = mkLocation (FileId 74) 2 1 + futureOccurrenceLocation = mkLocation (FileId 74) 7 19 + a = Raw.NamedVarAt location "A" + x = Raw.NamedVarAt location "x" + y = Raw.NamedVarAt location "y" + futureY = Raw.NamedVarAt futureOccurrenceLocation "y" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + replacement firstDomain = + Raw.ExprReplace + location + (Raw.ExprVar y) + ( (x, firstDomain) :| + [(y, Raw.ExprVar x)] + ) + (Just (equality (Raw.ExprVar x) (Raw.ExprVar y))) + validStatement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| []) + Raw.Unbounded + Nothing + (equality + (replacement (Raw.ExprVar a)) + (Raw.ExprVar a)) + invalidStatement = + equality + (replacement (Raw.ExprVar futureY)) + (Raw.ExprInteger Nowhere 0) + predicateReplacementLocation = mkLocation (FileId 74) 9 3 + predicateReplacementStatement = + equality + (Raw.ExprReplacePred + predicateReplacementLocation + y + x + (Raw.ExprInteger Nowhere 0) + (equality (Raw.ExprVar x) (Raw.ExprVar y))) + (Raw.ExprInteger Nowhere 0) + namedPredicateReplacement = + Raw.ExprReplacePred + predicateReplacementLocation + y + x + (Raw.ExprVar a) + (equality (Raw.ExprVar x) (Raw.ExprVar y)) + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + expected = + Core.CForall Core.TySet $ + Core.CEq Core.TySet + (app1 Core.FamilyUnion $ + app2 Core.Repl (Core.CBound 0) $ + Core.CLam Core.TySet $ + app2 Core.Repl + (app2 Core.Sep + (Core.CBound 0) + (Core.CLam Core.TySet $ + Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CBound 0))) + (Core.CBound 0) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactSetExpression + ) + action = + Declaration.runProspectiveLoweringDriver do + valid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + validStatement + invalid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + invalidStatement + predicateReplacement <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + predicateReplacementStatement + namedContext <- + either + (impossible + . Text.unpack + . Exact.renderExactCompileError) + pure + (Exact.extendExactBinderContext + ((Exact.exactLocalId 0, a) :| []) + Exact.emptyExactBinderContext) + named <- Exact.prepareExactSetExpression + namedContext namedPredicateReplacement + pure (valid, invalid, predicateReplacement, named) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + ( Right prepared + , Left failure + , Left predicateReplacementFailure + , Right named + ) _interface _prefix _closure -> do + assertEqual + "dependent replacement core" + expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "future replacement binder location" + (Exact.ExactFreeVariable futureOccurrenceLocation futureY) + failure + assertEqual + "predicate replacement remains unsupported at its location" + (Exact.ExactRelationalReplacementRequiresNamedDefinition + predicateReplacementLocation) + predicateReplacementFailure + case Exact.preparedExactSetExpressionConstruction named of + Just (Exact.PreparedRelationalSetConstruction construction) -> do + assertEqual "relational replacement canonical term" + expectedRelationalTerm + (Core.scopedCoreTerm + (SetConstruction.relationalSetConstructionTerm + construction)) + assertEqual "relational replacement functionality" + expectedFunctionality + (Core.scopedCoreTerm + (SetConstruction.relationalSetConstructionFunctionality + construction)) + let relationalObject = + Identity.assertedObjectId + (opaqueFixtureObject fixture) + closedFunctionality = + SetConstruction.relationalSetConstructionClosedFunctionality + construction + relationalFact <- + maybe + (assertFailure + "exact functionality did not unlock relational extensionality" + >> fail "unreachable") + pure + (SetConstruction.relationalSetConstructionObjectFact + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + relationalObject + construction + closedFunctionality) + assertEqual + "relational replacement flattened extensional proposition" + (expectedRelationalExtensional relationalObject) + (Core.frozenCoreTerm + (SetConstruction.relationalSetConstructionFactProposition + relationalFact)) + assertEqual + "unrelated functionality cannot unlock the relational view" + Nothing + (SetConstruction.relationalSetConstructionLocalViews + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + construction + (Core.falsumScopedCore [Core.TySet])) + wrongClosed <- expectRight + (Core.checkCanonicalCore + (const Nothing) + Core.CFalsum) + assertBool + "malformed relational authority is rejected" + (isNothing + (SetConstruction.relationalSetConstructionObjectFact + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + relationalObject + construction + wrongClosed)) + _ -> + assertFailure + "named predicate replacement lost its relational construction" + Declaration.DriverSucceeded + (Left validFailure, _, _, _) _interface _prefix _closure -> + assertFailure + ("valid replacement failed: " + <> Text.unpack + (Exact.renderExactCompileError validFailure)) + Declaration.DriverSucceeded + (_, Right{}, _, _) _interface _prefix _closure -> + assertFailure "invalid replacement was accepted" + Declaration.DriverSucceeded + (_, _, Right{}, _) _interface _prefix _closure -> + assertFailure "predicate replacement was accepted" + Declaration.DriverSucceeded + (_, _, _, Left failure) _interface _prefix _closure -> + assertFailure + ("named predicate replacement failed: " + <> Text.unpack (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("replacement driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("replacement driver did not seal: " <> show failure) + where + relApp1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + relApp2 intrinsic first second = + Core.CApp (relApp1 intrinsic first) second + notP proposition = Core.CImp proposition Core.CFalsum + andP left right = notP (Core.CImp left (notP right)) + existsP body = notP (Core.CForall Core.TySet (notP body)) + relation = Core.CEq Core.TySet (Core.CBound 1) (Core.CBound 0) + restricted = + relApp2 Core.Sep (Core.CBound 0) + (Core.CLam Core.TySet (existsP relation)) + expectedRelationalTerm = + relApp2 Core.Repl restricted + (Core.CLam Core.TySet + (relApp1 Core.SetChoose (Core.CLam Core.TySet relation))) + expectedFunctionality = + Core.CForall Core.TySet + (Core.CImp + (relApp2 Core.Member (Core.CBound 0) (Core.CBound 1)) + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (andP + (Core.CEq Core.TySet + (Core.CBound 2) (Core.CBound 1)) + (Core.CEq Core.TySet + (Core.CBound 2) (Core.CBound 0))) + (Core.CEq Core.TySet + (Core.CBound 1) (Core.CBound 0)))))) + expectedRelationalExtensional object = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TyProp + (relApp2 Core.Member + (Core.CBound 0) + (Core.CApp + (Core.CGlobal object) + (Core.CBound 1))) + (existsP + (andP + (relApp2 Core.Member + (Core.CBound 0) + (Core.CBound 2)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 1)))))) + +lowersExactFiniteSets :: Assertion +lowersExactFiniteSets = do + fixture <- makeNamedFixture "exact-finite-set" + let location = mkLocation (FileId 75) 2 1 + a = Raw.NamedVarAt location "a" + b = Raw.NamedVarAt location "b" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| [b]) + Raw.Unbounded + Nothing + (equality + (Raw.ExprFiniteSet + location + (Raw.ExprVar a :| [Raw.ExprVar b])) + (Raw.ExprVar a)) + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + insert element rest = + app1 Core.FamilyUnion + (app2 Core.PairSet + (app2 Core.PairSet element element) + rest) + expected = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (insert + (Core.CBound 1) + (insert + (Core.CBound 0) + (Core.CIntrinsic Core.Empty))) + (Core.CBound 1))) + action + :: Declaration.ModuleDriver Text + (Either + Exact.ExactCompileError + Exact.PreparedExactProposition) + action = + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactProposition + Exact.emptyExactBinderContext + statement) + internal <- + expectRight + (evalState + (runExceptT (Meaning.glossStmt statement)) + Meaning.initialGlossState) + reusable <- + expectRight + (Typed.prepareTypedClosedFormula + absurd + (const Nothing) + internal + :: Either + Typed.TypedInductiveError + (Core.FrozenCheckedCore Void)) + assertEqual + "raw and reusable finite-set lowering" + expected + (Core.frozenCoreTerm reusable) + let internalSymbols = Internal.mentionedSymbols internal + assertBool + "finite-set meaning has no source-owned cons dependency" + (Internal.SymbolMixfix Raw.ConsSymbol + `Set.notMember` internalSymbols) + assertBool + "finite-set meaning retains fixed adjunction operations" + ( Set.fromList + [ Internal.SymbolMixfix Raw.UnionsSymbol + , Internal.SymbolMixfix Raw.UpairSymbol + ] + `Set.isSubsetOf` internalSymbols + ) + case Vocabulary.classifyExactSymbol + (Internal.SymbolMixfix Raw.ConsSymbol) of + Vocabulary.ExactSourceGlobal{} -> pure () + classification -> + assertFailure + ("explicit cons did not retain source ownership: " + <> show classification) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (Right prepared) _interface _prefix _closure -> + assertEqual + "source-order finite-set core" + expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Declaration.DriverSucceeded + (Left failure) _interface _prefix _closure -> + assertFailure + ("valid finite set failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("finite-set driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("finite-set driver did not seal: " <> show failure) + +lowersExactOrdinaryDeclarations :: Assertion +lowersExactOrdinaryDeclarations = do + fixture <- makeNamedFixture "exact-lowering" + level <- expectRight (Syntax.mixfixLevel 2) + let makeSymbol command marker = + Raw.mkMixfixItem + [ Just (Raw.Command command) + , Just Raw.InvisibleBraceL + , Nothing + , Just Raw.InvisibleBraceR + ] + (Raw.Marker marker) + Raw.NonAssoc + opaqueSymbol = makeSymbol "phasefiveopaque" "opaque-label" + aliasSymbol = makeSymbol "phasefivealias" "alias-label" + definitionSymbol = makeSymbol "phasefivedef" "definition-label" + entry symbol = + Syntax.CanonicalExpressionFunction + (Raw.mixfixPattern symbol) + (Raw.mixfixMarker symbol) + (Syntax.Fixity Raw.NonAssoc level) + parameter = Raw.NamedVar "x" + exactSet = + Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [] + Nothing + signature = + Raw.BlockSig + Nowhere Nothing (Raw.Marker "opaque-declaration") [] + (Raw.SignatureSymbolic + (Raw.SymbolPattern opaqueSymbol [parameter]) + exactSet) + application symbol = + Raw.ExprOp Nowhere symbol [Raw.ExprVar parameter] + abbreviation = + Raw.BlockAbbr + Nowhere Nothing (Raw.Marker "alias-declaration") + (Raw.AbbreviationEq + (Raw.SymbolPattern aliasSymbol [parameter]) + (application opaqueSymbol)) + definition = + Raw.BlockDefn + Nowhere Nothing (Raw.Marker "definition-declaration") + (Raw.DefnOp + (Raw.SymbolPattern definitionSymbol [parameter]) + (application aliasSymbol)) + compile block lexicalEntry = do + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactDeclaration block [lexicalEntry]) >>= \case + Left failure -> + Declaration.failModuleDriver + (Exact.renderExactCompileError failure) + Right prepared -> pure prepared + admit prepared = do + lowered <- + Declaration.runProspectiveLoweringDriver + (Exact.lowerPreparedExactBinding prepared) + checked <- + either Declaration.failDeclarationDriver pure lowered + void + (Declaration.admitCheckedDeclaration + checked + Exact.authorizeCheckedExactBinding) + outcome <- runFixtureDriver fixture [] do + preparedSignature <- + compile signature (entry opaqueSymbol) + admit preparedSignature + preparedAbbreviation <- + compile abbreviation (entry aliasSymbol) + admit preparedAbbreviation + preparedDefinition <- + compile definition (entry definitionSymbol) + admit preparedDefinition + pure + ( preparedSignature + , preparedAbbreviation + , preparedDefinition + ) + case outcome of + Declaration.DriverSucceeded + (preparedSignature, preparedAbbreviation, preparedDefinition) + interface prefix _closure -> do + assertEqual "three committed declarations" + 3 + (length (Semantic.semanticInterfaceDeclarations interface)) + assertEqual "three committed batches" + 3 + (length (Declaration.pendingModulePrefixBatches prefix)) + assertEqual "opaque signature family" + Identity.OpaqueObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedSignature)) + assertEqual "transparent abbreviation family" + Identity.TransparentObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedAbbreviation)) + assertEqual "transparent definition family" + Identity.TransparentObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedDefinition)) + assertEqual "expanded definition coalesces with abbreviation" + (Exact.preparedExactObjectId preparedAbbreviation) + (Exact.preparedExactObjectId preparedDefinition) + case Exact.preparedExactObject preparedAbbreviation of + Just object -> + case Identity.assertedObjectContent object of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual "definition type" + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual "expanded body retains opaque seed" + (Core.CLam Core.TySet + (Core.CApp + (Core.CGlobal + (Exact.preparedExactObjectId + preparedSignature)) + (Core.CBound 0))) + body + content -> + assertFailure + ("unexpected definition content: " <> show content) + Nothing -> + assertFailure "new abbreviation object was not prepared" + assertEqual "coalesced definition adds no object" + Nothing + (Exact.preparedExactObject preparedDefinition) + case reverse (Declaration.pendingModulePrefixBatches prefix) of + definitionBatch : _ -> do + case Declaration.committedBatchDeclarationValidation + definitionBatch of + Just record -> + case Semantic.declarationValidationRecordCertificates + record of + [certificate] -> do + assertEqual "definition authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Exact.preparedExactObjectId + preparedDefinition))) + (Authority.validationDirectAuthorization + certificate) + assertEqual "definition authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget + certificate)) + certificates -> + assertFailure + ("unexpected definition certificate count: " + <> show (length certificates)) + Nothing -> + assertFailure "definition has no declaration validation" + [] -> assertFailure "definition batch is absent" + Declaration.DriverFailed failure _prefix -> + assertFailure ("exact lowering failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("exact lowering did not seal: " <> show failure) + + let theory = Identity.theoryId (fixtureFoundation fixture) + mismatchBody = Core.COpaqueInteger 0 + mismatchType = Core.TySet + mismatchId = + Identity.transparentObjectId theory mismatchType mismatchBody + mismatchObject = + Identity.assertedObject + mismatchId + (Identity.TransparentObjectContent + theory mismatchType mismatchBody) + let mismatchAction + :: Declaration.ModuleDriver Text + ((), Declaration.CommittedDeclarationBatch) + mismatchAction = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + "mismatched-definition-equation") do + Declaration.addDeclarationObject mismatchObject + candidate <- Declaration.reserveCandidate + (factSpec fixture "not-a-definition-equation") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeDefinitionEquationCandidate + mismatchId + candidate) + mismatch <- runDriver fixture mismatchAction + case mismatch of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DefinitionEquationCandidateMismatch) + prefix -> + assertEqual "mismatched equation publishes no batch" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected mismatched-equation failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "mismatched definition equation was authorized" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("mismatched definition equation reached sealing: " + <> show failure) + +reconstructsImportedGlobalBindings :: Assertion +reconstructsImportedGlobalBindings = do + producerFixture <- makeNamedFixture "global-producer" + consumerFixture <- makeNamedFixture "global-consumer" + conflictFixture <- makeNamedFixture "global-conflict" + rootFixture <- makeNamedFixture "global-root" + let key = + Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "phasefive") Raw.End) + asserted = opaqueFixtureObject producerFixture + target = Identity.assertedObjectId asserted + publishWith targetMode fixture object = do + (batch, sealed) <- sealFixture fixture [] do + (_value, committed) <- + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "global-binding") do + Declaration.addDeclarationObject object + Declaration.stageSemanticGlobalBinding + key + (targetMode + (Identity.assertedObjectId object)) + Declaration.authorizeCompiledDeclaration (pure ()) + pure committed + pure (batch, sealed) + (producerBatch, freshProducer) <- + publishWith Semantic.GlobalReference producerFixture asserted + let FixtureSealed producerInterface _freshEvidence = freshProducer + objects = Declaration.committedBatchObjects producerBatch + cachedEvidence <- expectRight + (Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + producerInterface + objects + []) + let cachedProducer = FixtureSealed producerInterface cachedEvidence + resolveThrough label parent = do + outcome <- runFixtureDriver consumerFixture [parent] do + fst <$> Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + (TextEncoding.encodeUtf8 (Text.pack label))) do + found <- Declaration.resolveVisibleGlobal key + Declaration.authorizeCompiledDeclaration (pure ()) + pure found + case outcome of + Declaration.DriverSucceeded found _interface _prefix _closure -> + assertEqual label + (Just + ( Semantic.GlobalReference target + , Core.TySet + )) + found + Declaration.DriverFailed failure _prefix -> + assertFailure + ("global binding consumer failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("global binding consumer did not seal: " <> show failure) + resolveThrough "fresh-global-binding" freshProducer + resolveThrough "cached-global-binding" cachedProducer + + missingEnvironment <- expectRight + (Semantic.semanticEnvironmentDelta + [Semantic.semanticGlobalBinding + key + (Semantic.GlobalReference target)]) + missingDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + (fixtureOwner producerFixture) + (localDeclarationOrdinal 0)) + [] + [] + [] + [] + missingEnvironment) + missingInterface <- expectRight + (Semantic.semanticInterface + (fixtureOwner producerFixture) + [] + [missingDelta]) + case Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + missingInterface + [] + [] of + Left (Declaration.ImportedGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalTargetMissing missingTarget)) -> do + assertEqual "missing target key" key actualKey + assertEqual "missing target mode" + (Semantic.GlobalReference target) + actualTarget + assertEqual "missing target object" target missingTarget + Left failure -> + assertFailure + ("unexpected missing-target failure: " <> show failure) + Right _evidence -> + assertFailure "cached evidence accepted a missing target object" + + expansionEnvironment <- expectRight + (Semantic.semanticEnvironmentDelta + [Semantic.semanticGlobalBinding + key + (Semantic.TransparentExpansion target)]) + expansionDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + (fixtureOwner producerFixture) + (localDeclarationOrdinal 0)) + [] [] [target] [] expansionEnvironment) + expansionInterface <- expectRight + (Semantic.semanticInterface + (fixtureOwner producerFixture) [] [expansionDelta]) + case Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + expansionInterface + [asserted] + [] of + Left (Declaration.ImportedGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalExpansionNotTransparent + invalidTarget)) -> do + assertEqual "nontransparent target key" key actualKey + assertEqual "nontransparent target mode" + (Semantic.TransparentExpansion target) + actualTarget + assertEqual "nontransparent target object" target invalidTarget + Left failure -> + assertFailure + ("unexpected nontransparent-target failure: " + <> show failure) + Right _evidence -> + assertFailure "cached evidence accepted a nontransparent expansion" + + let intrinsicTarget = + Identity.intrinsicObjectId + (Identity.theoryId + (fixtureFoundation producerFixture)) + Core.Empty + Core.TySet + intrinsicObject = + Identity.assertedObject + intrinsicTarget + (Identity.IntrinsicObjectContent + (Identity.theoryId + (fixtureFoundation producerFixture)) + Core.Empty + Core.TySet) + intrinsicFailure <- runFixtureDriver producerFixture [] do + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "intrinsic-global-binding") do + Declaration.addDeclarationObject intrinsicObject + Declaration.stageSemanticGlobalBinding + key + (Semantic.GlobalReference intrinsicTarget) + Declaration.authorizeCompiledDeclaration (pure ()) + case intrinsicFailure of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.DeclarationGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalTargetIsIntrinsic + invalidTarget))) + _prefix -> do + assertEqual "intrinsic target key" key actualKey + assertEqual "intrinsic target mode" + (Semantic.GlobalReference intrinsicTarget) + actualTarget + assertEqual "intrinsic target object" + intrinsicTarget invalidTarget + other -> + assertFailure + (case other of + Declaration.DriverSucceeded{} -> + "ordinary binding accepted an intrinsic target" + Declaration.DriverFailed failure _prefix -> + "unexpected intrinsic-target failure: " <> show failure + Declaration.DriverSealFailed failure _prefix -> + "intrinsic target reached sealing: " <> show failure) + + conflictObject <- pure (opaqueFixtureObject conflictFixture) + (_conflictBatch, conflicting) <- + publishWith Semantic.GlobalReference conflictFixture conflictObject + collision <- runFixtureDriver rootFixture + [freshProducer, conflicting] + (pure ()) + case collision of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedGlobalCollision + actualKey firstTarget secondTarget)) + _prefix -> do + assertEqual "colliding global key" key actualKey + assertEqual "first imported target" + (Semantic.GlobalReference target) + firstTarget + assertEqual "second imported target" + (Semantic.GlobalReference + (Identity.assertedObjectId conflictObject)) + secondTarget + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected imported collision: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "unequal imported bindings did not collide" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("global collision reached sealing: " <> show failure) + + let theory = Identity.theoryId (fixtureFoundation producerFixture) + transparentBody = Core.COpaqueInteger 0 + transparentTarget = + Identity.transparentObjectId + theory Core.TySet transparentBody + transparentObject = + Identity.assertedObject + transparentTarget + (Identity.TransparentObjectContent + theory Core.TySet transparentBody) + (_referenceBatch, referenceProducer) <- + publishWith + Semantic.GlobalReference + producerFixture + transparentObject + (_expansionBatch, expansionProducer) <- + publishWith + Semantic.TransparentExpansion + conflictFixture + transparentObject + modeCollision <- runFixtureDriver rootFixture + [referenceProducer, expansionProducer] + (pure ()) + case modeCollision of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedGlobalCollision + actualKey firstTarget secondTarget)) + _prefix -> do + assertEqual "mode collision key" key actualKey + assertEqual "reference target" + (Semantic.GlobalReference transparentTarget) + firstTarget + assertEqual "expansion target" + (Semantic.TransparentExpansion transparentTarget) + secondTarget + other -> + assertFailure + (case other of + Declaration.DriverSucceeded{} -> + "different global target modes did not collide" + Declaration.DriverFailed failure _prefix -> + "unexpected mode-collision failure: " <> show failure + Declaration.DriverSealFailed failure _prefix -> + "mode collision reached sealing: " <> show failure) + +data FixtureSealed = FixtureSealed + !Semantic.SemanticInterface + !Declaration.ImportedModuleEvidence + +foldsTransitiveAndDiamondEvidence :: Assertion +foldsTransitiveAndDiamondEvidence = do + baseFixture <- makeNamedFixture "base" + middleFixture <- makeNamedFixture "middle" + transitiveFixture <- makeNamedFixture "transitive" + leftFixture <- makeNamedFixture "left" + rightFixture <- makeNamedFixture "right" + diamondFixture <- makeNamedFixture "diamond" + conflictLeftFixture <- makeNamedFixture "conflict-left" + conflictRightFixture <- makeNamedFixture "conflict-right" + conflictRootFixture <- makeNamedFixture "conflict-root" + + (base, baseFingerprint) <- + sealFactFixture baseFixture [] "transitive-shared" + middle <- snd <$> sealFixture middleFixture [base] (pure ()) + transitive <- sealUsingImportedFact + transitiveFixture [middle] baseFingerprint + assertLocalFactOrdinalZero "transitive importer" transitive + + left <- snd <$> sealFixture leftFixture [base] (pure ()) + right <- snd <$> sealFixture rightFixture [base] (pure ()) + diamond <- sealUsingImportedFact + diamondFixture [left, right] baseFingerprint + assertLocalFactOrdinalZero "diamond importer" diamond + + (conflictLeft, leftFingerprint) <- + sealFactFixture conflictLeftFixture [] "diamond-conflict" + (conflictRight, rightFingerprint) <- + sealFactFixture conflictRightFixture [] "diamond-conflict" + conflict <- runFixtureDriver + conflictRootFixture + [conflictLeft, conflictRight] + (pure ()) + case conflict of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedAliasCollision + alias + (Declaration.ImportedAliasOrigin + _leftSlot firstTarget) + (Declaration.ImportedAliasOrigin + _rightSlot secondTarget))) + _prefix -> do + assertEqual "conflicting alias" + (Semantic.semanticName "diamond-conflict") + alias + assertEqual "first alias origin" + leftFingerprint + firstTarget + assertEqual "second alias origin" + rightFingerprint + secondTarget + _ -> + assertFailure "conflicting diamond alias was not rejected" + where + sealUsingImportedFact fixture parents fingerprint = do + (batch, _sealed) <- sealFixture fixture parents do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "use-transitive-import") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "local-after-import") + Declaration.authorizeOmittedCandidate candidate do + void (Declaration.useAuthorizedFact fingerprint) + Declaration.recordOmittedUse + pure committed + pure batch + + assertLocalFactOrdinalZero label batch = + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + assertEqual label + (localFactOrdinal 0) + (Semantic.factSlotOrdinal + (Semantic.semanticFactSlot occurrence)) + facts -> + assertFailure + (label <> ": unexpected fact count " + <> show (length facts)) + +sealFactFixture + :: Fixture + -> [FixtureSealed] + -> Text + -> IO + ( FixtureSealed + , Semantic.SemanticFactOccurrenceFingerprint + ) +sealFactFixture fixture parents alias = do + (batch, sealed) <- sealFixture fixture parents do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId + (TextEncoding.encodeUtf8 alias)) do + candidate <- Declaration.reserveCandidate + (factSpec fixture alias) + Declaration.authorizeSourceAxiomCandidate candidate + pure committed + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + pure + ( sealed + , Semantic.semanticFactFingerprint occurrence + ) + facts -> + assertFailure + ("unexpected sealed fact count: " <> show (length facts)) + >> fail "unreachable" + +sealFixture + :: Fixture + -> [FixtureSealed] + -> Declaration.ModuleDriver Text value + -> IO (value, FixtureSealed) +sealFixture fixture parents action = do + outcome <- runFixtureDriver fixture parents action + case outcome of + Declaration.DriverSucceeded value interface prefix _closure -> + pure + ( value + , FixtureSealed + interface + (Declaration.freshImportedModuleEvidence + [ evidence + | FixtureSealed _interface evidence <- parents + ] + interface + prefix) + ) + Declaration.DriverFailed failure _prefix -> + assertFailure ("fixture failed: " <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("fixture did not seal: " <> show failure) + >> fail "unreachable" + +runFixtureDriver + :: Fixture + -> [FixtureSealed] + -> Declaration.ModuleDriver Text value + -> IO (Declaration.DriverResult Text value) +runFixtureDriver fixture parents action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [ Semantic.semanticInterfaceAssertedId interface + | FixtureSealed interface _evidence <- parents + ] + unavailableVampireResolver + Declaration.FreshValidation + do + traverse_ + (\(FixtureSealed _interface evidence) -> + Declaration.importSealedModuleDriver evidence) + parents + action + expectRight result + +requireSingleOccurrence + :: Declaration.CommittedDeclarationBatch + -> Declaration.ModuleDriver + Declaration.DeclarationError + Semantic.SemanticFactOccurrence +requireSingleOccurrence batch = + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + pure occurrence + _ -> + Declaration.failModuleDriver + Declaration.ProofDeclarationMustProduceOneFact + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value + +expectRightIO :: Show error => IO (Either error value) -> IO value +expectRightIO action = + action >>= expectRight + +withOpenedStore + :: Fixture + -> FilePath + -> (Store.Store -> IO value) + -> IO value +withOpenedStore fixture root action = + bracket + (expectRightIO + (Store.openStore + (root Posix. "store.sqlite") + (Identity.theoryId (fixtureFoundation fixture)))) + (Store.closeStore . snd) + (action . snd) + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + root <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile root template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Foundation.hs b/source/Felix/Test/Unit/Foundation.hs new file mode 100644 index 0000000..18ead04 --- /dev/null +++ b/source/Felix/Test/Unit/Foundation.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Foundation (unitTests) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Data.List qualified as List +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Foundation manifest" + [ testCase + "accepts the exact compiled foundation" + acceptsCompiledFoundation + , testCase + "rejects incomplete and altered manifests" + rejectsManifestMutations + , testCase + "classifies the exact UnivOf schemas" + classifiesUnivOfSchemas + , testCase + "selects only intrinsic characteristic dependencies" + selectsOnlyIntrinsicCharacteristicDependencies + ] + +acceptsCompiledFoundation :: Assertion +acceptsCompiledFoundation = do + foundation <- + either + (assertFailure . show) + pure + checkedFoundation + assertEqual + "intrinsic coverage" + [minBound .. maxBound] + (fst <$> compiledFoundationIntrinsicRows) + assertEqual + "guarded-rule coverage" + [minBound .. maxBound] + [ tag + | FoundationRuleInput tag _signature <- + compiledFoundationRuleRows + ] + for_ [minBound .. maxBound] \tag -> + assertEqual + ("closed proposition type for " <> show tag) + TyProp + (frozenCoreType + (foundationAxiomFrozen foundation tag)) + +selectsOnlyIntrinsicCharacteristicDependencies :: Assertion +selectsOnlyIntrinsicCharacteristicDependencies = do + let separation = + CApp + (CApp (CIntrinsic Sep) (CBound 0)) + (CLam TySet CFalsum) + underUniverse = + CApp (CIntrinsic UnivOf) separation + assertEqual + "separation is found recursively without a universe bundle" + (Set.singleton SeparationCharacteristic) + (foundationAxiomDependencies underUniverse) + +rejectsManifestMutations :: Assertion +rejectsManifestMutations = do + let withoutMinimal = + List.filter + (\case + FoundationAxiomInput + UnivOfMinimal + _syntax + _backendClass -> + False + _ -> + True) + compiledFoundationAxiomRows + wrongUnivType = + [ if tag == UnivOf + then (tag, TySet) + else row + | row@(tag, _coreType) <- + compiledFoundationIntrinsicRows + ] + duplicatedEmpty = + case findAxiomInput EmptyCharacteristic of + Just row -> + row : compiledFoundationAxiomRows + Nothing -> + impossible + "compiled manifest omitted EmptyCharacteristic" + alteredEmpty = + replaceAxiomInput + EmptyCharacteristic + (FoundationAxiomInput + EmptyCharacteristic + (coreOpaqueInteger 0) + FoundationFofProjectable) + alteredExtensionality = + replaceAxiomInput + SetExtensionality + (FoundationAxiomInput + SetExtensionality + coreFalsum + FoundationFofProjectable) + misclassifiedEmpty = + case findAxiomInput EmptyCharacteristic of + Just + (FoundationAxiomInput + tag + syntax + _backendClass) -> + replaceAxiomInput + tag + (FoundationAxiomInput + tag + syntax + (FoundationRequiresTh0 + (HigherOrderLambda :| []))) + Nothing -> + impossible + "compiled manifest omitted EmptyCharacteristic" + withoutLeast = + [ row + | row@(FoundationRuleInput tag _signature) <- + compiledFoundationRuleRows + , tag /= SetLfpLeast + ] + alteredInductSignature = + [ if tag == SetLfpInduct + then + FoundationRuleInput + tag + (KernelRuleSignature [TySet] 0) + else row + | row@(FoundationRuleInput tag _signature) <- + compiledFoundationRuleRows + ] + assertAuditContains + (== MissingFoundationAxiom UnivOfMinimal) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + withoutMinimal) + assertAuditContains + (== FoundationIntrinsicTypeMismatch + UnivOf + (TySet `TyArrow` TySet) + TySet) + (auditFoundationManifest + wrongUnivType + compiledFoundationRuleRows + compiledFoundationAxiomRows) + assertAuditContains + (== MissingFoundationRule SetLfpLeast) + (auditFoundationManifest + compiledFoundationIntrinsicRows + withoutLeast + compiledFoundationAxiomRows) + assertAuditContains + (\case + FoundationRuleSignatureMismatch + SetLfpInduct + _expected + (KernelRuleSignature [TySet] 0) -> + True + _ -> + False) + (auditFoundationManifest + compiledFoundationIntrinsicRows + alteredInductSignature + compiledFoundationAxiomRows) + assertAuditContains + (== DuplicateFoundationAxiom EmptyCharacteristic) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + duplicatedEmpty) + assertAuditContains + (\case + FoundationAxiomIllTyped + EmptyCharacteristic + (ExpectedCoreType TyProp TySet) -> + True + _ -> + False) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + alteredEmpty) + assertAuditContains + (== FoundationAxiomStatementMismatch + SetExtensionality) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + alteredExtensionality) + assertAuditContains + (== FoundationAxiomBackendClassMismatch + EmptyCharacteristic + (FoundationRequiresTh0 + (HigherOrderLambda :| [])) + FoundationFofProjectable) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + misclassifiedEmpty) + +classifiesUnivOfSchemas :: Assertion +classifiesUnivOfSchemas = do + foundation <- + either + (assertFailure . show) + pure + checkedFoundation + for_ + [ UnivOfContains + , UnivOfTransitive + , UnivOfFamilyUnionClosed + , UnivOfPowerSetClosed + ] + \tag -> + assertEqual + (show tag) + FoundationFofProjectable + (foundationAxiomBackendClass foundation tag) + for_ + [ UnivOfReplacementClosed + , UnivOfMinimal + ] + \tag -> + case foundationAxiomBackendClass foundation tag of + FoundationRequiresTh0 exclusions -> + assertBool + (show tag <> " has a structural exclusion") + (not (null exclusions)) + FoundationFofProjectable -> + assertFailure + (show tag <> " was classified as FOF") + +findAxiomInput + :: FoundationAxiomTag + -> Maybe FoundationAxiomInput +findAxiomInput wanted = + List.find + (\case + FoundationAxiomInput tag _syntax _backendClass -> + tag == wanted) + compiledFoundationAxiomRows + +replaceAxiomInput + :: FoundationAxiomTag + -> FoundationAxiomInput + -> [FoundationAxiomInput] +replaceAxiomInput wanted replacement = + fmap + (\row -> + case row of + FoundationAxiomInput tag _syntax _backendClass + | tag == wanted -> + replacement + _ -> + row) + compiledFoundationAxiomRows + +assertAuditContains + :: (FoundationManifestError -> Bool) + -> Either + (NonEmpty FoundationManifestError) + FoundationManifestAudit + -> Assertion +assertAuditContains predicate = \case + Left errors -> + assertBool + ("expected error not found in " <> show errors) + (any predicate errors) + Right _audit -> + assertFailure + "expected foundation-manifest audit to fail" diff --git a/source/Felix/Test/Unit/Html.hs b/source/Felix/Test/Unit/Html.hs new file mode 100644 index 0000000..c8395ec --- /dev/null +++ b/source/Felix/Test/Unit/Html.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Html (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph +import Felix.Workspace qualified as Workspace +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Abstract + +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.List.NonEmpty qualified as NonEmpty +import System.Directory qualified as Directory +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = testGroup "HTML renderer" + [ testCase "one shared index resolves local and cross-page previews" referencePreviews + , testCase "missing reference preview data falls back to readable text" missingReferenceFallback + , testCase "datatype rendering omits unchecked derived facts" datatypeDerivedFactsAreOmitted + ] + +referencePreviews :: Assertion +referencePreviews = do + environment <- expectRight =<< Workspace.prepareDefaultWorkspaceEnvironment + graph <- + expectRight =<< + Workspace.prepareDefaultSourceGraph + "test/html-fixtures/root-preview.tex" + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + hints <- TextIO.readFile "library/lexicon.tsv" + layout <- + expectRight + (layoutHtmlSourceGraph + (Workspace.workspaceHtmlMountPrefixes environment) + graph) + let nodes = Parse.parsedWorkspaceImportedBeforeImporter workspace + sourceBlocks = + (\node -> + ( Parse.parsedModuleResolved node + , Parse.parsedModuleBlocks node + )) + <$> nodes + (renderIndex, pages) = + Html.buildRenderIndex sourceBlocks + rootPage = NonEmpty.last pages + context <- + expectRight + (htmlRenderContext + layout + (Html.htmlPagePresentationSource rootPage)) + html <- + expectRight + (Html.renderDocument + context + hints + renderIndex + rootPage) + let supportScript = Html.supportScriptAssetContents + assertContains "local references keep page anchors" "href=\"#local_prop\"" html + assertContains "local references point previews at the visible target block" "data-reference-label=\"local_prop\" data-preview-target-id=\"local_prop\"" html + assertNotContains "local references do not use hidden preview ids" "data-reference-label=\"local_prop\" data-preview-id=\"" html + assertContains "visible target blocks expose preview metadata" "id=\"local_prop\" data-preview-kind=\"Proposition\" data-preview-label=\"local_prop\"" html + assertContains "imported references get preview metadata" "data-reference-label=\"imported_prop\"" html + assertContains "imported references link to their relative encoded theory route" "href=\"imported-preview#imported_prop\"" html + assertContains "imported references still use hidden preview templates" "data-reference-label=\"imported_prop\" data-preview-id=\"reference-preview-" html + assertNotContains "imported references do not get broken page anchors" "href=\"#imported_prop\"" html + assertNotContains "imported references are not non-clickable spans" " div" html + assertContains "page heading uses the selected mounted source" "

project:test/html-fixtures/root-preview.tex

" html + assertContains "imported preview records its mounted source" "project:test/html-fixtures/imported-preview.tex" html + assertContains "imported preview source links to the same route" "href=\"imported-preview\">project:test/html-fixtures/imported-preview.tex" html + assertContains "imported source renders on its own line" "class=\"reference-preview-source\"" html + assertContains "multi-reference rendering preserves the comma separator" ", local_prop, " html + assertContains "preview popup cancels delayed hide on pointer entry" "popup.addEventListener('pointerenter', clearHideTimer);" supportScript + assertContains "preview popup schedules delayed hide on pointer exit" "popup.addEventListener('pointerleave', scheduleHide);" supportScript + assertContains "group click pins the preview popup" "showPreview(trigger, event, true);" supportScript + assertContains "group keyboard activation pins the preview popup" "showPreview(trigger, null, true);" supportScript + assertContains "preview statements use a full-width paragraph" "class=\"reference-preview-statement\"" html + assertContains "preview popup is emitted once" "id=\"reference-preview-popup\"" html + +missingReferenceFallback :: Assertion +missingReferenceFallback = do + let proof = Qed (Just Nowhere) (JustificationRef ("missing_ref" :| [])) + blocks = [BlockProof Nowhere proof Nowhere] + html <- renderSynthetic blocks + assertContains "missing references remain visible" "missing_ref" html + assertNotContains "missing references do not claim preview content" "data-preview-id=" html + +datatypeDerivedFactsAreOmitted :: Assertion +datatypeDerivedFactsAreOmitted = do + let blocks = + [ propformDatatypeBlock Nowhere + , referenceClaimBlock "uses_datatype_fact" + , referenceProofBlock "propform_induct" + ] + html <- renderSynthetic blocks + assertContains "datatype declarations remain visible" "Datatype of " html + assertContains "derived fact references remain readable" "propform_induct" html + assertNotContains "unchecked datatype facts are not rendered" "Derived facts" html + assertNotContains "unchecked datatype facts do not become preview targets" "data-preview-label=\"propform_induct\"" html + +renderSynthetic :: [Block] -> IO Text +renderSynthetic blocks = do + currentDirectory <- Directory.getCurrentDirectory + mounts <- + expectRight =<< + prepareSourceMounts + [(sourceMountId "project", currentDirectory)] + request <- + expectRight + (searchedRoot "test/html-fixtures/root-preview.tex") + graph <- + expectRight =<< + buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph) + context <- + expectRight + (htmlRenderContext + layout + (sourceGraphRootSource graph)) + let (renderIndex, page :| _remainingPages) = + Html.buildRenderIndex + ((sourceGraphRootSource graph, blocks) :| []) + expectRight + (Html.renderDocument + context + "" + renderIndex + page) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +propformDatatypeBlock :: Location -> Block +propformDatatypeBlock blockLoc = + BlockData blockLoc Nothing "propform" propformDatatype + +propformDatatype :: Datatype +propformDatatype = + Datatype + { datatypeHeadExpr = ExprOp Nowhere (constSymbol "propform") [] + , datatypeClauses = + DatatypeClause (ExprOp Nowhere (constSymbol "propbot") []) (ExprOp Nowhere (constSymbol "propform") []) [] :| + [ DatatypeClause (ExprOp Nowhere (unarySymbol "propvar") [ExprVar "n"]) (ExprOp Nowhere (constSymbol "propform") []) [("n", ExprOp Nowhere (constSymbol "naturals") [])] + , DatatypeClause + (ExprOp Nowhere (infixSymbol "propto") [ExprVar "p", ExprVar "q"]) + (ExprOp Nowhere (constSymbol "propform") []) + [ ("p", ExprOp Nowhere (constSymbol "propform") []) + , ("q", ExprOp Nowhere (constSymbol "propform") []) + ] + ] + } + +referenceClaimBlock :: Marker -> Block +referenceClaimBlock marker = + BlockClaim Proposition Nowhere Nothing marker (Claim [] (StmtFormula (PropositionalConstant Nowhere IsTop))) + +referenceProofBlock :: Marker -> Block +referenceProofBlock marker = + BlockProof Nowhere (Qed (Just Nowhere) (JustificationRef (marker :| []))) Nowhere + +constSymbol :: Text -> FunctionSymbol +constSymbol name = + mkMixfixItem [Just (Command name)] (Marker name) NonAssoc + +unarySymbol :: Text -> FunctionSymbol +unarySymbol name = + mkMixfixItem [Just (Command name), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] (Marker name) NonAssoc + +infixSymbol :: Text -> FunctionSymbol +infixSymbol name = + mkMixfixItem [Nothing, Just (Command name), Nothing] (Marker name) NonAssoc + +assertContains :: HasCallStack => String -> Text -> Text -> Assertion +assertContains label needle haystack = + assertBool + (label <> "\nExpected to find: " <> Text.unpack needle) + (needle `Text.isInfixOf` haystack) + +assertNotContains :: HasCallStack => String -> Text -> Text -> Assertion +assertNotContains label needle haystack = + assertBool + (label <> "\nDid not expect to find: " <> Text.unpack needle) + (not (needle `Text.isInfixOf` haystack)) + +assertCount :: HasCallStack => String -> Int -> Text -> Text -> Assertion +assertCount label expected needle haystack = + assertEqual + (label <> "\nExpected count for: " <> Text.unpack needle) + expected + (Text.count needle haystack) diff --git a/source/Felix/Test/Unit/HtmlLayout.hs b/source/Felix/Test/Unit/HtmlLayout.hs new file mode 100644 index 0000000..a3d701f --- /dev/null +++ b/source/Felix/Test/Unit/HtmlLayout.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlLayout (unitTests) where + +import Base +import Felix.Source +import Felix.Source.Graph +import Felix.Render.Html.Layout + +import Control.Exception (bracket) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "HTML layout" + [ testCase + "encodes URL segments canonically" + encodesUrlSegments + , testCase + "renders relative typed URLs" + rendersRelativeUrls + , testCase + "separates mounted route namespaces" + separatesMountedNamespaces + , testCase + "routes searched and exact roots identically" + routesRootFormsIdentically + , testCase + "requires an explicit mount for an external root" + requiresExternalMount + , testCase + "reports URL and destination collisions independently" + reportsRouteCollisions + , testCase + "rejects ancestor and descendant destinations" + rejectsNestedDestinations + , testCase + "is independent of graph and configuration traversal order" + isTraversalOrderIndependent + ] + + +encodesUrlSegments :: Assertion +encodesUrlSegments = do + let accepted = + [ ("AZaz09-._~", "AZaz09-._~") + , ("#?% \\", "%23%3F%25%20%5C") + , ("über", "%C3%BCber") + , ("%2f", "%252f") + ] + for_ accepted \(decoded, expected) -> + assertEqual + ("encoded segment " <> Text.unpack decoded) + (Right expected) + (renderUrlSegment <$> urlSegment decoded) + let rejected = + [ ("", EmptyUrlSegment) + , (".", DotUrlSegment ".") + , ("..", DotUrlSegment "..") + , ("a/b", UrlSegmentContainsSeparator "a/b") + ] + for_ rejected \(decoded, expected) -> + assertEqual + ("rejected segment " <> Text.unpack decoded) + (Left expected) + (urlSegment decoded) + assertEqual + "fragment encoding" + "#name%23%C3%BC" + (renderUrlFragment "name#ü") + +rendersRelativeUrls :: Assertion +rendersRelativeUrls = do + let cases = + [ ( ["library", "nested", "über"] + , ["_static", "naproche-html.js"] + , "../../_static/naproche-html.js" + ) + , ( ["first", "entry"] + , ["second", "entry"] + , "../second/entry" + ) + , ( ["mount", "entry"] + , ["mount", "a?b"] + , "a%3Fb" + ) + ] + for_ cases \(currentSegments, targetSegments, expected) -> do + current <- expectRight (urlPath currentSegments) + target <- expectRight (urlPath targetSegments) + assertEqual + "relative URL" + expected + (renderRelativeUrlPath current target) + current <- expectRight (urlPath ["mount", "entry"]) + target <- expectRight (urlPath ["mount", "ü"]) + assertEqual + "encoded path and fragment remain separate" + "%C3%BC#part%23%3F" + ( renderRelativeUrlPath current target + <> renderUrlFragment "part#?" + ) + +separatesMountedNamespaces :: Assertion +separatesMountedNamespaces = + withTemporaryDirectory "felix-html-layout-mounts" \temp -> do + let mountSpecifications = + [ ("project", []) + , ("library", ["library"]) + , ("debug", ["debug"]) + , ("external", ["external"]) + ] + roots <- for mountSpecifications \(ident, _prefix) -> do + let root = temp Posix. Text.unpack ident + Directory.createDirectory root + writeTheory (root Posix. "entry.tex") [] + pure (sourceMountId ident, root) + mounts <- expectRight =<< prepareSourceMounts roots + routes <- for mountSpecifications \(ident, prefix) -> do + let sourcePath = + temp + Posix. Text.unpack ident + Posix. "entry.tex" + request <- expectRight =<< existingRoot sourcePath + graph <- expectRight =<< buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId configuredId, configuredPrefix) + | (configuredId, configuredPrefix) <- + mountSpecifications + ] + graph) + route <- requireRootRoute graph layout + pure + ( ident + , renderUrlPath (routeUrlPath route) + , safeRelativePathFilePath + (routeDestination route) + , prefix + ) + assertEqual + "mount URLs" + [ ("project", "/entry") + , ("library", "/library/entry") + , ("debug", "/debug/entry") + , ("external", "/external/entry") + ] + [ (ident, url) | (ident, url, _destination, _prefix) <- routes ] + assertEqual + "mount destinations" + [ ("project", "entry.html") + , ("library", "library/entry.html") + , ("debug", "debug/entry.html") + , ("external", "external/entry.html") + ] + [ (ident, destination) + | (ident, _url, destination, _prefix) <- routes + ] + +routesRootFormsIdentically :: Assertion +routesRootFormsIdentically = + withTemporaryDirectory "felix-html-layout-root-forms" \temp -> do + let libraryRoot = temp Posix. "library" + entry = libraryRoot Posix. "entry.tex" + Directory.createDirectory libraryRoot + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", temp) + , (sourceMountId "library", libraryRoot) + ] + searched <- expectRight (searchedRoot "library/entry.tex") + exact <- expectRight =<< existingRoot entry + searchedGraph <- + expectRight =<< buildResolvedSourceGraph mounts searched + exactGraph <- + expectRight =<< buildResolvedSourceGraph mounts exact + let configuration = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + ] + searchedLayout <- + expectRight + (layoutHtmlSourceGraph configuration searchedGraph) + exactLayout <- + expectRight + (layoutHtmlSourceGraph configuration exactGraph) + searchedRoute <- + requireRootRoute searchedGraph searchedLayout + exactRoute <- + requireRootRoute exactGraph exactLayout + assertEqual "selected route" searchedRoute exactRoute + assertEqual + "most-specific URL" + "/library/entry" + (renderUrlPath (routeUrlPath searchedRoute)) + +requiresExternalMount :: Assertion +requiresExternalMount = + withTemporaryDirectory "felix-html-layout-external" \temp -> do + let projectRoot = temp Posix. "project" + externalRoot = temp Posix. "vendor" + externalEntry = externalRoot Posix. "entry.tex" + Directory.createDirectory projectRoot + Directory.createDirectory externalRoot + writeTheory externalEntry [] + request <- expectRight =<< existingRoot externalEntry + projectMounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", projectRoot)] + outsideResult <- + buildResolvedSourceGraph projectMounts request + case outsideResult of + Left RootOutsideConfiguredMount{} -> + pure () + result -> + assertFailure + ("expected external root rejection, got " + <> show result) + mounted <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "external", externalRoot) + ] + graph <- expectRight =<< buildResolvedSourceGraph mounted request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId "project", []) + , (sourceMountId "external", ["vendor"]) + ] + graph) + route <- requireRootRoute graph layout + assertEqual + "external URL" + "/vendor/entry" + (renderUrlPath (routeUrlPath route)) + +reportsRouteCollisions :: Assertion +reportsRouteCollisions = do + reportsPageCollisions + reportsAssetUrlCollision + +reportsPageCollisions :: Assertion +reportsPageCollisions = + withTemporaryDirectory "felix-html-layout-page-collision" \temp -> do + let firstRoot = temp Posix. "first" + secondRoot = temp Posix. "second" + firstEntry = firstRoot Posix. "two" Posix. "a.tex" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + Directory.createDirectory (firstRoot Posix. "two") + writeTheory (secondRoot Posix. "a.tex") [] + writeTheory firstEntry ["a.tex"] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "first", firstRoot) + , (sourceMountId "second", secondRoot) + ] + request <- expectRight =<< existingRoot firstEntry + graph <- expectRight =<< buildResolvedSourceGraph mounts request + let configuration = + [ (sourceMountId "first", ["one"]) + , (sourceMountId "second", ["one", "two"]) + ] + case layoutHtmlSourceGraph configuration graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url owners] + [HtmlDestinationRouteCollision destination + destinationOwners]) -> do + assertEqual + "canonical URL collision" + "/one/two/a" + (renderUrlPath url) + assertEqual + "URL owners" + (NonEmpty.toList owners) + (NonEmpty.toList destinationOwners) + assertEqual + "destination collision" + "one/two/a.html" + (safeRelativePathFilePath destination) + result -> + assertFailure + ("expected paired route collisions, got " + <> show result) + +reportsAssetUrlCollision :: Assertion +reportsAssetUrlCollision = + withTemporaryDirectory "felix-html-layout-asset-collision" \temp -> do + let entry = + temp + Posix. "_static" + Posix. "naproche-html.js.tex" + Directory.createDirectory (temp Posix. "_static") + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- + expectRight + (searchedRoot "_static/naproche-html.js.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case + layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url _owners] + []) -> + assertEqual + "page/asset URL collision" + "/_static/naproche-html.js" + (renderUrlPath url) + result -> + assertFailure + ("expected URL-only asset collision, got " + <> show result) + +rejectsNestedDestinations :: Assertion +rejectsNestedDestinations = + withTemporaryDirectory "felix-html-layout-nested" \temp -> do + let nestedDirectory = temp Posix. "a.html" + Directory.createDirectory nestedDirectory + writeTheory (temp Posix. "a.tex") [] + writeTheory (nestedDirectory Posix. "b.tex") [] + writeTheory + (temp Posix. "entry.tex") + ["a.tex", "a.html/b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [] + [NestedHtmlDestinationRouteCollision + ancestor + ancestorOwner + descendant + descendantOwner]) -> do + assertEqual + "ancestor destination" + "a.html" + (safeRelativePathFilePath ancestor) + assertEqual + "ancestor owner" + "a.tex" + (pageOwnerPath ancestorOwner) + assertEqual + "descendant destination" + "a.html/b.html" + (safeRelativePathFilePath descendant) + assertEqual + "descendant owner" + "a.html/b.tex" + (pageOwnerPath descendantOwner) + result -> + assertFailure + ("expected nested destination collision, got " + <> show result) + where + pageOwnerPath = \case + HtmlPage source -> + safeRelativePathFilePath + (resolvedSourceRelativePath source) + HtmlSupportScript -> + "" + +isTraversalOrderIndependent :: Assertion +isTraversalOrderIndependent = + withTemporaryDirectory "felix-html-layout-order" \temp -> do + writeTheory (temp Posix. "a.tex") [] + writeTheory (temp Posix. "b.tex") [] + let root = temp Posix. "entry.tex" + writeTheory root ["a.tex", "b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + firstGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + writeTheory root ["b.tex", "a.tex"] + secondGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + let firstConfiguration = + [ (sourceMountId "unused", ["unused"]) + , (sourceMountId "project", []) + ] + firstLayout <- + expectRight + (layoutHtmlSourceGraph + firstConfiguration + firstGraph) + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations firstConfiguration)) + \(orderedGraph, configuration) -> do + layout <- + expectRight + (layoutHtmlSourceGraph + configuration + orderedGraph) + assertEqual + "route table" + firstLayout + layout + + let collidingConfiguration = + [ (sourceMountId "z", ["same"]) + , (sourceMountId "a", ["same"]) + , (sourceMountId "project", []) + ] + expectedCollision = + layoutHtmlSourceGraph + collidingConfiguration + firstGraph + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations collidingConfiguration)) + \(orderedGraph, configuration) -> + assertEqual + "collision diagnostic" + expectedCollision + (layoutHtmlSourceGraph + configuration + orderedGraph) + + +requireRootRoute + :: ResolvedSourceGraph + -> HtmlLayout + -> IO HtmlRoute +requireRootRoute graph layout = + case htmlPageRoute layout (sourceGraphRootSource graph) of + Just route -> + pure route + Nothing -> do + assertFailure "layout omitted the root source" + pure (impossible "requireRootRoute: assertFailure returned") + +writeTheory :: FilePath -> [FilePath] -> IO () +writeTheory path imports = + writeFile path + (unlines + (["\\import{" <> imported <> "}" | imported <- imports] + <> [ "\\begin{axiom}\\label{route_fixture}" + , " $x = x$." + , "\\end{axiom}" + ])) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/HtmlOutput.hs b/source/Felix/Test/Unit/HtmlOutput.hs new file mode 100644 index 0000000..34fe2e7 --- /dev/null +++ b/source/Felix/Test/Unit/HtmlOutput.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlOutput (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph qualified as SourceGraph +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Export +import Felix.Render.Html.Output + +import Control.Exception (bracket) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import System.Directory qualified as Directory +import System.FilePath.Posix (()) +import System.Posix.Files qualified as PosixFiles +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "HTML output" + [ testCase + "publishes a mounted multi-page UTF-8 export" + publishesMountedExport + , testCase + "writes prepared strict bytes" + writesPreparedBytes + , testCase + "attaches bytes only to reserved routes" + attachesBytesToReservedRoutes + , testCase + "rejects a final symlink before publication" + rejectsFinalSymlink + , testCase + "replaces hard-linked targets without changing peers" + replacesHardLinkedTarget + , testCase + "rejects a FIFO before publication" + rejectsFifo + , testCase + "reports and cleans the source-order publication prefix" + reportsIncompletePublication + ] + + +publishesMountedExport :: Assertion +publishesMountedExport = + withTemporaryDirectory "felix-html-export" \temp -> do + let projectRoot = temp "project" + libraryRoot = temp "library" + projectDirectory = projectRoot "docs" + libraryDirectory = libraryRoot "shared" + rootSource = projectDirectory "über #.tex" + importedSource = + libraryDirectory "sets #.tex" + outputRoot = temp "html" + rootPage = outputRoot "docs" "über #.html" + importedPage = + outputRoot + "library" + "shared" + "sets #.html" + supportAsset = + outputRoot + "_static" + "naproche-html.js" + configuration = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + ] + hints = + "relation\teq\t0\t=\n" + Directory.createDirectory projectRoot + Directory.createDirectory libraryRoot + Directory.createDirectory projectDirectory + Directory.createDirectory libraryDirectory + writeImportedTheory importedSource + writeRootTheory rootSource + mounts <- + expectRight =<< + prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "library", libraryRoot) + ] + searched <- + expectRight + (searchedRoot "docs/über #.tex") + exact <- + expectRight =<< existingRoot rootSource + searchedExport <- + expectRight =<< + prepareTestHtmlExport + configuration + mounts + searched + hints + exactExport <- + expectRight =<< + prepareTestHtmlExport + configuration + mounts + exact + hints + assertEqual + "root-form-independent destinations" + (preparedHtmlArtifactDestination <$> searchedExport) + (preparedHtmlArtifactDestination <$> exactExport) + + let artifacts = searchedExport + rejectsArtifactEscape temp artifacts + + plan <- + requirePlan =<< + planHtmlOutput outputRoot artifacts + outputExistsBeforePublication <- + Directory.doesPathExist outputRoot + assertBool + "preflight created the output root" + (not outputExistsBeforePublication) + requirePublication =<< writeHtmlOutput plan + + rootText <- readUtf8 rootPage + importedText <- readUtf8 importedPage + supportText <- readUtf8 supportAsset + assertContains + "root heading" + "

project:docs/über #.tex

" + rootText + assertContains + "imported heading" + "

library:shared/sets #.tex

" + importedText + assertContains + "encoded imported reference" + "href=\"../library/shared/sets%20%23#imported_prop\"" + rootText + assertContains + "encoded imported source link" + "href=\"../library/shared/sets%20%23\">library:shared/sets #.tex" + rootText + assertContains + "root support route" + "src=\"../_static/naproche-html.js\"" + rootText + assertContains + "imported support route" + "src=\"../../_static/naproche-html.js\"" + importedText + for_ [rootText, importedText] \document -> + assertContains + "UTF-8 declaration" + "" + document + assertEqual + "support asset" + Html.supportScriptAssetContents + supportText + +rejectsArtifactEscape + :: FilePath + -> [PreparedHtmlArtifact] + -> Assertion +rejectsArtifactEscape temp artifacts = do + let outputRoot = temp "escape-html" + outsideRoot = temp "outside" + outsideMarker = outsideRoot "unchanged" + Directory.createDirectory outputRoot + Directory.createDirectory outsideRoot + ByteString.writeFile outsideMarker "outside" + Directory.createDirectoryLink + outsideRoot + (outputRoot "docs") + result <- planHtmlOutput outputRoot artifacts + case result of + Left + (HtmlOutputParentEscapesRoot + _parent + canonicalParent) -> do + expectedOutside <- + Directory.canonicalizePath outsideRoot + assertEqual + "escaping route target" + expectedOutside + canonicalParent + other -> + assertFailure + ("expected output-root escape rejection, got " + <> showPlanResult other) + outsideBytes <- ByteString.readFile outsideMarker + assertEqual + "escape planning changed the outside tree" + "outside" + outsideBytes + supportExists <- + Directory.doesPathExist + (outputRoot "_static") + assertBool + "escape preflight created another destination" + (not supportExists) + +writesPreparedBytes :: Assertion +writesPreparedBytes = + withTemporaryDirectory "felix-html-output-bytes" \temp -> do + let outputRoot = temp "html" + pageText = "∀ café" + supportText = "const π = 3;" + expectedPageBytes = + ByteString.pack + [ 0xe2, 0x88, 0x80 + , 0x20 + , 0x63, 0x61, 0x66 + , 0xc3, 0xa9 + ] + artifacts <- + makeArtifacts + [ ( "nested/über.html" + , TextEncoding.encodeUtf8 pageText + ) + , ( "_static/naproche-html.js" + , TextEncoding.encodeUtf8 supportText + ) + ] + publishArtifacts outputRoot artifacts + pageBytes <- + ByteString.readFile + (outputRoot "nested" "über.html") + supportBytes <- + ByteString.readFile + (outputRoot + "_static" + "naproche-html.js") + assertEqual + "exact page UTF-8 bytes" + expectedPageBytes + pageBytes + assertEqual + "exact support bytes" + (TextEncoding.encodeUtf8 supportText) + supportBytes + +attachesBytesToReservedRoutes :: Assertion +attachesBytesToReservedRoutes = + withTemporaryDirectory "felix-html-output-routes" \temp -> do + let outputRoot = temp "html" + reserved <- expectRight + (traverse safeRelativePath + ["page.html", "_static/naproche-html.js"]) + routes <- requireRoutePlan =<< + planHtmlRoutes outputRoot reserved + matching <- makeArtifacts + [ ("page.html", "page") + , ("_static/naproche-html.js", "support") + ] + case planHtmlOutputAgainst routes matching of + Right _ -> + pure () + Left failure -> + assertFailure (show failure) + mismatched <- makeArtifacts + [ ("other.html", "other") + , ("_static/naproche-html.js", "support") + ] + case planHtmlOutputAgainst routes mismatched of + Left HtmlOutputRouteMismatch{} -> + pure () + Left failure -> + assertFailure + ("unexpected route mismatch: " <> show failure) + Right _ -> + assertFailure "unreserved HTML route was accepted" + +rejectsFinalSymlink :: Assertion +rejectsFinalSymlink = + withTemporaryDirectory "felix-html-output-final-link" \temp -> do + let outputRoot = temp "html" + supportDirectory = outputRoot "_static" + page = outputRoot "page.html" + support = + supportDirectory "naproche-html.js" + outsideAsset = temp "outside.js" + Directory.createDirectory outputRoot + Directory.createDirectory supportDirectory + ByteString.writeFile page "old page" + ByteString.writeFile outsideAsset "outside asset" + Directory.createFileLink outsideAsset support + artifacts <- + makeArtifacts + [ ("page.html", "new page") + , ("_static/naproche-html.js", "new support") + ] + result <- planHtmlOutput outputRoot artifacts + case result of + Left (HtmlOutputTargetIsSymbolicLink target) -> + assertEqual "rejected target" support target + other -> + assertFailure + ("expected final symlink rejection, got " + <> showPlanResult other) + pageBytes <- ByteString.readFile page + outsideBytes <- ByteString.readFile outsideAsset + supportIsLink <- + Directory.pathIsSymbolicLink support + assertEqual + "page changed before complete preflight" + "old page" + pageBytes + assertEqual + "symlink referent changed" + "outside asset" + outsideBytes + assertBool "final symlink was replaced" supportIsLink + +replacesHardLinkedTarget :: Assertion +replacesHardLinkedTarget = + withTemporaryDirectory "felix-html-output-hard-link" \temp -> do + let outputRoot = temp "html" + page = outputRoot "page.html" + outsidePage = temp "outside.html" + Directory.createDirectory outputRoot + ByteString.writeFile outsidePage "outside page" + PosixFiles.createLink outsidePage page + artifacts <- + makeArtifacts [("page.html", "new page")] + publishArtifacts outputRoot artifacts + outsideBytes <- ByteString.readFile outsidePage + pageBytes <- ByteString.readFile page + assertEqual + "outside hard-link peer changed" + "outside page" + outsideBytes + assertEqual "page was not replaced" "new page" pageBytes + +rejectsFifo :: Assertion +rejectsFifo = + withTemporaryDirectory "felix-html-output-fifo" \temp -> do + let outputRoot = temp "html" + page = outputRoot "page.html" + Directory.createDirectory outputRoot + PosixFiles.createNamedPipe page PosixFiles.ownerModes + artifacts <- + makeArtifacts [("page.html", "page")] + result <- planHtmlOutput outputRoot artifacts + case result of + Left (HtmlOutputTargetNotRegularFile target) -> + assertEqual "rejected target" page target + other -> + assertFailure + ("expected FIFO rejection, got " + <> showPlanResult other) + pageStatus <- + PosixFiles.getSymbolicLinkStatus page + assertBool + "FIFO target was replaced" + (PosixFiles.isNamedPipe pageStatus) + +reportsIncompletePublication :: Assertion +reportsIncompletePublication = + withTemporaryDirectory "felix-html-output-incomplete" \temp -> do + let outputRoot = temp "html" + first = outputRoot "z.html" + blocked = outputRoot "b.html" + unpublished = outputRoot "a.html" + artifacts <- + makeArtifacts + [ ("z.html", "first") + , ("b.html", "blocked") + , ("a.html", "unpublished") + ] + plan <- + requirePlan =<< + planHtmlOutput outputRoot artifacts + Directory.createDirectory outputRoot + Directory.createDirectory blocked + result <- writeHtmlOutput plan + case result of + Left + IncompleteHtmlPublication + { committedHtmlDestinations + , failedHtmlDestination + } -> do + expectedFirst <- + expectRight + (safeRelativePath "z.html") + expectedBlocked <- + expectRight + (safeRelativePath "b.html") + assertEqual + "committed destinations" + [expectedFirst] + committedHtmlDestinations + assertEqual + "failed destination" + expectedBlocked + failedHtmlDestination + Right () -> + assertFailure + "expected incomplete publication" + firstBytes <- ByteString.readFile first + unpublishedExists <- + Directory.doesPathExist unpublished + blockedIsDirectory <- + Directory.doesDirectoryExist blocked + outputEntries <- + Directory.listDirectory outputRoot + assertEqual "first artifact" "first" firstBytes + assertBool + "later artifact was published" + (not unpublishedExists) + assertBool + "injected blocker was replaced" + blockedIsDirectory + assertBool + "unpublished temporary files remain" + (not + (any + (List.isInfixOf ".tmp") + outputEntries)) + + +publishArtifacts + :: FilePath + -> [PreparedHtmlArtifact] + -> IO () +publishArtifacts outputRoot artifacts = do + plan <- + requirePlan =<< planHtmlOutput outputRoot artifacts + requirePublication =<< writeHtmlOutput plan + +makeArtifacts + :: [(FilePath, ByteString.ByteString)] + -> IO [PreparedHtmlArtifact] +makeArtifacts artifacts = + for artifacts \(path, bytes) -> do + relative <- expectRight (safeRelativePath path) + pure (preparedHtmlArtifact relative (Right bytes)) + +requirePlan + :: Either HtmlOutputError HtmlOutputPlan + -> IO HtmlOutputPlan +requirePlan = + expectRight + +requireRoutePlan + :: Either HtmlOutputError HtmlRoutePlan + -> IO HtmlRoutePlan +requireRoutePlan = + expectRight + +requirePublication + :: Either HtmlPublicationError () + -> IO () +requirePublication = + expectRight + +showPlanResult + :: Either HtmlOutputError HtmlOutputPlan + -> String +showPlanResult = \case + Left err -> + show err + Right _plan -> + "successful output plan" + +readUtf8 :: FilePath -> IO Text +readUtf8 path = do + bytes <- ByteString.readFile path + case TextEncoding.decodeUtf8' bytes of + Left err -> + assertFailure + ("invalid UTF-8 output: " <> show err) + Right text -> + pure text + +prepareTestHtmlExport + :: [(SourceMountId, [Text])] + -> SourceMounts + -> RootRequest + -> Text + -> IO (Either HtmlExportError [PreparedHtmlArtifact]) +prepareTestHtmlExport configuration mounts request hints = do + graph <- + expectRight =<< + SourceGraph.buildResolvedSourceGraph mounts request + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + pure + (prepareHtmlExport + configuration + (htmlPresentationFromParsedWorkspace workspace) + hints) + +writeImportedTheory :: FilePath -> IO () +writeImportedTheory path = + writeFile path + (unlines + [ "\\begin{proposition}\\label{imported_prop}" + , " $i = i$." + , "\\end{proposition}" + ]) + +writeRootTheory :: FilePath -> IO () +writeRootTheory path = + writeFile path + (unlines + [ "\\import{shared/sets #.tex}" + , "\\begin{proposition}\\label{local_prop}" + , " $a = a$." + , "\\end{proposition}" + , "\\begin{proposition}\\label{uses_import}" + , " $b = b$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Follows by \\cref{imported_prop}." + , "\\end{proof}" + ]) + +assertContains + :: String + -> Text + -> Text + -> Assertion +assertContains description needle haystack = + assertBool + (description <> ": missing " <> show needle) + (needle `Text.isInfixOf` haystack) + +expectRight + :: (Show e, HasCallStack) + => Either e a + -> IO a +expectRight = \case + Left err -> + assertFailure + ("expected Right, got Left " <> show err) + Right value -> + pure value + +withTemporaryDirectory + :: String + -> (FilePath -> IO a) + -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- + Directory.getTemporaryDirectory + (path, handle) <- + openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Identity.hs b/source/Felix/Test/Unit/Identity.hs new file mode 100644 index 0000000..7e1e73f --- /dev/null +++ b/source/Felix/Test/Unit/Identity.hs @@ -0,0 +1,802 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Identity (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Source + +import Control.Exception (bracket) +import Data.ByteString qualified as ByteString +import Data.Either (isLeft) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Numeric.Natural (Natural) +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Content identities" + [ testCase "uses the frozen mathematical hash framing" + hashesCanonicalFields + , testCase "orders exhaustive foundation rows by stable tags" + ordersFoundationManifestTags + , testCase "uses the frozen source path codecs" + encodesSourcePaths + , testCase "separates durable namespaces from mount labels" + separatesModuleOwnership + , testCase "rejects duplicate canonical collection encodings" + rejectsDuplicateCanonicalCollections + , testCase "matches every frozen mathematical identity vector" + matchesMathematicalIdentityVectors + , testCase "validates recursive transparent object content" + validatesTransparentObjectClosure + , testCase "rejects cyclic and mismatched object content" + rejectsInvalidObjectContent + , testCase "validates proposition content and theorem closure" + validatesPropositionAndTheorem + , testCase "round-trips deterministic epoch cache values" + roundTripsEpochCacheValues + , testCase "validates compact fact authority" + validatesCompactFactAuthority + , testCase "propagates candidate safety through local claims" + propagatesCandidateSafety + ] + +ordersFoundationManifestTags :: Assertion +ordersFoundationManifestTags = do + let (intrinsics, rules, axioms) = + Identity.foundationManifestTags + assertEqual + "intrinsic stable-tag order" + [ Core.Member + , Core.Empty + , Core.PairSet + , Core.FamilyUnion + , Core.PowerSet + , Core.Sep + , Core.Repl + , Core.SetChoose + , Core.UnivOf + , Core.ISetLfp + ] + intrinsics + assertEqual + "kernel-rule stable-tag order" + [ Foundation.SetLfpBound + , Foundation.SetLfpLeast + , Foundation.SetLfpFixed + , Foundation.SetLfpInduct + ] + rules + assertEqual + "foundation-axiom stable-tag order" + [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + , Foundation.PowerSetCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + , Foundation.SetChooseWitness + , Foundation.SetExtensionality + , Foundation.SetInduction + , Foundation.PropositionalExtensionality + , Foundation.DoubleNegationElim + , Foundation.UnivOfContains + , Foundation.UnivOfTransitive + , Foundation.UnivOfFamilyUnionClosed + , Foundation.UnivOfPowerSetClosed + , Foundation.UnivOfReplacementClosed + , Foundation.UnivOfMinimal + ] + axioms + +hashesCanonicalFields :: Assertion +hashesCanonicalFields = do + let vectors = + [ ( [] + , "09ace37213e33d80b79e5f21fd60d03f25855e528cc2f25da4762be81d34a8c2" + ) + , ( [ByteString.empty] + , "cd166f5b566ebd02f00f202792699803df09e9a020afbaaa987f5001cb1d095e" + ) + , (["a", "bc"] + , "70c43385ae5b28bb862bc461a3c8d85ab94fd616528e7d94a9e7a52217b5c657" + ) + , (["ab", "c"] + , "d3588d1b26aac958d9f393d8528ad68ed34354aee41d7e405a156b3ffff20c90" + ) + ] + traverse_ + (\(fields, expected) -> do + digest <- expectRight + (hashCanonicalFields "felix-test-v1" fields) + assertEqual + ("fields " <> show fields) + expected + (mathematicalDigestHex digest)) + vectors + +encodesSourcePaths :: Assertion +encodesSourcePaths = do + let absoluteVectors = + [ ([] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000000" + ) + , (["a"] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000001000000000000000161" + ) + , (["a", "b"] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000002000000000000000161000000000000000162" + ) + ] + relativeVectors = + [ (["a"] + , "000000000000001b66656c69782d736166652d72656c61746976652d706174682d763100000001000000000000000161" + ) + , (["a", "b"] + , "000000000000001b66656c69782d736166652d72656c61746976652d706174682d763100000002000000000000000161000000000000000162" + ) + ] + traverse_ + (\(components, expected) -> do + encoded <- expectRight + (encodeCanonicalPathRecord + "felix-absolute-source-root-path-v1" + components) + assertEqual + (show components) + expected + (hex encoded)) + absoluteVectors + traverse_ + (\(components, expected) -> do + encoded <- expectRight + (encodeCanonicalPathRecord + "felix-safe-relative-path-v1" + components) + assertEqual + (show components) + expected + (hex encoded)) + relativeVectors + +separatesModuleOwnership :: Assertion +separatesModuleOwnership = + withTemporaryDirectory "felix-module-owner" \root -> do + writeFile (root Posix. "b.tex") "" + mounts <- expectRight + =<< prepareSourceMounts + [(sourceMountId "display-only", root)] + request <- expectRight (searchedRoot "b.tex") + source <- expectRight =<< resolveRoot mounts request + mount <- case sourceMountList mounts of + [only] -> + pure only + _ -> + assertFailure "expected one prepared mount" + >> fail "unreachable" + relative <- expectRight (safeRelativePath "b.tex") + let owner = + moduleName (resolvedSourceAddress source) + assertEqual + "relative owner" + relative + (moduleNameRelativePath owner) + assertEqual + "namespace derives from the canonical root" + (sourceNamespaceId (sourceMountRoot mount)) + (moduleNameNamespace owner) + +rejectsDuplicateCanonicalCollections :: Assertion +rejectsDuplicateCanonicalCollections = do + assertEqual + "set duplicate" + (Left (DuplicateCanonicalSetElement "a")) + (encodeCanonicalSet ["b", "a", "a"]) + assertEqual + "map duplicate" + (Left (DuplicateCanonicalMapKey "a")) + (encodeCanonicalMap [("a", "first"), ("a", "second")]) + +matchesMathematicalIdentityVectors :: Assertion +matchesMathematicalIdentityVectors = do + fixture <- makeIdentityFixture + let vectors = + [ ( "theory" + , Identity.theoryIdDigest + (fixtureTheory fixture) + , "46665f15f80ad52d319188de307471f34905ec3849b84b9d6d0d5a584a90eb62" + ) + , ( "intrinsic Empty" + , Identity.objectIdDigest + (fixtureIntrinsic fixture) + , "a11f641738714ac806f3c3b902841b3178d32fff38fea353aac409e3cc1a8efc" + ) + , ( "transparent Empty" + , Identity.objectIdDigest + (fixtureTransparent fixture) + , "49dfb3c96f0db2cc81703bbed82c08e9d2eda7d4a2274f0529d22c592003d4d1" + ) + , ( "opaque signature" + , Identity.objectIdDigest + (fixtureOpaque fixture) + , "8723488e60ed09ffad378bc6d9916d07c348d12d01548a7b482726e6e18b2c8d" + ) + , ( "proposition" + , Identity.propositionIdDigest + (Identity.checkedPropositionId + (fixtureProposition fixture)) + , "c40b403f0422f4125065d83b5eba64e4b0c4b24fb1559967ef986f5265829b65" + ) + , ( "theorem" + , Identity.theoremIdDigest + (fixtureTheorem fixture) + , "6a328a4142fde3c9851186ea00f54d8978d2640dcbe51421536c9726f4f717d2" + ) + ] + traverse_ + (\(description, digest, expected) -> + assertEqual + description + expected + (mathematicalDigestHex digest)) + vectors + assertEqual + "opaque declaration seed" + "27697d641220b8bb63b32631492646277b28e70c8b7149206580337254ecc123" + (mathematicalDigestHex + (Identity.opaqueDeclarationSeedDigest + (fixtureOpaqueSeed fixture))) + assertEqual + "family domains remain distinct" + (length vectors) + (Set.size + (Set.fromList + [ digest + | (_description, digest, _expected) <- vectors + ])) + +validatesTransparentObjectClosure :: Assertion +validatesTransparentObjectClosure = do + fixture <- makeIdentityFixture + let theory = fixtureTheory fixture + child = fixtureTransparent fixture + parentBody = Core.CGlobal child + parent = + Identity.transparentObjectId + theory + Core.TySet + parentBody + assertions = + [ Identity.assertedObject + parent + (Identity.TransparentObjectContent + theory + Core.TySet + parentBody) + , Identity.assertedObject + child + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty)) + , Identity.assertedObject + (fixtureIntrinsic fixture) + (Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet) + ] + closure <- expectRight + (Identity.validateObjectClosure theory assertions) + assertEqual + "all recursively checked objects" + (Set.fromList + [ fixtureIntrinsic fixture + , child + , parent + ]) + (Identity.checkedObjectIds closure) + assertEqual + "parent type" + (Just Core.TySet) + (Identity.lookupCheckedObjectType parent closure) + +rejectsInvalidObjectContent :: Assertion +rejectsInvalidObjectContent = do + fixture <- makeIdentityFixture + firstDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-a" []) + secondDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-b" []) + mismatchDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-mismatch" []) + let theory = fixtureTheory fixture + first = + Identity.objectId + Identity.TransparentObject + firstDigest + second = + Identity.objectId + Identity.TransparentObject + secondDigest + cycleAssertions = + [ Identity.assertedObject + first + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal second)) + , Identity.assertedObject + second + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal first)) + ] + case Identity.validateObjectClosure theory cycleAssertions of + Left (Identity.TransparentObjectCycle path) -> do + assertEqual + "cycle closes" + (NonEmpty.head path) + (NonEmpty.last path) + assertEqual + "cycle members" + (Set.fromList [first, second]) + (Set.fromList (NonEmpty.toList path)) + Left other -> + assertFailure + ("expected a transparent cycle, got " <> show other) + Right _ -> + assertFailure "expected a transparent cycle, got Right" + let mismatched = + Identity.objectId + Identity.TransparentObject + mismatchDigest + content = + Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + case + Identity.validateObjectClosure + theory + [Identity.assertedObject mismatched content] of + Left + (Identity.ObjectIdPayloadMismatch + supplied + computed) -> do + assertEqual "supplied ID" mismatched supplied + assertEqual + "computed ID" + (fixtureTransparent fixture) + computed + Left other -> + assertFailure + ("expected object ID disagreement, got " <> show other) + Right _ -> + assertFailure "expected object ID disagreement, got Right" + +validatesPropositionAndTheorem :: Assertion +validatesPropositionAndTheorem = do + fixture <- makeIdentityFixture + let proposition = + fixtureProposition fixture + reference = + fixtureTheoremRef fixture + assertEqual + "theorem retains its theory" + (fixtureTheory fixture) + (Identity.theoremRefTheory reference) + assertEqual + "theorem retains its proposition" + (Identity.checkedPropositionId proposition) + (Identity.theoremRefProposition reference) + falsum <- expectRight + (Identity.validatePropositionContent + (fixtureClosure fixture) + Core.CFalsum) + case + Identity.validateAssertedPropositionContent + (fixtureClosure fixture) + (Identity.checkedPropositionId falsum) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) of + Left + (Identity.PropositionIdPayloadMismatch + supplied + computed) -> do + assertEqual + "supplied proposition ID" + (Identity.checkedPropositionId falsum) + supplied + assertEqual + "computed proposition ID" + (Identity.checkedPropositionId proposition) + computed + Left other -> + assertFailure + ("expected proposition ID disagreement, got " + <> show other) + Right _ -> + assertFailure + "expected proposition ID disagreement, got Right" + +roundTripsEpochCacheValues :: Assertion +roundTripsEpochCacheValues = do + fixture <- makeIdentityFixture + let theory = fixtureTheory fixture + contents = + [ Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet + , Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + , Identity.OpaqueObjectContent + theory + (fixtureOpaqueSeed fixture) + Core.TySet + ] + traverse_ + (\content -> + assertEqual + "object-content cache round trip" + (Right content) + (decodeCache + Identity.getObjectContentCache + (encodeCache + (Identity.putObjectContentCache + content)))) + contents + assertEqual + "constructive theorem reference cache round trip" + (Right (fixtureTheoremRef fixture)) + (decodeCache + Identity.getTheoremRefCache + (encodeCache + (Identity.putTheoremRefCache + (fixtureTheoremRef fixture)))) + assertBool + "cache bytes are not mathematical theorem-reference bytes" + ( encodeCache + (Identity.putTheoremRefCache + (fixtureTheoremRef fixture)) + /= Identity.encodeTheoremRef + (fixtureTheoremRef fixture) + ) + let ascending = + Map.fromList [("a", 1 :: Natural), ("b", 2)] + putMap = + putCanonicalCacheMap + putCacheText + putCacheNatural + assertEqual + "canonical cache map round trip" + (Right ascending) + (decodeCache + (getCanonicalCacheMap + getCacheText + getCacheNatural) + (encodeCache (putMap ascending))) + +validatesCompactFactAuthority :: Assertion +validatesCompactFactAuthority = do + fixture <- makeIdentityFixture + let reference = fixtureTheoremRef fixture + sourceKinds = + Authority.singletonEscapeKind Authority.SourceAxiom + bothKinds = + Authority.escapeKinds + [Authority.Omitted, Authority.SourceAxiom] + sourceTarget = + Authority.factAuthority + reference + (Authority.authoritySafety sourceKinds) + bothTarget = + Authority.factAuthority + reference + (Authority.authoritySafety bothKinds) + requests = + [ Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "first" + , Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "first" + , Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "second" + ] + directRequest = + Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "same bytes" + indirectRequest = + Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestIndirect + "same bytes" + directAuthorizations = + [ Authority.CheckedKernelConstruction + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + , Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet + (Foundation.SetLfpBound :| []))) + , Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (fixtureIntrinsic fixture)) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + (fixtureIntrinsic fixture) + (hashCacheFields + "test-named-construction" ["checked"])) + , Authority.CheckedSourceProof requests + , Authority.TrustedCompilation + (Authority.DatatypeCompilation + (Authority.datatypeCompilationDescriptor + (fixtureIntrinsic fixture) + (NonEmpty.singleton + (fixtureIntrinsic fixture)) + [reference])) + , Authority.SourceAxiomAuthorization + , Authority.OmittedAuthorization + ] + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceTarget + Authority.SourceAxiomAuthorization) + proofCertificate <- expectRight + (Authority.validationCertificate + bothTarget + (Authority.CheckedSourceProof requests)) + assertEqual + "escape bits have canonical order" + [Authority.SourceAxiom, Authority.Omitted] + (Authority.escapeKindsToList bothKinds) + traverse_ + (\direct -> + assertEqual + ("direct authorization round trip: " <> show direct) + (Right direct) + (decodeCache + Authority.getDirectAuthorizationCache + (encodeCache + (Authority.putDirectAuthorizationCache + direct)))) + directAuthorizations + assertEqual + "certificate cache retains repeated ordered requests" + (Right proofCertificate) + (decodeCache + Authority.getValidationCertificateCache + (encodeCache + (Authority.putValidationCertificateCache + proofCertificate))) + assertBool + "request mode participates in exact request identity" + (directRequest /= indirectRequest) + assertEqual + "prepared-request cache identity vector" + "1d72b851cb8b1704617becbf9f2cf492aed1c674d9e6ca759e244f169b15f278" + (hex + (encodeCache + (Authority.putPreparedRequestIdCache + directRequest))) + assertEqual + "source certificate round trip" + (Right sourceCertificate) + (decodeCache + Authority.getValidationCertificateCache + (encodeCache + (Authority.putValidationCertificateCache + sourceCertificate))) + assertBool + "source axiom requires its exact singleton safety" + (isLeft + (Authority.validationCertificate + bothTarget + Authority.SourceAxiomAuthorization)) + assertBool + "omitted authorization requires its distinct bit" + (isLeft + (Authority.validationCertificate + sourceTarget + Authority.OmittedAuthorization)) + assertBool + "cache rejects an empty escape-backed value" + (isLeft + (decodeCache + Authority.getAuthoritySafetyCache + (encodeCache do + putCacheTag 0x01 + putCacheTag 0x00))) + let taintedCandidate = + Authority.addCandidateEscape + Authority.SourceAxiom + Authority.initialCandidateSafety + assertEqual + "candidate completion freezes accumulated safety" + sourceTarget + (Authority.candidateFactAuthority + reference + taintedCandidate) + +propagatesCandidateSafety :: Assertion +propagatesCandidateSafety = do + fixture <- makeIdentityFixture + let reference = fixtureTheoremRef fixture + imported = + Authority.factAuthority + reference + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + afterImported <- expectRight + (Authority.accumulateFactSafety + reference + imported + Authority.initialCandidateSafety) + -- A local claim shares the enclosing candidate value; citing that claim + -- does not create a second support representation. + afterLocalClaim <- expectRight + (Authority.accumulateFactSafety + reference + (Authority.factAuthority + reference + Authority.cleanAuthoritySafety) + afterImported) + let finalSafety = + Authority.addCandidateEscape + Authority.Omitted + afterLocalClaim + assertEqual + "local claim retains prior safety and direct omission" + [Authority.SourceAxiom, Authority.Omitted] + (Authority.escapeKindsToList + (Authority.authoritySafetyEscapeKinds + (Authority.candidateSafetyAuthority finalSafety))) + +data IdentityFixture = IdentityFixture + { fixtureTheory :: !Identity.TheoryId + , fixtureIntrinsic :: !Identity.ObjectId + , fixtureTransparent :: !Identity.ObjectId + , fixtureOpaqueSeed :: !Identity.OpaqueDeclarationSeed + , fixtureOpaque :: !Identity.ObjectId + , fixtureClosure :: !Identity.CheckedObjectClosure + , fixtureProposition :: !Identity.CheckedPropositionContent + , fixtureTheoremRef :: !Identity.TheoremRef + , fixtureTheorem :: !Identity.TheoremId + } + +makeIdentityFixture :: IO IdentityFixture +makeIdentityFixture = do + foundation <- expectRight Foundation.checkedFoundation + pathRecord <- expectRight + (encodeCanonicalPathRecord + "felix-absolute-source-root-path-v1" + ["a"]) + namespaceDigest <- expectRight + (hashCanonicalFields + "felix-source-namespace-v1" + [pathRecord]) + relative <- expectRight (safeRelativePath "b.tex") + let theory = + Identity.theoryId foundation + intrinsic = + Identity.intrinsicObjectId + theory + Core.Empty + Core.TySet + transparent = + Identity.transparentObjectId + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest + namespaceDigest) + relative + seed = + Identity.opaqueDeclarationSeed + owner + (localDeclarationOrdinal 2) + SignatureDeclaration + (generatedObjectSlot 0) + opaque = + Identity.opaqueObjectId + theory + seed + Core.TySet + closure <- expectRight + (Identity.validateObjectClosure + theory + [ Identity.assertedObject + intrinsic + (Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet) + ]) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal intrinsic) + (Core.CGlobal intrinsic))) + let reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + pure + IdentityFixture + { fixtureTheory = theory + , fixtureIntrinsic = intrinsic + , fixtureTransparent = transparent + , fixtureOpaqueSeed = seed + , fixtureOpaque = opaque + , fixtureClosure = closure + , fixtureProposition = proposition + , fixtureTheoremRef = reference + , fixtureTheorem = + Identity.theoremId reference + } + +hex :: ByteString.ByteString -> Text +hex = + Text.pack + . concatMap byteHex + . ByteString.unpack + where + byteHex byte = + let digits = "0123456789abcdef" + high = fromIntegral (byte `div` 16) + low = fromIntegral (byte `mod` 16) + in [digits `at` high, digits `at` low] + + at characters index = + fromMaybe + (impossible "hex digit index") + (nth index characters) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Kernel.hs b/source/Felix/Test/Unit/Kernel.hs new file mode 100644 index 0000000..7762a7e --- /dev/null +++ b/source/Felix/Test/Unit/Kernel.hs @@ -0,0 +1,858 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} + +module Felix.Test.Unit.Kernel (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp +import Felix.Checking.Typed.Inductive qualified as Inductive +import Felix.Report.Location (pattern Nowhere) +import Felix.Syntax.Internal qualified as Internal + +import Data.Set qualified as Set +import Data.Vector qualified as Vector +import Test.Tasty +import Test.Tasty.HUnit + + +data TestGlobal = TestGlobal + deriving (Show, Eq, Ord) + +testGlobalType :: TestGlobal -> CoreType +testGlobalType _global = TySet + +unitTests :: TestTree +unitTests = + testGroup "Kernel replay" + [ testCase + "replays equality reflexivity through kernel semantics" + replaysEqualityReflexivity + , testCase + "replays logical scopes and elimination" + replaysLogicalScopes + , testCase + "replays quantifier and equality structure" + replaysQuantifierAndEqualityStructure + , testCase + "records foundation and import leaves" + recordsAuthorityLeaves + , testCase + "checks and replays the exact set fixed-point rules" + checksSetLfpRules + , testCase + "replays direct inductive facts" + replaysDirectInductiveFacts + , testCase + "rejects altered set fixed-point applications" + rejectsAlteredSetLfpApplications + , testCase + "rejects invalid scoped replay" + rejectsInvalidScopedReplay + , testCase + "rejects a caller-supplied target mismatch" + rejectsTargetMismatch + ] + +replaysEqualityReflexivity :: Assertion +replaysEqualityReflexivity = do + foundation <- + expectRight Foundation.checkedFoundation + operand <- + expectRight + (checkCanonicalCore + absurd + (CIntrinsic Empty)) + direct <- + expectRight + (Semantics.equalityReflexivity + absurd + (embedClosedCore [] operand)) + directClosed <- + maybe + (assertFailure + "closed reflexivity result remained scoped") + pure + (closeScopedCore direct) + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + directClosed + (equalityReflexivityDerivation operand)) + assertEqual + "replay agrees with direct semantics" + directClosed + (replayedKernelTarget replayed) + assertEqual + "one replayed inference" + 1 + (replayedKernelNodeCount replayed) + +replaysLogicalScopes :: Assertion +replaysLogicalScopes = do + foundation <- + expectRight Foundation.checkedFoundation + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + implication <- + checkedScoped [] + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + let propositionScoped = + embedClosedCore [] proposition + identity = + implicationIntroductionDerivation + propositionScoped + (localHypothesisDerivation + (hypothesisIx 0)) + elimination = + implicationIntroductionDerivation + propositionScoped + (implicationIntroductionDerivation + implication + (implicationEliminationDerivation + (localHypothesisDerivation + (hypothesisIx 0)) + (localHypothesisDerivation + (hypothesisIx 1)))) + fromFalsum = + implicationIntroductionDerivation + falsum + (falsumEliminationDerivation + (localHypothesisDerivation + (hypothesisIx 0)) + propositionScoped) + falsum = + unsafeScoped [] CFalsum + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + identity + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (CImp + (scopedCoreTerm implication) + (frozenCoreTerm proposition))) + elimination + assertReplayTarget + foundation + (CImp + CFalsum + (frozenCoreTerm proposition)) + fromFalsum + +replaysQuantifierAndEqualityStructure :: Assertion +replaysQuantifierAndEqualityStructure = do + foundation <- + expectRight Foundation.checkedFoundation + boundSet <- + checkedScoped [TySet] (CBound 0) + emptySet <- + checkedScoped [] (CIntrinsic Empty) + unionFunction <- + checkedScoped [] (CIntrinsic FamilyUnion) + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + convertedTarget <- + checkedScoped [] + (CEq TySet + (CApp + (CLam TySet (CBound 0)) + (CIntrinsic Empty)) + (CIntrinsic Empty)) + oneReduction <- + expectRight (conversionPlan 1) + let boundReflexivity = + scopedEqualityReflexivityDerivation boundSet + universalReflexivity = + forallIntroductionDerivation + TySet + boundReflexivity + specializedReflexivity = + forallEliminationDerivation + universalReflexivity + emptySet + applicationCongruence = + equalityCongruenceApplicationDerivation + (scopedEqualityReflexivityDerivation + unionFunction) + (scopedEqualityReflexivityDerivation + emptySet) + lambdaCongruence = + equalityCongruenceLambdaDerivation + TySet + boundReflexivity + equalityMp = + implicationIntroductionDerivation + (embedClosedCore [] proposition) + (equalityModusPonensDerivation + (scopedEqualityReflexivityDerivation + (embedClosedCore [] + proposition)) + (localHypothesisDerivation + (hypothesisIx 0))) + conversion = + convertJudgmentDerivation + (scopedEqualityReflexivityDerivation + emptySet) + convertedTarget + oneReduction + assertReplayTarget + foundation + (CForall TySet + (CEq TySet + (CBound 0) + (CBound 0))) + universalReflexivity + assertReplayTarget + foundation + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + specializedReflexivity + assertReplayTarget + foundation + (CEq TySet + (CApp + (CIntrinsic FamilyUnion) + (CIntrinsic Empty)) + (CApp + (CIntrinsic FamilyUnion) + (CIntrinsic Empty))) + applicationCongruence + assertReplayTarget + foundation + (CEq + (TySet `TyArrow` TySet) + (CLam TySet (CBound 0)) + (CLam TySet (CBound 0))) + lambdaCongruence + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + equalityMp + assertReplayTarget + foundation + (scopedCoreTerm convertedTarget) + conversion + +recordsAuthorityLeaves :: Assertion +recordsAuthorityLeaves = do + foundation <- + expectRight Foundation.checkedFoundation + let foundationTag = + Foundation.EmptyCharacteristic + foundationTarget = + mapFrozenGlobals + absurd + (Foundation.foundationAxiomFrozen + foundation + foundationTag) + foundationReplay <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + foundationTarget + (foundationFactDerivation + foundationTag)) + assertEqual + "exact foundation use" + (Set.singleton foundationTag) + (replayedKernelFoundationUses + foundationReplay) + importedStatement <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + importedJudgment <- + expectRight + (derivationImportJudgment + importedStatement) + importedReplay <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + (Vector.singleton importedJudgment) + importedStatement + (importedFactDerivation + (importIx 0))) + assertEqual + "exact import use" + (Set.singleton (importIx 0)) + (replayedKernelImportUses importedReplay) + +checksSetLfpRules :: Assertion +checksSetLfpRules = do + foundation <- + expectRight Foundation.checkedFoundation + ( domain + , operator + , predicate + , element + , fixedPoint + , closedPremise + , boundedPremise + , monotonePremise + , memberPremise + , closurePremise + ) <- + setLfpFixture + bound <- + expectRight + (SetLfp.setLfpBound + foundation + absurd + domain + operator) + least <- + expectRight + (SetLfp.setLfpLeast + foundation + absurd + domain + operator + domain + closedPremise + boundedPremise) + fixed <- + expectRight + (SetLfp.setLfpFixed + foundation + absurd + domain + operator + monotonePremise) + inducted <- + expectRight + (SetLfp.setLfpInduct + foundation + absurd + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise) + expectedSubset <- + expectRight + (SetLfp.subsetProposition + absurd + fixedPoint + domain) + expectedFixed <- + checkedScoped [] + (CEq TySet + (scopedCoreTerm fixedPoint) + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm fixedPoint))) + expectedPredicate <- + checkedScoped [] + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + assertEqual "bound conclusion" expectedSubset bound + assertEqual "least conclusion" expectedSubset least + assertEqual "fixed conclusion" expectedFixed fixed + assertEqual "induction conclusion" expectedPredicate inducted + + target <- + maybe + (assertFailure + "closed fixed-point bound remained scoped") + pure + (closeScopedCore bound) + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + target + (setLfpBoundDerivation + domain + operator)) + assertEqual + "exact guarded-rule use" + (Set.singleton Foundation.SetLfpBound) + (replayedKernelRuleUses replayed) + +replaysDirectInductiveFacts :: Assertion +replaysDirectInductiveFacts = do + foundation <- + expectRight Foundation.checkedFoundation + traverse_ + (replayInductive foundation) + [ Inductive.DirectInductive + [] + (Internal.EmptySet Nowhere) + (Inductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| []) + , let x = Internal.NamedVar "x" + in Inductive.DirectInductive + [] + (Internal.EmptySet Nowhere) + ( Inductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| [ Inductive.DirectInductiveClause + [x] + [Inductive.DirectRecursiveCondition + (Internal.TermVar x) + (Inductive.directRecursiveCarrierContext Nowhere)] + (Internal.TermVar x) + ] + ) + ] + where + replayInductive foundation inductive = do + prepared <- + expectRight + (Inductive.prepareTypedInductive + testGlobalType + foundation + (const Nothing) + (Internal.Marker "direct_inductive") + inductive) + imports <- + traverse + (expectRight . derivationImportJudgment) + (Inductive.typedInductiveGuardTargets + prepared) + traverse_ + (\fact -> do + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + (const Nothing) + imports + (Inductive.typedInductiveFactTarget + fact) + (Inductive.typedInductiveFactDerivation + fact)) + assertEqual + "replay target" + (Inductive.typedInductiveFactTarget + fact) + (replayedKernelTarget replayed)) + (Inductive.typedInductiveFacts + prepared) + +rejectsAlteredSetLfpApplications :: Assertion +rejectsAlteredSetLfpApplications = do + foundation <- + expectRight Foundation.checkedFoundation + ( domain + , operator + , predicate + , _element + , _fixedPoint + , _closedPremise + , boundedPremise + , _monotonePremise + , _memberPremise + , _closurePremise + ) <- + setLfpFixture + falsum <- + checkedScoped [] CFalsum + assertEqual + "altered leastness premise" + (Left + (SetLfp.SetLfpRulePremiseMismatch + Foundation.SetLfpLeast + 0)) + (SetLfp.setLfpLeast + foundation + absurd + domain + operator + domain + falsum + boundedPremise) + assertEqual + "operator type mismatch" + (Left + (SetLfp.SetLfpRuleArgumentTypeMismatch + Foundation.SetLfpBound + 1 + (TySet `TyArrow` TySet) + (TySet `TyArrow` TyProp))) + (SetLfp.setLfpBound + foundation + absurd + domain + predicate) + bound <- + expectRight + (SetLfp.setLfpBound + foundation + absurd + domain + operator) + wrongTarget <- + checkedClosed CFalsum + assertEqual + "altered replay target" + (Left KernelReplayTargetMismatch) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + wrongTarget + (setLfpBoundDerivation + domain + operator)) + assertEqual + "the direct bound remains well formed" + TyProp + (scopedCoreType bound) + +setLfpFixture + :: IO + ( ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + ) +setLfpFixture = do + domain <- + checkedScoped [] (CIntrinsic Empty) + operator <- + checkedScoped [] + (CLam TySet (CBound 0)) + predicate <- + checkedScoped [] + (CLam TySet + (CEq TySet + (CBound 0) + (CBound 0))) + element <- + checkedScoped [] (CIntrinsic Empty) + fixedPoint <- + expectRight + (SetLfp.setLfpTerm + absurd + domain + operator) + operatorDomain <- + checkedScoped [] + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm domain)) + closedPremise <- + expectRight + (SetLfp.subsetProposition + absurd + operatorDomain + domain) + boundedPremise <- + expectRight + (SetLfp.subsetProposition + absurd + domain + domain) + monotonePremise <- + expectRight + (SetLfp.boundedMonoProposition + absurd + domain + operator) + memberPremise <- + expectRight + (SetLfp.memberProposition + absurd + element + fixedPoint) + closurePremise <- + expectRight + (SetLfp.inductionClosureProposition + absurd + domain + operator + predicate) + pure + ( domain + , operator + , predicate + , element + , fixedPoint + , closedPremise + , boundedPremise + , monotonePremise + , memberPremise + , closurePremise + ) + +rejectsInvalidScopedReplay :: Assertion +rejectsInvalidScopedReplay = do + foundation <- + expectRight Foundation.checkedFoundation + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + boundSet <- + checkedScoped [TySet] (CBound 0) + assertEqual + "missing local hypothesis" + (Left + (KernelReplayHypothesisOutOfBounds + (hypothesisIx 0))) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + proposition + (localHypothesisDerivation + (hypothesisIx 0))) + assertEqual + "stored term from another lexical context" + (Left + (KernelReplayStoredContextMismatch + [] + [TySet])) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + proposition + (scopedEqualityReflexivityDerivation + boundSet)) + expanded <- + checkedScoped [] + (CEq TySet + (CApp + (CLam TySet (CBound 0)) + (CIntrinsic Empty)) + (CIntrinsic Empty)) + noReductions <- + expectRight (conversionPlan 0) + assertEqual + "conversion budget" + (Left + (KernelReplaySemanticsError + Semantics.KernelConversionBudgetExhausted)) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + (unsafeClosed + (scopedCoreTerm expanded)) + (convertJudgmentDerivation + (equalityReflexivityDerivation + (unsafeClosed + (CIntrinsic Empty))) + expanded + noReductions)) + let checkedAsSet _global = + Just TySet + replayedAsProposition _global = + Just TyProp + globalTarget <- + expectRight + (checkCanonicalCore + checkedAsSet + (CEq TySet + (CGlobal TestGlobal) + (CGlobal TestGlobal))) + assertEqual + "stored global types are rechecked" + (Left + (KernelReplayStoredTermIllTyped + (EqualityOperandTypeMismatch + TySet + TyProp))) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + replayedAsProposition + Vector.empty + globalTarget + (equalityReflexivityDerivation + (unsafeGlobalOperand + checkedAsSet))) + oneNode <- + expectRight (kernelReplayLimits 1 10) + let propositionScoped = + embedClosedCore [] proposition + identityTarget = + unsafeClosed + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + assertEqual + "replay node limit" + (Left + (KernelReplayNodeLimitExceeded 1)) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + oneNode + absurd + Vector.empty + identityTarget + (implicationIntroductionDerivation + propositionScoped + (localHypothesisDerivation + (hypothesisIx 0)))) + +rejectsTargetMismatch :: Assertion +rejectsTargetMismatch = do + foundation <- + expectRight Foundation.checkedFoundation + operand <- + expectRight + (checkCanonicalCore + absurd + (CIntrinsic Empty)) + wrongTarget <- + expectRight + (checkCanonicalCore + absurd + (CImp CFalsum CFalsum)) + assertEqual + "the expected target is comparison input, not evidence" + (Left KernelReplayTargetMismatch) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + wrongTarget + (equalityReflexivityDerivation operand)) + +assertReplayTarget + :: Foundation.CheckedFoundation + -> CanonicalTerm Void + -> KernelDerivation Void + -> Assertion +assertReplayTarget foundation expectedTerm derivation = do + expected <- + checkedClosed expectedTerm + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + expected + derivation) + assertEqual + "replayed exact target" + expected + (replayedKernelTarget replayed) + +checkedClosed + :: CanonicalTerm Void + -> IO (FrozenCheckedCore Void) +checkedClosed = + expectRight . checkCanonicalCore absurd + +checkedScoped + :: [CoreType] + -> CanonicalTerm Void + -> IO (ScopedCheckedCore Void) +checkedScoped context = + expectRight + . checkScopedCanonicalCore absurd context + +unsafeScoped + :: [CoreType] + -> CanonicalTerm Void + -> ScopedCheckedCore Void +unsafeScoped context term = + case checkScopedCanonicalCore absurd context term of + Left coreError -> + impossible + ("invalid static kernel fixture: " + <> show coreError) + Right checked -> + checked + +unsafeClosed + :: CanonicalTerm Void + -> FrozenCheckedCore Void +unsafeClosed term = + case checkCanonicalCore absurd term of + Left coreError -> + impossible + ("invalid static closed kernel fixture: " + <> show coreError) + Right checked -> + checked + +unsafeGlobalOperand + :: (TestGlobal -> Maybe CoreType) + -> FrozenCheckedCore TestGlobal +unsafeGlobalOperand globalType = + case checkCanonicalCore + globalType + (CGlobal TestGlobal) of + Left coreError -> + impossible + ("invalid static global kernel fixture: " + <> show coreError) + Right checked -> + checked + +expectRight + :: Show error + => Either error value + -> IO value +expectRight = + either + (assertFailure . show) + pure diff --git a/source/Felix/Test/Unit/Lexicon.hs b/source/Felix/Test/Unit/Lexicon.hs new file mode 100644 index 0000000..4b7f9e7 --- /dev/null +++ b/source/Felix/Test/Unit/Lexicon.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Lexicon (unitTests) where + +import Base +import Felix.Cache.Codec +import Felix.Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon + +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Lexicon" + [ testCase "retains the literal ten-row base mixfix grouping" + retainsBaseMixfixGrouping + , testCase "checks literal mixfix levels" + checksMixfixLevels + , testCase "coalesces equal canonical syntax entries" + coalescesCanonicalEntries + , testCase "rejects shared plural parser surfaces" + rejectsSharedPluralSurfaces + , testCase "round-trips complete canonical lexical entries" + roundTripsCanonicalEntries + , testCase "round-trips asserted module syntax interfaces" + roundTripsSyntaxInterfaces + ] + +retainsBaseMixfixGrouping :: Assertion +retainsBaseMixfixGrouping = + do + assertEqual + "least-to-most-tight marker and associativity rows" + expectedBaseRows + (fmap (fmap entryShape) builtinMixfixLevels) + assertEqual + "canonical base manifest" + expectedBaseRows + (fmap (fmap canonicalEntryShape) baseSyntaxManifest) + assertEqual + "cache-epoch base syntax identity" + "97acdc8153821b20dd0f45cf9d44870705723bb60737f7bacbb9ac31a98987a5" + (cacheDigestHex + (baseSyntaxInterfaceIdDigest + baseSyntaxInterfaceId)) + where + entryShape (MixfixItem _pattern marker associativity) = + (marker, associativity) + + canonicalEntryShape = \case + CanonicalExpressionFunction + _pattern + marker + (Fixity associativity _level) -> + (marker, associativity) + entry -> + impossible + ("non-expression entry in base manifest: " + <> show entry) + +checksMixfixLevels :: Assertion +checksMixfixLevels = do + assertEqual + "lowest level" + (Right 0) + (mixfixLevelValue <$> mixfixLevel 0) + assertEqual + "highest internal level" + (Right 9) + (mixfixLevelValue <$> mixfixLevel 9) + assertEqual + "out-of-range level" + (Left (MixfixLevelOutOfRange 10)) + (mixfixLevel 10) + +coalescesCanonicalEntries :: Assertion +coalescesCanonicalEntries = do + level <- expectRight (mixfixLevel 3) + let pat = + patternFromHoley + [ Nothing + , Just (Command "star") + , Nothing + ] + first = + CanonicalExpressionFunction + pat + "star" + (Fixity LeftAssoc level) + conflicting = + CanonicalExpressionFunction + pat + "other_star" + (Fixity LeftAssoc level) + delta <- expectRight + (canonicalSyntaxDelta [first, first]) + assertEqual + "equal entries coalesce" + 1 + (canonicalSyntaxDeltaSize delta) + assertEqual + "coalesced entry" + [first] + (canonicalSyntaxDeltaEntries delta) + assertEqual + "collision is independent of occurrence order" + (canonicalSyntaxDelta [first, conflicting]) + (canonicalSyntaxDelta [conflicting, first]) + +rejectsSharedPluralSurfaces :: Assertion +rejectsSharedPluralSurfaces = do + let nounEntry = + CanonicalNoun + (wordPattern "member") + (wordPattern "objects") + "member" + otherNoun = + CanonicalNoun + (wordPattern "element") + (wordPattern "objects") + "element" + verbEntry = + CanonicalVerb + (wordPattern "belongs") + (wordPattern "objects") + "belongs" + assertPluralCollision nounEntry otherNoun + assertPluralCollision nounEntry verbEntry + case decodeCache + getCanonicalSyntaxDeltaCache + (encodeCache + (putCacheList + putCanonicalLexicalEntryCache + [nounEntry, otherNoun])) of + Left _ -> + pure () + Right _ -> + assertFailure + "decoded a delta with a shared plural collision" + where + wordPattern word = + TokenCons (Word word) End + + assertPluralCollision first second = + case canonicalSyntaxDelta [first, second] of + Left collision -> do + assertEqual + "shared plural pattern" + (wordPattern "objects") + (canonicalCollisionPattern collision) + assertEqual + "both complete entries" + (Set.fromList [first, second]) + (Set.fromList + (toList + (canonicalCollisionEntries collision))) + Right _ -> + assertFailure + "accepted two entries with one parser-active plural" + +roundTripsCanonicalEntries :: Assertion +roundTripsCanonicalEntries = do + level <- expectRight (mixfixLevel 4) + let unary = + patternFromHoley + [ Just (Word "red") + , Nothing + ] + singular = + patternFromHoley + [ Just (Word "member") + , Just (Word "of") + , Nothing + ] + plural = + patternFromHoley + [ Just (Word "members") + , Just (Word "of") + , Nothing + ] + binary = + patternFromHoley + [ Nothing + , Just (Command "star") + , Nothing + ] + entries = + [ CanonicalLeftAdjective unary "red" + , CanonicalRightAdjective unary "red_right" + , CanonicalFunctionPhrase singular plural "member_fun" + , CanonicalNoun singular plural "member" + , CanonicalStructureNoun singular plural "member_struct" + , CanonicalVerb singular plural "member_verb" + , CanonicalRelation (Command "rel") (ParameterArity 2) "rel" + , CanonicalExpressionFunction + binary + "star" + (Fixity LeftAssoc level) + , CanonicalPrefixPredicate "Pred" 3 "pred" + , CanonicalStructureOperation "operation" + ] + traverse_ + (\entry -> + assertEqual + ("cache round trip for " <> show entry) + (Right entry) + (decodeCache + getCanonicalLexicalEntryCache + (encodeCache + (putCanonicalLexicalEntryCache entry)))) + entries + +roundTripsSyntaxInterfaces :: Assertion +roundTripsSyntaxInterfaces = do + level <- expectRight (mixfixLevel 7) + changedLevel <- expectRight (mixfixLevel 6) + let entry = + CanonicalExpressionFunction + (patternFromHoley + [ Nothing + , Just (Command "diamond") + , Nothing + ]) + "diamond" + (Fixity NonAssoc level) + changedEntry = + CanonicalExpressionFunction + (patternFromHoley + [ Nothing + , Just (Command "diamond") + , Nothing + ]) + "diamond" + (Fixity RightAssoc changedLevel) + delta <- expectRight (canonicalSyntaxDelta [entry]) + changedDelta <- expectRight + (canonicalSyntaxDelta [changedEntry]) + interface <- expectRight + (moduleSyntaxInterface [] delta) + changedInterface <- expectRight + (moduleSyntaxInterface [] changedDelta) + assertEqual + "current fixed base" + baseSyntaxInterfaceId + (moduleSyntaxBase interface) + assertEqual + "module syntax cache round trip" + (Right interface) + (decodeCache + getModuleSyntaxInterfaceCache + (encodeCache + (putModuleSyntaxInterfaceCache interface))) + assertEqual + "asserted ID is deterministic" + (Right (moduleSyntaxAssertedId interface)) + (moduleSyntaxAssertedId + <$> moduleSyntaxInterface [] delta) + assertBool + "normalized fixity changes syntax identity" + (moduleSyntaxAssertedId interface + /= moduleSyntaxAssertedId changedInterface) + case moduleSyntaxInterface + [ moduleSyntaxAssertedId interface + , moduleSyntaxAssertedId interface + ] + delta of + Left (DuplicateDirectSyntaxInterface duplicate) -> + assertEqual + "duplicate direct interface" + (moduleSyntaxAssertedId interface) + duplicate + Left err -> + assertFailure + ("expected duplicate direct syntax input, got " + <> show err) + Right _ -> + assertFailure + "accepted a duplicate direct syntax input" + +expectRight :: Show err => Either err value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) + >> fail "unreachable" + Right value -> + pure value + +expectedBaseRows :: [[(Marker, Associativity)]] +expectedBaseRows = + [ [] + , [ ("add", LeftAssoc) + , ("union", LeftAssoc) + , ("minus", LeftAssoc) + , ("rminus", LeftAssoc) + , ("monus", LeftAssoc) + ] + , [("relcomp", LeftAssoc)] + , [("circ", LeftAssoc)] + , [ ("mul", LeftAssoc) + , ("inter", LeftAssoc) + , ("rmul", LeftAssoc) + ] + , [("setminus", LeftAssoc)] + , [("times", RightAssoc)] + , [] + , [ ("rfrac", NonAssoc) + , ("exp", NonAssoc) + , ("unions", NonAssoc) + , ("cumul", NonAssoc) + , ("fst", NonAssoc) + , ("snd", NonAssoc) + , ("pow", NonAssoc) + , ("neg", NonAssoc) + , ("inv", NonAssoc) + , ("abs", NonAssoc) + , ("cons", NonAssoc) + , ("pair", NonAssoc) + , ("upair", NonAssoc) + ] + , [ ("emptyset", NonAssoc) + , ("naturals", NonAssoc) + , ("naturalsPlus", NonAssoc) + , ("integers", NonAssoc) + , ("rationals", NonAssoc) + , ("reals", NonAssoc) + , ("unit", NonAssoc) + , ("zero", NonAssoc) + ] + ] diff --git a/source/Felix/Test/Unit/Materialization.hs b/source/Felix/Test/Unit/Materialization.hs new file mode 100644 index 0000000..9c4f54f --- /dev/null +++ b/source/Felix/Test/Unit/Materialization.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Materialization (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic qualified as Semantic +import Felix.Math.Codec +import Felix.Module +import Felix.Source + +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Validation applicability" + [ testCase "keeps serializable candidate validation inert" + keepsCandidateValidationInert + , testCase "rejects inexact candidate validation" + rejectsInexactCandidateValidation + , testCase "rejects mismatched candidate fields" + rejectsMismatchedCandidateFields + , testCase "selects ordered declaration certificates" + selectsDeclarationCertificate + , testCase "keeps raw interface membership inert" + keepsImportedMembershipInert + ] + +keepsCandidateValidationInert :: Assertion +keepsCandidateValidationInert = do + fixture <- makeFixture + let check = + Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + (fixtureProofValidation fixture) + assertEqual + "freely constructed records yield only inert applicability" + (Right ()) + check + assertEqual + "inert applicability data is reusable" + (Right ()) + check + +rejectsInexactCandidateValidation :: Assertion +rejectsInexactCandidateValidation = do + fixture <- makeFixture + let wrongKey = + Semantic.proofValidationKey + (Identity.theoremId + (fixtureReference fixture)) + (Semantic.proofSyntaxId "other-proof") + (fixturePrefix fixture) + wrongValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + wrongKey + (fixtureCertificate fixture)) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + wrongValidation of + Left Materialization.ProofValidationKeyMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected validation-key error: " <> show other) + Right _ -> + assertFailure "inexact proof validation key succeeded" + +rejectsMismatchedCandidateFields :: Assertion +rejectsMismatchedCandidateFields = do + fixture <- makeFixture + let sourceAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceAuthority + Authority.SourceAxiomAuthorization) + let key = + Semantic.proofValidationKey + (Identity.theoremId (fixtureReference fixture)) + (Semantic.proofSyntaxId "proof") + (fixturePrefix fixture) + sourceValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key + sourceCertificate) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + sourceValidation of + Left Materialization.CandidateCertificateTargetMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected target mismatch: " <> show other) + Right _ -> + assertFailure "mismatched safety was accepted" + differentDirect <- expectRight + (Authority.validationCertificate + (fixtureAuthority fixture) + (Authority.CheckedSourceProof + [Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "different-request"])) + let directValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key + differentDirect) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + directValidation of + Left Materialization.CandidateDirectAuthorizationMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected direct-authorization mismatch: " + <> show other) + Right _ -> + assertFailure "mismatched request list was accepted" + closure <- expectRight + (Identity.validateObjectClosure + (fixtureTheory fixture) + []) + otherProposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CImp Core.CFalsum Core.CFalsum)) + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + otherProposition + (fixtureAuthority fixture) + (fixtureDirect fixture) + (fixtureProofValidation fixture) of + Left Materialization.CandidatePropositionMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected proposition mismatch: " <> show other) + Right _ -> + assertFailure "mismatched proposition content was accepted" + +selectsDeclarationCertificate :: Assertion +selectsDeclarationCertificate = do + fixture <- makeFixture + let sourceAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceAuthority + Authority.SourceAxiomAuthorization) + let syntax = + Semantic.declarationSyntaxId "declaration" + producedTheorems = + [ Identity.theoremId + (fixtureReference fixture) + , Identity.theoremId + (fixtureReference fixture) + ] + key = + Semantic.declarationValidationKey + syntax + (fixturePrefix fixture) + [] + producedTheorems + validation = + Materialization.candidateDeclarationValidation + (Semantic.declarationValidationRecord + key + [sourceCertificate, fixtureCertificate fixture]) + syntax [] + producedTheorems + 1 + assertEqual + "candidate ordinal selects the second certificate" + (Right ()) + (Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + validation) + +keepsImportedMembershipInert :: Assertion +keepsImportedMembershipInert = do + fixture <- makeFixture + occurrence <- expectRight + (Materialization.checkImportedMembership + (fixtureTheory fixture) + (fixtureInterface fixture) + (fixtureFingerprint fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture)) + assertEqual + "raw interface yields only its inert occurrence" + (fixtureAuthority fixture) + (Semantic.semanticFactAuthority occurrence) + let wrongAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.Omitted)) + case Materialization.checkImportedMembership + (fixtureTheory fixture) + (fixtureInterface fixture) + (fixtureFingerprint fixture) + (fixtureProposition fixture) + wrongAuthority of + Left Materialization.ImportedAuthorityMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected imported-authority error: " <> show other) + Right _ -> + assertFailure "imported authority mismatch succeeded" + + +data Fixture = Fixture + { fixtureTheory :: !Identity.TheoryId + , fixtureReference :: !Identity.TheoremRef + , fixtureProposition :: !Identity.CheckedPropositionContent + , fixtureAuthority :: !Authority.FactAuthority + , fixtureDirect :: !Authority.DirectAuthorization + , fixtureCertificate :: !Authority.ValidationCertificate + , fixtureFingerprint + :: !Semantic.SemanticFactOccurrenceFingerprint + , fixtureInterface :: !Semantic.SemanticInterface + , fixturePrefix :: !Semantic.PrefixContextId + , fixtureProofValidation + :: !Materialization.CandidateValidation + } + +makeFixture :: IO Fixture +makeFixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "materialization-test-namespace" + ["root"]) + relative <- expectRight (safeRelativePath "producer.tex") + let theory = + Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + closure <- expectRight + (Identity.validateObjectClosure theory []) + proposition <- expectRight + (Identity.validatePropositionContent + closure Core.CFalsum) + let reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + authority = + Authority.factAuthority + reference + Authority.cleanAuthoritySafety + direct = + Authority.CheckedSourceProof [] + slot = + Semantic.factSlot owner (localFactOrdinal 0) + fingerprint = + Semantic.semanticFactOccurrenceFingerprint + slot authority + occurrence = + Semantic.semanticFactOccurrence + slot + authority + Semantic.SearchEligible + declaration = + Semantic.declarationSlot + owner + (localDeclarationOrdinal 0) + certificate <- expectRight + (Authority.validationCertificate authority direct) + delta <- expectRight + (Semantic.declarationInterfaceDelta + declaration + [occurrence] + [] + [] + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + interface <- expectRight + (Semantic.semanticInterface owner [] [delta]) + prefix <- expectRight + (Semantic.initialPrefixContextId theory owner []) + let syntax = + Semantic.proofSyntaxId "proof" + key = + Semantic.proofValidationKey + (Identity.theoremId reference) + syntax prefix + pure + Fixture + { fixtureTheory = theory + , fixtureReference = reference + , fixtureProposition = proposition + , fixtureAuthority = authority + , fixtureDirect = direct + , fixtureCertificate = certificate + , fixtureFingerprint = fingerprint + , fixtureInterface = interface + , fixturePrefix = prefix + , fixtureProofValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key certificate) + syntax + } + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Meaning.hs b/source/Felix/Test/Unit/Meaning.hs new file mode 100644 index 0000000..3093a84 --- /dev/null +++ b/source/Felix/Test/Unit/Meaning.hs @@ -0,0 +1,1119 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Meaning (unitTests) where + +import Base +import Felix.Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Sem +import Felix.Syntax.LexicalPhrase + ( unsafeReadPhrase + , unsafeReadPhraseSgPl + ) + +import Bound (instantiate) +import Control.Monad.Except (runExceptT) +import Control.Monad.State (evalState, gets) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = + testGroup "Meaning" + [ testCase "relation applications reject missing and extra parameters" do + for_ [(0, Raw.ParameterArity 0), (2, Raw.ParameterArity 2)] + \(actualCount, actualArity) -> + case meaning [relationClaim actualCount] of + Left + (GlossRelationApplicationError + (Sem.RelationParameterArityMismatch + actualLocation + actualSymbol + expectedArity + reportedActualArity)) -> do + assertEqual + "relation location" + relationLocation + actualLocation + assertEqual + "relation symbol" + relationSymbol + actualSymbol + assertEqual + "expected parameter arity" + (Raw.ParameterArity 1) + expectedArity + assertEqual + "actual parameter arity" + actualArity + reportedActualArity + Left err -> + assertFailure + ("expected a relation arity error, got " + <> show err) + Right _ -> + assertFailure + "expected relation arity validation to fail" + , testCase + "dependent replacement domains report their occurrences" + dependentReplacementDomains + , testCase + "replacement domains remain outside own and future binders" + independentReplacementDomains + , testCase + "functional definitions reject quantified terms with source context" + quantifiedFunctionalDefinition + , testCase + "unsupported source constructs return located errors" + unsupportedSourceConstructs + , testCase + "proof-local function definitions reject mismatched heads" + proofLocalFunctionDefinitionMismatches + , testCase + "abbreviations reject duplicate parameters with source context" + duplicateAbbreviationParameters + , testCase + "abbreviations reject named free body variables" + freeAbbreviationBodyVariable + , testCase + "abbreviation parameters retain positional slots" + orderedAbbreviationParameters + , testCase + "quantified noun binders resolve their whole scope" + quantifiedNounBinderScope + , testCase + "quantified noun binders obey lexical scope" + quantifiedNounLexicalScope + , testCase + "resolved binder adaptation is injective and ignores trivia" + resolvedBinderAdapter + ] + +dependentReplacementDomains :: Assertion +dependentReplacementDomains = + for_ cases \(label, replacement, expectedLocation) -> + assertEqual + label + (Left + (DependentReplacementDomainNotSupported + expectedLocation)) + (glossTestExpr replacement) + where + cases = + [ ( "two-domain replacement" + , replacementExpr + (Raw.ExprVar y) + ( (x, rawInteger 1) + :| [(y, rawVarAt twoXLocation "x")] + ) + , twoXLocation + ) + , ( "three-domain replacement reports its first dependent occurrence" + , replacementExpr + (Raw.ExprVar z) + ( (x, rawInteger 1) + :| [ (y, rawInteger 2) + , (z, Raw.ExprOp + Nowhere + (testFunctionSymbol "dependent_domain" 2) + [ rawVarAt threeYLocation "y" + , rawVarAt threeXLocation "x" + ]) + ] + ) + , threeYLocation + ) + ] + x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + twoXLocation = mkLocation replacementFile 3 17 + threeYLocation = mkLocation replacementFile 4 29 + threeXLocation = mkLocation replacementFile 4 32 + +independentReplacementDomains :: Assertion +independentReplacementDomains = + case glossTestExpr replacement of + Right + (Sem.ReplaceFun + ( (actualX, Sem.TermVar actualOwnX) + :| [ (actualY, Sem.TermVar actualFutureZ) + , ( actualZ + , Sem.TermSymbol + _thirdDomainLocation + (Sem.SymbolInteger 3) + [] + ) + ] + ) + valueScope + conditionScope) -> do + assertEqual + "replacement binder order" + [x, y, z] + [actualX, actualY, actualZ] + assertEqual + "own-domain occurrence remains free" + ownXLocation + (locate actualOwnX) + assertEqual + "future-binder occurrence remains free" + futureZLocation + (locate actualFutureZ) + assertEqual + "replacement value lowering" + expectedValue + (instantiate instantiateBinder valueScope) + assertEqual + "default replacement condition" + Sem.Top + (instantiate instantiateBinder conditionScope) + Right expr -> + assertFailure + ("expected an independent functional replacement, got " + <> show expr) + Left err -> + assertFailure + ("expected independent replacement domains to succeed, got " + <> show err) + where + replacement = + replacementExpr + ( Raw.ExprOp + replacementValueLocation + replacementValueSymbol + [ rawVarAt replacementValueLocation "x" + , rawVarAt replacementValueLocation "y" + , rawVarAt replacementValueLocation "z" + ] + ) + ( (x, rawVarAt ownXLocation "x") + :| [ (y, rawVarAt futureZLocation "z") + , (z, rawInteger 3) + ] + ) + x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + ownXLocation = mkLocation replacementFile 6 7 + futureZLocation = mkLocation replacementFile 6 16 + replacementValueLocation = mkLocation replacementFile 6 29 + replacementValueSymbol = testFunctionSymbol "replacement_value" 3 + expectedValue = + Sem.TermSymbol + replacementValueLocation + (Sem.SymbolMixfix replacementValueSymbol) + [ closedInteger 11 + , closedInteger 22 + , closedInteger 33 + ] + instantiateBinder binder + | binder == x = closedInteger 11 + | binder == y = closedInteger 22 + | binder == z = closedInteger 33 + | otherwise = closedInteger (-1) + +replacementExpr + :: Raw.Expr + -> NonEmpty (Raw.VarSymbol, Raw.Expr) + -> Raw.Expr +replacementExpr value bounds = + Raw.ExprReplace replacementLocation value bounds Nothing + +rawVarAt :: Location -> Text -> Raw.Expr +rawVarAt location name = + Raw.ExprVar (Raw.NamedVarAt location name) + +rawInteger :: Int -> Raw.Expr +rawInteger = + Raw.ExprInteger Nowhere + +glossTestExpr :: Raw.Expr -> Either GlossError Sem.Expr +glossTestExpr expr = + evalState + (runExceptT (glossExpr expr)) + initialGlossState + +glossTestStmt :: Raw.Stmt -> Either GlossError Sem.Formula +glossTestStmt statement = + evalState + (runExceptT (glossStmt statement)) + initialGlossState + +unsupportedSourceConstructs :: Assertion +unsupportedSourceConstructs = do + assertEqual + "definite-description term" + (Left (IotaTermNotSupported iotaLocation)) + (runGlossUnit (glossH0Term [] iotaTerm)) + assertEqual + "definite-function assumption" + (Left + (DefiniteFunctionAssumptionNotSupported + definiteFunctionLocation)) + (runGlossUnit (glossAsm definiteFunctionAssumption)) + where + iotaTerm = + Raw.TermIota + iotaLocation + (Raw.NamedVarAt iotaLocation "x") + (Raw.StmtFormula + (Raw.PropositionalConstant iotaLocation Raw.IsTop)) + definiteFunctionAssumption = + Raw.AsmLetThe + (Raw.NamedVarAt definiteFunctionLocation "f") + (Raw.Fun + definiteFunctionLocation + (Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "function[/s]") + "function") + []) + +runGlossUnit :: Gloss a -> Either GlossError () +runGlossUnit action = + void + (evalState + (runExceptT action) + initialGlossState) + +quantifiedNounBinderScope :: Assertion +quantifiedNounBinderScope = do + case glossTestStmt (namedSetEquality "x") of + Right formula@(Sem.Quantified Sem.Universally scope) -> do + assertEqual + "the written binder does not remain free" + Set.empty + (Sem.freeVars formula) + assertEqual + "the continuation uses the quantified witness" + (Sem.Top + `Sem.Implies` + Sem.Equals + equalityLocation + witness + witness) + (instantiate (const witness) scope) + Right formula -> + assertFailure + ("expected a universal named binder, got " <> show formula) + Left err -> + assertFailure + ("expected the named binder to gloss, got " <> show err) + + case glossTestStmt constrainedNamedBinder of + Right formula@(Sem.Quantified Sem.Universally scope) -> do + assertEqual + "only the ambient noun argument remains free" + (Set.singleton ambientVariable) + (Sem.freeVars formula) + assertEqual + "noun, modifier, such-that, and continuation share the binder" + expectedConstrainedBody + (instantiate (const witness) scope) + Right formula -> + assertFailure + ("expected a constrained universal binder, got " + <> show formula) + Left err -> + assertFailure + ("expected the constrained binder to gloss, got " + <> show err) + where + witness = closedInteger 17 + ambientVariable = + Raw.NamedVarAt ambientLocation "T" + nounConstraint = + Sem.FormulaNoun + nounLocation + witness + subsetNounPattern + [Sem.TermVar ambientVariable] + modifierConstraint = + Sem.FormulaAdj + modifierLocation + witness + modifierPattern + [witness] + suchThatConstraint = + Sem.Equals suchThatLocation witness witness + continuation = + Sem.Equals equalityLocation witness witness + expectedConstrainedBody = + Sem.makeConjunction + [ suchThatConstraint + , Sem.makeConjunction + [nounConstraint, modifierConstraint] + ] + `Sem.Implies` continuation + +quantifiedNounLexicalScope :: Assertion +quantifiedNounLexicalScope = do + assertEqual + "alpha-renaming a referenced binder" + (glossTestStmt (namedSetEquality "x")) + (glossTestStmt (namedSetEquality "renamed")) + assertEqual + "a vacuous written name is semantic trivia" + (glossTestStmt (vacuousSetStatement Nothing)) + (glossTestStmt + (vacuousSetStatement + (Just + (Raw.NamedVarAt binderLocation "unused")))) + + assertEqual + "overlapping sibling names are rejected" + (Left + (DuplicateQuantifiedNounBinder + firstSiblingLocation + secondSiblingLocation + "same")) + (glossTestStmt duplicateSiblingStatement) + + case glossTestStmt nestedShadowingStatement of + Right (Sem.Quantified Sem.Universally outerScope) -> + case instantiate (const outerWitness) outerScope of + Sem.Top + `Sem.Implies` + Sem.Quantified Sem.Existentially innerScope -> + assertEqual + "the nearest binder owns the nested occurrences" + expectedInnerBody + (instantiate + (const innerWitness) + innerScope) + body -> + assertFailure + ("expected a nested existential binder, got " + <> show body) + Right formula -> + assertFailure + ("expected an outer universal binder, got " <> show formula) + Left err -> + assertFailure + ("expected nested shadowing to gloss, got " <> show err) + where + outerWitness = closedInteger 23 + innerWitness = closedInteger 29 + expectedInnerBody = + Sem.makeConjunction + [ Sem.Equals + nestedSuchThatLocation + innerWitness + innerWitness + , Sem.Top + ] + `Sem.And` + Sem.Equals + nestedEqualityLocation + outerWitness + innerWitness + +resolvedBinderAdapter :: Assertion +resolvedBinderAdapter = do + case ( binderAdapterObservation + ("first", firstAdapterLocation) + ("second", secondAdapterLocation) + , binderAdapterObservation + ("alpha", alternateFirstLocation) + ("beta", alternateSecondLocation) + ) of + ( Right (firstId :| [secondId], firstTokens, firstResult) + , Right (alternateIds, alternateTokens, alternateResult) + ) -> do + assertBool + "pre-adapter local identities are distinct" + (firstId /= secondId) + case + ( Map.lookup firstId firstTokens + , Map.lookup secondId firstTokens + ) of + (Just firstToken, Just secondToken) -> do + assertBool + "legacy tokens are injective" + (firstToken /= secondToken) + assertBool + "legacy tokens avoid ambient variables" + ( firstToken /= adapterAmbientVariable + && secondToken + /= adapterAmbientVariable + ) + tokens -> + assertFailure + ("expected two adapter assignments, got " + <> show tokens) + assertEqual + "trivia does not affect local identities" + (firstId :| [secondId]) + alternateIds + assertEqual + "trivia does not affect adapter assignments" + firstTokens + alternateTokens + assertEqual + "trivia does not affect the alpha-normal result" + firstResult + alternateResult + assertEqual + "ambient references pass through unchanged" + (Set.singleton adapterAmbientVariable) + (Sem.freeVars firstResult) + (firstResult, secondResult) -> + assertFailure + ("expected successful adapter observations, got " + <> show (firstResult, secondResult)) + + assertEqual + "an unadapted local reference is a located typed error" + (Left + (GlossResolvedBinderAdapterError + firstAdapterLocation + (UnknownResolvedLocal (LocalId 0)))) + ( evalState + (runExceptT + do + binder <- + freshH0Binder + firstAdapterLocation + (Just + (Raw.NamedVarAt + firstAdapterLocation + "unadapted")) + lowerH0Expr + (Sem.TermVar + (LocalRef (h0BinderId binder)))) + initialGlossState + ) + +binderAdapterObservation + :: (Text, Location) + -> (Text, Location) + -> Either + GlossError + ( NonEmpty LocalId + , Map LocalId Sem.VarSymbol + , Sem.Expr + ) +binderAdapterObservation + (firstName, firstLocation) + (secondName, secondLocation) = + evalState + (runExceptT do + firstBinder <- + freshH0Binder + firstLocation + (Just + (Raw.NamedVarAt firstLocation firstName)) + secondBinder <- + freshH0Binder + secondLocation + (Just + (Raw.NamedVarAt secondLocation secondName)) + let firstId = h0BinderId firstBinder + secondId = h0BinderId secondBinder + resolvedBody = + Sem.TermSymbol + Nowhere + (Sem.SymbolMixfix adapterBodySymbol) + [ Sem.TermVar (LocalRef firstId) + , Sem.TermVar (LocalRef secondId) + , Sem.TermVar + (AmbientRef adapterAmbientVariable) + ] + quantifiedTerms = + [ H0QuantifiedTerm + Raw.Universally + firstBinder + [] + , H0QuantifiedTerm + Raw.Existentially + secondBinder + [] + ] + adapted <- + applyH0Quantifiers quantifiedTerms resolvedBody + >>= lowerH0Expr + assignments <- gets legacyLocalTokens + pure + ( firstId :| [secondId] + , assignments + , adapted + )) + initialGlossState + +namedSetEquality :: Text -> Raw.Stmt +namedSetEquality name = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + binderLocation + (Just + (Raw.NamedVarAt binderLocation name)) + [] + Nothing + :| [] + ) + (equalityVerbPhrase + equalityLocation + (rawTermVar equalityLocation name)) + +constrainedNamedBinder :: Raw.Stmt +constrainedNamedBinder = + Raw.StmtVerbPhrase + ( Raw.TermQuantified + Raw.Universally + binderLocation + ( Raw.NounPhrase + [ Raw.AdjL + modifierLocation + modifierPattern + [rawTermVar modifierLocation "x"] + ] + ( Raw.Noun + nounLocation + subsetNounPattern + [rawTermVar ambientLocation "T"] + ) + (Just + (Raw.NamedVarAt binderLocation "x")) + [] + (Just + (equalityStatement + suchThatLocation + "x" + "x")) + ) + :| [] + ) + (equalityVerbPhrase + equalityLocation + (rawTermVar equalityLocation "x")) + +vacuousSetStatement :: Maybe Raw.VarSymbol -> Raw.Stmt +vacuousSetStatement mayName = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + binderLocation + mayName + [] + Nothing + :| [] + ) + ( Raw.VPAdj + ( Raw.Adj + reflexiveLocation + reflexivePattern + [] + :| [] + ) + ) + +duplicateSiblingStatement :: Raw.Stmt +duplicateSiblingStatement = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + firstSiblingLocation + (Just + (Raw.NamedVarAt firstSiblingLocation "same")) + [] + Nothing + :| [ quantifiedSetTerm + Raw.Existentially + secondSiblingLocation + (Just + (Raw.NamedVarAt secondSiblingLocation "same")) + [] + Nothing + ] + ) + ( Raw.VPAdj + ( Raw.Adj + reflexiveLocation + reflexivePattern + [] + :| [] + ) + ) + +nestedShadowingStatement :: Raw.Stmt +nestedShadowingStatement = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + outerBinderLocation + (Just + (Raw.NamedVarAt outerBinderLocation "shadow")) + [] + Nothing + :| [] + ) + ( equalityVerbPhrase + nestedEqualityLocation + ( Raw.TermQuantified + Raw.Existentially + innerBinderLocation + ( Raw.NounPhrase + [] + (setNoun innerBinderLocation) + (Just + (Raw.NamedVarAt + innerBinderLocation + "shadow")) + [] + (Just + (equalityStatement + nestedSuchThatLocation + "shadow" + "shadow")) + ) + ) + ) + +quantifiedSetTerm + :: Raw.Quantifier + -> Location + -> Maybe Raw.VarSymbol + -> [Raw.AdjL] + -> Maybe Raw.Stmt + -> Raw.Term +quantifiedSetTerm quantifier location mayName leftAdjectives maySuchThat = + Raw.TermQuantified + quantifier + location + ( Raw.NounPhrase + leftAdjectives + (setNoun location) + mayName + [] + maySuchThat + ) + +setNoun :: Location -> Raw.Noun +setNoun location = + Raw.Noun location setNounPattern [] + +rawTermVar :: Location -> Text -> Raw.Term +rawTermVar location name = + Raw.TermExpr (rawVarAt location name) + +equalityStatement :: Location -> Text -> Text -> Raw.Stmt +equalityStatement location leftName rightName = + Raw.StmtVerbPhrase + (rawTermVar location leftName :| []) + (equalityVerbPhrase + location + (rawTermVar location rightName)) + +equalityVerbPhrase :: Location -> Raw.Term -> Raw.VerbPhrase +equalityVerbPhrase location argument = + Raw.VPAdj + ( Raw.Adj + location + equalityPattern + [argument] + :| [] + ) + +setNounPattern :: Raw.LexicalItemSgPl +setNounPattern = + Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "set[/s]") + "set" + +subsetNounPattern :: Raw.LexicalItemSgPl +subsetNounPattern = + Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "subset[/s] of ?") + "test_subset" + +modifierPattern :: Raw.LexicalItem +modifierPattern = + Raw.mkLexicalItem + (unsafeReadPhrase "related to ?") + "test_modifier" + +equalityPattern :: Raw.LexicalItem +equalityPattern = + Raw.mkLexicalItem + (unsafeReadPhrase "equal to ?") + "eq" + +reflexivePattern :: Raw.LexicalItem +reflexivePattern = + Raw.mkLexicalItem + (unsafeReadPhrase "reflexive") + "test_reflexive" + +adapterBodySymbol :: Raw.FunctionSymbol +adapterBodySymbol = + testFunctionSymbol "adapter_body" 3 + +adapterAmbientVariable :: Sem.VarSymbol +adapterAmbientVariable = + Sem.FreshVar 0 + +binderLocation, equalityLocation, nounLocation, ambientLocation :: Location +binderLocation = mkLocation (FileId 48) 2 7 +equalityLocation = mkLocation (FileId 48) 2 24 +nounLocation = mkLocation (FileId 48) 3 7 +ambientLocation = mkLocation (FileId 48) 3 20 + +modifierLocation, suchThatLocation, reflexiveLocation :: Location +modifierLocation = mkLocation (FileId 48) 3 27 +suchThatLocation = mkLocation (FileId 48) 3 42 +reflexiveLocation = mkLocation (FileId 48) 4 17 + +firstSiblingLocation, secondSiblingLocation :: Location +firstSiblingLocation = mkLocation (FileId 48) 5 7 +secondSiblingLocation = mkLocation (FileId 48) 5 24 + +outerBinderLocation, innerBinderLocation :: Location +outerBinderLocation = mkLocation (FileId 48) 6 7 +innerBinderLocation = mkLocation (FileId 48) 6 31 + +nestedSuchThatLocation, nestedEqualityLocation :: Location +nestedSuchThatLocation = mkLocation (FileId 48) 6 45 +nestedEqualityLocation = mkLocation (FileId 48) 6 20 + +firstAdapterLocation, secondAdapterLocation :: Location +firstAdapterLocation = mkLocation (FileId 48) 7 7 +secondAdapterLocation = mkLocation (FileId 48) 7 19 + +alternateFirstLocation, alternateSecondLocation :: Location +alternateFirstLocation = mkLocation (FileId 48) 8 7 +alternateSecondLocation = mkLocation (FileId 48) 8 19 + +replacementFile :: FileId +replacementFile = FileId 47 + +replacementLocation :: Location +replacementLocation = mkLocation replacementFile 2 1 + +iotaLocation :: Location +iotaLocation = mkLocation (FileId 49) 3 5 + +definiteFunctionLocation :: Location +definiteFunctionLocation = mkLocation (FileId 49) 4 9 + +proofLocalFunctionDefinitionMismatches :: Assertion +proofLocalFunctionDefinitionMismatches = + for_ mismatchCases \(label, proof, expectedError) -> + assertEqual + label + (Left expectedError) + (meaning + [ Raw.BlockProof + proofLocation + proof + proofLocation + ]) + where + mismatchCases = + [ ( "argument and domain binder" + , Raw.DefineFunction + proofLocation + "f" + "x" + (Raw.ExprVar "x") + "y" + (Raw.ExprVar "domain") + (Raw.Omitted proofLocation) + , GlossProofFunctionArgumentMismatch + proofLocation + "x" + "y" + ) + , ( "declared and defined function name" + , Raw.DefineFunctionLocal + proofLocation + "f" + "domain" + (Raw.ExprVar "range") + "g" + "x" + ( ( Raw.ExprVar "x" + , Raw.PropositionalConstant + proofLocation + Raw.IsTop + ) + :| [] + ) + (Raw.Omitted proofLocation) + , GlossProofFunctionNameMismatch + proofLocation + "f" + "g" + ) + ] + proofLocation = mkLocation (FileId 46) 5 9 + +quantifiedFunctionalDefinition :: Assertion +quantifiedFunctionalDefinition = + case meaning [definitionBlock] of + Left + (GlossDefnError + actualLocation + DefnErrorQuantifiedRhsTerm + actualMarker) -> do + assertEqual + "quantified term location" + termLocation + actualLocation + assertEqual + "definition marker" + definitionMarker + actualMarker + Left err -> + assertFailure + ("expected a quantified definition term error, got " + <> show err) + Right _ -> + assertFailure + "expected quantified definition term validation to fail" + where + definitionBlock = + Raw.BlockDefn + blockLocation + Nothing + definitionMarker + ( Raw.DefnFun + [] + ( Raw.Fun + blockLocation + ( Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "value[/s] of ?") + "quantified_function" + ) + ["argument"] + ) + Nothing + ( Raw.TermQuantified + Raw.Existentially + termLocation + ( Raw.NounPhrase + [] + ( Raw.Noun + termLocation + ( Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "set[/s]") + "set" + ) + [] + ) + Nothing + [] + Nothing + ) + ) + ) + definitionMarker = "quantified_definition" + blockLocation = mkLocation (FileId 44) 8 1 + termLocation = mkLocation (FileId 44) 8 29 + +duplicateAbbreviationParameters :: Assertion +duplicateAbbreviationParameters = do + let marker = "duplicate_abbreviation" + duplicate = Raw.NamedVar "duplicate" + expectAbbreviationError + marker + [duplicate, duplicate] + (Raw.ExprVar duplicate) + \case + DuplicateAbbreviationParameters actualVariables -> + assertEqual + "duplicate parameter names" + (duplicate :| []) + actualVariables + err -> + assertFailure + ("expected duplicate abbreviation parameters, got " + <> show err) + +freeAbbreviationBodyVariable :: Assertion +freeAbbreviationBodyVariable = do + let marker = "free_abbreviation_body" + freeVariable = Raw.NamedVar "free" + expectAbbreviationError + marker + ["parameter"] + (Raw.ExprVar freeVariable) + \case + FreeAbbreviationBodyVariables actualVariables -> + assertEqual + "free body variable names" + (freeVariable :| []) + actualVariables + err -> + assertFailure + ("expected free abbreviation variables, got " + <> show err) + +orderedAbbreviationParameters :: Assertion +orderedAbbreviationParameters = do + let first = Raw.NamedVar "first" + second = Raw.NamedVar "second" + third = Raw.NamedVar "third" + firstArgument = closedInteger 11 + secondArgument = closedInteger 22 + thirdArgument = closedInteger 33 + arguments = + [ firstArgument + , secondArgument + , thirdArgument + ] + expectedBody = + Sem.TermSymbol + abbreviationLocation + (Sem.SymbolMixfix abbreviationBodySymbol) + [thirdArgument, firstArgument, secondArgument] + unexpectedArgument = closedInteger (-1) + case meaning + [ abbreviationBlock + abbreviationLocation + "ordered_abbreviation" + [first, second, third] + ( Raw.ExprOp + abbreviationLocation + abbreviationBodySymbol + [ Raw.ExprVar third + , Raw.ExprVar first + , Raw.ExprVar second + ] + ) + ] of + Right + [Sem.BlockAbbr + _actualLocation + _actualMarker + (Sem.Abbreviation _actualSymbol scope)] -> + assertEqual + "instantiated abbreviation body" + expectedBody + ( instantiate + (\parameterIndex -> + nth parameterIndex arguments + ?? unexpectedArgument) + scope + ) + Right blocks -> + assertFailure + ("expected one glossed abbreviation, got " + <> show blocks) + Left err -> + assertFailure + ("expected a valid abbreviation, got " + <> show err) + +expectAbbreviationError + :: Raw.Marker + -> [Raw.VarSymbol] + -> Raw.Expr + -> (AbbreviationParameterError -> Assertion) + -> Assertion +expectAbbreviationError marker parameters body checkError = + case meaning + [ abbreviationBlock + abbreviationLocation + marker + parameters + body + ] of + Left + (GlossAbbreviationError + actualLocation + actualMarker + abbreviationError) -> do + assertEqual + "abbreviation location" + abbreviationLocation + actualLocation + assertEqual + "abbreviation marker" + marker + actualMarker + checkError abbreviationError + Left err -> + assertFailure + ("expected an abbreviation parameter error, got " + <> show err) + Right _ -> + assertFailure + "expected abbreviation parameter validation to fail" + +abbreviationBlock + :: Location + -> Raw.Marker + -> [Raw.VarSymbol] + -> Raw.Expr + -> Raw.Block +abbreviationBlock location marker parameters body = + Raw.BlockAbbr + location + Nothing + marker + ( Raw.AbbreviationEq + ( Raw.SymbolPattern + (testFunctionSymbol + "abbreviation_head" + (length parameters)) + parameters + ) + body + ) + +abbreviationBodySymbol :: Raw.FunctionSymbol +abbreviationBodySymbol = + testFunctionSymbol "abbreviation_body" 3 + +testFunctionSymbol :: Text -> Int -> Raw.FunctionSymbol +testFunctionSymbol name arity = + Raw.mkMixfixItem + (Just (Raw.Command name) : replicate arity Nothing) + (Raw.Marker name) + Raw.NonAssoc + +closedInteger :: Int -> Sem.ExprOf a +closedInteger value = + Sem.TermSymbol + Nowhere + (Sem.SymbolInteger value) + [] + +abbreviationLocation :: Location +abbreviationLocation = + mkLocation (FileId 43) 8 12 + +relationClaim :: Int -> Raw.Block +relationClaim actualParameterCount = + Raw.BlockClaim + Raw.Proposition + relationLocation + Nothing + "relation_arity" + (Raw.Claim [] + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar "x" :| []) + Raw.Positive + (Raw.Relation + relationLocation + relationSymbol + (replicate + actualParameterCount + (Raw.ExprVar "p"))) + (Raw.ExprVar "y" :| []))))) + +relationSymbol :: Raw.RelationSymbol +relationSymbol = + Raw.RelationSymbol + (Raw.Command "parametric") + (Raw.ParameterArity 1) + "parametric" + +relationLocation :: Location +relationLocation = mkLocation (FileId 42) 7 11 diff --git a/source/Felix/Test/Unit/Module.hs b/source/Felix/Test/Unit/Module.hs new file mode 100644 index 0000000..44f0ccb --- /dev/null +++ b/source/Felix/Test/Unit/Module.hs @@ -0,0 +1,9759 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Module (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Module +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as TypedInductive +import Felix.CommandLine qualified as CommandLine +import Felix.Math.Codec +import Felix.Module +import Felix.Parse qualified as Parse +import Felix.Prelude qualified as Prelude +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Source +import Felix.Source.Content qualified as Content +import Felix.Store qualified as Store +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon +import Felix.Syntax.Pragma qualified as Pragma +import Felix.Verification qualified as Verification +import Felix.Workspace qualified as Workspace +import Paths_felix qualified as Paths + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM + ( atomically + , check + , newEmptyTMVarIO + , newTQueueIO + , newTVarIO + , putTMVar + , readTQueue + , readTVar + , takeTMVar + , tryReadTMVar + , tryReadTQueue + , writeTQueue + , writeTVar + ) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad (foldM, when) +import Data.ByteString qualified as ByteString +import Data.Text qualified as StrictText +import Data.Text.Encoding qualified as Text +import Data.IORef + ( IORef + , atomicModifyIORef' + , modifyIORef' + , newIORef + , readIORef + ) +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import System.Directory + ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , getPermissions + , setOwnerExecutable + , setPermissions + ) +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO.Async (withAsync, wait) + + +unitTests :: TestTree +unitTests = + testGroup "Typed module inputs" + [ testCase "constructs the empty bootstrap ordinarily" + constructsEmptyBootstrap + , testCase "identifies comment-only reserved input" + identifiesCommentOnlyInput + , testCase "loads and parses the packaged final prelude" + parsesPackagedFinalPrelude + , testCase "renders packaged final-prelude failures" + rendersPackagedPreludeFailures + , testCase "confines exact foundation-leaf completion" + confinesFoundationLeafCompletion + , testCase "builds the confined final prelude" + buildsConfinedFinalPrelude + , testCase "publishes the final prelude as an ordinary sealed root" + publishesFinalPreludeRoot + , testCase "retains exact omitted-proof locations" + retainsExactOmittedProofLocation + , testCase "coalesces syntax without collapsing semantic imports" + coalescesSharedDirectSyntax + , testCase "makes selected source errors terminal" + rejectsUnsupportedTypedSource + , testCase "reuses one verification session for successive checks" + reusesVerificationSession + , testCase "compiles exact declarations across an import" + compilesExactDeclarationGraph + , testCase "compiles and imports exact structures" + compilesExactStructures + , testCase "compiles and caches contextual abbreviations" + compilesContextualAbbreviations + , testCase "rejects an unknown exact structure parent atomically" + rejectsUnknownExactStructureParent + , testCase "compiles exact relation expressions" + compilesExactRelationExpressions + , testCase "resolves source-owned set application" + resolvesSourceOwnedApplication + , testCase "scopes quantified terms in proposition contexts" + confinesExactQuantifiedTerms + , testCase "closes the exact definition declaration boundary" + closesExactDefinitionDeclarationBoundary + , testCase "compiles exact ordinary proofs" + compilesExactOrdinaryProofs + , testCase "restores exact binder and witness proof forms" + restoresExactBinderAndWitnessProofForms + , testCase "restores exact local reasoning and calculations" + restoresExactLocalReasoningAndCalculations + , testCase "selects calculation link failures by source order" + selectsCalculationLinkFailureBySourceOrder + , testCase "compiles and reuses proof-local set definitions" + compilesAndReusesProofLocalSetDefinitions + , testCase "compiles and reuses proof-local function graphs" + compilesAndReusesProofLocalFunctionGraphs + , testCase "restores exact cases and classical contradiction" + confinesTerminalExactContradiction + , testCase "compiles exact separation comprehensions" + compilesExactSeparationComprehensions + , testCase "compiles exact replacement comprehensions" + compilesExactReplacementComprehensions + , testCase "compiles and reuses relational replacement" + compilesAndReusesRelationalReplacement + , testCase "compiles and reuses exact finite sets" + compilesAndReusesExactFiniteSets + , testCase "prepares exact deterministic datatypes" + preparesExactDatatypes + , testCase "rejects nested exact datatype recursion" + rejectsNestedExactDatatypeRecursion + , testCase "compiles and reuses exact datatypes" + compilesAndReusesExactDatatypes + , testCase "prepares exact direct inductives" + preparesExactDirectInductives + , testCase "prepares nested exact inductive recursion" + preparesNestedExactInductiveRecursion + , testCase "compiles transparent nested inductive wrappers" + compilesTransparentNestedInductiveWrappers + , testCase "normalizes nested exact inductive contexts" + normalizesNestedExactInductiveContexts + , testCase "compiles and reuses exact inductives" + compilesAndReusesExactInductives + , testCase "authorizes recursive exact inductives" + authorizesRecursiveExactInductives + , testCase "reuses exact separation validation" + reusesExactSeparationValidation + , testCase "compiles exact source axioms" + compilesExactSourceAxioms + , testCase "does not treat marker-only nouns as the fixed set noun" + doesNotTreatMarkerOnlyNounAsSet + , testCase "rejects proof-local generalization" + rejectsProofLocalGeneralization + , testCase "restores checked set induction" + restoresCheckedSetInduction + , testCase "compiles exact omitted proofs" + compilesExactOmittedProofs + , testCase "propagates and reuses exact escape authority" + reusesExactEscapeAuthority + , testCase "checks continuations after omitted subclaims" + rejectsAfterExactOmittedSubclaim + , testCase "reuses exact proof validation across module misses" + reusesExactProofValidationAcrossModuleMisses + , testCase "rejects declarations of fixed semantics" + rejectsFixedSemanticDeclaration + , testCase "rejects inductive carriers with fixed semantics" + rejectsFixedSemanticInductive + , testCase "keeps exact semantics independent of fixity" + keepsExactSemanticsIndependentOfFixity + , testCase "loads a cached exact producer for a fresh importer" + loadsCachedExactProducerForFreshImporter + , testCase "reports admitted source escapes on fresh, warm, and failure paths" + reportsAdmittedSourceEscapes + , testCase "selects concurrent module failures by source order" + selectsConcurrentModuleFailureDeterministically + , testCase "batches independent structure obligations atomically" + batchesStructureObligationsAtomically + , testCase "speculates dependent proof obligations without admitting ahead" + speculatesDependentProofObligationsWithoutAdmittingAhead + , testCase "starts diamond consumers after sealed acknowledgements" + schedulesDiamondAfterSealedImports + , testCase "classifies typed Vampire failures conservatively" + classifiesTypedVampireFailures + , testCase "retains the exact prefix before a later failure" + retainsExactPrefixBeforeFailure + , testCase "routes every production root through exact checking" + routesProductionVerification + , testCase "installs nonempty implicit prelude evidence" + installsNonemptyImplicitPreludeEvidence + ] + +constructsEmptyBootstrap :: Assertion +constructsEmptyBootstrap = do + foundation <- expectRight Foundation.checkedFoundation + result <- + Module.buildBootstrapPreludeFixture + foundation + unusedResolver + session <- expectRight result + let input = Module.bootstrapPreludeInput session + parsed = Module.identifiedModuleParsed input + sealed = Module.bootstrapPreludeModule session + syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + assertEqual "reserved owner" + preludeModuleName + (Module.identifiedModuleOwner input) + case Module.identifiedModuleBinding input of + Module.ReservedModuleBinding fileId label -> do + assertEqual "diagnostic label" + Prelude.preludeDiagnosticLabel + label + assertEqual "registered display label" + (Just Prelude.preludeDiagnosticLabel) + (lookupFilePath fileId) + assertEqual "registered identity label" + (Just Prelude.preludeDiagnosticLabel) + (lookupFileIdentityPath fileId) + Module.PhysicalModuleBinding source -> + assertFailure + ("bootstrap acquired a physical source: " <> show source) + assertEqual "empty parsed blocks" + [] + (Parse.identifiedParsedModuleBlocks parsed) + assertEqual "exact empty source identity" + (Content.sourceContentIdBytes ByteString.empty) + (Parse.identifiedParsedModuleSourceContentId parsed) + assertEqual "no syntax imports" + [] + (Syntax.moduleSyntaxDirectInputs syntax) + assertEqual "empty local syntax" + [] + (Syntax.canonicalSyntaxDeltaEntries + (Syntax.moduleSyntaxLocalDelta syntax)) + assertEqual "semantic owner" + preludeModuleName + (Semantic.semanticInterfaceOwner semantic) + assertEqual "no semantic imports" + [] + (Semantic.semanticInterfaceDirectInputs semantic) + assertEqual "no semantic declarations" + [] + (Semantic.semanticInterfaceDeclarations semantic) + expectedPrefix <- + expectRight + (Semantic.initialPrefixContextId + (Identity.theoryId foundation) + preludeModuleName + []) + assertEqual "empty sealed prefix" + expectedPrefix + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + +identifiesCommentOnlyInput :: Assertion +identifiesCommentOnlyInput = do + emptySource <- + expectRight + =<< Prelude.parseReservedPreludeSource + Prelude.emptyBootstrapSourceInput + source <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 "% an in-memory comment\n")) + first <- + expectRight + =<< Prelude.parseReservedPreludeSource source + second <- + expectRight + =<< Prelude.parseReservedPreludeSource source + let emptyParsed = Prelude.reservedParsedPreludeModule emptySource + firstParsed = Prelude.reservedParsedPreludeModule first + secondParsed = Prelude.reservedParsedPreludeModule second + assertEqual "reserved live source binding" + Parse.FreshReservedSource + (Parse.freshModuleInputBinding + (Prelude.reservedParsedPreludeInput first)) + assertEqual "comment-only source has no blocks" + [] + (Parse.identifiedParsedModuleBlocks firstParsed) + assertBool "content changes parsed identity" + (Parse.identifiedParsedModuleId emptyParsed + /= Parse.identifiedParsedModuleId firstParsed) + assertEqual "same input has stable parsed identity" + (Parse.identifiedParsedModuleId firstParsed) + (Parse.identifiedParsedModuleId secondParsed) + assertEqual "comments do not change syntax" + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface emptyParsed)) + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface firstParsed)) + +parsesPackagedFinalPrelude :: Assertion +parsesPackagedFinalPrelude = do + path <- Paths.getDataFileName "data/felix-prelude.tex" + expectedBytes <- ByteString.readFile path + source <- expectRight =<< Prelude.loadReservedPreludeSourceInput + assertEqual "exact packaged bytes" + expectedBytes + (Prelude.reservedPreludeSourceBytes source) + assertEqual "reserved owner" + preludeModuleName + (Prelude.reservedPreludeSourceOwner source) + assertEqual "diagnostic label" + Prelude.preludeDiagnosticLabel + (Prelude.reservedPreludeSourceLabel source) + first <- expectRight =<< Prelude.parseReservedPreludeSource source + second <- expectRight =<< Prelude.parseReservedPreludeSource source + let firstInput = Prelude.reservedParsedPreludeInput first + firstParsed = Prelude.reservedParsedPreludeModule first + secondParsed = Prelude.reservedParsedPreludeModule second + assertEqual "no textual imports" + [] + (Parse.freshModuleInputImports firstInput) + assertBool "declaration-bearing source" + (not (null (Parse.identifiedParsedModuleBlocks firstParsed))) + assertEqual "deterministic syntax interface" + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface firstParsed)) + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface secondParsed)) + +rendersPackagedPreludeFailures :: Assertion +rendersPackagedPreludeFailures = do + assertEqual "load failure" + "/missing/felix-prelude.tex: unable to read packaged final prelude: not found" + (Prelude.renderPreludeLoadError + (Prelude.PreludeSourceReadFailed + "/missing/felix-prelude.tex" + "not found")) + assertEqual "located syntax failure" + ": syntax pragma location is out of range at 7:3" + (Prelude.renderPreludeParseError parseFailure) + assertEqual "authority-free API presentation" + ("packaged final prelude parsing failed: " + <> ": syntax pragma location is out of range at 7:3") + (Workspace.renderAuthorityFreeParseError + (Workspace.AuthorityFreePreludeParseFailed parseFailure)) + where + parseFailure = + Prelude.PreludeSyntaxPragmaFailed + (Pragma.SyntaxPragmaLocationOutOfRange + Prelude.preludeDiagnosticLabel + 7 + 3) + +confinesFoundationLeafCompletion :: Assertion +confinesFoundationLeafCompletion = do + foundation <- expectRight Foundation.checkedFoundation + packaged <- expectRight =<< Prelude.loadReservedPreludeSourceInput + parsed <- expectRight =<< Prelude.parseReservedPreludeSource packaged + matching <- sole "matching foundation claim" + (take 1 + (Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed))) + mismatchInput <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 + "\\begin{proposition}\\label{not_foundation}\n $\\emptyset = \\emptyset$.\n\\end{proposition}\n")) + mismatchParsed <- + expectRight =<< Prelude.parseReservedPreludeSource mismatchInput + mismatch <- sole "mismatching claim" + (Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule mismatchParsed)) + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + explicit <- + admitFoundationClaim + foundation + matching + (Just (Raw.Omitted (locate matching))) + nonmatching <- + admitFoundationClaim + foundation + mismatch + Nothing + committed <- + admitFoundationClaim + foundation + matching + Nothing + pure (explicit, nonmatching, committed) + case outcome of + Right (Declaration.DriverSucceeded + (explicit, nonmatching, committed) + _semantic _prefix _closure) -> do + case explicit of + Left ExactProof.ExactProofFoundationLeafRequiresImplicitAuto{} -> + pure () + Left other -> + assertFailure + ("explicit foundation result: " <> show other) + Right{} -> + assertFailure "explicit foundation proof was accepted" + batch <- expectRight committed + case nonmatching of + Left ExactProof.ExactProofFoundationLeafTargetMismatch{} -> + pure () + Left other -> + assertFailure + ("mismatching foundation result: " <> show other) + Right{} -> + assertFailure "mismatching foundation claim was accepted" + assertEqual "foundation tag" + Foundation.UnivOfContains + (case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) of + Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) -> + tag + authorization -> + error + ("unexpected foundation authorization: " + <> show authorization) + records -> + error + ("unexpected foundation validation count: " + <> show (length records))) + Right Declaration.DriverFailed{} -> + assertFailure "foundation driver failed" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("foundation driver did not seal: " <> show failure) + Left failure -> + assertFailure ("foundation driver did not open: " <> show failure) + where + admitFoundationClaim foundation block proof = + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareFinalPreludeFoundationClaim + foundation block proof) >>= \case + Left failure -> pure (Left failure) + Right prepared -> do + lowered <- + Declaration.runProspectiveLoweringDriver + (ExactProof.lowerPreparedFinalPreludeFoundationClaim + prepared) + checked <- + either Declaration.failDeclarationDriver pure lowered + batch <- + Declaration.admitCheckedDeclaration + checked + ExactProof.authorizeCheckedFinalPreludeFoundationClaim + pure (Right batch) + +buildsConfinedFinalPrelude :: Assertion +buildsConfinedFinalPrelude = do + foundation <- expectRight Foundation.checkedFoundation + FinalPrelude.buildFinalPreludeCandidate + foundation finalPreludeResolver >>= \case + FinalPrelude.FinalPreludeBuilt candidate -> do + assertEqual "confined semantic owner" + preludeModuleName + (Semantic.semanticInterfaceOwner + (FinalPrelude.finalPreludeSemantic candidate)) + assertEqual "confined semantic imports" + [] + (Semantic.semanticInterfaceDirectInputs + (FinalPrelude.finalPreludeSemantic candidate)) + let baseDeltas = + [ delta + | delta <- Semantic.semanticInterfaceDeclarations + (FinalPrelude.finalPreludeSemantic candidate) + , not + (null + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta))) + ] + case baseDeltas of + [delta] -> do + assertEqual "base structure has no facts" + [] + (Semantic.declarationDeltaFacts delta) + assertEqual "base structure has no propositions" + [] + (Semantic.declarationDeltaPropositions delta) + case Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta) of + [descriptor] -> do + assertEqual "base structure is metadata-only" + Nothing + (Semantic.semanticStructureDescriptorPredicate + descriptor) + case Semantic.semanticStructureDescriptorOperations + descriptor of + [operation] -> + case Identity.lookupCheckedObjectContent + (Semantic.semanticStructureOperationObject + operation) + (FinalPrelude.finalPreludeObjects candidate) of + Just Identity.OpaqueObjectContent{} -> pure () + content -> + assertFailure + ("expected opaque carrier, got " + <> show content) + operations -> + assertFailure + ("expected one base operation, got " + <> show operations) + descriptors -> + assertFailure + ("expected one base descriptor, got " + <> show descriptors) + deltas -> + assertFailure + ("expected one base structure delta, got " + <> show (length deltas)) + let role roleName = + maybe + (assertFailure + ("missing final-prelude role " + <> show roleName)) + pure + (FinalPrelude.finalPreludePublicRole + candidate roleName) + omega <- role FinalPrelude.PreludeOmegaObject + naturals <- role FinalPrelude.PreludeNaturalsAlias + assertEqual "naturals expands to Omega" + omega naturals + traverse_ + (void . role) + (Set.toList FinalPrelude.expectedFinalPreludePublicRoles) + let foundationTags = Set.fromList + [ tag + | batch <- + Declaration.pendingModulePrefixBatches + (FinalPrelude.finalPreludePrefix candidate) + , record <- + Declaration.committedBatchProofValidations batch + , Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) <- + [ Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) + ] + ] + assertBool "protected foundation presentation" + ( Set.fromList + [ Foundation.SetExtensionality + , Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + ] + `Set.isSubsetOf` foundationTags + ) + assertFinalPreludeFoundationAlias + candidate + "pairset_iff" + Foundation.PairSetCharacteristic + assertFinalPreludeFoundationAlias + candidate + "pow_iff" + Foundation.PowerSetCharacteristic + assertRejectsAdditionalOmegaFact candidate + FinalPrelude.FinalPreludeBuildFailed failure prefix -> + assertFailure + ("final prelude failed after " + <> show + (length + (Declaration.pendingModulePrefixBatches prefix)) + <> " declarations: " + <> show failure) + FinalPrelude.FinalPreludeBuildOpenFailed failure -> + assertFailure ("final prelude did not open: " <> show failure) + FinalPrelude.FinalPreludeSourceLoadFailed failure -> + assertFailure ("final prelude did not load: " <> show failure) + FinalPrelude.FinalPreludeSourceParseFailed failure -> + assertFailure ("final prelude did not parse: " <> show failure) + +assertRejectsAdditionalOmegaFact + :: FinalPrelude.FinalPreludeCandidate + -> Assertion +assertRejectsAdditionalOmegaFact candidate = do + omegaId <- + case FinalPrelude.finalPreludePublicRole + candidate FinalPrelude.PreludeOmegaObject of + Just (FinalPrelude.FinalPreludeObjectRole identity) -> + pure identity + role -> + assertFailure ("unexpected Omega role " <> show role) + >> fail "unreachable" + batch <- batchByAlias + (FinalPrelude.finalPreludePrefix candidate) + "prelude_omega" + let delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + propositions = Declaration.committedBatchPropositions batch + certificates <- + maybe + (assertFailure "Omega declaration validation is absent" + >> fail "unreachable") + (pure . Semantic.declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + (omegaBody, extensional, descriptor, extraFact, extraProposition, + extraCertificate) <- + case (facts, propositions, certificates) of + ( [_equationFact, extensionalFact] + , [equationProposition, extensionalProposition] + , [ _equationCertificate + , extensionalCertificate + ] + ) -> do + body <- case Core.frozenCoreTerm + (Identity.checkedPropositionTerm equationProposition) of + Core.CEq Core.TySet + (Core.CGlobal identity) candidateBody + | identity == omegaId -> pure candidateBody + target -> + assertFailure + ("unexpected Omega equation " <> show target) + >> fail "unreachable" + constructionDescriptor <- + case Authority.validationDirectAuthorization + extensionalCertificate of + Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + identity candidateDescriptor) + | identity == omegaId -> pure candidateDescriptor + authorization -> + assertFailure + ("unexpected Omega extensional authority " + <> show authorization) + >> fail "unreachable" + pure + ( body + , Identity.checkedPropositionTerm extensionalProposition + , constructionDescriptor + , extensionalFact + , extensionalProposition + , extensionalCertificate + ) + (candidateFacts, candidatePropositions, candidateCertificates) -> + assertFailure + ("unexpected Omega inventory shape " + <> show + ( length candidateFacts + , length candidatePropositions + , length candidateCertificates + )) + >> fail "unreachable" + case FinalPrelude.validateOmegaFactInventory + omegaId omegaBody extensional descriptor + (facts <> [extraFact]) + aliases + (propositions <> [extraProposition]) + (certificates <> [extraCertificate]) of + Left (FinalPrelude.FinalPreludeFactContentMismatch + "prelude_omega") -> + pure () + result -> + assertFailure + ("additional Omega construction fact was accepted: " + <> show result) + +publishesFinalPreludeRoot :: Assertion +publishesFinalPreludeRoot = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-final-prelude-root" \directory -> do + let path = directory Posix. "store.sqlite" + theory = Identity.theoryId foundation + open = do + (_startup, store) <- + Store.openStore path theory >>= expectRight + pure store + bracket open Store.closeStore \store -> do + freshMemo <- Store.newStoreMemo store + session <- + expectRight + =<< Module.acquireFinalPreludeSession + freshMemo store foundation finalPreludeResolver + let input = Module.finalPreludeInput session + sealed = Module.finalPreludeModule session + syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + assertEqual "empty store constructs the final-prelude root" + Module.ModuleRootMiss + (Module.finalPreludeAcquisition session) + assertEqual "final prelude owner" + preludeModuleName + (Module.identifiedModuleOwner input) + assertEqual "final prelude has no semantic parents" + [] + (Semantic.semanticInterfaceDirectInputs semantic) + warmMemo <- Store.newStoreMemo store + warmSession <- expectRight + =<< Module.acquireFinalPreludeSession + warmMemo store foundation unusedResolver + let cached = Module.finalPreludeModule warmSession + assertEqual "persisted final-prelude root is a cache hit" + Module.ModuleRootHit + (Module.finalPreludeAcquisition warmSession) + assertEqual "generic root syntax" + syntax + (Module.sealedTypedModuleSyntax cached) + assertEqual "generic root semantics" + semantic + (Module.sealedTypedModuleSemantic cached) + assertEqual "cached base structure descriptor" + (semanticStructureDescriptors semantic) + (semanticStructureDescriptors + (Module.sealedTypedModuleSemantic cached)) + assertEqual "generic root final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix cached)) + visits <- Store.storeMemoVisits warmMemo + assertEqual "cached prelude validates one artifact root" + 1 + (Store.storeArtifactsValidated visits) + +semanticStructureDescriptors + :: Semantic.SemanticInterface + -> [Semantic.SemanticStructureDescriptor] +semanticStructureDescriptors semantic = + [ descriptor + | delta <- Semantic.semanticInterfaceDeclarations semantic + , descriptor <- Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta) + ] + +assertTransparentObjectAlias + :: Module.SealedTypedModule + -> Text + -> Assertion +assertTransparentObjectAlias sealed name = do + target <- localObjectAliasTarget sealed name + assertEqual + ("transparent object for " <> StrictText.unpack name) + Identity.TransparentObject + (Identity.objectIdFamily target) + +localObjectKeyTarget + :: Module.SealedTypedModule + -> Semantic.SemanticGlobalKey + -> IO Identity.ObjectId +localObjectKeyTarget sealed key = do + binding <- sole + ("semantic binding for " <> show key) + [ candidate + | delta <- localSemanticDeltas sealed + , candidate <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + , Semantic.semanticGlobalBindingKey candidate == key + ] + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + +localObjectAliasTarget + :: Module.SealedTypedModule + -> Text + -> IO Identity.ObjectId +localObjectAliasTarget sealed name = do + delta <- localDeltaByAlias sealed name + binding <- sole + ("semantic binding for " <> StrictText.unpack name) + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta)) + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + +checkedPropositionTermByAlias + :: Module.SealedTypedModule + -> Text + -> IO (Core.FrozenCheckedCore Identity.ObjectId) +checkedPropositionTermByAlias sealed name = do + batch <- batchByAlias + (Module.sealedTypedModulePrefix sealed) + name + alias <- sole + ("semantic alias for " <> StrictText.unpack name) + [ candidate + | candidate <- Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch) + , Semantic.semanticAliasName candidate + == Semantic.semanticName name + ] + occurrence <- sole + ("semantic fact for " <> StrictText.unpack name) + [ candidate + | candidate <- Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) + , Semantic.semanticFactFingerprint candidate + == Semantic.semanticAliasTarget alias + ] + proposition <- sole + ("checked proposition for " <> StrictText.unpack name) + [ candidate + | candidate <- Declaration.committedBatchPropositions batch + , Identity.checkedPropositionId candidate + == Semantic.semanticFactProposition occurrence + ] + pure (Identity.checkedPropositionTerm proposition) + +batchByAlias + :: Declaration.PendingModulePrefix + -> Text + -> IO Declaration.CommittedDeclarationBatch +batchByAlias prefix name = + sole + ("declaration batch for " <> StrictText.unpack name) + [ batch + | batch <- Declaration.pendingModulePrefixBatches prefix + , alias <- Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch) + , Semantic.semanticAliasName alias + == Semantic.semanticName name + ] + +assertFinalPreludeFoundationAlias + :: FinalPrelude.FinalPreludeCandidate + -> Text + -> Foundation.FoundationAxiomTag + -> Assertion +assertFinalPreludeFoundationAlias candidate name tag = do + batch <- batchByAlias + (FinalPrelude.finalPreludePrefix candidate) + name + fact <- sole + ("foundation fact " <> StrictText.unpack name) + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual + ("foundation safety for " <> StrictText.unpack name) + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + validation <- sole + ("foundation validation for " <> StrictText.unpack name) + (Declaration.committedBatchProofValidations batch) + assertEqual + ("exact foundation authority for " <> StrictText.unpack name) + (Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag)) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate validation)) + +localDeltaByAlias + :: Module.SealedTypedModule + -> Text + -> IO Semantic.DeclarationInterfaceDelta +localDeltaByAlias sealed name = + sole + ("declaration delta for " <> StrictText.unpack name) + [ delta + | delta <- localSemanticDeltas sealed + , any + ((== Semantic.semanticName name) + . Semantic.semanticAliasName) + (Semantic.declarationDeltaAliases delta) + ] + +localSemanticDeltas + :: Module.SealedTypedModule + -> [Semantic.DeclarationInterfaceDelta] +localSemanticDeltas = + Semantic.semanticInterfaceDeclarations + . Module.sealedTypedModuleSemantic + +retainsExactOmittedProofLocation :: Assertion +retainsExactOmittedProofLocation = do + foundation <- expectRight Foundation.checkedFoundation + source <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 + (StrictText.unlines + [ "\\begin{proposition}\\label{omitted_location}" + , " For all $x$ we have $x = x$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Omitted." + , "\\end{proof}" + ]))) + parsed <- expectRight =<< Prelude.parseReservedPreludeSource source + let blocks = + Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed) + claim <- sole "omitted claim" + [ block + | block@Raw.BlockClaim{} <- blocks + ] + proof <- sole "omitted proof" + [ sourceProof + | Raw.BlockProof _location sourceProof _end <- blocks + ] + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof claim (Just proof)) + >>= either Declaration.failModuleDriver pure + case outcome of + Right (Declaration.DriverSucceeded + prepared _semantic prefix _closure) -> do + location <- + maybe + (assertFailure "prepared omitted proof lost its location") + pure + (ExactProof.preparedExactProofFirstOmission prepared) + assertEqual "omitted source line" 5 (locLine location) + assertBool "preparation publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure ("omitted preparation failed: " <> show failure) + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("omitted preparation did not seal: " <> show failure) + Left failure -> + assertFailure ("omitted preparation did not open: " <> show failure) + +coalescesSharedDirectSyntax :: Assertion +coalescesSharedDirectSyntax = do + foundation <- expectRight Foundation.checkedFoundation + session <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + root <- getCurrentDirectory + mounts <- + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", root) + , (sourceMountId "library", root Posix. "library") + , (sourceMountId "debug", root Posix. "debug") + ] + let bootstrapSyntax = + Module.sealedTypedModuleSyntax + (Module.bootstrapPreludeModule session) + syntaxInputs _source = [bootstrapSyntax] + request <- + expectRight + (searchedRoot "test/phase3/typed-shared-root.tex") + workspace <- + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + syntaxInputs + case Parse.parsedWorkspaceModules workspace of + [firstParsed, secondParsed, rootParsed] -> do + first <- seal foundation session firstParsed [] + second <- seal foundation session secondParsed [] + assertEqual "distinct modules share one syntax interface" + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax first)) + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax second)) + assertBool "semantic module owners remain distinct" + (Module.sealedTypedModuleOwner first + /= Module.sealedTypedModuleOwner second) + assertBool "semantic interfaces remain distinct" + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic first) + /= Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic second)) + let rootSyntax = Parse.parsedModuleSyntaxInterface rootParsed + assertEqual "root coalesces the shared direct syntax" + [ Syntax.moduleSyntaxAssertedId bootstrapSyntax + , Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax first) + ] + (Syntax.moduleSyntaxDirectInputs rootSyntax) + sealedRoot <- + seal foundation session rootParsed [first, second] + assertEqual "root retains both semantic imports" + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule session)) + , Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic first) + , Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic second) + ] + (Semantic.semanticInterfaceDirectInputs + (Module.sealedTypedModuleSemantic sealedRoot)) + modules -> + assertFailure + ("unexpected shared-syntax module count: " + <> show (length modules)) + where + seal foundation session parsed direct = do + input <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness session) + unusedResolver + Declaration.FreshValidation + parsed + direct) + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded sealed -> + pure sealed + Module.TypedModuleOpenFailed{} -> + assertFailure "empty typed module did not open" + >> fail "unreachable" + Module.TypedModuleFailed{} -> + assertFailure "empty typed module did not seal" + >> fail "unreachable" + +rejectsUnsupportedTypedSource :: Assertion +rejectsUnsupportedTypedSource = do + result <- + (checkFileFresh + (Provers.vampire + "vampire" + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + "test/phase3/typed-unsupported.tex") + case result of + Right + ( Verification.VerificationCheckingFailure _report + (failure@(Verification.VerificationTypedModuleError + source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactGuardedOpaqueSignature location))) + prefix)) + , _slowReport + ) -> do + assertEqual "failed source" + "test/phase3/typed-unsupported.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertEqual "unsupported source location line" + 2 + (locLine location) + assertEqual "failure retains the initial module prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + let diagnostic = + Verification.renderVerificationDriverError failure + assertBool "diagnostic retains resolved source" + ("project:test/phase3/typed-unsupported.tex" + `StrictText.isInfixOf` diagnostic) + assertBool "diagnostic retains best location" + ("typed-unsupported.tex 2:14" + `StrictText.isInfixOf` diagnostic) + assertBool "diagnostic explains the typed failure" + ("opaque signature cannot have a header assumption" + `StrictText.isInfixOf` diagnostic) + Left err -> + assertFailure ("unexpected verification driver error: " <> show err) + Right{} -> + assertFailure "unsupported typed source was admitted" + +reusesVerificationSession :: Assertion +reusesVerificationSession = + withAcceptedFixtureVampire "felix-session-reuse" \prover -> do + plan <- Store.planStore Store.FreshTemporaryStore >>= expectRight + graph <- Workspace.prepareDefaultSourceGraph source >>= expectRight + Store.withStoreLease plan \lease -> do + opened <- Verification.withVerificationSession lease \session -> do + let request = Verification.CheckRequest + { Verification.checkSourceGraph = graph + , Verification.checkStoreValidationMode = + Verification.FreshStoreValidation + , Verification.checkEffectiveJobs = testSequentialJobs + , Verification.checkVampire = prover + , Verification.checkRequestObserver = + ignoredVerificationRequests + } + first <- + Verification.checkWorkspace session request >>= expectRight + second <- + Verification.checkWorkspace session request >>= expectRight + traverse_ + assertUnsupported + [ Verification.checkVerificationResult first + , Verification.checkVerificationResult second + ] + void (expectRight opened) + where + source = "test/phase3/typed-unsupported.tex" + + assertUnsupported = \case + Verification.VerificationCheckingFailure + _report + Verification.VerificationTypedModuleError{} -> + pure () + other -> + assertFailure + ("successive session check had unexpected result: " + <> show other) + +compilesExactDeclarationGraph :: Assertion +compilesExactDeclarationGraph = do + (_foundation, _bootstrap, workspace, sealedModules) <- + compileExactFixture "test/phase5/exact-importer.tex" + assertEqual "dependency-closed module count" 2 (length sealedModules) + assertEqual "imported-before-importer source order" + [ "test/phase5/exact-producer.tex" + , "test/phase5/exact-importer.tex" + ] + [ safeRelativePathFilePath + (resolvedSourceRelativePath + (Parse.parsedModuleResolved parsed)) + | parsed <- toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + ] + case sealedModules of + [producer, importer] -> do + let producerPrefix = Module.sealedTypedModulePrefix producer + importerPrefix = Module.sealedTypedModulePrefix importer + producerBatches = + Declaration.pendingModulePrefixBatches producerPrefix + importerBatches = + Declaration.pendingModulePrefixBatches importerPrefix + assertEqual "producer declaration batches" 3 + (length producerBatches) + assertEqual "importer declaration batches" 1 + (length importerBatches) + assertEqual "producer declaration order" + [0, 1, 2] + [ localDeclarationOrdinalValue + (Semantic.declarationSlotOrdinal + (Declaration.committedBatchSlot batch)) + | batch <- producerBatches + ] + + let producerDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic producer) + importerDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic importer) + assertEqual "one exact binding per producer declaration" + [1, 1, 1] + (bindingCount <$> producerDeltas) + assertEqual "one exact importer binding" + [1] + (bindingCount <$> importerDeltas) + assertEqual "producer object families" + ["opaque", "transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | batch <- producerBatches + , object <- Declaration.committedBatchObjects batch + ] + + definitionDelta <- sole "producer definition delta" + (drop 2 producerDeltas) + definitionBinding <- sole "producer definition binding" + (bindings definitionDelta) + definitionFact <- sole "producer definition fact" + (Semantic.declarationDeltaFacts definitionDelta) + definitionAlias <- sole "producer definition alias" + (Semantic.declarationDeltaAliases definitionDelta) + assertEqual "definition alias" + (Semantic.semanticName "phase5_definition") + (Semantic.semanticAliasName definitionAlias) + assertEqual "definition is proof-search eligible" + Semantic.SearchEligible + (Semantic.semanticFactSearchEligibility definitionFact) + assertEqual "definition authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority definitionFact)) + definitionBatch <- sole "producer definition batch" + (drop 2 producerBatches) + validation <- + maybe + (assertFailure "definition declaration validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + certificate <- sole "definition validation certificate" + (Semantic.declarationValidationRecordCertificates validation) + assertEqual "direct defining-equation authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + definitionBinding)))) + (Authority.validationDirectAuthorization + certificate) + + aliasDelta <- sole "producer abbreviation delta" + (take 1 (drop 1 producerDeltas)) + aliasBinding <- sole "producer abbreviation binding" + (bindings aliasDelta) + seedDelta <- sole "producer signature delta" + (take 1 producerDeltas) + seedBinding <- sole "producer signature binding" + (bindings seedDelta) + let seedTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget seedBinding) + aliasTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget aliasBinding) + definitionTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + definitionBinding) + assertEqual "abbreviation expands transparently" + (Semantic.TransparentExpansion + aliasTarget) + (Semantic.semanticGlobalBindingTarget aliasBinding) + assertEqual "definition remains a named global" + (Semantic.GlobalReference definitionTarget) + (Semantic.semanticGlobalBindingTarget definitionBinding) + assertEqual "definition content coalesces with its expansion" + aliasTarget + definitionTarget + assertEqual "coalesced definition adds no object" + [] + (Declaration.committedBatchObjects definitionBatch) + aliasBatch <- sole "producer abbreviation batch" + (take 1 (drop 1 producerBatches)) + aliasObject <- sole "producer abbreviation object" + (Declaration.committedBatchObjects aliasBatch) + case Identity.assertedObjectContent aliasObject of + Identity.TransparentObjectContent _theory _coreType body -> + assertEqual + "expanded body retains only the opaque seed" + (Set.singleton seedTarget) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("abbreviation object is not transparent: " + <> show content) + importerBatch <- sole "importer declaration batch" importerBatches + importerDelta <- sole "importer semantic delta" importerDeltas + importerBinding <- sole "importer binding" + (bindings importerDelta) + assertEqual "equal transparent content reuses the producer object" + (Semantic.semanticGlobalBindingTarget definitionBinding) + (Semantic.semanticGlobalBindingTarget importerBinding) + assertEqual "reused transparent content adds no object" + [] + (Declaration.committedBatchObjects importerBatch) + modules -> + assertFailure + ("unexpected exact module count: " <> show (length modules)) + where + bindingCount = length . bindings + + bindings = + Semantic.semanticEnvironmentBindings + . Semantic.declarationDeltaEnvironment + + objectFamilyName :: Identity.ObjectContent -> String + objectFamilyName = \case + Identity.OpaqueObjectContent{} -> "opaque" + Identity.TransparentObjectContent{} -> "transparent" + Identity.IntrinsicObjectContent{} -> "intrinsic" + +compilesExactStructures :: Assertion +compilesExactStructures = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + Temp.withSystemTempDirectory "felix-exact-structures" \directory -> do + let path = directory Posix. "store.sqlite" + executable = directory Posix. "vampire" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore path (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + carrierOperation <- sole "base carrier operation" + [ operation + | descriptor <- semanticStructureDescriptors + (Module.sealedTypedModuleSemantic + (Module.finalPreludeModule prelude)) + , operation <- + Semantic.semanticStructureDescriptorOperations descriptor + ] + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-structure-child.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + freshRuns <- readIORef runs + warm <- installAndLoadStructures + opened foundation prelude workspace sealed + warmRuns <- readIORef runs + assertEqual "warm structures preserve descriptors" + (structureDescriptors <$> sealed) + (structureDescriptors <$> warm) + assertEqual "warm structures make no prover calls" + freshRuns warmRuns + case sealed of + [parent, child] -> do + let parentBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix parent) + parentDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic parent) + childBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix child) + childDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic child) + parentBatch <- sole "parent structure batch" + (take 1 parentBatches) + parentDelta <- sole "parent structure delta" + (take 1 parentDeltas) + parentDescriptor <- sole "parent structure descriptor" + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment parentDelta)) + parentOperation <- sole "parent structure operation" + (Semantic.semanticStructureDescriptorOperations + parentDescriptor) + parentPredicate <- + maybe + (assertFailure "parent structure has no predicate" + >> fail "unreachable") + pure + (Semantic.semanticStructureDescriptorPredicate + parentDescriptor) + assertEqual "structure object family order" + ["opaque", "transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | object <- Declaration.committedBatchObjects parentBatch + ] + assertEqual "structure fact aliases" + [ Semantic.semanticName "pointed_set" + , Semantic.semanticName "pointed_refl" + ] + (Semantic.semanticAliasName + <$> Semantic.declarationDeltaAliases parentDelta) + definitionFact <- sole "structure definition fact" + (take 1 (Semantic.declarationDeltaFacts parentDelta)) + definitionTarget <- + targetForOccurrence parentBatch definitionFact + assertEqual "pointwise structure definition" + (Core.CForall Core.TySet + (Core.CEq Core.TyProp + (Core.CApp + (Core.CGlobal parentPredicate) + (Core.CBound 0)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + definitionTarget + validations <- + maybe + (assertFailure "structure validation is absent" + >> fail "unreachable") + (pure + . Semantic.declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation + parentBatch) + case validations of + definitionValidation : projectionValidation : [] -> do + assertEqual "structure definition authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + parentPredicate)) + (Authority.validationDirectAuthorization + definitionValidation) + projectionFact <- sole + "structure projection fact" + (drop 1 + (Semantic.declarationDeltaFacts + parentDelta)) + assertEqual + "projection has independent authority" + (Semantic.semanticFactAuthority projectionFact) + (Authority.validationTarget + projectionValidation) + assertEqual "projection authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget + projectionValidation)) + records -> + assertFailure + ("expected two structure validations, got " + <> show records) + assertBool "all parent structure facts are clean" + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + (Semantic.declarationDeltaFacts parentDelta)) + + let claimGlobals marker = do + batch <- batchWithAlias marker parentBatches + occurrence <- sole (marker <> " occurrence") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + Core.canonicalTermGlobals + <$> targetForOccurrence batch occurrence + carrierGlobals <- claimGlobals "pointed_carrier" + operationGlobals <- claimGlobals "pointed_operation" + assertBool "membership uses inherited carrier" + (Semantic.semanticStructureOperationObject carrierOperation + `Set.member` carrierGlobals) + assertBool "implicit and explicit operation share one object" + (Semantic.semanticStructureOperationObject parentOperation + `Set.member` operationGlobals) + + let assertEquivalentClaim surface explicit = do + surfaceTerm <- + checkedPropositionTermByAlias parent surface + explicitTerm <- + checkedPropositionTermByAlias parent explicit + assertEqual + (StrictText.unpack surface + <> " uses the inherited carrier") + explicitTerm + surfaceTerm + assertEquivalentClaim + "pointed_self_member" + "pointed_self_member_explicit" + assertEquivalentClaim + "pointed_self_not_member" + "pointed_self_not_member_explicit" + assertEquivalentClaim + "pointed_self_element" + "pointed_self_element_explicit" + assertEquivalentClaim + "pointed_header_member" + "pointed_header_member_explicit" + + childBatch <- sole "child structure batch" childBatches + childDelta <- sole "child structure delta" childDeltas + childDescriptor <- sole "child structure descriptor" + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment childDelta)) + assertEqual "child allocates no replacement operation" + [] + (Semantic.semanticStructureDescriptorOperations + childDescriptor) + assertEqual "child owns only its transparent predicate" + ["transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | object <- Declaration.committedBatchObjects childBatch + ] + modules -> + assertFailure + ("expected parent and child structures, got " + <> show (length modules)) + where + installAndLoadStructures store foundation prelude workspace sealed = do + memo <- Store.newStoreMemo store + case + ( toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + , sealed + ) of + ([parentParsed, childParsed], [parent, child]) -> do + cachedParent <- persistAndLoad memo [] parentParsed parent + cachedChild <- persistAndLoad + memo [cachedParent] childParsed child + pure [cachedParent, cachedChild] + (parsed, modules) -> + assertFailure + ("expected two structure installations, got " + <> show (length parsed) + <> " parsed and " + <> show (length modules) + <> " checked modules") + >> fail "unreachable" + where + preludeModule = Module.finalPreludeModule prelude + + persistAndLoad memo parents parsed sealedModule = do + let input = Module.identifiedPhysicalModule parsed + syntax = Module.sealedTypedModuleSyntax sealedModule + semantic = Module.sealedTypedModuleSemantic sealedModule + key <- expectRight + (Semantic.moduleArtifactKey + (Module.identifiedModuleOwner input) + (Parse.identifiedParsedModuleId + (Module.identifiedModuleParsed input)) + (Semantic.semanticInterfaceDirectInputs semantic) + (Identity.theoryId foundation)) + let artifact = Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + acknowledged <- expectRight + =<< Store.writeSealedModule + store + (Module.sealedTypedModulePrefix sealedModule) + [syntax] + [semantic] + artifact + assertEqual "cached structure artifact acknowledgement" + artifact acknowledged + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + installation <- maybe + (assertFailure "cached structure installation is absent" + >> fail "unreachable") + pure + loaded + expectRight + (Module.cachedSealedTypedModule + foundation + (preludeModule : parents) + installation) + + structureDescriptors = + semanticStructureDescriptors + . Module.sealedTypedModuleSemantic + + objectFamilyName :: Identity.ObjectContent -> String + objectFamilyName = \case + Identity.OpaqueObjectContent{} -> "opaque" + Identity.TransparentObjectContent{} -> "transparent" + Identity.IntrinsicObjectContent{} -> "intrinsic" + + targetForOccurrence batch occurrence = + maybe + (assertFailure "structure proposition is absent" + >> fail "unreachable") + (pure . Core.frozenCoreTerm . Identity.checkedPropositionTerm) + (find + ((== Semantic.semanticFactProposition occurrence) + . Identity.checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + + batchWithAlias marker batches = + maybe + (assertFailure ("missing batch alias " <> marker) + >> fail "unreachable") + pure + (find + (elem (Semantic.semanticName (StrictText.pack marker)) + . fmap Semantic.semanticAliasName + . Semantic.declarationDeltaAliases + . Declaration.committedBatchDelta) + batches) + +compilesContextualAbbreviations :: Assertion +compilesContextualAbbreviations = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + Temp.withSystemTempDirectory "felix-contextual-abbreviation" \directory -> do + let storePath = directory Posix. "store.sqlite" + executable = directory Posix. "vampire" + relative = "test/phase5/exact-contextual-abbreviation.tex" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace prelude mounts relative + sealed <- sole "contextual abbreviation module" + =<< compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + let deltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed) + contextualTargets = + [ (identity, requirements) + | delta <- deltas + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + , Semantic.ContextualTransparentExpansion + identity requirements <- + [Semantic.semanticGlobalBindingTarget binding] + ] + assertEqual "contextual target count" 2 + (length contextualTargets) + requirements <- + sole "canonical contextual requirement set" + (nubOrd (snd <$> contextualTargets)) + assertEqual "one structure operation requirement" 1 + (Map.size requirements) + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + traverse_ + (assertReflexiveFact batches) + [ "phase5_context_dot_explicit" + , "phase5_context_inherited" + , "phase5_context_nested" + , "phase5_context_explicit_unique" + ] + + parsed <- pure (Parse.parsedWorkspaceRootModule workspace) + let syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + (Semantic.semanticInterfaceDirectInputs semantic) + (Identity.theoryId foundation)) + let artifact = + Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + void + (expectRight + =<< Store.writeSealedModule + opened + (Module.sealedTypedModulePrefix sealed) + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo opened + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo opened key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + installation <- maybe + (assertFailure "contextual cached installation is absent" + >> fail "unreachable") + pure + loaded + cached <- expectRight + (Module.cachedSealedTypedModule + foundation + [Module.finalPreludeModule prelude] + installation) + assertEqual "cached contextual semantic target" + semantic + (Module.sealedTypedModuleSemantic cached) + + runsBeforeConsumer <- readIORef runs + consumerWorkspace <- + parseFinalExactWorkspace prelude mounts + "test/phase5/exact-contextual-abbreviation-consumer.tex" + let consumerParsed = + Parse.parsedWorkspaceRootModule consumerWorkspace + consumerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + consumerParsed + [cached]) + consumer <- Module.runTypedModule consumerInput >>= \case + Module.TypedModuleSucceeded sealedConsumer -> + pure sealedConsumer + Module.TypedModuleOpenFailed failure -> + assertFailure + ("contextual consumer did not open: " <> show failure) + >> fail "unreachable" + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("contextual consumer did not seal: " <> show failure) + >> fail "unreachable" + let consumerTargets = + [ Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding) + | delta <- localSemanticDeltas consumer + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + ] + assertEqual "two contextual consumer declarations" 2 + (length consumerTargets) + void + (sole + "quantified contextual binder matches its explicit parameter" + (nubOrd consumerTargets)) + runsAfterConsumer <- readIORef runs + assertEqual "contextual abbreviations require no prover call" + runsBeforeConsumer runsAfterConsumer + + verifyFailure foundation resolver prelude mounts sealed + "test/phase5/exact-contextual-abbreviation-missing.tex" + (\case + Exact.ExactContextualExpansionNotAvailable location _key -> + assertEqual "missing context line" 5 (locLine location) + failure -> + assertFailure + ("unexpected missing-context failure: " + <> show failure)) + verifyFailure foundation resolver prelude mounts sealed + "test/phase5/exact-contextual-abbreviation-ambiguous.tex" + (\case + Exact.ExactStructureOperationAmbiguous + location _symbol objects -> do + assertEqual "ambiguous operation line" 16 + (locLine location) + assertEqual "two distinct operation objects" 2 + (length objects) + failure -> + assertFailure + ("unexpected operation ambiguity failure: " + <> show failure)) + where + assertReflexiveFact batches marker = do + batch <- maybe + (assertFailure ("missing contextual fact " <> marker) + >> fail "unreachable") + pure + (find + (elem (Semantic.semanticName (StrictText.pack marker)) + . fmap Semantic.semanticAliasName + . Semantic.declarationDeltaAliases + . Declaration.committedBatchDelta) + batches) + proposition <- sole (marker <> " proposition") + (Declaration.committedBatchPropositions batch) + let body = stripClaimEnvelope + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) + case body of + Core.CEq _ left right -> + assertEqual (marker <> " canonical sides") left right + _ -> + assertFailure + (marker <> " did not elaborate to reflexive equality: " + <> show body) + + stripClaimEnvelope = \case + Core.CForall _ body -> stripClaimEnvelope body + Core.CImp _ body -> stripClaimEnvelope body + term -> term + + verifyFailure foundation resolver prelude mounts imported relative checkFailure = do + workspace <- parseFinalExactWorkspace prelude mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + parsed + [imported]) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed failure)) + _prefix -> + checkFailure failure + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed failure))) + _prefix -> + checkFailure failure + Module.TypedModuleSucceeded{} -> + assertFailure (relative <> " was unexpectedly accepted") + Module.TypedModuleOpenFailed failure -> + assertFailure + (relative <> " did not open: " <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + (relative <> " failed unexpectedly: " <> show failure) + +rejectsUnknownExactStructureParent :: Assertion +rejectsUnknownExactStructureParent = + Temp.withSystemTempDirectory "felix-exact-structure-parent" \root -> do + let relative = "entry.tex" + path = root Posix. relative + source = + "\\begin{struct}\\label{known_structure}\n" + <> " A known structure $X$ is a onesorted structure.\n" + <> "\\end{struct}\n\n" + <> "\\begin{struct}\\label{invalid_structure}\n" + <> " An invalid structure $X$ is a future structure.\n" + <> "\\end{struct}\n\n" + <> "\\begin{struct}\\label{future_structure}\n" + <> " A future structure $X$ is a onesorted structure.\n" + <> "\\end{struct}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-exact-structure-store" \directory -> do + let storePath = directory Posix. "store.sqlite" + executable = directory Posix. "vampire" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + mounts <- exactFixtureMounts root + workspace <- parseFinalExactWorkspace prelude mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactStructureNotVisible + location _phrase))) + prefix -> do + assertEqual "unknown parent line" 5 (locLine location) + assertEqual "only the valid structure was published" + 1 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "unknown structure parent was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid structure module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected invalid structure failure: " + <> show failure) + +compilesExactRelationExpressions :: Assertion +compilesExactRelationExpressions = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-relation-expression.tex" + observed <- newIORef [] + withAcceptedFixtureVampire "felix-exact-relation-expression" \prover -> do + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observed + (<> [ [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ]) + (Provers.runPreparedTypedProver prover prepared) + void + (compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace) + assertEqual + "relation expression is ordered-pair membership" + [[True]] + =<< readIORef observed + + missingPair <- + withAcceptedFixtureVampire "felix-exact-relation-expression-missing-pair" \prover -> + (checkFileFresh + prover + "test/phase5/exact-relation-expression-missing-pair.tex") + case missingPair of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactGlobalNotVisible location key)))) + prefix) + , _slowReport + ) -> do + assertEqual "missing ordered-pair provider line" + 2 + (locLine location) + assertEqual "missing ordered-pair semantic key" + (Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol)) + key + assertEqual "missing provider publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected relation-expression failure: " <> show err) + Right{} -> + assertFailure "relation expression without ordered pairing was admitted" + +resolvesSourceOwnedApplication :: Assertion +resolvesSourceOwnedApplication = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + withAcceptedFixtureVampire "felix-exact-application" \prover -> + Temp.withSystemTempDirectory "felix-exact-application" \directory -> do + let storePath = directory Posix. "store.sqlite" + resolver = Declaration.vampireResolver + (Provers.runPreparedTypedProver prover) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + store foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-application.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + root <- case reverse sealed of + rootModule : _ -> pure rootModule + [] -> + assertFailure "application fixture root is absent" + >> fail "unreachable" + assertTransparentObjectAlias root "phase5_apply" + let applyKey = Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.ApplySymbol) + applyObject <- localObjectKeyTarget root applyKey + surface <- checkedPropositionTermByAlias + root "phase5_application_surface" + explicit <- checkedPropositionTermByAlias + root "phase5_application_explicit" + assertEqual + "surface and explicit application lower identically" + explicit + surface + assertBool + "surface application resolves through the declared object" + (applyObject `Set.member` Core.frozenCoreGlobals surface) + + missing <- + withAcceptedFixtureVampire "felix-exact-application-missing" + \prover -> + (checkFileFresh + prover + "test/phase5/exact-application-missing.tex") + case missing of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactGlobalNotVisible location key)))) + prefix) + , _slowReport + ) -> do + assertEqual "unresolved application line" 2 (locLine location) + assertEqual "unresolved application key" + (Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.ApplySymbol)) + key + assertEqual "unresolved application publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left failure -> + assertFailure + ("unexpected unresolved application failure: " <> show failure) + Right{} -> + assertFailure "application without its source binding was admitted" + +confinesExactQuantifiedTerms :: Assertion +confinesExactQuantifiedTerms = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + withAcceptedFixtureVampire "felix-exact-quantified-subject" \prover -> + Temp.withSystemTempDirectory "felix-quantified-subject" \directory -> do + let storePath = directory Posix. "store.sqlite" + resolver = Declaration.vampireResolver + (Provers.runPreparedTypedProver prover) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + store foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts + "test/phase5/exact-quantified-subject.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + root <- case reverse sealed of + rootModule : _ -> pure rootModule + [] -> + assertFailure "quantified-subject root is absent" + >> fail "unreachable" + quantified <- checkedPropositionTermByAlias root + "phase5_quantified_subject" + explicit <- checkedPropositionTermByAlias root + "phase5_explicit_quantifier" + assertEqual + "quantified noun subject retains its domain constraint" + explicit + quantified + + propositionWorkspace <- parseFinalExactWorkspace + prelude mounts + "test/phase5/exact-quantified-proposition-terms.tex" + observations <- newIORef [] + let observingResolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem + prepared + request = + Provers.preparedTypedProverRequest + prepared + modifyIORef' observations + (<> [ ( Provers.preparedVerificationRequestId + request + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + , Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries + problem) + ) + ]) + (Provers.runPreparedTypedProver + prover prepared) + freshModules <- + compileFinalParsedWorkspaceWithResolver + foundation prelude observingResolver + propositionWorkspace + freshRoot <- case reverse freshModules of + rootModule : _ -> pure rootModule + [] -> + assertFailure + "quantified proposition-term root is absent" + >> fail "unreachable" + let member left right = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) left) + right + memberAtX = + member (Core.CBound 0) (Core.CBound 1) + expectedFunctionTarget = + Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)) + expectedVerbRequestTarget = + Core.CForall Core.TySet + (Core.CImp memberAtX memberAtX) + expectedVerbProposition = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp memberAtX memberAtX)) + expectedTargets = + [ expectedFunctionTarget + , expectedVerbRequestTarget + ] + ordinaryImplicitAuxiliaries = + [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + , Foundation.PowerSetCharacteristic + ] + freshObservations <- readIORef observations + assertEqual + "nested function and verb terms have exact FOF targets" + [ ( target + , Backend.RouteFof + , ordinaryImplicitAuxiliaries + ) + | target <- expectedTargets + ] + [ (target, route, auxiliaries) + | (_request, target, route, auxiliaries) <- + freshObservations + ] + functionTarget <- checkedPropositionTermByAlias freshRoot + "phase5_quantified_function_argument" + verbTarget <- checkedPropositionTermByAlias freshRoot + "phase5_quantified_verb_argument" + assertEqual "nested function proposition core" + expectedFunctionTarget + (Core.frozenCoreTerm functionTarget) + assertEqual "nested verb proposition core" + expectedVerbProposition + (Core.frozenCoreTerm verbTarget) + let proofRecords moduleValue = + concatMap + Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue)) + proofAuthorizations moduleValue = + Authority.validationDirectAuthorization + . Semantic.proofValidationRecordCertificate + <$> proofRecords moduleValue + case proofAuthorizations freshRoot of + [ Authority.CheckedSourceProof [_functionRequest] + , Authority.CheckedSourceProof [_verbRequest] + ] -> pure () + authorizations -> + assertFailure + ("unexpected quantified-term authority: " + <> show authorizations) + assertBool + "quantified terms add no escape-backed authority" + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + (concatMap + (Semantic.declarationDeltaFacts + . Declaration.committedBatchDelta) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix freshRoot)))) + + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithReadiness + foundation + (Module.finalPreludeReadiness prelude) + unusedResolver + validation + propositionWorkspace + warmRoot <- case reverse warmModules of + rootModule : _ -> pure rootModule + [] -> + assertFailure + "warm quantified proposition-term root is absent" + >> fail "unreachable" + assertEqual "fresh and warm quantified semantic interface" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic warmRoot) + assertEqual "fresh and warm quantified request authority" + (proofAuthorizations freshRoot) + (proofAuthorizations warmRoot) + assertEqual "fresh and warm quantified prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix freshRoot)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warmRoot)) + + negative <- + withAcceptedFixtureVampire "felix-exact-quantified-term-valued" + \prover -> + (checkFileFresh + prover + "test/phase5/exact-quantified-term-valued.tex") + case negative of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactQuantifiedTermRequiresPropositionContext + location))) + prefix) + , _slowReport + ) -> do + assertEqual "term-valued quantified term line" + 2 (locLine location) + assertBool "failed term-valued abbreviation publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + Left failure -> + assertFailure + ("unexpected term-valued quantified-term failure: " + <> show failure) + Right{} -> + assertFailure "term-valued quantified exact term was admitted" + +closesExactDefinitionDeclarationBoundary :: Assertion +closesExactDefinitionDeclarationBoundary = do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + repositoryMounts <- exactFixtureMounts repository + Temp.withSystemTempDirectory "felix-definition-boundary" \directory -> do + mounts <- exactFixtureMounts directory + annotatedText <- + readFile + (repository Posix. + "test/phase5/exact-definition-boundary.tex") + let relative = "entry.tex" + sourcePath = directory Posix. relative + unannotatedText = + StrictText.unpack + (StrictText.replace + "A set " + "" + (StrictText.pack annotatedText)) + writeFile sourcePath annotatedText + annotatedWorkspace <- + parseExactWorkspace bootstrap mounts relative + annotated <- sole "annotated definition module" + =<< compileParsedWorkspace + foundation bootstrap annotatedWorkspace + assertEqual "annotated definition declaration count" + 4 + (length + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated))) + assertBool "annotated definitions prepare no Vampire validations" + (null (proofValidationRecords annotated)) + let annotatedBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated) + symbolicBatch <- sole "symbolic primary declaration" + (take 1 (drop 2 annotatedBatches)) + wrapperBatch <- sole "functional wrapper declaration" + (take 1 (drop 3 annotatedBatches)) + symbolicObject <- bindingObject "symbolic primary" symbolicBatch + wrapperObject <- bindingObject "functional wrapper" wrapperBatch + wrapperContent <- sole "functional wrapper transparent object" + [ Identity.assertedObjectContent object + | batch <- + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated) + , object <- Declaration.committedBatchObjects batch + , Identity.assertedObjectId object == wrapperObject + ] + case wrapperContent of + Identity.TransparentObjectContent _theory _type body -> + assertEqual + "functional wrapper applies the primary symbolic object" + (Set.singleton symbolicObject) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("functional wrapper is not transparent: " <> show content) + + writeFile sourcePath unannotatedText + unannotatedWorkspace <- + parseExactWorkspace bootstrap mounts relative + unannotated <- sole "unannotated definition module" + =<< compileParsedWorkspace + foundation bootstrap unannotatedWorkspace + assertEqual + "canonical set annotations do not change the semantic interface" + (Module.sealedTypedModuleSemantic unannotated) + (Module.sealedTypedModuleSemantic annotated) + assertEqual + "canonical set annotations do not change declaration identity" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix unannotated)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix annotated)) + assertEqual + "canonical set annotations do not change direct authority" + (directDeclarationAuthorizations unannotated) + (directDeclarationAuthorizations annotated) + + let storePath = directory Posix. "store.sqlite" + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix annotated)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warm <- sole "warm annotated definition module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver validation + annotatedWorkspace + assertEqual "warm annotated semantic interface" + (Module.sealedTypedModuleSemantic annotated) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm annotated declaration identity" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix annotated)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm annotated direct authority" + (directDeclarationAuthorizations annotated) + (directDeclarationAuthorizations warm) + assertBool "warm annotated definitions run no prover" + (null (proofValidationRecords warm)) + + annotationFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-annotation-failure.tex" + case annotationFailure of + ( Exact.ExactNonCanonicalSetDefinitionAnnotation location + , prefix + ) -> do + assertEqual "nontrivial annotation line" 2 (locLine location) + assertBool "nontrivial annotation publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "annotation diagnostic gives the explicit migration" + ("total condition in the definiens" + `StrictText.isInfixOf` + Exact.renderExactCompileError + (fst annotationFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected annotation failure: " <> show failure) + + aliasFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-alias-failure.tex" + case aliasFailure of + (Exact.ExactDefinitionCombinedSymbolicAlias location, prefix) -> do + assertEqual "combined symbolic alias line" 2 (locLine location) + assertBool "combined symbolic alias publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "combined alias diagnostic gives the wrapper migration" + ("define the symbolic operator first" + `StrictText.isInfixOf` + Exact.renderExactCompileError (fst aliasFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected combined-alias failure: " <> show failure) + + guardFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-guard-failure.tex" + case guardFailure of + (Exact.ExactGuardedTransparentDefinition location, prefix) -> do + assertEqual "guarded definition line" 2 (locLine location) + assertBool "guarded definition publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "guard diagnostic gives the total-definition migration" + ("where a corresponding opaque signature form exists" + `StrictText.isInfixOf` + Exact.renderExactCompileError (fst guardFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected guarded-definition failure: " <> show failure) + + assertRussellSetAnnotation bootstrap repository + where + proofValidationRecords moduleValue = + concatMap + Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue)) + + directDeclarationAuthorizations moduleValue = + [ Authority.validationDirectAuthorization certificate + | batch <- + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue) + , validation <- + maybeToList + (Declaration.committedBatchDeclarationValidation batch) + , certificate <- + Semantic.declarationValidationRecordCertificates validation + ] + + bindingObject label batch = do + binding <- sole (label <> " semantic binding") + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment + (Declaration.committedBatchDelta batch))) + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + + exactFailure foundation bootstrap mounts relative = do + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- sole "failed exact definition module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed failure)) + prefix -> + pure (failure, prefix) + result -> + assertFailure + (case result of + Module.TypedModuleSucceeded{} -> + "expected exact definition failure, but the module succeeded" + Module.TypedModuleOpenFailed{} -> + "expected exact definition failure, but the module did not open" + Module.TypedModuleFailed{} -> + "expected an exact compile failure, but checking failed differently") + >> fail "unreachable" + + assertRussellSetAnnotation bootstrap repository = do + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/examples/russell.tex" + parsed <- sole "Russell parity module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + case Parse.identifiedParsedModuleBlocks + (Module.identifiedModuleParsed + (Module.identifiedPhysicalModule parsed)) of + Raw.BlockDefn _location _title _marker + (Raw.Defn [] + (Raw.DefnAdj + (Just (Raw.NounPhrase + [] (Raw.Noun _ noun []) Nothing [] Nothing)) + _subject _adjective) + _statement) : _ -> + assertBool "Russell uses the canonical built-in set noun" + (Lexicon.isBuiltinSetNoun noun) + _ -> + assertFailure + "Russell source does not retain its annotated adjective head" + +compilesExactOrdinaryProofs :: Assertion +compilesExactOrdinaryProofs = + Temp.withSystemTempDirectory "felix-exact-proofs" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proofs.tex" + let executable = root Posix. "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = + Backend.typedProblemClaim problem + locals = + Backend.typedProblemLocalPremises problem + modifyIORef' observations + (<> [ ( Vector.length + (Backend.typedProblemGlobalPremises problem) + , Vector.length + locals + , [ Vector.length + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition premise)) + | premise <- Vector.toList locals + ] + , [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + sealed <- + compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + rootModule <- sole "exact proof root" (drop 1 sealed) + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix rootModule) + assertEqual "one definition and five theorem declarations" + 6 + (length batches) + let proofBatches = drop 1 batches + assertEqual "only closed theorem facts are published" + [1, 1, 1, 1, 1] + [ length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + | batch <- proofBatches + ] + assertEqual "proof request aggregation follows source structure" + [1, 2, 2, 1, 1] + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) of + Authority.CheckedSourceProof requests -> + length requests + authorization -> + error + ("unexpected exact proof authority: " + <> show authorization) + records -> + error + ("unexpected exact proof validation count: " + <> show (length records)) + | batch <- proofBatches + ] + headerBatch <- sole "header-envelope proof batch" + (take 1 (drop 3 proofBatches)) + headerProposition <- sole "header-envelope checked proposition" + (Declaration.committedBatchPropositions headerBatch) + assertEqual "header-envelope closed target" + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.CBound 1)) + (member + (Core.CBound 0) + (Core.CBound 1))))) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm headerProposition)) + headerFact <- sole "header-envelope published fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta headerBatch)) + assertEqual "header-envelope proof remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority headerFact)) + observed <- readIORef observations + case observed of + (implicitGlobals, 0, [], []) + : [ (0, 1, [1], _structuralMatches) + , (1, 2, [1, 1], _subclaimMatches) + , (0, 0, [], []) + , (0, 1, [1], _followingMatches) + , (0, 1, [2], [True]) + , (generalizedGlobals, 0, [], []) + ] -> do + assertBool "implicit Auto selects visible FOF facts" + (implicitGlobals > 0) + assertBool "generalized Auto selects visible FOF facts" + (generalizedGlobals > 0) + _ -> + assertFailure + ("unexpected exact proof premise policies: " + <> show observed) + where + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + +restoresExactBinderAndWitnessProofForms :: Assertion +restoresExactBinderAndWitnessProofForms = + Temp.withSystemTempDirectory "felix-exact-proof-parity" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-parity.tex" + parsed <- sole "parsed proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claims = [claim | claim@Raw.BlockClaim{} <- blocks] + proofs = + [ proof + | Raw.BlockProof _location proof _end <- blocks + ] + omittedClaim <- + case reverse claims of + claim : _ -> pure claim + [] -> assertFailure "missing omitted witness claim" + >> fail "unreachable" + omittedProof <- + case reverse proofs of + proof : _ -> pure proof + [] -> assertFailure "missing omitted witness proof" + >> fail "unreachable" + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + omittedClaim (Just omittedProof)) + >>= either Declaration.failModuleDriver pure + >>= \case + Right (Declaration.DriverSucceeded + prepared _semantic _prefix _closure) -> + case ExactProof.preparedExactProofFirstOmission prepared of + Just location -> + assertEqual "nested Take retains first omission" + 106 (locLine location) + Nothing -> + assertFailure "nested Take lost its omission" + Right Declaration.DriverFailed{} -> + assertFailure "omitted witness preparation failed" + Right Declaration.DriverSealFailed{} -> + assertFailure "omitted witness preparation did not seal" + Left failure -> + assertFailure + ("omitted witness preparation did not open: " + <> show failure) + let executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof-parity'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + fresh <- + sole "proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingAcceptedResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "restored proof request count" 17 (length observed) + assertEqual + "restored proof declarations preserve discharge order" + [1, 1, 1, 1, 1, 1, 3, 2, 2, 3, 1] + (proofRequestCounts fresh) + case observed of + first : second : third : fourth : _rest -> do + assertGuardRequest "single bounded fix" 2 first + assertGuardRequest "multiple bounded fix" 3 second + assertGuardRequest "negative bounded fix" 2 third + assertGuardRequest "fix such that" 2 fourth + _ -> assertFailure "missing bounded-fix requests" + case drop 4 observed of + leftFirst : rightFirst : _ -> do + assertSequentialAssumptions "left conjunct first" leftFirst + assertSequentialAssumptions "right conjunct first" rightFirst + _ -> assertFailure "missing conjunction-assumption requests" + assertTakeSequence "bounded TakeVar" (drop 6 observed) + assertTakeSequence "existential Have" (drop 13 observed) + case drop 9 observed of + namedDischarge : _namedFinal : anonymousDischarge : _ -> do + assertExactDischarge "named noun" namedDischarge + assertEqual "named noun opens two witness binders" + 2 + (leadingExistentials + (observedClaimTerm namedDischarge)) + assertExactDischarge "anonymous noun" anonymousDischarge + assertEqual "anonymous noun opens one unnameable binder" + 1 + (leadingExistentials + (observedClaimTerm anonymousDischarge)) + _ -> assertFailure "missing noun-witness requests" + lastBatch <- + case reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) of + batch : _ -> pure batch + [] -> assertFailure "missing restored-proof batches" + >> fail "unreachable" + lastFact <- sole "omitted witness fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta lastBatch)) + assertEqual "omitted continuation remains escape-backed" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority lastFact)) + assertBool "proof-local witnesses publish no objects" + (all + (null . Declaration.committedBatchObjects) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh))) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm restored proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual + "fresh and warm proof validation keys and authority" + (proofValidationRecords fresh) + (proofValidationRecords warm) + assertEqual + "fresh and warm checked proposition identities" + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm)))) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix-shape.tex" + (\case + ExactProof.ExactProofExpectedUniversalGoal location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-assume.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + where + observingAcceptedResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + ProofParityObservation + (snd <$> Vector.toList + (Backend.supportedPropositionSupport claim)) + (Backend.supportedPropositionTerm claim) + [ ( Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + , snd <$> Vector.toList + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition + premise)) + , Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + ) + | premise <- Vector.toList locals + ] + modifyIORef' observations (<> [observation]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + assertGuardRequest label supportCount observation = do + assertEqual (label <> " support") + supportCount + (length (observedClaimSupport observation)) + case observedLocals observation of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact guard") + (observedClaimTerm observation) + local + locals -> + assertFailure + (label <> ": expected one guard, found " + <> show (length locals)) + + assertTakeSequence label observations = + case observations of + discharge : continuation : _ -> do + assertExactDischarge label discharge + assertEqual (label <> " continuation premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- + observedLocals continuation + ] + assertEqual (label <> " continuation witness support") + 2 + (length (observedClaimSupport continuation)) + _ -> assertFailure (label <> ": missing request sequence") + + assertSequentialAssumptions label observation = do + assertEqual (label <> " premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- observedLocals observation + ] + case observedLocals observation of + (_ordinal, _support, first) : _ -> + assertEqual (label <> " retained source order") + (observedClaimTerm observation) + first + [] -> assertFailure (label <> ": no scoped assumptions") + + assertExactDischarge label discharge = + case observedLocals discharge of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact existential discharge") + (observedClaimTerm discharge) + local + locals -> + assertFailure + (label <> ": unexpected discharge premises " + <> show (length locals)) + + proofRequestCounts sealed = + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) of + Authority.CheckedSourceProof requests -> length requests + Authority.OmittedAuthorization -> 1 + authorization -> + error ("unexpected restored-proof authority: " + <> show authorization) + records -> + error ("unexpected restored-proof validation count: " + <> show (length records)) + | batch <- Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + ] + + proofValidationRecords sealed = + concatMap Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + + leadingExistentials + :: Core.CanonicalTerm Identity.ObjectId + -> Int + leadingExistentials = \case + Core.CImp + (Core.CForall Core.TySet + (Core.CImp body Core.CFalsum)) + Core.CFalsum -> + 1 + leadingExistentials body + _ -> 0 + +data ProofParityObservation = ProofParityObservation + { observedClaimSupport :: ![Core.CoreType] + , observedClaimTerm :: !(Core.CanonicalTerm Identity.ObjectId) + , observedLocals :: + ![(Natural, [Core.CoreType], Core.CanonicalTerm Identity.ObjectId)] + } + +restoresExactLocalReasoningAndCalculations :: Assertion +restoresExactLocalReasoningAndCalculations = + Temp.withSystemTempDirectory "felix-exact-local-reasoning" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-local-reasoning.tex" + let executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + writeAcceptedFixtureVampire executable + observations <- newIORef [] + fresh <- + sole "exact local-reasoning module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "local-reasoning request count" 16 (length observed) + assertEqual "proof forms retain source request order" + [2, 3, 3, 2, 2, 3, 1] + (requestCounts fresh) + case observed of + sufficesImplication : sufficesReduction + : equalityFirst : equalitySecond : equalityContinuation + : biconditionalFirst : biconditionalSecond + : biconditionalContinuation + : quantifiedLink : quantifiedContinuation + : sinceStructuralClaim : sinceStructuralContinuation + : sinceDischarge : sinceClaim : sinceContinuation + : _omittedSufficesImplication + : [] -> do + case localReasoningTarget sufficesImplication of + Core.CImp antecedent conclusion -> do + assertEqual + "Suffices implication starts from the reduction" + (localReasoningTarget sufficesReduction) + antecedent + assertBool + "Suffices keeps its distinct current goal as conclusion" + (conclusion /= antecedent) + implication -> + assertFailure + ("expected Suffices implication, found " + <> show implication) + assertEqual "first equality link uses its destination citation" + 1 (localReasoningGlobalCount equalityFirst) + assertEqual "second equality link uses local-only justification" + 0 (localReasoningGlobalCount equalitySecond) + assertDerivedContinuation + "equality calculation" + [0, 1] + (localReasoningTarget equalityContinuation) + equalityContinuation + assertPairwiseDistinct + "equality links and endpoint" + [ localReasoningTarget equalityFirst + , localReasoningTarget equalitySecond + , localReasoningTarget equalityContinuation + ] + assertEqual "first biconditional link remains proposition equality" + Core.TyProp + (equalityOperandType + (localReasoningTarget biconditionalFirst)) + assertDerivedContinuation + "biconditional calculation" + [0] + (localReasoningTarget biconditionalContinuation) + biconditionalContinuation + assertPairwiseDistinct + "biconditional links and endpoint" + [ localReasoningTarget biconditionalFirst + , localReasoningTarget biconditionalSecond + , localReasoningTarget biconditionalContinuation + ] + assertEqual "quantified calculation closes both binders" + 2 + (leadingForalls + (localReasoningTarget quantifiedLink)) + assertQuantifiedCalculationGuard + (localReasoningTarget quantifiedLink) + assertDerivedContinuation + "quantified calculation" + [0] + (localReasoningTarget quantifiedLink) + quantifiedContinuation + assertEqual + "quantified source goal and derived local retain the same guard shape" + (quantifiedCalculationShape + (localReasoningTarget quantifiedContinuation)) + (quantifiedCalculationShape + (localReasoningTarget quantifiedLink)) + assertQuantifiedCalculationGuard + (localReasoningTarget quantifiedContinuation) + assertEqual "structural Since submits no premise discharge" + [0] + (localReasoningLocalOrdinals sinceStructuralClaim) + assertEqual "structural Since does not duplicate its premise" + [0, 1] + (localReasoningLocalOrdinals + sinceStructuralContinuation) + assertEqual "ATP-backed Since starts from existing locals only" + [0] + (localReasoningLocalOrdinals sinceDischarge) + assertEqual "Since claim sees the admitted discourse premise" + [0, 1] + (localReasoningLocalOrdinals sinceClaim) + assertEqual "Since continuation sees premise then claim" + [0, 1, 2] + (localReasoningLocalOrdinals sinceContinuation) + assertEqual "local-only Since requests select no globals" + [0, 0, 0] + (localReasoningGlobalCount + <$> [sinceDischarge, sinceClaim, sinceContinuation]) + assertEqual "biconditional second link keeps local-only policy" + 0 (localReasoningGlobalCount biconditionalSecond) + _ -> + assertFailure + ("unexpected local-reasoning observations: " + <> show observed) + omittedBatch <- sole "omitted Suffices batch" + (take 1 + (reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + omittedFact <- sole "omitted Suffices fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta omittedBatch)) + assertEqual "Suffices continuation omission reaches final authority" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority omittedFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm local-reasoning module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm local-reasoning validation skips Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm local-reasoning validations" + (validationRecords fresh) + (validationRecords warm) + + assertRejectedPrefix + "Suffices implication failure" foundation bootstrap workspace + executable 0 0 1 + assertRejectedPrefix + "Suffices reduction failure" foundation bootstrap workspace + executable 1 0 2 + assertRejectedPrefix + "middle calculation link failure" foundation bootstrap workspace + executable 3 1 4 + where + observingResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + LocalReasoningObservation + { localReasoningTarget = + Backend.supportedPropositionTerm claim + , localReasoningGlobalCount = Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + [ Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + | premise <- Vector.toList locals + ] + , localReasoningLocalTerms = + [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + | premise <- Vector.toList locals + ] + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + modifyIORef' observations (<> [observation]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + requestCounts sealed = + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) of + Authority.CheckedSourceProof requests -> length requests + Authority.OmittedAuthorization -> 1 + direct -> error + ("unexpected local-reasoning authority: " <> show direct) + records -> error + ("unexpected local-reasoning validation count: " + <> show (length records)) + | batch <- Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + ] + + validationRecords = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + + assertDerivedContinuation + label expectedOrdinals expectedEndpoint continuation = do + assertEqual (label <> " local source ordinals") + expectedOrdinals + (localReasoningLocalOrdinals continuation) + case reverse (localReasoningLocalTerms continuation) of + derived : _ -> + assertEqual (label <> " derived endpoint") + expectedEndpoint derived + [] -> + assertFailure + (label <> ": continuation has no derived endpoint") + + assertPairwiseDistinct label terms = + assertEqual (label <> ": " <> show terms) + (length terms) + (Set.size (Set.fromList terms)) + + assertQuantifiedCalculationGuard proposition = + case dropForalls 2 proposition of + Core.CImp constraint endpoint -> do + assertEqual "quantified guard retains both membership bounds" + 2 (countIntrinsic Core.Member constraint) + assertEqual "quantified guard retains its such-that equality" + 1 (countSetEqualities constraint) + case endpoint of + Core.CEq Core.TySet (Core.CBound left) (Core.CBound right) -> + assertBool "quantified endpoint keeps asymmetric binders" + (left /= right) + _ -> + assertFailure + ("unexpected quantified endpoint: " <> show endpoint) + target -> + assertFailure + ("expected quantified guarded implication, found " + <> show target) + + quantifiedCalculationShape proposition = + case dropForalls 2 proposition of + Core.CImp constraint endpoint -> + Just + ( countIntrinsic Core.Member constraint + , countSetEqualities constraint + , endpoint + ) + _ -> Nothing + + dropForalls + :: Int + -> Core.CanonicalTerm Identity.ObjectId + -> Core.CanonicalTerm Identity.ObjectId + dropForalls 0 term = term + dropForalls remaining (Core.CForall _binder body) = + dropForalls (remaining - 1) body + dropForalls _remaining term = term + + countIntrinsic + :: Core.CoreIntrinsicTag + -> Core.CanonicalTerm Identity.ObjectId + -> Int + countIntrinsic intrinsic = \case + Core.CBound{} -> 0 + Core.CGlobal{} -> 0 + Core.CIntrinsic found -> fromEnum (found == intrinsic) + Core.COpaqueInteger{} -> 0 + Core.CApp function argument -> + countIntrinsic intrinsic function + + countIntrinsic intrinsic argument + Core.CLam _binder body -> countIntrinsic intrinsic body + Core.CFalsum -> 0 + Core.CImp premise conclusion -> + countIntrinsic intrinsic premise + + countIntrinsic intrinsic conclusion + Core.CEq _operand left right -> + countIntrinsic intrinsic left + + countIntrinsic intrinsic right + Core.CForall _binder body -> countIntrinsic intrinsic body + + countSetEqualities + :: Core.CanonicalTerm Identity.ObjectId + -> Int + countSetEqualities = \case + Core.CBound{} -> 0 + Core.CGlobal{} -> 0 + Core.CIntrinsic{} -> 0 + Core.COpaqueInteger{} -> 0 + Core.CApp function argument -> + countSetEqualities function + countSetEqualities argument + Core.CLam _binder body -> countSetEqualities body + Core.CFalsum -> 0 + Core.CImp premise conclusion -> + countSetEqualities premise + countSetEqualities conclusion + Core.CEq operand left right -> + fromEnum (operand == Core.TySet) + + countSetEqualities left + + countSetEqualities right + Core.CForall _binder body -> countSetEqualities body + + equalityOperandType = \case + Core.CEq operandType _left _right -> operandType + term -> error ("expected checked equality, found " <> show term) + + leadingForalls + :: Core.CanonicalTerm Identity.ObjectId + -> Int + leadingForalls = \case + Core.CForall _binder body -> 1 + leadingForalls body + _ -> 0 + + assertRejectedPrefix + label foundation bootstrap workspace executable rejectedIndex + expectedPrefix expectedRuns = do + runs <- newIORef (0 :: Int) + parsed <- sole (label <> " parsed module") + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let resolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' runs \current -> + (current + 1, current) + if index == rejectedIndex + then pure + (Right + (Provers.CounterSatisfiable + "focused deterministic rejection")) + else + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed _failure prefix -> + assertEqual + (label <> " publishes only the prior prefix") + expectedPrefix + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure (label <> " unexpectedly succeeded") + Module.TypedModuleOpenFailed failure -> + assertFailure + (label <> " did not open: " <> show failure) + assertEqual (label <> " selects the first rejected request") + expectedRuns =<< readIORef runs + +data LocalReasoningObservation = LocalReasoningObservation + { localReasoningTarget :: !(Core.CanonicalTerm Identity.ObjectId) + , localReasoningGlobalCount :: !Int + , localReasoningLocalOrdinals :: ![Natural] + , localReasoningLocalTerms :: + ![Core.CanonicalTerm Identity.ObjectId] + , localReasoningAuxiliaries :: ![Foundation.FoundationAxiomTag] + } + deriving (Show) + +selectsCalculationLinkFailureBySourceOrder :: Assertion +selectsCalculationLinkFailureBySourceOrder = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-calculation-link-order" \root -> do + let executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + source = "test/phase7/calculation-link-order.tex" + laterCompleted = root Posix. "later-completed" + firstRun = root Posix. "first-run" + secondRun = root Posix. "second-run" + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + prover + "test/phase3/typed-unsupported.tex") + >>= expectRight) + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "if mkdir \"" <> firstRun <> "\" 2>/dev/null; then" + , " printf '%s\\n' '% SZS status Theorem for calculation-link-order'" + , "elif mkdir \"" <> secondRun <> "\" 2>/dev/null; then" + , " : > \"" <> laterCompleted <> "\"" + , " printf '%s\\n' '% SZS status Theorem for calculation-link-order'" + , "else" + , " printf '%s\\n' '% SZS status CounterSatisfiable for calculation-link-order'" + , "fi" + ]) + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + jobs <- + Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + positions <- newIORef [] + middleStarted <- newEmptyTMVarIO + laterStarted <- newEmptyTMVarIO + releaseMiddle <- newEmptyTMVarIO + let observer = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + modifyIORef' positions (position :) + case ordinal of + 1 -> pure () + 2 -> do + atomically (putTMVar middleStarted ()) + atomically (takeTMVar releaseMiddle) + 3 -> atomically (putTMVar laterStarted ()) + _ -> + assertFailure + ("unexpected calculation request ordinal: " + <> show ordinal) + withAsync + ( + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + prover + source) + >>= expectRight) + \verification -> do + void + (awaitTmvar "middle calculation link" middleStarted) + void + (awaitTmvar "later calculation continuation" laterStarted) + waitForFileSignal + "later calculation continuation" laterCompleted + atomically (putTMVar releaseMiddle ()) + (result, _slowReport) <- wait verification + case result of + Verification.VerificationFailure report failed -> do + assertEqual "middle link failure location" + (source, 10) + ( locFile + (Verification.failedVerificationLocation failed) + , locLine + (Verification.failedVerificationLocation failed) + ) + assertEqual "failed calculation admits no source fact" + [] (Verification.verificationDirectEscapes report) + other -> + assertFailure + ("calculation link order did not reject: " + <> show other) + observedPositions <- + fmap + (\position -> + ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal + position + )) + <$> readIORef positions + assertEqual "all calculation requests executed" + [(1, 1), (1, 2), (1, 3)] + (sort observedPositions) + + writeAcceptedFixtureVampire executable + retryPositions <- newIORef [] + let retryObserver = + Verification.verificationRequestObserver \position _request -> + modifyIORef' retryPositions (position :) + (retry, _retrySlowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + retryObserver + prover + source) + >>= expectRight + case retry of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("calculation rollback retry failed: " <> show other) + retryObserved <- readIORef retryPositions + assertEqual "retry executes the complete calculation proof" + 3 (length retryObserved) + where + awaitTmvar label variable = do + result <- Timeout.timeout 10000000 + (atomically (takeTMVar variable)) + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + +assertProofParityFailure + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> SourceMounts + -> FilePath + -> (ExactProof.ExactProofError -> Bool) + -> Assertion +assertProofParityFailure foundation bootstrap mounts relative matches = do + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- sole "invalid proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed failure)) + prefix -> do + assertBool ("unexpected proof failure: " <> show failure) + (matches failure) + assertBool "failing proof publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "invalid proof-parity module succeeded" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid proof-parity module did not open: " <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected proof-parity module failure: " <> show failure) + +compilesExactSeparationComprehensions :: Assertion +compilesExactSeparationComprehensions = + Temp.withSystemTempDirectory "felix-exact-separation" \root -> do + let relative = "test/phase5/exact-separation.tex" + executable = root Posix. "vampire" + failedSource = root Posix. relative + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace bootstrap mounts relative + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-separation'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + request = + Provers.preparedTypedProverRequest prepared + globals = + Backend.typedProblemGlobalPremises problem + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedBackendFactReference <$> globals + , all + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> True + Backend.RequiresTh0{} -> False) + globals + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList + (Backend.typedProblemLocalPremises problem) + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + , Provers.preparedVerificationRequestId request + , Provers.preparedVerificationByteCount request + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact separation module" modules + assertExactSeparationModule "fresh" sealed + definition <- batchByAlias + (Module.sealedTypedModulePrefix sealed) + "phase5_separation_definition" + let definitionFacts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definition) + extensional <- sole "searchable separation view" + [ Semantic.semanticFactFingerprint occurrence + | occurrence <- definitionFacts + , Semantic.semanticFactSearchEligibility occurrence + == Semantic.SearchEligible + ] + equation <- sole "explicit separation equation" + [ Semantic.semanticFactFingerprint occurrence + | occurrence <- definitionFacts + , Semantic.semanticFactSearchEligibility occurrence + == Semantic.SearchIneligible + ] + readIORef observations >>= \case + [ ( Backend.RouteFof + , selectedGlobals + , True + , [0] + , [] + , _requestId + , requestBytes + ) ] -> do + assertBool "searchable separation view is selected" + (extensional `elem` selectedGlobals) + assertBool "exact separation equation is not selected" + (equation `notElem` selectedGlobals) + assertBool "separation exact request has bytes" + (requestBytes > 0) + observed -> + assertFailure + ("unexpected implicit separation problem: " + <> show observed) + + createDirectoryIfMissing True (Posix.takeDirectory failedSource) + original <- ByteString.readFile relative + let invalid = + Text.encodeUtf8 + (StrictText.replace + "x \\in A \\mid x = x" + "x \\in x \\mid x = x" + (Text.decodeUtf8 original)) + ByteString.writeFile failedSource invalid + failedMounts <- exactFixtureMounts root + failedWorkspace <- + parseExactWorkspace bootstrap failedMounts relative + let parsed = Parse.parsedWorkspaceRootModule failedWorkspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "x")))) + prefix -> do + assertEqual "invalid separation bound line" + 2 (locLine location) + assertEqual + "invalid separation publishes none of its declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "invalid separation was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid separation module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected invalid separation failure: " + <> show failure) + +compilesAndReusesProofLocalSetDefinitions :: Assertion +compilesAndReusesProofLocalSetDefinitions = + Temp.withSystemTempDirectory "felix-exact-local-definition" \root -> do + let relative = "test/phase5/exact-local-definition.tex" + failedRelative = + "test/phase5/exact-local-definition-failure.tex" + sourcePath = root Posix. relative + failedSourcePath = root Posix. failedRelative + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + createDirectoryIfMissing True (Posix.takeDirectory failedSourcePath) + ByteString.readFile failedRelative + >>= ByteString.writeFile failedSourcePath + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + freshRuns <- newIORef (0 :: Int) + observations <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRuns (+ 1) + let problem = + Provers.preparedTypedProverLogicalProblem prepared + premises = + Backend.typedProblemLocalPremises problem + definition = + Vector.find + ((== Backend.localPremiseOrdinal 0) + . Backend.typedLocalPremiseOrdinal) + premises + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList premises + , fmap localDefinitionShape definition + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + freshResolver + Declaration.FreshValidation + workspace + assertEqual "fresh local-definition discharge count" + 2 =<< readIORef freshRuns + assertEqual "implicit and local-only definition views" + [ (Backend.RouteFof, [0, 2], Just expectedLocalDefinitionShape) + , (Backend.RouteTh0, [0, 1, 3], Just expectedLocalDefinitionShape) + ] + =<< readIORef observations + fresh <- sole "fresh local-definition module" freshModules + localDefinitionBatch <- sole + "proof-local definition publishes one declaration" + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) + assertEqual "proof-local definition publishes no object" + [] + (Declaration.committedBatchObjects localDefinitionBatch) + assertEqual "proof-local definition publishes only its theorem" + 1 + (length + (Declaration.committedBatchPropositions + localDefinitionBatch)) + localDefinitionFact <- sole + "proof-local definition theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta + localDefinitionBatch)) + assertEqual "proof-local definition remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority localDefinitionFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm local-definition proof skips Vampire" + 0 =<< readIORef warmRuns + warm <- sole "warm local-definition module" warmModules + assertEqual "warm local-definition semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm local-definition prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + + failedWorkspace <- + parseExactWorkspace bootstrap mounts failedRelative + let failedParsed = + Parse.parsedWorkspaceRootModule failedWorkspace + failedInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + failedParsed + []) + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "B"))))) + prefix -> do + assertEqual "self-reference rejection line" + 6 (locLine location) + assertBool "failed local definition publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "self-referential local definition was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("local-definition failure fixture did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected local-definition failure: " + <> show failure) + where + localDefinitionShape premise = + let proposition = + Backend.typedLocalPremiseProposition premise + in ( fmap + snd + (Vector.toList + (Backend.supportedPropositionSupport proposition)) + , Backend.supportedPropositionTerm proposition + ) + + expectedLocalDefinitionShape = + ( [Core.TySet, Core.TySet] + , Core.CForall Core.TySet + (Core.CEq Core.TyProp + (member (Core.CBound 0) (Core.CBound 1)) + (andP + (member (Core.CBound 0) (Core.CBound 2)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + ) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + + andP left right = + Core.CImp + (Core.CImp left (Core.CImp right Core.CFalsum)) + Core.CFalsum + +compilesAndReusesProofLocalFunctionGraphs :: Assertion +compilesAndReusesProofLocalFunctionGraphs = + Temp.withSystemTempDirectory "felix-exact-local-function" \root -> do + let relative = "test/phase5/exact-local-function.tex" + failedRelative = + "test/phase5/exact-local-function-failure.tex" + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts relative + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + premises = + [ ( Backend.typedProblemRoute problem + , fmap snd + (Vector.toList + (Backend.supportedPropositionSupport + proposition)) + , Backend.supportedPropositionTerm proposition + ) + | premise <- + Vector.toList + (Backend.typedProblemLocalPremises problem) + , let proposition = + Backend.typedLocalPremiseProposition premise + ] + modifyIORef' observations (<> premises) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + allObserved <- readIORef observations + let observed = + [ (route, proposition) + | (route, support, proposition) <- allObserved + , support == [Core.TySet, Core.TySet] + , isJust (localFunctionPair proposition) + ] + assertBool + ("the local graph characteristic reaches a discharge: " + <> show allObserved) + (not (null observed)) + for_ observed \(route, proposition) -> do + assertEqual "local function characteristic stays on FOF" + Backend.RouteFof route + assertExactLocalFunctionCharacteristic proposition + freshRoot <- sole "fresh local-function root" + (take 1 (reverse freshModules)) + rootBatch <- sole "local function publishes only its theorem" + (drop 1 + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix freshRoot))) + assertEqual "local function publishes no object" + [] (Declaration.committedBatchObjects rootBatch) + assertEqual "local function publishes only its theorem" + 1 + (length + (Declaration.committedBatchPropositions rootBatch)) + assertEqual "local function publishes no semantic binding" + [] + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment + (Declaration.committedBatchDelta rootBatch))) + rootFact <- sole "local-function theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta rootBatch)) + assertEqual "local-function theorem remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority rootFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation workspace + assertEqual "warm local-function graph skips Vampire" + 0 =<< readIORef warmRuns + warmRoot <- sole "warm local-function root" + (take 1 (reverse warmModules)) + assertEqual "warm local-function semantic interface" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic warmRoot) + assertEqual "warm local-function prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix freshRoot)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warmRoot)) + + failedWorkspace <- + parseExactWorkspace bootstrap mounts failedRelative + failedInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failedWorkspace) + []) + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "f"))))) + prefix -> do + assertEqual "self-reference rejection line" + 6 (locLine location) + assertBool "failed local function publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "self-referential local function was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("local-function failure fixture did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected local-function failure: " + <> show failure) + where + assertExactLocalFunctionCharacteristic proposition = do + pair <- + maybe + (assertFailure "local function characteristic has wrong shape") + pure + (localFunctionPair proposition) + assertEqual "local function uses the exact replacement characteristic" + (expectedLocalFunctionCharacteristic pair) + proposition + + localFunctionPair proposition = + case Set.toList (Core.canonicalTermGlobals proposition) of + [pair] + | proposition == expectedLocalFunctionCharacteristic pair -> + Just pair + _ -> + Nothing + + expectedLocalFunctionCharacteristic pair = + Core.CForall Core.TySet + (Core.CEq Core.TyProp + (member (Core.CBound 0) (Core.CBound 1)) + (existsP + (andP + (member (Core.CBound 0) (Core.CBound 3)) + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CApp + (Core.CApp + (Core.CGlobal pair) + (Core.CBound 0)) + (Core.CBound 0)))))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + + andP left right = + notP (Core.CImp left (notP right)) + + existsP proposition = + notP (Core.CForall Core.TySet (notP proposition)) + + notP proposition = + Core.CImp proposition Core.CFalsum + +confinesTerminalExactContradiction :: Assertion +confinesTerminalExactContradiction = + Temp.withSystemTempDirectory "felix-exact-contradiction" \directory -> do + let acceptedExecutable = directory Posix. "accepted-vampire" + contradictoryExecutable = directory Posix. "contradictory-vampire" + storePath = directory Posix. "store.sqlite" + writeAcceptedFixtureVampire acceptedExecutable + writeFile contradictoryExecutable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status ContradictoryAxioms for exact-contradiction'" + ]) + permissions <- getPermissions contradictoryExecutable + setPermissions contradictoryExecutable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-cases-contradiction.tex" + assertEmptyCaseAstRejected foundation bootstrap workspace + observations <- newIORef [] + fresh <- + sole "cases and contradiction module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingResolver + acceptedExecutable + contradictoryExecutable + observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "cases and contradiction request count" + 8 (length observed) + case observed of + branchOne : branchTwo : branchThree : exhaustive + : byContradiction : arbitraryContradiction + : omittedLaterBranch : omittedExhaustive : [] -> do + assertEqual "case branches have isolated local ordinals" + [[0], [1], [2]] + (localReasoningLocalOrdinals + <$> [branchOne, branchTwo, branchThree]) + assertEqual "exhaustiveness sees pre-case locals only" + [] (localReasoningLocalOrdinals exhaustive) + case + ( localReasoningLocalTerms branchOne + , localReasoningLocalTerms branchTwo + , localReasoningLocalTerms branchThree + ) of + ([caseOne], [caseTwo], [caseThree]) -> + assertEqual + "case exhaustiveness is left-associated in source order" + (orP (orP caseOne caseTwo) caseThree) + (localReasoningTarget exhaustive) + branchTerms -> + assertFailure + ("unexpected branch-local premises: " + <> show branchTerms) + assertEqual "proof by contradiction targets falsum" + Core.CFalsum + (localReasoningTarget byContradiction) + assertBool + "double-negation elimination is not an ATP auxiliary" + (Foundation.DoubleNegationElim + `notElem` localReasoningAuxiliaries byContradiction) + case localReasoningLocalTerms byContradiction of + [Core.CImp negatedGoal Core.CFalsum] -> + assertEqual + "proof by contradiction assumes the exact negated goal" + (localReasoningTarget branchOne) + negatedGoal + locals -> + assertFailure + ("unexpected contradiction locals: " + <> show locals) + assertEqual "arbitrary terminal contradiction targets falsum" + Core.CFalsum + (localReasoningTarget arbitraryContradiction) + assertEqual "omitted case does not leak into its sibling" + [1] + (localReasoningLocalOrdinals omittedLaterBranch) + assertEqual "omitted exhaustiveness sees no branch local" + [] (localReasoningLocalOrdinals omittedExhaustive) + _ -> + assertFailure + ("unexpected cases/contradiction observations: " + <> show observed) + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh) of + [caseBatch, byContradictionBatch, terminalBatch, omittedBatch] -> do + traverse_ + (assertBatchSafety Authority.cleanAuthoritySafety) + [caseBatch, byContradictionBatch, terminalBatch] + assertBatchSafety + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + omittedBatch + batches -> + assertFailure + ("unexpected cases/contradiction declaration count: " + <> show (length batches)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm cases and contradiction module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver + acceptedExecutable warmRuns) + validation + workspace + assertEqual "warm structural proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm structural proof validations" + (proofValidations fresh) + (proofValidations warm) + + failureWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-case-failure.tex" + assertCaseFailure + "middle case branch" + foundation bootstrap failureWorkspace acceptedExecutable 1 2 + assertCaseFailure + "case exhaustiveness" + foundation bootstrap failureWorkspace acceptedExecutable 3 4 + + directWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-direct-contradictory.tex" + directParsed <- sole "direct contradictory parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter directWorkspace)) + directInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + (Declaration.vampireResolver + (runWith contradictoryExecutable)) + Declaration.FreshValidation + directParsed + []) + Module.runTypedModule directInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + _location + Declaration.VampireObligationRejected{})) + prefix -> + assertBool + "direct contradictory input publishes no theorem" + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "direct contradictory input was accepted" + where + observingResolver acceptedExecutable contradictoryExecutable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + target = Backend.supportedPropositionTerm claim + modifyIORef' observations + (<> [ LocalReasoningObservation + { localReasoningTarget = target + , localReasoningGlobalCount = + Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + [ Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + | premise <- Vector.toList locals + ] + , localReasoningLocalTerms = + Backend.supportedPropositionTerm + . Backend.typedLocalPremiseProposition + <$> Vector.toList locals + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + ]) + runWith + (if target == Core.CFalsum + then contradictoryExecutable + else acceptedExecutable) + prepared + + runWith executable prepared = + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + assertEmptyCaseAstRejected foundation bootstrap workspace = do + parsed <- sole "cases parsed module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claim <- sole "cases source claim" + [ candidate + | candidate@Raw.BlockClaim{} <- take 1 blocks + ] + location <- + case + [ found + | Raw.BlockProof _ (Raw.ByCase found _cases) _ <- blocks + ] of + found : _ -> pure found + [] -> + assertFailure "cases source proof is absent" + >> fail "unreachable" + let preludeModule = Module.bootstrapPreludeModule bootstrap + outcome <- Declaration.runModuleDriver + foundation + (moduleName (Parse.parsedModuleAddress parsed)) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic preludeModule) + ] + unusedResolver + Declaration.FreshValidation do + Declaration.importSealedModuleDriver + (Module.sealedTypedModuleEvidence preludeModule) + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + claim + (Just (Raw.ByCase location []))) + case outcome of + Right (Declaration.DriverSucceeded + (Left (ExactProof.ExactProofEmptyCaseSplit found)) + _semantic prefix _closure) -> do + assertEqual "empty case AST failure location" + location found + assertBool "empty case AST publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + _ -> + assertFailure "empty programmatic case split was not rejected" + + assertBatchSafety expected batch = do + fact <- sole "structural proof fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual "structural proof authority safety" + expected + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + + proofValidations = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + + assertCaseFailure + label foundation bootstrap workspace executable rejectedIndex + expectedRuns = do + runs <- newIORef (0 :: Int) + parsed <- sole (label <> " parsed module") + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let resolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' runs \current -> + (current + 1, current) + if index == rejectedIndex + then pure + (Right + (Provers.CounterSatisfiable + "focused case rejection")) + else runWith executable prepared + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool + (label <> " publishes no declaration") + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure (label <> " unexpectedly succeeded") + assertEqual + (label <> " selects failures in source order") + expectedRuns =<< readIORef runs + + orP left right = Core.CImp (Core.CImp left Core.CFalsum) right + +compilesExactReplacementComprehensions :: Assertion +compilesExactReplacementComprehensions = + Temp.withSystemTempDirectory "felix-exact-replacement" \root -> do + let relative = "test/phase5/exact-replacement.tex" + executable = root Posix. "vampire" + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace bootstrap mounts relative + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-replacement'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact replacement module" modules + assertExactReplacementModule sealed + assertEqual + "replacement proof uses its checked characteristic on TH0" + [( Backend.RouteTh0 + , [Foundation.ReplacementCharacteristic] + )] + =<< readIORef observations + +assertExactReplacementModule + :: Module.SealedTypedModule + -> Assertion +assertExactReplacementModule sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + definitionObject <- sole + "replacement definition object" + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual "replacement definition type" + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual "replacement definition body" + expectedBody + body + assertEqual "replacement definition foundation helpers" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies body) + content -> + assertFailure + ("unexpected replacement object " <> show content) + let definitionDelta = + Declaration.committedBatchDelta definitionBatch + definitionFacts = + Semantic.declarationDeltaFacts definitionDelta + assertEqual "replacement definition fact count" + 2 (length definitionFacts) + assertEqual "replacement equation/search view eligibility" + [Semantic.SearchIneligible, Semantic.SearchEligible] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + assertEqual "replacement generated view is unaliased" + 1 + (length (Semantic.declarationDeltaAliases definitionDelta)) + assertEqual "replacement definition proposition count" + 2 + (length + (Declaration.committedBatchPropositions definitionBatch)) + assertEqual "replacement definition proof validations" + [] + (Declaration.committedBatchProofValidations definitionBatch) + definitionValidation <- + maybe + (assertFailure "replacement validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + definitionValidation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation target) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + generatedTarget _descriptor) + ] -> + assertEqual "replacement construction authority object" + target generatedTarget + authorizations -> + assertFailure + ("unexpected replacement definition authorities " + <> show authorizations) + + assertEqual "replacement theorem adds no object" + [] + (Declaration.committedBatchObjects theoremBatch) + assertEqual "replacement theorem fact count" + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch))) + assertEqual "replacement theorem proposition count" + 1 + (length + (Declaration.committedBatchPropositions theoremBatch)) + theoremValidation <- sole + "replacement theorem validation" + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + ("unexpected replacement theorem authority " + <> show authorization) + batches -> + assertFailure + ("expected replacement definition and theorem, found " + <> show (length batches)) + where + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + expectedBody = + Core.CLam Core.TySet $ + app1 Core.FamilyUnion $ + app2 Core.Repl (Core.CBound 0) $ + Core.CLam Core.TySet $ + app2 Core.Repl + (app2 Core.Sep + (Core.CBound 0) + (Core.CLam Core.TySet $ + Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CBound 0)) + +compilesAndReusesRelationalReplacement :: Assertion +compilesAndReusesRelationalReplacement = + Temp.withSystemTempDirectory "felix-exact-relational-replacement" \root -> do + let relative = "test/phase5/exact-relational-replacement.tex" + failureRelative = + "test/phase5/exact-relational-replacement-failure.tex" + localFailureRelative = + "test/phase5/exact-relational-replacement-local-failure.tex" + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts relative + observed <- newIORef [] + runs <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList + (Backend.typedProblemLocalPremises problem) + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + fresh <- sole "fresh relational replacement module" freshModules + assertRelationalReplacementModule fresh + problems <- readIORef observed + assertEqual "relational replacement request count" + 3 (length problems) + firstProblem <- sole "module functionality request" (take 1 problems) + assertEqual "module functionality uses FOF" + Backend.RouteFof + (case firstProblem of (route, _, _) -> route) + assertEqual "module functionality has no local premises" + [] + (case firstProblem of (_, ordinals, _) -> ordinals) + assertEqual + "relational equivalence creates no ATP obligation or auxiliary" + [ (Backend.RouteFof, [], []) + , (Backend.RouteFof, [], []) + , (Backend.RouteFof, [0], []) + ] + problems + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation workspace + assertEqual "warm relational replacement skips Vampire" + 0 =<< readIORef warmRuns + warm <- sole "warm relational replacement module" warmModules + assertEqual "warm relational replacement interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm relational replacement prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + + let rejectingResolver = + Declaration.vampireResolver \_prepared -> + pure + (Right + (Provers.CounterSatisfiable + "relational functionality rejected")) + runRejected relativePath = do + failedWorkspace <- + parseExactWorkspace bootstrap mounts relativePath + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + rejectingResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failedWorkspace) + []) + Module.runTypedModule input + runRejected failureRelative >>= \case + Module.TypedModuleFailed _failure prefix -> do + batches <- pure + (Declaration.pendingModulePrefixBatches prefix) + assertEqual "failed relational definition keeps its prefix" + 1 (length batches) + prefixBatch <- sole "relational prefix declaration" batches + assertEqual "failed relational definition publishes no object" + 1 (length + (Declaration.committedBatchObjects prefixBatch)) + _result -> + assertFailure + "nonfunctional relational definition did not fail" + runRejected localFailureRelative >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool + "failed local functionality publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure + "nonfunctional local definition did not fail" + +assertRelationalReplacementModule + :: Module.SealedTypedModule + -> Assertion +assertRelationalReplacementModule sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_axiomBatch, definitionBatch, proofBatch] -> do + _object <- sole "relational replacement object" + (Declaration.committedBatchObjects definitionBatch) + let definitionFacts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definitionBatch) + assertEqual "relational replacement fact eligibility" + [ Semantic.SearchIneligible + , Semantic.SearchIneligible + , Semantic.SearchEligible + ] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + let sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + assertEqual "relational extensionality inherits functionality safety" + [ Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + ] + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> definitionFacts + ) + assertEqual "relational replacement has only its equation alias" + 1 + (length + (Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta definitionBatch))) + validation <- + maybe + (assertFailure "relational replacement validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation equationObject) + , Authority.CheckedSourceProof [_functionalityRequest] + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + extensionalObject _descriptor) + ] -> + assertEqual "relational facts target one object" + equationObject extensionalObject + authorizations -> + assertFailure + ("unexpected relational authorities " + <> show authorizations) + assertEqual "module construction generates no proof row" + [] + (Declaration.committedBatchProofValidations definitionBatch) + + proofValidation <- sole "proof-local relational validation" + (Declaration.committedBatchProofValidations proofBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + proofValidation) of + Authority.CheckedSourceProof requests -> + assertEqual + "local functionality precedes its continuation" + 2 (length requests) + authorization -> + assertFailure + ("unexpected proof-local relational authority " + <> show authorization) + proofFact <- sole "proof-local relational theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta proofBatch)) + assertEqual "local extensional premise retains discharge safety" + sourceSafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority proofFact)) + batches -> + assertFailure + ("expected relational axiom, definition, and proof, found " + <> show (length batches)) + +compilesAndReusesExactFiniteSets :: Assertion +compilesAndReusesExactFiniteSets = + Temp.withSystemTempDirectory "felix-exact-finite-set" \root -> do + let relative = "test/phase5/exact-finite-set.tex" + sourcePath = root Posix. relative + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-finite-set'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation + workspace + fresh <- sole "fresh finite-set module" freshModules + assertExactFiniteSetModule "fresh" fresh + assertEqual + "finite-set proof uses exactly its FOF characteristics" + [( Backend.RouteFof + , [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + ] + )] + =<< readIORef observations + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm finite-set proof skips Vampire" + 0 + =<< readIORef warmRuns + warm <- sole "warm finite-set module" warmModules + assertExactFiniteSetModule "warm" warm + assertEqual "warm finite-set semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm finite-set final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + +preparesExactDirectInductives :: Assertion +preparesExactDirectInductives = do + foundation <- expectRight Foundation.checkedFoundation + prepared <- + expectRight + =<< prepareExactInductiveFixture + "test/phase5/exact-inductive.tex" + assertEqual "exact inductive carrier type" + (Core.TyArrow Core.TySet Core.TySet) + (ExactInductive.preparedExactInductiveCarrierType prepared) + assertEqual "exact inductive carrier body" + expectedCarrier + (Core.frozenCoreTerm + (ExactInductive.preparedExactInductiveCarrierBody prepared)) + assertEqual "foundation guard needs no imported fact" + [] + (Vector.toList + (ExactInductive.preparedExactInductiveGuardTargets prepared)) + let facts = + toList + (ExactInductive.preparedExactInductiveFacts prepared) + assertEqual "generated fact order" + [ Raw.Marker "phase5_fin_intro_1" + , Raw.Marker "phase5_fin_dom_subset" + , Raw.Marker "phase5_fin_cases" + , Raw.Marker "phase5_fin_induct" + ] + (TypedInductive.typedInductiveFactMarker <$> facts) + assertEqual "generated guarded-rule descriptors" + [ Set.singleton Foundation.SetLfpFixed + , Set.singleton Foundation.SetLfpBound + , Set.singleton Foundation.SetLfpFixed + , Set.singleton Foundation.SetLfpInduct + ] + ( Set.fromList + . toList + . TypedInductive.typedInductiveFactRules + <$> facts + ) + assertBool "generated targets are closed propositions" + (all + (\fact -> + let target = TypedInductive.typedInductiveFactTarget fact + in Core.frozenCoreType target == Core.TyProp + && Set.null (Core.frozenCoreGlobals target)) + facts) + + let singleton = + Internal.finiteSet + Nowhere + (Internal.EmptySet Nowhere :| []) + noGlobalType :: Void -> Core.CoreType + noGlobalType = absurd + noGlobal + :: Internal.Symbol + -> Maybe (TypedInductive.SourceGlobal Void) + noGlobal = const Nothing + finite <- + expectRight + (TypedInductive.prepareTypedInductive + noGlobalType + foundation + noGlobal + (Internal.Marker "finite_internal") + (TypedInductive.DirectInductive + [] + singleton + (TypedInductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| []))) + finiteGuard <- + sole + "finite-set inductive guard" + (Vector.toList + (TypedInductive.typedInductiveGuardTargets finite)) + assertEqual + "typed inductive path uses intrinsic finite-set adjunction" + (member + (Core.CIntrinsic Core.Empty) + (Core.canonicalSetInsert + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty))) + (Core.frozenCoreTerm finiteGuard) + where + apply1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + expectedCarrier = + Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.ISetLfp) + (apply1 Core.UnivOf (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (apply1 Core.UnivOf (Core.CBound 1))) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 2)))))) + +preparesExactDatatypes :: Assertion +preparesExactDatatypes = do + (foundation, owner, prepared) <- + expectRight + =<< prepareExactDatatypeFixture + "test/phase5/exact-datatype.tex" + let objects = + toList + (ExactDatatype.preparedExactDatatypeObjects prepared) + objectIds = fst <$> objects + objectTypes = snd <$> objects + expectedTypes = + [ Core.TySet + , Core.TySet + , Core.TyArrow Core.TySet Core.TySet + , Core.TyArrow Core.TySet + (Core.TyArrow Core.TySet Core.TySet) + ] + theory = Identity.theoryId foundation + expectedIds = + [ Identity.opaqueObjectId theory + (Identity.opaqueDeclarationSeed + owner + (localDeclarationOrdinal 0) + DatatypeDeclaration + (generatedObjectSlot index)) + coreType + | (index, coreType) <- zip [0 ..] expectedTypes + ] + assertEqual "datatype opaque object types" + expectedTypes objectTypes + assertEqual "datatype opaque object slots" + expectedIds objectIds + assertBool "datatype objects are opaque" + (all ((== Identity.OpaqueObject) . Identity.objectIdFamily) objectIds) + (carrierId, zeroId, atomId, joinId, constructorIds) <- + case expectedIds of + [carrier, zero, atom, join] -> + pure + ( carrier + , zero + , atom + , join + , zero :| [atom, join] + ) + _ -> + assertFailure "datatype object inventory is incomplete" + >> fail "unreachable" + let facts = + toList + (ExactDatatype.preparedExactDatatypeFacts prepared) + markers = + ExactDatatype.preparedExactDatatypeFactMarker <$> facts + assertEqual "datatype generated fact order" + [ Internal.Marker "phase5_data_phasefivezero_intro" + , Internal.Marker "phase5_data_phasefiveatom_intro" + , Internal.Marker "phase5_data_phasefivejoin_intro" + , Internal.Marker + "phase5_data_phasefivezero_phasefiveatom_distinct" + , Internal.Marker + "phase5_data_phasefivezero_phasefivejoin_distinct" + , Internal.Marker + "phase5_data_phasefiveatom_phasefivejoin_distinct" + , Internal.Marker "phase5_data_phasefiveatom_injective" + , Internal.Marker "phase5_data_phasefivejoin_injective" + , Internal.Marker "phase5_data_cases" + , Internal.Marker "phase5_data_induct" + ] + markers + assertBool "datatype generated targets are checked propositions" + (all + (\fact -> + Core.frozenCoreType + (ExactDatatype.preparedExactDatatypeFactTarget fact) + == Core.TyProp) + facts) + atomIntroduction <- + sole "domain-bearing datatype introduction" + [ fact + | fact <- facts + , ExactDatatype.preparedExactDatatypeFactMarker fact + == Internal.Marker "phase5_data_phasefiveatom_intro" + ] + assertEqual "domain-bearing datatype introduction target" + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + singletonEmpty) + (member + (Core.CApp + (Core.CGlobal atomId) + (Core.CBound 0)) + (Core.CGlobal carrierId)))) + (Core.frozenCoreTerm + (ExactDatatype.preparedExactDatatypeFactTarget + atomIntroduction)) + induction <- + sole "datatype induction law" + [ fact + | fact <- facts + , ExactDatatype.preparedExactDatatypeFactMarker fact + == Internal.Marker "phase5_data_induct" + ] + assertEqual "datatype induction target" + (Core.CForall Core.TySet + (Core.CImp + (conjunctions + [ member + (Core.CGlobal zeroId) + (Core.CBound 0) + , Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + singletonEmpty) + (member + (Core.CApp + (Core.CGlobal atomId) + (Core.CBound 0)) + (Core.CBound 1))) + , Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (conjunction + (member + (Core.CBound 1) + (Core.CBound 2)) + (member + (Core.CBound 0) + (Core.CBound 2))) + (member + (Core.CApp + (Core.CApp + (Core.CGlobal joinId) + (Core.CBound 1)) + (Core.CBound 0)) + (Core.CBound 2)))) + ]) + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.CGlobal carrierId)) + (member + (Core.CBound 0) + (Core.CBound 1)))))) + (Core.frozenCoreTerm + (ExactDatatype.preparedExactDatatypeFactTarget induction)) + assertEqual "datatype descriptor membership" + (Authority.datatypeCompilationDescriptor + carrierId + constructorIds + (ExactDatatype.preparedExactDatatypeFactReference <$> facts)) + (ExactDatatype.preparedExactDatatypeDescriptor prepared) + where + singletonEmpty = + Core.canonicalSetInsert + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + + conjunction left right = + Core.CImp + (Core.CImp left (Core.CImp right Core.CFalsum)) + Core.CFalsum + + conjunctions = \case + [] -> Core.CImp Core.CFalsum Core.CFalsum + first : remaining -> foldl' conjunction first remaining + +rejectsNestedExactDatatypeRecursion :: Assertion +rejectsNestedExactDatatypeRecursion = do + result <- + prepareExactDatatypeFixture + "test/phase5/exact-datatype-nested.tex" + case result of + Left ExactDatatype.ExactDatatypeInvalid{} -> pure () + Left failure -> + assertFailure + ("unexpected nested datatype failure: " <> show failure) + Right _prepared -> + assertFailure "nested exact datatype recursion was accepted" + +compilesAndReusesExactDatatypes :: Assertion +compilesAndReusesExactDatatypes = + Temp.withSystemTempDirectory "felix-exact-datatype" \directory -> do + let relative = "test/phase5/exact-datatype.tex" + storePath = directory Posix. "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh exact datatype module" freshModules + assertExactDatatypeModule "fresh" fresh + parsed <- + sole "exact datatype parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let artifact sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + freshArtifact <- artifact fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm exact datatype module" warmModules + assertExactDatatypeModule "warm" warm + assertEqual "warm exact datatype semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm exact datatype final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm exact datatype module artifact" + freshArtifact + =<< artifact warm + + mounts <- exactFixtureMounts =<< getCurrentDirectory + nestedWorkspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-datatype-nested.tex" + nestedParsed <- + sole "nested exact datatype module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter + nestedWorkspace)) + nestedInput <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + nestedParsed + []) + Module.runTypedModule nestedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactDatatypeFailed + (ExactDatatype.ExactDatatypeInvalid + location _message))) + prefix -> do + assertEqual "nested datatype failure line" + 4 + (locLine location) + assertBool "nested datatype publishes no prefix" + (null + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "unexpected nested datatype result" + +preparesNestedExactInductiveRecursion :: Assertion +preparesNestedExactInductiveRecursion = + withAcceptedFixtureVampire "felix-nested-inductive" \vampire -> do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-nested.tex" + parsed <- sole "nested exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + observed <- newIORef [] + let resolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + ) + ]) + (Provers.runPreparedTypedProver vampire prepared) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + sealed <- sole "nested exact inductive module" modules + observations <- readIORef observed + assertEqual "guard proof plus nested monotonicity request count" + 2 (length observations) + (route, target) <- + sole "nested monotonicity request" + [ observation + | observation@(_route, candidate) <- observations + , candidate == expectedPowerMonotonicity + ] + assertEqual "nested monotonicity target" + expectedPowerMonotonicity + target + assertEqual "nested monotonicity request is first-order" + Backend.RouteFof + route + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_guardBatch, _unsafeBatch, inductiveBatch] -> do + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + aliases = + Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta inductiveBatch) + sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + assertEqual "nested inductive fact eligibility" + ( Semantic.SearchEligible + : Semantic.SearchIneligible + : replicate 4 Semantic.SearchEligible + ) + (Semantic.semanticFactSearchEligibility <$> facts) + monotonicityFact <- case facts of + _definition : fact : _laws -> pure fact + _ -> assertFailure "nested inductive fact inventory" + >> fail "unreachable" + assertEqual "nested monotonicity fact is unaliased" + False + (Semantic.semanticFactFingerprint monotonicityFact + `elem` (Semantic.semanticAliasTarget <$> aliases)) + assertEqual "nested authority safety reaches generated laws" + [ Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + , Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + ] + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- + maybe + (assertFailure "nested inductive validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual "nested inductive candidate authority shape" + [ "definition" + , "source-proof" + , "kernel" + , "kernel" + , "kernel" + , "kernel" + ] + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + requestId <- nestedRequestId inductiveBatch + Temp.withSystemTempDirectory + "felix-nested-inductive-cache" \temporary -> do + let storePath = temporary Posix. "store.sqlite" + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix sealed)) + let warmValidation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation + store) + (expectRightIO + . Store.loadDeclarationValidation + store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver + warmValidation workspace + warm <- sole + "warm nested exact inductive module" + warmModules + warmBatch <- case + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm) of + [_warmGuard, _warmUnsafe, batch] -> pure batch + batches -> + assertFailure + ("warm nested batch count: " + <> show (length batches)) + >> fail "unreachable" + assertEqual "warm nested exact request" + requestId + =<< nestedRequestId warmBatch + assertEqual "warm nested semantic interface" + (Module.sealedTypedModuleSemantic sealed) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm nested admitted prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + freshArtifact <- + moduleArtifact + foundation bootstrap parsed sealed + warmArtifact <- + moduleArtifact + foundation bootstrap parsed warm + assertEqual "warm nested module artifact" + freshArtifact warmArtifact + batches -> + assertFailure + ("expected guard and nested inductive batches, found " + <> show (length batches)) + + failureWorkspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-nested-failure.tex" + successfulRequests <- newIORef [] + let successfulResolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' successfulRequests + (<> [Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem)]) + (Provers.runPreparedTypedProver vampire prepared) + successfulModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap successfulResolver + Declaration.FreshValidation failureWorkspace + successful <- sole + "successful repeated/distinct nested inductive module" + successfulModules + assertEqual + "repeated and distinct contexts use two monotonicity requests" + [ expectedPowerMonotonicity + , expectedDoublePowerMonotonicity + ] + =<< readIORef successfulRequests + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix successful) of + [_guardOne, _guardTwo, batch] -> do + validation <- maybe + (assertFailure + "successful multi-context validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + assertEqual + "deduplicated monotonicities precede all kernel laws" + ( ["definition", "source-proof", "source-proof"] + <> replicate 6 "kernel" + ) + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + batches -> + assertFailure + ("successful multi-context batch count: " + <> show (length batches)) + attempts <- newIORef (0 :: Int) + let rejectingResolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' attempts \current -> + (current + 1, current) + if index == 0 + then pure + (Right + (Provers.CounterSatisfiable + "first monotonicity rejected")) + else + (Provers.runPreparedTypedProver vampire prepared) + failureInput <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + rejectingResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failureWorkspace) + []) + Module.runTypedModule failureInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "earliest monotonicity failure location" + 14 (locLine location) + assertEqual + "later monotonicity still resolves before first rejection" + 2 =<< readIORef attempts + assertEqual + "rejected monotonicity preserves only earlier declarations" + 2 + (length + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure + "nested monotonicity rejection unexpectedly succeeded" + where + authorizationKind = \case + Authority.CheckedKernelConstruction + Authority.CheckedDefinitionEquation{} -> "definition" + Authority.CheckedKernelConstruction{} -> "kernel" + Authority.CheckedSourceProof{} -> "source-proof" + authorization -> show authorization + + nestedRequestId batch = do + validation <- maybe + (assertFailure "nested declaration validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- case + Semantic.declarationValidationRecordCertificates validation of + _definition : monotonicity : _laws -> pure monotonicity + certificates -> + assertFailure + ("nested declaration certificate count: " + <> show (length certificates)) + >> fail "unreachable" + case Authority.validationDirectAuthorization certificate of + Authority.CheckedSourceProof [request] -> pure request + authorization -> + assertFailure + ("unexpected nested proof authorization " + <> show authorization) + >> fail "unreachable" + + moduleArtifact foundation bootstrap parsed sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + + expectedPowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (Core.CBound 1)) + (power (Core.CBound 0))))))) + + expectedDoublePowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (power (Core.CBound 1))) + (power (power (Core.CBound 0)))))))) + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +compilesTransparentNestedInductiveWrappers :: Assertion +compilesTransparentNestedInductiveWrappers = + withAcceptedFixtureVampire "felix-nested-wrapper" \vampire -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-wrapper.tex" + observed <- newIORef [] + let resolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + ) + ]) + (Provers.runPreparedTypedProver vampire prepared) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + sealed <- sole "transparent-wrapper nested module" modules + observations <- readIORef observed + assertEqual "wrapper guard plus monotonicity request count" + 2 (length observations) + (route, target) <- case + [ observation + | observation@(_route, candidate) <- observations + , candidate == expectedPowerMonotonicity + ] of + [observation] -> pure observation + matches -> + assertFailure + ("normalized wrapper monotonicity matches: " + <> show matches + <> "; observed: " <> show observations) + >> fail "unreachable" + assertEqual "transparent-wrapper monotonicity is FOF" + Backend.RouteFof route + assertEqual "transparent-wrapper monotonicity target" + expectedPowerMonotonicity target + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_wrapperDefinition, _guardProof, inductiveBatch] -> do + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + assertEqual "transparent-wrapper inductive stays clean" + (replicate 6 Authority.cleanAuthoritySafety) + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- maybe + (assertFailure + "transparent-wrapper declaration validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual "transparent-wrapper staged authority" + [ "definition" + , "source-proof" + , "kernel" + , "kernel" + , "kernel" + , "kernel" + ] + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + batches -> + assertFailure + ("transparent-wrapper declaration count: " + <> show (length batches)) + where + authorizationKind = \case + Authority.CheckedKernelConstruction + Authority.CheckedDefinitionEquation{} -> "definition" + Authority.CheckedKernelConstruction{} -> "kernel" + Authority.CheckedSourceProof{} -> "source-proof" + authorization -> show authorization + + expectedPowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (Core.CBound 1)) + (power (Core.CBound 0))))))) + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +normalizesNestedExactInductiveContexts :: Assertion +normalizesNestedExactInductiveContexts = do + foundation <- expectRight Foundation.checkedFoundation + powerSymbol <- fixedFunctionSymbol "pow" + carrierSymbol <- fixedFunctionSymbol "cumul" + let a = Internal.NamedVar "A" + x = Internal.NamedVar "x" + y = Internal.NamedVar "y" + z = Internal.NamedVar "z" + carrier = + Internal.TermOp Nowhere carrierSymbol [Internal.TermVar a] + powerCarrier = + Internal.TermOp Nowhere powerSymbol [carrier] + doublePowerCarrier = + Internal.TermOp Nowhere powerSymbol [powerCarrier] + parameterizedCarrier = + Internal.TermOp Nowhere powerSymbol + [ Internal.TermOp Nowhere Lexicon.UpairSymbol + [carrier, Internal.TermVar x] + ] + powerContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] powerCarrier) + doublePowerContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] doublePowerCarrier) + parameterizedContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] parameterizedCarrier) + deduplicated <- + expectRight + (TypedInductive.prepareTypedInductive + (const Core.TySet) + foundation + (const Nothing) + (Internal.Marker "nested_dedup") + (TypedInductive.DirectInductive + [a] + (Internal.EmptySet Nowhere) + (TypedInductive.DirectInductiveClause + [x, y, z] + [ TypedInductive.DirectRecursiveCondition + (Internal.TermVar x) powerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar y) powerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar z) doublePowerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar z) parameterizedContext + ] + (Internal.TermVar a) + :| []))) + assertEqual "equal contexts deduplicate in first-occurrence order" + [ monotonicityTarget 4 power + , monotonicityTarget 4 (power . power) + , monotonicityTarget 4 + (\hole -> power (pair hole (Core.CBound 4))) + ] + ( Core.frozenCoreTerm + . TypedInductive.typedInductiveMonotonicityTarget + <$> Vector.toList + (TypedInductive.typedInductiveMonotonicities deduplicated) + ) + + let wrapperSymbol = + Raw.mkMixfixItem + [ Just (Internal.Command "phasefivecheckedwrapper") + , Just Internal.InvisibleBraceL + , Nothing + , Just Internal.InvisibleBraceR + ] + (Internal.Marker "phasefivecheckedwrapper") + Raw.NonAssoc + wrapperCarrier = + Internal.TermOp Nowhere wrapperSymbol [carrier] + wrapperContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] wrapperCarrier) + wrapperBody <- + expectRight + (Core.checkCanonicalCore + (const Nothing) + (Core.CLam Core.TySet + (power (Core.CBound 0)))) + let wrapperId = + Identity.transparentObjectId + (Identity.theoryId foundation) + (Core.TyArrow Core.TySet Core.TySet) + (Core.frozenCoreTerm wrapperBody) + wrapped <- + expectRight + (TypedInductive.prepareTypedInductive + (const (Core.TyArrow Core.TySet Core.TySet)) + foundation + (\symbol -> + if symbol == Internal.SymbolMixfix wrapperSymbol + then Just + (TypedInductive.SourceGlobal + wrapperId (Just wrapperBody)) + else Nothing) + (Internal.Marker "nested_wrapper") + (TypedInductive.DirectInductive + [a] + (Internal.EmptySet Nowhere) + (TypedInductive.DirectInductiveClause + [x] + [TypedInductive.DirectRecursiveCondition + (Internal.TermVar x) wrapperContext] + (Internal.TermVar a) + :| []))) + assertEqual + "transparent content, not a primitive-name whitelist, owns context semantics" + [monotonicityTarget 2 power] + ( Core.frozenCoreTerm + . TypedInductive.typedInductiveMonotonicityTarget + <$> Vector.toList + (TypedInductive.typedInductiveMonotonicities wrapped) + ) + assertBool "transparent context target contains no wrapper global" + (all + (Set.null + . Core.frozenCoreGlobals + . TypedInductive.typedInductiveMonotonicityTarget) + (Vector.toList + (TypedInductive.typedInductiveMonotonicities wrapped))) + + assertExactFailure + "test/phase5/exact-inductive-wrong-arguments.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveCarrierWrongArguments{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-outside-membership.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveCarrierOutsideMembership{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-element.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveTermMentionsCarrier{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-domain.tex" + 2 + (\case + ExactInductive.ExactInductiveDomainMentionsCarrier{} -> True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-result.tex" + 4 + (\case + ExactInductive.ExactInductiveResultMentionsCarrier{} -> True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-unsupported-context.tex" + 4 + (\case + ExactInductive.ExactInductiveUnsupportedRecursiveCarrierContext{} -> + True + _ -> False) + where + fixedFunctionSymbol marker = + sole ("fixed function " <> StrictText.unpack marker) + [ symbol + | symbol <- Lexicon.prefixOps + , Raw.mixfixMarker symbol == Internal.Marker marker + ] + + assertExactFailure relative expectedLine expected = + prepareExactInductiveFixture relative >>= \case + Left failure + | expected failure -> + assertEqual + ("nested-context failure line for " <> relative) + expectedLine + (locLine + (ExactInductive.exactInductiveErrorLocation + failure)) + | otherwise -> + assertFailure + ("unexpected nested-context failure for " + <> relative <> ": " <> show failure) + Right{} -> + assertFailure + ("unsupported nested context was accepted: " <> relative) + + monotonicityTarget + :: Int + -> (Core.CanonicalTerm Identity.ObjectId + -> Core.CanonicalTerm Identity.ObjectId) + -> Core.CanonicalTerm Identity.ObjectId + monotonicityTarget sourceBinders context = + foldr + (const (Core.CForall Core.TySet)) + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (context (Core.CBound 1)) + (context (Core.CBound 0)))))) + [1 .. sourceBinders] + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + pair left right = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.PairSet) left) + right + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +compilesAndReusesExactInductives :: Assertion +compilesAndReusesExactInductives = + Temp.withSystemTempDirectory "felix-exact-inductive" \directory -> do + let relative = "test/phase5/exact-inductive.tex" + storePath = directory Posix. "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh exact inductive module" freshModules + assertExactInductiveModule foundation "fresh" fresh + parsed <- + sole "exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let artifact sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + freshArtifact <- artifact fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm exact inductive module" warmModules + assertExactInductiveModule foundation "warm" warm + assertEqual "warm exact inductive semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm exact inductive final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm exact inductive module artifact" + freshArtifact + =<< artifact warm + +authorizesRecursiveExactInductives :: Assertion +authorizesRecursiveExactInductives = + Temp.withSystemTempDirectory "felix-recursive-inductive" \directory -> do + let relative = "test/phase5/exact-inductive-recursive.tex" + storePath = directory Posix. "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh recursive inductive module" freshModules + assertRecursiveExactInductiveModule "fresh" fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm recursive inductive module" warmModules + assertRecursiveExactInductiveModule "warm" warm + assertEqual "warm recursive inductive semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm recursive inductive final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + +assertRecursiveExactInductiveModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertRecursiveExactInductiveModule label sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_axiomBatch, inductiveBatch] -> do + object <- + sole (label <> " recursive inductive carrier") + (Declaration.committedBatchObjects inductiveBatch) + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom) + assertEqual (label <> " recursive inductive safety") + (Authority.cleanAuthoritySafety : replicate 4 sourceSafety) + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- + maybe + (assertFailure + (label <> ": recursive validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual (label <> " recursive inductive descriptors") + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Identity.assertedObjectId object)) + , guardedRules + (Foundation.SetLfpBound :| [Foundation.SetLfpFixed]) + , guardedRules (Foundation.SetLfpBound :| []) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpInduct :| []) + ] + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation + ) + batches -> + assertFailure + (label <> ": expected axiom and inductive batches, found " + <> show (length batches)) + where + guardedRules rules = + Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet rules)) + +assertExactDatatypeModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactDatatypeModule label sealed = do + assertEqual (label <> " datatype semantic declaration count") + 1 + (length + (Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed))) + batch <- + sole (label <> " datatype declaration batch") + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + let objects = Declaration.committedBatchObjects batch + objectIds = Identity.assertedObjectId <$> objects + delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + bindings = + Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + boundIds = + Semantic.semanticGlobalTargetObject + . Semantic.semanticGlobalBindingTarget + <$> bindings + assertEqual (label <> " datatype object count") 4 (length objects) + assertBool (label <> " datatype objects are opaque") + (all + ((== Identity.OpaqueObject) + . Identity.objectIdFamily + . Identity.assertedObjectId) + objects) + assertEqual (label <> " datatype global binding count") + 4 + (length bindings) + assertBool (label <> " datatype globals are references") + (all + (\binding -> + case Semantic.semanticGlobalBindingTarget binding of + Semantic.GlobalReference{} -> True + Semantic.TransparentExpansion{} -> False + Semantic.ContextualTransparentExpansion{} -> False) + bindings) + assertEqual (label <> " datatype global targets") + (Set.fromList objectIds) + (Set.fromList boundIds) + assertEqual (label <> " datatype fact count") 10 (length facts) + assertEqual (label <> " datatype aliases") + (Semantic.semanticName <$> + [ "phase5_data_phasefivezero_intro" + , "phase5_data_phasefiveatom_intro" + , "phase5_data_phasefivejoin_intro" + , "phase5_data_phasefivezero_phasefiveatom_distinct" + , "phase5_data_phasefivezero_phasefivejoin_distinct" + , "phase5_data_phasefiveatom_phasefivejoin_distinct" + , "phase5_data_phasefiveatom_injective" + , "phase5_data_phasefivejoin_injective" + , "phase5_data_cases" + , "phase5_data_induct" + ]) + (Semantic.semanticAliasName <$> aliases) + assertBool (label <> " datatype facts are clean") + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + facts) + assertEqual (label <> " datatype proof validations") + [] + (Declaration.committedBatchProofValidations batch) + validation <- + maybe + (assertFailure (label <> ": datatype validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + descriptor <- + case objectIds of + carrier : firstConstructor : remainingConstructors -> + pure + (Authority.datatypeCompilationDescriptor + carrier + (firstConstructor :| remainingConstructors) + ( Authority.factAuthorityTheorem + . Semantic.semanticFactAuthority + <$> facts + )) + _ -> + assertFailure (label <> ": datatype object family is absent") + >> fail "unreachable" + assertEqual (label <> " datatype validation descriptors") + (replicate 10 + (Authority.TrustedCompilation + (Authority.DatatypeCompilation descriptor))) + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates validation + ) + +assertExactInductiveModule + :: Foundation.CheckedFoundation + -> String + -> Module.SealedTypedModule + -> Assertion +assertExactInductiveModule foundation label sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [batch] -> do + object <- + sole (label <> " inductive carrier") + (Declaration.committedBatchObjects batch) + case Identity.assertedObjectContent object of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " inductive carrier type") + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual (label <> " inductive carrier identity") + (Identity.transparentObjectId + (Identity.theoryId foundation) + coreType + body) + (Identity.assertedObjectId object) + content -> + assertFailure + (label <> ": unexpected inductive carrier " + <> show content) + let delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + assertEqual (label <> " inductive fact count") + 5 + (length facts) + assertEqual (label <> " inductive aliases") + (Semantic.semanticName <$> + [ "phase5_fin" + , "phase5_fin_intro_1" + , "phase5_fin_dom_subset" + , "phase5_fin_cases" + , "phase5_fin_induct" + ]) + (Semantic.semanticAliasName <$> aliases) + assertBool (label <> " inductive facts are clean") + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + facts) + assertEqual (label <> " inductive proof validations") + [] + (Declaration.committedBatchProofValidations batch) + validation <- + maybe + (assertFailure + (label <> ": inductive validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + assertEqual (label <> " inductive validation descriptors") + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Identity.assertedObjectId object)) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpBound :| []) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpInduct :| []) + ] + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation + ) + batches -> + assertFailure + (label <> ": expected one inductive batch, found " + <> show (length batches)) + where + guardedRules rules = + Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet rules)) + +assertExactFiniteSetModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactFiniteSetModule label sealed = do + assertEqual (label <> " finite-set semantic declarations") + 2 + (length + (Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed))) + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + definitionObject <- sole + (label <> " finite-set definition object") + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " finite-set definition type") + (Core.TyArrow Core.TySet + (Core.TyArrow Core.TySet Core.TySet)) + coreType + assertEqual (label <> " finite-set definition body") + expectedBody + body + content -> + assertFailure + (label <> ": unexpected finite-set object " + <> show content) + assertEqual (label <> " finite-set definition fact count") + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definitionBatch))) + assertEqual (label <> " finite-set definition proof validations") + [] + (Declaration.committedBatchProofValidations definitionBatch) + + assertEqual (label <> " finite-set theorem adds no object") + [] + (Declaration.committedBatchObjects theoremBatch) + theoremFact <- sole + (label <> " finite-set theorem fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch)) + assertEqual (label <> " finite-set theorem safety") + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority theoremFact)) + theoremValidation <- sole + (label <> " finite-set theorem validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + (label <> ": unexpected finite-set theorem authority " + <> show authorization) + batches -> + assertFailure + (label <> ": expected finite-set definition and theorem, found " + <> show (length batches)) + where + expectedBody = + Core.CLam Core.TySet + (Core.CLam Core.TySet + (Core.canonicalSetInsert + (Core.CBound 1) + (Core.canonicalSetInsert + (Core.CBound 0) + (Core.CIntrinsic Core.Empty)))) + +assertExactSeparationModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactSeparationModule label sealed = do + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + assertEqual (label <> " separation definition object count") + 1 + (length + (Declaration.committedBatchObjects definitionBatch)) + definitionObject <- sole + (label <> " separation definition object") + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " separation definition type") + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual (label <> " separation definition body") + (Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (Core.CBound 0)) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0))))) + body + content -> + assertFailure + (label <> ": unexpected separation object " + <> show content) + let definitionDelta = + Declaration.committedBatchDelta definitionBatch + definitionFacts = + Semantic.declarationDeltaFacts definitionDelta + assertEqual (label <> " definition fact count") + 2 (length definitionFacts) + assertEqual (label <> " defining equation is explicit-only") + [Semantic.SearchIneligible, Semantic.SearchEligible] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + assertEqual (label <> " generated view is unaliased") + 1 + (length (Semantic.declarationDeltaAliases definitionDelta)) + assertEqual (label <> " definition proposition count") + 2 + (length + (Declaration.committedBatchPropositions definitionBatch)) + assertEqual (label <> " definition proof validations") + [] + (Declaration.committedBatchProofValidations definitionBatch) + definitionValidation <- + maybe + (assertFailure + (label <> ": definition validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + definitionValidation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation target) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + generatedTarget _descriptor) + ] -> + assertEqual + (label <> " construction authority object") + target generatedTarget + authorizations -> + assertFailure + (label <> ": unexpected definition authorities " + <> show authorizations) + + assertEqual (label <> " theorem adds no object") + [] + (Declaration.committedBatchObjects theoremBatch) + theoremFact <- sole + (label <> " separation theorem fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch)) + assertEqual (label <> " theorem safety") + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority theoremFact)) + theoremValidation <- sole + (label <> " separation theorem validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + (label <> ": unexpected theorem authority " + <> show authorization) + batches -> + assertFailure + (label <> ": expected definition and theorem, found " + <> show (length batches)) + +reusesExactSeparationValidation :: Assertion +reusesExactSeparationValidation = + Temp.withSystemTempDirectory "felix-exact-separation-cache" \root -> do + let relative = "test/phase5/exact-separation.tex" + sourcePath = root Posix. relative + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-separation-cache'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + freshRequests <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRequests + (<> [Provers.preparedTypedProverRequest prepared]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + freshResolver + Declaration.FreshValidation + workspace + assertEqual "fresh separation proof runs Vampire once" + 1 + . length + =<< readIORef freshRequests + fresh <- sole "fresh exact separation module" freshModules + assertExactSeparationModule "fresh cached" fresh + freshDefinitionBatch <- + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh) of + batch : _theorem : [] -> pure batch + batches -> + assertFailure + ("fresh separation declaration count: " + <> show (length batches)) + >> fail "unreachable" + freshDefinitionValidation <- + maybe + (assertFailure "fresh separation definition validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + freshDefinitionBatch) + corruptedDefinitionValidation <- + case Semantic.declarationValidationRecordCertificates + freshDefinitionValidation of + [equation, extensional] -> do + corruptedExtensional <- + expectRight + (Authority.validationCertificate + (Authority.validationTarget extensional) + (Authority.validationDirectAuthorization + equation)) + pure + (Semantic.declarationValidationRecord + (Semantic.declarationValidationRecordKey + freshDefinitionValidation) + [equation, corruptedExtensional]) + certificates -> + assertFailure + ("fresh separation certificate count: " + <> show (length certificates)) + >> fail "unreachable" + freshRequest <- + sole "fresh separation request" + =<< readIORef freshRequests + freshAcceptedRequest <- + acceptedRequestId "fresh separation" fresh + assertEqual "fresh authority binds the exact request bytes" + freshAcceptedRequest + (Provers.preparedVerificationRequestId freshRequest) + assertBool "fresh separation request bytes are retained by the caller" + (Provers.preparedVerificationByteCount freshRequest > 0) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm separation proof skips Vampire" + 0 + =<< readIORef warmRuns + warm <- sole "warm exact separation module" warmModules + assertExactSeparationModule "warm cached" warm + warmAcceptedRequest <- + acceptedRequestId "warm separation" warm + assertEqual + "warm validation retains the fresh request-byte identity" + freshAcceptedRequest + warmAcceptedRequest + assertEqual "warm separation semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm separation final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + let components sealed = + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + in ( concatMap + Declaration.committedBatchObjects + batches + , concatMap + (fmap Identity.checkedPropositionId + . Declaration.committedBatchPropositions) + batches + , concatMap + Declaration.committedBatchProofValidations + batches + , Declaration.committedBatchDeclarationValidation + <$> batches + ) + assertEqual "warm separation checked artifacts" + (components fresh) + (components warm) + corruptRuns <- newIORef (0 :: Int) + let corruptedValidation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (\key -> + if key + == Semantic.declarationValidationRecordKey + corruptedDefinitionValidation + then pure + (Just corruptedDefinitionValidation) + else expectRightIO + (Store.loadDeclarationValidation + store key))) + corrupted <- Exception.try + (compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable corruptRuns) + corruptedValidation + workspace) + :: IO + (Either + Declaration.ValidationIntegrityError + [Module.SealedTypedModule]) + case corrupted of + Left Declaration.CachedValidationIntegrityError{} -> + pure () + Right _ -> + assertFailure + "mismatched generated authority replay succeeded" + assertEqual + "mismatched generated authority does not invoke Vampire" + 0 + =<< readIORef corruptRuns + where + acceptedRequestId label sealed = do + theoremBatch <- + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_definitionBatch, batch] -> pure batch + batches -> + assertFailure + (label <> ": unexpected declaration count " + <> show (length batches)) + >> fail "unreachable" + validation <- sole + (label <> " proof validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate validation) of + Authority.CheckedSourceProof [request] -> pure request + authorization -> + assertFailure + (label <> ": unexpected direct authorization " + <> show authorization) + >> fail "unreachable" + +compilesExactSourceAxioms :: Assertion +compilesExactSourceAxioms = + Temp.withSystemTempDirectory "felix-exact-source-axiom" \root -> do + let storePath = root Posix. "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture + "test/phase5/exact-source-axiom-assumptions.tex" + fresh <- sole "fresh source-axiom module" freshModules + assertSourceAxiom "fresh" fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver validation workspace + warm <- sole "warm source-axiom module" warmModules + assertSourceAxiom "warm" warm + assertEqual "warm source axiom preserves semantics" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm source axiom preserves prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + where + assertSourceAxiom label sealed = do + batch <- sole (label <> " source-axiom batch") + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + fact <- sole (label <> " source-axiom fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + alias <- sole (label <> " source-axiom alias") + (Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " source-axiom search eligibility") + Semantic.SearchEligible + (Semantic.semanticFactSearchEligibility fact) + assertEqual (label <> " source-axiom marker alias") + (Semantic.semanticName "phase5_exact_source_axiom_assumptions") + (Semantic.semanticAliasName alias) + proposition <- sole (label <> " source-axiom proposition") + (Declaration.committedBatchPropositions batch) + assertEqual (label <> " source-axiom closed target") + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (Core.CImp + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)) + (member + (Core.CBound 0) + (Core.CBound 1)))))) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) + assertEqual (label <> " source-axiom safety") + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + validation <- + maybe + (assertFailure (label <> " source-axiom validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- sole (label <> " source-axiom certificate") + (Semantic.declarationValidationRecordCertificates validation) + assertEqual (label <> " source-axiom direct authority") + Authority.SourceAxiomAuthorization + (Authority.validationDirectAuthorization certificate) + assertEqual (label <> " source axiom has no proof validations") + [] + (Declaration.committedBatchProofValidations batch) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + +rejectsProofLocalGeneralization :: Assertion +rejectsProofLocalGeneralization = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts + "test/phase5/exact-proof-local-free.tex" + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule workspace) + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "y"))))) + prefix -> do + assertEqual "proof-local free variable line" + 6 (locLine location) + assertEqual "proof-local failure commits nothing" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "proof-local variable was generalized" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("proof-local generalization module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected proof-local generalization failure: " + <> show failure) + +doesNotTreatMarkerOnlyNounAsSet :: Assertion +doesNotTreatMarkerOnlyNounAsSet = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts + "test/phase5/exact-set-marker.tex" + Temp.withSystemTempDirectory "felix-exact-set-marker" \root -> do + let executable = root Posix. "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for set-marker'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observed <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observed + (<> [ [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule workspace) + []) + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded{} -> + assertEqual + "the source noun supplies the local proof premise" + [[True]] + =<< readIORef observed + Module.TypedModuleOpenFailed failure -> + assertFailure + ("marker-only set noun module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected marker-only set noun failure: " + <> show failure) + +compilesExactOmittedProofs :: Assertion +compilesExactOmittedProofs = + Temp.withSystemTempDirectory "felix-exact-omitted" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-omitted.tex" + let executable = root Posix. "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-omitted'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + calls <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + modifyIORef' calls (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- + compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact omitted module" modules + assertEqual "only the non-omitted continuation invokes Vampire" + 1 + =<< readIORef calls + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + assertEqual "top-level and nested omitted declarations" + 2 (length batches) + for_ (zip ["top-level", "nested"] batches) \(label, batch) -> do + fact <- sole (label <> " omitted fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " omitted safety") + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + record <- sole (label <> " omitted validation") + (Declaration.committedBatchProofValidations batch) + assertEqual (label <> " omitted direct authority") + Authority.OmittedAuthorization + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + assertEqual (label <> " publishes only its final theorem") + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch))) + +reusesExactEscapeAuthority :: Assertion +reusesExactEscapeAuthority = + Temp.withSystemTempDirectory "felix-exact-escape-cache" \root -> do + let consumerRelative = "test/phase5/exact-escape-consumer.tex" + producerRelative = "test/phase5/exact-escape-producer.tex" + consumerPath = root Posix. consumerRelative + producerPath = root Posix. producerRelative + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory consumerPath) + consumerSource <- ByteString.readFile consumerRelative + producerSource <- ByteString.readFile producerRelative + ByteString.writeFile consumerPath consumerSource + ByteString.writeFile producerPath producerSource + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-escape'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + freshWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + freshRuns <- newIORef (0 :: Int) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (acceptedResolver executable freshRuns) + Declaration.FreshValidation + freshWorkspace + assertEqual "fresh escape graph Vampire requests" + 5 + =<< readIORef freshRuns + assertEscapeGraph "fresh" freshModules + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + compileWarm workspace = do + runs <- newIORef (0 :: Int) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (acceptedResolver executable runs) + validation + workspace + runCount <- readIORef runs + pure (modules, runCount) + (warmModules, warmRuns) <- compileWarm freshWorkspace + assertEqual "exact escape warm hit skips Vampire" + 0 warmRuns + assertEscapeGraph "warm" warmModules + assertEqual "warm escape graph preserves module semantics" + (moduleSemantics freshModules) + (moduleSemantics warmModules) + assertEqual "warm escape graph preserves module prefixes" + (modulePrefixes freshModules) + (modulePrefixes warmModules) + + let formattingOnly = + Text.encodeUtf8 + ("% shifted exact escape source\n" + <> Text.decodeUtf8 consumerSource) + ByteString.writeFile consumerPath formattingOnly + formattedWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + assertBool "formatting changes the escape parsed identity" + (Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule freshWorkspace) + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule + formattedWorkspace)) + (formattedModules, formattedRuns) <- + compileWarm formattedWorkspace + assertEqual "formatting-only escape edit reuses validation" + 0 formattedRuns + assertEqual "formatting-only escape edit preserves semantics" + (moduleSemantics freshModules) + (moduleSemantics formattedModules) + + let omittedGoalEdit = + Text.encodeUtf8 + (StrictText.replace + " Show $x = x$." + " Show if $x = x$, then $x = x$." + (Text.decodeUtf8 consumerSource)) + ByteString.writeFile consumerPath omittedGoalEdit + editedWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + (editedModules, editedRuns) <- + compileWarm editedWorkspace + assertEqual "changed omitted goal misses its proof validation" + 1 editedRuns + assertEqual "changed omitted goal preserves public semantics" + (moduleSemantics freshModules) + (moduleSemantics editedModules) + where + acceptedResolver executable runs = + Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + moduleSemantics = fmap Module.sealedTypedModuleSemantic + modulePrefixes = + fmap + (Declaration.pendingModulePrefixCurrent + . Module.sealedTypedModulePrefix) + + assertEscapeGraph label = \case + [producer, consumer] -> do + let producerBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix producer) + consumerBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix consumer) + case producerBatches of + [sourceAxiom, omitted] -> do + assertEscapeSafety + (label <> " source axiom") + [Authority.SourceAxiom] + sourceAxiom + assertDeclarationDirect + (label <> " source axiom") + Authority.SourceAxiomAuthorization + sourceAxiom + assertEscapeSafety + (label <> " omitted theorem") + [Authority.Omitted] + omitted + assertProofDirectOmitted + (label <> " omitted theorem") + omitted + batches -> + assertFailure + (label <> " producer batch count: " + <> show (length batches)) + case consumerBatches of + [fromAxiom, fromOmitted, throughLocal, ownOmission] -> do + assertEscapeSafety + (label <> " source-axiom consumer") + [Authority.SourceAxiom] + fromAxiom + assertProofDirectChecked + (label <> " source-axiom consumer") 1 fromAxiom + assertEscapeSafety + (label <> " omitted consumer") + [Authority.Omitted] + fromOmitted + assertProofDirectChecked + (label <> " omitted consumer") 1 fromOmitted + assertEscapeSafety + (label <> " local source-axiom consumer") + [Authority.SourceAxiom] + throughLocal + assertProofDirectChecked + (label <> " local source-axiom consumer") + 2 throughLocal + assertEscapeSafety + (label <> " own omission") + [Authority.SourceAxiom, Authority.Omitted] + ownOmission + assertProofDirectOmitted + (label <> " own omission") ownOmission + batches -> + assertFailure + (label <> " consumer batch count: " + <> show (length batches)) + modules -> + assertFailure + (label <> " escape module count: " + <> show (length modules)) + + assertEscapeSafety label expected batch = do + fact <- sole (label <> " fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " public escape kinds") + expected + (Authority.escapeKindsToList + (Authority.authoritySafetyEscapeKinds + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)))) + + assertDeclarationDirect label expected batch = do + validation <- + maybe + (assertFailure (label <> " declaration validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- sole (label <> " declaration certificate") + (Semantic.declarationValidationRecordCertificates validation) + assertEqual (label <> " direct authorization") + expected + (Authority.validationDirectAuthorization certificate) + + assertProofDirectChecked label expectedCount batch = do + authorization <- proofDirect label batch + case authorization of + Authority.CheckedSourceProof requests -> + assertEqual (label <> " accepted request count") + expectedCount (length requests) + direct -> + assertFailure + (label <> " has unexpected direct authority: " + <> show direct) + + assertProofDirectOmitted label batch = do + authorization <- proofDirect label batch + assertEqual (label <> " direct authorization") + Authority.OmittedAuthorization authorization + + proofDirect label batch = do + record <- sole (label <> " proof validation") + (Declaration.committedBatchProofValidations batch) + pure + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + +rejectsAfterExactOmittedSubclaim :: Assertion +rejectsAfterExactOmittedSubclaim = + Temp.withSystemTempDirectory "felix-exact-omitted-rollback" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-escape-consumer.tex" + parsedModules <- + pure + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + (producerParsed, consumerParsed) <- + case parsedModules of + [producer, consumer] -> pure (producer, consumer) + modules -> + assertFailure + ("unexpected rollback graph size: " + <> show (length modules)) + >> fail "unreachable" + producerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + producerParsed + []) + producer <- Module.runTypedModule producerInput >>= \case + Module.TypedModuleSucceeded sealed -> pure sealed + _ -> + assertFailure "escape producer did not seal" + >> fail "unreachable" + let executable = root Posix. "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for omitted-rollback'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + calls <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + runCount <- readIORef calls + modifyIORef' calls (+ 1) + if runCount < 4 + then + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + else + pure + (Right + (Provers.CounterSatisfiable + "rejected continuation")) + consumerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + consumerParsed + [producer]) + Module.runTypedModule consumerInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "the continuation is the fifth request" + 5 + =<< readIORef calls + assertEqual "rejected continuation location" + 37 (locLine location) + assertEqual "omitted declaration rolls back atomically" + 3 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "rejected omitted continuation was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("omitted rollback module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected omitted rollback failure: " + <> show failure) + +reusesExactProofValidationAcrossModuleMisses :: Assertion +reusesExactProofValidationAcrossModuleMisses = + Temp.withSystemTempDirectory "felix-exact-proof-cache" \root -> do + let relative = "test/phase5/exact-proofs.tex" + producerRelative = "test/phase5/exact-producer.tex" + sourcePath = root Posix. relative + producerPath = root Posix. producerRelative + executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + original <- ByteString.readFile relative + producer <- ByteString.readFile producerRelative + ByteString.writeFile sourcePath original + ByteString.writeFile producerPath producer + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-cache'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + freshWorkspace <- parseExactWorkspace bootstrap mounts relative + freshRuns <- newIORef (0 :: Int) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable freshRuns) + Declaration.FreshValidation + freshWorkspace + assertEqual "fresh proof obligations run Vampire" + 7 + =<< readIORef freshRuns + freshRoot <- sole "fresh exact proof root" (drop 1 freshModules) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + compileWarm workspace = do + runs <- newIORef (0 :: Int) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable runs) + validation + workspace + rootModule <- sole "warm exact proof root" (drop 1 modules) + runCount <- readIORef runs + pure (rootModule, runCount) + (unchangedRoot, unchangedRuns) <- + compileWarm freshWorkspace + assertEqual "exact warm hit skips Vampire" + 0 unchangedRuns + assertEqual "exact warm hit preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic unchangedRoot) + + let formattingOnly = + Text.encodeUtf8 + (StrictText.replace + "\\begin{proposition}\\label{phase5_structural_proof}" + ("% shifted source location\n" + <> "\\begin{proposition}\\label{phase5_structural_proof}") + (Text.decodeUtf8 original)) + ByteString.writeFile sourcePath formattingOnly + formattedWorkspace <- + parseExactWorkspace bootstrap mounts relative + assertBool "formatting changes parsed module identity" + (Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule freshWorkspace) + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule formattedWorkspace)) + (formattedRoot, formattedRuns) <- + compileWarm formattedWorkspace + assertEqual "formatting-only module miss reuses proof validation" + 0 formattedRuns + assertEqual "formatting-only miss preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic formattedRoot) + + let semanticEdit = + Text.encodeUtf8 + (StrictText.replace + " We have $x = x$ by assumption." + (StrictText.intercalate "\n" + [ " Show $x = x$." + , " \\begin{subproof}" + , " Follows by assumption." + , " \\end{subproof}" + ]) + (Text.decodeUtf8 original)) + ByteString.writeFile sourcePath semanticEdit + editedWorkspace <- + parseExactWorkspace bootstrap mounts relative + (editedRoot, editedRuns) <- + compileWarm editedWorkspace + assertEqual "semantic proof edit reruns its obligations" + 2 editedRuns + assertEqual "request-equivalent proof preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic editedRoot) +rejectsFixedSemanticDeclaration :: Assertion +rejectsFixedSemanticDeclaration = + Temp.withSystemTempDirectory "felix-fixed-semantic" \root -> do + let relative = "entry.tex" + path = root Posix. relative + source = + "\\begin{signature}\\label{source_unions}\n" + <> " $\\unions{X}$ is a set.\n" + <> "\\end{signature}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactFixedSemanticCollision + location key))) + prefix -> do + assertEqual "fixed collision line" 1 (locLine location) + assertEqual "fixed collision key" + (Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "unions") + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons + Raw.InvisibleBraceR Raw.End))))) + key + assertEqual "fixed collision commits no prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "fixed semantic declaration was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("fixed semantic module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected fixed semantic failure: " + <> show failure) + +rejectsFixedSemanticInductive :: Assertion +rejectsFixedSemanticInductive = + Temp.withSystemTempDirectory "felix-fixed-inductive" \root -> do + let relative = "entry.tex" + path = root Posix. relative + source = + "\\begin{inductive}\\label{source_pow}\n" + <> " Define $\\pow{A}\\subseteq\\cumul{A}$ inductively as follows.\n" + <> " \\begin{enumerate}\n" + <> " \\item $A\\in\\pow{A}$.\n" + <> " \\end{enumerate}\n" + <> "\\end{inductive}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactInductiveFailed + (ExactInductive.ExactInductiveFixedSemanticCollision + location key))) + prefix -> do + assertEqual "fixed inductive collision line" + 1 + (locLine location) + assertEqual "fixed inductive collision key" + (Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "pow") + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons + Raw.InvisibleBraceR Raw.End))))) + key + assertEqual "fixed inductive collision commits no prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "fixed semantic inductive was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("fixed semantic inductive did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected fixed inductive failure: " + <> show failure) + +keepsExactSemanticsIndependentOfFixity :: Assertion +keepsExactSemanticsIndependentOfFixity = + Temp.withSystemTempDirectory "felix-exact-fixity" \root -> do + let relative = "test/phase5/exact-producer.tex" + path = root Posix. relative + createDirectoryIfMissing True (Posix.takeDirectory path) + original <- ByteString.readFile relative + let changed = + Text.encodeUtf8 + (StrictText.replace + "infixl 2" + "infixr 6" + (Text.decodeUtf8 original)) + ByteString.writeFile path original + first <- compileExactRootAt root relative + ByteString.writeFile path changed + second <- compileExactRootAt root relative + let firstParsed = Parse.parsedWorkspaceRootModule (fst first) + secondParsed = Parse.parsedWorkspaceRootModule (fst second) + firstSealed = snd first + secondSealed = snd second + assertBool "fixity changes syntax identity" + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface firstParsed) + /= Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface secondParsed)) + assertBool "fixity changes parsed identity" + (Parse.parsedModuleId firstParsed + /= Parse.parsedModuleId secondParsed) + assertEqual "fixity preserves semantic interface" + (Module.sealedTypedModuleSemantic firstSealed) + (Module.sealedTypedModuleSemantic secondSealed) + assertEqual "fixity preserves semantic prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix firstSealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix secondSealed)) + +loadsCachedExactProducerForFreshImporter :: Assertion +loadsCachedExactProducerForFreshImporter = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-exact-cache" \root -> do + let path = root Posix. "store.sqlite" + executable = root Posix. "vampire" + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore path (Identity.theoryId foundation) + >>= expectRight + let observer = Verification.verificationRequestObserver \_ordinal _request -> + pure () + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + verify mode source = + (checkResultWithStore + store mode observer prover source) + >>= expectRight + producer <- + verify Verification.FreshStoreValidation + "test/phase5/exact-producer.tex" + importer <- + verify Verification.WarmStoreValidation + "test/phase5/exact-importer.tex" + assertTypedSuccess "fresh producer" producer + assertTypedSuccess "warm producer/fresh importer" importer + memo <- Store.newStoreMemo store + prelude <- + expectRight + =<< Module.acquireFinalPreludeSession + memo store foundation unusedResolver + preludeVisits <- Store.storeMemoVisits memo + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-importer.tex" + let parsedModules = + toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + preludeSemantic = + Module.sealedTypedModuleSemantic + (Module.finalPreludeModule prelude) + preludeId = + Semantic.semanticInterfaceAssertedId preludeSemantic + theory = Identity.theoryId foundation + loadInstallation parsed direct = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + direct + theory) + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + maybe + (assertFailure "exact cached installation is absent" + >> fail "unreachable") + pure + loaded + environmentBindings installation = + [ binding + | delta <- Semantic.semanticInterfaceDeclarations + (Store.cachedInstallationSemantic installation) + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + ] + case parsedModules of + [producerParsed, importerParsed] -> do + producerInstallation <- + loadInstallation producerParsed [preludeId] + producerVisits <- Store.storeMemoVisits memo + assertEqual "ordinary root adds one artifact validation" + (Store.storeArtifactsValidated preludeVisits + 1) + (Store.storeArtifactsValidated producerVisits) + assertEqual "ordinary root reuses prelude syntax validation" + (Store.storeSyntaxRowsValidated preludeVisits + 1) + (Store.storeSyntaxRowsValidated producerVisits) + assertEqual "ordinary root reuses prelude semantic validation" + (Store.storeSemanticRowsValidated preludeVisits + 1) + (Store.storeSemanticRowsValidated producerVisits) + let producerSemanticId = + Semantic.semanticInterfaceAssertedId + (Store.cachedInstallationSemantic + producerInstallation) + importerInstallation <- + loadInstallation + importerParsed [preludeId, producerSemanticId] + case ( environmentBindings producerInstallation + , environmentBindings importerInstallation + ) of + (seedBinding : aliasBinding : _definitionBinding : [], + [importerBinding]) -> do + let seedTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + seedBinding) + aliasTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + aliasBinding) + importerTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + importerBinding) + assertEqual "cached importer reuses expanded content" + aliasTarget importerTarget + assertEqual "cached importer adds no object" + [] + (Store.cachedInstallationObjects + importerInstallation) + expandedObject <- + maybe + (assertFailure + "cached expanded object is absent" + >> fail "unreachable") + pure + (find + ((== aliasTarget) + . Identity.assertedObjectId) + (Store.cachedInstallationObjects + producerInstallation)) + case Identity.assertedObjectContent expandedObject of + Identity.TransparentObjectContent + _identity _coreType body -> + assertEqual + "cached expansion retains the opaque seed" + (Set.singleton seedTarget) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("cached expansion is not transparent: " + <> show content) + (producerBindings, importerBindings) -> + assertFailure + ("unexpected cached exact bindings: " + <> show + ( length producerBindings + , length importerBindings + )) + modules -> + assertFailure + ("unexpected cached exact module count: " + <> show (length modules)) + Store.closeStore store + +selectsConcurrentModuleFailureDeterministically :: Assertion +selectsConcurrentModuleFailureDeterministically = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-concurrent-module-failure" \root -> do + let executable = root Posix. "vampire" + source = "test/phase7/concurrent-failure-root.tex" + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + select amount = + Provers.selectEffectiveJobs + (Provers.effectiveJobs amount) + (fail "explicit jobs unexpectedly detected processors") + reportEntry escape = + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + ) + inspect label expectedPositions + (result, _slowReport, positions) = do + case result of + Verification.VerificationFailure report failed -> do + assertEqual (label <> " selected earlier failure") + "test/phase7/concurrent-earlier.tex" + (locFile (Verification.failedVerificationLocation failed)) + assertEqual (label <> " admitted source prefix") + [ ( Verification.ReportedSourceAxiom + , "test/phase7/concurrent-earlier.tex" + , 1 + ) + ] + (reportEntry + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + (label <> " did not reject deterministically: " + <> show other) + assertEqual (label <> " executed only sibling obligations") + expectedPositions + (sort + [ ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal position + ) + | position <- positions + ]) + runCase label jobsAmount = do + let storePath = root Posix. (label <> ".sqlite") + processLock = root Posix. (label <> ".process-lock") + processStarted = + root Posix. (label <> ".process-started") + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Seed only the final prelude. The unsupported ordinary + -- module cannot publish a root. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + prover + "test/phase3/typed-unsupported.tex") + >>= expectRight) + writeFile executable + (unlines + [ "#!/bin/sh" + , "while ! mkdir \"" <> processLock + <> "\" 2>/dev/null; do sleep 0.01; done" + , "trap 'rmdir \"" <> processLock + <> "\"' EXIT" + , ": > \"" <> processStarted <> "\"" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for concurrent-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + positionsRef <- newIORef [] + let observer = + Verification.verificationRequestObserver + (\position _request -> do + atomicModifyIORef' positionsRef + (\positions -> + (position : positions, ())) + when + (jobsAmount > 1 + && Provers.workPositionModuleOrdinal + position == 1) + (waitForFileSignal + "later module process" + processStarted)) + jobs <- select jobsAmount + (result, slowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + prover + source) + >>= expectRight + positions <- readIORef positionsRef + pure (result, slowReport, positions) + void $ runCase "parallel" 2 + >>= inspect "parallel" [(1, 1), (2, 1)] + void $ runCase "sequential" 1 + >>= inspect "sequential" [(1, 1)] + +waitForFileSignal :: String -> FilePath -> Assertion +waitForFileSignal label path = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just () -> + pure () + Nothing -> + assertFailure (label <> " was not observed") + where + loop = do + exists <- doesFileExist path + if exists + then pure () + else do + threadDelay 10000 + loop + +batchesStructureObligationsAtomically :: Assertion +batchesStructureObligationsAtomically = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-structure-obligation-batch" \root -> do + let storePath = root Posix. "store.sqlite" + executable = root Posix. "vampire" + unavailable = root Posix. "must-not-run-vampire" + source = "test/phase7/structure-obligation-batch.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + select amount = + Provers.selectEffectiveJobs + (Provers.effectiveJobs amount) + (fail "explicit jobs unexpectedly detected processors") + run openStore jobs observer vampireCommand = + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + vampireCommand + source) + >>= expectRight + inspectFailure label positions (result, _slowReport) = do + case result of + Verification.VerificationFailure report failed -> do + assertEqual (label <> " selects first consequence") + (source, 12) + ( locFile (Verification.failedVerificationLocation failed) + , locLine (Verification.failedVerificationLocation failed) + ) + assertEqual (label <> " retains preceding prefix") + [(Verification.ReportedSourceAxiom, source, 1)] + [ ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + ) + | escape <- Verification.verificationDirectEscapes report + ] + other -> + assertFailure + (label <> " did not reject its structure batch: " + <> show other) + assertEqual (label <> " assigns consecutive positions") + [(1, 1), (1, 2)] + (sort positions) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + -- Seed only the confined prelude so this fixture observes exactly + -- the ordinary structure module's ready batch. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + parallelJobs <- select 2 + parallelPositions <- newIORef [] + firstStarted <- newEmptyTMVarIO + secondStarted <- newEmptyTMVarIO + releaseFirst <- newEmptyTMVarIO + let laterCompleted = root Posix. "later-completed" + writeLaterAcceptingVampire executable laterCompleted + let parallelObserver = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + atomicModifyIORef' parallelPositions + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , ordinal + ) : positions + , () + )) + case ordinal of + 1 -> do + atomically (putTMVar firstStarted ()) + atomically (takeTMVar releaseFirst) + 2 -> + atomically (putTMVar secondStarted ()) + _ -> + assertFailure + ("unexpected structure request ordinal: " + <> show ordinal) + withAsync + (run openStore parallelJobs parallelObserver + (prover executable)) + \verification -> do + void + (awaitSignal "first structure request" + (atomically (takeTMVar firstStarted))) + void + (awaitSignal "second structure request" + (atomically (takeTMVar secondStarted))) + -- Only the later member can reach the subprocess while + -- the first observer is gated. Its completed signal + -- therefore establishes reversed wall-clock completion. + waitForFileSignal + "later structure consequence" + laterCompleted + atomically (putTMVar releaseFirst ()) + parallelResult <- wait verification + positions <- readIORef parallelPositions + inspectFailure "parallel" positions parallelResult + + sequentialJobs <- select 1 + sequentialPositions <- newIORef [] + let sequentialCompleted = root Posix. "sequential-completed" + writeRejectingVampire executable sequentialCompleted + let sequentialObserver = + Verification.verificationRequestObserver \position _request -> + atomicModifyIORef' sequentialPositions + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal + position + ) : positions + , () + )) + sequentialResult <- + run openStore sequentialJobs sequentialObserver + (prover executable) + sequentialObserved <- readIORef sequentialPositions + inspectFailure "sequential" + sequentialObserved sequentialResult + + -- A rejected sibling wrote neither validation nor a module root: + -- the complete batch executes again, while the earlier source + -- axiom remains the admitted prefix. A subsequent hit executes + -- no request at all. + writeAcceptedFixtureVampire executable + acceptedPositions <- newIORef [] + let acceptedObserver = + Verification.verificationRequestObserver \position _request -> + modifyIORef' acceptedPositions + (position :) + (accepted, _acceptedSlowReport) <- + run openStore parallelJobs acceptedObserver + (prover executable) + case accepted of + Verification.VerificationCompleted report _presentation -> + assertEqual "successful retry retains only source axiom" + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + ("successful structure retry failed: " <> show other) + acceptedObserved <- readIORef acceptedPositions + assertEqual "successful retry executes the complete batch" + 2 + (length acceptedObserved) + let forbiddenObserver = + Verification.verificationRequestObserver \position _request -> + assertFailure + ("warm structure batch invoked Vampire at " + <> show position) + (warm, _warmSlowReport) <- + run openStore parallelJobs forbiddenObserver + (prover unavailable) + case warm of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm structure batch did not install: " <> show other) + where + awaitSignal label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + + writeRejectingVampire executable completed = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , ": > \"" <> completed <> "\"" + , "printf '%s\\n' '% SZS status CounterSatisfiable for structure-batch-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + + writeLaterAcceptingVampire executable completed = do + let firstProcess = completed <> ".first-process" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , ": > \"" <> completed <> "\"" + , "if mkdir \"" <> firstProcess <> "\" 2>/dev/null; then" + , " printf '%s\\n' '% SZS status Theorem for structure-batch-fixture'" + , "else" + , " printf '%s\\n' '% SZS status CounterSatisfiable for structure-batch-fixture'" + , "fi" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + +speculatesDependentProofObligationsWithoutAdmittingAhead :: Assertion +speculatesDependentProofObligationsWithoutAdmittingAhead = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-dependent-proof-chain" \root -> do + let executable = root Posix. "vampire" + unavailable = root Posix. "must-not-run-vampire" + storePath = root Posix. "store.sqlite" + source = "test/phase7/dependent-proof-chain.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Seed only the final prelude so the observed work belongs to the + -- ordinary proof module. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + jobs <- + Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + firstStarted <- newEmptyTMVarIO + secondStarted <- newEmptyTMVarIO + releaseFirst <- newEmptyTMVarIO + positionsRef <- newIORef [] + let observer = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + atomicModifyIORef' positionsRef + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , ordinal + ) : positions + , () + )) + case ordinal of + 1 -> do + atomically (putTMVar firstStarted ()) + atomically (takeTMVar releaseFirst) + 2 -> atomically (putTMVar secondStarted ()) + _ -> + assertFailure + ("unexpected dependent proof request: " + <> show ordinal) + withAsync + ( + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + (prover executable) + source) + >>= expectRight) + \checking -> do + void + (awaitSignal "local subclaim request" + (atomically (takeTMVar firstStarted))) + -- The continuation is semantically dependent, but its + -- already checked request may execute prospectively. It + -- cannot be admitted until the local claim succeeds. + void + (awaitSignal "dependent continuation request" + (atomically (takeTMVar secondStarted))) + atomically (putTMVar releaseFirst ()) + (result, _slowReport) <- wait checking + case result of + Verification.VerificationCompleted report _presentation -> + assertEqual "only the preceding axiom is reported" + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + ("dependent proof module did not seal: " + <> show other) + positions <- readIORef positionsRef + assertEqual "dependent requests retain source positions" + [(1, 1), (1, 2)] + (sort positions) + + let forbiddenObserver = + Verification.verificationRequestObserver \position _request -> + assertFailure + ("warm dependent proof invoked Vampire at " + <> show position) + (warm, _warmSlowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + forbiddenObserver + (prover unavailable) + source) + >>= expectRight + case warm of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm dependent proof did not install: " <> show other) + where + awaitSignal label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + +schedulesDiamondAfterSealedImports :: Assertion +schedulesDiamondAfterSealedImports = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-concurrent-diamond" \root -> do + let storePath = root Posix. "store.sqlite" + executable = root Posix. "vampire" + unavailable = root Posix. "must-not-run-vampire" + source = "test/phase7/diamond-root.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Acquire the final prelude before introducing scheduler gates. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + jobs <- Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + baseStarted <- newEmptyTMVarIO + branchStarted <- newTQueueIO + rootStarted <- newEmptyTMVarIO + releaseBase <- newTVarIO False + releaseBranches <- newTVarIO False + let awaitRelease released = + atomically (readTVar released >>= check) + observer = + Verification.verificationRequestObserver + (\position _request -> + case Provers.workPositionModuleOrdinal position of + 1 -> do + atomically (putTMVar baseStarted ()) + awaitRelease releaseBase + ordinal@2 -> do + atomically + (writeTQueue branchStarted ordinal) + awaitRelease releaseBranches + ordinal@3 -> do + atomically + (writeTQueue branchStarted ordinal) + awaitRelease releaseBranches + 4 -> + atomically (putTMVar rootStarted ()) + _ -> + pure ()) + verify vampireCommand requestObserver = + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + requestObserver + vampireCommand + source) + >>= expectRight + await label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + withAsync (verify (prover executable) observer) \verification -> do + void (await "base request" (atomically (takeTMVar baseStarted))) + threadDelay 50000 + atomically (tryReadTQueue branchStarted) >>= \case + Nothing -> pure () + Just ordinal -> + assertFailure + ("dependent module started before base seal: " + <> show ordinal) + atomically (writeTVar releaseBase True) + firstBranch <- await "first branch" + (atomically (readTQueue branchStarted)) + secondBranch <- await "second branch" + (atomically (readTQueue branchStarted)) + assertEqual "both diamond branches became ready together" + [2, 3] + (sort [firstBranch, secondBranch]) + atomically (tryReadTMVar rootStarted) >>= \case + Nothing -> pure () + Just () -> + assertFailure + "diamond root started before both branch seals" + atomically (writeTVar releaseBranches True) + void (await "diamond root" (atomically (takeTMVar rootStarted))) + (coldResult, _coldSlowReport) <- wait verification + case coldResult of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("cold diamond did not complete: " <> show other) + let forbiddenObserver = + Verification.verificationRequestObserver + (\position _request -> + assertFailure + ("warm diamond invoked Vampire at " + <> show position)) + (warmResult, _warmSlowReport) <- + verify (prover unavailable) forbiddenObserver + case warmResult of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm diamond did not install: " <> show other) + +reportsAdmittedSourceEscapes :: Assertion +reportsAdmittedSourceEscapes = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-admitted-source-report" \root -> do + let storePath = root Posix. "store.sqlite" + executable = root Posix. "vampire" + unavailable = root Posix. "must-not-run-vampire" + observer = + Verification.verificationRequestObserver \_ordinal _request -> pure () + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let verify mode vampirePath source = + (checkFileWithStore + openStore + mode + observer + (prover vampirePath) + source) + >>= expectRight + reportEntries = + fmap + (\escape -> + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + )) + . Verification.verificationDirectEscapes + expectedConsumer = + [ ( Verification.ReportedSourceAxiom + , "test/phase5/exact-escape-producer.tex" + , 1 + ) + , ( Verification.ReportedOmitted + , "test/phase5/exact-escape-producer.tex" + , 9 + ) + , ( Verification.ReportedOmitted + , "test/phase5/exact-escape-consumer.tex" + , 35 + ) + ] + (freshResult, _freshSlowReport) <- + verify + Verification.FreshStoreValidation + executable + "test/phase5/exact-escape-consumer.tex" + freshReport <- case freshResult of + Verification.CompletedWithExplicitGaps report _presentation -> pure report + other -> + assertFailure + ("fresh escape report did not complete with gaps: " + <> show other) + >> fail "unreachable" + assertEqual "fresh direct escapes" + expectedConsumer + (reportEntries freshReport) + (warmResult, _warmSlowReport) <- + verify + Verification.WarmStoreValidation + unavailable + "test/phase5/exact-escape-consumer.tex" + warmReport <- case warmResult of + Verification.CompletedWithExplicitGaps report _presentation -> pure report + other -> + assertFailure + ("warm escape report did not complete with gaps: " + <> show other) + >> fail "unreachable" + assertEqual "warm report uses rebound current locations" + freshReport warmReport + + void + (verify + Verification.FreshStoreValidation + executable + "test/phase5/exact-source-axiom.tex") + (failedResult, _failedSlowReport) <- + verify + Verification.WarmStoreValidation + unavailable + "test/phase6/admitted-prefix-failure.tex" + failedReport <- case failedResult of + Verification.VerificationCheckingFailure report _failure -> pure report + other -> + assertFailure + ("typed suffix failure was not report-bearing: " + <> show other) + >> fail "unreachable" + assertEqual "failure report retains only admitted source prefix" + (take 2 expectedConsumer + <> [ ( Verification.ReportedOmitted + , "test/phase6/admitted-prefix-failure.tex" + , 7 + ) + ]) + (reportEntries failedReport) + +classifiesTypedVampireFailures :: Assertion +classifiesTypedVampireFailures = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-typed-failure-classification" \root -> do + let storePath = root Posix. "store.sqlite" + executable = root Posix. "vampire" + observer = + Verification.verificationRequestObserver \_ordinal _request -> pure () + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let verify source = + (checkFileWithStore + openStore + Verification.WarmStoreValidation + observer + prover + source) + >>= expectRight + writeProtocol lines = do + writeFile executable + (unlines (["#!/bin/sh", "cat >/dev/null"] <> lines)) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + expectTypedFailure classify = do + (result, slowReport) <- + verify "test/phase5/exact-runtime-failure.tex" + case result of + Verification.VerificationFailure report failed -> do + assertEqual "typed failure has no direct escapes" + [] + (Verification.verificationDirectEscapes report) + assertEqual "typed failure retains source location" + "test/phase5/exact-runtime-failure.tex" + (locFile + (Verification.failedVerificationLocation failed)) + classify + (Verification.failedVerificationReason failed) + (CommandLine.verificationCommandOutcome + result slowReport) + other -> + assertFailure + ("typed prover outcome was misclassified: " + <> show other) + + -- Populate only the confined prelude. The selected ordinary + -- module then remains a miss for each classified live failure. + (_preludeResult, _preludeSlowReport) <- + verify "test/phase3/typed-unsupported.tex" + + writeProtocol + [ "printf '%s\\n' '% SZS status CounterSatisfiable for typed-failure'" + , "exit 0" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.CountermodelFailure{} -> pure () + other -> assertFailure ("expected countermodel: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected rejection: " <> show other) + + writeProtocol + [ "printf '%s\\n' '% SZS status Timeout for typed-failure'" + , "exit 0" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.IndeterminateFailure{} -> pure () + other -> assertFailure ("expected indeterminate result: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + + writeProtocol + [ "printf '%s\\n' '% SZS status Theorem for typed-failure'" + , "exit 7" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.ProtocolFailure{} -> pure () + other -> assertFailure ("expected protocol failure: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + + writeFile executable "not executable" + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable False permissions) + expectTypedFailure \reason outcome -> do + case reason of + Verification.TransportFailure{} -> pure () + other -> assertFailure ("expected transport failure: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + +retainsExactPrefixBeforeFailure :: Assertion +retainsExactPrefixBeforeFailure = do + result <- + withAcceptedFixtureVampire "felix-exact-failure" \prover -> + (checkFileFresh + prover + "test/phase5/exact-failure.tex") + case result of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactGuardedOpaqueSignature location))) + prefix) + , _slowReport + ) -> do + assertEqual "failed exact source" + "test/phase5/exact-failure.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertEqual "unsupported declaration line" 6 (locLine location) + assertEqual "earlier exact declaration remains committed" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure ("unexpected exact failure: " <> show err) + Right{} -> + assertFailure "unsupported declaration was admitted" + + proofFailure <- + withAcceptedFixtureVampire "felix-exact-proof-failure" \prover -> + (checkFileFresh + prover + "test/phase5/exact-proof-failure.tex") + case proofFailure of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofGoalStatementMismatch + location))) + prefix) + , _slowReport + ) -> do + assertEqual "mismatched assumption line" 10 (locLine location) + assertEqual "failed proof publishes no theorem" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected exact proof failure: " <> show err) + Right{} -> + assertFailure "mismatched exact proof was admitted" + + unmatched <- + withAcceptedFixtureVampire "felix-unmatched-proof" \prover -> + (checkFileFresh + prover + "test/phase5/unmatched-proof.tex") + case unmatched of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedUnmatchedProof location)) + prefix) + , _slowReport + ) -> do + assertEqual "unmatched proof line" 1 (locLine location) + assertEqual "unmatched proof publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected unmatched-proof failure: " <> show err) + Right{} -> + assertFailure "unmatched proof was admitted" + + runtimeFailure <- + Temp.withSystemTempDirectory "felix-runtime-proof-failure" \root -> do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-runtime-failure.tex" + let executable = root Posix. "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for located-proof'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + runs <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + runNumber <- readIORef runs + modifyIORef' runs (+ 1) + if runNumber == 0 + then + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + else + pure + (Right + (Provers.CounterSatisfiable + "later exact obligation")) + parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input + case runtimeFailure of + Module.TypedModuleFailed + failure@(Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "later rejected obligation line" + 11 + (locLine location) + assertEqual "typed failure retains obligation location" + (Just location) + (Module.typedModuleFailureLocation failure) + assertEqual "runtime proof failure publishes no theorem" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "unexpected runtime proof failure" + +restoresCheckedSetInduction :: Assertion +restoresCheckedSetInduction = + Temp.withSystemTempDirectory "felix-checked-set-induction" \root -> do + let executable = root Posix. "vampire" + storePath = root Posix. "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + + initialWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-initial.tex" + initialObservations <- newIORef [] + initial <- + sole "initial set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable initialObservations) + Declaration.FreshValidation + initialWorkspace + [initialRequest] <- + expectCount "initial set-induction request" 1 + =<< readIORef initialObservations + assertEqual "initial induction retains header then hypothesis ordinals" + [0, 1] + (localReasoningLocalOrdinals initialRequest) + let initialTarget = + Core.CEq Core.TySet (Core.CBound 0) (Core.CBound 0) + initialAntecedent = + member (Core.CBound 1) (Core.CBound 0) + initialHypothesis = + Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 2)) + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + assertEqual "initial induction child target" + initialTarget + (localReasoningTarget initialRequest) + assertEqual "initial induction uses the complete guarded property" + [initialAntecedent, initialHypothesis] + (localReasoningLocalTerms initialRequest) + + nestedWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-nested.tex" + nestedObservations <- newIORef [] + nested <- + sole "nested set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable nestedObservations) + Declaration.FreshValidation + nestedWorkspace + [nestedChild, nestedContinuation] <- + expectCount "nested set-induction requests" 2 + =<< readIORef nestedObservations + let x = Core.CBound 0 + a = Core.CBound 1 + y = Core.CBound 0 + xUnderY = Core.CBound 1 + aUnderY = Core.CBound 2 + guardAtX = + andP + (member x a) + (notP (Core.CEq Core.TySet x a)) + guardAtY = + andP + (member y aUnderY) + (notP (Core.CEq Core.TySet y aUnderY)) + nestedHypothesis = + Core.CForall Core.TySet + (Core.CImp + (member y xUnderY) + (Core.CImp + guardAtY + (Core.CEq Core.TySet y y))) + nestedTarget = Core.CEq Core.TySet x x + assertEqual + "omitted leading induction retains its source binder and guard" + ([0, 1], [nestedHypothesis, guardAtX], nestedTarget) + ( localReasoningLocalOrdinals nestedChild + , localReasoningLocalTerms nestedChild + , localReasoningTarget nestedChild + ) + case localReasoningLocalTerms nestedContinuation of + [derived] -> do + assertEqual "subproof continuation uses one derived local" + [2] (localReasoningLocalOrdinals nestedContinuation) + assertEqual "subproof closes the exact binder-level result" + derived (localReasoningTarget nestedContinuation) + locals -> + assertFailure + ("unexpected induction continuation locals: " + <> show locals) + + formulaWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-formula-quantified.tex" + formulaObservations <- newIORef [] + _formula <- + sole "formula-quantified set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable formulaObservations) + Declaration.FreshValidation + formulaWorkspace + [formulaChild, formulaContinuation] <- + expectCount "formula-quantified set-induction requests" 2 + =<< readIORef formulaObservations + assertEqual + "formula-quantified omitted induction retains its written binder" + (Core.CEq Core.TySet (Core.CBound 0) (Core.CBound 0)) + (localReasoningTarget formulaChild) + assertEqual + "formula-quantified continuation retains hypothesis and derived local" + [0, 1] + (localReasoningLocalOrdinals formulaContinuation) + + anchorWorkspace <- parseExactWorkspace bootstrap mounts + "test/examples/no-reflexive-set.tex" + anchorObservations <- newIORef [] + _anchor <- + sole "omitted-focus set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable anchorObservations) + Declaration.FreshValidation + anchorWorkspace + [anchorRequest] <- + expectCount "omitted-focus set-induction request" 1 + =<< readIORef anchorObservations + anchorLocal <- + case localReasoningLocalTerms anchorRequest of + [term] -> pure term + terms -> + assertFailure + ("unexpected omitted-focus locals: " <> show terms) + >> fail "unreachable" + assertEqual "omitted focus retains its source binder in the child" + ([0], Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (notP (member (Core.CBound 0) (Core.CBound 0))))) + ( localReasoningLocalOrdinals anchorRequest + , anchorLocal + ) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-induction-ambiguous.tex" + (\case + ExactProof.ExactProofSetInductionFocusAmbiguous location -> + locLine location == 5 + _failure -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-induction-fixed.tex" + (\case + ExactProof.ExactProofSetInductionActiveBinderIneligible + location (Raw.NamedVar "x") -> + locLine location == 7 + _failure -> False) + + failedInput <- + moduleInput + foundation bootstrap initialWorkspace + (Declaration.vampireResolver \_prepared -> + pure + (Right + (Provers.CounterSatisfiable + "focused induction child rejection"))) + Declaration.FreshValidation + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool "failed induction child publishes no theorem" + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "rejected induction child unexpectedly succeeded" + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix nested)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm nested set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation nestedWorkspace + assertEqual "warm set induction skips Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm induction proof validations" + (proofValidations nested) + (proofValidations warm) + assertBool "initial induction publishes one theorem" + (not + (null + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix initial)))) + where + observingResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observations + (<> [ LocalReasoningObservation + { localReasoningTarget = + Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + , localReasoningGlobalCount = + Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList locals + , localReasoningLocalTerms = + Backend.supportedPropositionTerm + . Backend.typedLocalPremiseProposition + <$> Vector.toList locals + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + expectCount label expected values = do + assertEqual label expected (length values) + pure values + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + + notP proposition = Core.CImp proposition Core.CFalsum + + andP left right = notP (Core.CImp left (notP right)) + + moduleInput foundation bootstrap workspace resolver validation = do + parsed <- sole "set-induction parsed module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver validation parsed []) + + proofValidations = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + +routesProductionVerification :: Assertion +routesProductionVerification = + Temp.withSystemTempDirectory "felix-production-route" \directory -> do + let executable = directory Posix. "vampire" + counter = directory Posix. "runs" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' run >> " <> show counter + , "printf '%s\\n' '% SZS status Theorem for production-route'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + producer <- verifyFixture executable "test/phase3/typed-producer.tex" + assertTypedSuccess "exact producer" producer + selectedRuns <- runCount counter + assertBool "ordinary roots construct the final prelude" + (selectedRuns > 0) + importer <- verifyFixture executable "test/phase3/typed-importer.tex" + assertTypedSuccess "ordinary importer" importer + assertBool "every root constructs the final prelude" + . (> selectedRuns) + =<< runCount counter + where + verifyFixture executable path = + fst + <$> ( + (checkFileFresh + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + path) + >>= expectRight) + + runCount path = + length . StrictText.lines . StrictText.pack <$> readFile path + +installsNonemptyImplicitPreludeEvidence :: Assertion +installsNonemptyImplicitPreludeEvidence = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId foundation) + []) + proposition <- expectRight + (Identity.validatePropositionContent closure Core.CFalsum) + preludeDriver <- Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation + do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "nonempty-prelude") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName "prelude-fact"]) + Declaration.authorizeSourceAxiomCandidate candidate + preludeResult <- expectRight preludeDriver + (preludeSemantic, preludePrefix) <- + case preludeResult of + Declaration.DriverSucceeded _value semantic prefix _closure -> + pure (semantic, prefix) + _ -> + assertFailure "nonempty prelude fixture did not seal" + >> fail "unreachable" + preludeFingerprint <- + case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations preludeSemantic) of + [occurrence] -> + pure (Semantic.semanticFactFingerprint occurrence) + facts -> + assertFailure + ("unexpected prelude fact count: " + <> show (length facts)) + >> fail "unreachable" + let preludeSyntax = + Module.sealedTypedModuleSyntax + (Module.bootstrapPreludeModule bootstrap) + nonemptyPrelude <- + Temp.withSystemTempDirectory "felix-nonempty-prelude" \directory -> do + let path = directory Posix. "store.sqlite" + theory = Identity.theoryId foundation + parsed = + Module.identifiedModuleParsed + (Module.bootstrapPreludeInput bootstrap) + (_startup, store) <- + Store.openStore path theory >>= expectRight + artifactKey <- expectRight + (Semantic.moduleArtifactKey + preludeModuleName + (Parse.identifiedParsedModuleId parsed) + [] + theory) + let artifact = + Semantic.moduleArtifactResult + artifactKey + (Syntax.moduleSyntaxAssertedId preludeSyntax) + (Semantic.semanticInterfaceAssertedId + preludeSemantic) + _ <- expectRight + =<< Store.writeSealedModule + store + preludePrefix + [preludeSyntax] + [preludeSemantic] + artifact + memo <- Store.newStoreMemo store + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId preludeSyntax) + installation <- maybe + (assertFailure "nonempty prelude was not installed" + >> fail "unreachable") + pure + loaded + sealed <- expectRight + (Module.cachedSealedTypedModule + foundation + [] + installation) + Store.closeStore store + pure sealed + + root <- getCurrentDirectory + mounts <- + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", root) + , (sourceMountId "library", root Posix. "library") + , (sourceMountId "debug", root Posix. "debug") + ] + request <- expectRight + (searchedRoot "test/phase3/typed-producer.tex") + workspace <- + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.fixtureFinalPreludeReadinessFromSealed nonemptyPrelude) + unusedResolver + Declaration.FreshValidation + parsed + []) + ordinary <- Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded sealed -> pure sealed + _ -> + assertFailure "ordinary module rejected the nonempty prelude" + >> fail "unreachable" + + consumerDigest <- expectRight + (hashCanonicalFields + "implicit-prelude-consumer" + ["consumer"]) + consumerPath <- expectRight (safeRelativePath "consumer.tex") + let consumerOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest consumerDigest) + consumerPath + consumed <- Declaration.runModuleDriver + foundation + consumerOwner + [Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic ordinary)] + unusedResolver + Declaration.FreshValidation + do + Declaration.importSealedModuleDriver + (Module.sealedTypedModuleEvidence ordinary) + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "use-implicit-prelude") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate do + void + (Declaration.useAuthorizedFact + preludeFingerprint) + Declaration.recordOmittedUse + consumedResult <- expectRight consumed + case consumedResult of + Declaration.DriverSucceeded{} -> pure () + _ -> + assertFailure + "implicit prelude fact was not transitively visible" + +unusedResolver :: Declaration.VampireResolver +unusedResolver = + Declaration.vampireResolver \_prepared -> + fail "empty bootstrap invoked Vampire" + +writeAcceptedFixtureVampire :: FilePath -> IO () +writeAcceptedFixtureVampire executable = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for typed-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + +withAcceptedFixtureVampire + :: String + -> (Provers.Vampire -> IO value) + -> IO value +withAcceptedFixtureVampire label action = + Temp.withSystemTempDirectory label \directory -> do + let executable = directory Posix. "vampire" + writeAcceptedFixtureVampire executable + action + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + +finalPreludeResolver :: Declaration.VampireResolver +finalPreludeResolver = + Declaration.vampireResolver \prepared -> + (Provers.runPreparedTypedProver + (Provers.vampire + "vampire" + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + +countingAcceptedResolver + :: FilePath + -> IORef Int + -> Declaration.VampireResolver +countingAcceptedResolver executable runs = + Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + +prepareExactInductiveFixture + :: FilePath + -> IO + (Either + ExactInductive.ExactInductiveError + ExactInductive.PreparedExactInductive) +prepareExactInductiveFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- + sole "exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let identified = Module.identifiedPhysicalModule parsed + owner = Module.identifiedModuleOwner identified + parsedModule = Module.identifiedModuleParsed identified + (blockIndex, block) <- + sole "exact inductive block" + [ (index, candidate) + | (index, candidate@Raw.BlockInductive{}) <- + zip [0..] + (Parse.identifiedParsedModuleBlocks parsedModule) + ] + let entries = + [ Parse.parsedSyntaxOccurrenceEntry occurrence + | occurrence <- + Parse.identifiedParsedModuleSyntaxOccurrences parsedModule + , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == blockIndex + ] + action + :: Declaration.ModuleDriver Void + (Either + ExactInductive.ExactInductiveError + ExactInductive.PreparedExactInductive) + action = + Declaration.runProspectiveLoweringDriver + (ExactInductive.prepareExactInductive + foundation + block + entries) + result <- + Declaration.runModuleDriver + foundation + owner + [] + unusedResolver + Declaration.FreshValidation + action + driver <- expectRight result + case driver of + Declaration.DriverSucceeded prepared _semantic _prefix _closure -> + pure prepared + Declaration.DriverFailed failure _prefix -> + assertFailure + ("exact inductive preparation driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("exact inductive preparation driver did not seal: " + <> show failure) + >> fail "unreachable" + +prepareExactDatatypeFixture + :: FilePath + -> IO + (Either + ExactDatatype.ExactDatatypeError + ( Foundation.CheckedFoundation + , ModuleName + , ExactDatatype.PreparedExactDatatype + )) +prepareExactDatatypeFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- + sole "exact datatype parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let identified = Module.identifiedPhysicalModule parsed + owner = Module.identifiedModuleOwner identified + parsedModule = Module.identifiedModuleParsed identified + block <- + sole "exact datatype block" + (Parse.identifiedParsedModuleBlocks parsedModule) + let occurrences = + [ ( Parse.parsedSyntaxOccurrenceLocation occurrence + , Parse.parsedSyntaxOccurrenceMarker occurrence + , Parse.parsedSyntaxOccurrenceEntry occurrence + ) + | occurrence <- + Parse.identifiedParsedModuleSyntaxOccurrences parsedModule + , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == 0 + ] + action + :: Declaration.ModuleDriver Void + (Either + ExactDatatype.ExactDatatypeError + ExactDatatype.PreparedExactDatatype) + action = + Declaration.runProspectiveLoweringDriver + (ExactDatatype.prepareExactDatatype block occurrences) + result <- + Declaration.runModuleDriver + foundation + owner + [] + unusedResolver + Declaration.FreshValidation + action + driver <- expectRight result + case driver of + Declaration.DriverSucceeded prepared _semantic _prefix _closure -> + pure + ((\datatype -> (foundation, owner, datatype)) + <$> prepared) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("exact datatype preparation driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("exact datatype preparation driver did not seal: " + <> show failure) + >> fail "unreachable" + +compileExactFixture + :: FilePath + -> IO + ( Foundation.CheckedFoundation + , Module.BootstrapPreludeFixture + , Parse.ParsedSourceWorkspace + , [Module.SealedTypedModule] + ) +compileExactFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + sealed <- compileParsedWorkspace foundation bootstrap workspace + pure (foundation, bootstrap, workspace, sealed) + +compileExactRootAt + :: FilePath + -> FilePath + -> IO (Parse.ParsedSourceWorkspace, Module.SealedTypedModule) +compileExactRootAt projectRoot relative = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts projectRoot + workspace <- parseExactWorkspace bootstrap mounts relative + sealed <- compileParsedWorkspace foundation bootstrap workspace + rootModule <- sole "exact root module" (reverse sealed) + pure (workspace, rootModule) + +exactFixtureMounts :: FilePath -> IO SourceMounts +exactFixtureMounts projectRoot = do + repository <- getCurrentDirectory + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "library", repository Posix. "library") + , (sourceMountId "debug", repository Posix. "debug") + ] + +parseExactWorkspace + :: Module.BootstrapPreludeFixture + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseExactWorkspace bootstrap mounts relative = + parseExactWorkspaceWithPrelude + (Module.bootstrapPreludeModule bootstrap) + mounts + relative + +parseFinalExactWorkspace + :: Module.FinalPreludeSession + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseFinalExactWorkspace prelude mounts relative = + parseExactWorkspaceWithPrelude + (Module.finalPreludeModule prelude) + mounts + relative + +parseExactWorkspaceWithPrelude + :: Module.SealedTypedModule + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseExactWorkspaceWithPrelude prelude mounts relative = do + request <- expectRight (searchedRoot relative) + let preludeSyntax = + Module.sealedTypedModuleSyntax + prelude + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) + +compileParsedWorkspace + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspace foundation bootstrap workspace = + compileParsedWorkspaceWithResolver + foundation + bootstrap + unusedResolver + workspace + +compileParsedWorkspaceWithResolver + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Declaration.VampireResolver + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithResolver foundation bootstrap resolver workspace = + compileParsedWorkspaceWithValidation + foundation + bootstrap + resolver + Declaration.FreshValidation + workspace + +compileParsedWorkspaceWithValidation + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithValidation + foundation bootstrap resolver validation workspace = + compileParsedWorkspaceWithReadiness + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + validation + workspace + +compileFinalParsedWorkspaceWithResolver + :: Foundation.CheckedFoundation + -> Module.FinalPreludeSession + -> Declaration.VampireResolver + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileFinalParsedWorkspaceWithResolver foundation prelude resolver workspace = + compileParsedWorkspaceWithReadiness + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + workspace + +compileParsedWorkspaceWithReadiness + :: Foundation.CheckedFoundation + -> Module.FinalPreludeReadiness + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithReadiness + foundation readiness resolver validation workspace = + snd + <$> foldM + compileOne + (Map.empty, []) + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + where + compileOne (admitted, ordered) parsed = do + direct <- + traverse + (\address -> + maybe + (assertFailure + ("missing exact direct module: " <> show address) + >> fail "unreachable") + pure + (Map.lookup address admitted)) + (nubOrd + (Parse.parsedImportedAddress + <$> Parse.parsedModuleImports parsed)) + input <- + expectRight + (Module.typedModuleInput + foundation + readiness + resolver + validation + parsed + direct) + sealed <- + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded module' -> pure module' + Module.TypedModuleOpenFailed failure -> + assertFailure + ("exact module did not open: " <> show failure) + >> fail "unreachable" + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("exact module did not seal: " <> show failure) + >> fail "unreachable" + pure + ( Map.insert (Parse.parsedModuleAddress parsed) sealed admitted + , ordered <> [sealed] + ) + +checkFileFresh + :: Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileFresh prover source = do + plan <- Store.planStore Store.FreshTemporaryStore >>= expectRight + Store.withStoreLease plan \lease -> do + opened <- Verification.withVerificationSession lease + (\session -> + checkFileWithSession + session + Verification.FreshStoreValidation + testSequentialJobs + ignoredVerificationRequests + prover + source) + case opened of + Left failure -> + assertFailure + ("test verification session failed: " <> show failure) + >> fail "unreachable" + Right result -> pure result + +checkFileWithStore + :: Store.Store + -> Verification.StoreValidationMode + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithStore store mode = + checkFileWithStoreAndJobs store mode testSequentialJobs + +checkFileWithStoreAndJobs + :: Store.Store + -> Verification.StoreValidationMode + -> Provers.EffectiveJobs + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithStoreAndJobs store mode jobs observer prover source = do + opened <- Verification.withVerificationSessionUsingStore store + (\session -> + checkFileWithSession session mode jobs observer prover source) + case opened of + Left failure -> + assertFailure + ("test verification session failed: " <> show failure) + >> fail "unreachable" + Right result -> pure result + +checkResultWithStore + :: Store.Store + -> Verification.StoreValidationMode + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + Verification.VerificationResult) +checkResultWithStore store mode observer prover source = + fmap (fmap fst) + (checkFileWithStore store mode observer prover source) + +checkFileWithSession + :: Verification.VerificationSession + -> Verification.StoreValidationMode + -> Provers.EffectiveJobs + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithSession session mode jobs observer prover source = + Workspace.prepareDefaultSourceGraph source >>= \case + Left failure -> + pure (Left (Verification.VerificationWorkspaceError failure)) + Right graph -> + fmap + (fmap + (\outcome -> + ( Verification.checkVerificationResult outcome + , Verification.checkSlowAtpReport outcome + ))) + (Verification.checkWorkspace + session + Verification.CheckRequest + { Verification.checkSourceGraph = graph + , Verification.checkStoreValidationMode = mode + , Verification.checkEffectiveJobs = jobs + , Verification.checkVampire = prover + , Verification.checkRequestObserver = observer + }) + +ignoredVerificationRequests :: Verification.VerificationRequestObserver +ignoredVerificationRequests = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + +testSequentialJobs :: Provers.EffectiveJobs +testSequentialJobs = + fromMaybe + (impossible "one is a positive worker count") + (Provers.effectiveJobs 1) + +assertTypedSuccess :: String -> Verification.VerificationResult -> Assertion +assertTypedSuccess label = \case + Verification.VerificationCompleted _report _presentation -> + pure () + Verification.CompletedWithExplicitGaps _report _presentation -> + assertFailure (label <> " completed with gaps") + Verification.VerificationFailure _report failure -> + assertFailure (label <> " failed: " <> show failure) + Verification.VerificationCheckingFailure _report failure -> + assertFailure (label <> " failed: " <> show failure) + +sole :: String -> [value] -> IO value +sole label = \case + [value] -> pure value + values -> + assertFailure + (label <> ": expected one value, found " <> show (length values)) + >> fail "unreachable" + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> assertFailure (show err) >> fail "unreachable" + Right value -> pure value + +expectRightIO :: Show error => IO (Either error value) -> IO value +expectRightIO action = + action >>= expectRight + +acquireFinalPreludeSession + :: Store.Store + -> Foundation.CheckedFoundation + -> Declaration.VampireResolver + -> IO + (Either + Module.FinalPreludeReadinessError + Module.FinalPreludeSession) +acquireFinalPreludeSession store foundation resolver = do + memo <- Store.newStoreMemo store + Module.acquireFinalPreludeSession + memo store foundation resolver diff --git a/source/Felix/Test/Unit/OutputPlan.hs b/source/Felix/Test/Unit/OutputPlan.hs new file mode 100644 index 0000000..803b7da --- /dev/null +++ b/source/Felix/Test/Unit/OutputPlan.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.OutputPlan (unitTests) where + +import Base +import Felix.OutputPlan qualified as Output +import Felix.Source +import Felix.Store qualified as Store + +import Control.Exception qualified as Exception +import System.Directory qualified as Directory +import System.Environment qualified as Environment +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Verification output preflight" + [ testCase "accepts absent and empty dump destinations" + acceptsAbsentAndEmptyDumpDestinations + , testCase "rejects a nonempty dump before store startup" + rejectsNonemptyDumpBeforeStoreStartup + , testCase "rejects persistent and fresh store collisions" + rejectsStoreCollisions + , testCase "reserves the store rollback journal" + reservesRollbackJournal + , testCase "rejects dump and HTML route collisions" + rejectsDumpHtmlCollisions + ] + +acceptsAbsentAndEmptyDumpDestinations :: Assertion +acceptsAbsentAndEmptyDumpDestinations = + Temp.withSystemTempDirectory "felix-output-dump" \root -> do + let storeParent = root Posix. "store" + storeFile = storeParent Posix. "store.sqlite" + dump = root Posix. "dump" + Directory.createDirectory storeParent + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + absent <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + plannedAbsent <- expectOutputRight absent + assertEqual "absent dump path" + (Just dump) + (Output.dumpOutputPath + <$> Output.verificationDumpOutput plannedAbsent) + + Directory.createDirectory dump + emptyResult <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + void (expectOutputRight emptyResult) + +rejectsNonemptyDumpBeforeStoreStartup :: Assertion +rejectsNonemptyDumpBeforeStoreStartup = + Temp.withSystemTempDirectory "felix-output-before-store" \root -> do + let cacheRoot = root Posix. "cache" + dump = root Posix. "dump" + Directory.createDirectory cacheRoot + Directory.createDirectory dump + writeFile (dump Posix. "old.p") "stale" + withEnvironment "XDG_CACHE_HOME" cacheRoot do + plan <- expectRightIO + (Store.planStore Store.DefaultStore) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + case result of + Left Output.DumpDestinationNotEmpty{} -> + pure () + Left other -> + assertFailure + ("unexpected nonempty result: " <> show other) + Right _ -> + assertFailure "nonempty dump was accepted" + assertBool "preflight did not create the default store" + . not + =<< Directory.doesPathExist + (cacheRoot Posix. "felix") + +rejectsStoreCollisions :: Assertion +rejectsStoreCollisions = + Temp.withSystemTempDirectory "felix-output-store-collision" \root -> do + let dump = root Posix. "dump" + persistentStore = dump Posix. "store.sqlite" + Directory.createDirectory dump + persistentPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore persistentStore)) + Store.withStoreLease persistentPlan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + expectCollision result + + freshPlan <- expectRightIO + (Store.planStore Store.FreshTemporaryStore) + Store.withStoreLease freshPlan \lease -> do + let freshParent = + Posix.takeDirectory + (Store.storePathFilePath + (Store.storeLeasePath lease)) + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just freshParent) + Nothing + expectCollision result + + relative <- expectRight (safeRelativePath "page.html") + let htmlRoot = root Posix. "html" + htmlStore = htmlRoot Posix. "page.html" + Directory.createDirectory htmlRoot + htmlPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore htmlStore)) + Store.withStoreLease htmlPlan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + Nothing + (Just (htmlRoot, [relative])) + expectCollision result + +rejectsDumpHtmlCollisions :: Assertion +rejectsDumpHtmlCollisions = + Temp.withSystemTempDirectory "felix-output-cross-collision" \root -> do + let storeParent = root Posix. "store" + storeFile = storeParent Posix. "store.sqlite" + htmlRoot = root Posix. "html" + Directory.createDirectory storeParent + Directory.createDirectory htmlRoot + relative <- expectRight (safeRelativePath "nested/page.html") + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just htmlRoot) + (Just (htmlRoot, [relative])) + expectCollision result + +reservesRollbackJournal :: Assertion +reservesRollbackJournal = + Temp.withSystemTempDirectory "felix-output-journal" \root -> do + let storeParent = root Posix. "store" + storeFile = storeParent Posix. "store.sqlite" + journal = storeFile <> "-journal" + Directory.createDirectory storeParent + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just journal) + Nothing + case result of + Left + (Output.CollidingOutputNamespaces + (Output.OutputNamespaceCollision + Output.StoreJournalOutputNamespace + reserved + Output.DumpOutputNamespace + requested :| [])) -> do + assertEqual "reserved journal" journal reserved + assertEqual "requested dump" journal requested + Left other -> + assertFailure + ("unexpected journal collision: " <> show other) + Right _ -> + assertFailure "store rollback journal was not reserved" + +expectCollision + :: Either Output.OutputPlanError Output.VerificationOutputPlan + -> Assertion +expectCollision = \case + Left Output.CollidingOutputNamespaces{} -> + pure () + Left other -> + assertFailure + ("unexpected output-plan result: " <> show other) + Right _ -> + assertFailure "colliding output namespaces were accepted" + +expectOutputRight + :: Either Output.OutputPlanError Output.VerificationOutputPlan + -> IO Output.VerificationOutputPlan +expectOutputRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right plan -> + pure plan + +expectRight :: Show failure => Either failure value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +expectRightIO + :: Show failure + => IO (Either failure value) + -> IO value +expectRightIO action = + expectRight =<< action + +withEnvironment + :: String + -> String + -> IO value + -> IO value +withEnvironment name value action = + Exception.bracket + (Environment.lookupEnv name) + restore + \_previous -> do + Environment.setEnv name value + action + where + restore = \case + Nothing -> + Environment.unsetEnv name + Just previous -> + Environment.setEnv name previous diff --git a/source/Felix/Test/Unit/Provers.hs b/source/Felix/Test/Unit/Provers.hs new file mode 100644 index 0000000..f1e3cc1 --- /dev/null +++ b/source/Felix/Test/Unit/Provers.hs @@ -0,0 +1,1159 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Provers (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Core +import Felix.Provers + +import Control.Concurrent + ( newEmptyMVar + , putMVar + , takeMVar + , threadDelay + ) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad (when) +import Data.IORef + ( atomicModifyIORef' + , newIORef + , readIORef + , writeIORef + ) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Data.Vector qualified as Vector +import Felix.Report.Location (Location(..)) +import System.Directory qualified as Directory +import System.Exit (ExitCode(..)) +import System.FilePath.Posix (()) +import System.Posix.Signals + ( nullSignal + , sigTERM + , signalProcess + ) +import System.Posix.Types (ProcessID) +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit +import Text.Read (readMaybe) +import Text.Megaparsec (parseMaybe) +import UnliftIO.Async (cancel, mapConcurrently, withAsync) +import UnliftIO.Async qualified as Async + +unitTests :: TestTree +unitTests = + testGroup "Provers" + [ vampireStatusParserTests + , vampireClassifierTests + , jobsSelectionTests + , slowAtpReportTests + , vampireExecutorTests + , vampireProcessTests + ] + +jobsSelectionTests :: TestTree +jobsSelectionTests = + testGroup "effective jobs" + [ testCase "uses a positive override exactly" do + detectorCalled <- newIORef False + selected <- selectEffectiveJobs + (effectiveJobs 3) + (writeIORef detectorCalled True >> pure 99) + selected `shouldBe` positiveJobs 3 + readIORef detectorCalled >>= (`shouldBe` False) + , testCase "rounds automatic jobs to one third of detected processors" do + for_ + [(8, 3), (16, 5), (24, 8), (32, 11)] + \(detected, expected) -> do + selected <- selectEffectiveJobs Nothing (pure detected) + selected `shouldBe` positiveJobs expected + , testCase "falls back to one after bad detection" do + nonPositive <- selectEffectiveJobs Nothing (pure 0) + nonPositive `shouldBe` positiveJobs 1 + failed <- selectEffectiveJobs Nothing + (Exception.throwIO (userError "processor detection failed")) + failed `shouldBe` positiveJobs 1 + ] + +slowAtpReportTests :: TestTree +slowAtpReportTests = + testGroup "slow ATP report" + [ testCase "applies the threshold and retains the twelve slowest" do + prepared <- preparedTypedTask 0 + let requestId = + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + task nanoseconds position = + SlowAtpTask + { slowAtpDuration = + atpDurationFromNanoseconds nanoseconds + , slowAtpOutcome = SlowAtpAccepted + , slowAtpPosition = workPosition 1 position + , slowAtpLocation = testLocation + , slowAtpRequestId = requestId + } + report = slowAtpReportFromTasks + ( task 4999999999 0 + : [ task (5000000000 + fromIntegral position) position + | position <- [0..13] + ] + ) + slowAtpQualifyingTaskCount report `shouldBe` 14 + length (slowAtpTasks report) `shouldBe` 12 + slowAtpOmittedTaskCount report `shouldBe` 2 + atpDurationNanoseconds + (slowAtpDuration + (fromMaybe + (error "slow report unexpectedly empty") + (listToMaybe (slowAtpTasks report)))) + `shouldBe` 5000000013 + , testCase "keeps earlier source positions on equal durations" do + prepared <- preparedTypedTask 0 + let requestId = + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + task position = + SlowAtpTask + { slowAtpDuration = + atpDurationFromNanoseconds 5000000000 + , slowAtpOutcome = SlowAtpAccepted + , slowAtpPosition = workPosition 1 position + , slowAtpLocation = testLocation + , slowAtpRequestId = requestId + } + report = slowAtpReportFromTasks (task <$> [1..13]) + (workPositionLocalRequestOrdinal . slowAtpPosition + <$> slowAtpTasks report) + `shouldBe` [1..12] + ] + +vampireExecutorTests :: TestTree +vampireExecutorTests = + testGroup "bounded Vampire executor" + [ testCase "records completed qualifying tasks with runtime context" do + prepared <- preparedTypedTask 0 + clock <- scriptedClock [10, 5000000010] + let position = workPosition 2 3 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutorUsingClock + clock + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + position + testLocation + (preparedTypedProverRequest prepared) + awaitVampireRequest handle + >>= assertAcceptedRequest prepared + report <- vampireExecutorSlowAtpReport executor + slowAtpQualifyingTaskCount report `shouldBe` 1 + case slowAtpTasks report of + [task] -> do + atpDurationNanoseconds + (slowAtpDuration task) + `shouldBe` 5000000000 + slowAtpOutcome task `shouldBe` SlowAtpAccepted + slowAtpPosition task `shouldBe` position + slowAtpLocation task `shouldBe` testLocation + slowAtpRequestId task `shouldBe` + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + tasks -> + assertFailure + ("unexpected slow-task report: " + <> show tasks) + , testCase "does not report a cancelled partial task" do + prepared <- preparedTypedTask 0 + clock <- scriptedClock [0, 6000000000] + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutorUsingClock + clock + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + cancelVampireRequest handle + report <- vampireExecutorSlowAtpReport executor + slowAtpQualifyingTaskCount report `shouldBe` 0 + assertBool "cancelled report is empty" + (null (slowAtpTasks report)) + assertProcessesGone processIds + , testCase "opaque handles complete out of submission order" do + prepared <- preparedTypedTask 0 + firstStarted <- newEmptyMVar + releaseFirst <- newEmptyMVar + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 2) + vampireCommand + (\position _request -> + when + (workPositionLocalRequestOrdinal position == 1) + (putMVar firstStarted () >> takeMVar releaseFirst)) + \executor -> withVampireRequestOwner executor \owner -> do + first <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + takeMVar firstStarted + second <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + secondCompletion <- awaitVampireRequest second + assertAcceptedRequest prepared secondCompletion + putMVar releaseFirst () + firstCompletion <- awaitVampireRequest first + assertAcceptedRequest prepared firstCompletion + , testCase "validates request identity before a rejection" do + submitted <- preparedTypedTask 0 + mismatched <- preparedTypedTask 1 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status CounterSatisfiable for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest submitted) + outcome <- Exception.try + (awaitPreparedVampireRequest + (preparedTypedProverRequest mismatched) + handle) + case outcome of + Left (failure :: VampireExecutorFault) -> + assertBool + "request mismatch is an integrity fault" + ("wrong request id" + `Text.isInfixOf` + Text.pack (show failure)) + Right answer -> + assertFailure + ("mismatched rejection was accepted: " + <> show answer) + , testCase "runs requests through the bounded worker pool" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "previous=''" + , "found=0" + , "for argument in \"$@\"; do" + , " if [ \"$previous\" = '--cores' ]; then" + , " [ \"$argument\" = '2' ] || exit 17" + , " found=1" + , " fi" + , " previous=$argument" + , "done" + , "[ \"$found\" = '1' ] || exit 18" + , "cat >/dev/null" + , "sleep 0.2" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 2) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + answers <- mapConcurrently + (\ordinal -> + runPreparedTypedProverWithExecutor + owner + (workPosition 1 ordinal) + testLocation + prepared) + [1..4] + traverse_ assertProved answers + , testCase "propagates observer failure to the submitter" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> + Exception.throwIO + (userError "observer failed")) + \executor -> withVampireRequestOwner executor \owner -> do + result <- Exception.try + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) + case result of + Left (failure :: VampireExecutorFault) -> + assertBool + "global executor fault" + ("observer failed" + `Text.isInfixOf` + Text.pack (show failure)) + Right answer -> + assertFailure + ("observer failure was lost: " + <> show answer) + , testCase "cancels queued and running jobs independently" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> + withAsync + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) + \running -> do + processIds <- waitForProcessIds pidFile + queuedSubmitted <- newEmptyMVar + withAsync + (do + handle <- submitVampireRequest + owner + (workPosition 2 1) + testLocation + (preparedTypedProverRequest prepared) + putMVar queuedSubmitted () + awaitPreparedVampireRequest + (preparedTypedProverRequest prepared) + handle) + \queued -> do + takeMVar queuedSubmitted + cancel queued + cancel running + assertProcessesGone processIds + , testCase "explicit cancellation completes queued and running handles" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + running <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + queued <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + cancelVampireRequest queued + awaitVampireRequest queued + >>= assertCancelled prepared + cancelVampireRequest running + awaitVampireRequest running + >>= assertCancelled prepared + assertProcessesGone processIds + , testCase "structured shutdown wakes waiter and full-queue submitter" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> do + (waiter, blockedSubmit, processIds) <- + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> + withVampireRequestOwner executor \owner -> do + running <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + _queuedOne <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + _queuedTwo <- submitVampireRequest + owner + (workPosition 1 3) + testLocation + (preparedTypedProverRequest prepared) + waiter <- Async.async + (awaitVampireRequest running) + submitStarted <- newEmptyMVar + blockedSubmit <- Async.async do + putMVar submitStarted () + submitVampireRequest + owner + (workPosition 1 4) + testLocation + (preparedTypedProverRequest prepared) + takeMVar submitStarted + pure (waiter, blockedSubmit, processIds) + Async.waitCatch waiter >>= \case + Right completion -> + assertCancelled prepared completion + Left failure -> + assertFailure + ("shutdown waiter failed: " <> show failure) + Async.waitCatch blockedSubmit >>= \case + Left failure -> + assertBool + "backpressured submit observes owner shutdown" + ("VampireRequestOwnerClosed" + `Text.isInfixOf` + Text.pack (show failure)) + Right _handle -> + assertFailure + "backpressured submit survived structured shutdown" + assertProcessesGone processIds + , testCase "worker fault wakes a waiter and a full-queue submitter" do + prepared <- preparedTypedTask 0 + observerEntered <- newEmptyMVar + failObserver <- newEmptyMVar + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\position _request -> + when + (workPositionLocalRequestOrdinal position == 1) + (putMVar observerEntered () + >> takeMVar failObserver + >> Exception.throwIO + (userError "fatal observer fault"))) + \executor -> withVampireRequestOwner executor \owner -> do + first <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + takeMVar observerEntered + _second <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + _third <- submitVampireRequest + owner + (workPosition 1 3) + testLocation + (preparedTypedProverRequest prepared) + withAsync + (submitVampireRequest + owner + (workPosition 1 4) + testLocation + (preparedTypedProverRequest prepared)) + \blockedSubmit -> do + putMVar failObserver () + awaitFault (awaitVampireRequest first) + Async.waitCatch blockedSubmit >>= \case + Left failure -> + assertExecutorFault failure + Right _handle -> + assertFailure + "full-queue submission survived executor fault" + , testCase "declared launch failure remains request-local" do + prepared <- preparedTypedTask 0 + let missing = vampire + "/definitely/missing/felix-vampire" + defaultTimeLimit + defaultMemoryLimit + withVampireExecutor + (positiveJobs 1) + missing + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireProcessFailed ProverLaunchFailed{} -> pure () + terminal -> + assertFailure + ("expected a local launch failure, got " + <> show terminal) + , testCase "protocol failure is distinct from ATP rejection" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' 'completed without an SZS status'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireProtocolFailed{} -> pure () + terminal -> + assertFailure + ("expected a protocol terminal, got " + <> show terminal) + , testCase "completed rejection diagnostics are compact" do + prepared <- preparedTypedTask 0 + let headMarker :: Text + headMarker = "HEAD-MARKER" + tailMarker :: Text + tailMarker = "TAIL-MARKER" + status :: Text + status = "% SZS status CounterSatisfiable for fake" + originalByteCount = + Text.length headMarker + + 1048576 + + Text.length tailMarker + 1 + + Text.length status + 1 + withFakeVampire + [ "printf '%s' 'HEAD-MARKER'" + , "head -c 1048576 /dev/zero" + , "printf '%s\n' 'TAIL-MARKER'" + , "printf '%s\n' '% SZS status CounterSatisfiable for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + case renderVampireTerminalDiagnostic + (vampireCompletionTerminal completion) of + Just diagnostic -> do + assertBool + "retained diagnostic is bounded" + (Text.length diagnostic < 70000) + assertBool + "truncation is reported" + ("retained first and last 16 KiB" + `Text.isInfixOf` diagnostic) + assertBool + "original byte count is reported" + (("of " + <> Text.pack + (show originalByteCount) + <> " bytes)") + `Text.isInfixOf` diagnostic) + assertBool + "diagnostic head is retained" + (headMarker `Text.isInfixOf` diagnostic) + assertBool + "diagnostic tail is retained" + (tailMarker `Text.isInfixOf` diagnostic) + Nothing -> + assertFailure "expected a rejected terminal" + ] + +positiveJobs :: Int -> EffectiveJobs +positiveJobs amount = + fromMaybe + (error "test requested a non-positive job count") + (effectiveJobs amount) + +scriptedClock :: [Word64] -> IO (IO Word64) +scriptedClock ticks = do + remaining <- newIORef ticks + pure + (atomicModifyIORef' remaining \case + next : rest -> (rest, next) + [] -> error "test monotonic clock exhausted") + +testLocation :: Location +testLocation = Location maxBound + +vampireStatusParserTests :: TestTree +vampireStatusParserTests = + testGroup "Vampire status parser" + [ testCase "parses canonical status lines" do + parseMaybe + vampireStatusParser + "% SZS status ContradictoryAxioms for 2260" + `shouldBe` Just StatusContradictoryAxioms + , testCase "parses worker-prefixed status lines" do + parseMaybe + vampireStatusParser + "% (2581105)SZS status Timeout for " + `shouldBe` Just StatusTimeout + , testCase "parses ResourceOut status" do + parseMaybe + vampireStatusParser + "% SZS status ResourceOut for 2260" + `shouldBe` Just StatusResourceOut + , testCase "retains unsupported status values" do + parseMaybe + vampireStatusParser + "% SZS status AlienResult for 2260" + `shouldBe` Just (UnsupportedStatus "AlienResult") + ] + +vampireClassifierTests :: TestTree +vampireClassifierTests = + testGroup "Vampire completed transcript classifier" + [ testCase "maps each terminal status in both task modes" do + classify DirectTask [StatusTheorem] + `shouldBe` Right Proved + classify DirectTask [StatusCounterSatisfiable] + `shouldBe` Right Counterexample + classify DirectTask [StatusContradictoryAxioms] + `shouldBe` Right ContradictoryInput + classify IndirectTask [StatusContradictoryAxioms] + `shouldBe` Right Proved + , testCase "maps every resource status to indeterminate" do + for_ indeterminateStatuses \status -> + classify DirectTask [status] + `shouldBe` Right Indeterminate + , testCase "lets a unique terminal outcome override resource statuses" do + for_ indeterminateStatuses \status -> + classify DirectTask [status, StatusTheorem] + `shouldBe` Right Proved + , testCase "accepts duplicate and equivalent terminal statuses" do + classify DirectTask [StatusTheorem, StatusTheorem] + `shouldBe` Right Proved + classify + IndirectTask + [StatusTheorem, StatusContradictoryAxioms] + `shouldBe` Right Proved + , testCase "rejects every pair of different terminal outcomes" do + for_ conflictingTerminalCases + \(mode, statuses, outcomes) -> + classify mode statuses + `shouldBe` + Left (ConflictingTerminalOutcomes outcomes) + , testCase "is independent of status order" do + for_ orderCases \(mode, statuses) -> + classify mode statuses + `shouldBe` classify mode (reverse statuses) + , testCase "rejects unsupported status values" do + classify + DirectTask + [StatusTheorem, UnsupportedStatus "AlienResult"] + `shouldBe` + Left + (UnsupportedVampireStatuses + (Set.singleton "AlienResult")) + , testCase "rejects a successful exit without an outcome" do + classify DirectTask [] + `shouldBe` Left MissingVampireOutcome + , testCase "rejects every status after a nonzero exit" do + classifyVampireProtocol + DirectTask + (ExitFailure 7) + [StatusTheorem] + `shouldBe` + Left (UnsuccessfulVampireExit (ExitFailure 7)) + ] + +vampireProcessTests :: TestTree +vampireProcessTests = + testGroup "Vampire process boundary" + [ testCase "classifies statuses from both completed streams" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Timeout for fake'" + , "printf '%s\\n' '% SZS status Theorem for fake' >&2" + , "exit 0" + ] + assertProved answer + , testCase "rejects a split-stream terminal conflict" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for fake'" + , "printf '%s\\n' '% SZS status CounterSatisfiable for fake' >&2" + , "exit 0" + ] + assertProtocolError "ConflictingTerminalOutcomes" answer + , testCase "rejects a theorem from a nonzero exit" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for fake'" + , "exit 7" + ] + assertProtocolError "ExitFailure 7" answer + , testCase "rejects malformed UTF-8 output" do + answer <- runFakeVampire + [ "printf '\\377'" + , "exit 0" + ] + case answer of + Left + (ProverOutputMalformedUtf8 + _ + ProverOutputStdout + _) -> + pure () + result -> + assertFailure + ("expected malformed stdout, got " <> show result) + , testCase "returns a broken stdin pipe" do + prepared <- preparedTypedTask 20000 + result <- withFakeVampire + [ "exec 0<&-" + , "sleep 1" + ] + \vampireCommand -> + runPreparedTypedProver vampireCommand prepared + case result of + Left (ProverCommunicationFailed _ ProverStdin _) -> + pure () + processResult -> + assertFailure + ("expected a communication failure, got " + <> show processResult) + , testCase "drains output while feeding prover input" do + prepared <- preparedTypedTask 20000 + guardedAnswer <- Timeout.timeout + 30000000 + (withFakeVampire + [ "head -c 1048576 /dev/zero &" + , "head -c 1048576 /dev/zero >&2 &" + , "wait" + , "printf '\\n'" + , "printf '\\n' >&2" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for fake'" + , "exit 0" + ] + \vampireCommand -> do + runPreparedTypedProver vampireCommand prepared) + case guardedAnswer of + Nothing -> + assertFailure "prover communication did not finish" + Just answer -> + assertProved answer + , testCase "reports signal termination separately" do + prepared <- preparedTypedTask 0 + result <- withFakeVampire + [ "kill -TERM $$" + ] + \vampireCommand -> + runPreparedTypedProver vampireCommand prepared + case result of + Left + (ProverTerminatedBySignal + _ + signalNumber + _) -> + assertEqual + "termination signal" + (fromIntegral sigTERM) + signalNumber + processResult -> + assertFailure + ("expected signal termination, got " + <> show processResult) + , testCase "deadline terminates and reaps the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + (Seconds 0) + [] + \pidFile vampireCommand -> do + result <- + runPreparedTypedProver vampireCommand prepared + assertTimedOut result + processIds <- readProcessIds pidFile + assertProcessesGone processIds + , testCase "output exhaustion terminates the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [ "head -c 33554432 /dev/zero" + ] + \pidFile vampireCommand -> do + result <- + runPreparedTypedProver vampireCommand prepared + case result of + Left + (ProverOutputLimitExceeded + _ + ProverOutputStdout + _) -> + pure () + processResult -> + assertFailure + ("expected stdout limit exhaustion, got " + <> show processResult) + processIds <- readProcessIds pidFile + assertProcessesGone processIds + , testCase "cancellation terminates and reaps the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withAsync + (runPreparedTypedProver vampireCommand prepared) + \worker -> do + processIds <- waitForProcessIds pidFile + cancel worker + assertProcessesGone processIds + ] + +classify + :: VampireTaskMode + -> [VampireStatus] + -> Either VampireProtocolError CanonicalAtpOutcome +classify mode = + classifyVampireProtocol mode ExitSuccess + +indeterminateStatuses :: [VampireStatus] +indeterminateStatuses = + [ StatusTimeout + , StatusResourceOut + , StatusGaveUp + , StatusUnknown + ] + +conflictingTerminalCases + :: [(VampireTaskMode, [VampireStatus], Set CanonicalAtpOutcome)] +conflictingTerminalCases = + [ ( DirectTask + , [StatusTheorem, StatusCounterSatisfiable] + , Set.fromList [Proved, Counterexample] + ) + , ( DirectTask + , [StatusTheorem, StatusContradictoryAxioms] + , Set.fromList [Proved, ContradictoryInput] + ) + , ( DirectTask + , [StatusCounterSatisfiable, StatusContradictoryAxioms] + , Set.fromList [Counterexample, ContradictoryInput] + ) + , ( IndirectTask + , [StatusTheorem, StatusCounterSatisfiable] + , Set.fromList [Proved, Counterexample] + ) + , ( IndirectTask + , [StatusCounterSatisfiable, StatusContradictoryAxioms] + , Set.fromList [Proved, Counterexample] + ) + ] + +orderCases :: [(VampireTaskMode, [VampireStatus])] +orderCases = + [ (DirectTask, StatusTheorem : indeterminateStatuses) + , (DirectTask, [StatusTheorem, StatusCounterSatisfiable]) + , (IndirectTask, [StatusTheorem, StatusContradictoryAxioms]) + , (DirectTask, [UnsupportedStatus "B", UnsupportedStatus "A"]) + ] + +assertProved + :: Either ProverProcessError ProverAnswer + -> Assertion +assertProved = \case + Right Yes -> + pure () + answer -> + assertFailure ("expected a proof, got " <> show answer) + +assertAcceptedRequest + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertAcceptedRequest prepared completion = do + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireAccepted -> pure () + terminal -> + assertFailure ("expected an accepted terminal, got " <> show terminal) + +assertCompletionRequest + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertCompletionRequest prepared completion = + vampireCompletionRequestId completion + `shouldBe` + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + +assertCancelled + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertCancelled prepared completion = do + assertCompletionRequest prepared completion + vampireCompletionTerminal completion `shouldBe` VampireCancelled + +awaitFault :: IO value -> Assertion +awaitFault action = do + result <- Exception.try action + case result of + Left failure -> assertExecutorFault failure + Right _value -> assertFailure "expected a global executor fault" + +assertExecutorFault :: Exception.SomeException -> Assertion +assertExecutorFault failure = + case Exception.fromException failure :: Maybe VampireExecutorFault of + Just _fault -> pure () + Nothing -> + assertFailure + ("expected VampireExecutorFault, got " <> show failure) + +assertProtocolError + :: Text + -> Either ProverProcessError ProverAnswer + -> Assertion +assertProtocolError expected = \case + Right (Error _label diagnostic) -> + assertBool + ( "expected protocol error containing " + <> show expected + <> ", got " + <> show diagnostic + ) + (expected `Text.isInfixOf` diagnostic) + answer -> + assertFailure ("expected a protocol error, got " <> show answer) + +assertTimedOut + :: Either ProverProcessError a + -> Assertion +assertTimedOut = \case + Left ProverTimedOut{} -> + pure () + result -> + assertFailure ("expected prover timeout, got " <> showResult result) + where + showResult = \case + Left err -> + show err + Right _ -> + "successful process result" + +withProcessGroupFake + :: TimeLimit + -> [String] + -> (FilePath -> Vampire -> IO a) + -> IO a +withProcessGroupFake timeLimit body action = + withFakeVampireIn + (\temp -> + let pidFile = temp "process-ids" + in [ "trap '' TERM" + , "sleep 60 &" + , "printf '%s %s\\n' \"$$\" \"$!\" > " <> pidFile + ] + <> body + <> ["wait"]) + timeLimit + \temp -> + action (temp "process-ids") + +readProcessIds :: FilePath -> IO [ProcessID] +readProcessIds path = do + contents <- Text.readFile path + case traverse + (readMaybe . Text.unpack) + (Text.words contents) of + Just processIds@[_leader, _descendant] -> + pure processIds + _ -> + assertFailure + ("expected leader and descendant process ids, got " + <> show contents) + +waitForProcessIds :: FilePath -> IO [ProcessID] +waitForProcessIds path = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just processIds -> + pure processIds + Nothing -> + assertFailure "fake prover did not publish its process ids" + where + loop = do + exists <- Directory.doesFileExist path + if exists + then readProcessIds path + else do + threadDelay 10000 + loop + +assertProcessesGone :: [ProcessID] -> Assertion +assertProcessesGone processIds = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just () -> + pure () + Nothing -> + assertFailure + ("supervisor left processes running: " + <> show processIds) + where + loop = do + alive <- traverse processIsAlive processIds + if or alive + then do + threadDelay 10000 + loop + else pure () + +processIsAlive :: ProcessID -> IO Bool +processIsAlive processId = + (signalProcess nullSignal processId >> pure True) + `Exception.catch` \(err :: Exception.IOException) -> + if isDoesNotExistError err + then pure False + else throwIO err + +runFakeVampire + :: [String] + -> IO (Either ProverProcessError ProverAnswer) +runFakeVampire scriptLines = + withFakeVampire + (["cat >/dev/null"] <> scriptLines) + \vampireCommand -> do + prepared <- preparedTypedTask 0 + runPreparedTypedProver vampireCommand prepared + +withFakeVampire + :: [String] + -> (Vampire -> IO a) + -> IO a +withFakeVampire scriptLines action = + withFakeVampireIn + (const scriptLines) + defaultTimeLimit + (const action) + +withFakeVampireIn + :: (FilePath -> [String]) + -> TimeLimit + -> (FilePath -> Vampire -> IO a) + -> IO a +withFakeVampireIn makeScript timeLimit action = + withTemporaryDirectory "felix-fake-vampire" \temp -> do + let executablePath = temp "vampire" + writeFile executablePath + (unlines + ( [ "#!/bin/sh" + ] + <> makeScript temp + )) + permissions <- Directory.getPermissions executablePath + Directory.setPermissions executablePath + (Directory.setOwnerExecutable True permissions) + action + temp + (vampire + executablePath + timeLimit + defaultMemoryLimit) + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = + flip (assertEqual "") + +preparedTypedTask + :: Int + -> IO (PreparedTypedProverTask Int Void Void Void) +preparedTypedTask factCount = do + checked <- expectRight + (checkScopedCanonicalCore + (const Nothing) + [] + propositionTerm) + proposition <- expectRight + (supportedProposition Vector.empty checked) + capability <- expectRight + (classifySupportedProposition (const Nothing) proposition) + let facts = + Vector.generate + factCount + (\reference -> + typedBackendFact reference proposition capability) + problem <- expectRight + (planTypedProblem + (const Nothing) + facts + proposition + [] + [] + FirstOrderLocals + ExplicitHigherOrderJustification) + expectRight (prepareTypedProverTask DirectTask problem) + where + propositionTerm = + CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Semantic.hs b/source/Felix/Test/Unit/Semantic.hs new file mode 100644 index 0000000..f62a003 --- /dev/null +++ b/source/Felix/Test/Unit/Semantic.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Semantic (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity +import Felix.Source +import Felix.Source.Content +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Abstract qualified as Raw + +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Semantic interfaces" + [ testCase "separates syntax and semantic Merkle identities" + separatesSyntaxAndSemantics + , testCase "round-trips closed semantic declaration state" + roundTripsSemanticState + , testCase "round-trips exact semantic global keys" + roundTripsSemanticGlobalKeys + , testCase "round-trips canonical structure descriptors" + roundTripsStructureDescriptors + , testCase "keys exact proof and module inputs" + keysExactInputs + ] + +separatesSyntaxAndSemantics :: Assertion +separatesSyntaxAndSemantics = do + fixture <- makeFixture + firstSyntax <- makeSyntax "first" + secondSyntax <- makeSyntax "second" + assertBool + "notation changes syntax identity" + ( Syntax.moduleSyntaxAssertedId firstSyntax + /= Syntax.moduleSyntaxAssertedId secondSyntax + ) + assertEqual + "notation does not enter semantic prefix identity" + (fixtureNextPrefix fixture) + (Semantic.nextPrefixContextId + (fixtureInitialPrefix fixture) + (fixtureDelta fixture)) + +roundTripsSemanticState :: Assertion +roundTripsSemanticState = do + fixture <- makeFixture + assertEqual + "semantic interface cache round trip" + (Right (fixtureInterface fixture)) + (decodeCache + Semantic.getSemanticInterfaceCache + (encodeCache + (Semantic.putSemanticInterfaceCache + (fixtureInterface fixture)))) + assertEqual + "walking-subset environment delta round trip" + (Right Semantic.emptySemanticEnvironmentDelta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache + Semantic.emptySemanticEnvironmentDelta))) + +roundTripsSemanticGlobalKeys :: Assertion +roundTripsSemanticGlobalKeys = do + fixture <- makeFixture + let unary = Raw.HoleCons (Raw.TokenCons (Raw.Command "f") Raw.End) + plural = Raw.HoleCons (Raw.TokenCons (Raw.Word "things") Raw.End) + keys = + [ Semantic.SemanticLeftAdjective unary + , Semantic.SemanticRightAdjective unary + , Semantic.SemanticFunctionPhrase unary plural + , Semantic.SemanticNoun unary plural + , Semantic.SemanticVerb unary plural + , Semantic.SemanticRelation + (Raw.Command "rel") + (Raw.ParameterArity 2) + , Semantic.SemanticExpressionFunction unary + , Semantic.SemanticPrefixPredicate "Pred" 3 + ] + target = + Identity.intrinsicObjectId + (fixtureTheory fixture) + Core.Empty + Core.TySet + bindings = + List.sortOn Semantic.semanticGlobalBindingKey + ( case keys of + [] -> [] + first : rest -> + Semantic.semanticGlobalBinding + first + (Semantic.ContextualTransparentExpansion + target + (Map.singleton + (Raw.StructSymbol "operation") + target)) + : [ Semantic.semanticGlobalBinding + key + (Semantic.GlobalReference target) + | key <- rest + ] + ) + delta <- expectRight (Semantic.semanticEnvironmentDelta bindings) + assertEqual "binding cache round trip" + (Right delta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache delta))) + case bindings of + first : second : _ -> do + assertEqual "rejects noncanonical order" + (Left Semantic.NonCanonicalSemanticGlobalBindingOrder) + (Semantic.semanticEnvironmentDelta + (second : first : drop 2 bindings)) + assertEqual "rejects duplicate key" + (Left + (Semantic.DuplicateSemanticGlobalKey + (Semantic.semanticGlobalBindingKey first))) + (Semantic.semanticEnvironmentDelta [first, first]) + _ -> assertFailure "semantic key fixture is unexpectedly empty" + +roundTripsStructureDescriptors :: Assertion +roundTripsStructureDescriptors = do + fixture <- makeFixture + let structurePhrase marker word = + Semantic.semanticStructurePhrase + (Raw.LexicalItemSgPl + (Raw.SgPl + (Raw.TokenCons (Raw.Word word) Raw.End) + (Raw.TokenCons (Raw.Word (word <> "s")) Raw.End)) + marker) + base = structurePhrase "onesorted_structure" "base" + child = structurePhrase "ordered_structure" "ordered" + object = + Identity.intrinsicObjectId + (fixtureTheory fixture) + Core.Empty + Core.TySet + operation = + Semantic.semanticStructureOperation + (Raw.StructSymbol "carrier") + object + descriptor <- expectRight + (Semantic.semanticStructureDescriptor + child + (Just object) + [base] + [operation]) + delta <- expectRight + (Semantic.semanticEnvironmentWithStructures [] [descriptor]) + assertEqual + "structure environment cache round trip" + (Right delta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache delta))) + assertEqual + "duplicate local operation is rejected" + (Left + (Semantic.DuplicateSemanticStructureOperation + (Raw.StructSymbol "carrier"))) + (Semantic.semanticStructureDescriptor + child + (Just object) + [base] + [operation, operation]) + +keysExactInputs :: Assertion +keysExactInputs = do + fixture <- makeFixture + let authority = + Authority.factAuthority + (fixtureTheorem fixture) + Authority.cleanAuthoritySafety + certificate <- expectRight + (Authority.validationCertificate + authority + (Authority.CheckedSourceProof [])) + let theorem = + Identity.theoremId + (fixtureTheorem fixture) + firstProof = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-a") + (fixtureInitialPrefix fixture) + secondProof = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-b") + (fixtureInitialPrefix fixture) + laterContext = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-a") + (fixtureNextPrefix fixture) + assertBool + "proof syntax is an exact validation input" + (firstProof /= secondProof) + assertBool + "semantic predecessor is an exact validation input" + (firstProof /= laterContext) + let proofRecord = + Semantic.proofValidationRecord + firstProof certificate + declarationKey = + Semantic.declarationValidationKey + (Semantic.declarationSyntaxId "declaration") + (fixtureInitialPrefix fixture) + [] + [theorem, theorem] + declarationRecord = + Semantic.declarationValidationRecord + declarationKey + [certificate, certificate] + assertEqual + "proof validation record cache round trip" + (Right proofRecord) + (decodeCache + Semantic.getProofValidationRecordCache + (encodeCache + (Semantic.putProofValidationRecordCache + proofRecord))) + assertEqual + "ordered declaration certificates retain repetitions" + (Right declarationRecord) + (decodeCache + Semantic.getDeclarationValidationRecordCache + (encodeCache + (Semantic.putDeclarationValidationRecordCache + declarationRecord))) + firstParsedKey <- expectRight + (parsedModuleKey + (fixtureSourceContentId "source-a") + Syntax.baseSyntaxInterfaceId + []) + secondParsedKey <- expectRight + (parsedModuleKey + (fixtureSourceContentId "source-b") + Syntax.baseSyntaxInterfaceId + []) + directSyntax <- makeSyntax "direct" + let directSyntaxId = + Syntax.moduleSyntaxAssertedId directSyntax + assertEqual + "parsed identity rejects duplicate direct syntax" + (Left + (DuplicateParsedDirectSyntaxInput + directSyntaxId)) + (parsedModuleKey + (fixtureSourceContentId "source-a") + Syntax.baseSyntaxInterfaceId + [directSyntaxId, directSyntaxId]) + let + firstParsed = + parsedModuleId firstParsedKey "parsed" + secondParsed = + parsedModuleId secondParsedKey "parsed" + firstArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (fixtureOwner fixture) + firstParsed + [] + (fixtureTheory fixture)) + secondArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (fixtureOwner fixture) + secondParsed + [] + (fixtureTheory fixture)) + let firstArtifact = + Semantic.moduleArtifactId firstArtifactKey + secondArtifact = + Semantic.moduleArtifactId secondArtifactKey + assertBool + "module artifact binds parsed source identity" + (firstArtifact /= secondArtifact) + let semanticId = + Semantic.semanticInterfaceAssertedId + (fixtureInterface fixture) + assertEqual + "prefix identity rejects duplicate direct semantics" + (Left + (Semantic.DuplicateInitialPrefixSemanticInput + semanticId)) + (Semantic.initialPrefixContextId + (fixtureTheory fixture) + (fixtureOwner fixture) + [semanticId, semanticId]) + assertEqual + "module artifact key cache round trip" + (Right firstArtifactKey) + (decodeCache + Semantic.getModuleArtifactKeyCache + (encodeCache + (Semantic.putModuleArtifactKeyCache + firstArtifactKey))) + syntax <- makeSyntax "artifact" + let artifactResult = + Semantic.moduleArtifactResult + firstArtifactKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId + (fixtureInterface fixture)) + assertEqual + "module artifact root round trip" + (Right artifactResult) + (decodeCache + (Semantic.getModuleArtifactResultCache + firstArtifact) + (encodeCache + (Semantic.putModuleArtifactResultCache + artifactResult))) + + +data Fixture = Fixture + { fixtureTheory :: !Identity.TheoryId + , fixtureOwner :: !ModuleName + , fixtureTheorem :: !Identity.TheoremRef + , fixtureDelta :: !Semantic.DeclarationInterfaceDelta + , fixtureInterface :: !Semantic.SemanticInterface + , fixtureInitialPrefix :: !Semantic.PrefixContextId + , fixtureNextPrefix :: !Semantic.PrefixContextId + } + +makeFixture :: IO Fixture +makeFixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "semantic-test-namespace" + ["root"]) + relative <- expectRight (safeRelativePath "module.tex") + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId foundation) + []) + proposition <- expectRight + (Identity.validatePropositionContent + closure + Core.CFalsum) + let theory = + Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + authority = + Authority.factAuthority + reference + Authority.cleanAuthoritySafety + occurrence = + Semantic.semanticFactOccurrence + (Semantic.factSlot owner (localFactOrdinal 0)) + authority + Semantic.SearchEligible + slot = + Semantic.declarationSlot + owner + (localDeclarationOrdinal 0) + delta <- expectRight + (Semantic.declarationInterfaceDelta + slot + [occurrence] + [ Semantic.semanticAlias + (Semantic.semanticName "theorem") + (Semantic.semanticFactOccurrenceFingerprint + (Semantic.factSlot owner (localFactOrdinal 0)) + authority) + ] + [] + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + interface <- expectRight + (Semantic.semanticInterface owner [] [delta]) + initial <- expectRight + (Semantic.initialPrefixContextId theory owner []) + pure + Fixture + { fixtureTheory = theory + , fixtureOwner = owner + , fixtureTheorem = reference + , fixtureDelta = delta + , fixtureInterface = interface + , fixtureInitialPrefix = initial + , fixtureNextPrefix = + Semantic.nextPrefixContextId initial delta + } + +makeSyntax :: Text -> IO Syntax.ModuleSyntaxInterface +makeSyntax command = do + delta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation command]) + expectRight (Syntax.moduleSyntaxInterface [] delta) + +fixtureSourceContentId :: ByteString -> SourceContentId +fixtureSourceContentId bytes = + either + (impossible . show) + id + (decodeCache + getSourceContentIdCache + (encodeCache + (putCacheDigest + (hashCacheFields + "semantic-test-source" + [bytes])))) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Source.hs b/source/Felix/Test/Unit/Source.hs new file mode 100644 index 0000000..6216381 --- /dev/null +++ b/source/Felix/Test/Unit/Source.hs @@ -0,0 +1,2581 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Felix.Test.Unit.Source (unitTests) where + +import Base +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec qualified as Cache +import Felix.Module qualified as Module +import Felix.Parse qualified as Parse +import Felix.Parsed.Identity qualified as ParsedIdentity +import Felix.Parsed.Payload qualified as Parsed +import Felix.Prelude qualified as Prelude +import Felix.Source +import Felix.Source.Content qualified as Content +import Felix.Source.Graph +import Felix.Store qualified as Store +import Felix.Report.Location + ( FileId(..) + , FileIdAllocator(..) + , Location(..) + , LocationRegistrationError(..) + , allocateFileId + , locColumn + , locFile + , locFileId + , locLine + , lookupFileIdentityPath + ) +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt qualified as Adapt +import Felix.Syntax.Interface qualified as Interface +import Felix.Syntax.Token (runLexer) + +import Control.Exception (bracket, evaluate) +import Data.ByteString qualified as ByteString +import Data.IORef +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Data.Word (Word8, Word16) +import Database.SQLite.Simple qualified as SQLite +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import System.Posix.Files qualified as PosixFiles +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = testGroup "Source resolution" + [ testCase "validates mount-root-relative POSIX paths" validatesRelativePaths + , testCase "rejects duplicate source mount ids" rejectsDuplicateMountIds + , testCase "rejects duplicate canonical mount roots" rejectsDuplicateMountRoots + , testCase "permits missing and rejects non-directory mounts" + validatesMountRootTypes + , testCase "rejects relative exact roots" rejectsRelativeExactRoots + , testCase "retains exact root spelling as diagnostic trivia" retainsRootSpelling + , testCase "searched and exact roots share canonical identity" rootFormsShareIdentity + , testCase "attributes nested sources to the most specific mount" attributesNestedSources + , testCase "configured order selects searched candidates" candidateOrderSelectsWinner + , testCase "rejects a higher-priority special source" + rejectsHigherPrioritySpecialSource + , testCase "rejects exact roots outside configured mounts" rejectsOutsideExactRoot + , testCase "loads source text as strict UTF-8" loadsStrictUtf8 + , testCase "reports malformed UTF-8 sequence starts" + reportsInvalidUtf8Offsets + , testCase "reserves the all-ones file identifier" + preservesReservedFileId + , testCase "builds an imported-before-importer source graph" buildsSourceGraph + , testCase "rejects the packaged prelude as ordinary source" + rejectsPackagedPreludeAsOrdinarySource + , testCase "orders sibling imports by textual occurrence" + ordersSiblingImports + , testCase "orders shared dependencies before their importers" + ordersSharedDependencies + , testCase "retains repeated import-edge occurrences" retainsRepeatedImports + , testCase "deduplicates canonical source nodes" deduplicatesCanonicalNodes + , testCase "reports missing imports at their source location" reportsMissingImports + , testCase "rejects unsafe imports at their source location" rejectsUnsafeImports + , testCase "reports the located import cycle chain" reportsImportCycles + , testCase "rejects malformed imported source before discovery" rejectsMalformedImportedSource + , testCase "builds empty modules through the ordinary pipeline" + buildsEmptyModules + , testCase "identifies owner-independent parsed modules" + identifiesOwnerIndependentParsedModules + , testCase "keys effective direct syntax inputs" + keysEffectiveDirectSyntaxInputs + , testCase "reuses exact parsed syntax on a warm pass" + reusesExactParsedSyntax + , testCase "invalidates exact parsed inputs transitively" + invalidatesExactParsedInputs + , testCase "rebinds relocated parsed artifacts" + rebindsRelocatedParsedArtifacts + , testCase "rejects a corrupted cached declaration anchor" + rejectsCorruptedCachedDeclarationAnchor + , testCase "parses source-local blocks in graph order" parsesSourceGraph + , testCase "does not leak syntax between sibling imports" + rejectsSiblingSyntaxLeakage + , testCase "parses source fixity levels and grouping" + parsesSourceFixities + , testCase "parses cdot and symdiff fixities" + parsesLibraryFixities + , testCase "validates source pragma associations" + validatesSourcePragmaAssociations + , testCase "rejects fixed-base category mismatches" + rejectsFixedBaseCategoryMismatch + , testCase "retains multi-item syntax occurrence order" + retainsMultiItemSyntaxOccurrences + , testCase "propagates and coalesces imported syntax" + propagatesImportedSyntax + , testCase "rejects unequal imported syntax" + rejectsUnequalImportedSyntax + , testCase "qualifies same-display cross-mount collisions" + distinguishesPhysicalSourceLocations + , testCase "retains each workspace location display path" + retainsWorkspaceLocationDisplayPath + , testCase "reports imported scanner errors before importer tokenizer errors" + reportsImportedScannerErrorFirst + , testCase "returns malformed lexical declarations as typed errors" + reportsMalformedLexicalDeclaration + , testCase "validates inductive function patterns during scanning" + rejectsMalformedInductivePattern + , testCase "scans and parses adjective signatures" + acceptsAdjectiveSignature + , testCase "rejects malformed math-led signature heads" + rejectsMalformedSignatureHead + , testCase "locates conflicting declarations within one environment" + reportsSameSourceLexiconCollision + , testCase "accepts the first source declaration of a built-in pattern" + acceptsBuiltinSourceDeclaration + , testCase "keeps the built-in marker for a prefix predicate declaration" + acceptsBuiltinPrefixPredicateDeclaration + , testCase "does not rescan repeated canonical imports" + avoidsAliasImportLexiconCollision + , testCase "parses loaded sources without rereading files" parsesWithoutRereading + , testCase "returns source-local failures after prior chunk callbacks" + returnsSourceParseFailures + , testCase "rejects guarded symbolic declarations before publication" + rejectsGuardedSymbolicDeclarations + ] + +validatesRelativePaths :: Assertion +validatesRelativePaths = do + assertRight (safeRelativePath "theory/set.tex") + assertRight (safeRelativePath "theory\\set.tex") + assertLeft EmptyRelativePath (safeRelativePath "") + assertLeft AbsoluteRelativePath (safeRelativePath "/theory.tex") + assertLeft CurrentDirectoryComponent (safeRelativePath "./theory.tex") + assertLeft ParentDirectoryComponent (safeRelativePath "a/../theory.tex") + assertLeft EmptyPathComponent (safeRelativePath "a//theory.tex") + assertLeft EmptyPathComponent (safeRelativePath "a/") + assertLeft NullPathCharacter (safeRelativePath "a\0b") + +rejectsDuplicateMountIds :: Assertion +rejectsDuplicateMountIds = + withTemporaryDirectory "felix-source-duplicate-id" \temp -> do + result <- prepareSourceMounts + [ (sourceMountId "same", temp Posix. "one") + , (sourceMountId "same", temp Posix. "two") + ] + assertEqual + "duplicate id" + (Left (DuplicateSourceMountId (sourceMountId "same"))) + result + +rejectsDuplicateMountRoots :: Assertion +rejectsDuplicateMountRoots = + withTemporaryDirectory "felix-source-duplicate-root" \temp -> do + result <- prepareSourceMounts + [ (sourceMountId "one", temp) + , (sourceMountId "two", temp Posix. ".") + ] + canonical <- Directory.canonicalizePath temp + case result of + Left (DuplicateCanonicalMountRoot root firstId secondId) -> do + assertEqual "canonical root" canonical (canonicalPathFilePath root) + assertEqual "first mount id" (sourceMountId "one") firstId + assertEqual "second mount id" (sourceMountId "two") secondId + Left err -> + assertFailure ("expected DuplicateCanonicalMountRoot, got " <> show err) + Right mounts -> + assertFailure ("expected duplicate-root rejection, got " <> show mounts) + +validatesMountRootTypes :: Assertion +validatesMountRootTypes = + withTemporaryDirectory "felix-source-mount-type" \temp -> do + let ident = sourceMountId "project" + missing = temp Posix. "missing" + regularFile = temp Posix. "file" + assertRight =<< prepareSourceMounts [(ident, missing)] + + writeFile regularFile "" + result <- prepareSourceMounts [(ident, regularFile)] + case result of + Left SourceMountNotDirectory{} -> + pure () + Left err -> + assertFailure + ("expected SourceMountNotDirectory, got " <> show err) + Right mounts -> + assertFailure + ("expected non-directory rejection, got " <> show mounts) + +rejectsRelativeExactRoots :: Assertion +rejectsRelativeExactRoots = + assertEqual + "relative exact roots are rejected" + (Left (ExistingRootNotAbsolute "entry.tex")) + =<< existingRoot "entry.tex" + +retainsRootSpelling :: Assertion +retainsRootSpelling = + withTemporaryDirectory "felix-source-root-spelling" \temp -> do + let source = temp Posix. "entry.tex" + alias = temp Posix. "entry-alias.tex" + writeFile source "" + Directory.createFileLink source alias + direct <- expectRight =<< existingRoot source + throughAlias <- expectRight =<< existingRoot alias + assertEqual "canonical request identity" direct throughAlias + assertEqual "diagnostic spelling" alias + (rootRequestSpelling throughAlias) + +rootFormsShareIdentity :: Assertion +rootFormsShareIdentity = + withTemporaryDirectory "felix-source-root-identity" \temp -> do + let source = temp Posix. "entry.tex" + writeFile source "source" + mounts <- oneMount "project" temp + searched <- expectRight (searchedRoot "entry.tex") + exact <- expectRight =<< existingRoot source + searchedLoaded <- expectRight =<< resolveAndLoadRoot mounts searched + exactLoaded <- expectRight =<< resolveAndLoadRoot mounts exact + assertEqual "loaded source" searchedLoaded exactLoaded + assertEqual "source mount" + (resolvedSourceMount (loadedSource searchedLoaded)) + (resolvedSourceMount (loadedSource exactLoaded)) + assertEqual "mount-relative source path" + (resolvedSourceRelativePath (loadedSource searchedLoaded)) + (resolvedSourceRelativePath (loadedSource exactLoaded)) + +rejectsPackagedPreludeAsOrdinarySource :: Assertion +rejectsPackagedPreludeAsOrdinarySource = do + packaged <- expectRight =<< Prelude.loadReservedPreludeSourceInput + canonical <- expectJust "packaged canonical path" + (Prelude.reservedPreludeSourceCanonicalPath packaged) + let path = canonicalPathFilePath canonical + mounts <- oneMount "packaged" (Posix.takeDirectory path) + request <- expectRight (searchedRoot (Posix.takeFileName path)) + let validate = Prelude.rejectOrdinaryPreludeSourceGraph packaged + syntaxInputs = const [] + Parse.parseSourceWorkspaceWithSyntaxInputsAndGraphValidation + mounts request syntaxInputs validate >>= \case + Left + (Parse.SourceWorkspaceError + (PackagedPreludeSelectedAsOrdinarySource source)) -> + assertEqual "authority-free rejected path" + canonical + (resolvedSourceCanonicalPath source) + other -> + assertFailure + ("unexpected authority-free result: " <> show other) + + withTemporaryDirectory "felix-reserved-parse-store" \temp -> do + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix. "store.sqlite") + (Identity.theoryId foundation) + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation + store mounts request syntaxInputs validate >>= \case + Left + (Parse.ParseExecutionWorkspaceError + (Parse.SourceWorkspaceError + (PackagedPreludeSelectedAsOrdinarySource source))) -> + assertEqual "typed rejected path" + canonical + (resolvedSourceCanonicalPath source) + other -> + assertFailure + ("unexpected typed result: " <> show other) + Store.closeStore store + +attributesNestedSources :: Assertion +attributesNestedSources = + withTemporaryDirectory "felix-source-nested-mount" \temp -> do + let nested = temp Posix. "library" + source = nested Posix. "entry.tex" + Directory.createDirectory nested + writeFile source "source" + exact <- expectRight =<< existingRoot source + outerFirst <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", temp) + , (sourceMountId "library", nested) + ] + innerFirst <- expectRight =<< prepareSourceMounts + [ (sourceMountId "library", nested) + , (sourceMountId "project", temp) + ] + searched <- expectRight (searchedRoot "library/entry.tex") + outerFirstSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot outerFirst exact) + innerFirstSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot innerFirst exact) + searchedSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot outerFirst searched) + assertEqual "order-independent attribution" outerFirstSource innerFirstSource + assertEqual "root-form-independent attribution" outerFirstSource searchedSource + assertEqual "most specific mount" (sourceMountId "library") (resolvedSourceMount outerFirstSource) + assertEqual "mount-relative identity" "entry.tex" + (safeRelativePathFilePath (resolvedSourceRelativePath outerFirstSource)) + +candidateOrderSelectsWinner :: Assertion +candidateOrderSelectsWinner = + withTemporaryDirectory "felix-source-precedence" \temp -> do + let firstRoot = temp Posix. "first" + secondRoot = temp Posix. "second" + firstSource = firstRoot Posix. "entry.tex" + secondSource = secondRoot Posix. "entry.tex" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile firstSource "first" + writeFile secondSource "second" + request <- expectRight (searchedRoot "entry.tex") + firstMounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "first", firstRoot) + , (sourceMountId "second", secondRoot) + ] + secondMounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "second", secondRoot) + , (sourceMountId "first", firstRoot) + ] + firstWinner <- expectRight =<< resolveAndLoadRoot firstMounts request + secondWinner <- expectRight =<< resolveAndLoadRoot secondMounts request + assertEqual "first configured source" "first" (loadedText firstWinner) + assertEqual "reversed configured source" "second" (loadedText secondWinner) + +rejectsHigherPrioritySpecialSource :: Assertion +rejectsHigherPrioritySpecialSource = + withTemporaryDirectory "felix-source-special-precedence" \temp -> do + let higherRoot = temp Posix. "higher" + lowerRoot = temp Posix. "lower" + higherSource = higherRoot Posix. "entry.tex" + lowerSource = lowerRoot Posix. "entry.tex" + Directory.createDirectory higherRoot + Directory.createDirectory lowerRoot + PosixFiles.createNamedPipe higherSource PosixFiles.ownerModes + writeFile lowerSource "ordinary source" + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "higher", higherRoot) + , (sourceMountId "lower", lowerRoot) + ] + request <- expectRight (searchedRoot "entry.tex") + result <- resolveRoot mounts request + case result of + Left + (SelectedSourceNotRegular + (SearchedRootLookup relative) + selectedPath + canonical) -> do + assertEqual "searched path" + "entry.tex" + (safeRelativePathFilePath relative) + assertEqual "selected higher candidate" + higherSource + selectedPath + canonicalHigher <- + Directory.canonicalizePath higherSource + assertEqual "selected canonical target" + canonicalHigher + (canonicalPathFilePath canonical) + Left err -> + assertFailure + ("expected SelectedSourceNotRegular, got " <> show err) + Right source -> + assertFailure + ("expected special-source rejection, got " <> show source) + +rejectsOutsideExactRoot :: Assertion +rejectsOutsideExactRoot = + withTemporaryDirectory "felix-source-outside-root" \temp -> do + let mountRoot = temp Posix. "mount" + outsideRoot = temp Posix. "outside" + source = outsideRoot Posix. "entry.tex" + Directory.createDirectory mountRoot + Directory.createDirectory outsideRoot + writeFile source "source" + mounts <- oneMount "project" mountRoot + exact <- expectRight =<< existingRoot source + result <- resolveAndLoadRoot mounts exact + case result of + Left (RootOutsideConfiguredMount spelling _canonical) -> + assertEqual "exact-root diagnostic spelling" source spelling + Left err -> + assertFailure ("expected RootOutsideConfiguredMount, got " <> show err) + Right loaded -> + assertFailure ("expected outside-root rejection, got " <> show loaded) + +loadsStrictUtf8 :: Assertion +loadsStrictUtf8 = + withTemporaryDirectory "felix-source-utf8" \temp -> do + let source = temp Posix. "unicode.tex" + bytes = + ByteString.pack + [ 0xCE, 0xB1, 0x20, 0xE2 + , 0x88, 0x88, 0x20, 0x41 + ] + ByteString.writeFile source bytes + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "unicode.tex") + loaded <- expectRight =<< resolveAndLoadRoot mounts request + assertEqual "exact bytes" bytes (loadedBytes loaded) + assertEqual "decoded text" ("α ∈ A" :: Text) (loadedText loaded) + assertEqual + "byte count" + (fromIntegral (ByteString.length bytes)) + (loadedByteCount loaded) + let identifier = + Content.sourceContentId loaded + assertEqual + "content identity cache round trip" + (Right identifier) + (Cache.decodeCache + Content.getSourceContentIdCache + (Cache.encodeCache + (Content.putSourceContentIdCache + identifier))) + ByteString.writeFile source (bytes <> "\n") + changed <- expectRight + =<< loadResolvedSource (loadedSource loaded) + assertBool + "exact byte edits change source identity" + (identifier /= Content.sourceContentId changed) + +reportsInvalidUtf8Offsets :: Assertion +reportsInvalidUtf8Offsets = + withTemporaryDirectory "felix-source-invalid-utf8" \temp -> do + let source = temp Posix. "invalid.tex" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "invalid.tex") + let assertOffset label bytes expected = do + ByteString.writeFile source (ByteString.pack bytes) + result <- resolveAndLoadRoot mounts request + case result of + Left (SourceDecodeError _source offset) -> + assertEqual label expected offset + Left err -> + assertFailure + ("expected SourceDecodeError, got " <> show err) + Right loaded -> + assertFailure + ("expected malformed UTF-8 rejection, got " + <> show loaded) + assertOffset "malformed sequence start" [0x61, 0xC3, 0x28] 1 + assertOffset "incomplete sequence start" [0x61, 0xC3] 1 + +preservesReservedFileId :: Assertion +preservesReservedFileId = + case allocateFileId boundaryAllocator of + Left err -> + assertFailure + ("could not allocate last available file id: " <> show err) + Right (fileId, exhaustedAllocator) -> do + assertEqual "last available file id" + (maxBound - 1) + (unFileId fileId) + assertBool "allocator returned reserved file id" + (unFileId fileId /= maxBound) + assertEqual "allocator reports exhaustion" + (Left FileIdSpaceExhausted) + (allocateFileId exhaustedAllocator) + where + boundaryAllocator = + FileIdAllocator + (fromIntegral (maxBound :: Word16) - 1) + +buildsSourceGraph :: Assertion +buildsSourceGraph = + withTemporaryDirectory "felix-source-graph" \temp -> do + writeTheory (temp Posix. "shared.tex") [] "shared" + writeTheory (temp Posix. "entry.tex") ["shared.tex"] "entry" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + assertEqual "two source nodes" 2 (length (sourceGraphNodes graph)) + case sourceGraphImportEdges graph of + [edge] -> do + assertEqual "root imports" (sourceGraphRoot graph) (sourceImportingNode edge) + assertEqual + "imported-before-importer order" + [sourceImportedNode edge, sourceGraphRoot graph] + ( sourceNodeCanonicalPathForTest + <$> toList + (sourceGraphImportedBeforeImporter graph) + ) + assertEqual "import location line" 1 + (locLine (importLocation (sourceImportReference edge))) + assertEqual "selected location path" "entry.tex" + (locFile (importLocation (sourceImportReference edge))) + edges -> + assertFailure ("expected one import edge, got " <> show edges) + +ordersSiblingImports :: Assertion +ordersSiblingImports = + withTemporaryDirectory "felix-source-sibling-order" \temp -> do + writeTheory (temp Posix. "a.tex") [] "a" + writeTheory (temp Posix. "b.tex") [] "b" + writeTheory + (temp Posix. "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + order <- sourceGraphOrderPaths graph + assertEqual "DFS completion order" + ["a.tex", "b.tex", "entry.tex"] + order + +ordersSharedDependencies :: Assertion +ordersSharedDependencies = + withTemporaryDirectory "felix-source-shared-order" \temp -> do + writeTheory (temp Posix. "shared.tex") [] "shared" + writeTheory (temp Posix. "a.tex") ["shared.tex"] "a" + writeTheory (temp Posix. "b.tex") ["shared.tex"] "b" + writeTheory + (temp Posix. "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + order <- sourceGraphOrderPaths graph + assertEqual "shared dependency occurs once before both importers" + ["shared.tex", "a.tex", "b.tex", "entry.tex"] + order + +retainsRepeatedImports :: Assertion +retainsRepeatedImports = + withTemporaryDirectory "felix-source-repeated-import" \temp -> do + writeTheory (temp Posix. "shared.tex") [] "shared" + writeTheory + (temp Posix. "entry.tex") + ["shared.tex", "shared.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + assertEqual "canonical node count" 2 (length (sourceGraphNodes graph)) + assertEqual "repeated edge count" 2 (length (sourceGraphImportEdges graph)) + +deduplicatesCanonicalNodes :: Assertion +deduplicatesCanonicalNodes = + withTemporaryDirectory "felix-source-canonical-dedup" \temp -> do + let shared = temp Posix. "shared.tex" + alias = temp Posix. "alias.tex" + writeTheory shared [] "shared" + Directory.createFileLink shared alias + writeTheory + (temp Posix. "entry.tex") + ["shared.tex", "alias.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + assertEqual "one node for symlink aliases" 2 (length (sourceGraphNodes graph)) + case sourceGraphImportEdges graph of + [firstEdge, secondEdge] -> + assertEqual + "both occurrences reach one node" + (sourceImportedNode firstEdge) + (sourceImportedNode secondEdge) + edges -> + assertFailure ("expected two import edges, got " <> show edges) + +reportsMissingImports :: Assertion +reportsMissingImports = + withTemporaryDirectory "felix-source-missing-import" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "% heading" + , "\\import{missing.tex}" + , theoryBlock "entry" + ]) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceNotFound (ImportedSourceLookup _ reference) _candidates) -> do + assertEqual "missing import line" 2 (locLine (importLocation reference)) + assertEqual "missing import source" "entry.tex" + (locFile (importLocation reference)) + Left err -> + assertFailure ("expected located SourceNotFound, got " <> show err) + Right graph -> + assertFailure ("expected missing-import rejection, got " <> show graph) + +rejectsUnsafeImports :: Assertion +rejectsUnsafeImports = + withTemporaryDirectory "felix-source-unsafe-import" \temp -> do + writeTheory (temp Posix. "entry.tex") ["./shared.tex"] "entry" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (InvalidImportPath _source location raw CurrentDirectoryComponent) -> do + assertEqual "raw import" "./shared.tex" raw + assertEqual "unsafe import line" 1 (locLine location) + assertEqual "unsafe import source" "entry.tex" (locFile location) + Left err -> + assertFailure ("expected InvalidImportPath, got " <> show err) + Right graph -> + assertFailure ("expected unsafe-import rejection, got " <> show graph) + +reportsImportCycles :: Assertion +reportsImportCycles = + withTemporaryDirectory "felix-source-cycle" \temp -> do + writeTheory (temp Posix. "a.tex") ["b.tex"] "a" + writeTheory (temp Posix. "b.tex") ["a.tex"] "b" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "a.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceImportCycle steps) -> do + assertEqual "cycle length" 2 (length steps) + assertEqual + "cycle importer sequence" + ["a.tex", "b.tex"] + [ safeRelativePathFilePath + (resolvedSourceRelativePath (cycleImporter step)) + | step <- toList steps + ] + assertEqual + "cycle import locations" + ["a.tex", "b.tex"] + [ locFile (importLocation (cycleImport step)) + | step <- toList steps + ] + Left err -> + assertFailure ("expected SourceImportCycle, got " <> show err) + Right graph -> + assertFailure ("expected cycle rejection, got " <> show graph) + +rejectsMalformedImportedSource :: Assertion +rejectsMalformedImportedSource = + withTemporaryDirectory "felix-source-import-utf8" \temp -> do + writeTheory (temp Posix. "entry.tex") ["bad.tex"] "entry" + ByteString.writeFile + (temp Posix. "bad.tex") + (ByteString.pack [0x61, 0xFF]) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceDecodeError source offset) -> do + assertEqual "bad source" "bad.tex" + (safeRelativePathFilePath (resolvedSourceRelativePath source)) + assertEqual "bad byte offset" 1 offset + Left err -> + assertFailure ("expected SourceDecodeError, got " <> show err) + Right graph -> + assertFailure ("expected malformed-source rejection, got " <> show graph) + +buildsEmptyModules :: Assertion +buildsEmptyModules = + withTemporaryDirectory "felix-source-empty" \temp -> + forM_ + [ ("empty.tex", "") + , ("comments.tex", "% heading\n% body") + ] + \(relative, contents) -> do + writeFile (temp Posix. relative) contents + graph <- buildSearchedGraph temp relative + assertEqual + "one ordinary graph node" + 1 + (length (sourceGraphNodes graph)) + emittedRef <- newIORef (0 :: Int) + workspace <- + expectRight + =<< Parse.parseResolvedSourceGraphWith + graph + (\_source _block -> + modifyIORef' emittedRef (+ 1)) + assertEqual + "no block callbacks" + 0 + =<< readIORef emittedRef + assertEqual + "empty parsed projection" + [] + (Parse.importedBeforeImporterBlocks workspace) + assertBool + "empty syntax declarations" + (null + (Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface + (Parse.parsedWorkspaceRootModule + workspace))))) + +identifiesOwnerIndependentParsedModules :: Assertion +identifiesOwnerIndependentParsedModules = + withTemporaryDirectory "felix-parsed-identity" \temp -> do + let firstRoot = temp Posix. "first" + secondRoot = temp Posix. "second" + bytes = axiomBlock "same" "x = x" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix. "entry.tex") bytes + writeFile (secondRoot Posix. "entry.tex") bytes + firstWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph firstRoot "entry.tex" + secondWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + assertBool + "logical owners remain distinct" + ( Module.moduleName (Parse.parsedModuleAddress first) + /= Module.moduleName (Parse.parsedModuleAddress second) + ) + assertEqual + "equal bytes retain one content identity" + (Parse.parsedModuleSourceContentId first) + (Parse.parsedModuleSourceContentId second) + assertEqual + "physical source registration is outside parsed identity" + (Parse.parsedModuleId first) + (Parse.parsedModuleId second) + assertEqual + "canonical payload is owner-independent" + (Parse.parsedModulePayload first) + (Parse.parsedModulePayload second) + let payload = Parse.parsedModulePayload first + assertEqual + "canonical parsed payload cache round trip" + (Right payload) + (Cache.decodeCache + Parsed.getCanonicalParsedPayloadCache + (Cache.encodeCache + (Parsed.putCanonicalParsedPayloadCache payload))) + rebound <- expectRight + (Parsed.decodeCanonicalParsedPayload + (FileId 123) + payload) + case Parsed.decodedParsedBlocks rebound of + Raw.BlockAxiom location _title _marker _axiom : _ -> + assertEqual + "decoded locations bind only to the current live file" + (Just (FileId 123)) + (locFileId location) + blocks -> + assertFailure + ("expected decoded axiom, got " <> show blocks) + writeFile + (secondRoot Posix. "entry.tex") + (bytes <> "% content identity change\n") + changedWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + assertBool + "exact source changes parsed identity" + ( Parse.parsedModuleId first + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule changedWorkspace) + ) + +keysEffectiveDirectSyntaxInputs :: Assertion +keysEffectiveDirectSyntaxInputs = + withTemporaryDirectory "felix-parsed-syntax-input" \temp -> do + let firstRoot = temp Posix. "first" + secondRoot = temp Posix. "second" + rootBytes = "\\import{notation.tex}\n" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix. "entry.tex") rootBytes + writeFile (secondRoot Posix. "entry.tex") rootBytes + writeFile + (firstRoot Posix. "notation.tex") + (syntaxFunctionDefinition + "first_notation" + "firstop" + (Just "%! infixl 1")) + writeFile + (secondRoot Posix. "notation.tex") + (syntaxFunctionDefinition + "second_notation" + "secondop" + (Just "%! infixl 1")) + firstWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph firstRoot "entry.tex" + secondWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + assertEqual + "root source bytes are unchanged" + (Parse.parsedModuleSourceContentId first) + (Parse.parsedModuleSourceContentId second) + assertBool + "effective syntax changes the parsed key" + (Parse.parsedModuleKey first /= Parse.parsedModuleKey second) + assertBool + "effective syntax changes parsed identity" + (Parse.parsedModuleId first /= Parse.parsedModuleId second) + +reusesExactParsedSyntax :: Assertion +reusesExactParsedSyntax = + withTemporaryDirectory "felix-parsed-warm" \temp -> do + let datatype = unlines + [ "\\begin{datatype}\\label{multi_item}" + , " Define $\\itemkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $\\itemzero \\in \\itemkind$." + , " \\item $\\itemsucc{x} \\in \\itemkind$ for $x \\in \\itemkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ] + writeFile + (temp Posix. "entry.tex") + (builtinZeroDefinition "source_zero" <> datatype) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix. "store.sqlite") + (Identity.theoryId foundation) + coldCallbacks <- newIORef (0 :: Int) + cold <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + store mounts request (const []) + (\_source _block -> modifyIORef' coldCallbacks (+ 1)) + warmCallbacks <- newIORef (0 :: Int) + warm <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + store mounts request (const []) + (\_source _block -> modifyIORef' warmCallbacks (+ 1)) + let coldRoot = Parse.parsedWorkspaceRootModule cold + warmRoot = Parse.parsedWorkspaceRootModule warm + let expectedChunkCount = + length (Parse.parsedModuleBlocks warmRoot) + assertBool "fixture has source chunks" (expectedChunkCount > 0) + assertEqual "cold callbacks" expectedChunkCount + =<< readIORef coldCallbacks + assertEqual "warm callbacks" expectedChunkCount + =<< readIORef warmCallbacks + assertEqual "warm blocks" (Parse.parsedModuleBlocks coldRoot) + (Parse.parsedModuleBlocks warmRoot) + assertEqual "warm occurrences" + (Parse.parsedModuleSyntaxOccurrences coldRoot) + (Parse.parsedModuleSyntaxOccurrences warmRoot) + assertEqual "warm syntax interface" + (Parse.parsedModuleSyntaxInterface coldRoot) + (Parse.parsedModuleSyntaxInterface warmRoot) + assertEqual "warm parsed identity" + (Parse.parsedModuleId coldRoot) + (Parse.parsedModuleId warmRoot) + case Parse.parsedModuleSyntaxOccurrences warmRoot of + first : second : third : fourth : [] -> do + assertEqual "fixed source marker" "source_zero" + (Parse.parsedSyntaxOccurrenceMarker first) + case Parse.parsedSyntaxOccurrenceEntry first of + Interface.CanonicalExpressionFunction + _pattern marker _fixity -> + assertEqual "fixed authoritative marker" "zero" marker + entry -> + assertFailure + ("unexpected fixed cached entry: " <> show entry) + assertEqual "multi-item block order" [1, 1, 1] + (Parse.parsedSyntaxOccurrenceBlockIndex + <$> [second, third, fourth]) + assertEqual "multi-item scanner order" + ["multi_item", "itemzero", "itemsucc"] + (Parse.parsedSyntaxOccurrenceMarker + <$> [second, third, fourth]) + case drop 1 (Parse.parsedModuleBlocks warmRoot) of + block : _ -> + case block of + Raw.BlockData _location _title marker _datatype -> + assertEqual "cached declaration-head anchor" + marker + (Parse.parsedSyntaxOccurrenceMarker second) + other -> + assertFailure + ("expected cached datatype block, got " + <> show other) + [] -> + assertFailure "cached datatype block is absent" + occurrences -> + assertFailure + ("unexpected cached syntax occurrences: " + <> show occurrences) + assertEqual "cold callback projection" 2 + =<< readIORef coldCallbacks + assertEqual "warm callback projection" 2 + =<< readIORef warmCallbacks + Store.closeStore store + +invalidatesExactParsedInputs :: Assertion +invalidatesExactParsedInputs = + withTemporaryDirectory "felix-parsed-invalidation" \temp -> do + let notationPath = temp Posix. "notation.tex" + entryPath = temp Posix. "entry.tex" + notation associativity level = + syntaxFunctionDefinition + "join" + "join" + (Just + ("%! " <> associativity <> " " <> show level)) + entry suffix = + "\\import{notation.tex}\n" + <> axiomBlock + "imported_syntax_use" + "a\\join b\\join c = a" + <> suffix + writeFile notationPath (notation "infixl" (1 :: Int)) + writeFile entryPath (entry "") + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix. "store.sqlite") + (Identity.theoryId foundation) + let parse = + expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store mounts request (const []) + coldWorkspace <- parse + warmWorkspace <- parse + coldNotation <- findParsedModule "notation.tex" coldWorkspace + warmNotation <- findParsedModule "notation.tex" warmWorkspace + let coldRoot = Parse.parsedWorkspaceRootModule coldWorkspace + warmRoot = Parse.parsedWorkspaceRootModule warmWorkspace + assertEqual "unchanged import identity" + (Parse.parsedModuleId coldNotation) + (Parse.parsedModuleId warmNotation) + assertEqual "unchanged importer identity" + (Parse.parsedModuleId coldRoot) + (Parse.parsedModuleId warmRoot) + + writeFile entryPath (entry "% formatting-only edit\n") + editedWorkspace <- parse + editedNotation <- findParsedModule "notation.tex" editedWorkspace + let editedRoot = Parse.parsedWorkspaceRootModule editedWorkspace + assertEqual "cached import retains identity" + (Parse.parsedModuleId warmNotation) + (Parse.parsedModuleId editedNotation) + assertBool "exact source edit changes importer key" + (Parse.parsedModuleKey warmRoot + /= Parse.parsedModuleKey editedRoot) + assertEqual "formatting retains parsed projection" + (Parse.parsedModulePayload warmRoot) + (Parse.parsedModulePayload editedRoot) + + writeFile notationPath (notation "infixr" (2 :: Int)) + syntaxWorkspace <- parse + syntaxNotation <- findParsedModule "notation.tex" syntaxWorkspace + let syntaxRoot = Parse.parsedWorkspaceRootModule syntaxWorkspace + assertBool "local syntax identity changes" + ( Interface.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface editedNotation) + /= Interface.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface syntaxNotation) + ) + assertEqual "importer source is unchanged" + (Parse.parsedModuleSourceContentId editedRoot) + (Parse.parsedModuleSourceContentId syntaxRoot) + assertBool "direct syntax invalidates importer key" + (Parse.parsedModuleKey editedRoot + /= Parse.parsedModuleKey syntaxRoot) + Store.closeStore store + +rebindsRelocatedParsedArtifacts :: Assertion +rebindsRelocatedParsedArtifacts = + withTemporaryDirectory "felix-parsed-relocation" \temp -> do + let firstRoot = temp Posix. "first" + secondRoot = temp Posix. "second" + sourceBytes = axiomBlock "same" "x = x" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix. "entry.tex") sourceBytes + writeFile (secondRoot Posix. "entry.tex") sourceBytes + firstMounts <- oneMount "first" firstRoot + secondMounts <- oneMount "second" secondRoot + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + let theory = Identity.theoryId foundation + store <- openTestStore (temp Posix. "store.sqlite") theory + firstWorkspace <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store firstMounts request (const []) + secondWorkspace <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store secondMounts request (const []) + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + firstSource = Parse.parsedModuleResolved first + secondSource = Parse.parsedModuleResolved second + assertEqual "relocation retains parsed identity" + (Parse.parsedModuleId first) + (Parse.parsedModuleId second) + assertEqual "relocation retains canonical payload" + (Parse.parsedModulePayload first) + (Parse.parsedModulePayload second) + assertBool "relocation rebinds the physical source" + (resolvedSourceCanonicalPath firstSource + /= resolvedSourceCanonicalPath secondSource) + assertBool "relocation rebinds the logical owner" + (Parse.parsedModuleAddress first + /= Parse.parsedModuleAddress second) + firstFileId <- expectJust "first location file id" + (locFileId (onlyAxiomLocation first)) + secondFileId <- expectJust "second location file id" + (locFileId (onlyAxiomLocation second)) + assertBool "relocation rebinds locations" + (firstFileId /= secondFileId) + firstArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (Module.moduleName (Parse.parsedModuleAddress first)) + (Parse.parsedModuleId first) + [] + theory) + secondArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (Module.moduleName (Parse.parsedModuleAddress second)) + (Parse.parsedModuleId second) + [] + theory) + assertBool "module artifact remains owner-dependent" + (Semantic.moduleArtifactId firstArtifactKey + /= Semantic.moduleArtifactId secondArtifactKey) + Store.closeStore store + +rejectsCorruptedCachedDeclarationAnchor :: Assertion +rejectsCorruptedCachedDeclarationAnchor = + withTemporaryDirectory "felix-parsed-corrupt-anchor" \temp -> do + writeBuiltinZeroDefinition + (temp Posix. "entry.tex") + "source_zero" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + let storePath = temp Posix. "store.sqlite" + theory = Identity.theoryId foundation + store <- openTestStore storePath theory + cold <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store mounts request (const []) + let parsed = Parse.parsedWorkspaceRootModule cold + key = Parse.parsedModuleKey parsed + fileId <- case Parse.parsedModuleSyntaxOccurrences parsed of + occurrence : _ -> + expectJust + "parsed occurrence file id" + (locFileId + (Parse.parsedSyntaxOccurrenceLocation occurrence)) + [] -> + assertFailure "parsed fixed occurrence is absent" + >> fail "unreachable" + decoded <- expectRight + (Parsed.decodeCanonicalParsedPayload + fileId + (Parse.parsedModulePayload parsed)) + Store.closeStore store + let corruptedOccurrences = case Parsed.decodedParsedOccurrences decoded of + (blockIndex, location, _marker, entry) : rest -> + (blockIndex, location, "corrupted_anchor", entry) : rest + [] -> + [] + corruptedPayload = + Parsed.canonicalParsedPayload + (Parsed.decodedParsedImports decoded) + (Parsed.decodedParsedBlocks decoded) + corruptedOccurrences + (Parsed.decodedParsedSyntaxInterface decoded) + corruptedId = + ParsedIdentity.parsedModuleId + key + (Parsed.canonicalParsedPayloadBytes corruptedPayload) + connection <- SQLite.open storePath + SQLite.execute connection + "UPDATE parsed_artifacts \ + \SET parsed_module_id = ?, payload = ? \ + \WHERE parsed_module_key = ?" + ( Cache.cacheDigestBytes + (ParsedIdentity.parsedModuleIdDigest corruptedId) + , Parsed.canonicalParsedPayloadBytes corruptedPayload + , Cache.cacheDigestBytes + (ParsedIdentity.parsedModuleKeyDigest key) + ) + SQLite.close connection + current <- openTestStore storePath theory + callbacks <- newIORef (0 :: Int) + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + current mounts request (const []) + (\_source _block -> modifyIORef' callbacks (+ 1)) >>= \case + Left + (Parse.ParseExecutionArtifactIntegrityFailure + _source + (Parse.ParsedArtifactAssociationFailure + Parse.SyntaxOccurrenceMarkerMismatch{})) -> + pure () + other -> + assertFailure + ("unexpected corrupted parsed result: " <> show other) + assertEqual "corrupt hit invokes no parse callback" 0 + =<< readIORef callbacks + Store.closeStore current + +openTestStore :: FilePath -> Identity.TheoryId -> IO Store.Store +openTestStore path theory = + Store.openStore path theory >>= \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right (_startup, store) -> + pure store + +expectParseExecution + :: Either Parse.ParseExecutionError value + -> IO value +expectParseExecution = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +parsesSourceGraph :: Assertion +parsesSourceGraph = + withTemporaryDirectory "felix-source-parse" \temp -> do + writeTheory (temp Posix. "shared.tex") [] "shared" + writeTheory (temp Posix. "entry.tex") ["shared.tex"] "entry" + graph <- buildSearchedGraph temp "entry.tex" + emittedRef <- newIORef [] + workspace <- expectRight =<< + Parse.parseResolvedSourceGraphWith graph + (\source _block -> + modifyIORef' + emittedRef + (safeRelativePathFilePath + (resolvedSourceRelativePath source) :)) + assertEqual "two parsed source nodes" 2 + (length (Parse.parsedWorkspaceModules workspace)) + assertEqual "one source-local block per node" [1, 1] + (toList + (length . Parse.parsedModuleBlocks + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace)) + assertEqual "imported-before-importer source order" + ["shared.tex", "entry.tex"] + (toList + (safeRelativePathFilePath + . resolvedSourceRelativePath + . Parse.parsedModuleResolved + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace)) + assertEqual "flattened block view" 2 + (length (Parse.importedBeforeImporterBlocks workspace)) + emitted <- reverse <$> readIORef emittedRef + assertEqual "streamed block order" + ["shared.tex", "entry.tex"] + emitted + +rejectsSiblingSyntaxLeakage :: Assertion +rejectsSiblingSyntaxLeakage = + withTemporaryDirectory "felix-source-syntax-world" \temp -> do + writeFile + (temp Posix. "use.tex") + (unlines + [ "\\begin{axiom}\\label{use}" + , " $x$ is special." + , "\\end{axiom}" + ]) + writeAdjectiveDefinition + (temp Posix. "declare.tex") + "shared_special" + writeTheory + (temp Posix. "entry.tex") + ["use.tex", "declare.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left (Parse.SourceParseError source _parseError) -> + assertEqual + "syntax consumer fails in its own module" + "use.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + Left err -> + assertFailure + ("expected a source-local parse error, got " + <> show err) + Right workspace -> + assertFailure + ("sibling syntax leaked into use.tex: " + <> show workspace) + +parsesSourceFixities :: Assertion +parsesSourceFixities = + withTemporaryDirectory "felix-source-fixity" \temp -> do + writeFile + (temp Posix. "entry.tex") + ( syntaxFunctionDefinition + "loose" + "loose" + (Just "%! infixl 0") + <> syntaxFunctionDefinition + "tight" + "tight" + (Just "%! infixr 7") + <> axiomBlock + "loose_associativity" + "a\\loose b\\loose c = a" + <> axiomBlock + "tight_associativity" + "a\\tight b\\tight c = a" + <> axiomBlock + "mixed_precedence" + "a\\loose b\\tight c = a" + <> axiomBlock + "parenthesized_precedence" + "(a\\loose b)\\tight c = a" + ) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + localEntries = + Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface root)) + assertExpressionFixity + "loose" + Raw.LeftAssoc + 0 + localEntries + assertExpressionFixity + "tight" + Raw.RightAssoc + 7 + localEntries + assertEqual + "source declaration occurrences" + [0, 1] + (Parse.parsedSyntaxOccurrenceBlockIndex + <$> Parse.parsedModuleSyntaxOccurrences root) + case drop 2 (Parse.parsedModuleBlocks root) of + [ looseAssociativity + , tightAssociativity + , mixedPrecedence + , parenthesizedPrecedence + ] -> do + assertAxiomLeftShape + "left associativity" + "loose(loose(a,b),c)" + looseAssociativity + assertAxiomLeftShape + "right associativity" + "tight(a,tight(b,c))" + tightAssociativity + assertAxiomLeftShape + "mixed precedence" + "loose(a,tight(b,c))" + mixedPrecedence + assertAxiomLeftShape + "parentheses override precedence" + "tight(loose(a,b),c)" + parenthesizedPrecedence + blocks -> + assertFailure + ("expected four fixity axioms, got " + <> show blocks) + +parsesLibraryFixities :: Assertion +parsesLibraryFixities = + withTemporaryDirectory "felix-source-library-fixity" \temp -> do + writeFile + (temp Posix. "entry.tex") + ( syntaxFunctionDefinition + "cdot" + "cdot" + (Just "%! infixl 4") + <> syntaxFunctionDefinition + "symdiff" + "symdiff" + (Just "%! infixl 1") + <> axiomBlock + "cdot_associativity" + "a\\cdot b\\cdot c = a" + <> axiomBlock + "symdiff_associativity" + "a\\symdiff b\\symdiff c = a" + <> axiomBlock + "library_mixed_precedence" + "a\\symdiff b\\cdot c = a" + <> axiomBlock + "library_parentheses" + "(a\\symdiff b)\\cdot c = a" + ) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + case drop 2 + (Parse.parsedModuleBlocks + (Parse.parsedWorkspaceRootModule workspace)) of + [ cdotAssociativity + , symdiffAssociativity + , mixedPrecedence + , parenthesizedPrecedence + ] -> do + assertAxiomLeftShape + "cdot left associativity" + "cdot(cdot(a,b),c)" + cdotAssociativity + assertAxiomLeftShape + "symdiff left associativity" + "symdiff(symdiff(a,b),c)" + symdiffAssociativity + assertAxiomLeftShape + "cdot binds tighter than symdiff" + "symdiff(a,cdot(b,c))" + mixedPrecedence + assertAxiomLeftShape + "library parentheses override precedence" + "cdot(symdiff(a,b),c)" + parenthesizedPrecedence + blocks -> + assertFailure + ("expected four library-fixity axioms, got " + <> show blocks) + +validatesSourcePragmaAssociations :: Assertion +validatesSourcePragmaAssociations = + forM_ cases \(description, contents, checkProblem) -> + withTemporaryDirectory + ("felix-source-pragma-" <> description) + \temp -> do + writeFile + (temp Posix. "entry.tex") + contents + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left + (Parse.SourceSyntaxDeclarationError + source + problem) -> do + assertEqual + "pragma source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + checkProblem problem + Left err -> + assertFailure + ("expected source pragma error, got " + <> show err) + Right workspace -> + assertFailure + ("expected source pragma rejection, got " + <> show workspace) + where + cases + :: [ ( String + , String + , Parse.SyntaxDeclarationError -> Assertion + ) + ] + cases = + [ ( "outside" + , "%! infixl 1\n" <> theoryBlock "outside" + , \case + Parse.SyntaxPragmaOutsideDeclaration{} -> + pure () + problem -> + unexpected "outside-declaration pragma" problem + ) + , ( "inside-nonsyntax" + , unlines + [ "\\begin{axiom}\\label{inside_nonsyntax}" + , " %! infixl 1" + , " $x = x$." + , "\\end{axiom}" + ] + , \case + Parse.SyntaxPragmaOutsideDeclaration location -> + assertEqual + "pragma in non-syntax chunk" + 2 + (locLine location) + problem -> + unexpected "non-syntax declaration pragma" problem + ) + , ( "missing" + , syntaxFunctionDefinition + "missing" + "missing" + Nothing + , \case + Parse.MissingSyntaxPragma{} -> + pure () + problem -> + unexpected "missing pragma" problem + ) + , ( "duplicate" + , unlines + [ "\\begin{abbreviation}\\label{duplicate}" + , " %! infixl 1" + , " %! infixl 1" + , " $x\\duplicate y = x$." + , "\\end{abbreviation}" + ] + , \case + Parse.DuplicateSyntaxPragma{} -> + pure () + problem -> + unexpected "duplicate pragma" problem + ) + , ( "irrelevant" + , unlines + [ "\\begin{definition}\\label{irrelevant}" + , " %! infixl 1" + , " $x$ is irrelevant iff $x = x$." + , "\\end{definition}" + ] + , \case + Parse.IrrelevantSyntaxPragma{} -> + pure () + problem -> + unexpected "irrelevant pragma" problem + ) + , ( "multiple-without-pragma" + , unlines + [ "\\begin{datatype}\\label{multiple_patterns}" + , " Define $\\patternkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $(x \\firstpattern y) \\in \\patternkind$." + , " \\item $(x \\secondpattern y) \\in \\patternkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ] + , \case + problem@(Parse.MultipleNewSyntaxPatternsWithoutPragma + location + patterns) -> do + assertEqual + "first new pattern location" + 4 + (locLine location) + assertEqual + "new pattern count" + 2 + (NonEmpty.length patterns) + assertBool + "accurate multiple-pattern message" + ("several new eligible patterns that V1 cannot select between" + `List.isInfixOf` show problem) + assertBool + "message requires an unambiguous declaration" + ("make the declaration unambiguous" + `List.isInfixOf` show problem) + problem -> + unexpected "multiple unannotated patterns" problem + ) + , ( "fixed" + , unlines + [ "\\begin{abbreviation}\\label{local_addition}" + , " %! infixl 1" + , " $x + y = x$." + , "\\end{abbreviation}" + ] + , \case + Parse.SyntaxPragmaOnFixedReuse{} -> + pure () + problem -> + unexpected "fixed-base pragma" problem + ) + ] + + unexpected expected problem = + assertFailure + ("expected " <> expected <> ", got " <> show problem) + +rejectsFixedBaseCategoryMismatch :: Assertion +rejectsFixedBaseCategoryMismatch = + withTemporaryDirectory "felix-source-fixed-category" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\begin{definition}\\label{local_add_relation}" + , " $x + y$ iff $x = y$." + , "\\end{definition}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + assertEqual + "fixed collision pattern" + (Raw.HoleCons + (Raw.TokenCons + (Raw.Symbol "+") + (Raw.HoleCons Raw.End))) + (Parse.lexiconCollisionPattern collision) + case toList (Parse.lexiconCollisionOrigins collision) of + [ Parse.FixedLexiconOrigin + Interface.CanonicalExpressionFunction{} + , Parse.SourceLexiconOrigin + Interface.CanonicalRelation{} + source + location + ] -> do + assertEqual + "local collision source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertLocation + "local collision declaration" + "entry.tex" + 1 + location + origins -> + assertFailure + ("expected fixed/source category origins, got " + <> show origins) + +retainsMultiItemSyntaxOccurrences :: Assertion +retainsMultiItemSyntaxOccurrences = + withTemporaryDirectory "felix-source-multi-item-syntax" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\begin{datatype}\\label{multi_item}" + , " Define $\\itemkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $\\itemzero \\in \\itemkind$." + , " \\item $\\itemsucc{x} \\in \\itemkind$ for $x \\in \\itemkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + occurrences = + Parse.parsedModuleSyntaxOccurrences root + summarize occurrence = + case Parse.parsedSyntaxOccurrenceEntry occurrence of + Interface.CanonicalExpressionFunction + _pattern + marker + _fixity -> + Right + ( Parse.parsedSyntaxOccurrenceBlockIndex + occurrence + , locLine + (Parse.parsedSyntaxOccurrenceLocation + occurrence) + , Parse.parsedSyntaxOccurrenceMarker occurrence + , marker + ) + entry -> + Left entry + case traverse summarize occurrences of + Right summaries -> + assertEqual + "block association and scanner order" + [ (0, 2, "multi_item", "multi_item") + , (0, 4, "itemzero", "itemzero") + , (0, 5, "itemsucc", "itemsucc") + ] + summaries + Left entry -> + assertFailure + ("expected an expression occurrence, got " + <> show entry) + case (Parse.parsedModuleBlocks root, occurrences) of + ( Raw.BlockData _location _title blockMarker _datatype : _ + , firstOccurrence : _ + ) -> + assertEqual + "first occurrence is the declaration-head anchor" + blockMarker + (Parse.parsedSyntaxOccurrenceMarker firstOccurrence) + _ -> + assertFailure "expected a datatype block and its occurrences" + +propagatesImportedSyntax :: Assertion +propagatesImportedSyntax = + withTemporaryDirectory "felix-source-syntax-diamond" \temp -> do + writeFile + (temp Posix. "base.tex") + (syntaxFunctionDefinition + "star" + "star" + (Just "%! infixl 3")) + writeFile + (temp Posix. "left.tex") + ("\\import{base.tex}\n" + <> syntaxFunctionDefinition + "star" + "star" + Nothing) + writeTheory + (temp Posix. "right.tex") + ["base.tex"] + "right" + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\import{left.tex}" + , "\\import{right.tex}" + ] + <> axiomBlock + "imported_use" + "a\\star b\\star c = a") + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + baseModule <- findParsedModule "base.tex" workspace + leftModule <- findParsedModule "left.tex" workspace + rightModule <- findParsedModule "right.tex" workspace + let root = + Parse.parsedWorkspaceRootModule workspace + interface = + Parse.parsedModuleSyntaxInterface + localEntries parsed = + Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (interface parsed)) + assertEqual "base exports one syntax entry" + 1 + (length (localEntries baseModule)) + assertEqual "imported reuse emits no local entry" + [] + (localEntries leftModule) + assertEqual "imported reuse retains its occurrence" + 1 + (length + (Parse.parsedModuleSyntaxOccurrences leftModule)) + assertEqual "empty diamond branch has no occurrence" + [] + (Parse.parsedModuleSyntaxOccurrences rightModule) + assertEqual "equal diamond interfaces" + (Interface.moduleSyntaxAssertedId + (interface leftModule)) + (Interface.moduleSyntaxAssertedId + (interface rightModule)) + assertEqual "root coalesces equal direct interfaces" + 1 + (length + (Interface.moduleSyntaxDirectInputs + (interface root))) + case Parse.parsedModuleBlocks root of + [block] -> + assertAxiomLeftShape + "imported left associativity" + "star(star(a,b),c)" + block + blocks -> + assertFailure + ("expected one imported-syntax axiom, got " + <> show blocks) + writeFile + (temp Posix. "left.tex") + ("\\import{base.tex}\n" + <> syntaxFunctionDefinition + "star" + "star" + (Just "%! infixl 3")) + reuseGraph <- buildSearchedGraph temp "left.tex" + reuseResult <- + Parse.parseResolvedSourceGraph reuseGraph + case reuseResult of + Left + (Parse.SourceSyntaxDeclarationError + _source + Parse.SyntaxPragmaOnImportedReuse{}) -> + pure () + Left err -> + assertFailure + ("expected imported-reuse pragma rejection, got " + <> show err) + Right reused -> + assertFailure + ("expected imported-reuse pragma rejection, got " + <> show reused) + +rejectsUnequalImportedSyntax :: Assertion +rejectsUnequalImportedSyntax = + forM_ cases \(description, leftDefinition, rightDefinition) -> + withTemporaryDirectory + ("felix-source-imported-collision-" <> description) + \temp -> do + writeFile + (temp Posix. "a.tex") + leftDefinition + writeFile + (temp Posix. "b.tex") + rightDefinition + writeTheory + (temp Posix. "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + (firstLocation, secondLocation) <- + expectTwoCollisionLocations collision + assertLocation + "first imported declaration" + "a.tex" + 1 + firstLocation + assertLocation + "second imported declaration" + "b.tex" + 1 + secondLocation + where + cases = + [ ( "marker" + , syntaxFunctionDefinition + "clash_left" + "clash" + (Just "%! infixl 2") + , syntaxFunctionDefinition + "clash_right" + "clash" + (Just "%! infixl 2") + ) + , ( "fixity" + , syntaxFunctionDefinition + "clash" + "clash" + (Just "%! infixl 2") + , syntaxFunctionDefinition + "clash" + "clash" + (Just "%! infixr 2") + ) + ] + +distinguishesPhysicalSourceLocations :: Assertion +distinguishesPhysicalSourceLocations = + withTemporaryDirectory "felix-source-location-identity" \temp -> do + let projectRoot = temp Posix. "project" + libraryRoot = temp Posix. "library" + projectEntry = projectRoot Posix. "entry.tex" + libraryEntry = libraryRoot Posix. "entry.tex" + Directory.createDirectory projectRoot + Directory.createDirectory libraryRoot + writeFile projectEntry + ("\\import{entry.tex}\n" + <> adjectiveDefinition "project_adjective") + writeNounDefinition libraryEntry "library_noun" + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "library", libraryRoot) + , (sourceMountId "project", projectRoot) + ] + request <- expectRight =<< existingRoot projectEntry + graph <- expectRight =<< buildResolvedSourceGraph mounts request + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + assertEqual "normalized cross-category pattern" + (Raw.TokenCons (Raw.Word "special") Raw.End) + (Parse.lexiconCollisionPattern collision) + (libraryLocation, projectLocation) <- + expectTwoCollisionLocations collision + assertEqual "accepted display path" + "entry.tex" + (locFile libraryLocation) + assertEqual "accepted declaration line" + 1 + (locLine libraryLocation) + assertEqual "colliding display path" + "entry.tex" + (locFile projectLocation) + assertEqual "colliding declaration line" + 2 + (locLine projectLocation) + canonicalProject <- Directory.canonicalizePath projectEntry + canonicalLibrary <- Directory.canonicalizePath libraryEntry + let rendered = show collision + quotedLibrary = show canonicalLibrary + quotedProject = show canonicalProject + assertBool "rendered error includes accepted canonical path" + (quotedLibrary `List.isInfixOf` rendered) + assertBool "rendered error includes colliding canonical path" + (quotedProject `List.isInfixOf` rendered) + assertBool "canonical locations render in declaration order" + (substringIndex quotedLibrary rendered + < substringIndex quotedProject rendered) + +retainsWorkspaceLocationDisplayPath :: Assertion +retainsWorkspaceLocationDisplayPath = + withTemporaryDirectory "felix-source-location-display" \temp -> do + let nested = temp Posix. "nested" + entry = nested Posix. "entry.tex" + Directory.createDirectory nested + writeTheory entry [] "entry" + outerMounts <- oneMount "project" temp + outerRequest <- expectRight (searchedRoot "nested/entry.tex") + outerGraph <- expectRight =<< + buildResolvedSourceGraph outerMounts outerRequest + outerWorkspace <- expectRight =<< + Parse.parseResolvedSourceGraph outerGraph + innerMounts <- oneMount "library" nested + innerRequest <- expectRight (searchedRoot "entry.tex") + innerGraph <- expectRight =<< + buildResolvedSourceGraph innerMounts innerRequest + innerWorkspace <- expectRight =<< + Parse.parseResolvedSourceGraph innerGraph + let outerLocation = + onlyAxiomLocation + (Parse.parsedWorkspaceRootModule outerWorkspace) + innerLocation = + onlyAxiomLocation + (Parse.parsedWorkspaceRootModule innerWorkspace) + assertEqual "outer-mount display path" + "nested/entry.tex" + (locFile outerLocation) + assertEqual "more-specific-mount display path" + "entry.tex" + (locFile innerLocation) + outerFileId <- expectJust "outer workspace file id" + (locFileId outerLocation) + innerFileId <- expectJust "inner workspace file id" + (locFileId innerLocation) + assertBool "distinct display registrations use distinct file ids" + (outerFileId /= innerFileId) + canonicalEntry <- Directory.canonicalizePath entry + assertEqual "outer physical location key" + (Just canonicalEntry) + (lookupFileIdentityPath outerFileId) + assertEqual "inner physical location key" + (Just canonicalEntry) + (lookupFileIdentityPath innerFileId) + +reportsImportedScannerErrorFirst :: Assertion +reportsImportedScannerErrorFirst = + withTemporaryDirectory "felix-source-lexer-error-order" \temp -> do + let scannerFailure = unlines + [ "\\begin{abbreviation}\\label{malformed_function}" + , " $x = \\emptyset$." + , "\\end{abbreviation}" + ] + tokenizerFailure = unlines + [ "\\begin{axiom}" + , "#" + , "\\end{axiom}" + ] + writeFile + (temp Posix. "imported.tex") + scannerFailure + writeFile + (temp Posix. "entry.tex") + ("\\import{imported.tex}\n" <> tokenizerFailure) + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left + (Parse.SourceParseError + source + (Parse.LexicalScanFailure + Adapt.InvalidFunctionPattern{})) -> + assertEqual + "dependency scanner error" + "imported.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + Left err -> + assertFailure + ("expected imported scanner error, got " <> show err) + Right workspace -> + assertFailure + ("expected imported scanner error, got " + <> show workspace) + +reportsMalformedLexicalDeclaration :: Assertion +reportsMalformedLexicalDeclaration = + withTemporaryDirectory "felix-source-malformed-lexical" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\begin{abbreviation}\\label{malformed_function}" + , " $x = \\emptyset$." + , "\\end{abbreviation}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + void (evaluate (length (show result))) + case result of + Left + (Parse.SourceParseError + source + (Parse.LexicalScanFailure + (Adapt.InvalidFunctionPattern + location + Adapt.FunctionPatternBareVariable))) -> do + assertEqual "malformed source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertLocation + "malformed declaration" + "entry.tex" + 1 + location + Left err -> + assertFailure + ("expected typed lexical scan failure, got " <> show err) + Right workspace -> + assertFailure + ("expected typed lexical scan failure, got " + <> show workspace) + +rejectsMalformedInductivePattern :: Assertion +rejectsMalformedInductivePattern = + case runLexer (FileId 0) "inductive.tex" source of + Left err -> + assertFailure ("could not tokenize fixture: " <> show err) + Right (_imports, [chunk]) -> + case Adapt.scanChunk chunk of + Left + (Adapt.InvalidFunctionPattern + _location + Adapt.FunctionPatternBareVariable) -> + pure () + Left err -> + assertFailure + ("expected bare-variable scan failure, got " + <> show err) + Right scans -> + assertFailure + ("expected bare-variable scan failure, got " + <> show scans) + Right (_imports, chunks) -> + assertFailure + ("expected one lexical chunk, got " <> show (length chunks)) + where + source = + Text.pack + (unlines + [ "\\begin{inductive}\\label{malformed_inductive}" + , " Define $x\\subseteq\\pow{x}$ inductively." + , "\\end{inductive}" + ]) + +acceptsAdjectiveSignature :: Assertion +acceptsAdjectiveSignature = + withTemporaryDirectory "felix-source-signature-adjective" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\begin{signature}\\label{reflexive_signature}" + , " Suppose $A$ is a set." + , " Then $x$ can be reflexive." + , "\\end{signature}" + , "\\begin{axiom}\\label{reflexive_use}" + , " $x$ is reflexive." + , "\\end{axiom}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let blocks = Parse.importedBeforeImporterBlocks workspace + case blocks of + [ Raw.BlockSig + _signatureLocation + _signatureTitle + _signatureMarker + [_signatureAssumption] + (Raw.SignatureAdj + _variable + (Raw.Adj _adjectiveLocation declaredAdjective [])) + , Raw.BlockAxiom{} + ] -> do + assertEqual + "signature marker enters the lexicon" + "reflexive_signature" + (Raw.lexicalItemMarker declaredAdjective) + _ -> + assertFailure + ("unexpected adjective-signature blocks: " <> show blocks) + +rejectsMalformedSignatureHead :: Assertion +rejectsMalformedSignatureHead = do + case runLexer + (FileId 49) + "malformed-signature.tex" + (Text.unlines + [ "\\begin{signature}\\label{bad_signature}" + , " $x$ can be." + , "\\end{signature}" + ]) of + Left err -> + assertFailure ("unexpected token error: " <> show err) + Right (_imports, [chunk]) -> + case Adapt.scanChunk chunk of + Left + (Adapt.InvalidFunctionPattern + location + Adapt.FunctionPatternBareVariable) -> do + assertEqual "error line" 1 (locLine location) + assertEqual "error column" 1 (locColumn location) + Left err -> + assertFailure + ("expected malformed signature error, got " <> show err) + Right scans -> + assertFailure + ("expected malformed signature rejection, got " + <> show scans) + Right (_imports, chunks) -> + assertFailure + ("expected one malformed signature chunk, got " + <> show (length chunks)) + +reportsSameSourceLexiconCollision :: Assertion +reportsSameSourceLexiconCollision = + withTemporaryDirectory "felix-source-local-lexicon-collision" \temp -> do + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\begin{struct}\\label{duplicate_operations}" + , " A \\duplicateop $X$ is equipped with" + , " \\begin{enumerate}" + , " \\item $\\duplicateop$" + , " \\end{enumerate}" + , "\\end{struct}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + (firstLocation, secondLocation) <- + expectTwoCollisionLocations collision + assertEqual "first declaration file" + "entry.tex" + (locFile firstLocation) + assertEqual "first declaration line" 1 (locLine firstLocation) + assertEqual "colliding declaration file" + "entry.tex" + (locFile secondLocation) + assertEqual "colliding declaration line" 4 (locLine secondLocation) + assertBool "declarations have distinct locations" + (firstLocation /= secondLocation) + +acceptsBuiltinSourceDeclaration :: Assertion +acceptsBuiltinSourceDeclaration = + withTemporaryDirectory "felix-source-builtin-declaration" \temp -> do + writeBuiltinZeroDefinition + (temp Posix. "entry.tex") + "source_zero" + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + assertEqual + "fixed reuse emits no local syntax" + [] + (Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface root))) + case Parse.parsedModuleBlocks root of + [Raw.BlockAbbr + _location + _title + blockMarker + (Raw.AbbreviationEq + (Raw.SymbolPattern + (Raw.MixfixItem + _pattern + symbolMarker + _associativity) + []) + _expression)] -> do + assertEqual + "declaration label remains independent" + "source_zero" + blockMarker + assertEqual + "built-in marker remains authoritative" + "zero" + symbolMarker + case Parse.parsedModuleSyntaxOccurrences root of + [occurrence] -> + case Parse.parsedSyntaxOccurrenceEntry occurrence of + Interface.CanonicalExpressionFunction + _pattern + occurrenceMarker + _fixity -> do + assertEqual + "occurrence retains source marker" + "source_zero" + (Parse.parsedSyntaxOccurrenceMarker + occurrence) + assertEqual + "occurrence uses fixed marker" + "zero" + occurrenceMarker + fileId <- expectJust + "fixed occurrence file id" + (locFileId + (Parse.parsedSyntaxOccurrenceLocation + occurrence)) + decoded <- expectRight + (Parsed.decodeCanonicalParsedPayload + fileId + (Parse.parsedModulePayload root)) + case Parsed.decodedParsedOccurrences decoded of + [ ( _blockIndex + , _location + , storedMarker + , Interface.CanonicalExpressionFunction + _storedPattern + storedEntryMarker + _storedFixity + ) + ] -> do + assertEqual + "payload source marker" + "source_zero" + storedMarker + assertEqual + "payload authoritative marker" + "zero" + storedEntryMarker + stored -> + assertFailure + ("unexpected decoded fixed occurrence: " + <> show stored) + entry -> + assertFailure + ("unexpected fixed occurrence: " + <> show entry) + occurrences -> + assertFailure + ("unexpected fixed occurrences: " + <> show occurrences) + blocks -> + assertFailure + ("unexpected built-in declaration parse: " + <> show blocks) + +acceptsBuiltinPrefixPredicateDeclaration :: Assertion +acceptsBuiltinPrefixPredicateDeclaration = + withTemporaryDirectory "felix-source-builtin-prefix" \temp -> do + writeBuiltinCongDefinition + (temp Posix. "entry.tex") + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + case Parse.parsedModuleBlocks + (Parse.parsedWorkspaceRootModule workspace) of + [Raw.BlockDefn + _location + _title + _blockMarker + (Raw.Defn + _assumptions + (Raw.DefnSymbolicPredicate + predicate + predicateMarker + _variables) + _statement)] -> do + assertEqual "built-in prefix predicate" + (Raw.PrefixPredicate "Cong" 4) + predicate + assertEqual + "built-in prefix marker remains authoritative" + "cong" + predicateMarker + blocks -> + assertFailure + ("unexpected built-in prefix declaration parse: " + <> show blocks) + +avoidsAliasImportLexiconCollision :: Assertion +avoidsAliasImportLexiconCollision = + withTemporaryDirectory "felix-source-alias-lexicon" \temp -> do + let shared = temp Posix. "shared.tex" + alias = temp Posix. "alias.tex" + writeAdjectiveDefinition shared "shared_special" + Directory.createFileLink shared alias + writeFile + (temp Posix. "entry.tex") + (unlines + [ "\\import{shared.tex}" + , "\\import{shared.tex}" + , "\\import{alias.tex}" + , "\\begin{axiom}\\label{root}" + , " $x$ is special." + , "\\end{axiom}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + assertEqual "canonical source is parsed once" + ["shared.tex", "entry.tex"] + (toList + ( safeRelativePathFilePath + . resolvedSourceRelativePath + . Parse.parsedModuleResolved + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace + )) + +parsesWithoutRereading :: Assertion +parsesWithoutRereading = + withTemporaryDirectory "felix-source-no-reread" \temp -> do + let shared = temp Posix. "shared.tex" + entry = temp Posix. "entry.tex" + writeTheory shared [] "shared" + writeTheory entry ["shared.tex"] "entry" + graph <- buildSearchedGraph temp "entry.tex" + Directory.removeFile entry + Directory.removeFile shared + firstWorkspace <- expectRight =<< Parse.parseResolvedSourceGraph graph + secondWorkspace <- expectRight =<< Parse.parseResolvedSourceGraph graph + assertEqual "first flat projection" 2 + (length (Parse.importedBeforeImporterBlocks firstWorkspace)) + assertEqual "repeated downstream projection" 2 + (length (Parse.importedBeforeImporterBlocks secondWorkspace)) + +returnsSourceParseFailures :: Assertion +returnsSourceParseFailures = + withTemporaryDirectory "felix-source-parse-error" \temp -> do + writeFile + (temp Posix. "entry.tex") + (theoryBlock "accepted" + <> "\\begin{axiom}\\label{late_failure}\n") + graph <- buildSearchedGraph temp "entry.tex" + emittedRef <- newIORef [] + result <- + Parse.parseResolvedSourceGraphWith graph + (\_source block -> + case block of + Raw.BlockAxiom _location _title marker _axiom -> + modifyIORef' emittedRef (marker :) + _ -> + assertFailure + ("unexpected emitted block: " <> show block)) + case result of + Left (Parse.SourceParseError source _err) -> do + assertEqual "failed source" "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + emitted <- reverse <$> readIORef emittedRef + assertEqual "completed callbacks before later failure" + ["accepted"] + emitted + Left err -> + assertFailure ("expected SourceParseError, got " <> show err) + Right workspace -> + assertFailure ("expected parse failure, got " <> show workspace) + +rejectsGuardedSymbolicDeclarations :: Assertion +rejectsGuardedSymbolicDeclarations = + for_ [("definition", 3 :: Int), ("abbreviation", 2)] + \(kind, failureLine) -> + withTemporaryDirectory + ("felix-guarded-symbolic-" <> kind) + \temp -> do + let relative = "entry.tex" + source = unlines + [ "\\begin{" <> kind <> "}\\label{guarded_symbolic}" + , " Suppose $\\top$." + , " $\\guardedsymbolic{X} = X$." + , "\\end{" <> kind <> "}" + ] + writeFile (temp Posix. relative) source + graph <- buildSearchedGraph temp relative + emittedRef <- newIORef ([] :: [Raw.Block]) + result <- + Parse.parseResolvedSourceGraphWith graph + (\_source block -> modifyIORef' emittedRef (block :)) + case result of + Left (Parse.SourceParseError failed parseFailure) -> do + assertEqual (kind <> " source") relative + (safeRelativePathFilePath + (resolvedSourceRelativePath failed)) + assertBool + (kind <> " parse failure retains a located source position: " + <> show parseFailure) + (("entry.tex " <> show failureLine <> ":") + `List.isInfixOf` show parseFailure) + assertEqual + (kind <> " publishes no completed source block") + [] + =<< readIORef emittedRef + Left failure -> + assertFailure + ("expected guarded-symbolic parse failure, got " + <> show failure) + Right workspace -> + assertFailure + ("guarded symbolic " <> kind + <> " was silently accepted: " <> show workspace) + +buildSearchedGraph :: FilePath -> FilePath -> IO ResolvedSourceGraph +buildSearchedGraph root path = do + mounts <- oneMount "project" root + request <- expectRight (searchedRoot path) + expectRight =<< buildResolvedSourceGraph mounts request + +sourceGraphOrderPaths :: ResolvedSourceGraph -> IO [FilePath] +sourceGraphOrderPaths graph = + pure + [ safeRelativePathFilePath + (resolvedSourceRelativePath (sourceNodeResolved node)) + | node <- toList (sourceGraphImportedBeforeImporter graph) + ] + +sourceNodeCanonicalPathForTest :: SourceNode -> CanonicalPath +sourceNodeCanonicalPathForTest = + resolvedSourceCanonicalPath . sourceNodeResolved + +onlyAxiomLocation :: Parse.ParsedModule -> Location +onlyAxiomLocation node = + case Parse.parsedModuleBlocks node of + [Raw.BlockAxiom location _title _marker _axiom] -> + location + blocks -> + error ("expected one axiom block, got " <> show blocks) + +syntaxFunctionDefinition + :: String + -> String + -> Maybe String + -> String +syntaxFunctionDefinition marker command pragma = + unlines + ( [ "\\begin{abbreviation}\\label{" <> marker <> "}" + ] + <> maybe [] (\line -> [" " <> line]) pragma + <> [ " $x\\" <> command <> " y = x$." + , "\\end{abbreviation}" + ] + ) + +axiomBlock :: String -> String -> String +axiomBlock marker statement = + unlines + [ "\\begin{axiom}\\label{" <> marker <> "}" + , " $" <> statement <> "$." + , "\\end{axiom}" + ] + +assertExpressionFixity + :: Text + -> Raw.Associativity + -> Word8 + -> [Interface.CanonicalLexicalEntry] + -> Assertion +assertExpressionFixity marker associativity level entries = + case + [ fixity + | Interface.CanonicalExpressionFunction + _pattern + (Raw.Marker candidate) + fixity <- + entries + , candidate == marker + ] of + [Interface.Fixity actualAssociativity actualLevel] -> do + assertEqual + (Text.unpack marker <> " associativity") + associativity + actualAssociativity + assertEqual + (Text.unpack marker <> " level") + level + (Interface.mixfixLevelValue actualLevel) + actual -> + assertFailure + ("expected one fixity for " + <> Text.unpack marker + <> ", got " + <> show actual) + +assertAxiomLeftShape + :: String + -> String + -> Raw.Block + -> Assertion +assertAxiomLeftShape description expected block = + case block of + Raw.BlockAxiom + _location + _title + _marker + (Raw.Axiom + _assumptions + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (expression :| []) + _sign + _relation + _right)))) -> + assertEqual + description + expected + (expressionShape expression) + _ -> + assertFailure + ("expected an axiom with one left expression, got " + <> show block) + +expressionShape :: Raw.Expr -> String +expressionShape = \case + Raw.ExprVar (Raw.NamedVarAt _location name) -> + Text.unpack name + Raw.ExprOp + _location + symbol + arguments -> + let Raw.Marker marker = + Raw.mixfixMarker symbol + in + Text.unpack marker + <> "(" + <> List.intercalate "," + (expressionShape <$> arguments) + <> ")" + expression -> + show expression + +findParsedModule + :: FilePath + -> Parse.ParsedSourceWorkspace + -> IO Parse.ParsedModule +findParsedModule relative workspace = + case List.find hasPath + (Parse.parsedWorkspaceModules workspace) of + Just parsed -> + pure parsed + Nothing -> + assertFailure + ("could not find parsed module " <> relative) + where + hasPath parsed = + safeRelativePathFilePath + (resolvedSourceRelativePath + (Parse.parsedModuleResolved parsed)) + == relative + +writeAdjectiveDefinition :: FilePath -> String -> IO () +writeAdjectiveDefinition path marker = + writeFile path (adjectiveDefinition marker) + +adjectiveDefinition :: String -> String +adjectiveDefinition marker = + unlines + [ "\\begin{definition}\\label{" <> marker <> "}" + , " $x$ is special iff $x = x$." + , "\\end{definition}" + ] + +writeNounDefinition :: FilePath -> String -> IO () +writeNounDefinition path marker = + writeFile path + (unlines + [ "\\begin{definition}\\label{" <> marker <> "}" + , " $x$ is a special iff $x = x$." + , "\\end{definition}" + ]) + +writeBuiltinZeroDefinition :: FilePath -> String -> IO () +writeBuiltinZeroDefinition path marker = + writeFile path (builtinZeroDefinition marker) + +builtinZeroDefinition :: String -> String +builtinZeroDefinition marker = + unlines + [ "\\begin{abbreviation}\\label{" <> marker <> "}" + , " $\\zero = \\emptyset$." + , "\\end{abbreviation}" + ] + +writeBuiltinCongDefinition :: FilePath -> IO () +writeBuiltinCongDefinition path = + writeFile path + (unlines + [ "\\begin{definition}\\label{source_cong}" + , " $\\Cong{x}{y}{z}{w}$ iff $x = x$." + , "\\end{definition}" + ]) + +writeTheory :: FilePath -> [FilePath] -> String -> IO () +writeTheory path imports label = + writeFile path + (unlines + (["\\import{" <> imported <> "}" | imported <- imports] + <> [theoryBlock label])) + +theoryBlock :: String -> String +theoryBlock label = + unlines + [ "\\begin{axiom}\\label{" <> label <> "}" + , " $x = x$." + , "\\end{axiom}" + ] + +oneMount :: Text -> FilePath -> IO SourceMounts +oneMount ident root = + expectRight =<< prepareSourceMounts [(sourceMountId ident, root)] + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +assertRight :: (Show e, HasCallStack) => Either e a -> Assertion +assertRight = void . expectRight + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +expectJust :: HasCallStack => String -> Maybe a -> IO a +expectJust description = \case + Nothing -> + assertFailure ("expected " <> description) + Just value -> + pure value + +expectLexiconCollision + :: Either Parse.ParseWorkspaceError a + -> IO Parse.LexiconCollision +expectLexiconCollision = \case + Left (Parse.SourceLexiconCollision collision) -> + pure collision + Left err -> + assertFailure + ("expected SourceLexiconCollision, got " <> show err) + Right _value -> + assertFailure "expected SourceLexiconCollision, got Right" + +expectTwoCollisionLocations + :: Parse.LexiconCollision + -> IO (Location, Location) +expectTwoCollisionLocations collision = + case Parse.lexiconCollisionDeclarations collision of + firstLocation : secondLocation : _ -> + pure (firstLocation, secondLocation) + locations -> + assertFailure + ("expected two source collision locations, got " + <> show locations) + +assertLocation :: String -> FilePath -> Int -> Location -> Assertion +assertLocation description expectedFile expectedLine location = do + assertEqual (description <> " file") + expectedFile + (locFile location) + assertEqual (description <> " line") + expectedLine + (locLine location) + assertEqual (description <> " column") + 1 + (locColumn location) + +substringIndex :: String -> String -> Int +substringIndex needle haystack = + fromMaybe maxBound + (List.findIndex + (List.isPrefixOf needle) + (List.tails haystack)) + +assertLeft :: (Eq e, Eq a, Show e, Show a, HasCallStack) => e -> Either e a -> Assertion +assertLeft expected actual = + assertEqual "expected Left value" (Left expected) actual diff --git a/source/Felix/Test/Unit/Store.hs b/source/Felix/Test/Unit/Store.hs new file mode 100644 index 0000000..423204c --- /dev/null +++ b/source/Felix/Test/Unit/Store.hs @@ -0,0 +1,1675 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Store (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Typed +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec qualified as Cache +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity qualified as Parsed +import Felix.Parsed.Payload qualified as ParsedPayload +import Felix.Source.Content qualified as Content +import Felix.Source +import Felix.Store qualified as Store +import Felix.Provers qualified as Provers +import Felix.Syntax.Interface qualified as Syntax + +import Control.Concurrent (threadDelay) +import Control.Exception qualified as Exception +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.IORef qualified as IORef +import Database.SQLite.Simple qualified as SQLite +import Database.SQLite.Simple.Types (Only(..)) +import System.Directory qualified as Directory +import System.Environment qualified as Environment +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO.Async (concurrently) + + +unitTests :: TestTree +unitTests = + testGroup "SQLite store" + [ testCase "initializes and reopens the current schema" + initializesAndReopensCurrentSchema + , testCase "serializes invocation-local coordinator access" + serializesCoordinatorAccess + , testCase "rejects incompatibility without configuring the store" + rejectsIncompatibilityWithoutConfiguration + , testCase "rejects malformed compatibility metadata" + rejectsMalformedCompatibilityMetadata + , testCase "rejects a compatible incomplete schema" + rejectsCompatibleIncompleteSchema + , testCase "round-trips exact parsed artifacts" + roundTripsExactParsedArtifacts + , testCase "rejects malformed parsed payloads" + rejectsMalformedParsedPayloads + , testCase "rejects disagreeing parsed artifact identities" + rejectsDisagreeingParsedArtifactIdentities + , testCase "rejects malformed typed validation rows" + rejectsMalformedTypedValidationRows + , testCase "publishes a completed prefix before readiness" + publishesCompletedPrefixBeforeReadiness + , testCase "installs a sealed producer for a cached importer" + installsSealedProducerForCachedImporter + , testCase "validates exact cached installation inputs" + validatesExactCachedInstallationInputs + , testCase "rejects invalid cached root authority and closure" + rejectsInvalidCachedRootAuthorityAndClosure + , testCase "rejects disagreeing module artifact columns" + rejectsDisagreeingModuleArtifactColumns + , testCase "validates shared closures once per invocation" + validatesSharedClosuresOncePerInvocation + , testCase "rolls back a failed readiness transaction" + rollsBackFailedReadiness + , testCase "rolls back an unequal duplicate batch" + rollsBackUnequalDuplicateBatch + , testCase "rejects malformed canonical payloads" + rejectsMalformedCanonicalPayloads + , testCase "plans default and explicit persistent stores" + plansPersistentStores + , testCase "cleans fresh stores on return and exceptions" + cleansFreshStores + , testCase "does not fall back after fatal startup" + doesNotFallBackAfterFatalStartup + ] + +serializesCoordinatorAccess :: Assertion +serializesCoordinatorAccess = do + coordinator <- Store.newStoreCoordinator + active <- IORef.newIORef (0 :: Int) + maximumActive <- IORef.newIORef (0 :: Int) + let operation = + Store.withStoreCoordinator coordinator + (Exception.bracket_ + (IORef.atomicModifyIORef' active + (\current -> + let next = current + 1 + in (next, ()))) + (IORef.atomicModifyIORef' active + (\current -> (current - 1, ()))) + (do + current <- IORef.readIORef active + IORef.atomicModifyIORef' maximumActive + (\observed -> (max current observed, ())) + threadDelay 50000)) + void (concurrently operation operation) + IORef.readIORef maximumActive >>= assertEqual "maximum owner count" 1 + +roundTripsExactParsedArtifacts :: Assertion +roundTripsExactParsedArtifacts = + withStoreFixture "felix-store-parsed" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, unequal) <- makeParsedArtifacts + assertEqual "initial exact lookup misses" (Right Nothing) + =<< Store.loadParsedArtifact store key + assertEqual "published parsed artifact" + (Right artifact) + =<< Store.writeParsedArtifact store key artifact + assertEqual "exact parsed round trip" + (Right (Just artifact)) + =<< Store.loadParsedArtifact store key + assertEqual "equal publication is idempotent" + (Right artifact) + =<< Store.writeParsedArtifact store key artifact + Store.writeParsedArtifact store key unequal >>= \case + Left Store.StoreRowPayloadMismatch{} -> + pure () + other -> + assertFailure + ("unexpected unequal parsed publication: " <> show other) + Store.closeStore store + +rejectsMalformedParsedPayloads :: Assertion +rejectsMalformedParsedPayloads = do + check "malformed" (ByteString.singleton 0xff) + check "noncanonical" . (<> ByteString.singleton 0x00) + =<< parsedPayloadBytes + where + check label corrupted = + withStoreFixture ("felix-store-parsed-" <> label) + \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, _unequal) <- makeParsedArtifacts + _ <- expectRightIO + (Store.writeParsedArtifact store key artifact) + Store.closeStore store + updateParsedPayload path key corrupted + (_reopened, current) <- expectOpen path theory + Store.loadParsedArtifact current key >>= \case + Left Store.StoreRowDecodeFailure{} -> + pure () + other -> + assertFailure + ("unexpected " <> label + <> " parsed row result: " <> show other) + Store.closeStore current + + parsedPayloadBytes = do + (_key, artifact, _unequal) <- makeParsedArtifacts + pure + (ParsedPayload.canonicalParsedPayloadBytes + (ParsedPayload.parsedArtifactPayload artifact)) + +rejectsDisagreeingParsedArtifactIdentities :: Assertion +rejectsDisagreeingParsedArtifactIdentities = + withStoreFixture "felix-store-parsed-id" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, _unequal) <- makeParsedArtifacts + _ <- expectRightIO (Store.writeParsedArtifact store key artifact) + Store.closeStore store + connection <- SQLite.open path + SQLite.execute connection + "UPDATE parsed_artifacts SET parsed_module_id = ? \ + \WHERE parsed_module_key = ?" + ( ByteString.replicate 32 0 + , Cache.cacheDigestBytes (Parsed.parsedModuleKeyDigest key) + ) + SQLite.close connection + (_reopened, current) <- expectOpen path theory + Store.loadParsedArtifact current key >>= \case + Left Store.StoreParsedArtifactIdMismatch -> + pure () + other -> + assertFailure + ("unexpected parsed identity result: " <> show other) + Store.closeStore current + +makeParsedArtifacts + :: IO + ( Parsed.ParsedModuleKey + , ParsedPayload.ParsedArtifact + , ParsedPayload.ParsedArtifact + ) +makeParsedArtifacts = do + key <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "parsed-source") + Syntax.baseSyntaxInterfaceId + []) + emptyDelta <- expectRight (Syntax.canonicalSyntaxDelta []) + emptySyntax <- expectRight (Syntax.moduleSyntaxInterface [] emptyDelta) + otherDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "other"]) + otherSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] otherDelta) + let payload syntax = + ParsedPayload.canonicalParsedPayload + [] [] [] (Syntax.moduleSyntaxAssertedId syntax) + pure + ( key + , ParsedPayload.parsedArtifact key (payload emptySyntax) + , ParsedPayload.parsedArtifact key (payload otherSyntax) + ) + +updateParsedPayload + :: FilePath + -> Parsed.ParsedModuleKey + -> ByteString.ByteString + -> IO () +updateParsedPayload path key payload = do + connection <- SQLite.open path + SQLite.execute connection + "UPDATE parsed_artifacts SET payload = ? \ + \WHERE parsed_module_key = ?" + ( payload + , Cache.cacheDigestBytes (Parsed.parsedModuleKeyDigest key) + ) + SQLite.close connection + +rejectsMalformedTypedValidationRows :: Assertion +rejectsMalformedTypedValidationRows = + withStoreFixture "felix-store-malformed-typed" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, _syntax, _semantic, _key, _artifact, _proposition) <- + makeCommittedModule theory fixture + batch <- case Declaration.pendingModulePrefixBatches prefix of + [one] -> pure one + batches -> + assertFailure + ("unexpected prefix batch count: " <> show (length batches)) + >> fail "unreachable" + proof <- case Declaration.committedBatchProofValidations batch of + [one] -> pure one + proofs -> + assertFailure + ("unexpected proof validation count: " <> show (length proofs)) + >> fail "unreachable" + let key = Semantic.proofValidationRecordKey proof + certificate = Semantic.proofValidationRecordCertificate proof + theorem = Identity.theoremId + (Authority.factAuthorityTheorem + (Authority.validationTarget certificate)) + wrongKey = Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "other-row") + (Declaration.committedBatchPreviousPrefix batch) + wrongProof = + Semantic.proofValidationRecord wrongKey certificate + expectRightIO (Store.writePendingModulePrefix store prefix) + Store.closeStore store + connection <- SQLite.open path + SQLite.execute connection + "UPDATE proof_validations SET payload = ? \ + \WHERE validation_key = ?" + ( Cache.encodeCache + (Semantic.putProofValidationRecordCache wrongProof) + , Cache.cacheDigestBytes + (Semantic.proofValidationKeyDigest key) + ) + SQLite.close connection + (_reopened, current) <- expectOpen path theory + Store.loadProofValidation current key >>= \case + Left Store.StoreValidationRecordKeyMismatch{} -> pure () + Left other -> + assertFailure + ("unexpected typed key mismatch: " <> show other) + Right _ -> + assertFailure "typed key mismatch was accepted" + Store.closeStore current + connection' <- SQLite.open path + SQLite.execute connection' + "UPDATE proof_validations SET payload = ? \ + \WHERE validation_key = ?" + ( ByteString.singleton 0xff + , Cache.cacheDigestBytes + (Semantic.proofValidationKeyDigest key) + ) + SQLite.close connection' + (_reopenedMalformed, malformed) <- expectOpen path theory + Store.loadProofValidation malformed key >>= \case + Left Store.StoreRowDecodeFailure{} -> pure () + Left other -> + assertFailure + ("unexpected malformed typed row: " <> show other) + Right _ -> + assertFailure "malformed typed row was accepted" + Store.closeStore malformed + +publishesCompletedPrefixBeforeReadiness :: Assertion +publishesCompletedPrefixBeforeReadiness = + withStoreFixture "felix-store-prefix" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + expectRightIO (Store.writePendingModulePrefix store prefix) + connection <- SQLite.open path + [Only propositionRows] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_propositions \ + \WHERE proposition_id = ?" + (Only + (Cache.encodeCache + (Identity.putPropositionIdCache + (Identity.checkedPropositionId proposition)))) + :: IO [Only Int] + [Only artifactRowsBefore] <- SQLite.query_ connection + "SELECT COUNT(*) FROM module_artifacts" + :: IO [Only Int] + SQLite.close connection + assertEqual "completed prefix proposition is visible" 1 propositionRows + assertEqual "prefix publication does not publish readiness" + 0 artifactRowsBefore + expectRightIO + (Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo store + installation <- expectRightIO + (Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId syntax)) + case installation of + Just loaded -> do + assertEqual "validated semantic interface" semantic + (Store.cachedInstallationSemantic loaded) + assertEqual "validated imported proposition count" 1 + (length (Store.cachedInstallationPropositions loaded)) + Nothing -> + assertFailure "validated module installation was absent" + Store.closeStore store + +installsSealedProducerForCachedImporter :: Assertion +installsSealedProducerForCachedImporter = + withStoreFixture "felix-store-cached-import" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + foundation <- expectRight Foundation.checkedFoundation + (_owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + expectRightIO + (Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo store + installation <- + expectRightIO + (Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId syntax)) + >>= \case + Nothing -> + assertFailure "sealed producer was not loadable" + >> fail "unreachable" + Just loaded -> + pure loaded + cached <- expectRight + (Typed.cachedSealedTypedModule + foundation + [] + installation) + let loadedSemantic = Store.cachedInstallationSemantic installation + fingerprint <- + case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations loadedSemantic) of + [occurrence] -> + pure (Semantic.semanticFactFingerprint occurrence) + occurrences -> + assertFailure + ("unexpected cached producer facts: " + <> show (length occurrences)) + >> fail "unreachable" + namespaceDigest <- expectRight + (hashCanonicalFields + "store-cached-import-consumer" + ["consumer"]) + relative <- expectRight (safeRelativePath "consumer.tex") + let consumerOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "cached importer does not run Vampire")) + result <- + (Declaration.runModuleDriver + foundation + consumerOwner + [Semantic.semanticInterfaceAssertedId loadedSemantic] + resolver + Declaration.FreshValidation + do + Declaration.importSealedModuleDriver + (Typed.sealedTypedModuleEvidence cached) + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "cached-import-consumer") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate do + _ <- Declaration.useAuthorizedFact fingerprint + Declaration.recordOmittedUse + pure batch + :: IO + (Either + Declaration.DriverOpenError + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch))) + case result of + Left failure -> + assertFailure ("cached importer could not open: " <> show failure) + Right (Declaration.DriverSucceeded _ _ _ _closure) -> + pure () + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure ("cached importer failed: " <> show failure) + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("cached importer did not seal: " <> show failure) + Store.closeStore store + +validatesExactCachedInstallationInputs :: Assertion +validatesExactCachedInstallationInputs = + withStoreFixture "felix-store-exact-install" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + _ <- expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + otherDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "other-syntax"]) + otherSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] otherDelta) + wrongSyntaxMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + wrongSyntaxMemo + store + artifactKey + (Syntax.moduleSyntaxAssertedId otherSyntax) + >>= \case + Left Store.StoreModuleArtifactSyntaxMismatch{} -> pure () + _ -> + assertFailure "unexpected syntax-input result" + + parent <- expectRight + (Semantic.semanticInterface preludeModuleName [] []) + mismatched <- expectRight + (Semantic.semanticInterface + owner + [Semantic.semanticInterfaceAssertedId parent] + (Semantic.semanticInterfaceDeclarations semantic)) + mismatchKey <- makeArtifactKey owner theory "direct-mismatch" + let mismatchArtifact = + Semantic.moduleArtifactResult + mismatchKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId mismatched) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [parent, mismatched] + mismatchArtifact + directMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + directMemo + store + mismatchKey + (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreModuleArtifactDirectMismatch{} -> pure () + _ -> + assertFailure "unexpected direct-input result" + Store.closeStore store + +rejectsInvalidCachedRootAuthorityAndClosure :: Assertion +rejectsInvalidCachedRootAuthorityAndClosure = + withStoreFixture "felix-store-invalid-install" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, _prefix, syntax, semantic, _artifactKey, _artifact, proposition) <- + makeCommittedModule theory fixture + otherTheory <- expectRight + (Cache.decodeCache + Identity.getTheoryIdCache + (ByteString.replicate 32 0x5a)) + original <- case Semantic.semanticInterfaceDeclarations semantic of + [delta] -> pure delta + deltas -> + assertFailure + ("unexpected declaration count: " <> show (length deltas)) + >> fail "unreachable" + occurrence <- case Semantic.declarationDeltaFacts original of + [fact] -> pure fact + facts -> + assertFailure + ("unexpected fact count: " <> show (length facts)) + >> fail "unreachable" + let badAuthority = + Authority.factAuthority + (Identity.theoremRef + otherTheory + (Semantic.semanticFactProposition occurrence)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority occurrence)) + badOccurrence = + Semantic.semanticFactOccurrence + (Semantic.semanticFactSlot occurrence) + badAuthority + (Semantic.semanticFactSearchEligibility occurrence) + badDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationDeltaSlot original) + [badOccurrence] + (Semantic.declarationDeltaAliases original) + (Semantic.declarationDeltaObjects original) + (Semantic.declarationDeltaPropositions original) + (Semantic.declarationDeltaEnvironment original)) + badSemantic <- expectRight + (Semantic.semanticInterface owner [] [badDelta]) + badKey <- makeArtifactKey owner theory "bad-authority" + let badArtifact = + Semantic.moduleArtifactResult + badKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId badSemantic) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [badSemantic] + badArtifact + badMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + badMemo store badKey (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreImportedOccurrenceValidationFailure{} -> pure () + _ -> + assertFailure "unexpected root-authority result" + + childKey <- makeArtifactKey owner theory "missing-late-child" + let childArtifact = + Semantic.moduleArtifactResult + childKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [semantic] + childArtifact + connection <- SQLite.open path + SQLite.execute connection + "DELETE FROM canonical_objects WHERE object_id = ?" + (Only + (Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId + (fixtureFirstObject fixture))))) + SQLite.close connection + childMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + childMemo store childKey (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreAssertedChildMissing{} -> pure () + _ -> + assertFailure "unexpected missing-child result" + Store.closeStore store + +rejectsDisagreeingModuleArtifactColumns :: Assertion +rejectsDisagreeingModuleArtifactColumns = + withStoreFixture "felix-store-artifact-columns" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, syntax, semantic, key, artifact, _proposition) <- + makeCommittedModule theory fixture + _ <- expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + connection <- SQLite.open path + SQLite.execute_ connection "PRAGMA foreign_keys = OFF" + SQLite.execute connection + "UPDATE module_artifacts SET syntax_interface_id = ? \ + \WHERE module_artifact_id = ?" + ( ByteString.replicate 32 0x3c + , Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest + (Semantic.moduleArtifactResultId artifact)) + ) + SQLite.close connection + memo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreModuleArtifactColumnsMismatch -> pure () + Left other -> + assertFailure + ("unexpected artifact-column load: " <> show other) + Right _ -> + assertFailure "disagreeing artifact columns were accepted" + Store.writeSealedModule + store prefix [syntax] [semantic] artifact >>= \case + Left Store.StoreRowPayloadMismatch{} -> pure () + other -> + assertFailure + ("unexpected artifact-column rewrite: " <> show other) + Store.closeStore store + +validatesSharedClosuresOncePerInvocation :: Assertion +validatesSharedClosuresOncePerInvocation = + withStoreFixture "felix-store-linear-closure" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let baseObject = fixtureFirstObject fixture + first = transparentSetObject theory baseObject + second = transparentSetObject theory first + third = transparentSetObject theory second + objects = [baseObject, first, second, third] + closure <- expectRight + (Identity.validateObjectClosure theory objects) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal (Identity.assertedObjectId third)) + (Core.CGlobal (Identity.assertedObjectId third)))) + baseOwner <- testModuleName "linear-base.tex" + leftOwner <- testModuleName "linear-left.tex" + rightOwner <- testModuleName "linear-right.tex" + rootOwner <- testModuleName "linear-root.tex" + let theorem = Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + occurrence = Semantic.semanticFactOccurrence + (Semantic.factSlot baseOwner (localFactOrdinal 0)) + (Authority.factAuthority + theorem Authority.cleanAuthoritySafety) + Semantic.SearchEligible + baseDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + baseOwner + (localDeclarationOrdinal 0)) + [occurrence] + [] + (Identity.assertedObjectId <$> objects) + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + baseSemantic <- expectRight + (Semantic.semanticInterface baseOwner [] [baseDelta]) + leftSemantic <- expectRight + (Semantic.semanticInterface + leftOwner + [Semantic.semanticInterfaceAssertedId baseSemantic] + []) + rightSemantic <- expectRight + (Semantic.semanticInterface + rightOwner + [Semantic.semanticInterfaceAssertedId baseSemantic] + []) + rootSemantic <- expectRight + (Semantic.semanticInterface + rootOwner + [ Semantic.semanticInterfaceAssertedId leftSemantic + , Semantic.semanticInterfaceAssertedId rightSemantic + ] + []) + + emptyDelta <- expectRight (Syntax.canonicalSyntaxDelta []) + leftDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "linear-left"]) + rightDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "linear-right"]) + baseSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] emptyDelta) + leftSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId baseSyntax] + leftDelta) + rightSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId baseSyntax] + rightDelta) + rootSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [ Syntax.moduleSyntaxAssertedId leftSyntax + , Syntax.moduleSyntaxAssertedId rightSyntax + ] + emptyDelta) + + rootKey <- makeArtifactKeyWithDirect + rootOwner + theory + [ Semantic.semanticInterfaceAssertedId leftSemantic + , Semantic.semanticInterfaceAssertedId rightSemantic + ] + "linear-root" + leftKey <- makeArtifactKeyWithDirect + leftOwner + theory + [Semantic.semanticInterfaceAssertedId baseSemantic] + "linear-left" + let rootArtifact = Semantic.moduleArtifactResult + rootKey + (Syntax.moduleSyntaxAssertedId rootSyntax) + (Semantic.semanticInterfaceAssertedId rootSemantic) + leftArtifact = Semantic.moduleArtifactResult + leftKey + (Syntax.moduleSyntaxAssertedId leftSyntax) + (Semantic.semanticInterfaceAssertedId leftSemantic) + connection <- SQLite.open path + SQLite.withTransaction connection do + traverse_ (insertRawObject connection) objects + insertRawProposition connection proposition + traverse_ + (insertRawSyntaxInterface connection) + [baseSyntax, leftSyntax, rightSyntax, rootSyntax] + traverse_ + (insertRawSemanticInterface connection) + [baseSemantic, leftSemantic, rightSemantic, rootSemantic] + insertRawModuleArtifact connection rootArtifact + insertRawModuleArtifact connection leftArtifact + SQLite.close connection + + memo <- Store.newStoreMemo store + expectInstallation memo store rootKey rootSyntax + expectInstallation memo store leftKey leftSyntax + expectInstallation memo store rootKey rootSyntax + visits <- Store.storeMemoVisits memo + assertEqual "unique artifact rows" 2 + (Store.storeArtifactRowsDecoded visits) + assertEqual "unique artifact validations" 2 + (Store.storeArtifactsValidated visits) + assertEqual "syntax diamond rows" 4 + (Store.storeSyntaxRowsDecoded visits) + assertEqual "syntax diamond validations" 4 + (Store.storeSyntaxRowsValidated visits) + assertEqual "semantic diamond rows" 4 + (Store.storeSemanticRowsDecoded visits) + assertEqual "semantic diamond validations" 4 + (Store.storeSemanticRowsValidated visits) + assertEqual "transparent-chain rows" 4 + (Store.storeObjectRowsDecoded visits) + assertEqual "transparent-chain validations" 4 + (Store.storeObjectRowsValidated visits) + assertEqual "proposition rows" 1 + (Store.storePropositionRowsDecoded visits) + assertEqual "proposition validations" 1 + (Store.storePropositionRowsValidated visits) + Store.closeStore store + where + expectInstallation memo store key syntax = + Store.loadCachedModuleInstallation + memo store key (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Right (Just _installation) -> pure () + _ -> assertFailure "cached closure installation failed" + +transparentSetObject + :: Identity.TheoryId + -> Identity.AssertedObject + -> Identity.AssertedObject +transparentSetObject theory dependency = + Identity.assertedObject identity content + where + content = Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal (Identity.assertedObjectId dependency)) + identity = Identity.transparentObjectId + theory + Core.TySet + (Core.CGlobal (Identity.assertedObjectId dependency)) + +testModuleName :: FilePath -> IO ModuleName +testModuleName path = do + digest <- expectRight + (hashCanonicalFields + "store-linear-module" + [ByteString.Char8.pack path]) + relative <- expectRight (safeRelativePath path) + pure + (moduleNameFromParts + (sourceNamespaceIdFromDigest digest) + relative) + +makeArtifactKey + :: ModuleName + -> Identity.TheoryId + -> ByteString.ByteString + -> IO Semantic.ModuleArtifactKey +makeArtifactKey owner theory label = do + makeArtifactKeyWithDirect owner theory [] label + +makeArtifactKeyWithDirect + :: ModuleName + -> Identity.TheoryId + -> [Semantic.SemanticInterfaceId] + -> ByteString.ByteString + -> IO Semantic.ModuleArtifactKey +makeArtifactKeyWithDirect owner theory direct label = do + parsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes label) + Syntax.baseSyntaxInterfaceId + []) + expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId parsedKey label) + direct + theory) + +writeRawModuleRows + :: FilePath + -> [Identity.AssertedObject] + -> [Identity.CheckedPropositionContent] + -> Syntax.ModuleSyntaxInterface + -> [Semantic.SemanticInterface] + -> Semantic.ModuleArtifactResult + -> IO () +writeRawModuleRows path objects propositions syntax semantics artifact = do + connection <- SQLite.open path + SQLite.withTransaction connection do + traverse_ (insertRawObject connection) objects + traverse_ (insertRawProposition connection) propositions + insertRawSyntaxInterface connection syntax + traverse_ (insertRawSemanticInterface connection) semantics + insertRawModuleArtifact connection artifact + SQLite.close connection + +insertRawObject :: SQLite.Connection -> Identity.AssertedObject -> IO () +insertRawObject connection object = + SQLite.execute connection + "INSERT OR IGNORE INTO canonical_objects (object_id, payload) \ + \VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId object)) + , Cache.encodeCache + (Identity.putObjectContentCache + (Identity.assertedObjectContent object)) + ) + +insertRawProposition + :: SQLite.Connection + -> Identity.CheckedPropositionContent + -> IO () +insertRawProposition connection proposition = + SQLite.execute connection + "INSERT OR IGNORE INTO canonical_propositions \ + \(proposition_id, payload) VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putPropositionIdCache + (Identity.checkedPropositionId proposition)) + , Cache.encodeCache + (Cache.putCanonicalTermCache + Identity.putObjectIdCache + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition))) + ) + +insertRawSyntaxInterface + :: SQLite.Connection + -> Syntax.ModuleSyntaxInterface + -> IO () +insertRawSyntaxInterface connection interface = + SQLite.execute connection + "INSERT OR IGNORE INTO syntax_interfaces \ + \(syntax_interface_id, payload) VALUES (?, ?)" + ( Cache.cacheDigestBytes + (Syntax.syntaxInterfaceIdDigest + (Syntax.moduleSyntaxAssertedId interface)) + , Cache.encodeCache + (Syntax.putModuleSyntaxInterfaceCache interface) + ) + +insertRawSemanticInterface + :: SQLite.Connection + -> Semantic.SemanticInterface + -> IO () +insertRawSemanticInterface connection interface = + SQLite.execute connection + "INSERT OR IGNORE INTO semantic_interfaces \ + \(semantic_interface_id, payload) VALUES (?, ?)" + ( Cache.cacheDigestBytes + (Semantic.semanticInterfaceIdDigest + (Semantic.semanticInterfaceAssertedId interface)) + , Cache.encodeCache + (Semantic.putSemanticInterfaceCache interface) + ) + +insertRawModuleArtifact + :: SQLite.Connection + -> Semantic.ModuleArtifactResult + -> IO () +insertRawModuleArtifact connection artifact = + SQLite.execute connection + "INSERT OR IGNORE INTO module_artifacts \ + \(module_artifact_id, syntax_interface_id, \ + \semantic_interface_id, payload) VALUES (?, ?, ?, ?)" + ( Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest + (Semantic.moduleArtifactResultId artifact)) + , Cache.cacheDigestBytes + (Syntax.syntaxInterfaceIdDigest + (Semantic.moduleArtifactResultSyntax artifact)) + , Cache.cacheDigestBytes + (Semantic.semanticInterfaceIdDigest + (Semantic.moduleArtifactResultSemantic artifact)) + , Cache.encodeCache + (Semantic.putModuleArtifactResultCache artifact) + ) + +storedPropositionCount + :: FilePath + -> Identity.PropositionId + -> IO Int +storedPropositionCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_propositions \ + \WHERE proposition_id = ?" + (Only + (Cache.encodeCache + (Identity.putPropositionIdCache identity))) + SQLite.close connection + pure rowCount + +storedObjectCount + :: FilePath + -> Identity.ObjectId + -> IO Int +storedObjectCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_objects WHERE object_id = ?" + (Only + (Cache.encodeCache + (Identity.putObjectIdCache identity))) + SQLite.close connection + pure rowCount + +storedArtifactCount + :: FilePath + -> Semantic.ModuleArtifactId + -> IO Int +storedArtifactCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM module_artifacts \ + \WHERE module_artifact_id = ?" + (Only + (Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest identity))) + SQLite.close connection + pure rowCount + +rollsBackFailedReadiness :: Assertion +rollsBackFailedReadiness = + withStoreFixture "felix-store-readiness-rollback" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, prefix, _syntax, semantic, _artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + missingDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "missing-child"]) + missingInterface <- expectRight + (Syntax.moduleSyntaxInterface [] missingDelta) + syntaxDelta <- expectRight + (Syntax.canonicalSyntaxDelta []) + brokenSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId missingInterface] + syntaxDelta) + brokenParsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "rollback-source") + Syntax.baseSyntaxInterfaceId + []) + brokenArtifactKey <- expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId + brokenParsedKey + "rollback-parsed") + [] + theory) + let brokenArtifact = + Semantic.moduleArtifactResult + brokenArtifactKey + (Syntax.moduleSyntaxAssertedId brokenSyntax) + (Semantic.semanticInterfaceAssertedId semantic) + result <- Store.writeSealedModule + store + prefix + [brokenSyntax] + [semantic] + brokenArtifact + case result of + Left Store.StoreAssertedChildMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected readiness failure: " <> show other) + Right _ -> + assertFailure "broken readiness transaction was accepted" + assertEqual "failed readiness did not publish the prefix" 0 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + assertEqual "failed readiness leaves no module root" 0 + =<< storedArtifactCount + path + (Semantic.moduleArtifactResultId artifact) + -- A later failed seal must not erase a prefix published by an + -- earlier successful source prefix flush. + expectRightIO (Store.writePendingModulePrefix store prefix) + assertEqual "successful prefix is visible before retry" 1 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + retry <- Store.writeSealedModule + store + prefix + [brokenSyntax] + [semantic] + brokenArtifact + case retry of + Left Store.StoreAssertedChildMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected retry readiness failure: " <> show other) + Right _ -> + assertFailure "broken readiness retry was accepted" + assertEqual "failed retry retains successful prefix" 1 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + assertEqual "failed retry still leaves no module root" 0 + =<< storedArtifactCount + path + (Semantic.moduleArtifactResultId artifact) + Store.closeStore store +makeCommittedModule + :: Identity.TheoryId + -> StoreFixture + -> IO + ( ModuleName + , Declaration.PendingModulePrefix + , Syntax.ModuleSyntaxInterface + , Semantic.SemanticInterface + , Semantic.ModuleArtifactKey + , Semantic.ModuleArtifactResult + , Identity.CheckedPropositionContent + ) +makeCommittedModule theory fixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields "store-module-test" ["prefix"]) + relative <- expectRight (safeRelativePath "module.tex") + let owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + proposition = fixtureProposition fixture + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "store fixture does not run Vampire")) + driver <- Declaration.runModuleDriver + foundation + owner + [] + resolver + Declaration.FreshValidation + do + (_value, _batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "store-prefix") do + Declaration.addDeclarationObject + (fixtureFirstObject fixture) + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure () + (_value, prefix, semantic) <- + case driver of + Right (Declaration.DriverSucceeded value interface pending _closure) -> + pure (value, pending, interface) + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure + ("unexpected declaration failure: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("unexpected seal failure: " <> show failure) + >> fail "unreachable" + Left failure -> + assertFailure ("unexpected driver-open failure: " <> show failure) + >> fail "unreachable" + delta <- expectRight (Syntax.canonicalSyntaxDelta []) + syntax <- expectRight (Syntax.moduleSyntaxInterface [] delta) + parsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "store-module-source") + Syntax.baseSyntaxInterfaceId + []) + artifactKey <- expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId parsedKey "store-module-parsed") + [] + theory) + let artifact = + Semantic.moduleArtifactResult + artifactKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + pure + ( owner + , prefix + , syntax + , semantic + , artifactKey + , artifact + , proposition + ) + +makePendingPrefix + :: StoreFixture + -> [Identity.AssertedObject] + -> IO Declaration.PendingModulePrefix +makePendingPrefix fixture objects = do + foundation <- expectRight Foundation.checkedFoundation + owner <- testModuleName "rollback-prefix.tex" + let proposition = fixtureProposition fixture + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "store fixture does not run Vampire")) + driver <- Declaration.runModuleDriver + foundation + owner + [] + resolver + Declaration.FreshValidation + do + (_value, _batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "store-rollback") do + traverse_ Declaration.addDeclarationObject objects + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure () + case driver of + Right (Declaration.DriverSucceeded _value _interface prefix _closure) -> + pure prefix + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure + ("unexpected declaration failure: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("unexpected seal failure: " <> show failure) + >> fail "unreachable" + Left failure -> + assertFailure ("unexpected driver-open failure: " <> show failure) + >> fail "unreachable" + +initializesAndReopensCurrentSchema :: Assertion +initializesAndReopensCurrentSchema = + withStoreFixture "felix-store-startup" \path theory _fixture -> do + (startup, store) <- expectOpen path theory + assertEqual "new store status" + Store.InitializedNewStore startup + Store.closeStore store + + (reopened, current) <- expectOpen path theory + assertEqual "current store status" + Store.OpenedCurrentStore reopened + Store.closeStore current + + connection <- SQLite.open path + names <- SQLite.query_ connection + "SELECT name FROM sqlite_master \ + \WHERE type = 'table' AND name NOT LIKE 'sqlite_%' \ + \ORDER BY name" + :: IO [Only Text] + journal <- SQLite.query_ connection + "PRAGMA journal_mode" + :: IO [Only Text] + SQLite.close connection + assertEqual "complete schema table count" 9 (length names) + assertEqual "rollback journal persists" + [Only "delete"] journal + +rejectsIncompatibilityWithoutConfiguration :: Assertion +rejectsIncompatibilityWithoutConfiguration = + withStoreFixture "felix-store-incompatible" \path theory _fixture -> do + connection <- SQLite.open path + _ <- SQLite.query_ connection + "PRAGMA journal_mode = WAL" + :: IO [Only Text] + SQLite.execute_ connection + "CREATE TABLE store_compatibility ( \ + \singleton INTEGER, cache_epoch INTEGER, theory_id BLOB )" + SQLite.execute connection + "INSERT INTO store_compatibility VALUES (1, ?, ?)" + ( 999 :: Int + , Cache.encodeCache (Identity.putTheoryIdCache theory) + ) + SQLite.execute_ connection + "CREATE TABLE untouched (value INTEGER)" + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.IncompatibleStore + Store.StoreCompatibilityMismatch{}) -> + pure () + Left other -> + assertFailure + ("unexpected incompatibility result: " <> show other) + Right (_startup, store) -> do + Store.closeStore store + assertFailure "incompatible store was accepted" + + inspected <- SQLite.open path + names <- SQLite.query_ inspected + "SELECT name FROM sqlite_master \ + \WHERE type = 'table' AND name NOT LIKE 'sqlite_%' \ + \ORDER BY name" + :: IO [Only Text] + journal <- SQLite.query_ inspected + "PRAGMA journal_mode" + :: IO [Only Text] + SQLite.close inspected + assertEqual "startup creates no schema" + [Only "store_compatibility", Only "untouched"] names + assertEqual "startup applies no journal configuration" + [Only "wal"] journal + +rejectsMalformedCompatibilityMetadata :: Assertion +rejectsMalformedCompatibilityMetadata = + withStoreFixture "felix-store-malformed" \path theory _fixture -> do + connection <- SQLite.open path + SQLite.execute_ connection + "CREATE TABLE store_compatibility ( \ + \singleton INTEGER, cache_epoch, theory_id )" + SQLite.execute connection + "INSERT INTO store_compatibility VALUES (1, ?, ?)" + ( "not-an-epoch" :: Text + , Cache.encodeCache (Identity.putTheoryIdCache theory) + ) + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.IncompatibleStore + Store.StoreCompatibilityMalformed{}) -> + pure () + Left other -> + assertFailure + ("unexpected malformed result: " <> show other) + Right (_startup, store) -> do + Store.closeStore store + assertFailure "malformed metadata was accepted" + +rejectsCompatibleIncompleteSchema :: Assertion +rejectsCompatibleIncompleteSchema = + withStoreFixture "felix-store-incomplete" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + Store.closeStore store + connection <- SQLite.open path + SQLite.execute_ connection + "DROP TABLE canonical_propositions" + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.FatalStoreStartup + Store.StoreSchemaIntegrityFailure{}) -> + pure () + Left other -> + assertFailure + ("unexpected incomplete-schema result: " <> show other) + Right (_startup, current) -> do + Store.closeStore current + assertFailure "incomplete current schema was accepted" + +rollsBackUnequalDuplicateBatch :: Assertion +rollsBackUnequalDuplicateBatch = + withStoreFixture "felix-store-rollback" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let first = fixtureFirstObject fixture + second = fixtureSecondObject fixture + prefix <- makePendingPrefix fixture [first, second] + Store.closeStore store + + connection <- SQLite.open path + SQLite.execute connection + "INSERT INTO canonical_objects (object_id, payload) VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId second)) + , Cache.encodeCache + (Identity.putObjectContentCache + (Identity.assertedObjectContent + first)) + ) + SQLite.close connection + + (_reopened, current) <- expectOpen path theory + result <- Store.writePendingModulePrefix current prefix + case result of + Left Store.StoreRowPayloadMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected duplicate result: " <> show other) + Right () -> + assertFailure "unequal duplicate was accepted" + assertEqual "earlier insertion was rolled back" 0 + =<< storedObjectCount path (Identity.assertedObjectId first) + Store.closeStore current + +rejectsMalformedCanonicalPayloads :: Assertion +rejectsMalformedCanonicalPayloads = + withStoreFixture "felix-store-decode" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let object = fixtureFirstObject fixture + (_owner, prefix, syntax, semantic, key, artifact, _proposition) <- + makeCommittedModule theory fixture + expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + Store.closeStore store + + connection <- SQLite.open path + SQLite.execute connection + "UPDATE canonical_objects SET payload = ? \ + \WHERE object_id = ?" + ( ByteString.singleton 0xff + , Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId object)) + ) + SQLite.close connection + + (_reopened, current) <- expectOpen path theory + memo <- Store.newStoreMemo current + result <- Store.loadCachedModuleInstallation + memo current key (Syntax.moduleSyntaxAssertedId syntax) + case result of + Left Store.StoreRowDecodeFailure{} -> + pure () + Left other -> + assertFailure + ("unexpected malformed-row result: " <> show other) + Right _ -> + assertFailure "malformed canonical payload was accepted" + Store.closeStore current + +plansPersistentStores :: Assertion +plansPersistentStores = + Temp.withSystemTempDirectory "felix-store-planning" \root -> do + (theory, _fixture) <- makeStoreFixture + let cacheRoot = root Posix. "cache" + expectedDefault = + cacheRoot Posix. "felix" Posix. "store.sqlite" + explicitParent = root Posix. "explicit" + explicitPath = explicitParent Posix. "selected.sqlite" + Directory.createDirectory cacheRoot + Directory.createDirectory explicitParent + withEnvironment "XDG_CACHE_HOME" cacheRoot do + defaultPlan <- expectRightIO + (Store.planStore Store.DefaultStore) + defaultResult <- Store.withStoreLease defaultPlan \lease -> do + assertEqual "default store path" + expectedDefault + (Store.storePathFilePath + (Store.storeLeasePath lease)) + assertBool "planning does not create the default parent" + . not + =<< Directory.doesPathExist + (cacheRoot Posix. "felix") + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist expectedDefault + assertEqual "default store opens at the XDG path" + (Right True) defaultResult + + explicitPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore explicitPath)) + explicitResult <- Store.withStoreLease explicitPlan \lease -> do + assertEqual "explicit store path" + explicitPath + (Store.storePathFilePath + (Store.storeLeasePath lease)) + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist explicitPath + assertEqual "explicit store opens without creating its parent" + (Right True) explicitResult + + missing <- Store.planStore + (Store.ExplicitStore + (root Posix. "missing" Posix. "store.sqlite")) + case missing of + Left Store.ExplicitStoreParentMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected missing-parent result: " <> show other) + Right _ -> + assertFailure "missing explicit parent was accepted" + +cleansFreshStores :: Assertion +cleansFreshStores = do + (theory, _fixture) <- makeStoreFixture + plan <- expectRightIO + (Store.planStore Store.FreshTemporaryStore) + + successPath <- IORef.newIORef Nothing + success <- Store.withStoreLease plan \lease -> do + let path = Store.storePathFilePath + (Store.storeLeasePath lease) + IORef.writeIORef successPath (Just path) + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist path + assertEqual "fresh store opened" (Right True) success + assertFreshRemoved successPath + + failurePath <- IORef.newIORef Nothing + failed <- Exception.try + (Store.withStoreLease plan \lease -> do + let path = Store.storePathFilePath + (Store.storeLeasePath lease) + IORef.writeIORef failurePath (Just path) + void + (Store.withOpenStore lease theory \_startup _store -> + ioError (userError "fresh action failed"))) + :: IO (Either IOError ()) + case failed of + Left _ -> + pure () + Right () -> + assertFailure "fresh-store action exception did not escape" + assertFreshRemoved failurePath + +doesNotFallBackAfterFatalStartup :: Assertion +doesNotFallBackAfterFatalStartup = + Temp.withSystemTempDirectory "felix-store-no-fallback" \root -> do + (theory, _fixture) <- makeStoreFixture + let persistentParent = root Posix. "persistent" + persistentPath = persistentParent Posix. "store.sqlite" + cacheRoot = root Posix. "cache" + Directory.createDirectory persistentParent + Directory.createDirectory cacheRoot + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore persistentPath)) + initialized <- Store.withStoreLease plan \lease -> + Store.withOpenStore lease theory \_startup _store -> + pure () + assertEqual "fixture store initialized" + (Right ()) initialized + connection <- SQLite.open persistentPath + SQLite.execute_ connection + "DROP TABLE canonical_objects" + SQLite.close connection + + withEnvironment "XDG_CACHE_HOME" cacheRoot do + result <- Store.withStoreLease plan \lease -> + Store.withOpenStore lease theory \_startup _store -> + pure () + case result of + Left + (Store.StoreLifecycleOpenFailed + (Store.FatalStoreStartup + Store.StoreSchemaIntegrityFailure{})) -> + pure () + Left other -> + assertFailure + ("unexpected fatal-startup result: " <> show other) + Right () -> + assertFailure "corrupt persistent store was accepted" + assertBool "fatal startup creates no default fallback" + . not + =<< Directory.doesPathExist + (cacheRoot Posix. "felix") + + +data StoreFixture = StoreFixture + !Identity.AssertedObject + !Identity.AssertedObject + !Identity.CheckedPropositionContent + +fixtureFirstObject :: StoreFixture -> Identity.AssertedObject +fixtureFirstObject (StoreFixture object _second _proposition) = + object + +fixtureSecondObject :: StoreFixture -> Identity.AssertedObject +fixtureSecondObject (StoreFixture _first object _proposition) = + object + +fixtureProposition + :: StoreFixture + -> Identity.CheckedPropositionContent +fixtureProposition (StoreFixture _first _second proposition) = + proposition + +makeStoreFixture + :: IO (Identity.TheoryId, StoreFixture) +makeStoreFixture = do + foundation <- expectRight Foundation.checkedFoundation + let theory = Identity.theoryId foundation + first = intrinsicObject theory Core.Empty + second = intrinsicObject theory Core.PairSet + closure <- expectRight + (Identity.validateObjectClosure theory [first, second]) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal (Identity.assertedObjectId first)) + (Core.CGlobal (Identity.assertedObjectId first)))) + pure + ( theory + , StoreFixture first second proposition + ) + +intrinsicObject + :: Identity.TheoryId + -> Core.CoreIntrinsicTag + -> Identity.AssertedObject +intrinsicObject theory tag = + Identity.assertedObject identity content + where + coreType = Core.coreIntrinsicType tag + content = + Identity.IntrinsicObjectContent + theory tag coreType + identity = + Identity.intrinsicObjectId + theory tag coreType + +withStoreFixture + :: String + -> ( FilePath + -> Identity.TheoryId + -> StoreFixture + -> IO a + ) + -> IO a +withStoreFixture template action = + Temp.withSystemTempDirectory template \root -> do + (theory, fixture) <- makeStoreFixture + action + (root Posix. "store.sqlite") + theory + fixture + +expectOpen + :: FilePath + -> Identity.TheoryId + -> IO (Store.StoreStartup, Store.Store) +expectOpen path theory = do + result <- Store.openStore path theory + case result of + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right opened -> + pure opened + +expectRight :: Show failure => Either failure value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +expectRightIO + :: Show failure + => IO (Either failure value) + -> IO value +expectRightIO action = + expectRight =<< action + +assertFreshRemoved :: IORef.IORef (Maybe FilePath) -> Assertion +assertFreshRemoved pathReference = do + selected <- IORef.readIORef pathReference + case selected of + Nothing -> + assertFailure "fresh store path was not allocated" + Just path -> do + assertBool "fresh database was removed" + . not + =<< Directory.doesPathExist path + assertBool "fresh database directory was removed" + . not + =<< Directory.doesPathExist + (Posix.takeDirectory path) + +withEnvironment + :: String + -> String + -> IO value + -> IO value +withEnvironment name value action = + Exception.bracket + (Environment.lookupEnv name) + restore + \_previous -> do + Environment.setEnv name value + action + where + restore = \case + Nothing -> + Environment.unsetEnv name + Just previous -> + Environment.setEnv name previous diff --git a/source/Felix/Test/Unit/Token.hs b/source/Felix/Test/Unit/Token.hs new file mode 100644 index 0000000..00c6755 --- /dev/null +++ b/source/Felix/Test/Unit/Token.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Token (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Adapt +import Felix.Syntax.Abstract (Associativity(..)) +import Felix.Syntax.Interface +import Felix.Syntax.Pragma +import Felix.Syntax.Token + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.Megaparsec (errorBundlePretty) + +unitTests :: TestTree +unitTests = testGroup "Lexer" + [ testCase "nested math inside text returns to text" nestedMathInsideText + , testCase "nested text and math returns to the enclosing frame" deeperAlternation + , testCase "braces inside text do not close the text frame" textBraceNesting + , testCase "cases is tokenized as an environment only inside math" casesOnlyInsideMath + , testCase "imports retain source locations and POSIX spellings" locatedImports + , testCase "commented environment starts are ignored" + ignoresCommentedEnvironmentStart + , testCase "empty inputs construct empty lexical syntax" + constructsEmptyLexicalSyntax + , testCase "extracts exact source fixity pragmas" + extractsSourceFixityPragmas + , testCase "rejects malformed reserved pragma lines" + rejectsMalformedPragmas + ] + +nestedMathInsideText :: Assertion +nestedMathInsideText = do + tokens <- tokensInProof "$\\text{if $x \\in A$ then}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "if" + , BeginEnv "math" + , Variable "x" + , Command "in" + , Variable "A" + , EndEnv "math" + , Word "then" + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +deeperAlternation :: Assertion +deeperAlternation = do + tokens <- tokensInProof "$\\text{a $ \\text{b $c$ d} e$ f}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "a" + , BeginEnv "math" + , BeginEnv "text" + , Word "b" + , BeginEnv "math" + , Variable "c" + , EndEnv "math" + , Word "d" + , EndEnv "text" + , Variable "e" + , EndEnv "math" + , Word "f" + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +textBraceNesting :: Assertion +textBraceNesting = do + tokens <- tokensInProof "$\\text{a {b}}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "a" + , InvisibleBraceL + , Word "b" + , InvisibleBraceR + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +casesOnlyInsideMath :: Assertion +casesOnlyInsideMath = do + tokensInsideMath <- tokensInProof "$\\begin{cases}x\\end{cases}$" + tokensInsideMath `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "cases" + , Variable "x" + , EndEnv "cases" + , EndEnv "math" + , EndEnv "proof" + ] + + tokensOutsideMath <- tokensInProof "\\begin{cases}x\\end{cases}" + assertBool + "cases should not be tokenized as an environment outside math" + (BeginEnv "cases" `notElem` tokensOutsideMath && EndEnv "cases" `notElem` tokensOutsideMath) + +locatedImports :: Assertion +locatedImports = do + let raw = Text.unlines + [ "% heading" + , "\\import{set/base.tex}" + , "\\import{set\\special.tex}" + , "\\begin{axiom}" + , " $x = x$." + , "\\end{axiom}" + ] + case gatherImports (FileId maxBound) "import-unit" raw of + Left err -> + assertFailure (errorBundlePretty err) + Right imports@[firstImport, secondImport] -> do + assertEqual + "import paths" + ["set/base.tex", "set\\special.tex"] + (unLocated <$> imports) + assertEqual "first import line" 2 (locLine (startPos firstImport)) + assertEqual "second import line" 3 (locLine (startPos secondImport)) + Right imports -> + assertFailure ("expected two imports, got " <> show imports) + +ignoresCommentedEnvironmentStart :: Assertion +ignoresCommentedEnvironmentStart = do + let raw = Text.unlines + [ "% \\begin{signature}" + , "ordinary text" + , "\\begin{struct}" + , " an ordered set $X$ is a onesorted structure." + , "\\end{struct}" + ] + (_, chunks) <- + either + (assertFailure . errorBundlePretty) + pure + (runLexer (FileId maxBound) "commented-environment" raw) + case chunks of + [Located{unLocated = BeginEnv "struct"} : _] -> pure () + _ -> assertFailure ("expected the real structure environment, got " <> show chunks) + +constructsEmptyLexicalSyntax :: Assertion +constructsEmptyLexicalSyntax = + forM_ + [ ("empty", "") + , ("comment-only", "% heading\n% body") + ] + \(description, raw) -> do + let input = Text.pack raw + imports <- + either + (assertFailure . errorBundlePretty) + pure + (gatherImports + (FileId maxBound) + description + input) + assertEqual (description <> " imports") [] imports + (lexedImports, chunks) <- + either + (assertFailure . errorBundlePretty) + pure + (runLexer + (FileId maxBound) + description + input) + assertEqual (description <> " lexer imports") [] lexedImports + assertEqual (description <> " chunks") [] chunks + scanned <- + either + (assertFailure . show) + pure + (concat <$> traverse scanChunk chunks) + assertEqual (description <> " scanned declarations") [] scanned + delta <- + either + (assertFailure . show) + pure + (canonicalSyntaxDelta []) + assertBool + (description <> " syntax declarations") + (null (canonicalSyntaxDeltaEntries delta)) + +extractsSourceFixityPragmas :: Assertion +extractsSourceFixityPragmas = do + let input = + " %! infixl 0\n" + <> "\t%! infixr 07\r\n" + <> "%! infix 3" + ordinaryComments = + Text.unlines + [ "% ! infixl 1" + , "text %! infixr 2" + , "% ordinary" + ] + pragmas <- + either + (assertFailure . Text.unpack . renderSyntaxPragmaError) + pure + (extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + input) + assertEqual + "normalized pragmas" + [ (LeftAssoc, 0, 1, 3) + , (RightAssoc, 7, 2, 2) + , (NonAssoc, 3, 3, 1) + ] + [ ( syntaxPragmaAssociativity pragma + , sourceMixfixLevelValue (syntaxPragmaLevel pragma) + , locLine (syntaxPragmaLocation pragma) + , locColumn (syntaxPragmaLocation pragma) + ) + | pragma <- pragmas + ] + assertEqual + "ordinary comments" + (Right []) + (extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + ordinaryComments) + +rejectsMalformedPragmas :: Assertion +rejectsMalformedPragmas = + forM_ + [ ("%!infixl 1\n", SyntaxPragmaMissingSpaceAfterPrefix) + , ("%!\n", SyntaxPragmaMissingKeyword) + , ("%! Infixl 1\n", SyntaxPragmaUnknownKeyword "Infixl") + , ("%! infixl\n", SyntaxPragmaMissingLevel) + , ("%! infixl -1\n", SyntaxPragmaInvalidLevel) + , ("%! infixl ١\n", SyntaxPragmaInvalidLevel) + , ("%! infixl 8\n", SyntaxPragmaLevelOutOfRange) + , ("%! infixl 1 extra\n", SyntaxPragmaTrailingContent) + , ("%! infixl 1\r", SyntaxPragmaLoneCarriageReturn) + ] + \(input, expectedProblem) -> + case extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + input of + Left (InvalidSyntaxPragma location actualProblem) -> do + assertEqual + ("problem for " <> show input) + expectedProblem + actualProblem + assertEqual "error line" 1 (locLine location) + assertEqual "error column" 1 (locColumn location) + Left err -> + assertFailure + ("unexpected pragma error: " + <> Text.unpack (renderSyntaxPragmaError err)) + Right pragmas -> + assertFailure + ("expected malformed pragma rejection, got " + <> show pragmas) + +tokensInProof :: Text -> IO [Token] +tokensInProof raw = + case runLexer (FileId maxBound) "lexer-unit" wrapped of + Left err -> + assertFailure (errorBundlePretty err) + Right (_imports, chunks) -> + pure (concatMap (map unLocated) chunks) + where + wrapped = Text.unlines + [ "\\begin{proof}" + , raw + , "\\end{proof}" + ] + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = flip (assertEqual "") -- cgit v1.2.3