diff options
Diffstat (limited to 'source/Test/Unit/Module.hs')
| -rw-r--r-- | source/Test/Unit/Module.hs | 481 |
1 files changed, 472 insertions, 9 deletions
diff --git a/source/Test/Unit/Module.hs b/source/Test/Unit/Module.hs index 267a9ad..7748dac 100644 --- a/source/Test/Unit/Module.hs +++ b/source/Test/Unit/Module.hs @@ -67,6 +67,7 @@ import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Vector qualified as Vector +import Numeric.Natural (Natural) import System.Directory ( createDirectoryIfMissing , doesFileExist @@ -122,6 +123,8 @@ unitTests = confinesExactQuantifiedTerms , testCase "compiles exact ordinary proofs" compilesExactOrdinaryProofs + , testCase "restores exact binder and witness proof forms" + restoresExactBinderAndWitnessProofForms , testCase "compiles and reuses proof-local set definitions" compilesAndReusesProofLocalSetDefinitions , testCase "compiles and reuses proof-local function graphs" @@ -1324,6 +1327,29 @@ compilesExactStructures = do (Semantic.semanticStructureOperationObject parentOperation `Set.member` operationGlobals) + let assertEquivalentClaim surface explicit = do + surfaceTerm <- + checkedPropositionTermByAlias parent surface + explicitTerm <- + checkedPropositionTermByAlias parent explicit + assertEqual + (StrictText.unpack surface + <> " uses the inherited carrier") + explicitTerm + surfaceTerm + assertEquivalentClaim + "pointed_self_member" + "pointed_self_member_explicit" + assertEquivalentClaim + "pointed_self_not_member" + "pointed_self_not_member_explicit" + assertEquivalentClaim + "pointed_self_element" + "pointed_self_element_explicit" + assertEquivalentClaim + "pointed_header_member" + "pointed_header_member_explicit" + childBatch <- sole "child structure batch" childBatches childDelta <- sole "child structure delta" childDeltas childDescriptor <- sole "child structure descriptor" @@ -2084,6 +2110,363 @@ compilesExactOrdinaryProofs = element) set +restoresExactBinderAndWitnessProofForms :: Assertion +restoresExactBinderAndWitnessProofForms = + Temp.withSystemTempDirectory "felix-exact-proof-parity" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-parity.tex" + parsed <- sole "parsed proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claims = [claim | claim@Raw.BlockClaim{} <- blocks] + proofs = + [ proof + | Raw.BlockProof _location proof _end <- blocks + ] + omittedClaim <- + case reverse claims of + claim : _ -> pure claim + [] -> assertFailure "missing omitted witness claim" + >> fail "unreachable" + omittedProof <- + case reverse proofs of + proof : _ -> pure proof + [] -> assertFailure "missing omitted witness proof" + >> fail "unreachable" + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + omittedClaim (Just omittedProof)) + >>= either Declaration.failModuleDriver pure + >>= \case + Right (Declaration.DriverSucceeded + prepared _semantic _prefix _closure) -> + case ExactProof.preparedExactProofFirstOmission prepared of + Just location -> + assertEqual "nested Take retains first omission" + 106 (locLine location) + Nothing -> + assertFailure "nested Take lost its omission" + Right Declaration.DriverFailed{} -> + assertFailure "omitted witness preparation failed" + Right Declaration.DriverSealFailed{} -> + assertFailure "omitted witness preparation did not seal" + Left failure -> + assertFailure + ("omitted witness preparation did not open: " + <> show failure) + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof-parity'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + fresh <- + sole "proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingAcceptedResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "restored proof request count" 17 (length observed) + assertEqual + "restored proof declarations preserve discharge order" + [1, 1, 1, 1, 1, 1, 3, 2, 2, 3, 1] + (proofRequestCounts fresh) + case observed of + first : second : third : fourth : _rest -> do + assertGuardRequest "single bounded fix" 2 first + assertGuardRequest "multiple bounded fix" 3 second + assertGuardRequest "negative bounded fix" 2 third + assertGuardRequest "fix such that" 2 fourth + _ -> assertFailure "missing bounded-fix requests" + case drop 4 observed of + leftFirst : rightFirst : _ -> do + assertSequentialAssumptions "left conjunct first" leftFirst + assertSequentialAssumptions "right conjunct first" rightFirst + _ -> assertFailure "missing conjunction-assumption requests" + assertTakeSequence "bounded TakeVar" (drop 6 observed) + assertTakeSequence "existential Have" (drop 13 observed) + case drop 9 observed of + namedDischarge : _namedFinal : anonymousDischarge : _ -> do + assertExactDischarge "named noun" namedDischarge + assertEqual "named noun opens two witness binders" + 2 + (leadingExistentials + (observedClaimTerm namedDischarge)) + assertExactDischarge "anonymous noun" anonymousDischarge + assertEqual "anonymous noun opens one unnameable binder" + 1 + (leadingExistentials + (observedClaimTerm anonymousDischarge)) + _ -> assertFailure "missing noun-witness requests" + lastBatch <- + case reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) of + batch : _ -> pure batch + [] -> assertFailure "missing restored-proof batches" + >> fail "unreachable" + lastFact <- sole "omitted witness fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta lastBatch)) + assertEqual "omitted continuation remains escape-backed" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority lastFact)) + assertBool "proof-local witnesses publish no objects" + (all + (null . Declaration.committedBatchObjects) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh))) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm restored proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual + "fresh and warm proof validation keys and authority" + (proofValidationRecords fresh) + (proofValidationRecords warm) + assertEqual + "fresh and warm checked proposition identities" + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm)))) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix-shape.tex" + (\case + ExactProof.ExactProofExpectedUniversalGoal location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-assume.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + where + observingAcceptedResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + ProofParityObservation + (snd <$> Vector.toList + (Backend.supportedPropositionSupport claim)) + (Backend.supportedPropositionTerm claim) + [ ( Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + , snd <$> Vector.toList + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition + premise)) + , Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + ) + | premise <- Vector.toList locals + ] + modifyIORef' observations (<> [observation]) + runNoLoggingT + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + assertGuardRequest label supportCount observation = do + assertEqual (label <> " support") + supportCount + (length (observedClaimSupport observation)) + case observedLocals observation of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact guard") + (observedClaimTerm observation) + local + locals -> + assertFailure + (label <> ": expected one guard, found " + <> show (length locals)) + + assertTakeSequence label observations = + case observations of + discharge : continuation : _ -> do + assertExactDischarge label discharge + assertEqual (label <> " continuation premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- + observedLocals continuation + ] + assertEqual (label <> " continuation witness support") + 2 + (length (observedClaimSupport continuation)) + _ -> assertFailure (label <> ": missing request sequence") + + assertSequentialAssumptions label observation = do + assertEqual (label <> " premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- observedLocals observation + ] + case observedLocals observation of + (_ordinal, _support, first) : _ -> + assertEqual (label <> " retained source order") + (observedClaimTerm observation) + first + [] -> assertFailure (label <> ": no scoped assumptions") + + assertExactDischarge label discharge = + case observedLocals discharge of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact existential discharge") + (observedClaimTerm discharge) + local + locals -> + assertFailure + (label <> ": unexpected discharge premises " + <> show (length locals)) + + proofRequestCounts sealed = + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) of + Authority.CheckedSourceProof requests -> length requests + Authority.OmittedAuthorization -> 1 + authorization -> + error ("unexpected restored-proof authority: " + <> show authorization) + records -> + error ("unexpected restored-proof validation count: " + <> show (length records)) + | batch <- Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + ] + + proofValidationRecords sealed = + concatMap Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + + leadingExistentials + :: Core.CanonicalTerm Identity.ObjectId + -> Int + leadingExistentials = \case + Core.CImp + (Core.CForall Core.TySet + (Core.CImp body Core.CFalsum)) + Core.CFalsum -> + 1 + leadingExistentials body + _ -> 0 + +data ProofParityObservation = ProofParityObservation + { observedClaimSupport :: ![Core.CoreType] + , observedClaimTerm :: !(Core.CanonicalTerm Identity.ObjectId) + , observedLocals :: + ![(Natural, [Core.CoreType], Core.CanonicalTerm Identity.ObjectId)] + } + +assertProofParityFailure + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> SourceMounts + -> FilePath + -> (ExactProof.ExactProofError -> Bool) + -> Assertion +assertProofParityFailure foundation bootstrap mounts relative matches = do + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- sole "invalid proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed failure)) + prefix -> do + assertBool ("unexpected proof failure: " <> show failure) + (matches failure) + assertBool "failing proof publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "invalid proof-parity module succeeded" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid proof-parity module did not open: " <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected proof-parity module failure: " <> show failure) + compilesExactSeparationComprehensions :: Assertion compilesExactSeparationComprehensions = Temp.withSystemTempDirectory "felix-exact-separation" \root -> do @@ -2112,11 +2495,27 @@ compilesExactSeparationComprehensions = let resolver = Declaration.vampireResolver \prepared -> do let problem = Provers.preparedTypedProverLogicalProblem prepared + request = + Provers.preparedTypedProverRequest prepared + globalsAreFof = + all + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> True + Backend.RequiresTh0{} -> False) + (Backend.typedProblemGlobalPremises problem) modifyIORef' observations (<> [ ( Backend.typedProblemRoute problem + , globalsAreFof + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList + (Backend.typedProblemLocalPremises problem) , Backend.typedProblemAuxiliaryTag <$> Vector.toList (Backend.typedProblemAuxiliaries problem) + , Provers.preparedVerificationRequestId request + , Provers.preparedVerificationByteCount request ) ]) runNoLoggingT @@ -2130,12 +2529,20 @@ compilesExactSeparationComprehensions = foundation bootstrap resolver workspace sealed <- sole "exact separation module" modules assertExactSeparationModule "fresh" sealed - assertEqual - "separation proof uses its checked characteristic on TH0" - [( Backend.RouteTh0 - , [Foundation.SeparationCharacteristic] - )] - =<< readIORef observations + readIORef observations >>= \case + [ ( Backend.RouteTh0 + , True + , [0] + , [Foundation.SeparationCharacteristic] + , _requestId + , requestBytes + ) ] -> + assertBool "separation exact request has bytes" + (requestBytes > 0) + observed -> + assertFailure + ("unexpected implicit separation problem: " + <> show observed) createDirectoryIfMissing True (Posix.takeDirectory failedSource) original <- ByteString.readFile relative @@ -2712,6 +3119,13 @@ assertExactReplacementModule sealed = assertEqual "replacement definition body" expectedBody body + assertEqual "replacement definition foundation helpers" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies body) content -> assertFailure ("unexpected replacement object " <> show content) @@ -3821,19 +4235,40 @@ reusesExactSeparationValidation = unusedResolver mounts <- exactFixtureMounts root workspace <- parseExactWorkspace bootstrap mounts relative - freshRuns <- newIORef (0 :: Int) + freshRequests <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRequests + (<> [Provers.preparedTypedProverRequest prepared]) + runNoLoggingT + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) freshModules <- compileParsedWorkspaceWithValidation foundation bootstrap - (countingAcceptedResolver executable freshRuns) + freshResolver Declaration.FreshValidation workspace assertEqual "fresh separation proof runs Vampire once" 1 - =<< readIORef freshRuns + . length + =<< readIORef freshRequests fresh <- sole "fresh exact separation module" freshModules assertExactSeparationModule "fresh cached" fresh + freshRequest <- + sole "fresh separation request" + =<< readIORef freshRequests + freshAcceptedRequest <- + acceptedRequestId "fresh separation" fresh + assertEqual "fresh authority binds the exact request bytes" + freshAcceptedRequest + (Provers.preparedVerificationRequestId freshRequest) + assertBool "fresh separation request bytes are retained by the caller" + (Provers.preparedVerificationByteCount freshRequest > 0) bracket (snd <$> (Store.openStore storePath (Identity.theoryId foundation) >>= expectRight)) @@ -3862,6 +4297,12 @@ reusesExactSeparationValidation = =<< readIORef warmRuns warm <- sole "warm exact separation module" warmModules assertExactSeparationModule "warm cached" warm + warmAcceptedRequest <- + acceptedRequestId "warm separation" warm + assertEqual + "warm validation retains the fresh request-byte identity" + freshAcceptedRequest + warmAcceptedRequest assertEqual "warm separation semantic interface" (Module.sealedTypedModuleSemantic fresh) (Module.sealedTypedModuleSemantic warm) @@ -3890,6 +4331,28 @@ reusesExactSeparationValidation = assertEqual "warm separation checked artifacts" (components fresh) (components warm) + where + acceptedRequestId label sealed = do + theoremBatch <- + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_definitionBatch, batch] -> pure batch + batches -> + assertFailure + (label <> ": unexpected declaration count " + <> show (length batches)) + >> fail "unreachable" + validation <- sole + (label <> " proof validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate validation) of + Authority.CheckedSourceProof [request] -> pure request + authorization -> + assertFailure + (label <> ": unexpected direct authorization " + <> show authorization) + >> fail "unreachable" compilesExactSourceAxioms :: Assertion compilesExactSourceAxioms = |