diff options
Diffstat (limited to 'source/Test/Unit')
| -rw-r--r-- | source/Test/Unit/Backend.hs | 245 | ||||
| -rw-r--r-- | source/Test/Unit/Checking.hs | 1982 | ||||
| -rw-r--r-- | source/Test/Unit/CommandLine.hs | 181 | ||||
| -rw-r--r-- | source/Test/Unit/Core.hs | 127 | ||||
| -rw-r--r-- | source/Test/Unit/Declaration.hs | 108 | ||||
| -rw-r--r-- | source/Test/Unit/Encoding.hs | 363 | ||||
| -rw-r--r-- | source/Test/Unit/Html.hs | 47 | ||||
| -rw-r--r-- | source/Test/Unit/HtmlOutput.hs | 114 | ||||
| -rw-r--r-- | source/Test/Unit/Kernel.hs | 8 | ||||
| -rw-r--r-- | source/Test/Unit/Migration.hs | 161 | ||||
| -rw-r--r-- | source/Test/Unit/Module.hs | 2665 | ||||
| -rw-r--r-- | source/Test/Unit/Provers.hs | 287 | ||||
| -rw-r--r-- | source/Test/Unit/Semantic.hs | 56 | ||||
| -rw-r--r-- | source/Test/Unit/Source.hs | 1930 | ||||
| -rw-r--r-- | source/Test/Unit/Store.hs | 26 | ||||
| -rw-r--r-- | source/Test/Unit/Symdiff.hs | 132 | ||||
| -rw-r--r-- | source/Test/Unit/Token.hs | 20 |
17 files changed, 2724 insertions, 5728 deletions
diff --git a/source/Test/Unit/Backend.hs b/source/Test/Unit/Backend.hs index 0c4ff71..11c36b8 100644 --- a/source/Test/Unit/Backend.hs +++ b/source/Test/Unit/Backend.hs @@ -4,18 +4,14 @@ module Test.Unit.Backend (unitTests) where import Base hiding (Empty) -import Checking.Backend.Connection qualified as Connection import Checking.Backend.Problem import Checking.Backend.Tptp import Checking.Core import Checking.Foundation qualified as Foundation -import Checking.Kernel.Derivation qualified as Derivation import Provers import Tptp.UnsortedFirstOrder qualified as Tptp -import Control.Monad (unless) import Data.Map.Strict qualified as Map -import Data.Set qualified as Set import Data.Text qualified as Text import Data.Vector (Vector) import Data.Vector qualified as Vector @@ -58,9 +54,6 @@ unitTests = , testCase "renders checked FOF and TH0 problems" rendersCheckedProblems - , testCase - "replays bounded Horn connection choices" - replaysHornConnections ] classifiesPropositionEquality :: Assertion @@ -450,216 +443,6 @@ rendersCheckedProblems = do globalPolicy localPolicy) -replaysHornConnections :: Assertion -replaysHornConnections = do - premiseP <- closedFrozen atomP - premisePtoQ <- - closedFrozen - (CImp atomP - (CImp atomP atomQ)) - premiseQtoR <- - closedFrozen (CImp atomQ atomR) - target <- closedFrozen atomR - facts <- - Vector.fromList - <$> sequence - [ checkedBackendFact - (0 :: Int) - atomP - , checkedBackendFact - 1 - (CImp atomP - (CImp atomP atomQ)) - , checkedBackendFact - 2 - (CImp atomQ atomR) - ] - claim <- - checkedClosedProposition atomR - problem <- - either - (assertFailure . show) - pure - (planTypedProblem - testGlobalType - facts - claim - [] - [] - ImplicitFofPremises - FirstOrderLocals) - connectionProblem <- - either - (assertFailure . show) - pure - (Connection.prepareConnectionProblem - problem) - threeNodeLimits <- - either - (assertFailure . show) - pure - (Connection.connectionLimits 100 3 8) - case Connection.searchConnectionProblem - threeNodeLimits - connectionProblem of - Connection.ConnectionSearchExhausted - (Connection.ConnectionTraceNodesExhausted 3) - _stats -> - pure () - result -> - assertFailure - ("expected expanded-node exhaustion, got " - <> show result) - fourNodeLimits <- - either - (assertFailure . show) - pure - (Connection.connectionLimits 100 4 8) - (foundTrace, searchStats) <- - case Connection.searchConnectionProblem - fourNodeLimits - connectionProblem of - Connection.ConnectionSearchFound - found - stats -> - pure (found, stats) - result -> - assertFailure - ("expected a Horn connection, got " - <> show result) - >> fail "unreachable" - assertEqual - "eleven charged search operations" - 11 - (Connection.connectionSearchWork - searchStats) - assertEqual - "three derived atoms" - 3 - (Connection.connectionSearchDerivedAtomCount - searchStats) - assertEqual - "candidate depth" - 3 - (Connection.connectionSearchMaximumCandidateDepth - searchStats) - let root = - Connection.connectionTraceRoot - foundTrace - assertEqual - "claim uses the final rule" - 2 - (Connection.connectionChoicePremiseOrdinal - root) - replayed <- - either - (assertFailure . show) - pure - (Connection.replayConnectionTrace - fourNodeLimits - connectionProblem - foundTrace) - assertEqual - "replay uses every exact premise" - (Set.fromList - [ Derivation.importIx 0 - , Derivation.importIx 1 - , Derivation.importIx 2 - ]) - (Connection.replayedConnectionImportUses - replayed) - assertEqual - "expanded replay nodes" - 4 - (Connection.replayedConnectionNodeCount - replayed) - assertEqual - "replay depth" - 3 - (Connection.replayedConnectionMaximumDepth - replayed) - checkedFoundationValue <- - either - (assertFailure . show) - pure - Foundation.checkedFoundation - imports <- - traverse - (either - (assertFailure . show) - pure - . Derivation.derivationImportJudgment) - [ premiseP - , premisePtoQ - , premiseQtoR - ] - kernelReplay <- - either - (assertFailure . show) - pure - (Derivation.replayKernelDerivation - checkedFoundationValue - Derivation.defaultKernelReplayLimits - testGlobalType - (Vector.fromList imports) - target - (Connection.replayedConnectionDerivation - replayed)) - assertEqual - "connection lifting proves the exact claim" - target - (Derivation.replayedKernelTarget - kernelReplay) - let wrongRoot = - Connection.connectionTrace - (Connection.connectionChoice - 1 - []) - case Connection.replayConnectionTrace - fourNodeLimits - connectionProblem - wrongRoot of - Left - (Connection.ConnectionReplayRejected - (Connection.ConnectionReplayGoalMismatch 1)) -> - pure () - result -> - assertFailure - ("expected changed-choice rejection, got " - <> case result of - Left err -> show err - Right _ -> "successful replay") - case Connection.replayConnectionTrace - threeNodeLimits - connectionProblem - foundTrace of - Left - (Connection.ConnectionReplayExhausted - (Connection.ConnectionTraceNodesExhausted 3)) -> - pure () - result -> - assertFailure - ("expected bounded replay exhaustion, got " - <> case result of - Left err -> show err - Right _ -> "successful replay") - tightWorkLimits <- - either - (assertFailure . show) - pure - (Connection.connectionLimits 10 4 8) - case Connection.searchConnectionProblem - tightWorkLimits - connectionProblem of - Connection.ConnectionSearchExhausted - (Connection.ConnectionSearchWorkExhausted 10) - _stats -> - pure () - result -> - assertFailure - ("expected bounded search exhaustion, got " - <> show result) - firstOrderClaim :: CanonicalTerm TestGlobal firstOrderClaim = CApp @@ -675,18 +458,6 @@ higherOrderClaim = (CGlobal FirstOrderPredicate) (CBound 0))) -atomP, atomQ, atomR :: CanonicalTerm TestGlobal -atomP = - firstOrderClaim -atomQ = - CApp - (CGlobal FirstOrderPredicate) - (COpaqueInteger 1) -atomR = - CApp - (CGlobal FirstOrderPredicate) - (COpaqueInteger 2) - checkedProposition :: Vector (TestLocal, CoreType) -> CanonicalTerm TestGlobal @@ -750,22 +521,6 @@ checkedBackendFact reference term = do proposition capability) -closedFrozen - :: CanonicalTerm TestGlobal - -> IO (FrozenCheckedCore TestGlobal) -closedFrozen term = do - checked <- - either - (assertFailure . show) - pure - (checkCanonicalCore - testGlobalType - term) - unless - (frozenCoreType checked == TyProp) - (assertFailure "fixture is not a proposition") - pure checked - checkedLocalPremise :: Natural -> Text diff --git a/source/Test/Unit/Checking.hs b/source/Test/Unit/Checking.hs deleted file mode 100644 index 13499a3..0000000 --- a/source/Test/Unit/Checking.hs +++ /dev/null @@ -1,1982 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Unit.Checking (unitTests) where - -import Base -import Checking -import Checking.Dependencies qualified as Dependencies -import Checking.Facts qualified as Facts -import Checking.Legacy -import Checking.Obligation -import Checking.Structure qualified as Structure -import Encoding (contractionTask, encodeTaskText) -import Report.Location -import Syntax.Internal -import Syntax.Lexicon (_Onesorted, pattern ApplySymbol) - -import Bound.Scope (bindings, fromScope, toScope) -import Bound.Var (Var(..)) -import Control.Exception (try) -import Control.Monad.State (runStateT) -import Data.HashSet qualified as HS -import Data.IORef (modifyIORef', newIORef, readIORef) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Test.Tasty -import Test.Tasty.HUnit - -unitTests :: TestTree -unitTests = testGroup "Checking" - [ testCase "renders checking context without constructors" do - let rendered = - renderCheckingError - (DuplicateMarker Nowhere (Marker "labelled")) - assertEqual - "checking diagnostic" - "<nowhere> -1:-1 in labelled: marker is already registered" - rendered - assertBool - "internal Marker constructor is absent" - (not ("Marker" `Text.isInfixOf` rendered)) - , testCase "TPTP encoding excludes task provenance" do - registration <- - registerFilePathWithDisplay - "/tmp/f24-source.tex" - "quote\"\nfof(injected,axiom,$false).\nλ.tex" - fileId <- either - (assertFailure . ("location registration failed: " <>) . show) - pure - registration - let expected = "fof(zf_q0,conjecture,$true)." - plainTask = Task - { taskDirectness = Direct - , taskHypotheses = [] - , taskConjectureLabel = Marker "provenance_test" - , taskLocation = Nowhere - , taskConjecture = PropositionalConstant IsTop - } - adversarialTask = plainTask - { taskDirectness = - Indirect (PropositionalConstant IsBottom) - , taskLocation = mkLocation fileId 12 34 - } - assertEqual "three-argument TPTP" expected (encodeTaskText plainTask) - assertEqual - "path, span, and directness do not affect proof bytes" - (encodeTaskText plainTask) - (encodeTaskText adversarialTask) - , testCase "prepares complete ordered obligation batches" - preparesCompleteObligationBatches - , testCase "replacement conditions remain existentially scoped" do - let x = NamedVar "x" - y = NamedVar "y" - replacement = - makeReplacementIff - (TermVar (F (NamedVar "image"))) - ((x, TermVar (NamedVar "X")) - :| [(y, TermVar (NamedVar "Y"))]) - (abstractVarSymbols [x, y] (TermVar x)) - (abstractVarSymbols - [x, y] - (Equals Nowhere (TermVar x) (TermVar y))) - case replacement of - Quantified Universally outerScope -> do - assertEqual - "outer binders" - [NamedVar "frv"] - (nubOrd (bindings outerScope)) - case fromScope outerScope of - Connected - Equivalence - _ - (Quantified Existentially innerScope) -> - case fromScope innerScope of - And _ (And _ (Equals _ left right)) -> do - assertEqual - "condition left operand" - (TermVar (B x)) - left - assertEqual - "condition right operand" - (TermVar (B y)) - right - body -> - assertFailure - ( "expected replacement condition equality, got " - <> show body - ) - body -> - assertFailure - ("expected replacement equivalence, got " - <> show body) - formula -> - assertFailure - ("expected replacement universal, got " <> show formula) - , testCase "fix rejects shadowing theorem-local variables" do - expectCheckingError "already in scope" (lemmaBlocks "bad_fix" badFixLemma badFixProof) - , testCase "define rejects shadowing local variables" do - expectCheckingError "already in scope" (lemmaBlocks "bad_define" badDefineLemma badDefineProof) - , testCase "take rejects shadowing theorem-local variables" do - expectCheckingError "already in scope" (lemmaBlocks "bad_take" badTakeLemma badTakeProof) - , testCase "have rejects new free variables" do - expectCheckingError "not in scope" (lemmaBlocks "bad_have" badHaveLemma badHaveProof) - , testCase "define function rejects shadowing function name" do - expectCheckingError "already in scope" (lemmaBlocks "bad_define_function_name" badDefineFunctionNameLemma badDefineFunctionNameProof) - , testCase "define function rejects shadowing argument name" do - expectCheckingError "shadow local variable" (lemmaBlocks "bad_define_function_arg" badDefineFunctionArgLemma badDefineFunctionArgProof) - , testCase "free theorem goal variables are local in proofs" do - expectChecks (lemmaBlocks "free_goal_local" freeGoalLocalLemma freeGoalLocalProof) - , testCase "fix accepts fresh local variables" do - expectChecks (lemmaBlocks "fresh_fix" freshFixLemma freshFixProof) - , testCase "take accepts fresh witnesses" do - expectChecks (lemmaBlocks "fresh_take" freshTakeLemma freshTakeProof) - , testCase "assume rejects disjunctive goals" do - expectMismatchedAssume unsoundDisjunctionAssumeBlocks - , assumptionGoalReductionTests - , proofShapeErrorTests - , testCase "struct axioms recursively rewrite carrier labels" do - text <- encodedTasksText structCarrierRewriteBlocks - assertContains "rewritten struct-rule carrier" "zf_u0(zf_f1,zf_s0(zf_f0))" text - assertNotContains "raw struct-rule carrier" "zf_u0(zf_f1,zf_f0)" text - , testCase "struct axioms annotate operations from the same structure" do - text <- encodedTasksText structOperationRewriteBlocks - assertContains "annotated struct operation in rule" "zf_u0(zf_s1(zf_f0),zf_s0(zf_f0))" text - , testCase "structure terms fail before task encoding" do - unresolved <- - try - (check - WithoutDumpPremselTraining - unresolvedStructOperationBlocks) - :: IO (Either CheckingError [Task]) - case unresolved of - Left - (UnresolvedStructureOperation - actualSymbol - actualLocation - actualMarker) -> do - assertEqual - "structure operation" - fooOp - actualSymbol - assertEqual - "block location" - structureTermErrorLocation - actualLocation - assertEqual - "block marker" - "unresolved_structure_operation" - actualMarker - Left err -> - assertFailure - ("expected unresolved structure operation, got " - <> show err) - Right _ -> - assertFailure - "expected unresolved structure operation to fail" - expectCheckingError - "Nested comprehensions are not supported" - nestedStructComprehensionBlocks - , testCase "exact structure claims introduce carrier labels for continuations" do - text <- encodedTasksText structClaimIntroducesContextBlocks - assertContains "claim continuation carrier" "conjecture,zf_u0(zf_f1,zf_s0(zf_f0))" text - , testCase "bound variables do not inherit outer carrier labels" do - text <- encodedTasksText boundStructLabelBlocks - assertContains "bound carrier label remains raw" "![V0]:zf_u0(zf_f1,V0)" text - assertNotContains "bound carrier label not rewritten" "![V0]:zf_u0(zf_f1,zf_s0(V0))" text - , structureTransactionTests - , testCase "abbreviations reject direct self-reference" do - expectCheckingError "self-referential" directSelfReferentialAbbrBlocks - , testCase "abbreviations reject indirect self-reference after expansion" do - expectCheckingError "self-referential" indirectSelfReferentialAbbrBlocks - , testCase "predicate definitions reject direct self-reference" do - expectCheckingError "self-referential" directSelfReferentialPredicateDefinitionBlocks - , testCase "function definitions reject direct self-reference" do - expectCheckingError "self-referential" directSelfReferentialFunctionDefinitionBlocks - , testCase "operator definitions reject direct self-reference" do - expectCheckingError "self-referential" directSelfReferentialOperatorDefinitionBlocks - , testCase "definitions reject abbreviation-hidden self-reference" do - expectCheckingError "self-referential" abbreviationHiddenSelfReferentialDefinitionBlocks - , testCase "definitions reject abbreviation-hidden self-reference in assumptions" do - expectCheckingError "self-referential" assumptionHiddenSelfReferentialDefinitionBlocks - , testCase "ordinary definitions accept non-recursive bodies" do - expectChecks nonRecursiveDefinitionBlocks - , testCase "definitions reject builtin mixfix marker collisions" do - expectCheckingError "object-symbol marker pow is already owned by builtin" [builtinMixfixMarkerCollisionBlock] - , testCase "definitions reject builtin predicate marker collisions" do - expectCheckingError "object-symbol marker elem is already owned by builtin" [builtinPredicateMarkerCollisionBlock] - , testCase "abbreviations reject builtin marker collisions" do - expectCheckingError "object-symbol marker pow is already owned by builtin" [builtinAbbreviationMarkerCollisionBlock] - , testCase "builtin object markers do not reserve proof labels" do - expectChecks [builtinMarkerProofLabelBlock] - , testCase "subseteq remains user-definable" do - expectChecks [subseteqDefinitionBlock] - , testCase "datatype accepts bootstrap propositional fragment" do - expectChecks [goodDatatypeBlock] - , testCase "datatype treats a carrier alias as direct recursion" do - directFacts <- - datatypePreparedFacts [goodDatatypeBlock] - aliasedFacts <- - datatypePreparedFacts directRecursionAliasDatatypeBlocks - assertEqual - "generated datatype facts" - directFacts - aliasedFacts - , testCase "datatype rejects powerset recursion through aliases" do - for_ - [ oneHopPowersetAliasDatatypeBlocks - , multiHopPowersetAliasDatatypeBlocks - ] - (expectCheckingError "recursive premise must be direct") - , testCase "datatype rejects nested recursive premise" do - expectCheckingError "recursive premise must be direct" [badNestedRecursiveDatatypeBlock] - , testCase "datatype rejects missing constructor premise" do - expectCheckingError "missing premise" [badMissingPremiseDatatypeBlock] - , testCase "datatype rejects duplicate constructor patterns" do - expectCheckingError "constructor patterns must be distinct" [badDuplicateConstructorDatatypeBlock] - , testCase "datatype rejects open premise domains" do - expectCheckingError "closed terms" [badOpenDomainDatatypeBlock] - , testCase "datatype rejects application-shaped constructors" do - expectCheckingError "function application" [badApplyConstructorDatatypeBlock] - , testCase "datatype generates trusted fact markers" do - expectFactMarkers datatypeGeneratedMarkers [goodDatatypeBlock] - , testCase "datatype generated fact markers are reserved globally" do - expectDefinedMarkers datatypeGeneratedMarkers [goodDatatypeBlock] - , testCase "datatype generated intro facts are usable by reference" do - expectChecks datatypeIntroReferenceBlocks - , testCase "datatype generated distinctness fact is usable by reference" do - expectChecks datatypeDistinctReferenceBlocks - , testCase "datatype generated injective fact is usable by reference" do - expectChecks datatypeInjectiveReferenceBlocks - , testCase "datatype generated fact markers cannot be reused by later blocks" do - expectDuplicateMarker "propform_cases" datatypeGeneratedMarkerReuseBlocks - , testCase "datatype rejects duplicate constructor markers" do - expectCheckingError "object-symbol marker dup is already owned by datatype constructor" [badDuplicateConstructorMarkerDatatypeBlock] - , testCase "signature predicate declares symbols for later facts" do - expectChecks signaturePredicateUsageBlocks - , testCase "signature formula declares symbolic operators for later facts" do - expectChecks signatureFormulaUsageBlocks - , testCase "signature formula rejects unrecoverable declarations" do - expectCheckingError "could not recover the declared symbol" [badSignatureFormulaBlock] - , testCase "inductive accepts bounded fin fragment" do - expectChecks goodInductiveBlocks - , testCase "inductive generates trusted fact markers" do - expectFactMarkers inductiveGeneratedMarkers goodInductiveBlocks - , testCase "inductive generated fact markers are reserved globally" do - expectDefinedMarkers inductiveGeneratedMarkers goodInductiveBlocks - , testCase "inductive generated intro and domain facts are usable by reference" do - expectChecks inductiveIntroAndDomainReferenceBlocks - , testCase "inductive generated cases fact is usable by reference" do - expectChecks inductiveCasesReferenceBlocks - , testCase "inductive generated induction fact is usable by reference" do - expectChecks inductiveInductReferenceBlocks - , testCase "inductive generates monotonicity obligations for recursive carriers" do - text <- encodedTasksText goodMonotoneInductiveBlocks - assertContains "monotonicity antecedent expands subset" "zf_u1(V2,V0)=>zf_u1(V2,V1)" text - assertContains "monotonicity conclusion expands subset" "zf_u1(V3,zf_u0(V0))=>zf_u1(V3,zf_u0(V1))" text - , testCase "inductive rejects recursive premises outside carrier positions" do - expectCheckingError "carrier of a membership premise" [badRecursiveTermInductiveBlock] - , testCase "inductive rejects malformed recursive premises" do - expectCheckingError "direct membership condition" [badRecursiveFormulaInductiveBlock] - , testCase "inductive rejects malformed results" do - expectCheckingError "form t \\in F(args)" [badInductiveResultBlock] - , testCase "inductive rejects recursive occurrences with the wrong arguments" do - expectCheckingError "wrong arguments" [badInductiveWrongArgsBlock] - , testCase "inductive validates generated markers before emitting obligations" do - tasksRef <- newIORef [] - result <- - try - (runCheckingBlocks - [ BlockAxiom - Nowhere - "fin_cases" - (Axiom [] Top) - , goodInductiveBlock - ] - ( initialCheckingState - WithoutDumpPremselTraining - (\task -> modifyIORef' tasksRef (task :)) - )) - :: IO (Either CheckingError CheckingState) - case result of - Left (DuplicateMarker _ actualMarker) -> - assertEqual - "duplicate marker" - "fin_cases" - actualMarker - Left err -> - assertFailure - ("expected DuplicateMarker, got " <> show err) - Right _ -> - assertFailure - "expected generated marker validation to fail" - tasks <- readIORef tasksRef - assertBool - "failed inductive obligations" - (null tasks) - , testCase "inductive rejects duplicate carrier ownership" do - expectCheckingError "already owned" duplicateInductiveCarrierBlocks - , testCase "inductive rejects operator definitions with the same carrier symbol" do - expectCheckingError "already owned" operatorThenInductiveBlocks - , testCase "inductive rejects prior axiom mentions of the carrier" do - expectCheckingError "without prior ownership" priorInductiveCarrierAxiomBlocks - , testCase "inductive rejects direct recursive domains" do - expectCheckingError "independent of the inductive symbol" [badInductiveSelfDomainBlock] - , testCase "inductive rejects abbreviation-hidden recursive domains" do - expectCheckingError "independent of the inductive symbol" hiddenSelfDomainBlocks - , testCase "inductive rejects prior ordinary-definition mentions of the carrier via domains" do - expectCheckingError "without prior ownership" hiddenDefinitionDomainBlocks - , testCase "inductive rejects prior ordinary-definition mentions of the carrier via side-condition aliases" do - expectCheckingError "without prior ownership" hiddenCarrierSideConditionBlocks - , testCase "datatype rejects prior signature mentions of the datatype head" do - expectCheckingError "already owned" priorDatatypeHeadSignatureBlocks - , testCase "datatype rejects prior theorem mentions of constructors" do - expectCheckingError "without prior ownership" priorDatatypeConstructorLemmaBlocks - , testCase "datatype constructor ownership blocks later operator definitions" do - expectCheckingError "already owned" datatypeConstructorThenOperatorBlocks - , testCase "inductive freezes mentioned symbols against later definitions" do - expectCheckingError "already owned by signature formula" frozenSymbolDefinitionBlocks - , testCase "inductive freezes symbols from canonicalized domains" do - expectCheckingError "already owned by signature formula" canonicalizedDomainFreezeBlocks - , testCase "inductive freezes transitive definition dependencies" do - expectCheckingError "already owned by signature formula" transitiveFrozenDefinitionBlocks - ] - -preparesCompleteObligationBatches :: Assertion -preparesCompleteObligationBatches = do - registry <- - case - Facts.registerStagedFacts - ( Facts.stageFact - ("known_fact" :| []) - (Facts.factOrigin Nowhere "known_block") - (Facts.prepareSemanticFact Top) - :| [] - ) - Facts.emptyFactRegistry of - Left marker -> - assertFailure - ("could not register premise " <> show marker) - Right preparedRegistry -> - pure preparedRegistry - batchesRef <- newIORef [] - let initial = - ( initialCheckingStateWithTaskPreparation - WithoutDumpPremselTraining - contractionTask - (\batch -> - modifyIORef' batchesRef (batch :)) - ) - { checkingFacts = registry - , checkingGoals = [Top `Iff` Top, Bottom] - , blockLabel = "batch_claim" - , stepLocation = Nowhere - } - (_result, afterGoals) <- runStateT tellTasks initial - (_emptyResult, afterEmpty) <- - runStateT - tellTasks - afterGoals{checkingGoals = []} - batches <- reverse <$> readIORef batchesRef - case batches of - [goalBatch, emptyBatch] -> do - assertEqual "batch marker" - "batch_claim" - (preparedBatchMarker goalBatch) - assertEqual "batch location" - Nowhere - (preparedBatchLocation goalBatch) - assertEqual "stable declaration-local ordinals" - [0, 1] - ( legacyObligationOrdinalValue - . preparedObligationOrdinal - <$> toList - (preparedBatchObligations goalBatch) - ) - assertEqual "prepared contracted goals" - [Top, Bottom] - ( taskConjecture - . preparedObligationTask - <$> toList - (preparedBatchObligations goalBatch) - ) - case toList (preparedBatchPremises goalBatch) of - [premise] -> do - assertEqual "premise marker" - "known_fact" - (hypothesisMarker - (preparedPremiseHypothesis premise)) - assertEqual "premise provenance" - (RegisteredFactPremise - (Facts.factOrigin - Nowhere - "known_block")) - (preparedPremiseOrigin premise) - premises -> - assertFailure - ("expected one premise, got " - <> show (length premises)) - assertBool "empty batch callback" - (null (preparedBatchObligations emptyBatch)) - assertEqual "empty batch does not consume an ordinal" - 2 - (legacyObligationOrdinalValue - (checkingNextObligationOrdinal afterEmpty)) - _ -> - assertFailure - ("expected one goal batch and one empty batch, got " - <> show (length batches)) - -structureTransactionTests :: TestTree -structureTransactionTests = - testGroup "structure transactions" - [ testCase "reject positive and negative direct self-reference" do - for_ [fooStructPredicate "A", Not Nowhere (fooStructPredicate "A")] - \assumption -> - expectCheckingError - "self-referential" - [fooStructBlock "self_struct" [("self_rule", assumption)]] - , testCase "reject abbreviation-hidden self-reference" do - expectCheckingError - "self-referential" - hiddenSelfReferentialStructBlocks - , testCase "report unknown and forward parents as located errors" do - expectUnknownStructureParent - unknownStruct - [testStructBlock "unknown_child" childStruct (Set.singleton unknownStruct) []] - expectUnknownStructureParent - fooStruct - [ testStructBlock "forward_child" childStruct (Set.singleton fooStruct) [] - , fooStructBlock "forward_parent" [] - ] - expectUnknownStructureParent - fooStruct - [testStructBlock "self_parent" fooStruct (Set.singleton fooStruct) []] - , testCase "reject every local structure marker collision" do - for_ - [ ( "same_marker" - , fooStructBlock "same_marker" [("same_marker", Top)] - ) - , ( "duplicate_rule" - , fooStructBlock - "duplicate_rules" - [("duplicate_rule", Top), ("duplicate_rule", Top)] - ) - , ( "inherit_collisioninherit" - , fooStructBlock - "inherit_collision" - [("inherit_collisioninherit", Top)] - ) - ] - \(duplicate, block) -> - expectDuplicateMarker duplicate [block] - , testCase "reject collisions before and after a structure" do - expectDuplicateMarker - "prior_rule" - [ BlockAxiom Nowhere "prior_rule" (Axiom [] Top) - , fooStructBlock "prior_collision" [("prior_rule", Top)] - ] - expectDuplicateMarker - "later_collisioninherit" - [ fooStructBlock "later_collision" [] - , BlockAxiom - Nowhere - "later_collisioninherit" - (Axiom [] Top) - ] - , testCase "commit exact prepared facts and backward dependencies" do - case preparedFooStructure "prepared_struct" of - Left err -> - assertFailure - ("could not prepare structure: " <> show err) - Right checked -> do - let context = BlockContext Nowhere "prepared_struct" - initial = - initialCheckingState - WithoutDumpPremselTraining - (\_task -> pure ()) - case commitCheckedStructDefn context checked initial of - Left err -> - assertFailure - ("could not commit structure: " <> show err) - Right committed -> do - assertBool - "fact registry invariant" - (Facts.factRegistryInvariant - (checkingFacts committed)) - for_ - (zip - (toList - (Structure.checkedStructMarkers checked)) - (toList - (Structure.checkedStructSemanticFacts checked))) - \(factMarker, prepared) -> - assertEqual - ("prepared fact " <> show factMarker) - (Just prepared) - (Facts.lookupPreparedFact - factMarker - (checkingFacts committed)) - assertEqual - "structure dependencies" - (Just - (Set.singleton - (SymbolPredicate - (PredicateNounStruct _Onesorted)))) - (Dependencies.lookupDependencies - (Structure.checkedStructSymbol checked) - (checkingDependencies committed)) - ] - -preparedFooStructure - :: Marker - -> Either - Structure.StructurePreparationError - Structure.CheckedStructDefn -preparedFooStructure marker = - Structure.prepareCheckedStructDefn - Nowhere - marker - (fooStructDefn [("prepared_rule", Top)]) - (Set.singleton _Onesorted) - (Set.singleton CarrierSymbol) - -expectUnknownStructureParent - :: StructPhrase - -> [Block] - -> Assertion -expectUnknownStructureParent expected blocks = do - result <- - try (check WithoutDumpPremselTraining blocks) - :: IO (Either CheckingError [Task]) - case result of - Left (UnknownStructureParent actual Nowhere _) -> - assertEqual "unknown structure parent" expected actual - Left err -> - assertFailure - ("expected UnknownStructureParent, got " <> show err) - Right _ -> - assertFailure "expected an unknown structure parent" - -assumptionGoalReductionTests :: TestTree -assumptionGoalReductionTests = - testGroup "assumption goal reductions" - [ testCase "introduces an implication antecedent" do - assertGoalReduction - (ImplicationIntroduction propositionA propositionC) - propositionA - (propositionA `Implies` propositionC) - propositionC - , testCase "curries an assumed left conjunct" do - assertGoalReduction - (CurryLeftConjunct propositionA propositionB propositionC) - propositionA - ((propositionA `And` propositionB) `Implies` propositionC) - (propositionB `Implies` propositionC) - , testCase "curries an assumed right conjunct" do - assertGoalReduction - (CurryRightConjunct propositionA propositionB propositionC) - propositionB - ((propositionA `And` propositionB) `Implies` propositionC) - (propositionA `Implies` propositionC) - , testCase "does not reduce a disjunction" do - assertEqual "disjunction reduction" - Nothing - (reduceGoalWithAssumption - propositionA - (propositionA `Or` propositionB)) - ] - -proofShapeErrorTests :: TestTree -proofShapeErrorTests = - testCase "malformed proof shapes return located errors" do - for_ cases \(label, expectedError, action) -> do - result <- try action :: IO (Either CheckingError ()) - assertEqual label (Left expectedError) result - where - cases = - [ ( "ordinal induction goal" - , ByOrdInductionSyntacticMismatch - proofShapeLocation - "bad_ordinal_induction" - , checkAsUnit - (proofBlocks - "bad_ordinal_induction" - Top - (ByOrdInduction - proofShapeLocation - (Omitted proofShapeLocation))) - ) - , ( "set extensionality with take" - , SetExtensionalityWithTake - proofShapeLocation - "bad_take_setext" - , checkAsUnit - (proofBlocks - "bad_take_setext" - Top - (Take - proofShapeLocation - ("witness" :| []) - Top - JustificationSetExt - (Omitted proofShapeLocation))) - ) - ] - - checkAsUnit = - void . check WithoutDumpPremselTraining - - proofBlocks marker goal proof = - [ BlockLemma - proofShapeLocation - marker - (Lemma [] goal) - , BlockProof - proofShapeLocation - proofShapeLocation - proof - ] - - proofShapeLocation = - mkLocation (FileId 47) 6 11 - -assertGoalReduction - :: GoalReduction - -> Formula - -> Formula - -> Formula - -> Assertion -assertGoalReduction expected assumption original residual = - case reduceGoalWithAssumption assumption original of - Nothing -> - assertFailure "expected a goal reduction" - Just reduction -> do - assertEqual "trusted rule" expected reduction - assertEqual "introduced assumption" - assumption - (goalReductionAssumption reduction) - assertEqual "residual goal" - residual - (goalReductionResidual reduction) - assertReductionSound original reduction - -assertReductionSound :: Formula -> GoalReduction -> Assertion -assertReductionSound original reduction = - for_ propositionAssignments \assignment -> do - let discharged = - goalReductionAssumption reduction - `Implies` goalReductionResidual reduction - soundness = discharged `Implies` original - assertBool - ( "reduction is not sound under " - <> show assignment - <> ": " - <> show reduction - ) - (evaluateProposition assignment soundness) - -type PropositionAssignment = (Bool, Bool, Bool) - -evaluateProposition :: PropositionAssignment -> Formula -> Bool -evaluateProposition assignment@(a, b, c) = \case - Atomic _location (PredicateSymbol name) [] -> - case name of - "A" -> a - "B" -> b - "C" -> c - _ -> error ("missing proposition value for " <> show name) - left `And` right -> - evaluateProposition assignment left - && evaluateProposition assignment right - left `Or` right -> - evaluateProposition assignment left - || evaluateProposition assignment right - left `Implies` right -> - not (evaluateProposition assignment left) - || evaluateProposition assignment right - Not _location formula -> - not (evaluateProposition assignment formula) - Top -> - True - Bottom -> - False - formula -> - error - ( "not a propositional test formula under " - <> show assignment - <> ": " - <> show formula - ) - -propositionAssignments :: [PropositionAssignment] -propositionAssignments = - [ (a, b, c) - | a <- [False, True] - , b <- [False, True] - , c <- [False, True] - ] - -propositionA, propositionB, propositionC :: Formula -propositionA = proposition "A" -propositionB = proposition "B" -propositionC = proposition "C" - -proposition :: Text -> Formula -proposition name = - Atomic Nowhere (PredicateSymbol name) [] - -expectChecks :: [Block] -> Assertion -expectChecks blocks = do - _tasks <- check WithoutDumpPremselTraining blocks - pure () - -encodedTasksText :: [Block] -> IO Text -encodedTasksText blocks = do - tasks <- check WithoutDumpPremselTraining blocks - if null tasks - then assertFailure "expected at least one generated task" - else pure () - pure (Text.intercalate "\n------------------\n" (encodeTaskText <$> tasks)) - -expectCheckingError :: Text -> [Block] -> Assertion -expectCheckingError fragment blocks = do - result <- try (check WithoutDumpPremselTraining blocks) :: IO (Either CheckingError [Task]) - case result of - Right _ -> - assertFailure "expected a CheckingError, but checking succeeded" - Left err@(CheckingError msg _ _) -> - assertBool ("expected error containing " <> show fragment <> ", got " <> show err) (fragment `Text.isInfixOf` msg) - Left err -> - assertFailure ("expected generic CheckingError, got " <> show err) - -expectMismatchedAssume :: [Block] -> Assertion -expectMismatchedAssume blocks = do - result <- try (check WithoutDumpPremselTraining blocks) :: IO (Either CheckingError [Task]) - case result of - Right _ -> - assertFailure "expected a MismatchedAssume error, but checking succeeded" - Left (MismatchedAssume _assumption _goal _location _marker) -> - pure () - Left err -> - assertFailure ("expected MismatchedAssume, got " <> show err) - -expectFactMarkers :: [Marker] -> [Block] -> Assertion -expectFactMarkers markers blocks = do - checkingState <- runCheckingBlocks blocks (initialCheckingState WithoutDumpPremselTraining (\_task -> pure ())) - let facts = checkingFacts checkingState - for_ markers \marker -> - assertBool - ("expected generated fact marker " <> show marker) - (isJust (Facts.lookupPreparedFact marker facts)) - -datatypePreparedFacts - :: [Block] - -> IO [Facts.PreparedSemanticFact] -datatypePreparedFacts blocks = do - checkingState <- - runCheckingBlocks - blocks - ( initialCheckingState - WithoutDumpPremselTraining - (\_task -> pure ()) - ) - traverse - (lookupFact (checkingFacts checkingState)) - datatypeGeneratedMarkers - where - lookupFact facts marker = - case Facts.lookupPreparedFact marker facts of - Just fact -> - pure fact - Nothing -> do - assertFailure - ("missing generated datatype fact " <> show marker) - pure - (impossible - "assertFailure returned while looking up a datatype fact") - -expectDefinedMarkers :: [Marker] -> [Block] -> Assertion -expectDefinedMarkers markers blocks = do - checkingState <- runCheckingBlocks blocks (initialCheckingState WithoutDumpPremselTraining (\_task -> pure ())) - let reserved = definedMarkers checkingState - for_ markers \marker -> - assertBool ("expected reserved marker " <> show marker) (HS.member marker reserved) - -expectDuplicateMarker :: Marker -> [Block] -> Assertion -expectDuplicateMarker expectedMarker blocks = do - result <- try (check WithoutDumpPremselTraining blocks) :: IO (Either CheckingError [Task]) - case result of - Right _ -> - assertFailure "expected a DuplicateMarker error, but checking succeeded" - Left (DuplicateMarker _ actualMarker) -> - assertEqual "duplicate marker" expectedMarker actualMarker - Left err -> - assertFailure ("expected DuplicateMarker, got " <> show err) - -assertContains :: String -> Text -> Text -> Assertion -assertContains label needle haystack = - assertBool (label <> ": expected to find " <> show needle <> " in " <> Text.unpack haystack) (needle `Text.isInfixOf` haystack) - -assertNotContains :: String -> Text -> Text -> Assertion -assertNotContains label needle haystack = - assertBool (label <> ": expected not to find " <> show needle <> " in " <> Text.unpack haystack) (not (needle `Text.isInfixOf` haystack)) - -lemmaBlocks :: Marker -> Lemma -> Proof -> [Block] -lemmaBlocks marker lemma proof = - [BlockLemma Nowhere marker lemma, BlockProof Nowhere Nowhere proof] - -badFixLemma :: Lemma -badFixLemma = - Lemma [Asm (var "a" `eq` var "b")] (makeForall ["x"] (var "x" `eq` var "b")) - -badFixProof :: Proof -badFixProof = - Fix Nowhere ("a" :| []) Top (Qed (Just Nowhere) JustificationLocal) - -badDefineLemma :: Lemma -badDefineLemma = - Lemma [] (makeForall ["x"] (var "x" `eq` emptySet)) - -badDefineProof :: Proof -badDefineProof = - Fix Nowhere ("x" :| []) Top (Define Nowhere "x" emptySet (Qed (Just Nowhere) JustificationLocal)) - -badTakeLemma :: Lemma -badTakeLemma = - Lemma [Asm (makeExists ["x"] (var "x" `neq` var "b"))] (var "a" `neq` var "b") - -badTakeProof :: Proof -badTakeProof = - Take Nowhere ("a" :| []) (var "a" `neq` var "b") JustificationLocal (Qed (Just Nowhere) JustificationLocal) - -badHaveLemma :: Lemma -badHaveLemma = - Lemma [] Top - -badHaveProof :: Proof -badHaveProof = - Have Nowhere (var "c" `eq` var "c") JustificationEmpty (Qed (Just Nowhere) JustificationEmpty) - -badDefineFunctionNameLemma :: Lemma -badDefineFunctionNameLemma = - Lemma [] (var "f" `eq` var "f") - -badDefineFunctionNameProof :: Proof -badDefineFunctionNameProof = - DefineFunction Nowhere "f" "x" (var "x") emptySet (Qed (Just Nowhere) JustificationLocal) - -badDefineFunctionArgLemma :: Lemma -badDefineFunctionArgLemma = - Lemma [] (var "x" `eq` var "x") - -badDefineFunctionArgProof :: Proof -badDefineFunctionArgProof = - DefineFunction Nowhere "f" "x" (var "x") emptySet (Qed (Just Nowhere) JustificationLocal) - -freeGoalLocalLemma :: Lemma -freeGoalLocalLemma = - Lemma [] (var "b" `eq` var "b") - -freeGoalLocalProof :: Proof -freeGoalLocalProof = - Qed (Just Nowhere) JustificationEmpty - -freshFixLemma :: Lemma -freshFixLemma = - Lemma [] (makeForall ["x"] (var "x" `eq` var "x")) - -freshFixProof :: Proof -freshFixProof = - Fix Nowhere ("x" :| []) Top (Qed (Just Nowhere) JustificationEmpty) - -freshTakeLemma :: Lemma -freshTakeLemma = - Lemma [Asm (makeExists ["x"] (var "x" `eq` var "b"))] (var "b" `eq` var "b") - -freshTakeProof :: Proof -freshTakeProof = - Take Nowhere ("y" :| []) (var "y" `eq` var "b") JustificationLocal (Qed (Just Nowhere) JustificationEmpty) - -unsoundDisjunctionAssumeBlocks :: [Block] -unsoundDisjunctionAssumeBlocks = - [ BlockAxiom Nowhere "membership_asymmetry" - (Axiom [] (membershipXY `Implies` Not Nowhere membershipYX)) - , BlockLemma Nowhere "membership_totality" - (Lemma [] (membershipXY `Or` membershipYX)) - , BlockProof Nowhere Nowhere - (Assume Nowhere membershipXY - (Qed (Just Nowhere) - (JustificationRef ("membership_asymmetry" :| [])))) - ] - where - membershipXY = var "x" `isElementOf` var "y" - membershipYX = var "y" `isElementOf` var "x" - -structCarrierRewriteBlocks :: [Block] -structCarrierRewriteBlocks = - [ fooStructBlock "foo_struct" [("foo_rule", makeForall ["x"] ((var "x" `isElementOf` var "A") `Implies` (var "x" `isElementOf` var "A")))] - , BlockLemma Nowhere "foo_test" (Lemma [AsmStruct "A" fooStruct, Asm (var "x" `isElementOf` var "A")] (var "x" `isElementOf` var "A")) - , BlockProof Nowhere Nowhere (Qed (Just Nowhere) (JustificationRef ("foo_rule" :| []))) - ] - -structOperationRewriteBlocks :: [Block] -structOperationRewriteBlocks = - [ fooStructBlock "foo_op_struct" [("foo_op_rule", TermSymbolStruct fooOp Nothing `isElementOf` var "A")] - , BlockLemma Nowhere "foo_op_test" (Lemma [AsmStruct "A" fooStruct] (TermSymbolStruct fooOp Nothing `isElementOf` var "A")) - , BlockProof Nowhere Nowhere (Qed (Just Nowhere) (JustificationRef ("foo_op_rule" :| []))) - ] - -unresolvedStructOperationBlocks :: [Block] -unresolvedStructOperationBlocks = - [ fooStructBlock "unresolved_structure_definition" [] - , BlockAxiom - structureTermErrorLocation - "unresolved_structure_operation" - (Axiom [] - (TermSymbolStruct fooOp Nothing - `eq` TermSymbolStruct fooOp Nothing)) - ] - -nestedStructComprehensionBlocks :: [Block] -nestedStructComprehensionBlocks = - [ fooStructBlock "nested_structure_definition" [] - , BlockAxiom - structureTermErrorLocation - "nested_structure_comprehension" - (Axiom [] - (nestedOperation `eq` nestedOperation)) - ] - where - nestedOperation = - TermSymbolStruct - fooOp - (Just - (TermSep - "x" - emptySet - (toScope Top))) - -structureTermErrorLocation :: Location -structureTermErrorLocation = - mkLocation (FileId 50) 7 1 - -structClaimIntroducesContextBlocks :: [Block] -structClaimIntroducesContextBlocks = - [ fooStructBlock "foo_claim_struct" [] - , BlockLemma Nowhere "foo_claim_test" (Lemma [] ((var "A" `eq` var "A") `And` (var "x" `eq` var "x"))) - , BlockProof Nowhere Nowhere $ - Have Nowhere (fooStructPredicate "A") JustificationEmpty $ - Have Nowhere (var "x" `isElementOf` var "A") JustificationEmpty (Omitted Nowhere) - ] - -boundStructLabelBlocks :: [Block] -boundStructLabelBlocks = - [ fooStructBlock "foo_bound_struct" [] - , BlockLemma Nowhere "foo_bound_test" (Lemma [AsmStruct "A" fooStruct] (makeForall ["A"] (var "x" `isElementOf` var "A"))) - , BlockProof Nowhere Nowhere (Qed (Just Nowhere) JustificationEmpty) - ] - -fooStructBlock :: Marker -> [(Marker, Formula)] -> Block -fooStructBlock marker assumes = - BlockStruct Nowhere marker (fooStructDefn assumes) - -fooStructDefn :: [(Marker, Formula)] -> StructDefn -fooStructDefn assumes = - StructDefn - { structPhrase = fooStruct - , structParents = Set.singleton _Onesorted - , structDefnLabel = "A" - , structDefnFixes = Set.singleton fooOp - , structDefnAssumes = assumes - } - -testStructBlock - :: Marker - -> StructPhrase - -> Set StructPhrase - -> [(Marker, Formula)] - -> Block -testStructBlock marker phrase parents assumes = - BlockStruct Nowhere marker StructDefn - { structPhrase = phrase - , structParents = parents - , structDefnLabel = "A" - , structDefnFixes = mempty - , structDefnAssumes = assumes - } - -fooStruct :: StructPhrase -fooStruct = - mkLexicalItemSgPl (unsafeReadPhraseSgPl "foo[/s]") "foo" - -childStruct :: StructPhrase -childStruct = - mkLexicalItemSgPl - (unsafeReadPhraseSgPl "child[/s]") - "child" - -unknownStruct :: StructPhrase -unknownStruct = - mkLexicalItemSgPl - (unsafeReadPhraseSgPl "unknown[/s]") - "unknown" - -fooOp :: StructSymbol -fooOp = - StructSymbol "fooop" - -fooStructPredicate :: VarSymbol -> Formula -fooStructPredicate x = - TermSymbol Nowhere (SymbolPredicate (PredicateNounStruct fooStruct)) [TermVar x] - -hiddenSelfReferentialStructBlocks :: [Block] -hiddenSelfReferentialStructBlocks = - [ BlockAbbr Nowhere "struct_alias_a" - ( Abbreviation - (SymbolPredicate structAliasA) - (toScope - (TermSymbol - Nowhere - (SymbolPredicate (PredicateNounStruct fooStruct)) - [TermVar (B 0)])) - ) - , BlockAbbr Nowhere "struct_alias_b" - ( Abbreviation - (SymbolPredicate structAliasB) - (toScope - (TermSymbol - Nowhere - (SymbolPredicate structAliasA) - [TermVar (B 0)])) - ) - , fooStructBlock - "hidden_self_struct" - [("hidden_self_rule", structAliasFormula structAliasB (var "A"))] - ] - -structAliasA :: Predicate -structAliasA = - PredicateSymbol "struct_alias_a" - -structAliasB :: Predicate -structAliasB = - PredicateSymbol "struct_alias_b" - -structAliasFormula :: Predicate -> Term -> Formula -structAliasFormula predicate term = - TermSymbol Nowhere (SymbolPredicate predicate) [term] - -var :: VarSymbol -> Term -var = TermVar - -emptySet :: Term -emptySet = EmptySet Nowhere - -eq :: Term -> Term -> Formula -eq = Equals Nowhere - -neq :: Term -> Term -> Formula -neq = NotEquals Nowhere - -directSelfReferentialAbbrBlocks :: [Block] -directSelfReferentialAbbrBlocks = - [ BlockAbbr Nowhere "bad_abbr_direct" (Abbreviation abbrSymbolA (toScope (TermSymbol Nowhere abbrSymbolA []))) - ] - -indirectSelfReferentialAbbrBlocks :: [Block] -indirectSelfReferentialAbbrBlocks = - [ BlockAbbr Nowhere "bad_abbr_indirect_a" (Abbreviation abbrSymbolA (toScope (TermSymbol Nowhere abbrSymbolB []))) - , BlockAbbr Nowhere "bad_abbr_indirect_b" (Abbreviation abbrSymbolB (toScope (TermSymbol Nowhere abbrSymbolA []))) - ] - -directSelfReferentialPredicateDefinitionBlocks :: [Block] -directSelfReferentialPredicateDefinitionBlocks = - [ BlockDefn Nowhere "bad_predicate_definition_direct" - ( DefnPredicate - [] - definitionTestPredicate - ("x" :| []) - (Not Nowhere (definitionTestPredicateFormula (var "x"))) - ) - ] - -directSelfReferentialFunctionDefinitionBlocks :: [Block] -directSelfReferentialFunctionDefinitionBlocks = - [ BlockDefn Nowhere "bad_function_definition_direct" - ( DefnFun - [] - definitionTestFunction - ["x"] - (definitionTestFunctionTerm (var "x")) - ) - ] - -directSelfReferentialOperatorDefinitionBlocks :: [Block] -directSelfReferentialOperatorDefinitionBlocks = - [ BlockDefn Nowhere "bad_operator_definition_direct" - (DefnOp definitionTestOperator ["x"] (termSymbol definitionTestOperator [var "x"])) - ] - -abbreviationHiddenSelfReferentialDefinitionBlocks :: [Block] -abbreviationHiddenSelfReferentialDefinitionBlocks = - [ BlockAbbr Nowhere "bad_definition_body_alias" - ( Abbreviation - (SymbolMixfix selfDefinitionBodyAlias) - (toScope (TermSymbol Nowhere (SymbolMixfix definitionTestOperator) [TermVar (B 0)])) - ) - , BlockDefn Nowhere "bad_definition_body_target" - (DefnOp definitionTestOperator ["x"] (termSymbol selfDefinitionBodyAlias [var "x"])) - ] - -assumptionHiddenSelfReferentialDefinitionBlocks :: [Block] -assumptionHiddenSelfReferentialDefinitionBlocks = - [ BlockAbbr Nowhere "bad_definition_assumption_alias" - ( Abbreviation - (SymbolPredicate selfDefinitionAssumptionAlias) - (toScope (TermSymbol Nowhere (SymbolPredicate definitionTestPredicate) [TermVar (B 0)])) - ) - , BlockDefn Nowhere "bad_definition_assumption_target" - ( DefnPredicate - [Asm (selfDefinitionAssumptionAliasFormula (var "x"))] - definitionTestPredicate - ("x" :| []) - (var "x" `eq` var "x") - ) - ] - -nonRecursiveDefinitionBlocks :: [Block] -nonRecursiveDefinitionBlocks = - [ BlockDefn Nowhere "good_predicate_definition" - (DefnPredicate [] definitionTestPredicate ("x" :| []) (var "x" `eq` var "x")) - , BlockDefn Nowhere "good_function_definition" - (DefnFun [] definitionTestFunction ["x"] emptySet) - , BlockDefn Nowhere "good_operator_definition" - (DefnOp definitionTestOperator ["x"] emptySet) - ] - -definitionTestPredicate :: Predicate -definitionTestPredicate = - PredicateSymbol "definition_test_predicate" - -definitionTestPredicateFormula :: Term -> Formula -definitionTestPredicateFormula expr = - TermSymbol Nowhere (SymbolPredicate definitionTestPredicate) [expr] - -definitionTestFunction :: LexicalItemSgPl -definitionTestFunction = - mkLexicalItemSgPl - (unsafeReadPhraseSgPl "definition test function[/s] of ?") - "definition_test_function" - -definitionTestFunctionTerm :: Term -> Term -definitionTestFunctionTerm expr = - TermSymbol Nowhere (SymbolFun definitionTestFunction) [expr] - -definitionTestOperator :: FunctionSymbol -definitionTestOperator = - unarySymbol "definition_test_operator" - -selfDefinitionBodyAlias :: FunctionSymbol -selfDefinitionBodyAlias = - unarySymbol "self_definition_body_alias" - -selfDefinitionAssumptionAlias :: Predicate -selfDefinitionAssumptionAlias = - PredicateSymbol "self_definition_assumption_alias" - -selfDefinitionAssumptionAliasFormula :: Term -> Formula -selfDefinitionAssumptionAliasFormula expr = - TermSymbol Nowhere (SymbolPredicate selfDefinitionAssumptionAlias) [expr] - -builtinMixfixMarkerCollisionBlock :: Block -builtinMixfixMarkerCollisionBlock = - BlockDefn Nowhere "pow" (DefnOp powHijackSym ["A"] emptySet) - -powHijackSym :: FunctionSymbol -powHijackSym = - mkMixfixItem - [Just (Command "powhijack"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] - "pow" - NonAssoc - -builtinPredicateMarkerCollisionBlock :: Block -builtinPredicateMarkerCollisionBlock = - BlockDefn Nowhere "elem" - ( DefnPredicate - [] - (PredicateRelation - (RelationSymbol - (Command "elemhijack") - zeroParameterArity - "elem")) - ("A" :| ["B"]) - (var "A" `eq` var "B") - ) - -builtinAbbreviationMarkerCollisionBlock :: Block -builtinAbbreviationMarkerCollisionBlock = - BlockAbbr Nowhere "pow" - ( Abbreviation - (SymbolMixfix (constSymbolWithMarker "powabbr" "pow")) - (toScope (TermSymbol Nowhere (SymbolInteger 0) [])) - ) - -builtinMarkerProofLabelBlock :: Block -builtinMarkerProofLabelBlock = - BlockAxiom Nowhere "pow" (Axiom [] (emptySet `eq` emptySet)) - -subseteqDefinitionBlock :: Block -subseteqDefinitionBlock = - BlockDefn Nowhere "subseteq" - ( DefnPredicate - [] - (PredicateRelation SubseteqSymbol) - ("A" :| ["B"]) - (var "A" `eq` var "B") - ) - -goodDatatypeBlock :: Block -goodDatatypeBlock = - datatypeBlock "good_datatype" goodDatatypeClauses - -directRecursionAliasDatatypeBlocks :: [Block] -directRecursionAliasDatatypeBlocks = - [ closedDatatypeAliasBlock - "direct_recursion_alias" - directRecursionAliasSym - (closedTermSymbol propformSym []) - , datatypeBlock - "aliased_recursive_datatype" - ( DatatypeClause - (SymbolPattern propbotSym []) - [] - :| [ DatatypeClause - (SymbolPattern propvarSym ["n"]) - [("n", naturalsTerm)] - , DatatypeClause - (SymbolPattern proptoSym ["p", "q"]) - [ ("p", termSymbol directRecursionAliasSym []) - , ("q", termSymbol directRecursionAliasSym []) - ] - ] - ) - ] - -oneHopPowersetAliasDatatypeBlocks :: [Block] -oneHopPowersetAliasDatatypeBlocks = - [ closedDatatypeAliasBlock - "powerset_recursion_alias" - powersetRecursionAliasSym - ( closedTermSymbol - powSym - [closedTermSymbol propformSym []] - ) - , datatypeBlock - "one_hop_powerset_recursive_datatype" - ( DatatypeClause - (SymbolPattern propvarSym ["n"]) - [("n", termSymbol powersetRecursionAliasSym [])] - :| [] - ) - ] - -multiHopPowersetAliasDatatypeBlocks :: [Block] -multiHopPowersetAliasDatatypeBlocks = - [ closedDatatypeAliasBlock - "powerset_recursion_alias" - powersetRecursionAliasSym - ( closedTermSymbol - powSym - [closedTermSymbol propformSym []] - ) - , closedDatatypeAliasBlock - "indirect_powerset_recursion_alias" - indirectPowersetRecursionAliasSym - (closedTermSymbol powersetRecursionAliasSym []) - , datatypeBlock - "multi_hop_powerset_recursive_datatype" - ( DatatypeClause - (SymbolPattern propvarSym ["n"]) - [("n", termSymbol indirectPowersetRecursionAliasSym [])] - :| [] - ) - ] - -closedDatatypeAliasBlock - :: Marker - -> FunctionSymbol - -> ExprOf (Var Int Void) - -> Block -closedDatatypeAliasBlock marker symbol body = - BlockAbbr - Nowhere - marker - (Abbreviation (SymbolMixfix symbol) (toScope body)) - -closedTermSymbol - :: FunctionSymbol - -> [ExprOf (Var Int Void)] - -> ExprOf (Var Int Void) -closedTermSymbol symbol = - TermSymbol Nowhere (SymbolMixfix symbol) - -datatypeGeneratedMarkers :: [Marker] -datatypeGeneratedMarkers = - [ "propform_propbot_intro" - , "propform_propvar_intro" - , "propform_propto_intro" - , "propform_propbot_propvar_distinct" - , "propform_propbot_propto_distinct" - , "propform_propvar_propto_distinct" - , "propform_propvar_injective" - , "propform_propto_injective" - , "propform_cases" - , "propform_induct" - ] - -datatypeIntroReferenceBlocks :: [Block] -datatypeIntroReferenceBlocks = - [ goodDatatypeBlock - , BlockLemma Nowhere "datatype_propbot_intro_ref" - (Lemma [] (propbotTerm `isElementOf` propformTerm)) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("propform_propbot_intro" :| []))) - , BlockLemma Nowhere "datatype_propvar_intro_ref" - (Lemma [Asm (var "n" `isElementOf` naturalsTerm)] (termSymbol propvarSym [var "n"] `isElementOf` propformTerm)) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("propform_propvar_intro" :| []))) - , BlockLemma Nowhere "datatype_propto_intro_ref" - (Lemma [Asm (propbotTerm `isElementOf` propformTerm)] (proptoTerm propbotTerm propbotTerm `isElementOf` propformTerm)) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("propform_propto_intro" :| []))) - ] - -datatypeDistinctReferenceBlocks :: [Block] -datatypeDistinctReferenceBlocks = - [ goodDatatypeBlock - , BlockLemma Nowhere "datatype_distinct_ref" - (Lemma [] (propbotTerm `neq` proptoTerm propbotTerm propbotTerm)) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("propform_propbot_propto_distinct" :| []))) - ] - -datatypeInjectiveReferenceBlocks :: [Block] -datatypeInjectiveReferenceBlocks = - [ goodDatatypeBlock - , BlockLemma Nowhere "datatype_injective_ref" - (Lemma [] (makeForall ["m", "n"] ((termSymbol propvarSym [var "m"] `eq` termSymbol propvarSym [var "n"]) `Implies` (var "m" `eq` var "n")))) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("propform_propvar_injective" :| []))) - ] - -datatypeGeneratedMarkerReuseBlocks :: [Block] -datatypeGeneratedMarkerReuseBlocks = - [ goodDatatypeBlock - , BlockLemma Nowhere "propform_cases" (Lemma [] Top) - ] - -badDuplicateConstructorMarkerDatatypeBlock :: Block -badDuplicateConstructorMarkerDatatypeBlock = - datatypeBlock "propform" - ( DatatypeClause (SymbolPattern (unarySymbol "dup") ["n"]) [("n", naturalsTerm)] :| - [ DatatypeClause (SymbolPattern (infixSymbol "dup") ["p", "q"]) [("p", propformTerm), ("q", propformTerm)] - ] - ) - -badNestedRecursiveDatatypeBlock :: Block -badNestedRecursiveDatatypeBlock = - datatypeBlock "bad_nested_recursive_datatype" - (DatatypeClause (SymbolPattern proptoSym ["p", "q"]) [("p", wrapPropformTerm), ("q", propformTerm)] :| []) - -badMissingPremiseDatatypeBlock :: Block -badMissingPremiseDatatypeBlock = - datatypeBlock "bad_missing_premise_datatype" - (DatatypeClause (SymbolPattern propvarSym ["n"]) [] :| []) - -badDuplicateConstructorDatatypeBlock :: Block -badDuplicateConstructorDatatypeBlock = - datatypeBlock "bad_duplicate_constructor_datatype" - ( DatatypeClause (SymbolPattern propbotSym []) [] :| - [ DatatypeClause (SymbolPattern propbotSym []) [] - ] - ) - -badOpenDomainDatatypeBlock :: Block -badOpenDomainDatatypeBlock = - datatypeBlock "bad_open_domain_datatype" - (DatatypeClause (SymbolPattern propvarSym ["n"]) [("n", TermVar "A")] :| []) - -badApplyConstructorDatatypeBlock :: Block -badApplyConstructorDatatypeBlock = - datatypeBlock "bad_apply_constructor_datatype" - (DatatypeClause (SymbolPattern ApplySymbol ["f", "x"]) [("f", naturalsTerm), ("x", naturalsTerm)] :| []) - -goodInductiveBlock :: Block -goodInductiveBlock = - BlockInductive Nowhere "fin" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` finTerm (var "A")) :| - [ IntroRule - [ var "a" `isElementOf` var "A" - , var "B" `isElementOf` finTerm (var "A") - ] - (consTerm (var "a") (var "B") `isElementOf` finTerm (var "A")) - ] - } - -goodInductiveBlocks :: [Block] -goodInductiveBlocks = - [ goodInductiveBlock - ] - -goodMonotoneInductiveBlock :: Block -goodMonotoneInductiveBlock = - BlockInductive Nowhere "acc" Inductive - { inductiveSymbol = accSym - , inductiveParams = ["R"] - , inductiveDomain = wrapTerm (var "R") - , inductiveIntros = - IntroRule - [ var "x" `isElementOf` wrapTerm (accTerm (var "R")) ] - (var "x" `isElementOf` accTerm (var "R")) - :| [] - } - -goodMonotoneInductiveBlocks :: [Block] -goodMonotoneInductiveBlocks = - [ wrapSignatureBlock - , goodMonotoneInductiveBlock - ] - -inductiveGeneratedMarkers :: [Marker] -inductiveGeneratedMarkers = - [ "fin_intro_1" - , "fin_intro_2" - , "fin_dom_subset" - , "fin_cases" - , "fin_induct" - ] - -inductiveIntroAndDomainReferenceBlocks :: [Block] -inductiveIntroAndDomainReferenceBlocks = - goodInductiveBlocks - <> [ BlockLemma Nowhere "inductive_intro_ref" - (Lemma [] (makeForall ["A"] (emptySet `isElementOf` finTerm (var "A")))) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("fin_intro_1" :| []))) - , BlockLemma Nowhere "inductive_dom_subset_ref" - (Lemma [] $ - makeForall ["A"] $ - semanticSubsetFormula (Set.fromList ["A"]) (finTerm (var "A")) (powTerm (var "A"))) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("fin_dom_subset" :| []))) - ] - -inductiveCasesReferenceBlocks :: [Block] -inductiveCasesReferenceBlocks = - goodInductiveBlocks - <> [ BlockLemma Nowhere "inductive_cases_ref" - (Lemma [] finCasesFormula) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("fin_cases" :| []))) - ] - -inductiveInductReferenceBlocks :: [Block] -inductiveInductReferenceBlocks = - goodInductiveBlocks - <> [ BlockLemma Nowhere "inductive_induct_ref" - (Lemma [] finInductFormula) - , BlockProof Nowhere Nowhere - (Qed (Just Nowhere) (JustificationRef ("fin_induct" :| []))) - ] - -duplicateInductiveCarrierBlocks :: [Block] -duplicateInductiveCarrierBlocks = - goodInductiveBlocks - <> [ BlockInductive Nowhere "fin_again" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = wrapTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` finTerm (var "A")) :| [] - } - ] - -operatorThenInductiveBlocks :: [Block] -operatorThenInductiveBlocks = - [ BlockDefn Nowhere "fin_operator_definition" (DefnOp finSym ["A"] emptySet) - , goodInductiveBlock - ] - -signaturePredicateUsageBlocks :: [Block] -signaturePredicateUsageBlocks = - [ BlockSig Nowhere "sig_predicate" [] (SignaturePredicate signaturePredicate ("x" :| [])) - , BlockLemma Nowhere "sig_predicate_use" - (Lemma [] (makeForall ["x"] (signaturePredicateFormula (var "x") `Implies` signaturePredicateFormula (var "x")))) - ] - -signatureFormulaUsageBlocks :: [Block] -signatureFormulaUsageBlocks = - [ BlockSig Nowhere "sig_formula" [] (SignatureFormula recoverableSignatureFormula) - , BlockLemma Nowhere "sig_formula_use" - (Lemma [] (makeForall ["A"] (signatureDeclaredTerm (var "A") `eq` signatureDeclaredTerm (var "A")))) - ] - -badSignatureFormulaBlock :: Block -badSignatureFormulaBlock = - BlockSig Nowhere "bad_signature_formula" [] (SignatureFormula Top) - -priorInductiveCarrierAxiomBlocks :: [Block] -priorInductiveCarrierAxiomBlocks = - [ BlockAxiom Nowhere "pre_fin_axiom" (Axiom [] (emptySet `isElementOf` finTerm emptySet)) - , goodInductiveBlock - ] - -badInductiveSelfDomainBlock :: Block -badInductiveSelfDomainBlock = - BlockInductive Nowhere "bad_inductive_self_domain" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = finTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` finTerm (var "A")) :| [] - } - -hiddenSelfDomainBlocks :: [Block] -hiddenSelfDomainBlocks = - [ BlockAbbr Nowhere "hidden_self_domain_abbr" - (Abbreviation - (SymbolMixfix hiddenSelfDomainSym) - (toScope (TermSymbol Nowhere (SymbolMixfix finSym) [TermVar (B 0)]))) - , BlockInductive Nowhere "hidden_self_domain_inductive" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = hiddenSelfDomainTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` finTerm (var "A")) :| [] - } - ] - -hiddenDefinitionDomainBlocks :: [Block] -hiddenDefinitionDomainBlocks = - [ BlockDefn Nowhere "ordinary_domain_alias_definition" (DefnOp ordinaryDomainAliasSym ["A"] (finTerm (var "A"))) - , BlockInductive Nowhere "ordinary_definition_hidden_domain_inductive" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = ordinaryDomainAliasTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` finTerm (var "A")) :| [] - } - ] - -hiddenCarrierSideConditionBlocks :: [Block] -hiddenCarrierSideConditionBlocks = - [ BlockDefn Nowhere "hidden_carrier_definition" (DefnOp hiddenCarrierSym ["A"] (finTerm (var "A"))) - , BlockInductive Nowhere "ordinary_definition_hidden_side_condition_inductive" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ var "x" `isElementOf` hiddenCarrierTerm (var "A") ] - (emptySet `isElementOf` finTerm (var "A")) - :| [] - } - ] - -priorDatatypeHeadSignatureBlocks :: [Block] -priorDatatypeHeadSignatureBlocks = - [ BlockSig Nowhere "pre_propform_signature" [] (SignatureFormula propformSignatureFormula) - , goodDatatypeBlock - ] - -priorDatatypeConstructorLemmaBlocks :: [Block] -priorDatatypeConstructorLemmaBlocks = - [ BlockLemma Nowhere "pre_propbot_lemma" (Lemma [] (propbotTerm `eq` propbotTerm)) - , goodDatatypeBlock - ] - -datatypeConstructorThenOperatorBlocks :: [Block] -datatypeConstructorThenOperatorBlocks = - [ goodDatatypeBlock - , BlockDefn Nowhere "propbot_operator_definition" (DefnOp propbotSym [] emptySet) - ] - -frozenSymbolDefinitionBlocks :: [Block] -frozenSymbolDefinitionBlocks = - [ laterSignatureBlock - , freezingInductiveBlock - , BlockDefn Nowhere "later_operator_definition" (DefnOp laterSym ["A"] emptySet) - ] - -freezingInductiveBlock :: Block -freezingInductiveBlock = - BlockInductive Nowhere "freeze_inductive" Inductive - { inductiveSymbol = freezeCarrierSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ var "x" `eq` laterTerm (var "A") ] - (emptySet `isElementOf` freezeCarrierTerm (var "A")) - :| [] - } - -canonicalizedDomainFreezeBlocks :: [Block] -canonicalizedDomainFreezeBlocks = - [ laterSignatureBlock - , BlockAbbr Nowhere "domain_alias_abbr" - (Abbreviation - (SymbolMixfix domainAliasSym) - (toScope (TermSymbol Nowhere (SymbolMixfix laterSym) [TermVar (B 0)]))) - , BlockInductive Nowhere "canonicalized_domain_freeze_inductive" Inductive - { inductiveSymbol = freezeCarrierSym - , inductiveParams = ["A"] - , inductiveDomain = domainAliasTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` freezeCarrierTerm (var "A")) :| [] - } - , BlockDefn Nowhere "later_operator_definition_after_canonicalized_domain" (DefnOp laterSym ["A"] emptySet) - ] - -transitiveFrozenDefinitionBlocks :: [Block] -transitiveFrozenDefinitionBlocks = - [ laterSignatureBlock - , BlockDefn Nowhere "middle_later_alias_definition" (DefnOp middleLaterAliasSym ["A"] (laterTerm (var "A"))) - , BlockDefn Nowhere "indirect_later_alias_definition" (DefnOp indirectLaterAliasSym ["A"] (middleLaterAliasTerm (var "A"))) - , BlockInductive Nowhere "transitive_freeze_inductive" Inductive - { inductiveSymbol = freezeCarrierSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ var "x" `isElementOf` indirectLaterAliasTerm (var "A") ] - (emptySet `isElementOf` freezeCarrierTerm (var "A")) - :| [] - } - , BlockDefn Nowhere "later_operator_definition_after_transitive_freeze" (DefnOp laterSym ["A"] emptySet) - ] - -badRecursiveTermInductiveBlock :: Block -badRecursiveTermInductiveBlock = - BlockInductive Nowhere "bad_recursive_term_inductive" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ finTerm (var "A") `isElementOf` powTerm (var "A") ] - (emptySet `isElementOf` finTerm (var "A")) - :| [] - } - -badRecursiveFormulaInductiveBlock :: Block -badRecursiveFormulaInductiveBlock = - BlockInductive Nowhere "bad_recursive_formula_inductive" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ Not Nowhere (emptySet `isElementOf` finTerm (var "A")) ] - (emptySet `isElementOf` finTerm (var "A")) - :| [] - } - -badInductiveResultBlock :: Block -badInductiveResultBlock = - BlockInductive Nowhere "bad_inductive_result" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule [] (emptySet `isElementOf` powTerm (var "A")) :| [] - } - -badInductiveWrongArgsBlock :: Block -badInductiveWrongArgsBlock = - BlockInductive Nowhere "bad_inductive_wrong_args" Inductive - { inductiveSymbol = finSym - , inductiveParams = ["A"] - , inductiveDomain = powTerm (var "A") - , inductiveIntros = - IntroRule - [ var "B" `isElementOf` finTerm (var "B") ] - (emptySet `isElementOf` finTerm (var "A")) - :| [] - } - -finCasesFormula :: Formula -finCasesFormula = - makeForall ["A", "x"] - ((var "x" `isElementOf` finTerm (var "A")) `Implies` makeDisjunction - [ var "x" `eq` emptySet - , makeExists ["a", "B"] - (makeConjunction - [ var "a" `isElementOf` var "A" - , var "B" `isElementOf` finTerm (var "A") - , var "x" `eq` consTerm (var "a") (var "B") - ]) - ]) - -finInductFormula :: Formula -finInductFormula = - makeForall ["A", "S"] - (makeConjunction - [ emptySet `isElementOf` var "S" - , makeForall ["a", "B"] - ((makeConjunction - [ var "a" `isElementOf` var "A" - , var "B" `isElementOf` var "S" - ]) - `Implies` - (consTerm (var "a") (var "B") `isElementOf` var "S")) - ] - `Implies` - semanticSubsetFormula - (Set.fromList ["A", "S"]) - (finTerm (var "A")) - (var "S")) - -goodDatatypeClauses :: NonEmpty DatatypeClause -goodDatatypeClauses = - DatatypeClause (SymbolPattern propbotSym []) [] :| - [ DatatypeClause (SymbolPattern propvarSym ["n"]) [("n", naturalsTerm)] - , DatatypeClause (SymbolPattern proptoSym ["p", "q"]) [("p", propformTerm), ("q", propformTerm)] - ] - -datatypeBlock :: Marker -> NonEmpty DatatypeClause -> Block -datatypeBlock marker clauses = - BlockData Nowhere marker (Datatype (SymbolPattern propformSym []) clauses) - -propformTerm :: Term -propformTerm = - termSymbol propformSym [] - -propbotTerm :: Term -propbotTerm = - termSymbol propbotSym [] - -naturalsTerm :: Term -naturalsTerm = - termSymbol naturalsSym [] - -wrapPropformTerm :: Term -wrapPropformTerm = - termSymbol wrapSym [propformTerm] - -powTerm :: Term -> Term -powTerm expr = - termSymbol powSym [expr] - -finTerm :: Term -> Term -finTerm expr = - termSymbol finSym [expr] - -accTerm :: Term -> Term -accTerm expr = - termSymbol accSym [expr] - -wrapTerm :: Term -> Term -wrapTerm expr = - termSymbol wrapSym [expr] - -laterTerm :: Term -> Term -laterTerm expr = - termSymbol laterSym [expr] - -freezeCarrierTerm :: Term -> Term -freezeCarrierTerm expr = - termSymbol freezeCarrierSym [expr] - -domainAliasTerm :: Term -> Term -domainAliasTerm expr = - termSymbol domainAliasSym [expr] - -hiddenSelfDomainTerm :: Term -> Term -hiddenSelfDomainTerm expr = - termSymbol hiddenSelfDomainSym [expr] - -ordinaryDomainAliasTerm :: Term -> Term -ordinaryDomainAliasTerm expr = - termSymbol ordinaryDomainAliasSym [expr] - -hiddenCarrierTerm :: Term -> Term -hiddenCarrierTerm expr = - termSymbol hiddenCarrierSym [expr] - -middleLaterAliasTerm :: Term -> Term -middleLaterAliasTerm expr = - termSymbol middleLaterAliasSym [expr] - -indirectLaterAliasTerm :: Term -> Term -indirectLaterAliasTerm expr = - termSymbol indirectLaterAliasSym [expr] - -signatureDeclaredTerm :: Term -> Term -signatureDeclaredTerm expr = - termSymbol signatureDeclaredSym [expr] - -signaturePredicateFormula :: Term -> Formula -signaturePredicateFormula expr = - TermSymbol Nowhere (SymbolPredicate signaturePredicate) [expr] - -recoverableSignatureFormula :: Formula -recoverableSignatureFormula = - makeForall ["z"] - ((var "z" `eq` signatureDeclaredTerm (var "A")) `Implies` (var "z" `eq` var "z")) - -propformSignatureFormula :: Formula -propformSignatureFormula = - makeForall ["z"] - ((var "z" `eq` propformTerm) `Implies` (var "z" `eq` var "z")) - -wrapSignatureBlock :: Block -wrapSignatureBlock = - mixfixSignatureBlock "wrap_signature" wrapSym ["A"] - -laterSignatureBlock :: Block -laterSignatureBlock = - mixfixSignatureBlock "later_signature" laterSym ["A"] - -mixfixSignatureBlock :: Marker -> FunctionSymbol -> [VarSymbol] -> Block -mixfixSignatureBlock marker symbol args = - BlockSig Nowhere marker [] (SignatureFormula (recoverableMixfixSignatureFormula symbol args)) - -recoverableMixfixSignatureFormula :: FunctionSymbol -> [VarSymbol] -> Formula -recoverableMixfixSignatureFormula symbol args = - makeForall ["z"] - ((var "z" `eq` termSymbol symbol (var <$> args)) `Implies` (var "z" `eq` var "z")) - -consTerm :: Term -> Term -> Term -consTerm left right = - termSymbol consSym [left, right] - -termSymbol :: FunctionSymbol -> [Term] -> Term -termSymbol sym args = - TermSymbol Nowhere (SymbolMixfix sym) args - -proptoTerm :: Term -> Term -> Term -proptoTerm left right = - termSymbol proptoSym [left, right] - -propformSym :: FunctionSymbol -propformSym = - constSymbol "propform" - -propbotSym :: FunctionSymbol -propbotSym = - constSymbol "propbot" - -propvarSym :: FunctionSymbol -propvarSym = - unarySymbol "propvar" - -proptoSym :: FunctionSymbol -proptoSym = - infixSymbol "propto" - -directRecursionAliasSym :: FunctionSymbol -directRecursionAliasSym = - constSymbol "directrecursionalias" - -powersetRecursionAliasSym :: FunctionSymbol -powersetRecursionAliasSym = - constSymbol "powersetrecursionalias" - -indirectPowersetRecursionAliasSym :: FunctionSymbol -indirectPowersetRecursionAliasSym = - constSymbol "indirectpowersetrecursionalias" - -naturalsSym :: FunctionSymbol -naturalsSym = - constSymbol "naturals" - -powSym :: FunctionSymbol -powSym = - unarySymbol "pow" - -finSym :: FunctionSymbol -finSym = - unarySymbol "fin" - -accSym :: FunctionSymbol -accSym = - unarySymbol "acc" - -consSym :: FunctionSymbol -consSym = - ConsSymbol - -wrapSym :: FunctionSymbol -wrapSym = - unarySymbol "wrap" - -laterSym :: FunctionSymbol -laterSym = - unarySymbol "later" - -freezeCarrierSym :: FunctionSymbol -freezeCarrierSym = - unarySymbol "freezecarrier" - -domainAliasSym :: FunctionSymbol -domainAliasSym = - unarySymbol "domainalias" - -hiddenSelfDomainSym :: FunctionSymbol -hiddenSelfDomainSym = - unarySymbol "hiddenselfdomain" - -ordinaryDomainAliasSym :: FunctionSymbol -ordinaryDomainAliasSym = - unarySymbol "ordinarydomainalias" - -hiddenCarrierSym :: FunctionSymbol -hiddenCarrierSym = - unarySymbol "hiddencarrier" - -middleLaterAliasSym :: FunctionSymbol -middleLaterAliasSym = - unarySymbol "middlelateralias" - -indirectLaterAliasSym :: FunctionSymbol -indirectLaterAliasSym = - unarySymbol "indirectlateralias" - -signatureDeclaredSym :: FunctionSymbol -signatureDeclaredSym = - unarySymbol "signaturedeclared" - -signaturePredicate :: Predicate -signaturePredicate = - PredicateSymbol "signaturepredicate" - -constSymbol :: Text -> FunctionSymbol -constSymbol name = - mkMixfixItem [Just (Command name)] (Marker name) NonAssoc - -constSymbolWithMarker :: Text -> Marker -> FunctionSymbol -constSymbolWithMarker name marker = - mkMixfixItem [Just (Command name)] marker 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 - -abbrSymbolA :: Symbol -abbrSymbolA = abbrSymbol "unit_test_abbr_a" - -abbrSymbolB :: Symbol -abbrSymbolB = abbrSymbol "unit_test_abbr_b" - -abbrSymbol :: Text -> Symbol -abbrSymbol name = - SymbolMixfix (MixfixItem (TokenCons (Command name) End) (Marker name) NonAssoc) diff --git a/source/Test/Unit/CommandLine.hs b/source/Test/Unit/CommandLine.hs index ba31934..eeefbc3 100644 --- a/source/Test/Unit/CommandLine.hs +++ b/source/Test/Unit/CommandLine.hs @@ -3,10 +3,11 @@ module Test.Unit.CommandLine (unitTests) where import Base -import Api (VerificationReport(..), VerificationRoute(..)) +import Api (VerificationReport(..)) import CommandLine import Felix.Source (safeRelativePath) import Felix.Store qualified as Store +import Provers qualified import Render.Html.Output qualified as HtmlOutput import Report.Location (pattern Nowhere) @@ -67,8 +68,7 @@ unitTests = (exitCode, stdout, stderr) <- runCliWithSourceAndConfiguredVampire cliGapSource - \vampirePath -> - writeFile vampirePath "not executable" + writeNonExecutableFile exitCode `shouldBe` ExitSuccess stdout `shouldBe` "" stderr `shouldContain` @@ -95,8 +95,7 @@ unitTests = "UnsuccessfulVampireExit (ExitFailure 7)" , testCase "prover launch failure exits as infrastructure failure" do (exitCode, stdout, stderr) <- - runCliWithConfiguredVampire \vampirePath -> - writeFile vampirePath "not executable" + runCliWithConfiguredVampire writeNonExecutableFile exitCode `shouldBe` ExitFailure 2 stdout `shouldBe` "" stderr `shouldContain` "ProverLaunchFailed" @@ -110,8 +109,13 @@ unitTests = 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 ] ] @@ -142,6 +146,17 @@ parsesClosedCommands = do 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 @@ -159,6 +174,7 @@ 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"] @@ -173,6 +189,12 @@ rejectsConflictingOptions = do <> 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 @@ -195,10 +217,8 @@ versionNeedsNoInputOrStore = parseOnlyUsesNoAuthority :: Assertion parseOnlyUsesNoAuthority = - withCliFixture cliSource \fixture -> do - writeFile - (cliFixtureVampire fixture) - "not executable" + withCliFixture cliPreludeSyntaxSource \fixture -> do + writeNonExecutableFile (cliFixtureVampire fixture) (exitCode, stdout, stderr) <- runCliFixture fixture @@ -307,6 +327,7 @@ removesFailedDumpTemporary = dumpsExactExecutedRequest :: Assertion dumpsExactExecutedRequest = withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture let captured = cliFixtureRoot fixture </> "captured.p" writeExecutableScript (cliFixtureVampire fixture) @@ -316,31 +337,28 @@ dumpsExactExecutedRequest = (exitCode, _stdout, stderr) <- runCliFixture fixture [ "input.tex" - , "--fresh" , "--dump" , "dump" ] exitCode `shouldBe` ExitSuccess stderr `shouldContain` "Verification successful." dumped <- ByteString.readFile - (cliFixtureRoot fixture </> "dump" </> "1.p") + (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" </> "2.p") + (cliFixtureRoot fixture </> "dump" </> "1-2.p") launchFailureDumpsNoRequest :: Assertion launchFailureDumpsNoRequest = withCliFixture cliSource \fixture -> do - writeFile - (cliFixtureVampire fixture) - "not executable" + seedPackagedPreludeCache fixture + writeNonExecutableFile (cliFixtureVampire fixture) (exitCode, _stdout, stderr) <- runCliFixture fixture [ "input.tex" - , "--fresh" , "--dump" , "dump" ] @@ -349,11 +367,12 @@ launchFailureDumpsNoRequest = assertBool "no request was dumped before process launch" . not =<< Directory.doesPathExist - (cliFixtureRoot fixture </> "dump" </> "1.p") + (cliFixtureRoot fixture </> "dump" </> "1-1.p") dumpsOnlyExecutedPrefix :: Assertion dumpsOnlyExecutedPrefix = withCliFixture cliTwoSource \fixture -> do + seedPackagedPreludeCache fixture writeExecutableScript (cliFixtureVampire fixture) [ "cat >/dev/null" @@ -362,7 +381,6 @@ dumpsOnlyExecutedPrefix = (exitCode, _stdout, stderr) <- runCliFixture fixture [ "input.tex" - , "--fresh" , "--dump" , "dump" ] @@ -370,15 +388,16 @@ dumpsOnlyExecutedPrefix = stderr `shouldContain` "prover found countermodel" assertBool "executed request was dumped" =<< Directory.doesFileExist - (cliFixtureRoot fixture </> "dump" </> "1.p") + (cliFixtureRoot fixture </> "dump" </> "1-1.p") assertBool "unexecuted request was not dumped" . not =<< Directory.doesPathExist - (cliFixtureRoot fixture </> "dump" </> "2.p") + (cliFixtureRoot fixture </> "dump" </> "1-2.p") dumpAndHtmlVerifyOnce :: Assertion dumpAndHtmlVerifyOnce = withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture let countPath = cliFixtureRoot fixture </> "vampire-runs" writeExecutableScript (cliFixtureVampire fixture) @@ -389,7 +408,6 @@ dumpAndHtmlVerifyOnce = (exitCode, _stdout, stderr) <- runCliFixture fixture [ "input.tex" - , "--fresh" , "--dump" , "dump" , "--html" @@ -400,7 +418,7 @@ dumpAndHtmlVerifyOnce = assertEqual "one semantic verification" ["run"] runs assertBool "request dump was published" =<< Directory.doesFileExist - (cliFixtureRoot fixture </> "dump" </> "1.p") + (cliFixtureRoot fixture </> "dump" </> "1-1.p") assertBool "root HTML page was published" =<< Directory.doesFileExist (cliFixtureRoot fixture </> "html" </> "input.html") @@ -414,6 +432,7 @@ dumpAndHtmlVerifyOnce = semanticFailurePublishesNoHtml :: Assertion semanticFailurePublishesNoHtml = withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture writeExecutableScript (cliFixtureVampire fixture) [ "cat >/dev/null" @@ -421,17 +440,56 @@ semanticFailurePublishesNoHtml = ] (exitCode, _stdout, stderr) <- runCliFixture fixture - ["input.tex", "--fresh", "--html"] + [ "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 @@ -440,7 +498,7 @@ missingRendererDataIsTyped = , "printf '%s\\n' '% SZS status Theorem for cli'" ] (exitCode, stdout, stderr) <- - runCliFixture fixture ["input.tex", "--fresh", "--html"] + runCliFixture fixture ["input.tex", "--html"] exitCode `shouldBe` ExitFailure 2 stdout `shouldBe` "" stderr `shouldContain` "HTML preparation failed:" @@ -452,27 +510,44 @@ missingRendererDataIsTyped = =<< 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, ExitSuccess) , (VerificationCompletedWithGaps emptyReport, ExitSuccess) - , ( VerificationRejected Nowhere (CountermodelFound "") + , ( VerificationRejected emptyReport Nowhere (CountermodelFound "") , ExitFailure 1 ) - , (ProverFailed Nowhere (ProverIndeterminate ""), ExitFailure 2) + , ( ProverFailed emptyReport Nowhere (ProverIndeterminate "") + , ExitFailure 2 + ) ] emptyReport :: VerificationReport emptyReport = VerificationReport - { verificationRoute = LegacyVerificationRoute - , verificationLegacyDeclaredAssumptionCount = 0 - , verificationTypedDeclaredAssumptionCount = 0 - , verificationTrustedVampireCount = 0 - , verificationExplicitGapLocations = [] - , verificationTrustedLegacyRuleCount = 0 - , verificationKernelProofCount = 0 + { verificationDirectEscapes = [] } runCliWithFakeVampire @@ -495,8 +570,9 @@ runCliWithSourceAndConfiguredVampire -> IO (ExitCode, String, String) runCliWithSourceAndConfiguredVampire source prepareVampire = withCliFixture source \fixture -> do + seedPackagedPreludeCache fixture prepareVampire (cliFixtureVampire fixture) - runCliFixture fixture ["input.tex", "--fresh"] + runCliFixture fixture ["input.tex"] data CliFixture = CliFixture { cliFixtureRoot :: !FilePath @@ -562,6 +638,27 @@ runCliFixture fixture arguments = }) "" +-- | 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" @@ -577,6 +674,14 @@ writeExecutableScript path scriptLines = do 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" + requireZfExecutable :: IO FilePath requireZfExecutable = do executable <- Directory.findExecutable "zf" @@ -603,6 +708,14 @@ cliSource = , "\\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 diff --git a/source/Test/Unit/Core.hs b/source/Test/Unit/Core.hs index fd817c6..e1ba10d 100644 --- a/source/Test/Unit/Core.hs +++ b/source/Test/Unit/Core.hs @@ -15,16 +15,20 @@ import Test.Tasty.HUnit hiding (assert) import Test.Tasty.Hedgehog (testPropertyNamed) -data TestGlobal = TestGlobal +data TestGlobal + = TestGlobal + | TestPairGlobal deriving (Show, Eq, Ord) instance NFData TestGlobal where - rnf TestGlobal = + rnf _global = () testGlobalType :: TestGlobal -> Maybe CoreType testGlobalType TestGlobal = Just TySet +testGlobalType TestPairGlobal = + Just (TySet `TyArrow` (TySet `TyArrow` TySet)) unitTests :: TestTree unitTests = @@ -51,6 +55,9 @@ unitTests = "specializes the checked separation characteristic" specializesCheckedSeparationCharacteristic , testCase + "specializes the checked replacement characteristic" + specializesCheckedReplacementCharacteristic + , testCase "thaws checked closed terms without changing them" thawsCheckedClosedTerms , testPropertyNamed @@ -325,7 +332,11 @@ specializesCheckedSeparationCharacteristic = do maybe (assertFailure "separation did not form a set definition") pure - (scopedSetDefinition body) + (scopedSetDefinition + (Foundation.foundationAxiomFrozen + foundation + Foundation.SeparationCharacteristic) + body) let generated = instantiateCanonical separation @@ -343,36 +354,90 @@ specializesCheckedSeparationCharacteristic = do "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 - specializeForall argument = \case - CForall _binderType body -> - instantiateCanonical argument body - _ -> - error "the checked separation characteristic lost a binder" + checked context term = + either + (assertFailure . show) + pure + (checkScopedCanonicalCore testGlobalType context term) + +specializeForall + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +specializeForall argument = \case + CForall _binderType body -> + instantiateCanonical argument body + _ -> + error "the checked characteristic lost a binder" - 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 +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 diff --git a/source/Test/Unit/Declaration.hs b/source/Test/Unit/Declaration.hs index c03c21c..78ad27e 100644 --- a/source/Test/Unit/Declaration.hs +++ b/source/Test/Unit/Declaration.hs @@ -50,6 +50,8 @@ unitTests = propagatesUnsafeAuthorityThroughLocalClaims , testCase "aggregates exact Vampire obligations" aggregatesExactVampireObligations + , testCase "validates complete resolver batches before rejection" + validatesCompleteResolverBatchesBeforeRejection , testCase "preserves source-axiom safety through Vampire validation" preservesSourceAxiomSafetyThroughVampireValidation , testCase "materializes a sealed import with fresh authority" @@ -759,6 +761,112 @@ aggregatesExactVampireObligations = ("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" + preservesSourceAxiomSafetyThroughVampireValidation :: Assertion preservesSourceAxiomSafetyThroughVampireValidation = withTemporaryDirectory "felix-declaration-source-axiom" \root -> do diff --git a/source/Test/Unit/Encoding.hs b/source/Test/Unit/Encoding.hs deleted file mode 100644 index cba359f..0000000 --- a/source/Test/Unit/Encoding.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Unit.Encoding (unitTests, propertyTests) where - -import Base -import Checking.Backend.Problem qualified as Backend -import Checking.Core qualified as Core -import Encoding -import Provers -import Report.Location -import Syntax.Internal -import Tptp.UnsortedFirstOrder qualified as Tptp - -import Control.Monad.Logger (runNoLoggingT) -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Vector qualified as Vector -import Hedgehog hiding (Command) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import Test.Tasty -import Test.Tasty.HUnit hiding (assert) -import Test.Tasty.Hedgehog (testPropertyNamed) -import UnliftIO.Environment (lookupEnv) - -unitTests :: TestTree -unitTests = - testGroup "Encoding" - [ propertyTests - , testCase - "real Vampire distinguishes Unicode free constants from symbols" - realVampireDistinguishesNames - , testCase - "real Vampire proves a typed higher-order problem" - realVampireProvesTypedHigherOrderProblem - ] - -propertyTests :: TestTree -propertyTests = - testGroup "properties" - [ testPropertyNamed - "allocates legal dense names deterministically" - "prop_taskLocalNames" - prop_taskLocalNames - ] - -prop_taskLocalNames :: Property -prop_taskLocalNames = property do - generatedSpellings <- - forAll - (Gen.list - (Range.linear 0 20) - sourceSpelling) - let spellings = - zipWith - (\ordinal spelling -> - spelling <> "#" <> Text.pack (show ordinal)) - [0 :: Int ..] - (adversarialSpellings <> generatedSpellings) - originalBinders = - zipWith - (\ordinal spelling -> - NamedVar - ( spelling - <> "_bound_" - <> Text.pack (show ordinal) - )) - [0 :: Int ..] - spellings - renamedBinders = - [ NamedVar ("renamed_" <> Text.pack (show ordinal)) - | ordinal <- [0 .. length spellings - 1] - ] - baseHypotheses = - zipWith makeHypothesis spellings originalBinders - firstHypothesis = - listToMaybe baseHypotheses - ?? impossible "allocator property has no seeded hypothesis" - duplicateHypotheses = - baseHypotheses <> [firstHypothesis] - alphaHypotheses = - let renamed = - zipWith makeHypothesis spellings renamedBinders - firstRenamed = - listToMaybe renamed - ?? impossible - "allocator property has no renamed hypothesis" - in renamed <> [firstRenamed] - shuffledHypotheses <- forAll (Gen.shuffle duplicateHypotheses) - let prepared = - prepareTptpTask (namingTask duplicateHypotheses) - shuffled = - prepareTptpTask (namingTask shuffledHypotheses) - alphaRenamed = - prepareTptpTask (namingTask alphaHypotheses) - nameOrigins = preparedTptpNameOrigins prepared - targetNames = Map.keysSet nameOrigins - renderedIdentifiers = - tptpIdentifiers (preparedTptpText prepared) - semanticCount = length spellings - hypothesisCount = length duplicateHypotheses - binderCount = 2 * hypothesisCount - - preparedTptpText shuffled === preparedTptpText prepared - preparedTptpText alphaRenamed === preparedTptpText prepared - preparedTptpNameOrigins shuffled === nameOrigins - preparedTptpNameOrigins alphaRenamed === nameOrigins - - categoryNames "zf_u" targetNames - === ordinalNames "zf_u" semanticCount - categoryNames "zf_f" targetNames - === ordinalNames "zf_f" semanticCount - categoryNames "zf_s" targetNames - === ordinalNames "zf_s" semanticCount - categoryNames "zf_h" targetNames - === ordinalNames "zf_h" hypothesisCount - categoryNames "zf_q" targetNames - === Set.singleton "zf_q0" - categoryNames "V" targetNames - === ordinalNames "V" binderCount - assert (targetNames `Set.isSubsetOf` renderedIdentifiers) - - Set.size targetNames - === 3 * semanticCount + hypothesisCount + binderCount + 1 - for_ targetNames \target -> - if "V" `Text.isPrefixOf` target - then assert (Tptp.isProperVariable target) - else assert (Tptp.isProperAtomicWord target) - -sourceSpelling :: Gen Text -sourceSpelling = - Gen.text - (Range.linear 0 16) - (Gen.element - ( ['a'..'z'] - <> ['A'..'Z'] - <> ['0'..'9'] - <> "_'-.:/\\" - <> ['λ', 'Ω', '\x0301', '💥'] - )) - -adversarialSpellings :: [Text] -adversarialSpellings = - [ "" - , "λ" - , "e\x0301" - , "name'" - , "under_score" - , "zf_u0" - , "zf_f0" - , "zf_s0" - , "V0" - , "Case" - , "case" - , "a-b" - , "💥" - ] - -makeHypothesis :: Text -> VarSymbol -> Hypothesis -makeHypothesis spelling binder = - let freeConstant = TermVar (NamedVar spelling) - structureTerm = - TermSymbolStruct - (StructSymbol spelling) - (Just freeConstant) - body = - Atomic - Nowhere - (PredicateSymbol spelling) - [ freeConstant - , structureTerm - , TermVar binder - ] - shadowedBody = - makeExists - [binder] - (Atomic - Nowhere - (PredicateSymbol spelling) - [TermVar binder]) - nativeRelations = - Equals Nowhere freeConstant freeConstant - `And` NotEquals Nowhere freeConstant structureTerm - in - Hypothesis - (Marker ("label_" <> spelling)) - (makeForall - [binder] - (body `And` shadowedBody `And` nativeRelations)) - -namingTask :: [Hypothesis] -> Task -namingTask hypotheses = - Task - { taskDirectness = Direct - , taskHypotheses = hypotheses - , taskConjectureLabel = "ignored_conjecture_label" - , taskLocation = Nowhere - , taskConjecture = Top - } - -categoryNames :: Text -> Set Text -> Set Text -categoryNames prefix = - Set.filter (prefix `Text.isPrefixOf`) - -ordinalNames :: Text -> Int -> Set Text -ordinalNames prefix size = - Set.fromList - [ prefix <> Text.pack (show ordinal) - | ordinal <- [0 .. size - 1] - ] - -tptpIdentifiers :: Text -> Set Text -tptpIdentifiers = - Set.delete "" - . Set.fromList - . Text.split (not . Tptp.isAsciiAlphaNumOrUnderscore) - -realVampireDistinguishesNames :: Assertion -realVampireDistinguishesNames = do - executable <- fromMaybe "vampire" <$> lookupEnv "NAPROCHE_ZF_VAMPIRE" - let collisionSymbol = - mkMixfixItem - [Just (Command "collision")] - "fx" - NonAssoc - freeConstant = TermVar (NamedVar "x") - userConstant = - TermSymbol - Nowhere - (SymbolMixfix collisionSymbol) - [] - unicodeVariable = NamedVar "λ" - unicodeReflexivity = - makeForall - [unicodeVariable] - (Equals - Nowhere - (TermVar unicodeVariable) - (TermVar unicodeVariable)) - task = - Task - { taskDirectness = Direct - , taskHypotheses = [] - , taskConjectureLabel = "unicode_collision" - , taskLocation = Nowhere - , taskConjecture = - Equals Nowhere freeConstant userConstant - `And` unicodeReflexivity - } - (_location, _formula, answer) <- - runNoLoggingT - (runProver - (vampire - executable - defaultTimeLimit - defaultMemoryLimit) - task) - case answer of - Right CounterSatisfiable{} -> - pure () - result -> - assertFailure - ("expected a countermodel, got " <> show result) - -data Th0Global - = Th0Predicate - | Th0PredicateConsumer - deriving (Show, Eq, Ord) - -th0GlobalType :: Th0Global -> Maybe Core.CoreType -th0GlobalType = \case - Th0Predicate -> - Just - (Core.TySet - `Core.TyArrow` Core.TyProp) - Th0PredicateConsumer -> - Just - ((Core.TySet - `Core.TyArrow` Core.TyProp) - `Core.TyArrow` Core.TyProp) - -realVampireProvesTypedHigherOrderProblem :: Assertion -realVampireProvesTypedHigherOrderProblem = do - executable <- - fromMaybe "vampire" - <$> lookupEnv "NAPROCHE_ZF_VAMPIRE" - let claimTerm = - Core.CApp - (Core.CGlobal Th0PredicateConsumer) - (Core.CLam Core.TySet - (Core.CApp - (Core.CGlobal Th0Predicate) - (Core.CBound 0))) - checked <- - either - (assertFailure . show) - pure - (Core.checkScopedCanonicalCore - th0GlobalType - [] - claimTerm) - claim <- - either - (assertFailure . show) - pure - (Backend.supportedProposition - (Vector.empty - :: Vector.Vector - (Void, Core.CoreType)) - checked) - capability <- - either - (assertFailure . show) - pure - (Backend.classifySupportedProposition - th0GlobalType - claim) - problem <- - either - (assertFailure . show) - pure - (Backend.planTypedProblem - th0GlobalType - (Vector.singleton - (Backend.typedBackendFact - (0 :: Int) - claim - capability)) - claim - [] - [] - Backend.ExplicitGlobalPremises - Backend.FirstOrderLocals) - prepared <- - either - (assertFailure . show) - pure - (prepareTypedProverTask - DirectTask - problem) - assertEqual - "higher-order request dialect" - VerificationTh0 - (preparedVerificationDialect - (preparedTypedProverRequest - prepared)) - answer <- - runNoLoggingT - (runPreparedTypedProver - (vampire - executable - defaultTimeLimit - defaultMemoryLimit) - prepared) - case answer of - Right result - | isJust (provedVampireRun result) -> - pure () - result -> - assertFailure - ("expected a higher-order theorem, got " - <> show result) diff --git a/source/Test/Unit/Html.hs b/source/Test/Unit/Html.hs index 7dd2837..14ecdc3 100644 --- a/source/Test/Unit/Html.hs +++ b/source/Test/Unit/Html.hs @@ -4,6 +4,7 @@ module Test.Unit.Html (unitTests) where import Base import Api qualified +import Felix.Parse qualified as Parse import Felix.Source import Felix.Source.Graph import Render.Html qualified as Html @@ -13,20 +14,55 @@ import Report.Location (Location, pattern Nowhere) import 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 "reference previews are rendered for local and imported refs" referencePreviews + [ 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 - html <- Api.exportHtml "test/html-fixtures/root-preview.tex" + graph <- + expectRight =<< + Api.prepareDefaultSourceGraph + "test/html-fixtures/root-preview.tex" + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + hints <- TextIO.readFile "library/lexicon.tsv" + layout <- + expectRight + (layoutHtmlSourceGraph + Api.defaultHtmlMountPrefixes + 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 @@ -111,12 +147,15 @@ renderSynthetic blocks = do (htmlRenderContext layout (sourceGraphRootSource graph)) + let (renderIndex, page :| _remainingPages) = + Html.buildRenderIndex + ((sourceGraphRootSource graph, blocks) :| []) expectRight (Html.renderDocument context "" - blocks - [(sourceGraphRootSource graph, blocks)]) + renderIndex + page) expectRight :: (Show e, HasCallStack) => Either e a -> IO a expectRight = \case diff --git a/source/Test/Unit/HtmlOutput.hs b/source/Test/Unit/HtmlOutput.hs index 1993fc9..0087f82 100644 --- a/source/Test/Unit/HtmlOutput.hs +++ b/source/Test/Unit/HtmlOutput.hs @@ -4,7 +4,9 @@ module Test.Unit.HtmlOutput (unitTests) where import Base +import Felix.Parse qualified as Parse import Felix.Source +import Felix.Source.Graph qualified as SourceGraph import Render.Html qualified as Html import Render.Html.Export import Render.Html.Output @@ -43,7 +45,7 @@ unitTests = "rejects a FIFO before publication" rejectsFifo , testCase - "reports and cleans an incomplete publication" + "reports and cleans the source-order publication prefix" reportsIncompletePublication ] @@ -94,36 +96,29 @@ publishesMountedExport = expectRight =<< existingRoot rootSource searchedExport <- expectRight =<< - prepareHtmlExport + prepareTestHtmlExport configuration mounts searched hints exactExport <- expectRight =<< - prepareHtmlExport + prepareTestHtmlExport configuration mounts exact hints assertEqual "root-form-independent destinations" - (preparedHtmlBundleDestinations - (preparedHtmlOutputBundle searchedExport)) - (preparedHtmlBundleDestinations - (preparedHtmlOutputBundle exactExport)) - assertEqual - "root-form-independent root document" - (preparedHtmlRootDocument searchedExport) - (preparedHtmlRootDocument exactExport) + (preparedHtmlArtifactDestination <$> searchedExport) + (preparedHtmlArtifactDestination <$> exactExport) - let bundle = - preparedHtmlOutputBundle searchedExport - rejectsBundleEscape temp bundle + let artifacts = searchedExport + rejectsArtifactEscape temp artifacts plan <- requirePlan =<< - planHtmlOutput outputRoot bundle + planHtmlOutput outputRoot artifacts outputExistsBeforePublication <- Directory.doesPathExist outputRoot assertBool @@ -168,11 +163,11 @@ publishesMountedExport = Html.supportScriptAssetContents supportText -rejectsBundleEscape +rejectsArtifactEscape :: FilePath - -> PreparedHtmlBundle + -> [PreparedHtmlArtifact] -> Assertion -rejectsBundleEscape temp bundle = do +rejectsArtifactEscape temp artifacts = do let outputRoot = temp </> "escape-html" outsideRoot = temp </> "outside" outsideMarker = outsideRoot </> "unchanged" @@ -182,7 +177,7 @@ rejectsBundleEscape temp bundle = do Directory.createDirectoryLink outsideRoot (outputRoot </> "docs") - result <- planHtmlOutput outputRoot bundle + result <- planHtmlOutput outputRoot artifacts case result of Left (HtmlOutputParentEscapesRoot @@ -223,8 +218,8 @@ writesPreparedBytes = , 0x63, 0x61, 0x66 , 0xc3, 0xa9 ] - bundle <- - makeBundle + artifacts <- + makeArtifacts [ ( "nested/über.html" , TextEncoding.encodeUtf8 pageText ) @@ -232,7 +227,7 @@ writesPreparedBytes = , TextEncoding.encodeUtf8 supportText ) ] - publishBundle outputRoot bundle + publishArtifacts outputRoot artifacts pageBytes <- ByteString.readFile (outputRoot </> "nested" </> "über.html") @@ -259,7 +254,7 @@ attachesBytesToReservedRoutes = ["page.html", "_static/naproche-html.js"]) routes <- requireRoutePlan =<< planHtmlRoutes outputRoot reserved - matching <- makeBundle + matching <- makeArtifacts [ ("page.html", "page") , ("_static/naproche-html.js", "support") ] @@ -268,7 +263,7 @@ attachesBytesToReservedRoutes = pure () Left failure -> assertFailure (show failure) - mismatched <- makeBundle + mismatched <- makeArtifacts [ ("other.html", "other") , ("_static/naproche-html.js", "support") ] @@ -295,12 +290,12 @@ rejectsFinalSymlink = ByteString.writeFile page "old page" ByteString.writeFile outsideAsset "outside asset" Directory.createFileLink outsideAsset support - bundle <- - makeBundle + artifacts <- + makeArtifacts [ ("page.html", "new page") , ("_static/naproche-html.js", "new support") ] - result <- planHtmlOutput outputRoot bundle + result <- planHtmlOutput outputRoot artifacts case result of Left (HtmlOutputTargetIsSymbolicLink target) -> assertEqual "rejected target" support target @@ -331,9 +326,9 @@ replacesHardLinkedTarget = Directory.createDirectory outputRoot ByteString.writeFile outsidePage "outside page" PosixFiles.createLink outsidePage page - bundle <- - makeBundle [("page.html", "new page")] - publishBundle outputRoot bundle + artifacts <- + makeArtifacts [("page.html", "new page")] + publishArtifacts outputRoot artifacts outsideBytes <- ByteString.readFile outsidePage pageBytes <- ByteString.readFile page assertEqual @@ -349,9 +344,9 @@ rejectsFifo = page = outputRoot </> "page.html" Directory.createDirectory outputRoot PosixFiles.createNamedPipe page PosixFiles.ownerModes - bundle <- - makeBundle [("page.html", "page")] - result <- planHtmlOutput outputRoot bundle + artifacts <- + makeArtifacts [("page.html", "page")] + result <- planHtmlOutput outputRoot artifacts case result of Left (HtmlOutputTargetNotRegularFile target) -> assertEqual "rejected target" page target @@ -369,18 +364,18 @@ reportsIncompletePublication :: Assertion reportsIncompletePublication = withTemporaryDirectory "felix-html-output-incomplete" \temp -> do let outputRoot = temp </> "html" - first = outputRoot </> "a.html" + first = outputRoot </> "z.html" blocked = outputRoot </> "b.html" - unpublished = outputRoot </> "c.html" - bundle <- - makeBundle - [ ("a.html", "first") + unpublished = outputRoot </> "a.html" + artifacts <- + makeArtifacts + [ ("z.html", "first") , ("b.html", "blocked") - , ("c.html", "unpublished") + , ("a.html", "unpublished") ] plan <- requirePlan =<< - planHtmlOutput outputRoot bundle + planHtmlOutput outputRoot artifacts Directory.createDirectory outputRoot Directory.createDirectory blocked result <- writeHtmlOutput plan @@ -392,7 +387,7 @@ reportsIncompletePublication = } -> do expectedFirst <- expectRight - (safeRelativePath "a.html") + (safeRelativePath "z.html") expectedBlocked <- expectRight (safeRelativePath "b.html") @@ -429,23 +424,22 @@ reportsIncompletePublication = outputEntries)) -publishBundle +publishArtifacts :: FilePath - -> PreparedHtmlBundle + -> [PreparedHtmlArtifact] -> IO () -publishBundle outputRoot bundle = do +publishArtifacts outputRoot artifacts = do plan <- - requirePlan =<< planHtmlOutput outputRoot bundle + requirePlan =<< planHtmlOutput outputRoot artifacts requirePublication =<< writeHtmlOutput plan -makeBundle +makeArtifacts :: [(FilePath, ByteString.ByteString)] - -> IO PreparedHtmlBundle -makeBundle artifacts = do - prepared <- for artifacts \(path, bytes) -> do + -> IO [PreparedHtmlArtifact] +makeArtifacts artifacts = + for artifacts \(path, bytes) -> do relative <- expectRight (safeRelativePath path) - pure (relative, bytes) - expectRight (preparedHtmlBundle prepared) + pure (preparedHtmlArtifact relative (Right bytes)) requirePlan :: Either HtmlOutputError HtmlOutputPlan @@ -484,6 +478,24 @@ readUtf8 path = do 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 diff --git a/source/Test/Unit/Kernel.hs b/source/Test/Unit/Kernel.hs index 27f92b2..c24debf 100644 --- a/source/Test/Unit/Kernel.hs +++ b/source/Test/Unit/Kernel.hs @@ -9,7 +9,6 @@ import Checking.Foundation qualified as Foundation import Checking.Kernel.Derivation import Checking.Kernel.Semantics qualified as Semantics import Checking.Kernel.SetLfp qualified as SetLfp -import Checking.Transition (checkedGlobalType) import Checking.Typed.Inductive qualified as Inductive import Report.Location (pattern Nowhere) import Syntax.Internal qualified as Internal @@ -23,6 +22,9 @@ import Test.Tasty.HUnit data TestGlobal = TestGlobal deriving (Show, Eq, Ord) +testGlobalType :: TestGlobal -> CoreType +testGlobalType _global = TySet + unitTests :: TestTree unitTests = testGroup "Kernel replay" @@ -438,7 +440,7 @@ replaysDirectInductiveFacts = do prepared <- expectRight (Inductive.prepareTypedInductive - checkedGlobalType + testGlobalType foundation (const Nothing) (Internal.Marker "direct_inductive") @@ -455,7 +457,7 @@ replaysDirectInductiveFacts = do (replayKernelDerivation foundation defaultKernelReplayLimits - (Just . checkedGlobalType) + (const Nothing) imports (Inductive.typedInductiveFactTarget fact) diff --git a/source/Test/Unit/Migration.hs b/source/Test/Unit/Migration.hs deleted file mode 100644 index d9042cc..0000000 --- a/source/Test/Unit/Migration.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Test.Unit.Migration (unitTests) where - -import Base -import Felix.Migration -import Felix.Parse qualified as Parse -import Felix.Prelude qualified as Prelude -import Felix.Source -import Syntax.Interface qualified as Syntax - -import System.Directory (getCurrentDirectory) -import System.FilePath.Posix qualified as Posix -import Test.Tasty -import Test.Tasty.HUnit - - -unitTests :: TestTree -unitTests = - testGroup "Migration manifest" - [ testCase "resolves references from prepared mount roots" - resolvesManifestReferences - , testCase "selects one driver for the complete graph" - selectsCompleteGraphDriver - ] - -resolvesManifestReferences :: Assertion -resolvesManifestReferences = do - mounts <- - expectRight - =<< prepareSourceMounts - [ (sourceMountId "project", "/tmp/felix-project") - , (sourceMountId "library", "/tmp/felix-library") - , (sourceMountId "debug", "/tmp/felix-debug") - ] - forM_ - (toList activeMigrationRoots - <> toList protectedMigrationModules - <> toList phase53LibraryMigrationModules) - \reference -> do - assertEqual - "manifest role" - MigrationLibrary - (migrationModuleRefRole reference) - candidate <- - expectRight - (migrationModuleCandidatePath mounts reference) - assertEqual - "mount-relative candidate" - ("/tmp/felix-library" - Posix.</> safeRelativePathFilePath - (migrationModuleRefPath reference)) - candidate - forM_ (toList typedMigrationModules) \reference -> - assertEqual - "typed module mount role" - (if reference `elem` - (toList protectedMigrationModules - <> toList phase53LibraryMigrationModules) - then MigrationLibrary - else MigrationProject) - (migrationModuleRefRole reference) - -selectsCompleteGraphDriver :: Assertion -selectsCompleteGraphDriver = do - root <- getCurrentDirectory - mounts <- - expectRight - =<< prepareSourceMounts - [ (sourceMountId "project", root) - , (sourceMountId "library", root Posix.</> "library") - , (sourceMountId "debug", root Posix.</> "debug") - ] - selection <- - expectRight - (resolveMigrationSelection mounts typedMigrationModules) - reserved <- - expectRight - =<< Prelude.parseReservedPreludeSource - Prelude.emptyBootstrapSourceInput - let bootstrapSyntax = - Parse.identifiedParsedModuleSyntaxInterface - (Prelude.reservedParsedPreludeModule reserved) - syntaxInputs source - | migrationSelectionContains selection source = - [bootstrapSyntax] - | otherwise = [] - parseRoot path = do - request <- expectRight (searchedRoot path) - Parse.parseSourceWorkspaceMeasuredWithSyntaxInputs - mounts request syntaxInputs - (producer, _producerMeasurements) <- - expectRight - =<< parseRoot "test/phase3/typed-producer.tex" - assertEqual "selected root uses typed driver" - TypedMigrationGraph - (classifyMigrationGraph selection producer) - assertEqual "selected parse receives the bootstrap syntax input" - [Syntax.moduleSyntaxAssertedId bootstrapSyntax] - (Syntax.moduleSyntaxDirectInputs - (Parse.parsedModuleSyntaxInterface - (Parse.parsedWorkspaceRootModule producer))) - (importer, _importerMeasurements) <- - expectRight - =<< parseRoot "test/phase3/legacy-importer.tex" - assertEqual "unselected importer keeps the complete graph legacy" - LegacyMigrationGraph - (classifyMigrationGraph selection importer) - forM_ - [ ( "set/bipartition.tex" - , ["set.tex", "set/cons.tex", "set/powerset.tex"] - ) - , ("set/product.tex", ["set.tex"]) - , ("set/filter.tex", ["set.tex", "set/powerset.tex"]) - , ( "relation.tex" - , ["set.tex", "set/powerset.tex", "set/product.tex"] - ) - , ( "relation/properties.tex" - , ["set.tex", "relation.tex"] - ) - , ( "relation/uniqueness.tex" - , ["set.tex", "relation.tex"] - ) - , ( "function.tex" - , ["set.tex", "relation.tex", "relation/uniqueness.tex"] - ) - , ( "set/cantor.tex" - , ["set/powerset.tex", "function.tex"] - ) - , ( "set/fixpoint.tex" - , ["set/powerset.tex", "function.tex"] - ) - ] - \(path, expectedImports) -> do - (phase53, _phase53Measurements) <- - expectRight =<< parseRoot path - assertEqual - (path <> " closure uses the typed driver") - TypedMigrationGraph - (classifyMigrationGraph selection phase53) - assertEqual - (path <> " direct imports") - expectedImports - [ safeRelativePathFilePath - (sourceAddressRelativePath - (Parse.parsedImportedAddress imported)) - | imported <- Parse.parsedModuleImports - (Parse.parsedWorkspaceRootModule phase53) - ] - (functionImporter, _functionMeasurements) <- - expectRight =<< parseRoot "set/equinumerosity.tex" - assertEqual "unselected function importer remains legacy" - LegacyMigrationGraph - (classifyMigrationGraph selection functionImporter) - -expectRight :: Show err => Either err value -> IO value -expectRight = \case - Left err -> - assertFailure (show err) >> fail "unreachable" - Right value -> - pure value diff --git a/source/Test/Unit/Module.hs b/source/Test/Unit/Module.hs index 1cf62e5..fbc6c0d 100644 --- a/source/Test/Unit/Module.hs +++ b/source/Test/Unit/Module.hs @@ -21,7 +21,6 @@ import Checking.Typed.Inductive qualified as TypedInductive import CommandLine qualified import Felix.Module import Felix.Math.Codec -import Felix.Migration qualified as Migration import Felix.Parse qualified as Parse import Felix.Prelude qualified as Prelude import Felix.Source @@ -33,21 +32,45 @@ import Paths_felix qualified as Paths import Syntax.Abstract qualified as Raw import Syntax.Internal qualified as Internal import Syntax.Interface qualified as Syntax - -import Bound.Scope (fromScope) -import Bound.Var (Var(..)) +import Syntax.Pragma qualified as Pragma + +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.Monad (foldM) +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 Control.Monad.Logger (runNoLoggingT) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.IORef + ( IORef + , atomicModifyIORef' + , modifyIORef' + , newIORef + , readIORef + ) +import Data.List (sort) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Vector qualified as Vector import System.Directory ( createDirectoryIfMissing + , doesFileExist , getCurrentDirectory , getPermissions , setOwnerExecutable @@ -55,8 +78,10 @@ import System.Directory ) 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 @@ -68,26 +93,28 @@ unitTests = 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 "checks the protected nat closure with the final prelude" - checksProtectedNatClosure - , testCase "checks Phase 5.3 library closures with the final prelude" - checksPhase53LibraryClosures , testCase "retains exact omitted-proof locations" retainsExactOmittedProofLocation , testCase "coalesces syntax without collapsing semantic imports" coalescesSharedDirectSyntax - , testCase "resets gloss state between modules" - resetsGlossStatePerModule , testCase "makes selected source errors terminal" rejectsUnsupportedTypedSource , 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" @@ -98,6 +125,8 @@ unitTests = compilesExactOrdinaryProofs , testCase "compiles and reuses proof-local set definitions" compilesAndReusesProofLocalSetDefinitions + , testCase "compiles and reuses proof-local function graphs" + compilesAndReusesProofLocalFunctionGraphs , testCase "confines terminal exact contradiction" confinesTerminalExactContradiction , testCase "compiles exact separation comprehensions" @@ -146,9 +175,21 @@ unitTests = 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 "keeps dependent proof obligations sequential" + keepsDependentProofObligationsSequential + , 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 production verification by complete graph" + , testCase "routes every production root through exact checking" routesProductionVerification , testCase "installs nonempty implicit prelude evidence" installsNonemptyImplicitPreludeEvidence @@ -285,6 +326,30 @@ parsesPackagedFinalPrelude = do (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" + "<felix-prelude>: syntax pragma location is out of range at 7:3" + (Prelude.renderPreludeParseError parseFailure) + assertEqual "authority-free API presentation" + ("packaged final prelude parsing failed: " + <> "<felix-prelude>: syntax pragma location is out of range at 7:3") + (Api.renderAuthorityFreeParseError + (Api.AuthorityFreePreludeParseFailed parseFailure)) + where + parseFailure = + Prelude.PreludeSyntaxPragmaFailed + (Pragma.SyntaxPragmaLocationOutOfRange + Prelude.preludeDiagnosticLabel + 7 + 3) + confinesFoundationLeafCompletion :: Assertion confinesFoundationLeafCompletion = do foundation <- expectRight Foundation.checkedFoundation @@ -387,6 +452,54 @@ buildsConfinedFinalPrelude = do [] (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 @@ -395,13 +508,13 @@ buildsConfinedFinalPrelude = do pure (FinalPrelude.finalPreludePublicRole candidate roleName) - omega <- role Migration.PreludeOmegaObject - naturals <- role Migration.PreludeNaturalsAlias + omega <- role FinalPrelude.PreludeOmegaObject + naturals <- role FinalPrelude.PreludeNaturalsAlias assertEqual "naturals expands to Omega" omega naturals traverse_ (void . role) - (Set.toList Migration.expectedFinalPreludePublicRoles) + (Set.toList FinalPrelude.expectedFinalPreludePublicRoles) let foundationTags = Set.fromList [ tag | batch <- @@ -459,518 +572,61 @@ publishesFinalPreludeRoot = do Store.openStore path theory >>= expectRight pure store bracket open Store.closeStore \store -> do + freshMemo <- Store.newStoreMemo store session <- expectRight - =<< Module.buildFinalPreludeSession - store foundation finalPreludeResolver - let input = Module.migrationPreludeInput session - sealed = Module.migrationPreludeModule session + =<< 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) - key <- expectRight - (Semantic.moduleArtifactKey - preludeModuleName - (Parse.identifiedParsedModuleId - (Module.identifiedModuleParsed input)) - [] - theory) - memo <- Store.newStoreMemo store - loaded <- expectRight - =<< Store.loadCachedModuleInstallation - memo - store - key - (Syntax.moduleSyntaxAssertedId syntax) - installation <- maybe - (assertFailure "final prelude root was not installed" - >> fail "unreachable") - pure - loaded - cached <- expectRight - (Module.cachedSealedTypedModule - foundation [] installation) + 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)) - -checksProtectedNatClosure :: Assertion -checksProtectedNatClosure = do - foundation <- expectRight Foundation.checkedFoundation - repository <- getCurrentDirectory - Temp.withSystemTempDirectory "felix-protected-nat" \directory -> do - let storePath = directory Posix.</> "store.sqlite" - executable = directory Posix.</> "vampire" - writeFile executable - (unlines - [ "#!/bin/sh" - , "cat >/dev/null" - , "printf '%s\\n' '% SZS status Theorem for protected-core'" - ]) - permissions <- getPermissions executable - setPermissions executable - (setOwnerExecutable True permissions) - runs <- newIORef (0 :: Int) - let resolver = countingAcceptedResolver executable runs - open = do - (_startup, store) <- - Store.openStore - storePath - (Identity.theoryId foundation) - >>= expectRight - pure store - bracket open Store.closeStore \store -> do - prelude <- - expectRight - =<< Module.buildFinalPreludeSession - store foundation resolver - mounts <- exactFixtureMounts repository - workspace <- parseFinalExactWorkspace prelude mounts "nat.tex" - sealed <- compileFinalParsedWorkspaceWithResolver - foundation prelude resolver workspace - let parsed = toList - (Parse.parsedWorkspaceImportedBeforeImporter workspace) - modules = Map.fromList - [ ( safeRelativePathFilePath - (resolvedSourceRelativePath - (Parse.parsedModuleResolved source)) - , checked - ) - | (source, checked) <- zip parsed sealed - ] - moduleAt path = maybe - (assertFailure ("missing typed module " <> path) - >> fail "unreachable") - pure - (Map.lookup path modules) - assertEqual "protected module count" - 5 - (length sealed) - let preludeSyntaxId = - Syntax.moduleSyntaxAssertedId - (Module.sealedTypedModuleSyntax - (Module.migrationPreludeModule prelude)) - preludeSemanticId = - Semantic.semanticInterfaceAssertedId - (Module.sealedTypedModuleSemantic - (Module.migrationPreludeModule prelude)) - forM_ - (toList - (Parse.parsedWorkspaceImportedBeforeImporter workspace)) - \parsedModule -> - assertEqual "final prelude is the first syntax input" - (Just preludeSyntaxId) - (listToMaybe - (Syntax.moduleSyntaxDirectInputs - (Parse.parsedModuleSyntaxInterface - parsedModule))) - forM_ sealed \sealedModule -> - assertEqual "final prelude is the first semantic input" - (Just preludeSemanticId) - (listToMaybe - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic sealedModule))) - setModule <- moduleAt "set.tex" - sucModule <- moduleAt "set/suc.tex" - natModule <- moduleAt "nat.tex" - assertLocalAliasesAbsent - setModule - [ "setext" - , "emptyset" - , "unions" - , "unions_iff" - ] - assertLocalAliasesAbsent - natModule - [ "num_naturals_inductive_set" - , "num_naturals_smallest_inductive_set" - ] - assertTransparentObjectAlias setModule "cons" - assertTransparentObjectAlias setModule "union" - pairIdentity <- localObjectKeyTarget - setModule - (Semantic.SemanticExpressionFunction - (Raw.mixfixPattern Raw.PairSymbol)) - consBody <- localTransparentObjectBody setModule "cons" - let expectedConsBody = - Core.CLam Core.TySet - (Core.CLam Core.TySet - (Core.canonicalSetInsert - (Core.CBound 1) - (Core.CBound 0))) - assertEqual "cons uses canonical set insertion" - expectedConsBody consBody - assertBool "cons does not use ordered pairing" - ( pairIdentity - `Set.notMember` Core.canonicalTermGlobals consBody - ) - let preludeModule = Module.migrationPreludeModule prelude - preludeSuccessor <- - localObjectAliasTarget preludeModule "prelude_successor" - sourceSuccessor <- localObjectAliasTarget sucModule "suc" - assertEqual "source successor reuses packaged successor content" - preludeSuccessor sourceSuccessor - preludeSuccessorBody <- - localTransparentObjectBody preludeModule "prelude_successor" - assertEqual "packaged successor uses canonical set insertion" - (Core.CLam Core.TySet - (Core.canonicalSetInsert - (Core.CBound 0) - (Core.CBound 0))) - preludeSuccessorBody - assertBool "successor does not use ordered pairing" - ( pairIdentity - `Set.notMember` - Core.canonicalTermGlobals preludeSuccessorBody - ) - assertOpaqueObjectKey - setModule - "pair" - (Semantic.SemanticExpressionFunction - (Raw.mixfixPattern Raw.PairSymbol)) - assertCleanFactAlias setModule "cons_iff" - assertCleanFactAlias setModule "union_iff" - traverse_ - (assertSourceAxiomAlias setModule) - [ "pair_eq_iff" - , "fst_eq" - , "snd_eq" - ] - assertBool "protected checking exercised Vampire" - . (> 0) - =<< readIORef runs - -checksPhase53LibraryClosures :: Assertion -checksPhase53LibraryClosures = do - foundation <- expectRight Foundation.checkedFoundation - repository <- getCurrentDirectory - Temp.withSystemTempDirectory "felix-phase53-library" \directory -> do - let storePath = directory Posix.</> "store.sqlite" - executable = directory Posix.</> "vampire" - writeFile executable - (unlines - [ "#!/bin/sh" - , "cat >/dev/null" - , "printf '%s\\n' '% SZS status Theorem for phase53-library'" - ]) - permissions <- getPermissions executable - setPermissions executable - (setOwnerExecutable True permissions) - runs <- newIORef (0 :: Int) - let resolver = countingAcceptedResolver executable runs - bracket - (snd <$> (Store.openStore storePath - (Identity.theoryId foundation) >>= expectRight)) - Store.closeStore - \store -> do - prelude <- - expectRight - =<< Module.buildFinalPreludeSession - store foundation resolver - mounts <- exactFixtureMounts repository - selection <- expectRight - (Migration.resolveMigrationSelection - mounts Migration.typedMigrationModules) - let preludeSyntaxId = Syntax.moduleSyntaxAssertedId - (Module.sealedTypedModuleSyntax - (Module.migrationPreludeModule prelude)) - preludeSemanticId = - Semantic.semanticInterfaceAssertedId - (Module.sealedTypedModuleSemantic - (Module.migrationPreludeModule prelude)) - checkRoot path inspect = do - workspace <- parseFinalExactWorkspace - prelude mounts path - assertEqual (path <> " graph route") - Migration.TypedMigrationGraph - (Migration.classifyMigrationGraph - selection workspace) - sealed <- compileFinalParsedWorkspaceWithResolver - foundation prelude resolver workspace - let parsed = toList - (Parse.parsedWorkspaceImportedBeforeImporter - workspace) - modules = Map.fromList - [ ( safeRelativePathFilePath - (resolvedSourceRelativePath - (Parse.parsedModuleResolved source)) - , (source, checked) - ) - | (source, checked) <- zip parsed sealed - ] - moduleAt modulePath = maybe - (assertFailure - ("missing typed module " <> modulePath) - >> fail "unreachable") - pure - (Map.lookup modulePath modules) - assertEqual (path <> " module count") - (length parsed) - (length sealed) - forM_ parsed \source -> - assertEqual - (path <> " final-prelude syntax input") - (Just preludeSyntaxId) - (listToMaybe - (Syntax.moduleSyntaxDirectInputs - (Parse.parsedModuleSyntaxInterface - source))) - forM_ sealed \checked -> - assertEqual - (path <> " final-prelude semantic input") - (Just preludeSemanticId) - (listToMaybe - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - checked))) - inspect moduleAt - unselectedImporter <- parseFinalExactWorkspace - prelude mounts "set/equinumerosity.tex" - assertEqual "unselected function importer graph route" - Migration.LegacyMigrationGraph - (Migration.classifyMigrationGraph - selection unselectedImporter) - checkRoot "set/bipartition.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_consParsed, consModule) <- - moduleAt "set/cons.tex" - (_powersetParsed, powersetModule) <- - moduleAt "set/powerset.tex" - (_bipartitionParsed, bipartitionModule) <- - moduleAt "set/bipartition.tex" - assertLocalAliasesAbsent powersetModule ["pow_iff"] - assertEqual "bipartition semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId consModule - , semanticId powersetModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - bipartitionModule)) - assertFactAliasEscapeKind - bipartitionModule - "bipartition_elim" - Authority.SourceAxiom - checkRoot "set/product.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_productParsed, productModule) <- - moduleAt "set/product.tex" - assertEqual "product semantic imports" - [preludeSemanticId, semanticId setModule] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - productModule)) - assertFactAliasEscapeKind - productModule - "inter_times_intro" - Authority.SourceAxiom - checkRoot "set/filter.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_powersetParsed, powersetModule) <- - moduleAt "set/powerset.tex" - (_filterParsed, filterModule) <- - moduleAt "set/filter.tex" - assertEqual "filter semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId powersetModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic filterModule)) - assertAllLocalFactsClean filterModule - checkRoot "relation.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_powersetParsed, powersetModule) <- - moduleAt "set/powerset.tex" - (_productParsed, productModule) <- - moduleAt "set/product.tex" - (_relationParsed, relationModule) <- - moduleAt "relation.tex" - assertEqual "relation semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId powersetModule - , semanticId productModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - relationModule)) - assertCleanFactAlias - relationModule - "union_relations_is_relation" - assertFactAliasEscapeKind - relationModule - "id_iff" - Authority.SourceAxiom - assertNoLocalFactEscapeKind - relationModule - Authority.Omitted - checkRoot "relation/properties.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_relationParsed, relationModule) <- - moduleAt "relation.tex" - (_propertiesParsed, propertiesModule) <- - moduleAt "relation/properties.tex" - assertEqual "relation properties semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId relationModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - propertiesModule)) - assertCleanFactAlias - propertiesModule - "asymmetric_implies_irreflexive" - assertNoLocalFactEscapeKind - propertiesModule - Authority.Omitted - assertNoLocalSourceAxiom propertiesModule - checkRoot "relation/uniqueness.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_relationParsed, relationModule) <- - moduleAt "relation.tex" - (_uniquenessParsed, uniquenessModule) <- - moduleAt "relation/uniqueness.tex" - assertEqual "relation uniqueness semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId relationModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - uniquenessModule)) - assertCleanFactAlias - uniquenessModule - "subseteq_of_injective_is_injective" - assertFactAliasEscapeKind - uniquenessModule - "identity_injective" - Authority.SourceAxiom - assertNoLocalFactEscapeKind - uniquenessModule - Authority.Omitted - assertNoLocalSourceAxiom uniquenessModule - checkRoot "function.tex" - \moduleAt -> do - (_setParsed, setModule) <- moduleAt "set.tex" - (_relationParsed, relationModule) <- - moduleAt "relation.tex" - (_uniquenessParsed, uniquenessModule) <- - moduleAt "relation/uniqueness.tex" - (_functionParsed, functionModule) <- - moduleAt "function.tex" - assertEqual "function semantic imports" - [ preludeSemanticId - , semanticId setModule - , semanticId relationModule - , semanticId uniquenessModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - functionModule)) - assertCleanFactAlias - functionModule - "function_on_weaken_codom" - assertFactAliasEscapeKind - functionModule - "function_apply_intro" - Authority.SourceAxiom - assertFactAliasEscapeKind - functionModule - "funs_circ" - Authority.Omitted - assertLocalDirectAuthorizationCount - functionModule - Authority.OmittedAuthorization - 6 - assertNoLocalSourceAxiom functionModule - checkRoot "set/cantor.tex" - \moduleAt -> do - (_powersetParsed, powersetModule) <- - moduleAt "set/powerset.tex" - (_functionParsed, functionModule) <- - moduleAt "function.tex" - (_cantorParsed, cantorModule) <- - moduleAt "set/cantor.tex" - assertEqual "Cantor semantic imports" - [ preludeSemanticId - , semanticId powersetModule - , semanticId functionModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - cantorModule)) - assertCleanFactAlias cantorModule "cantor" - assertNoLocalFactEscapeKind - cantorModule Authority.Omitted - assertNoLocalSourceAxiom cantorModule - checkRoot "set/fixpoint.tex" - \moduleAt -> do - (_powersetParsed, powersetModule) <- - moduleAt "set/powerset.tex" - (_functionParsed, functionModule) <- - moduleAt "function.tex" - (_fixpointParsed, fixpointModule) <- - moduleAt "set/fixpoint.tex" - assertEqual "fixpoint semantic imports" - [ preludeSemanticId - , semanticId powersetModule - , semanticId functionModule - ] - (Semantic.semanticInterfaceDirectInputs - (Module.sealedTypedModuleSemantic - fixpointModule)) - assertCleanFactAlias fixpointModule "fixpoint" - assertCleanFactAlias - fixpointModule "subseteqpreserving" - assertFactAliasEscapeKind - fixpointModule - "knastertarski" - Authority.SourceAxiom - assertNoLocalFactEscapeKind - fixpointModule Authority.Omitted - assertNoLocalSourceAxiom fixpointModule - where - semanticId = - Semantic.semanticInterfaceAssertedId - . Module.sealedTypedModuleSemantic - -assertLocalAliasesAbsent - :: Module.SealedTypedModule - -> [Text] - -> Assertion -assertLocalAliasesAbsent sealed names = - forM_ names \name -> - assertBool - ("protected module still publishes " <> show name) - (Semantic.semanticName name `notElem` aliases) - where - aliases = - [ Semantic.semanticAliasName alias - | delta <- localSemanticDeltas sealed - , alias <- Semantic.declarationDeltaAliases delta - ] + 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 @@ -983,18 +639,6 @@ assertTransparentObjectAlias sealed name = do Identity.TransparentObject (Identity.objectIdFamily target) -assertOpaqueObjectKey - :: Module.SealedTypedModule - -> Text - -> Semantic.SemanticGlobalKey - -> Assertion -assertOpaqueObjectKey sealed name key = do - target <- localObjectKeyTarget sealed key - assertEqual - ("opaque object for " <> StrictText.unpack name) - Identity.OpaqueObject - (Identity.objectIdFamily target) - localObjectKeyTarget :: Module.SealedTypedModule -> Semantic.SemanticGlobalKey @@ -1026,29 +670,6 @@ localObjectAliasTarget sealed name = do (Semantic.semanticGlobalTargetObject (Semantic.semanticGlobalBindingTarget binding)) -localTransparentObjectBody - :: Module.SealedTypedModule - -> Text - -> IO (Core.CanonicalTerm Identity.ObjectId) -localTransparentObjectBody sealed name = do - identity <- localObjectAliasTarget sealed name - object <- sole - ("asserted object for " <> StrictText.unpack name) - [ candidate - | batch <- Declaration.pendingModulePrefixBatches - (Module.sealedTypedModulePrefix sealed) - , candidate <- Declaration.committedBatchObjects batch - , Identity.assertedObjectId candidate == identity - ] - case Identity.assertedObjectContent object of - Identity.TransparentObjectContent _theory _coreType body -> - pure body - content -> - assertFailure - ("object for " <> StrictText.unpack name - <> " is not transparent: " <> show content) - >> fail "unreachable" - checkedPropositionTermByAlias :: Module.SealedTypedModule -> Text @@ -1057,30 +678,31 @@ 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) - (Declaration.committedBatchPropositions batch) + [ candidate + | candidate <- Declaration.committedBatchPropositions batch + , Identity.checkedPropositionId candidate + == Semantic.semanticFactProposition occurrence + ] pure (Identity.checkedPropositionTerm proposition) -assertFactAliasEscapeKind - :: Module.SealedTypedModule - -> Text - -> Authority.EscapeKind - -> Assertion -assertFactAliasEscapeKind sealed name expected = do - delta <- localDeltaByAlias sealed name - fact <- sole - ("semantic fact for " <> StrictText.unpack name) - (Semantic.declarationDeltaFacts delta) - assertBool - ("escape authority for " <> StrictText.unpack name) - ( expected - `elem` Authority.escapeKindsToList - (Authority.authoritySafetyEscapeKinds - (Authority.factAuthoritySafety - (Semantic.semanticFactAuthority fact))) - ) - assertCleanFactAlias :: Module.SealedTypedModule -> Text @@ -1107,114 +729,6 @@ assertCleanFactAlias sealed name = do (Authority.factAuthoritySafety (Semantic.semanticFactAuthority fact)) -assertAllLocalFactsClean - :: Module.SealedTypedModule - -> Assertion -assertAllLocalFactsClean sealed = - assertBool - "all locally published facts have clean authority" - (all hasCleanAuthority localFacts) - where - localFacts = - [ fact - | delta <- localSemanticDeltas sealed - , fact <- Semantic.declarationDeltaFacts delta - ] - hasCleanAuthority fact = - Authority.factAuthoritySafety - (Semantic.semanticFactAuthority fact) - == Authority.cleanAuthoritySafety - -assertNoLocalFactEscapeKind - :: Module.SealedTypedModule - -> Authority.EscapeKind - -> Assertion -assertNoLocalFactEscapeKind sealed unexpected = - assertBool - ("no local fact has " <> show unexpected <> " authority") - (all lacksEscapeKind localFacts) - where - localFacts = - [ fact - | delta <- localSemanticDeltas sealed - , fact <- Semantic.declarationDeltaFacts delta - ] - lacksEscapeKind fact = - unexpected - `notElem` Authority.escapeKindsToList - (Authority.authoritySafetyEscapeKinds - (Authority.factAuthoritySafety - (Semantic.semanticFactAuthority fact))) - -assertNoLocalSourceAxiom - :: Module.SealedTypedModule - -> Assertion -assertNoLocalSourceAxiom sealed = - assertBool - "module introduces no source axiom" - (all (/= Authority.SourceAxiomAuthorization) directAuthorizations) - where - directAuthorizations = - [ Authority.validationDirectAuthorization certificate - | batch <- Declaration.pendingModulePrefixBatches - (Module.sealedTypedModulePrefix sealed) - , validation <- maybeToList - (Declaration.committedBatchDeclarationValidation batch) - , certificate <- - Semantic.declarationValidationRecordCertificates validation - ] - -assertLocalDirectAuthorizationCount - :: Module.SealedTypedModule - -> Authority.DirectAuthorization - -> Int - -> Assertion -assertLocalDirectAuthorizationCount sealed expected expectedCount = - assertEqual - ("local " <> show expected <> " authorization count") - expectedCount - (length - [ () - | batch <- Declaration.pendingModulePrefixBatches - (Module.sealedTypedModulePrefix sealed) - , validation <- Declaration.committedBatchProofValidations batch - , Authority.validationDirectAuthorization - (Semantic.proofValidationRecordCertificate validation) - == expected - ]) - -assertSourceAxiomAlias - :: Module.SealedTypedModule - -> Text - -> Assertion -assertSourceAxiomAlias sealed name = do - batch <- batchByAlias - (Module.sealedTypedModulePrefix sealed) - name - fact <- sole - ("source axiom fact " <> StrictText.unpack name) - (Semantic.declarationDeltaFacts - (Declaration.committedBatchDelta batch)) - assertEqual - ("source axiom safety for " <> StrictText.unpack name) - (Authority.authoritySafety - (Authority.singletonEscapeKind Authority.SourceAxiom)) - (Authority.factAuthoritySafety - (Semantic.semanticFactAuthority fact)) - validation <- maybe - (assertFailure - ("source axiom validation for " <> StrictText.unpack name) - >> fail "unreachable") - pure - (Declaration.committedBatchDeclarationValidation batch) - certificate <- sole - ("source axiom certificate for " <> StrictText.unpack name) - (Semantic.declarationValidationRecordCertificates validation) - assertEqual - ("source axiom authority for " <> StrictText.unpack name) - Authority.SourceAxiomAuthorization - (Authority.validationDirectAuthorization certificate) - batchByAlias :: Declaration.PendingModulePrefix -> Text @@ -1350,18 +864,10 @@ coalescesSharedDirectSyntax = do , (sourceMountId "library", root Posix.</> "library") , (sourceMountId "debug", root Posix.</> "debug") ] - selection <- - expectRight - (Migration.resolveMigrationSelection - mounts - Migration.typedMigrationModules) let bootstrapSyntax = Module.sealedTypedModuleSyntax (Module.bootstrapPreludeModule session) - syntaxInputs source - | Migration.migrationSelectionContains selection source = - [bootstrapSyntax] - | otherwise = [] + syntaxInputs _source = [bootstrapSyntax] request <- expectRight (searchedRoot "test/phase3/typed-shared-root.tex") @@ -1371,9 +877,6 @@ coalescesSharedDirectSyntax = do mounts request syntaxInputs - assertEqual "selected shared-syntax graph" - Migration.TypedMigrationGraph - (Migration.classifyMigrationGraph selection workspace) case Parse.parsedWorkspaceModules workspace of [firstParsed, secondParsed, rootParsed] -> do first <- seal foundation session firstParsed [] @@ -1436,31 +939,6 @@ coalescesSharedDirectSyntax = do assertFailure "empty typed module did not seal" >> fail "unreachable" -resetsGlossStatePerModule :: Assertion -resetsGlossStatePerModule = do - blocks <- Api.gloss "test/phase3/gloss-root.tex" - binders <- traverse signatureBinder blocks - assertEqual "fresh variables restart at each module boundary" - [Internal.FreshVar 0, Internal.FreshVar 0, Internal.FreshVar 1] - binders - where - signatureBinder = \case - Internal.BlockSig - _location - _marker - _assumptions - (Internal.SignatureFormula - (Internal.Quantified Internal.Universally scope)) -> - case nubOrd [binder | B binder <- toList (fromScope scope)] of - [binder] -> pure binder - binders -> - assertFailure - ("unexpected signature binders: " <> show binders) - >> fail "unreachable" - block -> - assertFailure ("unexpected glossed block: " <> show block) - >> fail "unreachable" - rejectsUnsupportedTypedSource :: Assertion rejectsUnsupportedTypedSource = do result <- @@ -1472,13 +950,16 @@ rejectsUnsupportedTypedSource = do Provers.defaultMemoryLimit) "test/phase3/typed-unsupported.tex") case result of - Left - (failure@(Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (failure@(Api.VerificationTypedModuleError source (Module.TypedActionFailed (Module.TypedExactCompileFailed (Exact.ExactUnsupportedDeclarationBody location))) - prefix)) -> do + prefix)) + , _measurements + ) -> do assertEqual "failed source" "test/phase3/typed-unsupported.tex" (safeRelativePathFilePath @@ -1670,6 +1151,566 @@ compilesExactDeclarationGraph = do 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) + + 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 @@ -1712,14 +1753,17 @@ compilesExactRelationExpressions = do prover "test/phase5/exact-relation-expression-missing-pair.tex") case missingPair of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofElaborationFailed (Exact.ExactGlobalNotVisible location key)))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "missing ordered-pair provider line" 2 (locLine location) @@ -1752,7 +1796,7 @@ resolvesSourceOwnedApplication = do \store -> do prelude <- expectRight - =<< Module.buildFinalPreludeSession + =<< acquireFinalPreludeSession store foundation resolver mounts <- exactFixtureMounts repository workspace <- parseFinalExactWorkspace @@ -1788,14 +1832,17 @@ resolvesSourceOwnedApplication = do prover "test/phase5/exact-application-missing.tex") case missing of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofElaborationFailed (Exact.ExactGlobalNotVisible location key)))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "unresolved application line" 2 (locLine location) assertEqual "unresolved application key" (Semantic.SemanticExpressionFunction @@ -1826,7 +1873,7 @@ confinesExactQuantifiedTerms = do \store -> do prelude <- expectRight - =<< Module.buildFinalPreludeSession + =<< acquireFinalPreludeSession store foundation resolver mounts <- exactFixtureMounts repository workspace <- parseFinalExactWorkspace @@ -1856,15 +1903,18 @@ confinesExactQuantifiedTerms = do prover "test/phase5/exact-quantified-subject-nested.tex") case negative of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofElaborationFailed (Exact.ExactQuantifiedTermRequiresStatementSubject location)))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "nested quantified term line" 8 (locLine location) assertEqual "earlier exact definition remains committed" 1 @@ -2307,6 +2357,209 @@ compilesAndReusesProofLocalSetDefinitions = (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) + runNoLoggingT + (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 @@ -3210,7 +3463,8 @@ assertExactDatatypeModule label sealed = do (\binding -> case Semantic.semanticGlobalBindingTarget binding of Semantic.GlobalReference{} -> True - Semantic.TransparentExpansion{} -> False) + Semantic.TransparentExpansion{} -> False + Semantic.ContextualTransparentExpansion{} -> False) bindings) assertEqual (label <> " datatype global targets") (Set.fromList objectIds) @@ -4537,9 +4791,6 @@ loadsCachedExactProducerForFreshImporter = do executable Provers.defaultTimeLimit Provers.defaultMemoryLimit - resolver = Declaration.vampireResolver \prepared -> - runNoLoggingT - (Provers.runPreparedTypedProver prover prepared) verify mode source = runNoLoggingT (Api.verifyWithObserverAndStoreMode @@ -4553,10 +4804,12 @@ loadsCachedExactProducerForFreshImporter = do "test/phase5/exact-importer.tex" assertTypedSuccess "fresh producer" producer assertTypedSuccess "warm producer/fresh importer" importer + memo <- Store.newStoreMemo store prelude <- expectRight - =<< Module.buildFinalPreludeSession - store foundation resolver + =<< Module.acquireFinalPreludeSession + memo store foundation unusedResolver + preludeVisits <- Store.storeMemoVisits memo repository <- getCurrentDirectory mounts <- exactFixtureMounts repository workspace <- parseFinalExactWorkspace @@ -4566,11 +4819,11 @@ loadsCachedExactProducerForFreshImporter = do (Parse.parsedWorkspaceImportedBeforeImporter workspace) preludeSemantic = Module.sealedTypedModuleSemantic - (Module.migrationPreludeModule prelude) + (Module.finalPreludeModule prelude) preludeId = Semantic.semanticInterfaceAssertedId preludeSemantic theory = Identity.theoryId foundation - loadInstallation memo parsed direct = do + loadInstallation parsed direct = do key <- expectRight (Semantic.moduleArtifactKey (moduleName (Parse.parsedModuleAddress parsed)) @@ -4598,16 +4851,25 @@ loadsCachedExactProducerForFreshImporter = do ] case parsedModules of [producerParsed, importerParsed] -> do - memo <- Store.newStoreMemo store producerInstallation <- - loadInstallation memo producerParsed [preludeId] + 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 - memo importerParsed [preludeId, producerSemanticId] + importerParsed [preludeId, producerSemanticId] case ( environmentBindings producerInstallation , environmentBindings importerInstallation ) of @@ -4666,6 +4928,832 @@ loadsCachedExactProducerForFreshImporter = do <> 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 = + Api.verificationRequestObserver + (\_position _request -> pure ()) + select amount = + Provers.selectEffectiveJobs + (Provers.effectiveJobs amount) + (fail "explicit jobs unexpectedly detected processors") + reportEntry escape = + ( Api.reportedEscapeKind escape + , locFile (Api.reportedEscapeLocation escape) + , locLine (Api.reportedEscapeLocation escape) + ) + inspect label expectedPositions + (result, measurements, positions) = do + case result of + Api.VerificationFailure report failed -> do + assertEqual (label <> " selected earlier failure") + "test/phase7/concurrent-earlier.tex" + (locFile (Api.failedVerificationLocation failed)) + assertEqual (label <> " admitted source prefix") + [ ( Api.ReportedSourceAxiom + , "test/phase7/concurrent-earlier.tex" + , 1 + ) + ] + (reportEntry + <$> Api.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 + ]) + pure measurements + 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 + (runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreMode + openStore + Api.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 = + Api.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, measurements) <- + runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + openStore + Api.WarmStoreValidation + jobs + observer + prover + source) + >>= expectRight + positions <- readIORef positionsRef + pure (result, measurements, positions) + parallel <- + runCase "parallel" 2 + >>= inspect "parallel" [(1, 1), (2, 1)] + sequential <- + runCase "sequential" 1 + >>= inspect "sequential" [(1, 1)] + assertEqual "parallel module checker bound" + 2 + (Api.verificationMaximumLiveModuleCheckers parallel) + assertEqual "parallel Vampire bound" + 2 + (Api.verificationMaximumLiveVampireProcesses parallel) + assertEqual "sequential module checker reference" + 1 + (Api.verificationMaximumLiveModuleCheckers sequential) + assertEqual "sequential Vampire reference" + 1 + (Api.verificationMaximumLiveVampireProcesses sequential) + +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 = + runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + openStore + Api.WarmStoreValidation + jobs + observer + vampireCommand + source) + >>= expectRight + inspectFailure label positions (result, measurements) = do + case result of + Api.VerificationFailure report failed -> do + assertEqual (label <> " selects first consequence") + (source, 12) + ( locFile (Api.failedVerificationLocation failed) + , locLine (Api.failedVerificationLocation failed) + ) + assertEqual (label <> " retains preceding prefix") + [(Api.ReportedSourceAxiom, source, 1)] + [ ( Api.reportedEscapeKind escape + , locFile (Api.reportedEscapeLocation escape) + , locLine (Api.reportedEscapeLocation escape) + ) + | escape <- Api.verificationDirectEscapes report + ] + other -> + assertFailure + (label <> " did not reject its structure batch: " + <> show other) + assertEqual (label <> " assigns consecutive positions") + [(1, 1), (1, 2)] + (sort positions) + assertEqual (label <> " observes one two-member batch") + (1, 2, 2) + ( Api.verificationObligationBatchCount measurements + , Api.verificationPreparedObligationCount measurements + , Api.verificationMaximumObligationBatchSize measurements + ) + pure measurements + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let ignored = + Api.verificationRequestObserver + (\_position _request -> pure ()) + -- Seed only the confined prelude so this fixture observes exactly + -- the ordinary structure module's ready batch. + void + (runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreMode + openStore + Api.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" + writeRejectingVampire executable laterCompleted + let parallelObserver = + Api.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 + parallelMeasurements <- + inspectFailure "parallel" + positions parallelResult + assertEqual "parallel obligations overlap" + 2 + (Api.verificationMaximumLiveVampireProcesses + parallelMeasurements) + + sequentialJobs <- select 1 + sequentialPositions <- newIORef [] + let sequentialCompleted = root Posix.</> "sequential-completed" + writeRejectingVampire executable sequentialCompleted + let sequentialObserver = + Api.verificationRequestObserver \position _request -> + atomicModifyIORef' sequentialPositions + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal + position + ) : positions + , () + )) + sequentialResult <- + run openStore sequentialJobs sequentialObserver + (prover executable) + sequentialObserved <- readIORef sequentialPositions + sequentialMeasurements <- + inspectFailure "sequential" + sequentialObserved sequentialResult + assertEqual "sequential batch is the semantic reference" + 1 + (Api.verificationMaximumLiveVampireProcesses + sequentialMeasurements) + + -- 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 = + Api.verificationRequestObserver \position _request -> + modifyIORef' acceptedPositions + (position :) + (accepted, acceptedMeasurements) <- + run openStore parallelJobs acceptedObserver + (prover executable) + case accepted of + Api.VerificationCompleted report _presentation -> + assertEqual "successful retry retains only source axiom" + [Api.ReportedSourceAxiom] + (Api.reportedEscapeKind + <$> Api.verificationDirectEscapes report) + other -> + assertFailure + ("successful structure retry failed: " <> show other) + acceptedObserved <- readIORef acceptedPositions + assertEqual "successful retry executes the complete batch" + 2 + (length acceptedObserved) + assertEqual "failed declaration published no root" + (1, 1) + ( Api.verificationModuleRootHitCount acceptedMeasurements + , Api.verificationModuleRootMissCount acceptedMeasurements + ) + let forbiddenObserver = + Api.verificationRequestObserver \position _request -> + assertFailure + ("warm structure batch invoked Vampire at " + <> show position) + (warm, warmMeasurements) <- + run openStore parallelJobs forbiddenObserver + (prover unavailable) + case warm of + Api.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm structure batch did not install: " <> show other) + assertEqual "warm module hit executes no batch" + (2, 0, 0) + ( Api.verificationModuleRootHitCount warmMeasurements + , Api.verificationModuleRootMissCount warmMeasurements + , Api.verificationVampireRunCount warmMeasurements + ) + 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) + +keepsDependentProofObligationsSequential :: Assertion +keepsDependentProofObligationsSequential = + Temp.withSystemTempDirectory "felix-dependent-proof-chain" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase7/dependent-proof-chain.tex" + let executable = root Posix.</> "vampire" + writeAcceptedFixtureVampire executable + firstSubmitted <- newEmptyTMVarIO + secondSubmitted <- newEmptyTMVarIO + releaseFirst <- newEmptyTMVarIO + calls <- newIORef (0 :: Int) + let resolver = + Declaration.vampireBatchResolver \tasks -> do + assertEqual "dependent proof resolver batch is singleton" + 1 + (NonEmpty.length tasks) + ordinal <- atomicModifyIORef' calls + (\current -> (current + 1, current + 1)) + case ordinal of + 1 -> do + atomically (putTMVar firstSubmitted ()) + atomically (takeTMVar releaseFirst) + 2 -> + atomically (putTMVar secondSubmitted ()) + _ -> + assertFailure + ("unexpected dependent proof request: " + <> show ordinal) + traverse + (\prepared -> + runNoLoggingT + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared)) + tasks + withAsync + (compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace) + \checking -> do + void + (awaitSignal "local subclaim request" + (atomically (takeTMVar firstSubmitted))) + atomically (tryReadTMVar secondSubmitted) >>= \case + Nothing -> pure () + Just () -> + assertFailure + "proof continuation was submitted before its local claim" + atomically (putTMVar releaseFirst ()) + void + (awaitSignal "dependent continuation request" + (atomically (takeTMVar secondSubmitted))) + sealed <- wait checking + assertEqual "dependent proof module sealed" 1 (length sealed) + readIORef calls + >>= assertEqual "dependent proof executed two ordered requests" 2 + 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 = + Api.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 + (runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreMode + openStore + Api.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 = + Api.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 = + runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + openStore + Api.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, coldMeasurements) <- wait verification + case coldResult of + Api.VerificationCompleted{} -> pure () + other -> + assertFailure + ("cold diamond did not complete: " <> show other) + assertEqual "cold diamond module misses plus prelude hit" + (1, 4) + ( Api.verificationModuleRootHitCount coldMeasurements + , Api.verificationModuleRootMissCount coldMeasurements + ) + let forbiddenObserver = + Api.verificationRequestObserver + (\position _request -> + assertFailure + ("warm diamond invoked Vampire at " + <> show position)) + (warmResult, warmMeasurements) <- + verify (prover unavailable) forbiddenObserver + case warmResult of + Api.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm diamond did not install: " <> show other) + assertEqual "warm diamond installs each distinct root" + (5, 0) + ( Api.verificationModuleRootHitCount warmMeasurements + , Api.verificationModuleRootMissCount warmMeasurements + ) + assertEqual "warm diamond runs no prover" + 0 + (Api.verificationVampireRunCount warmMeasurements) + +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 = + Api.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 = + runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreMode + openStore + mode + observer + (prover vampirePath) + source) + >>= expectRight + reportEntries = + fmap + (\escape -> + ( Api.reportedEscapeKind escape + , locFile (Api.reportedEscapeLocation escape) + , locLine (Api.reportedEscapeLocation escape) + )) + . Api.verificationDirectEscapes + expectedConsumer = + [ ( Api.ReportedSourceAxiom + , "test/phase5/exact-escape-producer.tex" + , 1 + ) + , ( Api.ReportedOmitted + , "test/phase5/exact-escape-producer.tex" + , 9 + ) + , ( Api.ReportedOmitted + , "test/phase5/exact-escape-consumer.tex" + , 35 + ) + ] + (freshResult, freshMeasurements) <- + verify + Api.FreshStoreValidation + executable + "test/phase5/exact-escape-consumer.tex" + freshReport <- case freshResult of + Api.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) + assertEqual "cold acquisition includes prelude and two modules" + (0, 3) + ( Api.verificationModuleRootHitCount freshMeasurements + , Api.verificationModuleRootMissCount freshMeasurements + ) + + (warmResult, warmMeasurements) <- + verify + Api.WarmStoreValidation + unavailable + "test/phase5/exact-escape-consumer.tex" + warmReport <- case warmResult of + Api.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 + assertEqual "warm acquisition includes prelude and two modules" + (3, 0) + ( Api.verificationModuleRootHitCount warmMeasurements + , Api.verificationModuleRootMissCount warmMeasurements + ) + assertEqual "warm root hit invokes no Vampire process" + 0 + (Api.verificationVampireRunCount warmMeasurements) + + void + (verify + Api.FreshStoreValidation + executable + "test/phase5/exact-source-axiom.tex") + (failedResult, failedMeasurements) <- + verify + Api.WarmStoreValidation + unavailable + "test/phase6/admitted-prefix-failure.tex" + failedReport <- case failedResult of + Api.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 + <> [ ( Api.ReportedOmitted + , "test/phase6/admitted-prefix-failure.tex" + , 7 + ) + ]) + (reportEntries failedReport) + assertEqual "failed root is not counted as acquired" + (2, 0) + ( Api.verificationModuleRootHitCount failedMeasurements + , Api.verificationModuleRootMissCount failedMeasurements + ) + assertEqual "cached prefix failure invokes no Vampire process" + 0 + (Api.verificationVampireRunCount failedMeasurements) + +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 = + Api.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 = + runNoLoggingT + (Api.verifyMeasuredWithObserverAndStoreMode + openStore + Api.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, _measurements) <- + verify "test/phase5/exact-runtime-failure.tex" + case result of + Api.VerificationFailure report failed -> do + assertEqual "typed failure has no direct escapes" + [] + (Api.verificationDirectEscapes report) + assertEqual "typed failure retains source location" + "test/phase5/exact-runtime-failure.tex" + (locFile + (Api.failedVerificationLocation failed)) + classify + (Api.failedVerificationReason failed) + (CommandLine.verificationCommandOutcome result) + 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, _preludeMeasurements) <- + 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 + Api.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 + Api.IndeterminateFailure{} -> pure () + other -> assertFailure ("expected indeterminate result: " <> show other) + case outcome of + CommandLine.ProverFailed + _report _location CommandLine.ProverIndeterminate{} -> + 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 + Api.ProtocolFailure{} -> pure () + other -> assertFailure ("expected protocol failure: " <> show other) + case outcome of + CommandLine.ProverFailed + _report _location CommandLine.ProverProtocolFailure{} -> + 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 + Api.TransportFailure{} -> pure () + other -> assertFailure ("expected transport failure: " <> show other) + case outcome of + CommandLine.ProverFailed + _report _location CommandLine.ProverTransportFailure{} -> + pure () + other -> assertFailure ("expected prover failure: " <> show other) + retainsExactPrefixBeforeFailure :: Assertion retainsExactPrefixBeforeFailure = do result <- @@ -4675,13 +5763,16 @@ retainsExactPrefixBeforeFailure = do prover "test/phase5/exact-failure.tex") case result of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError source (Module.TypedActionFailed (Module.TypedExactCompileFailed (Exact.ExactUnsupportedDeclarationBody location))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "failed exact source" "test/phase5/exact-failure.tex" (safeRelativePathFilePath @@ -4702,14 +5793,17 @@ retainsExactPrefixBeforeFailure = do prover "test/phase5/exact-proof-failure.tex") case proofFailure of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofGoalStatementMismatch location))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "mismatched assumption line" 10 (locLine location) assertEqual "failed proof publishes no theorem" 1 @@ -4727,12 +5821,15 @@ retainsExactPrefixBeforeFailure = do prover "test/phase5/unmatched-proof.tex") case unmatched of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedUnmatchedProof location)) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "unmatched proof line" 1 (locLine location) assertEqual "unmatched proof publishes no declaration" 0 @@ -4821,14 +5918,17 @@ rejectsNestedExactSetInduction = do prover "test/phase5/exact-induction-nested.tex") case result of - Left - (Api.VerificationTypedModuleError + Right + ( Api.VerificationCheckingFailure _report + (Api.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofSetInductionNotOutermost location))) - prefix) -> do + prefix) + , _measurements + ) -> do assertEqual "nested induction line" 7 (locLine location) assertBool "failed proof publishes no theorem" (null (Declaration.pendingModulePrefixBatches prefix)) @@ -4854,35 +5954,14 @@ routesProductionVerification = setPermissions executable (setOwnerExecutable True permissions) producer <- verifyFixture executable "test/phase3/typed-producer.tex" - assertRoute "selected producer" - Api.TypedVerificationRoute - producer - setRoot <- verifyFixture executable "set.tex" - assertRoute "protected set root" - Api.TypedVerificationRoute - setRoot - natRoot <- verifyFixture executable "nat.tex" - assertRoute "protected naturals root" - Api.TypedVerificationRoute - natRoot - forM_ - [ ("bipartition", "set/bipartition.tex") - , ("function", "function.tex") - , ("Cantor", "set/cantor.tex") - ] - \(label, path) -> - assertRoute ("typed " <> label) - Api.TypedVerificationRoute - =<< verifyFixture executable path + assertTypedSuccess "exact producer" producer selectedRuns <- runCount counter - assertBool "selected roots constructed the final prelude" + assertBool "ordinary roots construct the final prelude" (selectedRuns > 0) - importer <- verifyFixture executable "test/phase3/legacy-importer.tex" - assertRoute "unselected importer" - Api.LegacyVerificationRoute - importer - assertEqual "legacy root did not construct the final prelude" - selectedRuns + 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 = @@ -4899,16 +5978,6 @@ routesProductionVerification = runCount path = length . StrictText.lines . StrictText.pack <$> readFile path - assertRoute label expected = \case - Api.VerifiedWithTrustedVampire report -> - assertEqual label expected (Api.verificationRoute report) - Api.CompletedWithExplicitGaps report -> - assertFailure - (label <> " completed with gaps via " - <> show (Api.verificationRoute report)) - Api.VerificationFailure failure -> - assertFailure (label <> " failed: " <> show failure) - installsNonemptyImplicitPreludeEvidence :: Assertion installsNonemptyImplicitPreludeEvidence = do foundation <- expectRight Foundation.checkedFoundation @@ -5330,13 +6399,13 @@ parseExactWorkspace bootstrap mounts relative = relative parseFinalExactWorkspace - :: Module.MigrationPreludeSession + :: Module.FinalPreludeSession -> SourceMounts -> FilePath -> IO Parse.ParsedSourceWorkspace parseFinalExactWorkspace prelude mounts relative = parseExactWorkspaceWithPrelude - (Module.migrationPreludeModule prelude) + (Module.finalPreludeModule prelude) mounts relative @@ -5401,7 +6470,7 @@ compileParsedWorkspaceWithValidation compileFinalParsedWorkspaceWithResolver :: Foundation.CheckedFoundation - -> Module.MigrationPreludeSession + -> Module.FinalPreludeSession -> Declaration.VampireResolver -> Parse.ParsedSourceWorkspace -> IO [Module.SealedTypedModule] @@ -5468,14 +6537,13 @@ compileParsedWorkspaceWithReadiness assertTypedSuccess :: String -> Api.VerificationResult -> Assertion assertTypedSuccess label = \case - Api.VerifiedWithTrustedVampire report -> - assertEqual label Api.TypedVerificationRoute - (Api.verificationRoute report) - Api.CompletedWithExplicitGaps report -> - assertFailure - (label <> " completed with gaps via " - <> show (Api.verificationRoute report)) - Api.VerificationFailure failure -> + Api.VerificationCompleted _report _presentation -> + pure () + Api.CompletedWithExplicitGaps _report _presentation -> + assertFailure (label <> " completed with gaps") + Api.VerificationFailure _report failure -> + assertFailure (label <> " failed: " <> show failure) + Api.VerificationCheckingFailure _report failure -> assertFailure (label <> " failed: " <> show failure) sole :: String -> [value] -> IO value @@ -5494,3 +6562,16 @@ expectRight = \case 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/Test/Unit/Provers.hs b/source/Test/Unit/Provers.hs index d852755..22a6b5b 100644 --- a/source/Test/Unit/Provers.hs +++ b/source/Test/Unit/Provers.hs @@ -2,24 +2,24 @@ module Test.Unit.Provers (unitTests) where -import Base +import Base hiding (Empty) +import Checking.Backend.Problem +import Checking.Core import Provers -import Report.Location (pattern Nowhere) -import Syntax.Internal - ( Directness(..) - , Hypothesis(..) - , Marker(..) - , Task(..) - , pattern Top - ) import Control.Concurrent (threadDelay) import Control.Exception (bracket) import Control.Exception qualified as Exception import Control.Monad.Logger (runNoLoggingT) +import Data.IORef + ( 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 System.Directory qualified as Directory import System.Exit (ExitCode(..)) import System.FilePath.Posix ((</>)) @@ -34,16 +34,162 @@ import Test.Tasty import Test.Tasty.HUnit import Text.Read (readMaybe) import Text.Megaparsec (parseMaybe) -import UnliftIO.Async (cancel, withAsync) +import UnliftIO.Async (cancel, mapConcurrently, withAsync) unitTests :: TestTree unitTests = testGroup "Provers" [ vampireStatusParserTests , vampireClassifierTests + , jobsSelectionTests + , 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) + jobsSelectionEffectiveJobs selected + `shouldBe` positiveJobs 3 + jobsSelectionDetectedProcessors selected `shouldBe` Nothing + jobsSelectionWasOverridden selected `shouldBe` True + readIORef detectorCalled >>= (`shouldBe` False) + , testCase "leaves one detected logical processor free" do + selected <- selectEffectiveJobs Nothing (pure 8) + jobsSelectionEffectiveJobs selected + `shouldBe` positiveJobs 7 + jobsSelectionDetectedProcessors selected `shouldBe` Just 8 + jobsSelectionWasOverridden selected `shouldBe` False + , testCase "falls back to one after bad detection" do + nonPositive <- selectEffectiveJobs Nothing (pure 0) + jobsSelectionEffectiveJobs nonPositive + `shouldBe` positiveJobs 1 + failed <- selectEffectiveJobs Nothing + (Exception.throwIO (userError "processor detection failed")) + jobsSelectionEffectiveJobs failed + `shouldBe` positiveJobs 1 + jobsSelectionDetectedProcessors failed `shouldBe` Nothing + ] + +vampireExecutorTests :: TestTree +vampireExecutorTests = + testGroup "bounded Vampire executor" + [ testCase "bounds live one-core processes" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "previous=''" + , "found=0" + , "for argument in \"$@\"; do" + , " if [ \"$previous\" = '--cores' ]; then" + , " [ \"$argument\" = '1' ] || 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 -> do + answers <- mapConcurrently + (\ordinal -> + runNoLoggingT + (runPreparedTypedProverWithExecutor + executor + (workPosition 1 ordinal) + prepared)) + [1..4] + traverse_ assertProved answers + observed <- vampireExecutorObservation executor + vampireExecutorRunCount observed `shouldBe` 4 + vampireExecutorMaximumLiveCount observed + `shouldBe` 2 + , 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 -> do + result <- Exception.try + (runNoLoggingT + (runPreparedTypedProverWithExecutor + executor + (workPosition 1 1) + prepared)) + case result of + Left (failure :: Exception.IOException) -> + assertBool + "observer exception" + ("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 -> + withAsync + (runNoLoggingT + (runPreparedTypedProverWithExecutor + executor + (workPosition 1 1) + prepared)) + \running -> do + processIds <- waitForProcessIds pidFile + withAsync + (runNoLoggingT + (runPreparedTypedProverWithExecutor + executor + (workPosition 2 1) + prepared)) + \queued -> do + waitForSubmittedCount executor 2 + cancel queued + cancel running + observed <- vampireExecutorObservation + executor + vampireExecutorSubmittedCount observed + `shouldBe` 2 + vampireExecutorRunCount observed + `shouldBe` 1 + assertProcessesGone processIds + ] + +positiveJobs :: Int -> EffectiveJobs +positiveJobs amount = + fromMaybe + (error "test requested a non-positive job count") + (effectiveJobs amount) + vampireStatusParserTests :: TestTree vampireStatusParserTests = testGroup "Vampire status parser" @@ -165,12 +311,14 @@ vampireProcessTests = assertFailure ("expected malformed stdout, got " <> show result) , testCase "returns a broken stdin pipe" do + prepared <- preparedTypedTask 20000 result <- withFakeVampire [ "exec 0<&-" , "sleep 1" ] \vampireCommand -> - runVampireProcess vampireCommand largeTask + runNoLoggingT + (runPreparedTypedProver vampireCommand prepared) case result of Left (ProverCommunicationFailed _ ProverStdin _) -> pure () @@ -179,6 +327,7 @@ vampireProcessTests = ("expected a communication failure, got " <> show processResult) , testCase "drains output while feeding prover input" do + prepared <- preparedTypedTask 20000 guardedAnswer <- Timeout.timeout 30000000 (withFakeVampire @@ -192,21 +341,23 @@ vampireProcessTests = , "exit 0" ] \vampireCommand -> do - (_location, _formula, answer) <- - runNoLoggingT - (runProver vampireCommand largeTask) - pure answer) + runNoLoggingT + (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 -> - runVampireProcess vampireCommand directTask + runNoLoggingT + (runPreparedTypedProver vampireCommand prepared) case result of Left (ProverTerminatedBySignal @@ -222,27 +373,31 @@ vampireProcessTests = ("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 <- - runVampireProcess - vampireCommand - directTask + runNoLoggingT + (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 <- - runVampireProcess - vampireCommand - directTask + runNoLoggingT + (runPreparedTypedProver + vampireCommand + prepared) case result of Left (ProverOutputLimitExceeded @@ -257,14 +412,16 @@ vampireProcessTests = processIds <- readProcessIds pidFile assertProcessesGone processIds , testCase "cancellation terminates and reaps the process group" do + prepared <- preparedTypedTask 0 withProcessGroupFake defaultTimeLimit [] \pidFile vampireCommand -> withAsync - (runVampireProcess - vampireCommand - directTask) + (runNoLoggingT + (runPreparedTypedProver + vampireCommand + prepared)) \worker -> do processIds <- waitForProcessIds pidFile cancel worker @@ -408,6 +565,24 @@ waitForProcessIds path = do threadDelay 10000 loop +waitForSubmittedCount :: VampireExecutor -> Int -> Assertion +waitForSubmittedCount executor expected = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just () -> + pure () + Nothing -> + assertFailure + ("executor did not submit " <> show expected <> " requests") + where + loop = do + observed <- vampireExecutorObservation executor + if vampireExecutorSubmittedCount observed >= expected + then pure () + else do + threadDelay 10000 + loop + assertProcessesGone :: [ProcessID] -> Assertion assertProcessesGone processIds = do guarded <- Timeout.timeout 10000000 loop @@ -442,9 +617,9 @@ runFakeVampire scriptLines = withFakeVampire (["cat >/dev/null"] <> scriptLines) \vampireCommand -> do - (_location, _formula, answer) <- runNoLoggingT - (runProver vampireCommand directTask) - pure answer + prepared <- preparedTypedTask 0 + runNoLoggingT + (runPreparedTypedProver vampireCommand prepared) withFakeVampire :: [String] @@ -496,21 +671,43 @@ shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion shouldBe = flip (assertEqual "") -directTask :: Task -directTask = - Task - { taskDirectness = Direct - , taskHypotheses = [] - , taskConjectureLabel = Marker "dummy" - , taskLocation = Nowhere - , taskConjecture = Top - } +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 + [] + [] + ExplicitGlobalPremises + FirstOrderLocals) + expectRight (prepareTypedProverTask DirectTask problem) + where + propositionTerm = + CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty) -largeTask :: Task -largeTask = - directTask - { taskHypotheses = - replicate - 20000 - (Hypothesis (Marker "large") Top) - } +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/Test/Unit/Semantic.hs b/source/Test/Unit/Semantic.hs index 4a22f08..160735c 100644 --- a/source/Test/Unit/Semantic.hs +++ b/source/Test/Unit/Semantic.hs @@ -19,6 +19,7 @@ import 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 @@ -32,6 +33,8 @@ unitTests = roundTripsSemanticState , testCase "round-trips exact semantic global keys" roundTripsSemanticGlobalKeys + , testCase "round-trips canonical structure descriptors" + roundTripsStructureDescriptors , testCase "keys exact proof and module inputs" keysExactInputs ] @@ -102,7 +105,11 @@ roundTripsSemanticGlobalKeys = do first : rest -> Semantic.semanticGlobalBinding first - (Semantic.TransparentExpansion target) + (Semantic.ContextualTransparentExpansion + target + (Map.singleton + (Raw.StructSymbol "operation") + target)) : [ Semantic.semanticGlobalBinding key (Semantic.GlobalReference target) @@ -129,6 +136,53 @@ roundTripsSemanticGlobalKeys = do (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 diff --git a/source/Test/Unit/Source.hs b/source/Test/Unit/Source.hs index 3f6703e..73eaef5 100644 --- a/source/Test/Unit/Source.hs +++ b/source/Test/Unit/Source.hs @@ -5,35 +5,24 @@ module Test.Unit.Source (unitTests) where import Base -import Checking qualified -import Checking.Backend.Problem qualified as Backend -import Checking.Backend.Reconstruction qualified as Reconstruction -import Checking.Core qualified as Core -import Checking.Facts qualified as Facts import Checking.Foundation qualified as Foundation import Checking.Identity qualified as Identity -import Checking.Kernel.Derivation qualified as Derivation -import Checking.Legacy qualified as Legacy -import Checking.Obligation qualified as Obligation import Checking.Semantic qualified as Semantic -import Checking.Transition qualified as Transition 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 Meaning qualified -import Provers qualified import Report.Location ( FileId(..) , FileIdAllocator(..) , Location(..) , LocationRegistrationError(..) - , pattern Nowhere , allocateFileId , locColumn , locFile @@ -44,21 +33,14 @@ import Report.Location import Syntax.Abstract qualified as Raw import Syntax.Adapt qualified as Adapt import Syntax.Interface qualified as Interface -import Syntax.Internal import Syntax.Token (runLexer) -import Bound.Scope (toScope) -import Control.Exception (bracket, evaluate, try) -import Control.Monad (foldM) -import Control.Monad.Logger (runNoLoggingT) +import Control.Exception (bracket, evaluate) import Data.ByteString qualified as ByteString -import Data.HashMap.Strict qualified as HashMap import Data.IORef import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty -import Data.Set qualified as Set import Data.Text qualified as Text -import Data.Vector qualified as Vector import Data.Word (Word8, Word16) import Database.SQLite.Simple qualified as SQLite import System.Directory qualified as Directory @@ -89,6 +71,8 @@ unitTests = testGroup "Source resolution" , 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" @@ -114,20 +98,6 @@ unitTests = testGroup "Source resolution" , testCase "rejects a corrupted cached declaration anchor" rejectsCorruptedCachedDeclarationAnchor , testCase "parses source-local blocks in graph order" parsesSourceGraph - , testCase "assigns and reserves dense legacy module positions" - reservesLegacyModulePositions - , testCase "admits complete legacy declaration batches" - admitsLegacyDeclarations - , testCase "publishes deterministic legacy import views" - publishesLegacyImportViews - , testCase "publishes typed signatures and facts through transition modules" - publishesTransitionSignatures - , testCase "rejects cached global types from another builder" - rejectsForeignCachedGlobalType - , testCase "authorizes exact typed Vampire requests" - authorizesTypedVampireRequests - , testCase "enforces and replays direct inductive guards" - publishesTypedInductive , testCase "does not leak syntax between sibling imports" rejectsSiblingSyntaxLeakage , testCase "parses source fixity levels and grouping" @@ -154,10 +124,8 @@ unitTests = testGroup "Source resolution" reportsMalformedLexicalDeclaration , testCase "validates inductive function patterns during scanning" rejectsMalformedInductivePattern - , testCase "scans, parses, and checks adjective signatures" + , testCase "scans and parses adjective signatures" acceptsAdjectiveSignature - , testCase "rejects unresolved quantified symbolic-signature terms" - rejectsQuantifiedSymbolicSignatureTerm , testCase "rejects malformed math-led signature heads" rejectsMalformedSignatureHead , testCase "locates conflicting declarations within one environment" @@ -166,8 +134,6 @@ unitTests = testGroup "Source resolution" acceptsBuiltinSourceDeclaration , testCase "keeps the built-in marker for a prefix predicate declaration" acceptsBuiltinPrefixPredicateDeclaration - , testCase "rejects duplicate fixed-base semantics during checking" - rejectsDuplicateFixedBaseSemantics , testCase "does not rescan repeated canonical imports" avoidsAliasImportLexiconCollision , testCase "parses loaded sources without rereading files" parsesWithoutRereading @@ -275,6 +241,47 @@ rootFormsShareIdentity = (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.parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation + 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.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation + 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 @@ -682,46 +689,6 @@ buildsEmptyModules = (Parse.parsedModuleSyntaxInterface (Parse.parsedWorkspaceRootModule workspace))))) - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - assignment <- - case toList assignments of - [only] -> - pure only - actual -> - assertFailure - ("expected one empty module assignment, got " - <> show (length actual)) - >> fail "unreachable" - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - builder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - []) - checked <- - Checking.runCheckingBlocks - [] - (Checking.initialTransitionCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - builder - (\_batch -> - assertFailure - "empty module emitted an obligation")) - finalBuilder <- - expectJust - "empty transition builder" - (Checking.checkingTransitionModuleBuilder checked) - void - (expectRight - (Transition.sealTransitionModule - (Checking.checkingStateEnvironment checked) - finalBuilder)) identifiesOwnerIndependentParsedModules :: Assertion identifiesOwnerIndependentParsedModules = @@ -1235,1613 +1202,6 @@ parsesSourceGraph = ["shared.tex", "entry.tex"] emitted -reservesLegacyModulePositions :: Assertion -reservesLegacyModulePositions = - withTemporaryDirectory "felix-legacy-module-stage" \temp -> do - writeTheory (temp Posix.</> "shared.tex") [] "shared" - writeTheory - (temp Posix.</> "entry.tex") - ["shared.tex"] - "entry" - graph <- buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - assertEqual "dense imported-first module ordinals" - [0, 1] - ( Legacy.legacyModuleOrdinalValue - . Legacy.assignedLegacyModuleOrdinal - <$> toList assignments - ) - assertEqual "assigned source order" - ["shared.tex", "entry.tex"] - ( safeRelativePathFilePath - . sourceAddressRelativePath - . Parse.parsedModuleAddress - . Legacy.assignedParsedModule - <$> toList assignments - ) - - let firstAssignment :| _remainingAssignments = - assignments - stage = - Legacy.openLegacyModuleStage - firstAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - origin = Facts.factOrigin (Location 0) "declaration" - firstFact = - Facts.stageFact - ("first" :| ["first_alias"]) - origin - (Facts.prepareSemanticFact Top) - secondFact = - Facts.stageFact - ("second" :| []) - origin - (Facts.prepareSemanticFact Bottom) - reservation <- - expectRight - (Legacy.reserveLegacyDeclaration - (firstFact :| [secondFact]) - stage) - assertEqual "dense local fact ordinals" - [0, 1] - ( Legacy.legacyLocalFactOrdinalValue - . Legacy.legacyFactLocalOrdinal - . Legacy.legacyReservedFactReference - <$> toList (Legacy.legacyReservedFacts reservation) - ) - - let duplicateAliasFact = - Facts.stageFact - ("first_alias" :| []) - origin - (Facts.prepareSemanticFact Bottom) - case Legacy.reserveLegacyDeclaration - (firstFact :| [duplicateAliasFact]) - stage of - Left Legacy.LegacyAliasAlreadyBound{} -> - pure () - Left err -> - assertFailure - ("expected alias rejection, got " <> show err) - Right _ -> - assertFailure "expected duplicate legacy alias rejection" - -admitsLegacyDeclarations :: Assertion -admitsLegacyDeclarations = - withTemporaryDirectory "felix-legacy-admission" \temp -> do - writeTheory (temp Posix.</> "entry.tex") [] "entry" - graph <- buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignment :| _ <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - let stage = - Legacy.openLegacyModuleStage - assignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - blocks = - [ BlockAxiom - Nowhere - "declared" - (Axiom [] Top) - , BlockLemma - Nowhere - "omitted" - (Lemma [] Bottom) - , BlockProof - Nowhere - Nowhere - (Omitted Nowhere) - ] - resolveGapBatch batch = do - resolved <- - traverse - (either - (ioError . userError . show) - pure - . Obligation.resolveObligationAsGap) - (Obligation.preparedBatchObligations batch) - either - (ioError . userError . show) - pure - (Obligation.resolveObligationBatch - batch - resolved) - initial = - Checking.initialLegacyCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - stage - resolveGapBatch - checked <- - Checking.runCheckingBlocks blocks initial - admittedStage <- - maybe - (assertFailure - "authoritative checking lost the legacy stage" - >> pure stage) - pure - (Checking.checkingLegacyModuleStage checked) - admittedModule <- - expectRight - (Legacy.sealLegacyModuleStage - (Checking.checkingStateEnvironment checked) - admittedStage) - assertEqual "two sealed local facts" - 2 - (Vector.length - (Legacy.legacyAdmittedLocalFacts admittedModule)) - assertEqual "one sealed declared assumption" - 1 - (Vector.length - (Legacy.legacyAdmittedDirectAxiomManifest - admittedModule)) - let finalTrust = - Legacy.legacyFactEntryTrustDependencies - (Vector.last - (Legacy.legacyAdmittedLocalFacts - admittedModule)) - assertEqual "one explicit gap" - 1 - (Set.size - (Legacy.legacyExplicitGaps finalTrust)) - assertEqual "direct gap needs no legacy finalization rule" - 0 - (Set.size - (Legacy.trustedLegacyRuleUses finalTrust)) - -publishesTransitionSignatures :: Assertion -publishesTransitionSignatures = - withTemporaryDirectory "felix-transition-signatures" \temp -> do - writeTheory (temp Posix.</> "shared.tex") [] "shared" - writeTheory - (temp Posix.</> "entry.tex") - ["shared.tex"] - "entry" - graph <- buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - case toList assignments of - [sharedAssignment, entryAssignment] -> do - shared <- - admit - checkedFoundationValue - sharedAssignment - [] - [ BlockSig - Nowhere - "shared_signature" - [] - (SignaturePredicate - sharedPredicate - ("x" :| [])) - , BlockAxiom - Nowhere - "shared_atomic_axiom" - (Axiom [] sharedAtomicFormula) - ] - let sharedGlobals = - Transition.transitionAdmittedGlobals - shared - assertEqual - "one shared typed declaration" - 1 - (Vector.length sharedGlobals) - case Vector.toList sharedGlobals of - [(symbol, reference, _origin)] -> do - assertEqual - "shared symbol" - (SymbolPredicate sharedPredicate) - symbol - assertEqual - "shared declaration ordinal" - 0 - (Transition.localDeclarationOrdinalValue - (Transition.opaqueDeclarationOrdinal - (Transition.checkedGlobalReference - reference))) - assertEqual - "shared predicate type" - (Core.TySet - `Core.TyArrow` - Core.TyProp) - (Transition.checkedGlobalType reference) - _ -> - assertFailure - "expected one shared typed declaration" - let sharedFacts = - Vector.toList - (Transition.transitionAdmittedFacts - shared) - sharedManifest = - Vector.toList - (Transition.transitionAdmittedTypedDirectAxiomManifest - shared) - (sharedReference, sharedStatement) <- - case (sharedFacts, sharedManifest) of - ([assumption], [manifestEntry]) -> do - assertBool - "typed axiom is not a kernel proof" - (not - (Transition.admittedFactIsKernelProof - assumption)) - assertEqual - "manifest kind" - Legacy.DeclaredUserAxiom - (Transition.typedDirectAssumptionKind - manifestEntry) - assertEqual - "manifest fact reference" - (Just - (Transition.typedDirectAssumptionFact - manifestEntry)) - (Transition.transitionTypedFactReference - (Transition.admittedFactReference - assumption)) - pure - ( Transition.admittedFactReference - assumption - , Transition.typedDirectAssumptionStatement - manifestEntry - ) - _ -> - fail - "expected one manifest-backed typed axiom" - - hiddenBuilder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - entryAssignment - []) - hiddenTarget <- - expectRight - (Core.checkCanonicalCore - (const Nothing) - (Core.CImp - Core.CFalsum - Core.CFalsum)) - hiddenImport <- - expectRight - (Transition.transitionDerivationImport - sharedReference - hiddenTarget) - case Transition.commitTransitionKernelFactWithImports - ("hidden_import" :| []) - (Transition.origin - Nowhere - Nothing - (Just "hidden_import")) - (Vector.singleton hiddenImport) - hiddenTarget - (Derivation.importedFactDerivation - (Derivation.importIx 0)) - hiddenBuilder of - Left - (Transition.TransitionKernelImportNotVisible - actualReference) -> - assertEqual - "unimported fact reference" - sharedReference - actualReference - Left err -> - assertFailure - ("expected hidden typed import failure, got " - <> show err) - Right _ -> - assertFailure - "an unimported typed row authorized replay" - - entryBuilder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - entryAssignment - [shared]) - assertBool - "direct import exposes the typed global" - (isJust - (Transition.lookupTransitionGlobal - (SymbolPredicate sharedPredicate) - entryBuilder)) - entry <- - admitWithBuilder - entryBuilder - [ BlockAxiom - Nowhere - "legacy_axiom" - (Axiom [] Top) - , BlockSig - Nowhere - "entry_signature" - [] - (SignaturePredicate - entryPredicate - ("z" :| [])) - , BlockLemma - Nowhere - "typed_import_reuse" - (Lemma [] sharedAtomicFormula) - , BlockLemma - Nowhere - "typed_reflexivity" - (Lemma - [] - (Equals - Nowhere - (EmptySet Nowhere) - (EmptySet Nowhere))) - ] - case Vector.toList - (Transition.transitionAdmittedGlobals - entry) of - [(_symbol, reference, _origin)] -> - assertEqual - "legacy declaration occupies its source ordinal" - 1 - (Transition.localDeclarationOrdinalValue - (Transition.opaqueDeclarationOrdinal - (Transition.checkedGlobalReference - reference))) - _ -> - assertFailure - "expected one local entry declaration" - let facts = - Vector.toList - (Transition.transitionAdmittedFacts - entry) - assertEqual - "imported and local rows retain declaration order" - [False, False, True, True] - (Transition.admittedFactIsKernelProof - <$> facts) - case facts of - [_assumption, _legacy, reused, reflexivity] -> do - case Transition.transitionTypedFactReference - (Transition.admittedFactReference - reused) of - Nothing -> - assertFailure - "expected a typed fact reference" - Just reference -> - assertEqual - "first typed fact ordinal" - 0 - (Transition.localFactOrdinalValue - (Transition.factReferenceOrdinal - reference)) - case Transition.transitionTypedFactReference - (Transition.admittedFactReference - reflexivity) of - Nothing -> - assertFailure - "expected a typed reflexivity reference" - Just reference -> - assertEqual - "second typed fact ordinal" - 1 - (Transition.localFactOrdinalValue - (Transition.factReferenceOrdinal - reference)) - _ -> - assertFailure - "expected imported assumption and three local facts" - let inheritedAssumptions = - Set.toList - (Transition.typedDeclaredAssumptionUses - (Transition.transitionAdmittedTypedTrustDependencies - entry)) - case inheritedAssumptions of - [assumption] -> do - assertEqual - "the importer retains the owner fact" - (Transition.transitionTypedFactReference - sharedReference) - (Just - (Transition.sessionTypedAssumptionFact - assumption)) - assertEqual - "the owner assumption ordinal" - 0 - (Transition.localAssumptionOrdinalValue - (Transition.sessionTypedAssumptionOrdinal - assumption)) - assertEqual - "the imported assumption statement" - sharedStatement - (Transition.sessionTypedAssumptionStatement - assumption) - _ -> - assertFailure - "expected one inherited typed declared assumption" - assertEqual - "two local replayed kernel proofs" - 2 - (Transition.transitionAdmittedKernelProofCount - entry) - actual -> - assertFailure - ("expected two module assignments, got " - <> show (length actual)) - where - sharedPredicate = - PredicateSymbol "typed_shared_predicate" - entryPredicate = - PredicateSymbol "typed_entry_predicate" - sharedAtomicFormula = - Atomic - Nowhere - sharedPredicate - [EmptySet Nowhere] - - admit checkedFoundationValue assignment imports blocks = do - builder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - imports) - admitWithBuilder builder blocks - - admitWithBuilder builder blocks = do - checked <- - Checking.runCheckingBlocks - blocks - (Checking.initialTransitionCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - builder - (\_batch -> - assertFailure - "typed transition emitted an obligation")) - finalBuilder <- - maybe - (assertFailure - "checking lost its transition builder") - pure - (Checking.checkingTransitionModuleBuilder - checked) - expectRight - (Transition.sealTransitionModule - (Checking.checkingStateEnvironment checked) - finalBuilder) - -rejectsForeignCachedGlobalType :: Assertion -rejectsForeignCachedGlobalType = - withTemporaryDirectory "felix-transition-global-types" \temp -> do - writeTheory - (temp Posix.</> "entry.tex") - [] - "entry" - graph <- - buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - assignment <- - case toList assignments of - [only] -> - pure only - actual -> - assertFailure - ("expected one module assignment, got " - <> show (length actual)) - >> fail "unreachable" - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - builderA0 <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - []) - builderB0 <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - []) - let symbol = - SymbolPredicate - (PredicateSymbol - "same_nominal_global") - declarationOrigin = - Transition.origin - Nowhere - Nothing - (Just "same_nominal_global") - builderA <- - expectRight - (Transition.commitTransitionOpaqueGlobal - symbol - Core.TySet - declarationOrigin - (Transition.beginTransitionDeclaration - builderA0)) - builderB <- - expectRight - (Transition.commitTransitionOpaqueGlobal - symbol - Core.TyProp - declarationOrigin - (Transition.beginTransitionDeclaration - builderB0)) - globalA <- - maybe - (assertFailure "builder A lost its global" - >> fail "unreachable") - pure - (Transition.lookupTransitionGlobal - symbol - builderA) - globalB <- - maybe - (assertFailure "builder B lost its global" - >> fail "unreachable") - pure - (Transition.lookupTransitionGlobal - symbol - builderB) - operand <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - (Core.CGlobal globalA)) - statement <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - (Core.CEq - Core.TySet - (Core.CGlobal globalA) - (Core.CGlobal globalA))) - case Transition.commitTransitionKernelFact - ("foreign_global_type" :| []) - (Transition.origin - Nowhere - Nothing - (Just "foreign_global_type")) - statement - (Derivation.equalityReflexivityDerivation - operand) - (Transition.beginTransitionDeclaration - builderB) of - Left - (Transition.TransitionGlobalReferenceTypeMismatch - actual - authoritativeType) -> do - assertEqual - "cached global reference" - globalA - actual - assertEqual - "builder B authoritative type" - Core.TyProp - authoritativeType - Left err -> - assertFailure - ("expected cached global type rejection, got " - <> show err) - Right _ -> - assertFailure - "builder B admitted builder A's cached type" - let remappedOperand = - Core.mapFrozenGlobals - (const globalB) - operand - remappedStatement = - Core.mapFrozenGlobals - (const globalB) - statement - case Transition.commitTransitionKernelFact - ("stale_term_annotation" :| []) - (Transition.origin - Nowhere - Nothing - (Just "stale_term_annotation")) - remappedStatement - (Derivation.equalityReflexivityDerivation - remappedOperand) - (Transition.beginTransitionDeclaration - builderB) of - Left - (Transition.TransitionCoreCheckError - (Core.EqualityOperandTypeMismatch - Core.TySet - Core.TyProp)) -> - pure () - Left err -> - assertFailure - ("expected fresh builder-relative core check, got " - <> show err) - Right _ -> - assertFailure - "builder B admitted a stale term annotation" - -authorizesTypedVampireRequests :: Assertion -authorizesTypedVampireRequests = - withTemporaryDirectory "felix-typed-vampire" \temp -> do - let sourcePath = - temp Posix.</> "entry.tex" - executablePath = - temp Posix.</> "vampire" - writeTheory sourcePath [] "entry" - graph <- - buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals - workspace) - assignment <- - case toList assignments of - [only] -> - pure only - actual -> - assertFailure - ("expected one module assignment, got " - <> show (length actual)) - >> fail "unreachable" - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - baseBuilder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - []) - let legacyStage = - Transition.transitionBuilderLegacyStage - baseBuilder - legacyStaged = - Facts.stageFact - ("legacy_input" :| []) - (Facts.factOrigin - (Location 0) - "legacy_input") - (Facts.prepareSemanticFact Top) - legacyReservation <- - expectRight - (Legacy.reserveLegacyDeclaration - (legacyStaged :| []) - legacyStage) - let legacyReserved = - NonEmpty.head - (Legacy.legacyReservedFacts - legacyReservation) - legacyAdmitted = - Legacy.authorizeLegacyDeclaredAssumption - legacyStage - Legacy.DeclaredUserAxiom - legacyReserved - legacyStage' <- - expectRight - (Legacy.appendEstablishedLegacyDeclaration - legacyReservation - (legacyAdmitted :| []) - legacyStage) - builderWithLegacy <- - expectRight - (Transition.transitionBuilderWithLegacyStage - legacyStage' - baseBuilder) - target <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - (Core.CImp - Core.CFalsum - Core.CFalsum)) - claim <- - expectRight - (Backend.supportedProposition - (Vector.empty - :: Vector.Vector - (Void, Core.CoreType)) - (Core.embedClosedCore [] target)) - builderWithFof <- - expectRight - (Transition.commitTransitionTypedDeclaredAssumption - ("fof_input" :| []) - (Transition.origin - Nowhere - Nothing - (Just "fof_input")) - Legacy.DeclaredUserAxiom - target - (Transition.beginTransitionDeclaration - builderWithLegacy)) - let higherOrderTarget = - Core.mapFrozenGlobals - absurd - (Foundation.foundationAxiomFrozen - checkedFoundationValue - Foundation.DoubleNegationElim) - builderWithTh0 <- - expectRight - (Transition.commitTransitionTypedDeclaredAssumption - ("th0_input" :| []) - (Transition.origin - Nowhere - Nothing - (Just "th0_input")) - Legacy.DeclaredUserAxiom - higherOrderTarget - (Transition.beginTransitionDeclaration - builderWithFof)) - builder <- - expectRight - (Transition.commitTransitionTypedDeclaredAssumption - ("second_fof_input" :| []) - (Transition.origin - Nowhere - Nothing - (Just "second_fof_input")) - Legacy.DeclaredUserAxiom - target - (Transition.beginTransitionDeclaration - builderWithTh0)) - implicitProblem <- - expectRight - (Transition.planTransitionTypedProblem - builder - claim - [] - [] - Transition.ImplicitFofFacts - Backend.FirstOrderLocals) - let selected = - Vector.toList - (Backend.typedProblemGlobalPremises - implicitProblem) - references <- - traverse - ( maybe - (assertFailure - "implicit planning selected a legacy row" - >> fail "unreachable") - pure - . Transition.transitionTypedFactReference - . Backend.typedBackendFactReference - ) - selected - assertEqual - "implicit planning preserves FOF admission order" - [0, 2] - ( Transition.localFactOrdinalValue - . Transition.factReferenceOrdinal - <$> references - ) - assertEqual - "implicit admitted-fact route" - Backend.RouteFof - (Backend.typedProblemRoute - implicitProblem) - explicitHigherOrder <- - expectRight - (Transition.planTransitionTypedProblem - builder - claim - [] - [] - (Transition.ExplicitFacts - ("th0_input" :| ["th0_input"])) - Backend.FirstOrderLocals) - assertEqual - "explicit higher-order admitted fact selects TH0" - Backend.RouteTh0 - (Backend.typedProblemRoute - explicitHigherOrder) - assertEqual - "repeated explicit aliases select one fact" - 1 - (Vector.length - (Backend.typedProblemGlobalPremises - explicitHigherOrder)) - case Transition.planTransitionTypedProblem - builder - claim - [] - [] - (Transition.ExplicitFacts - ("legacy_input" :| [])) - Backend.FirstOrderLocals of - Left - (Transition.TransitionTypedProblemDependencyNotMigrated - reference) -> - assertEqual - "legacy dependency stays legacy" - Nothing - (Transition.transitionTypedFactReference - reference) - result' -> - assertFailure - ("expected legacy dependency rejection, got " - <> case result' of - Left err -> - "Left " <> show err - Right _problem -> - "Right problem") - problem <- - expectRight - (Transition.planTransitionTypedProblem - builder - claim - [] - [Backend.typedFoundationAuxiliaryInput - checkedFoundationValue - Foundation.DoubleNegationElim] - Transition.NoGlobalFacts - Backend.AllLocals) - prepared <- - expectRight - (Provers.prepareTypedProverTask - Provers.DirectTask - problem) - mismatched <- - expectRight - (Provers.prepareTypedProverTask - Provers.IndirectTask - problem) - assertEqual - "higher-order foundation input selects TH0" - Provers.VerificationTh0 - (Provers.preparedVerificationDialect - (Provers.preparedTypedProverRequest - prepared)) - writeFile executablePath - (unlines - [ "#!/bin/sh" - , "cat >/dev/null" - , "printf '%s\\n' '% SZS status Theorem for typed'" - ]) - permissions <- - Directory.getPermissions executablePath - Directory.setPermissions executablePath - (Directory.setOwnerExecutable - True - permissions) - result <- - runNoLoggingT - (Provers.runPreparedTypedProver - (Provers.vampire - executablePath - Provers.defaultTimeLimit - Provers.defaultMemoryLimit) - prepared) - accepted <- - case result of - Right answer - | Just run <- - Provers.provedVampireRun answer -> - pure run - _ -> - assertFailure - ("expected accepted typed Vampire run, got " - <> show result) - >> fail "unreachable" - let factOrigin = - Transition.origin - Nowhere - Nothing - (Just "typed_vampire") - commit task = - Transition.commitTransitionTypedVampireFact - Reconstruction.defaultReconstructionPolicy - ("typed_vampire" :| []) - factOrigin - target - task - accepted - builder - case commit mismatched of - Left Transition.TransitionTypedVampireRequestMismatch -> - pure () - result' -> - assertFailure - ("expected exact-request mismatch, got " - <> showResult result') - committed <- - expectRight (commit prepared) - admitted <- - expectRight - (Transition.sealTransitionModule - Checking.initialLegacyCheckingEnvironment - committed) - let trust = - Transition.transitionAdmittedTypedTrustDependencies - admitted - assertEqual - "one typed trusted Vampire row" - 1 - (Transition.transitionAdmittedTypedTrustedVampireCount - admitted) - assertEqual - "one typed Vampire trust occurrence" - 1 - (Set.size - (Transition.typedTrustedVampireUses - trust)) - assertEqual - "mandatory lowering assumptions" - Legacy.mandatoryVampireLoweringAssumptions - (Transition.typedVampireLoweringUses - trust) - assertEqual - "exact foundation input" - (Set.singleton - Foundation.DoubleNegationElim) - (Transition.typedFoundationUses - trust) - let atom argument = - Core.CApp - (Core.CApp - (Core.CIntrinsic Core.Member) - (Core.CIntrinsic Core.Empty)) - argument - atomP = - atom (Core.CIntrinsic Core.Empty) - atomQ = - atom (Core.COpaqueInteger 1) - atomR = - atom (Core.COpaqueInteger 2) - declareTyped alias statement current = - expectRight - (Transition.commitTransitionTypedDeclaredAssumption - (alias :| []) - (Transition.origin - Nowhere - Nothing - (Just alias)) - Legacy.DeclaredUserAxiom - statement - (Transition.beginTransitionDeclaration - current)) - premiseP <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - atomP) - premisePtoQ <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - (Core.CImp atomP atomQ)) - premiseQtoR <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - (Core.CImp atomQ atomR)) - reconstructedTarget <- - expectRight - (Core.checkCanonicalCore - (Just . Transition.checkedGlobalType) - atomR) - builderWithP <- - declareTyped - "horn_p" - premiseP - builder - builderWithPtoQ <- - declareTyped - "horn_p_to_q" - premisePtoQ - builderWithP - builderWithHornInputs <- - declareTyped - "horn_q_to_r" - premiseQtoR - builderWithPtoQ - reconstructedClaim <- - expectRight - (Backend.supportedProposition - (Vector.empty - :: Vector.Vector - (Void, Core.CoreType)) - (Core.embedClosedCore - [] - reconstructedTarget)) - reconstructedProblem <- - expectRight - (Transition.planTransitionTypedProblem - builderWithHornInputs - reconstructedClaim - [] - [] - (Transition.ExplicitFacts - ("horn_p" - :| [ "horn_p_to_q" - , "horn_q_to_r" - ])) - Backend.FirstOrderLocals) - reconstructedPrepared <- - expectRight - (Provers.prepareTypedProverTask - Provers.DirectTask - reconstructedProblem) - reconstructedResult <- - runNoLoggingT - (Provers.runPreparedTypedProver - (Provers.vampire - executablePath - Provers.defaultTimeLimit - Provers.defaultMemoryLimit) - reconstructedPrepared) - reconstructedAccepted <- - case reconstructedResult of - Right answer - | Just run <- - Provers.provedVampireRun answer -> - pure run - _ -> - assertFailure - ("expected accepted Horn Vampire run, got " - <> show reconstructedResult) - >> fail "unreachable" - reconstructedBuilder <- - expectRight - (Transition.commitTransitionTypedVampireFact - Reconstruction.defaultReconstructionPolicy - ("horn_result" :| []) - (Transition.origin - Nowhere - Nothing - (Just "horn_result")) - reconstructedTarget - reconstructedPrepared - reconstructedAccepted - builderWithHornInputs) - reconstructedModule <- - expectRight - (Transition.sealTransitionModule - Checking.initialLegacyCheckingEnvironment - reconstructedBuilder) - reconstructedFact <- - case Vector.unsnoc - (Transition.transitionAdmittedFacts - reconstructedModule) of - Just (_earlier, finalFact) -> - pure finalFact - Nothing -> - assertFailure - "expected a reconstructed admitted fact" - >> fail "unreachable" - assertBool - "supported accepted task becomes a reconstructed kernel proof" - (Transition.admittedFactIsReconstructedKernelProof - reconstructedFact) - reconstructedTrust <- - maybe - (assertFailure - "expected typed reconstructed trust") - pure - (Transition.admittedFactTypedTrustDependencies - reconstructedFact) - assertEqual - "reconstruction inherits its three exact assumptions" - 3 - (Set.size - (Transition.typedDeclaredAssumptionUses - reconstructedTrust)) - assertEqual - "reconstructed run adds no trusted Vampire leaf" - Set.empty - (Transition.typedTrustedVampireUses - reconstructedTrust) - assertEqual - "reconstructed run adds no Vampire lowering trust" - Set.empty - (Transition.typedVampireLoweringUses - reconstructedTrust) - tinyKernelLimits <- - expectRight - (Derivation.kernelReplayLimits 1 10) - let tinyKernelPolicy = - Reconstruction.reconstructionPolicy - (Reconstruction.reconstructionPolicyConnectionLimits - Reconstruction.defaultReconstructionPolicy) - tinyKernelLimits - fallbackBuilder <- - expectRight - (Transition.commitTransitionTypedVampireFact - tinyKernelPolicy - ("horn_fallback" :| []) - (Transition.origin - Nowhere - Nothing - (Just "horn_fallback")) - reconstructedTarget - reconstructedPrepared - reconstructedAccepted - builderWithHornInputs) - fallbackModule <- - expectRight - (Transition.sealTransitionModule - Checking.initialLegacyCheckingEnvironment - fallbackBuilder) - fallbackFact <- - case Vector.unsnoc - (Transition.transitionAdmittedFacts - fallbackModule) of - Just (_earlier, finalFact) -> - pure finalFact - Nothing -> - assertFailure - "expected a kernel-exhaustion fallback fact" - >> fail "unreachable" - assertBool - "kernel exhaustion retains accepted Vampire authority" - (Transition.admittedFactIsTrustedVampire - fallbackFact) - where - showResult = \case - Left err -> - "Left " <> show err - Right _builder -> - "Right builder" - -publishesTypedInductive :: Assertion -publishesTypedInductive = - withTemporaryDirectory "felix-transition-inductive" \temp -> do - writeTheory - (temp Posix.</> "entry.tex") - [] - "entry" - graph <- buildSearchedGraph temp "entry.tex" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals - workspace) - assignment <- - case toList assignments of - [only] -> - pure only - actual -> - assertFailure - ("expected one module assignment, got " - <> show (length actual)) - >> fail "unreachable" - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - builder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - assignment - []) - let unprovedCarrier = - TermOp Nowhere unprovedInductiveSymbol [] - unprovedBlocks = - [ BlockInductive - Nowhere - "unproved_inductive" - Inductive - { inductiveSymbol = - unprovedInductiveSymbol - , inductiveParams = [] - , inductiveDomain = - EmptySet Nowhere - , inductiveIntros = - IntroRule - [] - ( EmptySet Nowhere - `isElementOf` - unprovedCarrier - ) - :| [] - } - ] - unproved <- - try - (Checking.runCheckingBlocks - unprovedBlocks - (Checking.initialTransitionCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - builder - (\_batch -> - assertFailure - "unproved inductive emitted a legacy obligation"))) - :: IO - (Either - Checking.CheckingError - Checking.CheckingState) - case unproved of - Left checkingError -> - assertBool - "missing exact guard is reported" - ("has no authorized typed fact" - `Text.isInfixOf` - Text.pack (show checkingError)) - Right _checked -> - assertFailure - "inductive with an unproved domain guard was admitted" - unchanged <- - expectRight - (Transition.sealTransitionModule - Checking.initialLegacyCheckingEnvironment - builder) - assertEqual - "failed inductive publishes no global" - 0 - (Vector.length - (Transition.transitionAdmittedGlobals - unchanged)) - assertEqual - "failed inductive publishes no fact" - 0 - (Vector.length - (Transition.transitionAdmittedFacts - unchanged)) - let parameter = - NamedVar "domain" - domain = - TermOp - Nowhere - cumulSymbol - [TermVar parameter] - carrier = - TermOp - Nowhere - typedInductiveSymbol - [TermVar parameter] - blocks = - [ BlockInductive - Nowhere - "typed_inductive" - Inductive - { inductiveSymbol = - typedInductiveSymbol - , inductiveParams = [parameter] - , inductiveDomain = domain - , inductiveIntros = - IntroRule - [] - (TermVar parameter - `isElementOf` - carrier) - :| [] - } - ] - checked <- - Checking.runCheckingBlocks - blocks - (Checking.initialTransitionCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - builder - (\_batch -> - assertFailure - "typed inductive emitted a legacy obligation")) - finalBuilder <- - maybe - (assertFailure - "checking lost its transition builder" - >> fail "unreachable") - pure - (Checking.checkingTransitionModuleBuilder - checked) - admitted <- - expectRight - (Transition.sealTransitionModule - (Checking.checkingStateEnvironment - checked) - finalBuilder) - assertEqual - "one transparent carrier" - 1 - (Vector.length - (Transition.transitionAdmittedGlobals - admitted)) - assertEqual - "four derived facts" - [True, True, True, True] - ( Transition.admittedFactIsKernelProof - <$> Vector.toList - (Transition.transitionAdmittedFacts - admitted) - ) - assertEqual - "four replayed inductive facts" - 4 - (Transition.transitionAdmittedKernelProofCount - admitted) - assertBool - "foundation guard dependency is retained" - (Foundation.UnivOfContains - `Set.member` - Transition.typedFoundationUses - (Transition.transitionAdmittedTypedTrustDependencies - admitted)) - where - typedInductiveSymbol = - mkMixfixItem - [ Just (Command "typedfin") - , Just InvisibleBraceL - , Nothing - , Just InvisibleBraceR - ] - "typed_inductive" - NonAssoc - - cumulSymbol = - mkMixfixItem - [ Just (Command "cumul") - , Just InvisibleBraceL - , Nothing - , Just InvisibleBraceR - ] - "cumul" - NonAssoc - - unprovedInductiveSymbol = - mkMixfixItem - [Just (Command "unprovedfin")] - "unproved_inductive" - NonAssoc - -publishesLegacyImportViews :: Assertion -publishesLegacyImportViews = - withTemporaryDirectory "felix-legacy-import-view" \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" - workspace <- - expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - case toList assignments of - [ sharedAssignment - , aAssignment - , bAssignment - , entryAssignment - ] -> do - shared <- - admitOne - sharedAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - "shared_fact" - Bottom - (Location 1) - sharedView <- - expectRight - (Legacy.legacyImportedView - Checking.initialLegacyCheckingEnvironment - [shared]) - a <- - admitOne - aAssignment - sharedView - "a_fact" - Top - (Location 2) - b <- - admitOne - bAssignment - sharedView - "b_fact" - Top - (Location 3) - diamondView <- - expectRight - (Legacy.legacyImportedView - Checking.initialLegacyCheckingEnvironment - [a, b]) - entry <- - expectRight - (Legacy.sealLegacyModuleStage - (Legacy.legacyImportedCheckingEnvironment - diamondView) - (Legacy.openLegacyModuleStage - entryAssignment - diamondView)) - assertEqual - "direct imports retain textual order" - [1, 2] - ( Legacy.legacyModuleOrdinalValue - <$> Vector.toList - (Legacy.legacyAdmittedDirectImports - entry) - ) - assertEqual - "diamond facts retain imported source order" - [0, 1, 2] - ( Legacy.legacyModuleOrdinalValue - . Legacy.legacyFactModule - . Legacy.legacyFactEntryReference - <$> Vector.toList - (Legacy.legacyAdmittedVisibleFacts - entry) - ) - assertEqual - "equal statements at different references remain" - 3 - (Vector.length - (Legacy.legacyAdmittedVisibleFacts entry)) - let environmentSymbol = - SymbolMixfix - (mkMixfixItem - [Just - (Command - "module_environment")] - "module_environment" - NonAssoc) - environmentWith body = - Legacy.legacyCheckingEnvironment - (HashMap.insert - environmentSymbol - (toScope body) - (Legacy.legacyEnvironmentAbbreviations - Checking.initialLegacyCheckingEnvironment)) - (Legacy.legacyEnvironmentPredicateDefinitions - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentDependencies - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentOwnedSymbols - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentOwnedSymbolMarkers - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentFrozenSymbols - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentStructs - Checking.initialLegacyCheckingEnvironment) - (Legacy.legacyEnvironmentDefinedMarkers - Checking.initialLegacyCheckingEnvironment) - environmentA <- - admitEnvironment - aAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - (environmentWith Top) - environmentView <- - expectRight - (Legacy.legacyImportedView - Checking.initialLegacyCheckingEnvironment - [environmentA]) - assertEqual - "admitted semantic environment is imported" - (Just (toScope Top)) - (HashMap.lookup - environmentSymbol - (Legacy.legacyEnvironmentAbbreviations - (Legacy.legacyImportedCheckingEnvironment - environmentView))) - environmentB <- - admitEnvironment - bAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - (environmentWith Bottom) - case Legacy.legacyImportedView - Checking.initialLegacyCheckingEnvironment - [environmentA, environmentB] of - Left Legacy.LegacyImportedEnvironmentConflict{} -> - pure () - Left err -> - assertFailure - ("expected imported environment conflict, got " - <> show err) - Right _ -> - assertFailure - "expected imported environment conflict" - - conflictingA <- - admitOne - aAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - "conflicting" - Top - (Location 4) - conflictingB <- - admitOne - bAssignment - (Legacy.emptyLegacyImportedView - Checking.initialLegacyCheckingEnvironment) - "conflicting" - Bottom - (Location 5) - case Legacy.legacyImportedView - Checking.initialLegacyCheckingEnvironment - [conflictingA, conflictingB] of - Left Legacy.LegacyImportedAliasConflict{} -> - pure () - Left err -> - assertFailure - ("expected imported alias conflict, got " - <> show err) - Right _ -> - assertFailure - "expected imported alias conflict" - actual -> - assertFailure - ("expected four module assignments, got " - <> show (length actual)) - where - admitOne assignment imported alias statement location = do - let stage = - Legacy.openLegacyModuleStage - assignment - imported - staged = - Facts.stageFact - (alias :| []) - (Facts.factOrigin location alias) - (Facts.prepareSemanticFact statement) - reservation <- - expectRight - (Legacy.reserveLegacyDeclaration - (staged :| []) - stage) - let reserved = - NonEmpty.head - (Legacy.legacyReservedFacts reservation) - admitted = - Legacy.authorizeLegacyDeclaredAssumption - stage - Legacy.DeclaredUserAxiom - reserved - stage' <- - expectRight - (Legacy.appendEstablishedLegacyDeclaration - reservation - (admitted :| []) - stage) - expectRight - (Legacy.sealLegacyModuleStage - (Legacy.legacyImportedCheckingEnvironment imported) - stage') - - admitEnvironment assignment imported finalEnvironment = - expectRight - (Legacy.sealLegacyModuleStage - finalEnvironment - (Legacy.openLegacyModuleStage assignment imported)) - rejectsSiblingSyntaxLeakage :: Assertion rejectsSiblingSyntaxLeakage = withTemporaryDirectory "felix-source-syntax-world" \temp -> do @@ -3667,48 +2027,6 @@ acceptsAdjectiveSignature = _ -> assertFailure ("unexpected adjective-signature blocks: " <> show blocks) - semanticBlocks <- expectRight (Meaning.meaning blocks) - void - (Checking.check - Checking.WithoutDumpPremselTraining - semanticBlocks) - -rejectsQuantifiedSymbolicSignatureTerm :: Assertion -rejectsQuantifiedSymbolicSignatureTerm = - withTemporaryDirectory "felix-source-signature-quantified-term" \temp -> do - writeFile - (temp Posix.</> "entry.tex") - (unlines - [ "\\begin{definition}\\label{bridge}" - , " $z$ is a bridge from $A$ to $B$ iff $z = z$ and $A = A$ and $B = B$." - , "\\end{definition}" - , "\\begin{signature}\\label{bridge_signature}" - , " $\\foo{A}$ is a bridge from every set $x$ to $x$." - , "\\end{signature}" - ]) - graph <- buildSearchedGraph temp "entry.tex" - workspace <- expectRight - =<< Parse.parseResolvedSourceGraph graph - case Meaning.meaning - (Parse.importedBeforeImporterBlocks workspace) of - Left (Meaning.QuantifiedTermRequiresResolvedContext location) -> do - assertEqual "quantified term file" - "entry.tex" - (locFile location) - assertEqual "quantified term line" - 5 - (locLine location) - assertEqual "quantified term column" - 30 - (locColumn location) - Left err -> - assertFailure - ("expected quantified-term context error, got " - <> show err) - Right blocks -> - assertFailure - ("expected quantified-term context rejection, got " - <> show blocks) rejectsMalformedSignatureHead :: Assertion rejectsMalformedSignatureHead = do @@ -3902,162 +2220,6 @@ acceptsBuiltinPrefixPredicateDeclaration = ("unexpected built-in prefix declaration parse: " <> show blocks) -rejectsDuplicateFixedBaseSemantics :: Assertion -rejectsDuplicateFixedBaseSemantics = - withTemporaryDirectory "felix-source-builtin-collision" \temp -> do - writeBuiltinZeroDefinition - (temp Posix.</> "a.tex") - "source_zero_a" - writeFile - (temp Posix.</> "entry.tex") - ("\\import{a.tex}\n" - <> builtinZeroDefinition "source_zero_b") - graph <- buildSearchedGraph temp "entry.tex" - workspace <- expectRight - =<< Parse.parseResolvedSourceGraph graph - assignments <- - expectRight - (Legacy.assignLegacyModuleOrdinals workspace) - case toList assignments of - [acceptedAssignment, collidingAssignment] -> do - let acceptedParsed = - Legacy.assignedParsedModule acceptedAssignment - collidingParsed = - Legacy.assignedParsedModule collidingAssignment - acceptedLocation <- - onlySyntaxOccurrenceLocation acceptedParsed - collidingLocation <- - onlySyntaxOccurrenceLocation collidingParsed - assertLocation - "accepted declaration" - "a.tex" - 1 - acceptedLocation - assertLocation - "colliding declaration" - "entry.tex" - 2 - collidingLocation - assertEqual - "fixed reuses emit no syntax delta" - [[], []] - [ Interface.canonicalSyntaxDeltaEntries - (Interface.moduleSyntaxLocalDelta - (Parse.parsedModuleSyntaxInterface parsed)) - | parsed <- [acceptedParsed, collidingParsed] - ] - - checkedFoundationValue <- - expectRight Foundation.checkedFoundation - (acceptedBlocks, glossState) <- - glossParsedBlocks - Meaning.initialGlossState - acceptedParsed - acceptedBuilder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - acceptedAssignment - []) - acceptedState <- - Checking.runCheckingBlocks - acceptedBlocks - (checkingState acceptedBuilder) - finalAcceptedBuilder <- - expectJust - "accepted transition builder" - (Checking.checkingTransitionModuleBuilder - acceptedState) - acceptedModule <- - expectRight - (Transition.sealTransitionModule - (Checking.checkingStateEnvironment - acceptedState) - finalAcceptedBuilder) - - (collidingBlocks, _finalGlossState) <- - glossParsedBlocks glossState collidingParsed - collidingBuilder <- - expectRight - (Transition.openTransitionModuleBuilder - checkedFoundationValue - Checking.initialLegacyCheckingEnvironment - collidingAssignment - [acceptedModule]) - result <- - try - (Checking.runCheckingBlocks - collidingBlocks - (checkingState collidingBuilder)) - :: IO - (Either - Checking.CheckingError - Checking.CheckingState) - case result of - Left - (Checking.CheckingError - message - location - marker) -> do - assertEqual - "semantic collision location" - collidingLocation - location - assertEqual - "semantic collision marker" - "source_zero_b" - marker - assertBool - "accepted owner is identified" - ("already owned by abbreviation source_zero_a" - `Text.isInfixOf` message) - Left err -> - assertFailure - ("expected located ownership collision, got " - <> show err) - Right _checked -> - assertFailure - "duplicate fixed-base semantics were accepted" - actual -> - assertFailure - ("expected two module assignments, got " - <> show (length actual)) - where - checkingState builder = - Checking.initialTransitionCheckingStateWithTaskPreparation - Checking.WithoutDumpPremselTraining - id - builder - (\_batch -> - assertFailure - "fixed-base abbreviation emitted an obligation") - - glossParsedBlocks initialState parsed = - fmap - (\(reversed, finalState) -> - (reverse reversed, finalState)) - (foldM - glossOne - ([], initialState) - (Parse.parsedModuleBlocks parsed)) - - glossOne (reversed, state) raw = do - (block, nextState) <- - expectRight (Meaning.glossStep state raw) - pure (block : reversed, nextState) - - onlySyntaxOccurrenceLocation parsed = - case Parse.parsedModuleSyntaxOccurrences parsed of - [occurrence] -> - pure - (Parse.parsedSyntaxOccurrenceLocation - occurrence) - occurrences -> - assertFailure - ("expected one fixed-base occurrence, got " - <> show occurrences) - avoidsAliasImportLexiconCollision :: Assertion avoidsAliasImportLexiconCollision = withTemporaryDirectory "felix-source-alias-lexicon" \temp -> do diff --git a/source/Test/Unit/Store.hs b/source/Test/Unit/Store.hs index 9f25a3b..e2896c3 100644 --- a/source/Test/Unit/Store.hs +++ b/source/Test/Unit/Store.hs @@ -21,6 +21,7 @@ import Felix.Store qualified as Store import Provers qualified import 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 @@ -33,6 +34,7 @@ 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 @@ -40,6 +42,8 @@ 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" @@ -80,6 +84,28 @@ unitTests = 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 diff --git a/source/Test/Unit/Symdiff.hs b/source/Test/Unit/Symdiff.hs deleted file mode 100644 index ec62fda..0000000 --- a/source/Test/Unit/Symdiff.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Test.Unit.Symdiff where - -import Base -import Bound.Scope -import Bound.Var -import Syntax.Internal -import Filter -import Report.Location - -import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as Text - -mixfix :: [Maybe Token] -> FunctionSymbol -mixfix pat = mkMixfixItem pat (markerFromPattern pat) NonAssoc - where - markerFromPattern = \case - Just tok : _ -> markerFromToken tok - Nothing : rest -> markerFromPattern rest - [] -> Marker "mixfix" - -subsetSymbol :: RelationSymbol -subsetSymbol = - RelationSymbol (Command "subset") zeroParameterArity "subset" - -adjInhabited :: LexicalItem -adjInhabited = mkLexicalItem [Just (Word "inhabited")] "inhabited" - -adjDisjointFrom :: LexicalItem -adjDisjointFrom = mkLexicalItem [Just (Word "disjoint"), Just (Word "from"), Nothing] "disjoint" - -filtersWell :: Bool -filtersWell = badFact `notElem` (hypothesisFormula <$> taskHypotheses (filterTask symdiff)) - - -handlesStructAndApply :: Bool -handlesStructAndApply = - let - structOp = StructSymbol "foo_op" - structTerm = TermSymbolStruct structOp (Just (TermVar (NamedVar "A"))) - formula = Apply (TermVar (NamedVar "f")) (structTerm :| []) - hypo = Hypothesis - { hypothesisMarker = Marker "struct_apply" - , hypothesisFormula = formula - } - in Map.member hypo (relevantFacts passmark formula (Set.singleton hypo)) - - -badFact :: ExprOf a -badFact = Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "FreshReplacementVar")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Quantified Existentially (Scope (Connected Conjunction (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "A"))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "b")), TermVar (F (TermVar (B (NamedVar "B"))))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (F (TermVar (B (NamedVar "FreshReplacementVar")))), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]])))))) - - -symdiff :: Task -symdiff = - Task - { taskDirectness = Direct - , taskLocation = Nowhere - , taskConjectureLabel = Marker "symdiff_test" - , taskHypotheses = zipWith - Hypothesis - (Marker . Text.pack . show <$> ([1..] :: [Int])) - [ Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))], TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "C"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "x"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []], TermVar (B (NamedVar "x"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "symdiff"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "x"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermVar (B (NamedVar "Z"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermVar (B (NamedVar "Z"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))], TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []], TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "C"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))]]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "inters"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "A"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "A"))]], TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "fst"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]], TermVar (B (NamedVar "a"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "snd"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]], TermVar (B (NamedVar "b"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "A"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) [], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "A"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation NeqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermVar (B (NamedVar "a"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation NeqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermVar (B (NamedVar "b"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "A"))])) - , Quantified Universally (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) [], TermVar (B (NamedVar "a"))])) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjDisjointFrom)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjDisjointFrom)) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))])))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]]) (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "Y"))])))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation NeqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Existentially (Scope (Connected ExclusiveOr (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "A"))))]) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "B"))))]))) (Connected Conjunction (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "A"))))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "B"))))]))))))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "B"))]))) - , Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "Y"))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]]))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "C"))]))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (PropositionalConstant IsTop) (PropositionalConstant IsTop)) (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Disjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))))) - , Quantified Universally (Scope (Connected Implication (Connected Conjunction (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "x"))])) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "y"))]))) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]))) - , Quantified Universally (Scope (Connected Implication (Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "A"))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "B"))))])))) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjDisjointFrom)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Not Nowhere (Quantified Existentially (Scope (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "B"))))))]))))))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "A"))]) (Quantified Universally (Scope (Quantified Existentially (Scope (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]))))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "A"))]) (Not Nowhere (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "A"))]))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "aprime")), TermVar (B (NamedVar "bprime"))]]) (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "aprime"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "bprime"))])))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "c"))]], TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "aprime")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Word "pair")])) [TermVar (B (NamedVar "bprime")), TermVar (B (NamedVar "cprime"))]]]) (Connected Conjunction (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "aprime"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "bprime"))])) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "c")), TermVar (B (NamedVar "cprime"))])))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "B")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "A"))]]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]))) - , badFact - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))])))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "x")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "X"))]]) (Connected Disjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))])))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "z")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "inters"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "X"))]]) (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "X"))]) (Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "Y")), TermVar (F (TermVar (B (NamedVar "X"))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (F (TermVar (B (NamedVar "z")))), TermVar (B (NamedVar "Y"))]))))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "z")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "X"))]]) (Quantified Existentially (Scope (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "Y")), TermVar (F (TermVar (B (NamedVar "X"))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (F (TermVar (B (NamedVar "z")))), TermVar (B (NamedVar "Y"))])))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation subsetSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Connected Conjunction (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (F (TermVar (B (NamedVar "A")))), TermVar (F (TermVar (B (NamedVar "B"))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation NeqSymbol)) [TermVar (F (TermVar (B (NamedVar "A")))), TermVar (F (TermVar (B (NamedVar "B"))))])))))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation EqSymbol)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "A"))]))) - , Quantified Universally (Scope (Connected Equivalence (TermSymbol Nowhere (SymbolPredicate (PredicateRelation SubseteqSymbol)) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "B"))))))])))))))) - , Quantified Universally (Scope (Connected Equivalence (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "times"), Nothing])) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]])) (Connected Disjunction (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "X"))])) (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateAdj adjInhabited)) [TermVar (B (NamedVar "Y"))]))))) - , Quantified Universally (Scope (Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (F (TermVar (B (NamedVar "y")))), TermVar (B (NamedVar "X"))]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (F (TermVar (B (NamedVar "y")))), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR])) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]]))))) - , Quantified Universally (Scope (Not Nowhere (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (NamedVar "a")), TermSymbol Nowhere (SymbolMixfix (mixfix [Just (Command "emptyset")])) []]))) - ] - , taskConjecture = - Quantified Universally (Scope (Connected Implication (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (FreshVar 0)), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "setminus"), Nothing])) [TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "union"), Nothing])) [TermVar (F (TermVar (NamedVar "x"))), TermVar (F (TermVar (NamedVar "y")))], TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "inter"), Nothing])) [TermVar (F (TermVar (NamedVar "y"))), TermVar (F (TermVar (NamedVar "x")))]]]) (TermSymbol Nowhere (SymbolPredicate (PredicateRelation ElementSymbol)) [TermVar (B (FreshVar 0)), TermSymbol Nowhere (SymbolMixfix (mixfix [Nothing, Just (Command "symdiff"), Nothing])) [TermVar (F (TermVar (NamedVar "x"))), TermVar (F (TermVar (NamedVar "y")))]]))) - } diff --git a/source/Test/Unit/Token.hs b/source/Test/Unit/Token.hs index b676f55..d399e2a 100644 --- a/source/Test/Unit/Token.hs +++ b/source/Test/Unit/Token.hs @@ -22,6 +22,8 @@ unitTests = testGroup "Lexer" , 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" @@ -130,6 +132,24 @@ locatedImports = do 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_ |