diff options
Diffstat (limited to 'source/Felix/Checking')
24 files changed, 36923 insertions, 0 deletions
diff --git a/source/Felix/Checking/Authority.hs b/source/Felix/Checking/Authority.hs new file mode 100644 index 0000000..58c123f --- /dev/null +++ b/source/Felix/Checking/Authority.hs @@ -0,0 +1,612 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Compact public fact authority and exact contextual authorization. +module Felix.Checking.Authority + ( EscapeKind(..) + , EscapeKinds + , emptyEscapeKinds + , singletonEscapeKind + , escapeKinds + , escapeKindsToList + , unionEscapeKinds + , AuthoritySafety + , cleanAuthoritySafety + , authoritySafety + , authoritySafetyEscapeKinds + , unionAuthoritySafety + , FactAuthority + , factAuthority + , factAuthorityTheorem + , factAuthoritySafety + , PreparedRequestDialect(..) + , PreparedRequestMode(..) + , PreparedRequestId + , preparedRequestId + , GuardedRuleSet + , guardedRuleSet + , guardedRuleTags + , KernelConstructionDescriptor(..) + , DatatypeCompilationDescriptor + , datatypeCompilationDescriptor + , CompilationDescriptor(..) + , DirectAuthorization(..) + , ValidationCertificate + , validationCertificate + , validationTarget + , validationDirectAuthorization + , ValidationCertificateError(..) + , CandidateSafety + , initialCandidateSafety + , candidateSafetyAuthority + , candidateFactAuthority + , accumulateFactSafety + , addCandidateEscape + , FactSafetyError(..) + , putEscapeKindsCache + , getEscapeKindsCache + , putAuthoritySafetyCache + , getAuthoritySafetyCache + , putFactAuthorityCache + , getFactAuthorityCache + , putPreparedRequestIdCache + , getPreparedRequestIdCache + , putDirectAuthorizationCache + , getDirectAuthorizationCache + , putValidationCertificateCache + , getValidationCertificateCache + ) where + +import Base +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Cache.Codec + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Bits ((.&.), (.|.), bit, complement) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.List (filter) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Data.Word (Word8) + + +data EscapeKind + = SourceAxiom + | Omitted + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +-- | Canonical bounded set. The bit positions are stable cache tags. +newtype EscapeKinds = + EscapeKinds Word8 + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NFData) + +emptyEscapeKinds :: EscapeKinds +emptyEscapeKinds = + EscapeKinds 0 + +singletonEscapeKind :: EscapeKind -> EscapeKinds +singletonEscapeKind = + EscapeKinds . escapeKindBit + +escapeKinds :: Foldable collection => collection EscapeKind -> EscapeKinds +escapeKinds = + foldl' + (\acc kind -> + unionEscapeKinds acc (singletonEscapeKind kind)) + emptyEscapeKinds + +escapeKindsToList :: EscapeKinds -> [EscapeKind] +escapeKindsToList kinds = + filter + (\kind -> + let EscapeKinds bits = kinds + in bits .&. escapeKindBit kind /= 0) + [SourceAxiom, Omitted] + +unionEscapeKinds :: EscapeKinds -> EscapeKinds -> EscapeKinds +unionEscapeKinds (EscapeKinds left) (EscapeKinds right) = + EscapeKinds (left .|. right) + +escapeKindBit :: EscapeKind -> Word8 +escapeKindBit = \case + SourceAxiom -> bit 0 + Omitted -> bit 1 + +allEscapeBits :: Word8 +allEscapeBits = + escapeKindBit SourceAxiom .|. escapeKindBit Omitted + + +data AuthoritySafety + = Clean + | EscapeHatchBacked !EscapeKinds + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +cleanAuthoritySafety :: AuthoritySafety +cleanAuthoritySafety = + Clean + +authoritySafety :: EscapeKinds -> AuthoritySafety +authoritySafety kinds + | kinds == emptyEscapeKinds = Clean + | otherwise = EscapeHatchBacked kinds + +authoritySafetyEscapeKinds :: AuthoritySafety -> EscapeKinds +authoritySafetyEscapeKinds = \case + Clean -> emptyEscapeKinds + EscapeHatchBacked kinds -> kinds + +unionAuthoritySafety + :: AuthoritySafety + -> AuthoritySafety + -> AuthoritySafety +unionAuthoritySafety left right = + authoritySafety + (unionEscapeKinds + (authoritySafetyEscapeKinds left) + (authoritySafetyEscapeKinds right)) + + +data FactAuthority = FactAuthority + !TheoremRef + !AuthoritySafety + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +factAuthority :: TheoremRef -> AuthoritySafety -> FactAuthority +factAuthority = + FactAuthority + +factAuthorityTheorem :: FactAuthority -> TheoremRef +factAuthorityTheorem (FactAuthority reference _) = + reference + +factAuthoritySafety :: FactAuthority -> AuthoritySafety +factAuthoritySafety (FactAuthority _ safety) = + safety + + +data PreparedRequestDialect + = PreparedRequestFof + | PreparedRequestTh0 + deriving stock (Show, Eq, Ord, Generic) + +data PreparedRequestMode + = PreparedRequestDirect + | PreparedRequestIndirect + deriving stock (Show, Eq, Ord, Generic) + +newtype PreparedRequestId = + PreparedRequestId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +preparedRequestId + :: PreparedRequestDialect + -> PreparedRequestMode + -> ByteString + -> PreparedRequestId +preparedRequestId dialect mode bytes = + PreparedRequestId + (hashCacheFields + "felix-prepared-request-v2" + [ ByteString.singleton (preparedRequestDialectTag dialect) + , ByteString.singleton (preparedRequestModeTag mode) + , bytes + ]) + +preparedRequestDialectTag :: PreparedRequestDialect -> Word8 +preparedRequestDialectTag = \case + PreparedRequestFof -> 0x00 + PreparedRequestTh0 -> 0x01 + +preparedRequestModeTag :: PreparedRequestMode -> Word8 +preparedRequestModeTag = \case + PreparedRequestDirect -> 0x00 + PreparedRequestIndirect -> 0x01 + + +-- | A nonempty canonical set of guarded kernel rules. +newtype GuardedRuleSet = + GuardedRuleSet (Set KernelRuleTag) + deriving stock (Show, Eq, Ord, Generic) + +guardedRuleSet :: NonEmpty KernelRuleTag -> GuardedRuleSet +guardedRuleSet = + GuardedRuleSet . Set.fromList . NonEmpty.toList + +guardedRuleTags :: GuardedRuleSet -> Set KernelRuleTag +guardedRuleTags (GuardedRuleSet rules) = + rules + +data KernelConstructionDescriptor + = FoundationLeaf !FoundationAxiomTag + | GuardedFoundationRules !GuardedRuleSet + | CheckedDefinitionEquation !ObjectId + | CheckedSetConstructionExtensionality !ObjectId !CacheDigest + deriving stock (Show, Eq, Ord, Generic) + +-- | Exact semantic members of one trusted datatype compilation. +data DatatypeCompilationDescriptor = + DatatypeCompilationDescriptor + !ObjectId + !(NonEmpty ObjectId) + ![TheoremRef] + deriving stock (Show, Eq, Ord, Generic) + +datatypeCompilationDescriptor + :: ObjectId + -> NonEmpty ObjectId + -> [TheoremRef] + -> DatatypeCompilationDescriptor +datatypeCompilationDescriptor = + DatatypeCompilationDescriptor + +data CompilationDescriptor + = DatatypeCompilation !DatatypeCompilationDescriptor + deriving stock (Show, Eq, Ord, Generic) + +data DirectAuthorization + = CheckedKernelConstruction !KernelConstructionDescriptor + | CheckedSourceProof ![PreparedRequestId] + | TrustedCompilation !CompilationDescriptor + | SourceAxiomAuthorization + | OmittedAuthorization + deriving stock (Show, Eq, Ord, Generic) + + +data ValidationCertificate = ValidationCertificate + !FactAuthority + !DirectAuthorization + deriving stock (Show, Eq, Ord, Generic) + +data ValidationCertificateError + = SourceAxiomSafetyMismatch !AuthoritySafety + | OmittedSafetyMissing !AuthoritySafety + deriving stock (Show, Eq) + +validationCertificate + :: FactAuthority + -> DirectAuthorization + -> Either ValidationCertificateError ValidationCertificate +validationCertificate target direct = do + case direct of + SourceAxiomAuthorization -> + unless + (factAuthoritySafety target + == authoritySafety + (singletonEscapeKind SourceAxiom)) + (Left + (SourceAxiomSafetyMismatch + (factAuthoritySafety target))) + OmittedAuthorization -> + unless + (Omitted + `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (factAuthoritySafety target))) + (Left + (OmittedSafetyMissing + (factAuthoritySafety target))) + CheckedKernelConstruction{} -> pure () + CheckedSourceProof{} -> pure () + TrustedCompilation{} -> pure () + pure (ValidationCertificate target direct) + +validationTarget :: ValidationCertificate -> FactAuthority +validationTarget (ValidationCertificate target _) = + target + +validationDirectAuthorization + :: ValidationCertificate + -> DirectAuthorization +validationDirectAuthorization (ValidationCertificate _ direct) = + direct + + +newtype CandidateSafety = + CandidateSafety AuthoritySafety + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NFData) + +initialCandidateSafety :: CandidateSafety +initialCandidateSafety = + CandidateSafety Clean + +candidateSafetyAuthority :: CandidateSafety -> AuthoritySafety +candidateSafetyAuthority (CandidateSafety safety) = + safety + +-- | Freeze the final safety of one completed candidate into public authority. +-- +-- The trusted completion boundary uses this projection for both the inert +-- validation certificate and its runtime pending authorization. +candidateFactAuthority + :: TheoremRef + -> CandidateSafety + -> FactAuthority +candidateFactAuthority reference (CandidateSafety safety) = + FactAuthority reference safety + +data FactSafetyError + = FactSafetyTheoremMismatch !TheoremRef !TheoremRef + deriving stock (Show, Eq) + +-- | Check theorem agreement and accumulate already-authorized public safety. +-- +-- This operation does not authorize a freely constructed 'FactAuthority'. +-- Callers may use it only after checking opaque global, imported, or staged +-- builder authorization at the boundary that owns that authority. +accumulateFactSafety + :: TheoremRef + -> FactAuthority + -> CandidateSafety + -> Either FactSafetyError CandidateSafety +accumulateFactSafety expected supplied (CandidateSafety current) = do + unless + (factAuthorityTheorem supplied == expected) + (Left + (FactSafetyTheoremMismatch + expected + (factAuthorityTheorem supplied))) + pure + (CandidateSafety + (unionAuthoritySafety + current + (factAuthoritySafety supplied))) + +addCandidateEscape + :: EscapeKind + -> CandidateSafety + -> CandidateSafety +addCandidateEscape kind (CandidateSafety current) = + CandidateSafety + (unionAuthoritySafety + current + (authoritySafety (singletonEscapeKind kind))) + + +putEscapeKindsCache :: EscapeKinds -> CachePut +putEscapeKindsCache (EscapeKinds bits) = + putCacheTag bits + +getEscapeKindsCache :: CacheGet EscapeKinds +getEscapeKindsCache = do + bits <- getCacheTag + unless + (bits .&. complement allEscapeBits == 0) + (fail "unknown cache escape-kind bit") + pure (EscapeKinds bits) + +putAuthoritySafetyCache :: AuthoritySafety -> CachePut +putAuthoritySafetyCache = \case + Clean -> + putCacheTag 0x00 + EscapeHatchBacked kinds -> do + putCacheTag 0x01 + putEscapeKindsCache kinds + +getAuthoritySafetyCache :: CacheGet AuthoritySafety +getAuthoritySafetyCache = + getCacheTag >>= \case + 0x00 -> + pure Clean + 0x01 -> do + kinds <- getEscapeKindsCache + when + (kinds == emptyEscapeKinds) + (fail "empty escape-hatch-backed safety") + pure (EscapeHatchBacked kinds) + tag -> + fail ("unknown cache authority-safety tag " <> show tag) + +putFactAuthorityCache :: FactAuthority -> CachePut +putFactAuthorityCache (FactAuthority reference safety) = do + putTheoremRefCache reference + putAuthoritySafetyCache safety + +getFactAuthorityCache :: CacheGet FactAuthority +getFactAuthorityCache = + FactAuthority + <$> getTheoremRefCache + <*> getAuthoritySafetyCache + +putPreparedRequestIdCache :: PreparedRequestId -> CachePut +putPreparedRequestIdCache (PreparedRequestId digest) = + putCacheDigest digest + +getPreparedRequestIdCache :: CacheGet PreparedRequestId +getPreparedRequestIdCache = + PreparedRequestId <$> getCacheDigest + +putDirectAuthorizationCache :: DirectAuthorization -> CachePut +putDirectAuthorizationCache = \case + CheckedKernelConstruction descriptor -> do + putCacheTag 0x00 + putKernelDescriptor descriptor + CheckedSourceProof requests -> do + putCacheTag 0x01 + putCacheList putPreparedRequestIdCache requests + TrustedCompilation descriptor -> do + putCacheTag 0x02 + putCompilationDescriptor descriptor + SourceAxiomAuthorization -> + putCacheTag 0x03 + OmittedAuthorization -> + putCacheTag 0x04 + +getDirectAuthorizationCache :: CacheGet DirectAuthorization +getDirectAuthorizationCache = + getCacheTag >>= \case + 0x00 -> + CheckedKernelConstruction <$> getKernelDescriptor + 0x01 -> + CheckedSourceProof + <$> getCacheList getPreparedRequestIdCache + 0x02 -> + TrustedCompilation <$> getCompilationDescriptor + 0x03 -> + pure SourceAxiomAuthorization + 0x04 -> + pure OmittedAuthorization + tag -> + fail ("unknown cache direct-authorization tag " <> show tag) + +putValidationCertificateCache :: ValidationCertificate -> CachePut +putValidationCertificateCache + (ValidationCertificate target direct) = do + putFactAuthorityCache target + putDirectAuthorizationCache direct + +getValidationCertificateCache :: CacheGet ValidationCertificate +getValidationCertificateCache = do + target <- getFactAuthorityCache + direct <- getDirectAuthorizationCache + case validationCertificate target direct of + Left err -> + fail ("invalid cache validation certificate: " <> show err) + Right certificate -> + pure certificate + + +putKernelDescriptor :: KernelConstructionDescriptor -> CachePut +putKernelDescriptor = \case + FoundationLeaf tag -> do + putCacheTag 0x00 + putFoundationTag tag + GuardedFoundationRules rules -> do + putCacheTag 0x01 + putCacheList putRuleTag + (Set.toAscList (guardedRuleTags rules)) + CheckedDefinitionEquation identity -> do + putCacheTag 0x02 + putObjectIdCache identity + CheckedSetConstructionExtensionality identity construction -> do + putCacheTag 0x03 + putObjectIdCache identity + putCacheDigest construction + +getKernelDescriptor :: CacheGet KernelConstructionDescriptor +getKernelDescriptor = + getCacheTag >>= \case + 0x00 -> FoundationLeaf <$> getFoundationTag + 0x01 -> do + tags <- getCacheList getRuleTag + rules <- + maybe + (fail "cache guarded-rule set is empty") + pure + (NonEmpty.nonEmpty tags) + unless (strictlyIncreasing tags) + (fail "cache guarded-rule tags are not in canonical order") + pure (GuardedFoundationRules (guardedRuleSet rules)) + 0x02 -> CheckedDefinitionEquation <$> getObjectIdCache + 0x03 -> + CheckedSetConstructionExtensionality + <$> getObjectIdCache + <*> getCacheDigest + tag -> + fail ("unknown cache kernel-construction tag " <> show tag) + +putCompilationDescriptor :: CompilationDescriptor -> CachePut +putCompilationDescriptor + (DatatypeCompilation + (DatatypeCompilationDescriptor + carrier constructors facts)) = do + putCacheTag 0x00 + putObjectIdCache carrier + putCacheList putObjectIdCache (NonEmpty.toList constructors) + putCacheList putTheoremRefCache facts + +getCompilationDescriptor :: CacheGet CompilationDescriptor +getCompilationDescriptor = + getCacheTag >>= \case + 0x00 -> do + carrier <- getObjectIdCache + rawConstructors <- + getCacheList getObjectIdCache + constructors <- + maybe + (fail "cache datatype compilation has no constructors") + pure + (NonEmpty.nonEmpty rawConstructors) + facts <- getCacheList getTheoremRefCache + pure + (DatatypeCompilation + (DatatypeCompilationDescriptor + carrier constructors facts)) + tag -> + fail ("unknown cache compilation tag " <> show tag) + +putFoundationTag :: FoundationAxiomTag -> CachePut +putFoundationTag = + putCacheTag . \case + EmptyCharacteristic -> 0x00 + PairSetCharacteristic -> 0x01 + FamilyUnionCharacteristic -> 0x02 + PowerSetCharacteristic -> 0x03 + SeparationCharacteristic -> 0x04 + ReplacementCharacteristic -> 0x05 + SetChooseWitness -> 0x06 + SetExtensionality -> 0x07 + SetInduction -> 0x08 + PropositionalExtensionality -> 0x09 + DoubleNegationElim -> 0x0a + UnivOfContains -> 0x0b + UnivOfTransitive -> 0x0c + UnivOfFamilyUnionClosed -> 0x0d + UnivOfPowerSetClosed -> 0x0e + UnivOfReplacementClosed -> 0x0f + UnivOfMinimal -> 0x10 + +getFoundationTag :: CacheGet FoundationAxiomTag +getFoundationTag = + getCacheTag >>= \case + 0x00 -> pure EmptyCharacteristic + 0x01 -> pure PairSetCharacteristic + 0x02 -> pure FamilyUnionCharacteristic + 0x03 -> pure PowerSetCharacteristic + 0x04 -> pure SeparationCharacteristic + 0x05 -> pure ReplacementCharacteristic + 0x06 -> pure SetChooseWitness + 0x07 -> pure SetExtensionality + 0x08 -> pure SetInduction + 0x09 -> pure PropositionalExtensionality + 0x0a -> pure DoubleNegationElim + 0x0b -> pure UnivOfContains + 0x0c -> pure UnivOfTransitive + 0x0d -> pure UnivOfFamilyUnionClosed + 0x0e -> pure UnivOfPowerSetClosed + 0x0f -> pure UnivOfReplacementClosed + 0x10 -> pure UnivOfMinimal + tag -> + fail ("unknown cache foundation-axiom tag " <> show tag) + +putRuleTag :: KernelRuleTag -> CachePut +putRuleTag = + putCacheTag . \case + SetLfpBound -> 0x00 + SetLfpLeast -> 0x01 + SetLfpFixed -> 0x02 + SetLfpInduct -> 0x03 + +getRuleTag :: CacheGet KernelRuleTag +getRuleTag = + getCacheTag >>= \case + 0x00 -> pure SetLfpBound + 0x01 -> pure SetLfpLeast + 0x02 -> pure SetLfpFixed + 0x03 -> pure SetLfpInduct + tag -> + fail ("unknown cache kernel-rule tag " <> show tag) + +strictlyIncreasing :: Ord value => [value] -> Bool +strictlyIncreasing values = + and (zipWith (<) values (drop 1 values)) diff --git a/source/Felix/Checking/Backend/Problem.hs b/source/Felix/Checking/Backend/Problem.hs new file mode 100644 index 0000000..0390020 --- /dev/null +++ b/source/Felix/Checking/Backend/Problem.hs @@ -0,0 +1,1301 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Complete-problem FOF/TH0 classification and construction. +module Felix.Checking.Backend.Problem + ( SupportedProposition + , supportedProposition + , projectSupportedProposition + , supportedPropositionSupport + , supportedPropositionTerm + , weakenClosedSupportedProposition + , SupportedPropositionError(..) + , SupportedPropositionProjectionError(..) + , CheckedFofProjection + , checkedFofProjectionProposition + , FofCapability(..) + , BackendFofExclusion(..) + , BackendClassificationError(..) + , classifySupportedProposition + , TypedBackendFact + , typedBackendFact + , typedBackendFactReference + , typedBackendFactProposition + , typedBackendFactCapability + , LocalPremiseOrdinal + , localPremiseOrdinal + , localPremiseOrdinalValue + , TypedLocalPremise + , typedLocalPremise + , typedLocalPremiseOrdinal + , typedLocalPremiseOrigin + , typedLocalPremiseProposition + , typedLocalPremiseCapability + , TypedFoundationAuxiliaryInput + , typedFoundationAuxiliaryInput + , TypedProblemAuxiliary + , typedProblemAuxiliaryOrdinal + , typedProblemAuxiliaryTag + , typedProblemAuxiliaryProposition + , typedProblemAuxiliaryCapability + , LocalPremisePolicy(..) + , HigherOrderJustificationPolicy(..) + , selectTypedLocalPremises + , TypedProblemRoute(..) + , TypedProblem + , planTypedProblem + , typedProblemRoute + , typedProblemClaim + , typedProblemGlobalPremises + , typedProblemLocalPremises + , typedProblemAuxiliaries + , typedProblemGlobalTypes + , typedProblemLocalTypes + , TypedProblemError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Control.Monad (foldM, unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +-- | A proposition under its exact nearest-first ambient-local support. +data SupportedProposition local global = + SupportedProposition + !(Vector (local, CoreType)) + !(ScopedCheckedCore global) + deriving stock (Eq) + +data SupportedPropositionError local + = SupportedPropositionIsNotProposition !CoreType + | SupportedPropositionContextMismatch + ![CoreType] + ![CoreType] + | DuplicateSupportedLocal !local + | UnusedSupportedLocal !local + deriving stock (Show, Eq) + +data SupportedPropositionProjectionError local + = SupportedProjectionContextMismatch + ![CoreType] + ![CoreType] + | SupportedProjectionDuplicateLocal !local + | SupportedProjectionIndexMissing !Natural + | SupportedProjectionCoreCheckFailed !CoreCheckError + | SupportedProjectionValidationFailed + !(SupportedPropositionError local) + deriving stock (Show, Eq) + +supportedProposition + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore global + -> Either + (SupportedPropositionError local) + (SupportedProposition local global) +supportedProposition support statement = do + unless + (scopedCoreType statement == TyProp) + (Left + (SupportedPropositionIsNotProposition + (scopedCoreType statement))) + let expectedContext = + snd <$> Vector.toList support + actualContext = + scopedCoreContext statement + unless + (actualContext == expectedContext) + (Left + (SupportedPropositionContextMismatch + expectedContext + actualContext)) + void + (foldM + (\seen (local, _coreType) -> + if local `Set.member` seen + then + Left + (DuplicateSupportedLocal local) + else + Right (Set.insert local seen)) + Set.empty + support) + case + List.find + (\(ordinal, _entry) -> + fromIntegral ordinal + `Set.notMember` + ambientIndices + (scopedCoreTerm statement)) + (Vector.toList + (Vector.indexed support)) of + Just (_ordinal, (local, _coreType)) -> + Left (UnusedSupportedLocal local) + Nothing -> + pure () + pure + (SupportedProposition + support + statement) + +-- | Retain exactly the ambient locals used by a checked proposition and +-- remap its indices to that dense nearest-first support. +projectSupportedProposition + :: Ord local + => (global -> Maybe CoreType) + -> Vector (local, CoreType) + -> ScopedCheckedCore global + -> Either + (SupportedPropositionProjectionError local) + (SupportedProposition local global) +projectSupportedProposition globalType available statement = do + let expectedContext = snd <$> Vector.toList available + actualContext = scopedCoreContext statement + unless (expectedContext == actualContext) + (Left + (SupportedProjectionContextMismatch + expectedContext + actualContext)) + void + (foldM + (\seen (local, _coreType) -> + if local `Set.member` seen + then Left (SupportedProjectionDuplicateLocal local) + else Right (Set.insert local seen)) + Set.empty + available) + let used = + Set.toAscList + (ambientIndices + (scopedCoreTerm statement)) + selected <- traverse (lookupNatural available) used + let remapping = + Map.fromAscList + (zip used [0 ..]) + remapped <- remapAmbientIndices remapping 0 + (scopedCoreTerm statement) + checked <- + first SupportedProjectionCoreCheckFailed + (checkScopedCanonicalCore + globalType + (snd <$> selected) + remapped) + first SupportedProjectionValidationFailed + (supportedProposition + (Vector.fromList selected) + checked) + where + lookupNatural values index = + maybe + (Left (SupportedProjectionIndexMissing index)) + Right + (go index (Vector.toList values)) + + go _index [] = + Nothing + go 0 (value : _rest) = + Just value + go index (_value : rest) = + go (index - 1) rest + + remapAmbientIndices remapping depth = \case + CBound index + | index < depth -> + Right (CBound index) + | otherwise -> + maybe + (Left + (SupportedProjectionIndexMissing + (index - depth))) + (Right . CBound . (+ depth)) + (Map.lookup (index - depth) remapping) + CGlobal global -> + Right (CGlobal global) + CIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + COpaqueInteger integer -> + Right (COpaqueInteger integer) + CApp function argument -> + CApp + <$> remapAmbientIndices remapping depth function + <*> remapAmbientIndices remapping depth argument + CLam binderType body -> + CLam binderType + <$> remapAmbientIndices remapping (depth + 1) body + CFalsum -> + Right CFalsum + CImp premise conclusion -> + CImp + <$> remapAmbientIndices remapping depth premise + <*> remapAmbientIndices remapping depth conclusion + CEq operandType left right -> + CEq operandType + <$> remapAmbientIndices remapping depth left + <*> remapAmbientIndices remapping depth right + CForall binderType body -> + CForall binderType + <$> remapAmbientIndices remapping (depth + 1) body + +ambientIndices + :: CanonicalTerm global + -> Set Natural +ambientIndices = + go 0 + where + go depth = \case + CBound index + | index < depth -> + mempty + | otherwise -> + Set.singleton (index - depth) + CGlobal{} -> + mempty + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + go depth function <> go depth argument + CLam _binderType body -> + go (depth + 1) body + CFalsum -> + mempty + CImp premise conclusion -> + go depth premise <> go depth conclusion + CEq _operandType left right -> + go depth left <> go depth right + CForall _binderType body -> + go (depth + 1) body + +supportedPropositionSupport + :: SupportedProposition local global + -> Vector (local, CoreType) +supportedPropositionSupport + (SupportedProposition support _statement) = + support + +supportedPropositionTerm + :: SupportedProposition local global + -> CanonicalTerm global +supportedPropositionTerm + (SupportedProposition _support statement) = + scopedCoreTerm statement + +weakenClosedSupportedProposition + :: SupportedProposition Void global + -> SupportedProposition local global +weakenClosedSupportedProposition + (SupportedProposition support statement) = + SupportedProposition + (fmap + (\(local, coreType) -> + (absurd local, coreType)) + support) + statement + + +newtype CheckedFofProjection local global = + CheckedFofProjection + (SupportedProposition local global) + deriving stock (Eq) + +checkedFofProjectionProposition + :: CheckedFofProjection local global + -> SupportedProposition local global +checkedFofProjectionProposition + (CheckedFofProjection proposition) = + proposition + +data FofCapability projection + = FofProjectable !projection + | RequiresTh0 !(NonEmpty BackendFofExclusion) + deriving stock (Eq) + +data BackendFofExclusion + = StructuralFofExclusion !FofExclusion + | HigherOrderGlobalType !CoreType + | HigherOrderAmbientLocal !CoreType + deriving stock (Show, Eq, Ord) + +data BackendClassificationError global + = UnknownBackendGlobal !global + | BackendFofProjectionInvariantFailed + deriving stock (Show, Eq) + +classifySupportedProposition + :: Ord global + => (global -> Maybe CoreType) + -> SupportedProposition local global + -> Either + (BackendClassificationError global) + (FofCapability + (CheckedFofProjection local global)) +classifySupportedProposition globalType proposition = do + globalExclusions <- + foldM + collectGlobal + Set.empty + (Set.toAscList + (canonicalGlobals + (supportedPropositionTerm proposition))) + let structuralExclusions = + case classifyScopedStructure proposition of + FoundationFofProjectable -> + Set.empty + FoundationRequiresTh0 structural -> + Set.fromList + (StructuralFofExclusion + <$> toList structural) + localExclusions = + Set.fromList + [ HigherOrderAmbientLocal coreType + | (_local, coreType) <- + Vector.toList + (supportedPropositionSupport + proposition) + , coreType /= TySet + ] + exclusions = + structuralExclusions + <> globalExclusions + <> localExclusions + case Set.toAscList exclusions of + [] -> + if isFirstOrderProposition + globalType + proposition + then + Right + (FofProjectable + (CheckedFofProjection + proposition)) + else + Left BackendFofProjectionInvariantFailed + firstExclusion : remainingExclusions -> + Right + (RequiresTh0 + (firstExclusion + :| remainingExclusions)) + where + collectGlobal exclusions global = + case globalType global of + Nothing -> + Left (UnknownBackendGlobal global) + Just coreType -> + Right + (if isFirstOrderGlobalType coreType + then exclusions + else + Set.insert + (HigherOrderGlobalType + coreType) + exclusions) + +classifyScopedStructure + :: SupportedProposition local global + -> FoundationBackendClass +classifyScopedStructure = + classifyCanonicalFofStructure + . supportedPropositionTerm + +isFirstOrderGlobalType :: CoreType -> Bool +isFirstOrderGlobalType = + go + where + go = \case + TySet -> + True + TyProp -> + True + TyArrow TySet result -> + go result + TyArrow _argument _result -> + False + +-- The structural and type exclusions make this projection total. This final +-- walk catches an accidentally unsaturated first-order head. +isFirstOrderProposition + :: (global -> Maybe CoreType) + -> SupportedProposition local global + -> Bool +isFirstOrderProposition globalType proposition = + isFormula initialContext + (supportedPropositionTerm proposition) + where + initialContext = + snd + <$> Vector.toList + (supportedPropositionSupport + proposition) + + isFormula context = \case + CFalsum -> + True + CImp premise conclusion -> + isFormula context premise + && isFormula context conclusion + CEq TySet left right -> + isTerm context left + && isTerm context right + CEq TyProp left right -> + isFormula context left + && isFormula context right + CForall TySet body -> + isFormula (TySet : context) body + application -> + case applicationHead application of + (CGlobal global, arguments) -> + maybe + False + (\coreType -> + applicationResult + coreType + arguments + == Just TyProp + && all + (isTerm context) + arguments) + (globalType global) + (CIntrinsic intrinsic, arguments) -> + applicationResult + (coreIntrinsicType intrinsic) + arguments + == Just TyProp + && all + (isTerm context) + arguments + _ -> + False + + isTerm context = \case + CBound index -> + contextAt index context + == Just TySet + CGlobal global -> + globalType global == Just TySet + CIntrinsic intrinsic -> + coreIntrinsicType intrinsic == TySet + COpaqueInteger{} -> + True + application -> + case applicationHead application of + (CGlobal global, arguments) -> + maybe + False + (\coreType -> + applicationResult + coreType + arguments + == Just TySet + && all + (isTerm context) + arguments) + (globalType global) + (CIntrinsic intrinsic, arguments) -> + applicationResult + (coreIntrinsicType intrinsic) + arguments + == Just TySet + && all + (isTerm context) + arguments + _ -> + False + +applicationHead + :: CanonicalTerm global + -> (CanonicalTerm global, [CanonicalTerm global]) +applicationHead = + go [] + where + go arguments = \case + CApp function argument -> + go (argument : arguments) function + headTerm -> + (headTerm, arguments) + +applicationResult + :: CoreType + -> [CanonicalTerm global] + -> Maybe CoreType +applicationResult = + foldM + (\coreType _argument -> + case coreType of + TyArrow TySet result -> + Just result + _ -> + Nothing) + +contextAt :: Natural -> [value] -> Maybe value +contextAt _index [] = + Nothing +contextAt 0 (value : _remaining) = + Just value +contextAt index (_value : remaining) = + contextAt (index - 1) remaining + +canonicalGlobals + :: Ord global + => CanonicalTerm global + -> Set global +canonicalGlobals = \case + CBound{} -> + mempty + CGlobal global -> + Set.singleton global + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalGlobals function + <> canonicalGlobals argument + CLam _binderType body -> + canonicalGlobals body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalGlobals premise + <> canonicalGlobals conclusion + CEq _operandType left right -> + canonicalGlobals left + <> canonicalGlobals right + CForall _binderType body -> + canonicalGlobals body + + +data TypedBackendFact ref global = + TypedBackendFact + !ref + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + deriving stock (Eq) + +typedBackendFact + :: ref + -> SupportedProposition Void global + -> FofCapability + (CheckedFofProjection Void global) + -> TypedBackendFact ref global +typedBackendFact = + TypedBackendFact + +typedBackendFactReference + :: TypedBackendFact ref global + -> ref +typedBackendFactReference + (TypedBackendFact + reference + _proposition + _capability) = + reference + +typedBackendFactProposition + :: TypedBackendFact ref global + -> SupportedProposition Void global +typedBackendFactProposition + (TypedBackendFact + _reference + proposition + _capability) = + proposition + +typedBackendFactCapability + :: TypedBackendFact ref global + -> FofCapability + (CheckedFofProjection Void global) +typedBackendFactCapability + (TypedBackendFact + _reference + _proposition + capability) = + capability + + +newtype LocalPremiseOrdinal = + LocalPremiseOrdinal Natural + deriving stock (Show, Eq, Ord) + +localPremiseOrdinal :: Natural -> LocalPremiseOrdinal +localPremiseOrdinal = + LocalPremiseOrdinal + +localPremiseOrdinalValue + :: LocalPremiseOrdinal + -> Natural +localPremiseOrdinalValue + (LocalPremiseOrdinal ordinal) = + ordinal + +data TypedLocalPremise local origin global = + TypedLocalPremise + !LocalPremiseOrdinal + !origin + !(SupportedProposition local global) + !(FofCapability + (CheckedFofProjection local global)) + deriving stock (Eq) + +typedLocalPremise + :: Ord global + => (global -> Maybe CoreType) + -> LocalPremiseOrdinal + -> origin + -> SupportedProposition local global + -> Either + (BackendClassificationError global) + (TypedLocalPremise local origin global) +typedLocalPremise globalType ordinal premiseOrigin proposition = + TypedLocalPremise + ordinal + premiseOrigin + proposition + <$> classifySupportedProposition + globalType + proposition + +typedLocalPremiseOrdinal + :: TypedLocalPremise local origin global + -> LocalPremiseOrdinal +typedLocalPremiseOrdinal + (TypedLocalPremise + ordinal + _origin + _proposition + _capability) = + ordinal + +typedLocalPremiseOrigin + :: TypedLocalPremise local origin global + -> origin +typedLocalPremiseOrigin + (TypedLocalPremise + _ordinal + premiseOrigin + _proposition + _capability) = + premiseOrigin + +typedLocalPremiseProposition + :: TypedLocalPremise local origin global + -> SupportedProposition local global +typedLocalPremiseProposition + (TypedLocalPremise + _ordinal + _origin + proposition + _capability) = + proposition + +typedLocalPremiseCapability + :: TypedLocalPremise local origin global + -> FofCapability + (CheckedFofProjection local global) +typedLocalPremiseCapability + (TypedLocalPremise + _ordinal + _origin + _proposition + capability) = + capability + + +data TypedFoundationAuxiliaryInput global = + TypedFoundationAuxiliaryInput + !FoundationAxiomTag + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + +typedFoundationAuxiliaryInput + :: CheckedFoundation + -> FoundationAxiomTag + -> TypedFoundationAuxiliaryInput global +typedFoundationAuxiliaryInput foundation tag = + TypedFoundationAuxiliaryInput + tag + proposition + capability + where + proposition = + SupportedProposition + Vector.empty + (embedClosedCore + [] + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag))) + capability = + case foundationAxiomBackendClass + foundation + tag of + FoundationFofProjectable -> + FofProjectable + (CheckedFofProjection + proposition) + FoundationRequiresTh0 exclusions -> + RequiresTh0 + (StructuralFofExclusion + <$> exclusions) + +data TypedProblemAuxiliary global = + TypedProblemAuxiliary + !Natural + !FoundationAxiomTag + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + deriving stock (Eq) + +typedProblemAuxiliaryOrdinal + :: TypedProblemAuxiliary global + -> Natural +typedProblemAuxiliaryOrdinal + (TypedProblemAuxiliary + ordinal + _tag + _proposition + _capability) = + ordinal + +typedProblemAuxiliaryTag + :: TypedProblemAuxiliary global + -> FoundationAxiomTag +typedProblemAuxiliaryTag + (TypedProblemAuxiliary + _ordinal + tag + _proposition + _capability) = + tag + +typedProblemAuxiliaryProposition + :: TypedProblemAuxiliary global + -> SupportedProposition Void global +typedProblemAuxiliaryProposition + (TypedProblemAuxiliary + _ordinal + _tag + proposition + _capability) = + proposition + +typedProblemAuxiliaryCapability + :: TypedProblemAuxiliary global + -> FofCapability + (CheckedFofProjection Void global) +typedProblemAuxiliaryCapability + (TypedProblemAuxiliary + _ordinal + _tag + _proposition + capability) = + capability + + +-- | Source justification policy for premise selection. Higher-order routing +-- is validated separately after the complete selected problem is known. +data LocalPremisePolicy + = FirstOrderLocals + | CompleteLocals + deriving stock (Show, Eq) + +-- | Whether selected higher-order components must be justified by one of the +-- two approved inline construction forms. Premise selection has already +-- happened when this policy is applied. +data HigherOrderJustificationPolicy + = ImplicitConstructionJustification + | ExplicitHigherOrderJustification + deriving stock (Show, Eq) + +selectTypedLocalPremises + :: LocalPremisePolicy + -> [TypedLocalPremise local origin global] + -> Vector (TypedLocalPremise local origin global) +selectTypedLocalPremises selection availableLocals = + Vector.fromList + (List.sortOn + typedLocalPremiseOrdinal + (case selection of + FirstOrderLocals -> + List.filter + (isFofCapability + . typedLocalPremiseCapability) + availableLocals + CompleteLocals -> + availableLocals)) + +data ImplicitHigherOrderConstruction + = ImplicitSeparation + | ImplicitFunctionalReplacement + deriving stock (Show, Eq, Ord) + +data TypedProblemRoute + = RouteFof + | RouteTh0 + deriving stock (Show, Eq) + +data TypedProblem ref local origin global = + TypedProblem + !TypedProblemRoute + !(SupportedProposition local global) + !(Vector (TypedBackendFact ref global)) + !(Vector (TypedLocalPremise local origin global)) + !(Vector (TypedProblemAuxiliary global)) + !(Map global CoreType) + !(Map local CoreType) + deriving stock (Eq) + +data TypedProblemError local global + = TypedProblemClaimClassificationFailed + !(BackendClassificationError global) + | TypedProblemExplicitHigherOrderJustificationRequired + !(NonEmpty BackendFofExclusion) + | TypedProblemDuplicateLocalPremiseOrdinal + !LocalPremiseOrdinal + | TypedProblemLocalTypeMismatch + !local + !CoreType + !CoreType + deriving stock (Show, Eq) + +planTypedProblem + :: (Ord local, Ord global) + => (global -> Maybe CoreType) + -> Vector (TypedBackendFact ref global) + -> SupportedProposition local global + -> [TypedLocalPremise local origin global] + -> [TypedFoundationAuxiliaryInput global] + -> LocalPremisePolicy + -> HigherOrderJustificationPolicy + -> Either + (TypedProblemError local global) + (TypedProblem ref local origin global) +planTypedProblem + globalType + selectedFacts + claim + availableLocals + auxiliaries + localPolicy + higherOrderPolicy = do + validateLocalPremiseOrdinals + availableLocals + claimCapability <- + first + TypedProblemClaimClassificationFailed + (classifySupportedProposition + globalType + claim) + let selectedLocals = + selectTypedLocalPremises + localPolicy + availableLocals + let preparedAuxiliaries = + zipWith + prepareAuxiliary + [0..] + auxiliaries + case higherOrderPolicy of + ImplicitConstructionJustification -> + validateImplicitHigherOrderAdmission + claim + claimCapability + selectedFacts + selectedLocals + preparedAuxiliaries + ExplicitHigherOrderJustification -> + pure () + let selectedFofCapabilities = + isFofCapability claimCapability + : (isFofCapability + . typedBackendFactCapability + <$> Vector.toList selectedFacts) + <> (isFofCapability + . typedLocalPremiseCapability + <$> Vector.toList selectedLocals) + <> (isFofCapability + . typedProblemAuxiliaryCapability + <$> preparedAuxiliaries) + route = + if and selectedFofCapabilities + then RouteFof + else RouteTh0 + globalTypes <- + collectProblemGlobals + globalType + claim + selectedFacts + selectedLocals + preparedAuxiliaries + localTypes <- + collectProblemLocals + claim + selectedLocals + pure + (TypedProblem + route + claim + selectedFacts + selectedLocals + (Vector.fromList preparedAuxiliaries) + globalTypes + localTypes) + where + prepareAuxiliary + ordinal + (TypedFoundationAuxiliaryInput + tag + proposition + capability) = + TypedProblemAuxiliary + ordinal + tag + proposition + capability + +-- | Implicit automation admits higher-order routing only for a checked +-- proposition that itself contains one of the two approved set constructions. +-- This classification selects no premise and grants no authority. +implicitConstructionAdmission + :: SupportedProposition local global + -> FofCapability projection + -> Maybe (Set ImplicitHigherOrderConstruction) +implicitConstructionAdmission proposition capability = + case capability of + FofProjectable{} -> + Nothing + RequiresTh0 exclusions + | Set.null constructions -> + Nothing + | all (admittedExclusion constructions) exclusions -> + Just constructions + | otherwise -> + Nothing + where + dependencies = + foundationAxiomDependencies + (supportedPropositionTerm proposition) + constructions = + Set.fromList + ( [ ImplicitSeparation + | SeparationCharacteristic `Set.member` dependencies + ] + <> [ ImplicitFunctionalReplacement + | ReplacementCharacteristic `Set.member` dependencies + ] + ) + + admittedExclusion allowed = \case + StructuralFofExclusion HigherOrderLambda -> + True + StructuralFofExclusion (HigherOrderIntrinsic Sep) -> + ImplicitSeparation `Set.member` allowed + StructuralFofExclusion (HigherOrderIntrinsic Repl) -> + ImplicitFunctionalReplacement `Set.member` allowed + -- The checked proposition is the deliberate granularity: its typed + -- global occurrences neither select another fact nor grant authority. + HigherOrderGlobalType{} -> + True + StructuralFofExclusion{} -> + False + HigherOrderAmbientLocal{} -> + False + +validateImplicitHigherOrderAdmission + :: SupportedProposition local global + -> FofCapability claimProjection + -> Vector (TypedBackendFact ref global) + -> Vector (TypedLocalPremise local origin global) + -> [TypedProblemAuxiliary global] + -> Either (TypedProblemError local global) () +validateImplicitHigherOrderAdmission + claim claimCapability selectedFacts selectedLocals auxiliaries = do + claimConstructions <- + admittedPropositionConstructions claim claimCapability + traverse_ requireFirstOrderGlobal selectedFacts + localConstructions <- + foldM + (\admitted premise -> + (admitted <>) + <$> admittedPropositionConstructions + (typedLocalPremiseProposition premise) + (typedLocalPremiseCapability premise)) + Set.empty + (Vector.toList selectedLocals) + let admitted = claimConstructions <> localConstructions + traverse_ (requireAdmittedAuxiliary admitted) auxiliaries + where + admittedPropositionConstructions proposition = \case + FofProjectable{} -> + Right Set.empty + RequiresTh0 exclusions -> + maybe + (Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions)) + Right + (implicitConstructionAdmission + proposition + (RequiresTh0 exclusions)) + + requireFirstOrderGlobal fact = + case typedBackendFactCapability fact of + FofProjectable{} -> + Right () + RequiresTh0 exclusions -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + requireAdmittedAuxiliary admitted auxiliary = + case typedProblemAuxiliaryCapability auxiliary of + FofProjectable{} -> + Right () + RequiresTh0 exclusions + | auxiliaryAdmitted admitted + (typedProblemAuxiliaryTag auxiliary) -> + Right () + | otherwise -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + auxiliaryAdmitted admitted = \case + SeparationCharacteristic -> + ImplicitSeparation `Set.member` admitted + ReplacementCharacteristic -> + ImplicitFunctionalReplacement `Set.member` admitted + _ -> + False + +validateLocalPremiseOrdinals + :: [TypedLocalPremise local origin global] + -> Either + (TypedProblemError local global) + () +validateLocalPremiseOrdinals = + void + . foldM + (\seen premise -> + let ordinal = + typedLocalPremiseOrdinal premise + in + if ordinal `Set.member` seen + then + Left + (TypedProblemDuplicateLocalPremiseOrdinal + ordinal) + else + Right + (Set.insert + ordinal + seen)) + Set.empty + +isFofCapability :: FofCapability projection -> Bool +isFofCapability = \case + FofProjectable{} -> + True + RequiresTh0{} -> + False + +collectProblemGlobals + :: Ord global + => (global -> Maybe CoreType) + -> SupportedProposition local global + -> Vector (TypedBackendFact ref global) + -> Vector (TypedLocalPremise local origin global) + -> [TypedProblemAuxiliary global] + -> Either + (TypedProblemError local global) + (Map global CoreType) +collectProblemGlobals + globalType + claim + facts + locals + auxiliaries = + Map.fromAscList + <$> traverse + resolveGlobal + (Set.toAscList globals) + where + globals = + canonicalGlobals + (supportedPropositionTerm claim) + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedBackendFactProposition) + facts + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedLocalPremiseProposition) + locals + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedProblemAuxiliaryProposition) + auxiliaries + + resolveGlobal global = + case globalType global of + Nothing -> + Left + (TypedProblemClaimClassificationFailed + (UnknownBackendGlobal global)) + Just coreType -> + Right (global, coreType) + +collectProblemLocals + :: Ord local + => SupportedProposition local global + -> Vector (TypedLocalPremise local origin global) + -> Either + (TypedProblemError local global) + (Map local CoreType) +collectProblemLocals claim locals = + foldM + insertSupport + Map.empty + supports + where + supports = + Vector.toList + (supportedPropositionSupport claim) + <> concatMap + (Vector.toList + . supportedPropositionSupport + . typedLocalPremiseProposition) + (Vector.toList locals) + + insertSupport current (local, coreType) = + case Map.lookup local current of + Nothing -> + Right + (Map.insert + local + coreType + current) + Just previousType + | previousType == coreType -> + Right current + | otherwise -> + Left + (TypedProblemLocalTypeMismatch + local + previousType + coreType) + +typedProblemRoute + :: TypedProblem ref local origin global + -> TypedProblemRoute +typedProblemRoute + (TypedProblem + route + _claim + _facts + _locals + _auxiliaries + _globals + _localTypes) = + route + +typedProblemClaim + :: TypedProblem ref local origin global + -> SupportedProposition local global +typedProblemClaim + (TypedProblem + _route + claim + _facts + _locals + _auxiliaries + _globals + _localTypes) = + claim + +typedProblemGlobalPremises + :: TypedProblem ref local origin global + -> Vector (TypedBackendFact ref global) +typedProblemGlobalPremises + (TypedProblem + _route + _claim + facts + _locals + _auxiliaries + _globals + _localTypes) = + facts + +typedProblemLocalPremises + :: TypedProblem ref local origin global + -> Vector (TypedLocalPremise local origin global) +typedProblemLocalPremises + (TypedProblem + _route + _claim + _facts + locals + _auxiliaries + _globals + _localTypes) = + locals + +typedProblemAuxiliaries + :: TypedProblem ref local origin global + -> Vector (TypedProblemAuxiliary global) +typedProblemAuxiliaries + (TypedProblem + _route + _claim + _facts + _locals + auxiliaries + _globals + _localTypes) = + auxiliaries + +typedProblemGlobalTypes + :: TypedProblem ref local origin global + -> Map global CoreType +typedProblemGlobalTypes + (TypedProblem + _route + _claim + _facts + _locals + _auxiliaries + globals + _localTypes) = + globals + +typedProblemLocalTypes + :: TypedProblem ref local origin global + -> Map local CoreType +typedProblemLocalTypes + (TypedProblem + _route + _claim + _facts + _locals + _auxiliaries + _globals + localTypes) = + localTypes diff --git a/source/Felix/Checking/Backend/Tptp.hs b/source/Felix/Checking/Backend/Tptp.hs new file mode 100644 index 0000000..a5c0546 --- /dev/null +++ b/source/Felix/Checking/Backend/Tptp.hs @@ -0,0 +1,1281 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Deterministic task-wide TPTP preparation for checked typed problems. +module Felix.Checking.Backend.Tptp + ( TypedFormulaOccurrence(..) + , TypedTptpNameOrigin(..) + , PreparedTypedTptpProblem + , prepareTypedTptpProblem + , preparedTypedTptpRoute + , preparedTypedTptpText + , preparedTypedTptpTextNewline + , preparedTypedTptpConjectureText + , preparedTypedTptpNameOrigins + , TypedTptpPreparationError(..) + ) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Core +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Control.Monad (foldM) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Control.Monad.Trans.Class (lift) +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 Numeric.Natural (Natural) +import TextBuilder + + +data TypedFormulaOccurrence ref + = TypedGlobalPremiseOccurrence !ref + | TypedLocalPremiseOccurrence !LocalPremiseOrdinal + | TypedAuxiliaryOccurrence !Natural + | TypedConjectureOccurrence + deriving stock (Show, Eq, Ord) + +data TypedTptpNameOrigin ref local global + = TypedGlobalNameOrigin !global + | TypedLocalNameOrigin !local + | TypedIntrinsicNameOrigin !CoreIntrinsicTag + | TypedIntegerNameOrigin !Integer + | TypedBinderNameOrigin !Natural + | TypedFormulaNameOrigin !(TypedFormulaOccurrence ref) + deriving stock (Show, Eq, Ord) + +data PreparedTypedTptpProblem ref local global = + PreparedTypedTptpProblem + !TypedProblemRoute + !Text + !Text + !(Map + Text + (TypedTptpNameOrigin ref local global)) + deriving stock (Eq) + +preparedTypedTptpRoute + :: PreparedTypedTptpProblem ref local global + -> TypedProblemRoute +preparedTypedTptpRoute + (PreparedTypedTptpProblem + route + _text + _conjecture + _origins) = + route + +preparedTypedTptpText + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpText + (PreparedTypedTptpProblem + _route + problemText + _conjecture + _origins) = + problemText + +preparedTypedTptpTextNewline + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpTextNewline = + (`Text.snoc` '\n') + . preparedTypedTptpText + +preparedTypedTptpConjectureText + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpConjectureText + (PreparedTypedTptpProblem + _route + _text + conjecture + _origins) = + conjecture + +preparedTypedTptpNameOrigins + :: PreparedTypedTptpProblem ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) +preparedTypedTptpNameOrigins + (PreparedTypedTptpProblem + _route + _text + _conjecture + origins) = + origins + +data TypedTptpPreparationError local global + = InvalidGeneratedTypedTptpName !Text + | DuplicateGeneratedTypedTptpName !Text + | TypedTptpUnknownGlobal !global + | TypedTptpUnknownLocal !local + | TypedTptpUnboundIndex !Natural + | TypedTptpFofProjectionMismatch + deriving stock (Show, Eq) + + +data NameEnvironment ref local global = + NameEnvironment + !(Map global Tptp.AtomicWord) + !(Map global CoreType) + !(Map local Tptp.AtomicWord) + !(Map CoreIntrinsicTag Tptp.AtomicWord) + !(Map Integer Tptp.AtomicWord) + !(Map + Text + (TypedTptpNameOrigin ref local global)) + +data RenderState ref local global = + RenderState + !Natural + !Natural + !(Map + Text + (TypedTptpNameOrigin ref local global)) + +type Render ref local global = + StateT + (RenderState ref local global) + (Either + (TypedTptpPreparationError local global)) + +data RenderedFormula ref = RenderedFormula + !Tptp.AtomicWord + !(TypedFormulaOccurrence ref) + !TextBuilder + +data BoundTarget + = BoundFofVariable !Tptp.Variable + | BoundTh0Variable !Tptp.Variable + | AmbientConstant !Tptp.AtomicWord + +prepareTypedTptpProblem + :: (Ord local, Ord global) + => TypedProblem ref local origin global + -> Either + (TypedTptpPreparationError local global) + (PreparedTypedTptpProblem ref local global) +prepareTypedTptpProblem problem = do + names <- + allocateNames problem + let initialState = + RenderState + 0 + 0 + (nameEnvironmentOrigins names) + (rendered, finalState) <- + State.runStateT + (renderProblem names problem) + initialState + let (problemBuilder, conjectureBuilder) = + rendered + RenderState _nextBinder _nextHypothesis origins = + finalState + pure + (PreparedTypedTptpProblem + (typedProblemRoute problem) + (TextBuilder.toText problemBuilder) + (TextBuilder.toText conjectureBuilder) + origins) + +allocateNames + :: (Ord local, Ord global) + => TypedProblem ref local origin global + -> Either + (TypedTptpPreparationError local global) + (NameEnvironment ref local global) +allocateNames problem = do + globalAllocations <- + allocateCategory + "tg_g" + TypedGlobalNameOrigin + (Map.keys + (typedProblemGlobalTypes + problem)) + localAllocations <- + allocateCategory + "tg_l" + TypedLocalNameOrigin + (Map.keys + (typedProblemLocalTypes + problem)) + intrinsicAllocations <- + allocateCategory + "tg_i" + TypedIntrinsicNameOrigin + (Set.toAscList + (problemIntrinsics problem)) + integerAllocations <- + allocateCategory + "tg_n" + TypedIntegerNameOrigin + (Set.toAscList + (problemIntegers problem)) + origins <- + foldM + (\current (target, nameOrigin) -> + insertOrigin + (Tptp.atomicWordText target) + nameOrigin + current) + Map.empty + ( [ (target, nameOrigin) + | (_global, target, nameOrigin) <- + globalAllocations + ] + <> [ (target, nameOrigin) + | (_local, target, nameOrigin) <- + localAllocations + ] + <> [ (target, nameOrigin) + | (_intrinsic, target, nameOrigin) <- + intrinsicAllocations + ] + <> [ (target, nameOrigin) + | (_integer, target, nameOrigin) <- + integerAllocations + ] + ) + pure + (NameEnvironment + (Map.fromList + [ (global, target) + | (global, target, _nameOrigin) <- + globalAllocations + ]) + (typedProblemGlobalTypes problem) + (Map.fromList + [ (local, target) + | (local, target, _nameOrigin) <- + localAllocations + ]) + (Map.fromList + [ (intrinsic, target) + | (intrinsic, target, _nameOrigin) <- + intrinsicAllocations + ]) + (Map.fromList + [ (integer, target) + | (integer, target, _nameOrigin) <- + integerAllocations + ]) + origins) + where + allocateCategory prefix makeOrigin semantics = + traverse + (\(ordinal, semantic) -> do + target <- + generatedAtomicWord + (prefix + <> Text.pack + (show ordinal)) + pure + ( semantic + , target + , makeOrigin semantic + )) + (zip [0 :: Int ..] semantics) + +nameEnvironmentOrigins + :: NameEnvironment ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) +nameEnvironmentOrigins + (NameEnvironment + _globals + _globalTypes + _locals + _intrinsics + _integers + origins) = + origins + +generatedAtomicWord + :: Text + -> Either + (TypedTptpPreparationError local global) + Tptp.AtomicWord +generatedAtomicWord target = + maybe + (Left + (InvalidGeneratedTypedTptpName + target)) + Right + (Tptp.atomicWord target) + +generatedVariable + :: Text + -> Either + (TypedTptpPreparationError local global) + Tptp.Variable +generatedVariable target = + maybe + (Left + (InvalidGeneratedTypedTptpName + target)) + Right + (Tptp.variable target) + +insertOrigin + :: Text + -> TypedTptpNameOrigin ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) + -> Either + (TypedTptpPreparationError local global) + (Map + Text + (TypedTptpNameOrigin ref local global)) +insertOrigin target nameOrigin origins = + if Map.member target origins + then + Left + (DuplicateGeneratedTypedTptpName + target) + else + Right + (Map.insert + target + nameOrigin + origins) + +renderProblem + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + (TextBuilder, TextBuilder) +renderProblem names problem = do + hypotheses <- + renderHypotheses names problem + conjecture <- + renderConjecture names problem + declarations <- + case typedProblemRoute problem of + RouteFof -> + pure [] + RouteTh0 -> + renderTh0Declarations + names + problem + let formulaBuilders = + renderFormulaLine + (typedProblemRoute problem) + "axiom" + <$> hypotheses + conjectureBuilder = + renderFormulaLine + (typedProblemRoute problem) + "conjecture" + conjecture + complete = + intercalate + (char '\n') + (declarations + <> formulaBuilders + <> [conjectureBuilder]) + pure + ( complete + , conjectureBuilder + ) + +renderHypotheses + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + [RenderedFormula ref] +renderHypotheses names problem = do + globalFormulas <- + traverse + (\fact -> + renderOccurrence + names + problem + (TypedGlobalPremiseOccurrence + (typedBackendFactReference + fact)) + (weakenClosedSupportedProposition + (typedBackendFactProposition + fact))) + (Vector.toList + (typedProblemGlobalPremises + problem)) + localFormulas <- + traverse + (\premise -> + renderOccurrence + names + problem + (TypedLocalPremiseOccurrence + (typedLocalPremiseOrdinal + premise)) + (typedLocalPremiseProposition + premise)) + (Vector.toList + (typedProblemLocalPremises + problem)) + auxiliaryFormulas <- + traverse + (\auxiliary -> + renderOccurrence + names + problem + (TypedAuxiliaryOccurrence + (typedProblemAuxiliaryOrdinal + auxiliary)) + (weakenClosedSupportedProposition + (typedProblemAuxiliaryProposition + auxiliary))) + (Vector.toList + (typedProblemAuxiliaries + problem)) + pure + (globalFormulas + <> localFormulas + <> auxiliaryFormulas) + +renderConjecture + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + (RenderedFormula ref) +renderConjecture names problem = + renderOccurrence + names + problem + TypedConjectureOccurrence + (typedProblemClaim problem) + +renderOccurrence + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> TypedFormulaOccurrence ref + -> SupportedProposition local global + -> Render + ref + local + global + (RenderedFormula ref) +renderOccurrence names problem occurrence proposition = do + target <- + case occurrence of + TypedConjectureOccurrence -> + liftEither + (generatedAtomicWord "tg_q0") + _ -> do + ordinal <- + nextHypothesisOrdinal + liftEither + (generatedAtomicWord + ("tg_h" + <> Text.pack + (show ordinal))) + registerOrigin + (Tptp.atomicWordText target) + (TypedFormulaNameOrigin occurrence) + bounds <- + initialBounds + names + proposition + formula <- + case typedProblemRoute problem of + RouteFof -> + renderFofFormula + names + bounds + (supportedPropositionTerm + proposition) + RouteTh0 -> + renderTh0Term + names + bounds + (supportedPropositionTerm + proposition) + pure + (RenderedFormula + target + occurrence + formula) + +-- Formula and binder ordinals use separate dense namespaces. +nextHypothesisOrdinal + :: Render ref local global Natural +nextHypothesisOrdinal = do + RenderState nextBinder nextHypothesis origins <- + State.get + State.put + (RenderState + nextBinder + (nextHypothesis + 1) + origins) + pure nextHypothesis + +registerOrigin + :: Text + -> TypedTptpNameOrigin ref local global + -> Render ref local global () +registerOrigin target nameOrigin = do + RenderState nextBinder nextHypothesis origins <- + State.get + origins' <- + liftEither + (insertOrigin + target + nameOrigin + origins) + State.put + (RenderState + nextBinder + nextHypothesis + origins') + +freshBinder + :: Render ref local global Tptp.Variable +freshBinder = do + RenderState nextBinder nextHypothesis origins <- + State.get + let target = + "V" <> Text.pack (show nextBinder) + variable <- + liftEither + (generatedVariable target) + origins' <- + liftEither + (insertOrigin + target + (TypedBinderNameOrigin + nextBinder) + origins) + State.put + (RenderState + (nextBinder + 1) + nextHypothesis + origins') + pure variable + +liftEither + :: Either + (TypedTptpPreparationError local global) + value + -> Render ref local global value +liftEither = + lift + +initialBounds + :: Ord local + => NameEnvironment ref local global + -> SupportedProposition local global + -> Render ref local global [BoundTarget] +initialBounds + (NameEnvironment + _globals + _globalTypes + localNames + _intrinsics + _integers + _origins) + proposition = + traverse + (\(local, _coreType) -> + maybe + (lift + (Left + (TypedTptpUnknownLocal + local))) + (pure . AmbientConstant) + (Map.lookup + local + localNames)) + (Vector.toList + (supportedPropositionSupport + proposition)) + +renderFormulaLine + :: TypedProblemRoute + -> TextBuilder + -> RenderedFormula ref + -> TextBuilder +renderFormulaLine route role + (RenderedFormula target _occurrence formula) = + dialect + <> char '(' + <> Tptp.buildAtomicWord target + <> char ',' + <> role + <> char ',' + <> formula + <> text ")." + where + dialect = + case route of + RouteFof -> + text "fof" + RouteTh0 -> + text "thf" + + +renderFofFormula + :: (Ord global) + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofFormula names bounds = \case + CFalsum -> + pure (text "$false") + CImp premise conclusion -> do + premise' <- + renderFofFormula names bounds premise + conclusion' <- + renderFofFormula names bounds conclusion + pure + (parenthesize + (premise' + <> text "=>" + <> conclusion')) + CEq TySet left right -> do + left' <- + renderFofTerm names bounds left + right' <- + renderFofTerm names bounds right + pure + (parenthesize + (left' + <> char '=' + <> right')) + CEq TyProp left right -> do + left' <- + renderFofFormula names bounds left + right' <- + renderFofFormula names bounds right + pure + (parenthesize + (left' + <> text "<=>" + <> right')) + CForall TySet body -> do + variable <- + freshBinder + body' <- + renderFofFormula + names + (BoundFofVariable variable + : bounds) + body + pure + (parenthesize + (text "![" + <> Tptp.buildVariable variable + <> text "]:" + <> body')) + application -> + renderFofApplication + names + bounds + TyProp + application + +renderFofTerm + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofTerm names bounds = \case + CBound index -> + renderBound index bounds + CGlobal global -> + Tptp.buildAtomicWord + <$> lookupGlobal names global + CIntrinsic intrinsic -> + Tptp.buildAtomicWord + <$> lookupIntrinsic names intrinsic + COpaqueInteger integer -> + Tptp.buildAtomicWord + <$> lookupInteger names integer + application -> + renderFofApplication + names + bounds + TySet + application + +renderFofApplication + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CoreType + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofApplication names bounds expected application = + case applicationHead application of + (CGlobal global, arguments) -> do + coreType <- + maybe + (lift + (Left + (TypedTptpUnknownGlobal + global))) + pure + (Map.lookup + global + (nameEnvironmentGlobalTypes + names)) + renderHead + coreType + (lookupGlobal names global) + arguments + (CIntrinsic intrinsic, arguments) -> + renderHead + (coreIntrinsicType intrinsic) + (lookupIntrinsic names intrinsic) + arguments + _ -> + lift + (Left + TypedTptpFofProjectionMismatch) + where + renderHead coreType targetAction arguments = do + unlessFofApplication + expected + coreType + arguments + target <- + targetAction + arguments' <- + traverse + (renderFofTerm names bounds) + arguments + pure + (applyAtomicWord + target + arguments') + +-- Global types are retained in the problem, but names need only the allocated +-- symbols. FOF saturation was already checked by the projection witness. +nameEnvironmentGlobalTypes + :: NameEnvironment ref local global + -> Map global CoreType +nameEnvironmentGlobalTypes + (NameEnvironment + _globals + globalTypes + _locals + _intrinsics + _integers + _origins) = + globalTypes + +unlessFofApplication + :: CoreType + -> CoreType + -> [CanonicalTerm global] + -> Render ref local global () +unlessFofApplication expected coreType arguments = + case consume coreType arguments of + Just result + | result == expected -> + pure () + _ -> + lift + (Left + TypedTptpFofProjectionMismatch) + where + consume current = \case + [] -> + Just current + _argument : remaining -> + case current of + TyArrow TySet result -> + consume result remaining + _ -> + Nothing + +applyAtomicWord + :: Tptp.AtomicWord + -> [TextBuilder] + -> TextBuilder +applyAtomicWord target = \case + [] -> + Tptp.buildAtomicWord target + arguments -> + Tptp.buildAtomicWord target + <> Tptp.buildTuple arguments + +renderBound + :: Natural + -> [BoundTarget] + -> Render ref local global TextBuilder +renderBound index bounds = + case contextAt index bounds of + Nothing -> + lift + (Left + (TypedTptpUnboundIndex + index)) + Just (BoundFofVariable variable) -> + pure + (Tptp.buildVariable + variable) + Just (BoundTh0Variable variable) -> + pure + (Tptp.buildVariable + variable) + Just (AmbientConstant target) -> + pure + (Tptp.buildAtomicWord + target) + + +renderTh0Term + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderTh0Term names bounds = \case + CBound index -> + renderBound index bounds + CGlobal global -> + Tptp.buildAtomicWord + <$> lookupGlobal names global + CIntrinsic intrinsic -> + Tptp.buildAtomicWord + <$> lookupIntrinsic names intrinsic + COpaqueInteger integer -> + Tptp.buildAtomicWord + <$> lookupInteger names integer + CApp function argument -> do + function' <- + renderTh0Term names bounds function + argument' <- + renderTh0Term names bounds argument + pure + (parenthesize + (function' + <> char '@' + <> argument')) + CLam binderType body -> do + variable <- + freshBinder + body' <- + renderTh0Term + names + (BoundTh0Variable variable + : bounds) + body + pure + (parenthesize + (text "^ [" + <> Tptp.buildVariable variable + <> char ':' + <> renderCoreType binderType + <> text "] : " + <> body')) + CFalsum -> + pure (text "$false") + CImp premise conclusion -> do + premise' <- + renderTh0Term names bounds premise + conclusion' <- + renderTh0Term names bounds conclusion + pure + (parenthesize + (premise' + <> text "=>" + <> conclusion')) + CEq operandType left right -> do + left' <- + renderTh0Term names bounds left + right' <- + renderTh0Term names bounds right + pure + (parenthesize + (left' + <> (case operandType of + TyProp -> text "<=>" + _ -> char '=') + <> right')) + CForall binderType body -> do + variable <- + freshBinder + body' <- + renderTh0Term + names + (BoundTh0Variable variable + : bounds) + body + pure + (parenthesize + (text "! [" + <> Tptp.buildVariable variable + <> char ':' + <> renderCoreType binderType + <> text "] : " + <> body')) + +renderTh0Declarations + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render ref local global [TextBuilder] +renderTh0Declarations names problem = do + globalDeclarations <- + traverse + (\(ordinal, (global, coreType)) -> do + target <- + lookupGlobal names global + label <- + liftEither + (generatedAtomicWord + ("tg_g_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType coreType))) + (zip [0 :: Int ..] + (Map.toAscList + (typedProblemGlobalTypes + problem))) + localDeclarations <- + traverse + (\(ordinal, (local, coreType)) -> do + target <- + lookupLocal names local + label <- + liftEither + (generatedAtomicWord + ("tg_l_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType coreType))) + (zip [0 :: Int ..] + (Map.toAscList + (typedProblemLocalTypes + problem))) + intrinsicDeclarations <- + traverse + (\(ordinal, intrinsic) -> do + target <- + lookupIntrinsic names intrinsic + label <- + liftEither + (generatedAtomicWord + ("tg_i_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType + (coreIntrinsicType + intrinsic)))) + (zip [0 :: Int ..] + (Set.toAscList + (problemIntrinsics problem))) + integerDeclarations <- + traverse + (\(ordinal, integer) -> do + target <- + lookupInteger names integer + label <- + liftEither + (generatedAtomicWord + ("tg_n_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType TySet))) + (zip [0 :: Int ..] + (Set.toAscList + (problemIntegers problem))) + pure + (globalDeclarations + <> localDeclarations + <> intrinsicDeclarations + <> integerDeclarations) + +typeDeclaration + :: Tptp.AtomicWord + -> Tptp.AtomicWord + -> TextBuilder + -> TextBuilder +typeDeclaration label target coreType = + text "thf(" + <> Tptp.buildAtomicWord label + <> text ",type,(" + <> Tptp.buildAtomicWord target + <> char ':' + <> coreType + <> text "))." + +renderCoreType :: CoreType -> TextBuilder +renderCoreType = \case + TyProp -> + text "$o" + TySet -> + text "$i" + TyArrow argument result -> + parenthesize + (renderCoreType argument + <> char '>' + <> renderCoreType result) + +parenthesize :: TextBuilder -> TextBuilder +parenthesize builder = + char '(' <> builder <> char ')' + + +lookupGlobal + :: Ord global + => NameEnvironment ref local global + -> global + -> Render ref local global Tptp.AtomicWord +lookupGlobal names global = + maybe + (lift + (Left + (TypedTptpUnknownGlobal + global))) + pure + (lookupGlobalPure names global) + +lookupGlobalPure + :: Ord global + => NameEnvironment ref local global + -> global + -> Maybe Tptp.AtomicWord +lookupGlobalPure + (NameEnvironment + globals + _globalTypes + _locals + _intrinsics + _integers + _origins) = + (`Map.lookup` globals) + +lookupLocalPure + :: Ord local + => NameEnvironment ref local global + -> local + -> Maybe Tptp.AtomicWord +lookupLocalPure + (NameEnvironment + _globals + _globalTypes + locals + _intrinsics + _integers + _origins) = + (`Map.lookup` locals) + +lookupLocal + :: Ord local + => NameEnvironment ref local global + -> local + -> Render ref local global Tptp.AtomicWord +lookupLocal names local = + maybe + (lift + (Left + (TypedTptpUnknownLocal + local))) + pure + (lookupLocalPure names local) + +lookupIntrinsic + :: NameEnvironment ref local global + -> CoreIntrinsicTag + -> Render ref local global Tptp.AtomicWord +lookupIntrinsic names intrinsic = + maybe + (lift + (Left + TypedTptpFofProjectionMismatch)) + pure + (lookupIntrinsicPure names intrinsic) + +lookupIntrinsicPure + :: NameEnvironment ref local global + -> CoreIntrinsicTag + -> Maybe Tptp.AtomicWord +lookupIntrinsicPure + (NameEnvironment + _globals + _globalTypes + _locals + intrinsics + _integers + _origins) = + (`Map.lookup` intrinsics) + +lookupInteger + :: NameEnvironment ref local global + -> Integer + -> Render ref local global Tptp.AtomicWord +lookupInteger names integer = + maybe + (lift + (Left + TypedTptpFofProjectionMismatch)) + pure + (lookupIntegerPure names integer) + +lookupIntegerPure + :: NameEnvironment ref local global + -> Integer + -> Maybe Tptp.AtomicWord +lookupIntegerPure + (NameEnvironment + _globals + _globalTypes + _locals + _intrinsics + integers + _origins) = + (`Map.lookup` integers) + +problemIntrinsics + :: TypedProblem ref local origin global + -> Set CoreIntrinsicTag +problemIntrinsics = + foldMap canonicalIntrinsics + . problemTerms + +problemIntegers + :: TypedProblem ref local origin global + -> Set Integer +problemIntegers = + foldMap canonicalIntegers + . problemTerms + +problemTerms + :: TypedProblem ref local origin global + -> [CanonicalTerm global] +problemTerms problem = + supportedPropositionTerm + (typedProblemClaim problem) + : (supportedPropositionTerm + . typedBackendFactProposition + <$> Vector.toList + (typedProblemGlobalPremises + problem)) + <> (supportedPropositionTerm + . typedLocalPremiseProposition + <$> Vector.toList + (typedProblemLocalPremises + problem)) + <> (supportedPropositionTerm + . typedProblemAuxiliaryProposition + <$> Vector.toList + (typedProblemAuxiliaries + problem)) + +canonicalIntrinsics + :: CanonicalTerm global + -> Set CoreIntrinsicTag +canonicalIntrinsics = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic -> + Set.singleton intrinsic + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalIntrinsics function + <> canonicalIntrinsics argument + CLam _binderType body -> + canonicalIntrinsics body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalIntrinsics premise + <> canonicalIntrinsics conclusion + CEq _operandType left right -> + canonicalIntrinsics left + <> canonicalIntrinsics right + CForall _binderType body -> + canonicalIntrinsics body + +canonicalIntegers + :: CanonicalTerm global + -> Set Integer +canonicalIntegers = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic{} -> + mempty + COpaqueInteger integer -> + Set.singleton integer + CApp function argument -> + canonicalIntegers function + <> canonicalIntegers argument + CLam _binderType body -> + canonicalIntegers body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalIntegers premise + <> canonicalIntegers conclusion + CEq _operandType left right -> + canonicalIntegers left + <> canonicalIntegers right + CForall _binderType body -> + canonicalIntegers body + +applicationHead + :: CanonicalTerm global + -> (CanonicalTerm global, [CanonicalTerm global]) +applicationHead = + go [] + where + go arguments = \case + CApp function argument -> + go (argument : arguments) function + headTerm -> + (headTerm, arguments) + +contextAt :: Natural -> [value] -> Maybe value +contextAt _index [] = + Nothing +contextAt 0 (value : _remaining) = + Just value +contextAt index (_value : remaining) = + contextAt (index - 1) remaining diff --git a/source/Felix/Checking/Core.hs b/source/Felix/Checking/Core.hs new file mode 100644 index 0000000..13ec218 --- /dev/null +++ b/source/Felix/Checking/Core.hs @@ -0,0 +1,1604 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked monomorphic HOL syntax and its nameless in-memory form. +-- +-- Scoped syntax is an operational construction language. Only a checked, +-- frozen value is semantic input to later kernel and backend boundaries. +module Felix.Checking.Core + ( CoreType(..) + , CoreIntrinsicTag(..) + , coreIntrinsicType + , CoreSyntax + , coreLocal + , coreGlobal + , coreIntrinsic + , coreOpaqueInteger + , coreApply + , coreLambda + , coreFalsum + , coreImplication + , coreEquality + , coreForall + , CheckedCore + , checkedCoreType + , checkCore + , checkClosedCore + , ClosedCheckedProposition + , checkedPropositionCore + , checkClosedProposition + , CoreCheckError(..) + , CanonicalTerm(..) + , canonicalSetInsert + , FrozenCheckedCore + , frozenCoreType + , frozenCoreTerm + , thawFrozenCore + , frozenCoreGlobals + , mapFrozenGlobals + , ScopedCheckedCore + , scopedCoreContext + , scopedCoreType + , scopedCoreTerm + , mapScopedGlobals + , checkScopedCanonicalCore + , embedClosedCore + , weakenCheckedScopedCore + , weakenScopedCore + , scopedSetDefinition + , scopedCharacteristicDefinition + , scopedReplacementGraph + , implyScopedCore + , equalScopedCore + , conjoinScopedCore + , disjoinScopedCore + , negateScopedCore + , falsumScopedCore + , splitScopedSetEquality + , scopedSetInductionInstance + , closeScopedForall + , closeScopedExists + , openScopedForall + , openScopedImplication + , openScopedAssumption + , closeScopedCore + , betaNormalizeCanonical + , instantiateCanonical + , shiftCanonical + , mapCanonicalGlobals + , canonicalTermGlobals + , checkCanonicalCore + , freezeClosed + , FreezeError(..) + , referenceFreezeClosed + ) where + +import Base hiding (Empty) + +import Bound +import Control.DeepSeq (NFData) +import Control.Monad (ap, unless) +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The complete monomorphic type grammar of the checked core. +data CoreType + = TyProp + | TySet + | TyArrow !CoreType !CoreType + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + + +-- | The complete set-forming primitive inventory. +data CoreIntrinsicTag + = Member + | Empty + | PairSet + | FamilyUnion + | PowerSet + | Sep + | Repl + | SetChoose + | UnivOf + -- | The bounded set-valued least fixed point. It denotes the elements of + -- its bound that belong to every bounded pre-fixed point of its operator. + | ISetLfp + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +coreIntrinsicType :: CoreIntrinsicTag -> CoreType +coreIntrinsicType = \case + Member -> + TySet `TyArrow` (TySet `TyArrow` TyProp) + Empty -> + TySet + PairSet -> + TySet `TyArrow` (TySet `TyArrow` TySet) + FamilyUnion -> + TySet `TyArrow` TySet + PowerSet -> + TySet `TyArrow` TySet + Sep -> + TySet + `TyArrow` + ((TySet `TyArrow` TyProp) `TyArrow` TySet) + Repl -> + TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + SetChoose -> + (TySet `TyArrow` TyProp) `TyArrow` TySet + UnivOf -> + TySet `TyArrow` TySet + ISetLfp -> + TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + + +-- | Operational scoped syntax. Its constructors remain private because this +-- value is neither a typing certificate nor an authority-bearing term. +data CoreSyntax global local + = CoreLocal local + | CoreGlobal global + | CoreIntrinsic CoreIntrinsicTag + | CoreOpaqueInteger !Integer + | CoreApply + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreLambda + !CoreType + !(Scope () (CoreSyntax global) local) + | CoreFalsum + | CoreImplication + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreEquality + !CoreType + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreForall + !CoreType + !(Scope () (CoreSyntax global) local) + deriving stock (Functor, Foldable, Traversable) + +instance Applicative (CoreSyntax global) where + pure = CoreLocal + (<*>) = ap + +instance Monad (CoreSyntax global) where + CoreLocal local >>= replace = + replace local + CoreGlobal global >>= _replace = + CoreGlobal global + CoreIntrinsic intrinsic >>= _replace = + CoreIntrinsic intrinsic + CoreOpaqueInteger integer >>= _replace = + CoreOpaqueInteger integer + CoreApply function argument >>= replace = + CoreApply + (function >>= replace) + (argument >>= replace) + CoreLambda binderType body >>= replace = + CoreLambda binderType (body >>>= replace) + CoreFalsum >>= _replace = + CoreFalsum + CoreImplication premise conclusion >>= replace = + CoreImplication + (premise >>= replace) + (conclusion >>= replace) + CoreEquality operandType left right >>= replace = + CoreEquality + operandType + (left >>= replace) + (right >>= replace) + CoreForall binderType body >>= replace = + CoreForall binderType (body >>>= replace) + +coreLocal :: local -> CoreSyntax global local +coreLocal = CoreLocal + +coreGlobal :: global -> CoreSyntax global local +coreGlobal = CoreGlobal + +coreIntrinsic :: CoreIntrinsicTag -> CoreSyntax global local +coreIntrinsic = CoreIntrinsic + +coreOpaqueInteger :: Integer -> CoreSyntax global local +coreOpaqueInteger = CoreOpaqueInteger + +coreApply + :: CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreApply = CoreApply + +coreLambda + :: Eq local + => CoreType + -> local + -> CoreSyntax global local + -> CoreSyntax global local +coreLambda binderType local body = + CoreLambda binderType (abstract1 local body) + +coreFalsum :: CoreSyntax global local +coreFalsum = CoreFalsum + +coreImplication + :: CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreImplication = CoreImplication + +coreEquality + :: CoreType + -> CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreEquality = CoreEquality + +coreForall + :: Eq local + => CoreType + -> local + -> CoreSyntax global local + -> CoreSyntax global local +coreForall binderType local body = + CoreForall binderType (abstract1 local body) + + +data CoreCheckError + = UnknownCoreGlobal + | UnboundCoreLocal + | UnboundCoreIndex !Natural + | AppliedNonFunction !CoreType + | ApplicationArgumentTypeMismatch + !CoreType + !CoreType + | ImplicationOperandTypeMismatch + !CoreType + | EqualityOperandTypeMismatch + !CoreType + !CoreType + | QuantifierBodyTypeMismatch + !CoreType + | ExpectedCoreType + !CoreType + !CoreType + deriving stock (Show, Eq) + + +-- | A scoped term whose complete tree has been type checked. +data CheckedCore global local = CheckedCore + !CoreType + !(CoreSyntax global local) + +checkedCoreType :: CheckedCore global local -> CoreType +checkedCoreType (CheckedCore coreType _syntax) = + coreType + +checkCore + :: (global -> Maybe CoreType) + -> (local -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (CheckedCore global local) +checkCore globalType localType syntax = do + coreType <- + inferCore globalType localType syntax + pure (CheckedCore coreType syntax) + +checkClosedCore + :: (global -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (CheckedCore global Void) +checkClosedCore globalType syntax = do + closedSyntax <- + maybe + (Left UnboundCoreLocal) + Right + (traverse (const Nothing) syntax) + checkCore globalType absurd closedSyntax + +newtype ClosedCheckedProposition global = + ClosedCheckedProposition (CheckedCore global Void) + +checkedPropositionCore + :: ClosedCheckedProposition global + -> CheckedCore global Void +checkedPropositionCore + (ClosedCheckedProposition proposition) = + proposition + +checkClosedProposition + :: (global -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (ClosedCheckedProposition global) +checkClosedProposition globalType syntax = do + checked <- + checkClosedCore globalType syntax + unless + (checkedCoreType checked == TyProp) + (Left + (ExpectedCoreType + TyProp + (checkedCoreType checked))) + pure (ClosedCheckedProposition checked) + +inferCore + :: forall global local + . (global -> Maybe CoreType) + -> (local -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError CoreType +inferCore globalType localType = + infer + (maybe + (Left UnboundCoreLocal) + Right + . localType) + where + infer + :: forall local' + . (local' -> Either CoreCheckError CoreType) + -> CoreSyntax global local' + -> Either CoreCheckError CoreType + infer resolveLocal = \case + CoreLocal local -> + resolveLocal local + CoreGlobal global -> + maybe + (Left UnknownCoreGlobal) + Right + (globalType global) + CoreIntrinsic intrinsic -> + Right (coreIntrinsicType intrinsic) + CoreOpaqueInteger{} -> + Right TySet + CoreApply function argument -> do + functionType <- + infer resolveLocal function + argumentType <- + infer resolveLocal argument + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + Right resultType + | otherwise -> + Left + (ApplicationArgumentTypeMismatch + expectedArgument + argumentType) + other -> + Left (AppliedNonFunction other) + CoreLambda binderType body -> do + bodyType <- + infer + (boundLocalType binderType resolveLocal) + (unscope body) + Right (binderType `TyArrow` bodyType) + CoreFalsum -> + Right TyProp + CoreImplication premise conclusion -> do + premiseType <- + infer resolveLocal premise + unless + (premiseType == TyProp) + (Left + (ImplicationOperandTypeMismatch + premiseType)) + conclusionType <- + infer resolveLocal conclusion + unless + (conclusionType == TyProp) + (Left + (ImplicationOperandTypeMismatch + conclusionType)) + Right TyProp + CoreEquality operandType left right -> do + leftType <- + infer resolveLocal left + unless + (leftType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + leftType)) + rightType <- + infer resolveLocal right + unless + (rightType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + rightType)) + Right TyProp + CoreForall binderType body -> do + bodyType <- + infer + (boundLocalType binderType resolveLocal) + (unscope body) + unless + (bodyType == TyProp) + (Left + (QuantifierBodyTypeMismatch bodyType)) + Right TyProp + + boundLocalType + :: forall local' + . CoreType + -> (local' -> Either CoreCheckError CoreType) + -> Var () (CoreSyntax global local') + -> Either CoreCheckError CoreType + boundLocalType binderType outerType = \case + B () -> + Right binderType + F outerSyntax -> + infer outerType outerSyntax + + +-- | Felix-owned explicit-index syntax. Index zero denotes the nearest +-- enclosing binder. +data CanonicalTerm global + = CBound !Natural + | CGlobal !global + | CIntrinsic !CoreIntrinsicTag + | COpaqueInteger !Integer + | CApp + !(CanonicalTerm global) + !(CanonicalTerm global) + | CLam + !CoreType + !(CanonicalTerm global) + | CFalsum + | CImp + !(CanonicalTerm global) + !(CanonicalTerm global) + | CEq + !CoreType + !(CanonicalTerm global) + !(CanonicalTerm global) + | CForall + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | The fixed checked-core interpretation of set insertion. +-- +-- Finite-set notation uses this intrinsic HOTG adjunction directly. The +-- ordinary source-owned @cons@ function is not consulted during lowering. +canonicalSetInsert + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +canonicalSetInsert element set = + CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp + (CIntrinsic PairSet) + (CApp + (CApp + (CIntrinsic PairSet) + element) + element)) + set) + +data FrozenCheckedCore global = FrozenCheckedCore + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +frozenCoreType :: FrozenCheckedCore global -> CoreType +frozenCoreType (FrozenCheckedCore coreType _term) = + coreType + +frozenCoreTerm :: FrozenCheckedCore global -> CanonicalTerm global +frozenCoreTerm (FrozenCheckedCore _coreType term) = + term + +mapFrozenGlobals + :: (global -> global') + -> FrozenCheckedCore global + -> FrozenCheckedCore global' +mapFrozenGlobals transform + (FrozenCheckedCore coreType term) = + FrozenCheckedCore + coreType + (mapCanonicalGlobals transform term) + +-- | Recover an operational closed term from a checked frozen value. Any caller +-- that extends or substitutes it must check the resulting term again. +thawFrozenCore + :: FrozenCheckedCore global + -> CoreSyntax global Void +thawFrozenCore (FrozenCheckedCore _coreType term) = + case traverse (const Nothing) (go [] term) of + Just closedSyntax -> + closedSyntax + Nothing -> + impossible + "a frozen core term became open while being thawed" + where + go + :: [Natural] + -> CanonicalTerm global + -> CoreSyntax global Natural + go binders = \case + CBound index -> + case lookupBinder index binders of + Just local -> + coreLocal local + Nothing -> + impossible + "a frozen core term contains an unbound index" + CGlobal global -> + coreGlobal global + CIntrinsic intrinsic -> + coreIntrinsic intrinsic + COpaqueInteger integer -> + coreOpaqueInteger integer + CApp function argument -> + coreApply + (go binders function) + (go binders argument) + CLam binderType body -> + let local = + fromIntegral (length binders) + in coreLambda + binderType + local + (go (local : binders) body) + CFalsum -> + coreFalsum + CImp premise conclusion -> + coreImplication + (go binders premise) + (go binders conclusion) + CEq operandType left right -> + coreEquality + operandType + (go binders left) + (go binders right) + CForall binderType body -> + let local = + fromIntegral (length binders) + in coreForall + binderType + local + (go (local : binders) body) + + lookupBinder + :: Natural + -> [Natural] + -> Maybe Natural + lookupBinder _index [] = + Nothing + lookupBinder 0 (local : _rest) = + Just local + lookupBinder index (_local : rest) = + lookupBinder (index - 1) rest + +frozenCoreGlobals + :: Ord global + => FrozenCheckedCore global + -> Set.Set global +frozenCoreGlobals = + canonicalTermGlobals . frozenCoreTerm + +canonicalTermGlobals + :: Ord global + => CanonicalTerm global + -> Set.Set global +canonicalTermGlobals = \case + CBound{} -> + mempty + CGlobal global -> + Set.singleton global + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalTermGlobals function + <> canonicalTermGlobals argument + CLam _binderType body -> + canonicalTermGlobals body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalTermGlobals premise + <> canonicalTermGlobals conclusion + CEq _operandType left right -> + canonicalTermGlobals left + <> canonicalTermGlobals right + CForall _binderType body -> + canonicalTermGlobals body + +-- | A checked canonical term relative to the listed nearest-first binders. +-- This is the construction boundary used by kernel replay; it carries no fact +-- authority. +data ScopedCheckedCore global = ScopedCheckedCore + ![CoreType] + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +scopedCoreContext + :: ScopedCheckedCore global + -> [CoreType] +scopedCoreContext + (ScopedCheckedCore context _coreType _term) = + context + +scopedCoreType + :: ScopedCheckedCore global + -> CoreType +scopedCoreType + (ScopedCheckedCore _context coreType _term) = + coreType + +scopedCoreTerm + :: ScopedCheckedCore global + -> CanonicalTerm global +scopedCoreTerm + (ScopedCheckedCore _context _coreType term) = + term + +mapScopedGlobals + :: (left -> right) + -> ScopedCheckedCore left + -> ScopedCheckedCore right +mapScopedGlobals transform + (ScopedCheckedCore context coreType term) = + ScopedCheckedCore + context + coreType + (mapCanonicalGlobals transform term) + +checkScopedCanonicalCore + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either CoreCheckError (ScopedCheckedCore global) +checkScopedCanonicalCore globalType context term = + ScopedCheckedCore context + <$> inferCanonicalCore globalType context term + <*> pure term + +-- | Regard a closed term under a larger lexical context. Closed canonical +-- terms contain no indices, so this does not shift the term. +embedClosedCore + :: [CoreType] + -> FrozenCheckedCore global + -> ScopedCheckedCore global +embedClosedCore context + (FrozenCheckedCore coreType term) = + ScopedCheckedCore context coreType term + +-- | Add one nearest binder to an already checked lexical context. +weakenCheckedScopedCore + :: CoreType + -> ScopedCheckedCore global + -> ScopedCheckedCore global +weakenCheckedScopedCore binderType scoped = + ScopedCheckedCore + (binderType : scopedCoreContext scoped) + (scopedCoreType scoped) + (shiftCanonical 1 0 (scopedCoreTerm scoped)) + +-- | Add one nearest binder to a checked lexical context. +weakenScopedCore + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either CoreCheckError (ScopedCheckedCore global) +weakenScopedCore globalType binderType scoped = + checkScopedCanonicalCore + globalType + (binderType : scopedCoreContext scoped) + (shiftCanonical 1 0 + (scopedCoreTerm scoped)) + +-- | Introduce a fresh set-valued local definition. Separation specializes +-- the checked foundation characteristic so its local premise remains +-- first-order. +scopedSetDefinition + :: Eq global + => FrozenCheckedCore Void + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +scopedSetDefinition + characteristic + expression@(ScopedCheckedCore context TySet term) = + case term of + CApp + (CApp (CIntrinsic Sep) bound) + predicate@(CLam TySet _body) -> + scopedCharacteristicDefinition + characteristic + expression + ( ScopedCheckedCore context TySet bound + :| [ ScopedCheckedCore + context + (TySet `TyArrow` TyProp) + predicate + ] + ) + _ -> + Just + (ScopedCheckedCore + (TySet : context) + TyProp + (CEq + TySet + (CBound 0) + (shiftCanonical 1 0 term))) +scopedSetDefinition _characteristic _expression = + Nothing + +-- | Specialize a checked characteristic and abstract its set-valued target +-- into one fresh nearest binder. Checked substitution and beta reduction +-- preserve the foundation row's proposition type. +scopedCharacteristicDefinition + :: Eq global + => FrozenCheckedCore Void + -> ScopedCheckedCore global + -> NonEmpty (ScopedCheckedCore global) + -> Maybe (ScopedCheckedCore global) +scopedCharacteristicDefinition + (FrozenCheckedCore TyProp frozen) + (ScopedCheckedCore context TySet target) + arguments + | all ((== context) . scopedCoreContext) arguments = do + specialized <- + specialize + (mapCanonicalGlobals absurd frozen) + (toList arguments) + let normalized = betaNormalizeCanonical specialized + (found, abstracted) = abstractTarget 0 normalized + guard found + pure + (ScopedCheckedCore + (TySet : context) + TyProp + abstracted) + where + specialize term [] = + Just term + specialize (CForall binderType body) + (ScopedCheckedCore _ argumentType argument : rest) + | binderType == argumentType = + specialize + (instantiateCanonical argument body) + rest + specialize _term _arguments = + Nothing + + abstractTarget depth term + | term == shiftCanonical depth 0 target = + (True, CBound (fromIntegral depth)) + | otherwise = + case term of + CBound index + | index < fromIntegral depth -> + (False, CBound index) + | otherwise -> + (False, CBound (index + 1)) + CGlobal global -> + (False, CGlobal global) + CIntrinsic intrinsic -> + (False, CIntrinsic intrinsic) + COpaqueInteger integer -> + (False, COpaqueInteger integer) + CApp function argument -> + combine CApp + (abstractTarget depth function) + (abstractTarget depth argument) + CLam binderType body -> + let (found, abstracted) = + abstractTarget (depth + 1) body + in (found, CLam binderType abstracted) + CFalsum -> + (False, CFalsum) + CImp premise conclusion -> + combine CImp + (abstractTarget depth premise) + (abstractTarget depth conclusion) + CEq operandType left right -> + combine (CEq operandType) + (abstractTarget depth left) + (abstractTarget depth right) + CForall binderType body -> + let (found, abstracted) = + abstractTarget (depth + 1) body + in (found, CForall binderType abstracted) + + combine constructor (leftFound, left) (rightFound, right) = + (leftFound || rightFound, constructor left right) +scopedCharacteristicDefinition _characteristic _target _arguments = + Nothing + +-- | Build the replacement graph of one checked set-valued local function. +-- The ordered-pair constructor is an ordinary checked source object. +scopedReplacementGraph + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + ) +scopedReplacementGraph + (ScopedCheckedCore context pairType pair) + domain@(ScopedCheckedCore domainContext TySet domainTerm) + (ScopedCheckedCore valueContext TySet value) + | pairType == TySet `TyArrow` (TySet `TyArrow` TySet) + , domainContext == context + , valueContext == TySet : context = + let pairValue = + CApp + (CApp + (shiftCanonical 1 0 pair) + (CBound 0)) + value + function = CLam TySet pairValue + graph = + CApp + (CApp (CIntrinsic Repl) domainTerm) + function + in Just + ( ScopedCheckedCore context TySet graph + , domain + , ScopedCheckedCore + context + (TySet `TyArrow` TySet) + function + ) +scopedReplacementGraph _pair _domain _value = + Nothing + +betaNormalizeCanonical + :: CanonicalTerm global + -> CanonicalTerm global +betaNormalizeCanonical = \case + CApp function argument -> + case betaNormalizeCanonical function of + CLam _binderType body -> + betaNormalizeCanonical + (instantiateCanonical + (betaNormalizeCanonical argument) + body) + normalizedFunction -> + CApp + normalizedFunction + (betaNormalizeCanonical argument) + CLam binderType body -> + CLam binderType (betaNormalizeCanonical body) + CImp premise conclusion -> + CImp + (betaNormalizeCanonical premise) + (betaNormalizeCanonical conclusion) + CEq operandType left right -> + CEq operandType + (betaNormalizeCanonical left) + (betaNormalizeCanonical right) + CForall binderType body -> + CForall binderType (betaNormalizeCanonical body) + term -> term + +-- | Combine two checked propositions under the same lexical context. +implyScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +implyScopedCore + (ScopedCheckedCore premiseContext TyProp premise) + (ScopedCheckedCore conclusionContext TyProp conclusion) + | premiseContext == conclusionContext = + Just + (ScopedCheckedCore + premiseContext + TyProp + (CImp premise conclusion)) +implyScopedCore _premise _conclusion = + Nothing + +-- | Form an equality between checked operands under the same lexical +-- context. This preserves the checked-core invariant without requiring a +-- caller to recover global types merely to combine already checked terms. +equalScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +equalScopedCore + (ScopedCheckedCore leftContext leftType left) + (ScopedCheckedCore rightContext rightType right) + | leftContext == rightContext + , leftType == rightType = + Just + (ScopedCheckedCore + leftContext + TyProp + (CEq leftType left right)) +equalScopedCore _left _right = + Nothing + +-- | Conjoin two checked propositions under the same lexical context. Truth +-- is normalized away so callers can build an optional source guard without +-- retaining an inert conjunct. +conjoinScopedCore + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +conjoinScopedCore + left@(ScopedCheckedCore leftContext TyProp leftTerm) + right@(ScopedCheckedCore rightContext TyProp rightTerm) + | leftContext == rightContext + , leftTerm == truth = Just right + | leftContext == rightContext + , rightTerm == truth = Just left + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp + (CImp leftTerm (CImp rightTerm CFalsum)) + CFalsum)) + where + truth = CImp CFalsum CFalsum +conjoinScopedCore _left _right = + Nothing + +-- | Disjoin two checked propositions under the same lexical context using +-- the fixed classical encoding owned by the checked core. +disjoinScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +disjoinScopedCore + (ScopedCheckedCore leftContext TyProp left) + (ScopedCheckedCore rightContext TyProp right) + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp (CImp left CFalsum) right)) +disjoinScopedCore _left _right = + Nothing + +-- | Negate a checked proposition without changing its lexical context. +negateScopedCore + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +negateScopedCore (ScopedCheckedCore context TyProp proposition) = + Just + (ScopedCheckedCore + context + TyProp + (CImp proposition CFalsum)) +negateScopedCore _proposition = + Nothing + +-- | Checked falsum at an already established lexical context. +falsumScopedCore :: [CoreType] -> ScopedCheckedCore global +falsumScopedCore context = + ScopedCheckedCore context TyProp CFalsum + +-- | Split a checked set equality into its two extensionality directions. +splitScopedSetEquality + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +splitScopedSetEquality + (ScopedCheckedCore context TyProp (CEq TySet left right)) = + Just (subset left right, subset right left) + where + subset source target = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (memberOf (shiftCanonical 1 0 source)) + (memberOf (shiftCanonical 1 0 target)))) + + memberOf set = + CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + set +splitScopedSetEquality _proposition = + Nothing + +-- | Derive the exact predicate, member-wise hypothesis, induction step, and +-- binder-level result for one set-valued ambient binder. The selected binder +-- is replaced by the newly introduced set variable; every other ambient +-- binder remains a parameter. +scopedSetInductionInstance + :: Natural + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + ) +scopedSetInductionInstance selected + (ScopedCheckedCore context TyProp property) + | binderTypeAt selected context == Just TySet = + Just (predicate, hypothesis, step, result) + where + abstractedProperty = abstractSelected 0 property + predicate = + ScopedCheckedCore + context + (TySet `TyArrow` TyProp) + (CLam TySet abstractedProperty) + hypothesis = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + (CBound (selected + 1))) + abstractedProperty)) + step = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (abstractSelected + 0 + (scopedCoreTerm hypothesis)) + abstractedProperty)) + result = + ScopedCheckedCore + context + TyProp + (CForall TySet abstractedProperty) + + abstractSelected depth = \case + CBound index + | index == depth + selected -> + CBound depth + | index >= depth -> + CBound (index + 1) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (abstractSelected depth function) + (abstractSelected depth argument) + CLam binderType body -> + CLam binderType + (abstractSelected (depth + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (abstractSelected depth premise) + (abstractSelected depth conclusion) + CEq operandType left right -> + CEq operandType + (abstractSelected depth left) + (abstractSelected depth right) + CForall binderType body -> + CForall binderType + (abstractSelected (depth + 1) body) +scopedSetInductionInstance _selected _property = + Nothing + +-- | Close the nearest checked binder as one leading universal. +closeScopedForall + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +closeScopedForall + (ScopedCheckedCore (binderType : context) TyProp body) = + Just + (ScopedCheckedCore + context + TyProp + (CForall binderType body)) +closeScopedForall _scoped = + Nothing + +-- | Close the nearest checked binder as one leading existential. +closeScopedExists + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +closeScopedExists + (ScopedCheckedCore (binderType : context) TyProp body) = + Just + (ScopedCheckedCore + context + TyProp + (CImp + (CForall binderType (CImp body CFalsum)) + CFalsum)) +closeScopedExists _scoped = + Nothing + +-- | Open one checked leading universal without rechecking its body. +openScopedForall + :: ScopedCheckedCore global + -> Maybe (CoreType, ScopedCheckedCore global) +openScopedForall + (ScopedCheckedCore context TyProp + (CForall binderType body)) = + Just + ( binderType + , ScopedCheckedCore + (binderType : context) + TyProp + body + ) +openScopedForall _scoped = + Nothing + +-- | Split one checked implication under its unchanged ambient context. +openScopedImplication + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +openScopedImplication + (ScopedCheckedCore context TyProp + (CImp premise conclusion)) = + Just + ( ScopedCheckedCore context TyProp premise + , ScopedCheckedCore context TyProp conclusion + ) +openScopedImplication _scoped = + Nothing + +-- | Open a checked proof assumption against the current goal. Besides a +-- direct implication antecedent, the source language historically permits +-- either immediate side of one binary conjunction antecedent to be assumed +-- first. The other side remains the next implication antecedent. This is a +-- deliberately shallow structural rule: it neither flattens conjunctions nor +-- treats disjunction as an eliminable assumption. +openScopedAssumption + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +openScopedAssumption supplied goal = do + (antecedent, conclusion) <- openScopedImplication goal + if supplied == antecedent + then pure (antecedent, conclusion) + else do + (left, right) <- splitScopedConjunction antecedent + if supplied == left + then do + remaining <- implyScopedCore right conclusion + pure (left, remaining) + else if supplied == right + then do + remaining <- implyScopedCore left conclusion + pure (right, remaining) + else Nothing + +splitScopedConjunction + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +splitScopedConjunction + (ScopedCheckedCore context TyProp + (CImp (CImp left (CImp right CFalsum)) CFalsum)) = + Just + ( ScopedCheckedCore context TyProp left + , ScopedCheckedCore context TyProp right + ) +splitScopedConjunction _scoped = + Nothing + +closeScopedCore + :: ScopedCheckedCore global + -> Maybe (FrozenCheckedCore global) +closeScopedCore + (ScopedCheckedCore [] coreType term) = + Just (FrozenCheckedCore coreType term) +closeScopedCore ScopedCheckedCore{} = + Nothing + +-- | Substitute an outer-context term for index zero and remove that binder. +instantiateCanonical + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +instantiateCanonical argument = + instantiateAt 0 + where + instantiateAt depth = \case + CBound index + | index == depth -> + shiftCanonical depth 0 argument + | index > depth -> + CBound (index - 1) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function operand -> + CApp + (instantiateAt depth function) + (instantiateAt depth operand) + CLam binderType body -> + CLam binderType + (instantiateAt (depth + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (instantiateAt depth premise) + (instantiateAt depth conclusion) + CEq operandType left right -> + CEq operandType + (instantiateAt depth left) + (instantiateAt depth right) + CForall binderType body -> + CForall binderType + (instantiateAt (depth + 1) body) + +mapCanonicalGlobals + :: (global -> global') + -> CanonicalTerm global + -> CanonicalTerm global' +mapCanonicalGlobals transform = \case + CBound index -> + CBound index + CGlobal global -> + CGlobal (transform global) + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (mapCanonicalGlobals transform function) + (mapCanonicalGlobals transform argument) + CLam binderType body -> + CLam binderType + (mapCanonicalGlobals transform body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (mapCanonicalGlobals transform premise) + (mapCanonicalGlobals transform conclusion) + CEq operandType left right -> + CEq operandType + (mapCanonicalGlobals transform left) + (mapCanonicalGlobals transform right) + CForall binderType body -> + CForall binderType + (mapCanonicalGlobals transform body) + +-- | Recheck a nameless term without exposing the checked wrapper constructor. +checkCanonicalCore + :: (global -> Maybe CoreType) + -> CanonicalTerm global + -> Either CoreCheckError (FrozenCheckedCore global) +checkCanonicalCore globalType term = + FrozenCheckedCore + <$> inferCanonicalCore globalType [] term + <*> pure term + +inferCanonicalCore + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either CoreCheckError CoreType +inferCanonicalCore globalType binders = \case + CBound index -> + maybe + (Left (UnboundCoreIndex index)) + Right + (binderTypeAt index binders) + CGlobal global -> + maybe + (Left UnknownCoreGlobal) + Right + (globalType global) + CIntrinsic intrinsic -> + Right (coreIntrinsicType intrinsic) + COpaqueInteger{} -> + Right TySet + CApp function argument -> do + functionType <- + inferCanonicalCore globalType binders function + argumentType <- + inferCanonicalCore globalType binders argument + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + Right resultType + | otherwise -> + Left + (ApplicationArgumentTypeMismatch + expectedArgument + argumentType) + other -> + Left (AppliedNonFunction other) + CLam binderType body -> do + bodyType <- + inferCanonicalCore + globalType + (binderType : binders) + body + Right (binderType `TyArrow` bodyType) + CFalsum -> + Right TyProp + CImp premise conclusion -> do + premiseType <- + inferCanonicalCore globalType binders premise + unless + (premiseType == TyProp) + (Left + (ImplicationOperandTypeMismatch + premiseType)) + conclusionType <- + inferCanonicalCore globalType binders conclusion + unless + (conclusionType == TyProp) + (Left + (ImplicationOperandTypeMismatch + conclusionType)) + Right TyProp + CEq operandType left right -> do + leftType <- + inferCanonicalCore globalType binders left + unless + (leftType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + leftType)) + rightType <- + inferCanonicalCore globalType binders right + unless + (rightType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + rightType)) + Right TyProp + CForall binderType body -> do + bodyType <- + inferCanonicalCore + globalType + (binderType : binders) + body + unless + (bodyType == TyProp) + (Left + (QuantifierBodyTypeMismatch bodyType)) + Right TyProp + +binderTypeAt :: Natural -> [CoreType] -> Maybe CoreType +binderTypeAt _index [] = + Nothing +binderTypeAt 0 (binderType : _rest) = + Just binderType +binderTypeAt index (_binderType : rest) = + binderTypeAt (index - 1) rest + +shiftCanonical + :: Natural + -> Natural + -> CanonicalTerm global + -> CanonicalTerm global +shiftCanonical amount cutoff = \case + CBound index + | index >= cutoff -> + CBound (index + amount) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (shiftCanonical amount cutoff function) + (shiftCanonical amount cutoff argument) + CLam binderType body -> + CLam binderType + (shiftCanonical amount (cutoff + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (shiftCanonical amount cutoff premise) + (shiftCanonical amount cutoff conclusion) + CEq operandType left right -> + CEq operandType + (shiftCanonical amount cutoff left) + (shiftCanonical amount cutoff right) + CForall binderType body -> + CForall binderType + (shiftCanonical amount (cutoff + 1) body) + +data FreezeError + = FreeLocalInClosedCore + deriving stock (Show, Eq) + +-- | Freeze a checked closed term in one traversal of the operational syntax. +freezeClosed + :: CheckedCore global Void + -> Either FreezeError (FrozenCheckedCore global) +freezeClosed (CheckedCore coreType syntax) = + FrozenCheckedCore coreType + <$> optimizedFreeze 0 rootResolver syntax + where + rootResolver _depth = + absurd + +-- | Bounded executable oracle for tests. Production code uses 'freezeClosed'. +referenceFreezeClosed + :: CheckedCore global Void + -> Either FreezeError (FrozenCheckedCore global) +referenceFreezeClosed (CheckedCore coreType syntax) = + FrozenCheckedCore coreType + <$> referenceFreeze 0 rootResolver syntax + where + rootResolver _depth = + absurd + +type VariableResolver local global = + Natural + -> local + -> Either FreezeError (CanonicalTerm global) + +optimizedFreeze + :: Natural + -> VariableResolver local global + -> CoreSyntax global local + -> Either FreezeError (CanonicalTerm global) +optimizedFreeze depth resolve = \case + CoreLocal local -> + resolve depth local + CoreGlobal global -> + Right (CGlobal global) + CoreIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + CoreOpaqueInteger integer -> + Right (COpaqueInteger integer) + CoreApply function argument -> + CApp + <$> optimizedFreeze depth resolve function + <*> optimizedFreeze depth resolve argument + CoreLambda binderType body -> + CLam binderType + <$> optimizedFreeze + (depth + 1) + (resolveGeneralized depth resolve) + (unscope body) + CoreFalsum -> + Right CFalsum + CoreImplication premise conclusion -> + CImp + <$> optimizedFreeze depth resolve premise + <*> optimizedFreeze depth resolve conclusion + CoreEquality operandType left right -> + CEq operandType + <$> optimizedFreeze depth resolve left + <*> optimizedFreeze depth resolve right + CoreForall binderType body -> + CForall binderType + <$> optimizedFreeze + (depth + 1) + (resolveGeneralized depth resolve) + (unscope body) + where + resolveGeneralized + :: Natural + -> VariableResolver local global + -> VariableResolver + (Var () (CoreSyntax global local)) + global + resolveGeneralized binderLevel outerResolve currentDepth = \case + B () -> + Right + (CBound + (currentDepth - binderLevel - 1)) + F outerSyntax -> + optimizedFreeze + currentDepth + outerResolve + outerSyntax + +referenceFreeze + :: Natural + -> VariableResolver local global + -> CoreSyntax global local + -> Either FreezeError (CanonicalTerm global) +referenceFreeze depth resolve = \case + CoreLocal local -> + resolve depth local + CoreGlobal global -> + Right (CGlobal global) + CoreIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + CoreOpaqueInteger integer -> + Right (COpaqueInteger integer) + CoreApply function argument -> + CApp + <$> referenceFreeze depth resolve function + <*> referenceFreeze depth resolve argument + CoreLambda binderType body -> + CLam binderType + <$> referenceFreeze + (depth + 1) + (resolveNormalized depth resolve) + (fromScope body) + CoreFalsum -> + Right CFalsum + CoreImplication premise conclusion -> + CImp + <$> referenceFreeze depth resolve premise + <*> referenceFreeze depth resolve conclusion + CoreEquality operandType left right -> + CEq operandType + <$> referenceFreeze depth resolve left + <*> referenceFreeze depth resolve right + CoreForall binderType body -> + CForall binderType + <$> referenceFreeze + (depth + 1) + (resolveNormalized depth resolve) + (fromScope body) + where + resolveNormalized + :: Natural + -> VariableResolver local global + -> VariableResolver (Var () local) global + resolveNormalized binderLevel outerResolve currentDepth = \case + B () -> + Right + (CBound + (currentDepth - binderLevel - 1)) + F outerLocal -> + outerResolve currentDepth outerLocal diff --git a/source/Felix/Checking/Datatype.hs b/source/Felix/Checking/Datatype.hs new file mode 100644 index 0000000..66e64db --- /dev/null +++ b/source/Felix/Checking/Datatype.hs @@ -0,0 +1,670 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Felix.Checking.Datatype + ( CheckedDatatype + , DatatypeValidationError + , datatypeValidationErrorLocation + , renderDatatypeValidationError + , prepareCheckedDatatype + , checkedDatatypeHeadSymbol + , checkedDatatypeConstructorSymbols + , CheckedDatatypeClauseView(..) + , CheckedDatatypePremiseView(..) + , checkedDatatypeClauseViews + , checkedDatatypeGeneratedFacts + ) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Internal +import Felix.Syntax.Lexicon + +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 + + +-- | A datatype whose premise domains have been canonicalized and validated. +data CheckedDatatype = CheckedDatatype + { checkedDatatypeHead :: !FunctionSymbol + , checkedDatatypeClauses :: !(NonEmpty CheckedDatatypeClause) + } + +data CheckedDatatypeClause = CheckedDatatypeClause + { checkedDatatypeClauseConstructor :: !FunctionSymbol + , checkedDatatypeClauseConstructorArgs :: ![VarSymbol] + , checkedDatatypeClausePremises :: ![CheckedDatatypePremise] + } + +-- Direct premises retain their canonical term for generated-fact locations. +data CheckedDatatypePremise + = RecursiveDatatypePremise !VarSymbol !Expr + | NonRecursiveDatatypePremise !VarSymbol !Expr + +data DatatypeValidationError + = InvalidDatatype !Text + | InvalidDatatypePremise !Location !Text + deriving (Show, Eq) + +datatypeValidationErrorLocation + :: DatatypeValidationError + -> Maybe Location +datatypeValidationErrorLocation = \case + InvalidDatatype _message -> Nothing + InvalidDatatypePremise location _message -> Just location + +renderDatatypeValidationError :: DatatypeValidationError -> Text +renderDatatypeValidationError = \case + InvalidDatatype message -> message + InvalidDatatypePremise _location message -> message + +data CanonicalDatatypeClause = CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor :: !SymbolPattern + , canonicalDatatypeClausePremises :: ![(VarSymbol, Location, Expr)] + } + +-- | Read-only normalized clause data for exact typed lowering. +data CheckedDatatypeClauseView = CheckedDatatypeClauseView + { checkedDatatypeClauseViewConstructor :: !FunctionSymbol + , checkedDatatypeClauseViewArguments :: ![VarSymbol] + , checkedDatatypeClauseViewPremises + :: ![CheckedDatatypePremiseView] + } deriving (Show, Eq) + +data CheckedDatatypePremiseView + = CheckedRecursiveDatatypePremise !VarSymbol !Expr + | CheckedNonRecursiveDatatypePremise !VarSymbol !Expr + deriving (Show, Eq) + +-- | Canonicalize every premise domain once, then validate the declaration. +prepareCheckedDatatype + :: Monad m + => (Expr -> m Expr) + -> Datatype + -> m (Either DatatypeValidationError CheckedDatatype) +prepareCheckedDatatype canonicalizeDomain Datatype{datatypeHead, datatypeClauses} = do + canonicalClauses <- traverse canonicalizeClause datatypeClauses + pure (validateDatatype datatypeHead canonicalClauses) + where + canonicalizeClause DatatypeClause + { datatypeClauseConstructor + , datatypeClausePremises + } = do + premises <- + traverse + (\(var, domain) -> + (\canonicalDomain -> + (var, exprLocation domain, canonicalDomain)) + <$> canonicalizeDomain domain) + datatypeClausePremises + pure + CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + datatypeClauseConstructor + , canonicalDatatypeClausePremises = premises + } + +validateDatatype + :: SymbolPattern + -> NonEmpty CanonicalDatatypeClause + -> Either DatatypeValidationError CheckedDatatype +validateDatatype + (SymbolPattern datatypeSymbol datatypeArgs) + datatypeClauses = do + require + (null datatypeArgs) + "datatype head must be nullary" + let constructorSymbols = + [ constructorSymbol + | CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + SymbolPattern constructorSymbol _ + } <- NonEmpty.toList datatypeClauses + ] + duplicateConstructors = + duplicateDatatypeConstructorSymbols constructorSymbols + require + (Set.null duplicateConstructors) + ( "datatype constructor patterns must be distinct: " + <> formatDatatypeConstructors duplicateConstructors + ) + checkedDatatypeClauses <- + traverse (validateDatatypeClause datatypeSymbol) datatypeClauses + pure + CheckedDatatype + { checkedDatatypeHead = datatypeSymbol + , checkedDatatypeClauses + } + +validateDatatypeClause + :: FunctionSymbol + -> CanonicalDatatypeClause + -> Either DatatypeValidationError CheckedDatatypeClause +validateDatatypeClause + datatypeSymbol + CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + SymbolPattern constructorSymbol constructorArgs + , canonicalDatatypeClausePremises + } = do + require + (constructorSymbol /= ApplySymbol) + "datatype constructor cannot be function application" + require + (constructorSymbol /= datatypeSymbol) + "datatype constructor cannot reuse the datatype symbol" + let duplicateConstructorArgs = duplicateVars constructorArgs + require + (Set.null duplicateConstructorArgs) + ( "datatype constructor arguments must be linear: " + <> formatVars duplicateConstructorArgs + ) + let premiseVars = + (\(variable, _location, _domain) -> variable) + <$> canonicalDatatypeClausePremises + duplicatePremiseVars = duplicateVars premiseVars + require + (Set.null duplicatePremiseVars) + ( "datatype premise variables must be linear: " + <> formatVars duplicatePremiseVars + ) + let missingPremises = + Set.fromList constructorArgs + `Set.difference` Set.fromList premiseVars + require + (Set.null missingPremises) + ( "datatype constructor argument(s) missing premise: " + <> formatVars missingPremises + ) + checkedDatatypeClausePremises <- + traverse + (validateDatatypePremise datatypeSymbol) + canonicalDatatypeClausePremises + pure + CheckedDatatypeClause + { checkedDatatypeClauseConstructor = constructorSymbol + , checkedDatatypeClauseConstructorArgs = constructorArgs + , checkedDatatypeClausePremises = + checkedDatatypeClausePremises + } + +validateDatatypePremise + :: FunctionSymbol + -> (VarSymbol, Location, Expr) + -> Either DatatypeValidationError CheckedDatatypePremise +validateDatatypePremise datatypeSymbol (var, location, domain) = do + let domainFreeVars = freeVars domain + requirePremise location + (Set.null domainFreeVars) + ( "datatype premise domains must be closed terms: " + <> formatVars domainFreeVars + ) + if equivalent domain datatypeCarrier + then + Right (RecursiveDatatypePremise var domain) + else do + requirePremise location + ( SymbolMixfix datatypeSymbol + `Set.notMember` mentionedSymbols domain + ) + "datatype recursive premise must be direct" + Right (NonRecursiveDatatypePremise var domain) + where + datatypeCarrier = + TermSymbol Nowhere (SymbolMixfix datatypeSymbol) [] + +require :: Bool -> Text -> Either DatatypeValidationError () +require condition message + | condition = + Right () + | otherwise = + Left (InvalidDatatype message) + +requirePremise + :: Location + -> Bool + -> Text + -> Either DatatypeValidationError () +requirePremise location condition message + | condition = + Right () + | otherwise = + Left (InvalidDatatypePremise location message) + +checkedDatatypeHeadSymbol :: CheckedDatatype -> Symbol +checkedDatatypeHeadSymbol = + SymbolMixfix . checkedDatatypeHead + +checkedDatatypeConstructorSymbols + :: CheckedDatatype + -> NonEmpty Symbol +checkedDatatypeConstructorSymbols = + fmap + (SymbolMixfix . checkedDatatypeClauseConstructor) + . checkedDatatypeClauses + +checkedDatatypeClauseViews + :: CheckedDatatype + -> NonEmpty CheckedDatatypeClauseView +checkedDatatypeClauseViews = + fmap clauseView . checkedDatatypeClauses + where + clauseView clause = + CheckedDatatypeClauseView + { checkedDatatypeClauseViewConstructor = + checkedDatatypeClauseConstructor clause + , checkedDatatypeClauseViewArguments = + checkedDatatypeClauseConstructorArgs clause + , checkedDatatypeClauseViewPremises = + premiseView + <$> checkedDatatypeClausePremises clause + } + + premiseView = \case + RecursiveDatatypePremise variable domain -> + CheckedRecursiveDatatypePremise variable domain + NonRecursiveDatatypePremise variable domain -> + CheckedNonRecursiveDatatypePremise variable domain + +checkedDatatypeGeneratedFacts + :: CheckedDatatype + -> NonEmpty (Marker, Formula) +checkedDatatypeGeneratedFacts = + datatypeFacts + +datatypeFacts :: CheckedDatatype -> NonEmpty (Marker, Formula) +datatypeFacts datatype = + appendList + (datatypeIntroFacts datatype) + ( datatypeDistinctFacts datatype + <> datatypeInjectiveFacts datatype + <> [ ( datatypeCasesMarker datatype + , datatypeCasesFormula datatype + ) + , ( datatypeInductMarker datatype + , datatypeInductFormula datatype + ) + ] + ) + where + appendList (first :| rest) trailing = + first :| (rest <> trailing) + +datatypeIntroFacts :: CheckedDatatype -> NonEmpty (Marker, Formula) +datatypeIntroFacts datatype = + fmap + (\clause -> + ( datatypeIntroMarker datatype clause + , datatypeIntroFormula datatype clause + )) + (checkedDatatypeClauses datatype) + +datatypeDistinctFacts :: CheckedDatatype -> [(Marker, Formula)] +datatypeDistinctFacts datatype = + [ ( datatypeDistinctMarker datatype leftClause rightClause + , datatypeDistinctFormula leftClause rightClause + ) + | (leftClause, rightClause) <- + unorderedPairs + (NonEmpty.toList (checkedDatatypeClauses datatype)) + ] + +datatypeInjectiveFacts :: CheckedDatatype -> [(Marker, Formula)] +datatypeInjectiveFacts datatype = + [ ( datatypeInjectiveMarker datatype clause + , datatypeInjectiveFormula clause + ) + | clause <- NonEmpty.toList (checkedDatatypeClauses datatype) + , not (null (checkedDatatypeClauseConstructorArgs clause)) + ] + +datatypeIntroMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> Marker +datatypeIntroMarker datatype clause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText clause + <> "_intro" + ) + +datatypeDistinctMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> CheckedDatatypeClause + -> Marker +datatypeDistinctMarker datatype leftClause rightClause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText leftClause + <> "_" + <> datatypeClauseSymbolText rightClause + <> "_distinct" + ) + +datatypeInjectiveMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> Marker +datatypeInjectiveMarker datatype clause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText clause + <> "_injective" + ) + +datatypeCasesMarker :: CheckedDatatype -> Marker +datatypeCasesMarker datatype = + Marker (datatypeFactBase datatype <> "_cases") + +datatypeInductMarker :: CheckedDatatype -> Marker +datatypeInductMarker datatype = + Marker (datatypeFactBase datatype <> "_induct") + +datatypeFactBase :: CheckedDatatype -> Text +datatypeFactBase = + functionSymbolText . checkedDatatypeHead + +datatypeIntroFormula + :: CheckedDatatype + -> CheckedDatatypeClause + -> Formula +datatypeIntroFormula datatype clause = + forallIfNeeded premiseVars (impliesFrom premises conclusion) + where + premiseVars = datatypeClausePremiseVars clause + premises = datatypeClausePremiseFormulas clause + conclusion = datatypeClauseResultFormula datatype clause + +datatypeDistinctFormula + :: CheckedDatatypeClause + -> CheckedDatatypeClause + -> Formula +datatypeDistinctFormula leftClause rightClause = + forallIfNeeded + (leftVars <> rightVars) + (NotEquals Nowhere leftTerm rightTerm) + where + leftVars = checkedDatatypeClauseConstructorArgs leftClause + rightVars = + renameDatatypeVars + (Set.fromList leftVars) + (checkedDatatypeClauseConstructorArgs rightClause) + leftTerm = datatypeClauseTerm leftClause (TermVar <$> leftVars) + rightTerm = datatypeClauseTerm rightClause (TermVar <$> rightVars) + +datatypeInjectiveFormula :: CheckedDatatypeClause -> Formula +datatypeInjectiveFormula clause = + forallIfNeeded + (leftVars <> rightVars) + ( Equals Nowhere leftTerm rightTerm + `Implies` makeConjunction equalities + ) + where + leftVars = checkedDatatypeClauseConstructorArgs clause + rightVars = renameDatatypeVars (Set.fromList leftVars) leftVars + leftTerm = datatypeClauseTerm clause (TermVar <$> leftVars) + rightTerm = datatypeClauseTerm clause (TermVar <$> rightVars) + equalities = + zipWith + (\leftVar rightVar -> + Equals Nowhere (TermVar leftVar) (TermVar rightVar)) + leftVars + rightVars + +datatypeCasesFormula :: CheckedDatatype -> Formula +datatypeCasesFormula datatype = + makeForall + [witnessVar] + ( isElementOf (TermVar witnessVar) datatypeCarrier + `Implies` makeDisjunction disjuncts + ) + where + usedVars = datatypeUsedVars datatype + witnessVar = freshDatatypeVar usedVars "x" + datatypeCarrier = datatypeCarrierTerm datatype + disjuncts = + datatypeCaseDisjunct witnessVar + <$> NonEmpty.toList (checkedDatatypeClauses datatype) + datatypeCaseDisjunct var clause = + existsIfNeeded + premiseVars + ( makeConjunction + ( premises + <> [ Equals + Nowhere + (TermVar var) + constructorTerm + ] + ) + ) + where + premiseVars = datatypeClausePremiseVars clause + premises = datatypeClausePremiseFormulas clause + constructorTerm = + datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + +datatypeInductFormula :: CheckedDatatype -> Formula +datatypeInductFormula datatype = + makeForall + [subsetVar] + (impliesFrom closureAssumptions conclusion) + where + usedVars = datatypeUsedVars datatype + subsetVar = freshDatatypeVar usedVars "S" + witnessVar = freshDatatypeVar (Set.insert subsetVar usedVars) "x" + datatypeCarrier = datatypeCarrierTerm datatype + conclusion = + makeForall + [witnessVar] + ( isElementOf (TermVar witnessVar) datatypeCarrier + `Implies` isElementOf + (TermVar witnessVar) + (TermVar subsetVar) + ) + closureAssumptions = + datatypeInductionClosure subsetVar + <$> NonEmpty.toList (checkedDatatypeClauses datatype) + +datatypeInductionClosure + :: VarSymbol + -> CheckedDatatypeClause + -> Formula +datatypeInductionClosure subsetVar clause = + forallIfNeeded + premiseVars + (impliesFrom inductionPremises conclusion) + where + premiseVars = datatypeClausePremiseVars clause + inductionPremises = + datatypeInductionPremise subsetVar + <$> checkedDatatypeClausePremises clause + conclusion = + isElementOf + ( datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + ) + (TermVar subsetVar) + +datatypeInductionPremise + :: VarSymbol + -> CheckedDatatypePremise + -> Formula +datatypeInductionPremise subsetVar = \case + RecursiveDatatypePremise var _canonicalDomain -> + isElementOf (TermVar var) (TermVar subsetVar) + NonRecursiveDatatypePremise var domain -> + isElementOf (TermVar var) domain + +datatypeCarrierTerm :: CheckedDatatype -> Expr +datatypeCarrierTerm datatype = + TermSymbol + Nowhere + (SymbolMixfix (checkedDatatypeHead datatype)) + [] + +datatypeClauseResultFormula + :: CheckedDatatype + -> CheckedDatatypeClause + -> Formula +datatypeClauseResultFormula datatype clause = + isElementOf + ( datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + ) + (datatypeCarrierTerm datatype) + +datatypeClauseTerm :: CheckedDatatypeClause -> [Expr] -> Expr +datatypeClauseTerm clause args = + TermSymbol + Nowhere + (SymbolMixfix (checkedDatatypeClauseConstructor clause)) + args + +datatypeClausePremiseVars :: CheckedDatatypeClause -> [VarSymbol] +datatypeClausePremiseVars = + fmap datatypePremiseVar . checkedDatatypeClausePremises + +datatypeClausePremiseFormulas + :: CheckedDatatypeClause + -> [Formula] +datatypeClausePremiseFormulas = + fmap datatypePremiseFormula + . checkedDatatypeClausePremises + +datatypePremiseFormula + :: CheckedDatatypePremise + -> Formula +datatypePremiseFormula = \case + RecursiveDatatypePremise var canonicalDomain -> + isElementOf (TermVar var) canonicalDomain + NonRecursiveDatatypePremise var domain -> + isElementOf (TermVar var) domain + +datatypePremiseVar :: CheckedDatatypePremise -> VarSymbol +datatypePremiseVar = \case + RecursiveDatatypePremise var _canonicalDomain -> + var + NonRecursiveDatatypePremise var _domain -> + var + +datatypeClauseSymbolText :: CheckedDatatypeClause -> Text +datatypeClauseSymbolText = + functionSymbolText . checkedDatatypeClauseConstructor + +functionSymbolText :: FunctionSymbol -> Text +functionSymbolText symbol = + case mixfixMarker symbol of + Marker name -> + name + +datatypeUsedVars :: CheckedDatatype -> Set VarSymbol +datatypeUsedVars datatype = + Set.fromList + [ var + | clause <- NonEmpty.toList (checkedDatatypeClauses datatype) + , var <- datatypeClausePremiseVars clause + ] + +duplicateDatatypeConstructorSymbols + :: [FunctionSymbol] + -> Set FunctionSymbol +duplicateDatatypeConstructorSymbols = + snd . foldl' step (Set.empty, Set.empty) + where + step (seen, duplicates) symbol + | symbol `Set.member` seen = + (seen, Set.insert symbol duplicates) + | otherwise = + (Set.insert symbol seen, duplicates) + +duplicateVars :: [VarSymbol] -> Set VarSymbol +duplicateVars = + snd . foldl' step (Set.empty, Set.empty) + where + step (seen, duplicates) var + | var `Set.member` seen = + (seen, Set.insert var duplicates) + | otherwise = + (Set.insert var seen, duplicates) + +formatDatatypeConstructors :: Set FunctionSymbol -> Text +formatDatatypeConstructors symbols = + Text.intercalate + ", " + (functionSymbolText <$> Set.toList symbols) + +formatVars :: Set VarSymbol -> Text +formatVars vars = + Text.intercalate ", " (formatVar <$> Set.toList vars) + +formatVar :: VarSymbol -> Text +formatVar = \case + NamedVar name -> + name + FreshVar index -> + "_" <> Text.pack (show index) + +renameDatatypeVars :: Set VarSymbol -> [VarSymbol] -> [VarSymbol] +renameDatatypeVars _used [] = + [] +renameDatatypeVars used (var:vars) = + let renamed = freshDatatypeLikeVar used var + in renamed : renameDatatypeVars (Set.insert renamed used) vars + +freshDatatypeLikeVar :: Set VarSymbol -> VarSymbol -> VarSymbol +freshDatatypeLikeVar used = \case + NamedVar name -> + freshDatatypeVar used (name <> "_rhs") + FreshVar index -> + freshDatatypeVar + used + ("_" <> Text.pack (show index) <> "_rhs") + +freshDatatypeVar :: Set VarSymbol -> Text -> VarSymbol +freshDatatypeVar used base = + List.head + [ NamedVar candidate + | candidate <- + base + : [ base <> Text.pack (show index) + | index <- [(1 :: Int) ..] + ] + , NamedVar candidate `Set.notMember` used + ] + +forallIfNeeded :: [VarSymbol] -> Formula -> Formula +forallIfNeeded [] formula = + formula +forallIfNeeded vars formula = + makeForall vars formula + +existsIfNeeded :: [VarSymbol] -> Formula -> Formula +existsIfNeeded [] formula = + formula +existsIfNeeded vars formula = + makeExists vars formula + +impliesFrom :: [Formula] -> Formula -> Formula +impliesFrom [] conclusion = + conclusion +impliesFrom premises conclusion = + makeConjunction premises `Implies` conclusion + +unorderedPairs :: [a] -> [(a, a)] +unorderedPairs = \case + [] -> + [] + value:rest -> + [(value, other) | other <- rest] + <> unorderedPairs rest diff --git a/source/Felix/Checking/Declaration.hs b/source/Felix/Checking/Declaration.hs new file mode 100644 index 0000000..15050c7 --- /dev/null +++ b/source/Felix/Checking/Declaration.hs @@ -0,0 +1,6770 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Builder-confined authorization and atomic typed declaration append. +module Felix.Checking.Declaration + ( ModuleDriver + , DriverFailure(..) + , DriverResult(..) + , ImportedModuleEvidence + , ImportedAliasOrigin(..) + , freshImportedModuleEvidence + , validateImportedModuleEvidence + , importSealedModule + , importSealedModuleDriver + , nextDeclarationSlotDriver + , currentTheoryDriver + , currentFoundationAxiomDriver + , resolveVisibleFactAliasDriver + , resolveVisibleFactTargetsDriver + , resolveVisibleGlobalDriver + , resolveVisibleGlobalContentDriver + , ResolvedStructure + , resolvedStructureDescriptor + , resolvedStructurePredicate + , resolvedStructureOperation + , resolvedStructureOperations + , resolveVisibleStructureDriver + , resolveVisibleStructureOperationObjectsDriver + , objectAvailableDriver + , objectTypeDriver + , LoweringDriver + , runProspectiveLoweringDriver + , nextDeclarationSlotLowering + , currentTheoryLowering + , currentFoundationLowering + , currentFoundationAxiomLowering + , resolveVisibleFactAliasLowering + , resolveVisibleFactTargetsLowering + , resolveVisibleGlobalLowering + , resolveVisibleGlobalContentLowering + , resolveVisibleStructureLowering + , resolveVisibleStructureOperationObjectsLowering + , objectAvailableLowering + , objectTypeLowering + , runModuleDriver + , ValidationLookup + , validationLookup + , ValidationRun(..) + , failModuleDriver + , failDeclarationDriver + , VampireResolver + , VampireSubmission(..) + , vampireBatchResolver + , vampireResolver + , vampireSubmissionResolver + , Declaration + , failDeclaration + , addDeclarationObject + , addDeclarationProposition + , resolveVisibleGlobal + , stageSemanticGlobalBinding + , stageSemanticStructureDescriptor + , CandidateSpec + , candidateSpec + , CandidatePlanningSpec + , CheckedCandidate + , checkedCandidate + , checkedDefinitionEquationPlanning + , checkedSourceAxiomPlanning + , checkedDatatypePlanning + , checkedKernelPlanning + , checkedKernelPlanningWithStaged + , checkedStagedKernelPlanning + , checkedSourceProofPlanning + , checkedOmittedPlanning + , CheckedPlannedVampireRequest + , checkedPlannedVampireRequest + , plannedEarlierCandidate + , CheckedDeclaration + , checkedProofDeclaration + , checkedCompiledDeclaration + , admitCheckedDeclaration + , PlannedDeclaration + , planCheckedDeclaration + , admitPlannedCheckedDeclaration + , plannedDeclarationPreviousPrefix + , plannedDeclarationNextPrefix + , plannedDeclarationDelta + , PlanningIntegrityError(..) + , prepareCandidateSpecDriver + , prepareFrozenCandidateSpecDriver + , prepareDefinitionEquationSpecDriver + , preparePointwiseDefinitionEquationSpecDriver + , prepareStagedCandidateVampireDriver + , prepareCandidateSpecLowering + , prepareFrozenCandidateSpecLowering + , prepareDefinitionEquationSpecLowering + , prepareDefinitionEquationSpecWithEligibilityLowering + , prepareNamedSetConstructionSpecLowering + , prepareRelationalSetConstructionSpecLowering + , preparePointwiseDefinitionEquationSpecLowering + , prepareStagedCandidateVampireLowering + , ReservedCandidate + , reserveCandidate + , reserveCandidateBatch + , reservePropositionCandidate + , reserveFrozenPropositionCandidateBatch + , reserveDefinitionEquationCandidate + , reservePointwiseDefinitionEquationCandidate + , reserveDefinitionEquationCandidateBatch + , reservedCandidateSlot + , reservedCandidateStage + , CandidateProof + , locateProofObligation + , recordOmittedUse + , VampirePremiseSelection(..) + , VampireObligationPreparationError(..) + , ScopedVampirePremise + , scopedVampirePremise + , PreparedVampireObligation + , prepareScopedVampireObligationDriver + , prepareScopedContradictionObligationDriver + , prepareScopedVampireObligationLowering + , prepareScopedContradictionObligationLowering + , useAuthorizedFact + , useStagedCandidate + , LocalClaim + , proveLocalKernelClaim + , useLocalClaim + , authorizeKernelProofCandidate + , authorizeKernelConstructionCandidate + , authorizeDefinitionEquationCandidate + , authorizeNamedSetConstructionCandidate + , authorizeRelationalSetConstructionCandidate + , acceptVampireObligation + , acceptPreparedVampireObligation + , acceptCurrentCandidateVampire + , prepareCurrentCandidateVampire + , authorizeVampireCandidate + , authorizeVampireCandidateBatch + , authorizeSourceAxiomCandidate + , authorizeOmittedCandidate + , authorizeDatatypeCompilationCandidates + , authorizeCompiledDeclaration + , commitProofDeclaration + , commitCompiledDeclaration + , CommittedDeclarationBatch + , committedBatchOwner + , committedBatchSlot + , committedBatchPreviousPrefix + , committedBatchNextPrefix + , committedBatchDelta + , committedBatchObjects + , committedBatchPropositions + , committedBatchProofValidations + , committedBatchDeclarationValidation + , PendingModulePrefix + , emptyPendingModulePrefix + , pendingModulePrefixBatches + , pendingModulePrefixCurrent + , ValidationIntegrityError(..) + , renderValidationIntegrityError + , DeclarationError(..) + , declarationErrorLocation + , renderDeclarationError + , DriverOpenError(..) + , renderDriverOpenError + ) where + +import Base +import Felix.Cache.Codec (encodeCache) +import Felix.Checking.Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Backend.Tptp qualified as Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction +import Felix.Module +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract (StructSymbol) + +import Control.Exception qualified as Exception +import Control.DeepSeq (deepseq) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, mapMaybe) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Unique (Unique, newUnique) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +newtype BuilderIdentity = BuilderIdentity Unique + deriving stock (Eq) + +newtype DeclarationInvocation = DeclarationInvocation Natural + deriving stock (Eq) + +newtype CandidateStage = CandidateStage Natural + deriving stock (Show, Eq, Ord) + +data ValidationLookup = ValidationLookup + !(ProofValidationKey -> IO (Maybe ProofValidationRecord)) + !(DeclarationValidationKey + -> IO (Maybe DeclarationValidationRecord)) + +validationLookup + :: (ProofValidationKey -> IO (Maybe ProofValidationRecord)) + -> (DeclarationValidationKey + -> IO (Maybe DeclarationValidationRecord)) + -> ValidationLookup +validationLookup = + ValidationLookup + +data ValidationRun + = FreshValidation + | WarmValidation !ValidationLookup + +data ValidationIntegrityError + = CachedValidationIntegrityError + !Materialization.MaterializationError + deriving stock (Show, Eq) + +instance Exception.Exception ValidationIntegrityError + +renderValidationIntegrityError :: ValidationIntegrityError -> Text +renderValidationIntegrityError = \case + CachedValidationIntegrityError failure -> + "cached validation does not match its exact contextual input: " + <> Text.pack (show failure) + + +data BuilderFactAuthorization = BuilderFactAuthorization + !BuilderIdentity + !FactSlot + !FactAuthority + +data PendingFactAuthorization = PendingFactAuthorization + !BuilderIdentity + !PrefixContextId + !DeclarationInvocation + !FactSlot + !FactAuthority + !CandidateStage + +-- | Checked fact semantics paired with caller-selected evidence. Semantic +-- lookup and request preparation deliberately ignore the evidence parameter; +-- only the admitted builder instantiation may consume capabilities. +data FactEntry evidence = FactEntry + !CheckedPropositionContent + !SemanticFactOccurrence + !evidence + +-- | The shared checked semantic state. The evidence parameter makes the +-- distinction between admitted authority and future inert planning data +-- visible without duplicating lookup, collision, closure, or delta logic. +data BuilderState evidence = BuilderState + { logicalBuilderIdentity :: !BuilderIdentity + , logicalBuilderFoundation :: !CheckedFoundation + , logicalBuilderTheory :: !TheoryId + , logicalBuilderOwner :: !ModuleName + , logicalBuilderDirectSemanticInputs :: ![SemanticInterfaceId] + , logicalBuilderPrefix :: !PrefixContextId + , logicalBuilderObjectClosure :: !CheckedObjectClosure + , logicalBuilderFacts + :: !(Map + SemanticFactOccurrenceFingerprint + (FactEntry evidence)) + , logicalBuilderAliases + :: !(Map SemanticName ImportedAliasBinding) + , logicalBuilderGlobals + :: !(Map SemanticGlobalKey SemanticGlobalTarget) + , logicalBuilderStructures + :: !(Map SemanticStructurePhrase ResolvedStructure) + , logicalBuilderImportedInterfaces :: !(Set SemanticInterfaceId) + , logicalBuilderDeltas :: ![DeclarationInterfaceDelta] + , logicalBuilderNextDeclaration :: !Natural + , logicalBuilderNextFact :: !Natural + , logicalBuilderNextInvocation :: !Natural + } + +-- | The only production builder in this milestone. Capability-consuming +-- operations below accept this admitted instantiation, never a polymorphic +-- 'BuilderState'. +type LogicalBuilder = BuilderState BuilderFactAuthorization + +-- | Public semantic contract and strict declaration-stage provenance for a +-- prospective fact. It deliberately contains no builder identity, prefix, +-- declaration invocation, pending authorization, or minting capability. +data PlanningProvenance = PlanningProvenance + !DeclarationSlot + !CandidateStage + !FactSlot + deriving stock (Eq) + +data PlanningEvidence = PlanningEvidence + !FactAuthority + !(Maybe PlanningProvenance) + +data ResolvedStructureOperation = ResolvedStructureOperation + !ObjectId + !SemanticStructurePhrase + deriving stock (Show, Eq) + +data ResolvedStructure = ResolvedStructure + !SemanticStructureDescriptor + !(Set SemanticStructurePhrase) + !(Map StructSymbol ResolvedStructureOperation) + deriving stock (Show, Eq) + +resolvedStructureDescriptor + :: ResolvedStructure + -> SemanticStructureDescriptor +resolvedStructureDescriptor (ResolvedStructure descriptor _ _) = + descriptor + +resolvedStructurePredicate :: ResolvedStructure -> Maybe ObjectId +resolvedStructurePredicate = + semanticStructureDescriptorPredicate . resolvedStructureDescriptor + +resolvedStructureOperation + :: StructSymbol + -> ResolvedStructure + -> Maybe ObjectId +resolvedStructureOperation symbol (ResolvedStructure _ _ operations) = + operationObject <$> Map.lookup symbol operations + where + operationObject (ResolvedStructureOperation object _origin) = object + +resolvedStructureOperations + :: ResolvedStructure + -> Map StructSymbol ObjectId +resolvedStructureOperations (ResolvedStructure _ _ operations) = + operationObject <$> operations + where + operationObject (ResolvedStructureOperation object _origin) = object + +structureOperationBindings + :: Map SemanticStructurePhrase ResolvedStructure + -> Set (StructSymbol, ObjectId) +structureOperationBindings structures = + Set.fromList + [ (symbol, object) + | structure <- Map.elems structures + , (symbol, object) <- + Map.toAscList (resolvedStructureOperations structure) + ] + + +data CommittedDeclarationBatch = CommittedDeclarationBatch + !ModuleName + !DeclarationSlot + !PrefixContextId + !PrefixContextId + !DeclarationInterfaceDelta + ![AssertedObject] + ![CheckedPropositionContent] + ![ProofValidationRecord] + !(Maybe DeclarationValidationRecord) + +committedBatchOwner :: CommittedDeclarationBatch -> ModuleName +committedBatchOwner + (CommittedDeclarationBatch owner _ _ _ _ _ _ _ _) = + owner + +committedBatchSlot + :: CommittedDeclarationBatch + -> DeclarationSlot +committedBatchSlot + (CommittedDeclarationBatch _ slot _ _ _ _ _ _ _) = + slot + +committedBatchPreviousPrefix + :: CommittedDeclarationBatch + -> PrefixContextId +committedBatchPreviousPrefix + (CommittedDeclarationBatch _ _ previous _ _ _ _ _ _) = + previous + +committedBatchNextPrefix + :: CommittedDeclarationBatch + -> PrefixContextId +committedBatchNextPrefix + (CommittedDeclarationBatch _ _ _ next _ _ _ _ _) = + next + +committedBatchDelta + :: CommittedDeclarationBatch + -> DeclarationInterfaceDelta +committedBatchDelta + (CommittedDeclarationBatch _ _ _ _ delta _ _ _ _) = + delta + +committedBatchObjects + :: CommittedDeclarationBatch + -> [AssertedObject] +committedBatchObjects + (CommittedDeclarationBatch _ _ _ _ _ objects _ _ _) = + objects + +committedBatchPropositions + :: CommittedDeclarationBatch + -> [CheckedPropositionContent] +committedBatchPropositions + (CommittedDeclarationBatch _ _ _ _ _ _ propositions _ _) = + propositions + +committedBatchProofValidations + :: CommittedDeclarationBatch + -> [ProofValidationRecord] +committedBatchProofValidations + (CommittedDeclarationBatch _ _ _ _ _ _ _ validations _) = + validations + +committedBatchDeclarationValidation + :: CommittedDeclarationBatch + -> Maybe DeclarationValidationRecord +committedBatchDeclarationValidation + (CommittedDeclarationBatch _ _ _ _ _ _ _ _ validation) = + validation + + +data PendingModulePrefix = PendingModulePrefix + !PrefixContextId + ![CommittedDeclarationBatch] + +emptyPendingModulePrefix + :: PrefixContextId + -> PendingModulePrefix +emptyPendingModulePrefix prefix = + PendingModulePrefix prefix [] + +instance Show PendingModulePrefix where + show prefix = + "PendingModulePrefix {pendingModulePrefixCurrent = " + <> show (pendingModulePrefixCurrent prefix) + <> ", pendingModulePrefixBatchCount = " + <> show (length (pendingModulePrefixBatches prefix)) + <> "}" + +pendingModulePrefixBatches + :: PendingModulePrefix + -> [CommittedDeclarationBatch] +pendingModulePrefixBatches + (PendingModulePrefix _ batchesReversed) = + reverse batchesReversed + +pendingModulePrefixCurrent + :: PendingModulePrefix + -> PrefixContextId +pendingModulePrefixCurrent + (PendingModulePrefix prefix _batches) = + prefix + +appendPendingBatch + :: CommittedDeclarationBatch + -> PendingModulePrefix + -> PendingModulePrefix +appendPendingBatch batch (PendingModulePrefix _ batches) = + forceCommittedBatch batch `seq` + PendingModulePrefix + (committedBatchNextPrefix batch) + (batch : batches) + +forceCommittedBatch :: CommittedDeclarationBatch -> () +forceCommittedBatch + (CommittedDeclarationBatch + owner slot previous next delta objects propositions + proofValidations declarationValidation) = + owner `seq` + slot `seq` + previous `seq` + next `seq` + ByteString.length + (encodeCache (putDeclarationInterfaceDeltaCache delta)) `seq` + objects `deepseq` + propositions `deepseq` + forceProofValidations proofValidations `seq` + forceDeclarationValidation declarationValidation + where + forceProofValidations = + foldl' + (\() record -> + proofValidationRecordKey record `seq` + ByteString.length + (encodeCache + (putValidationCertificateCache + (proofValidationRecordCertificate + record))) `seq` ()) + () + + forceDeclarationValidation = \case + Nothing -> () + Just record -> + declarationValidationRecordKey record `seq` + foldl' + (\() certificate -> + ByteString.length + (encodeCache + (putValidationCertificateCache + certificate)) `seq` ()) + () + (declarationValidationRecordCertificates record) + + +data VampireResolverMode + = SynchronousVampireResolution + (forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer))) + | AsynchronousVampireSubmission + (NonEmpty VampireSubmission + -> IO (NonEmpty Provers.VampireHandle)) + +data VampireResolver = VampireResolver !VampireResolverMode + +data VampireSubmission = VampireSubmission + !Location + !Provers.PreparedVerificationRequest + +vampireBatchResolver + :: (forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer))) + -> VampireResolver +vampireBatchResolver resolve = + VampireResolver (SynchronousVampireResolution resolve) + +-- | Production submission-only resolver. Retained-plan admission consumes +-- the submitted handles through its private synchronous replay resolver. +vampireSubmissionResolver + :: (NonEmpty VampireSubmission + -> IO (NonEmpty Provers.VampireHandle)) + -> VampireResolver +vampireSubmissionResolver submit = + VampireResolver (AsynchronousVampireSubmission submit) + +vampireResolver + :: (forall local origin. + Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + -> VampireResolver +vampireResolver resolve = + vampireBatchResolver (traverse resolve) + +resolveOneVampire + :: VampireResolver + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> ExceptT DeclarationError IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer) +resolveOneVampire resolver prepared = do + results@(result :| _) <- + liftIO (resolveSynchronousVampireBatch resolver (prepared :| [])) + void + (Except.liftEither + (validateVampireResolverResultCount 1 results)) + pure result + +resolveSynchronousVampireBatch + :: VampireResolver + -> NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) +resolveSynchronousVampireBatch + (VampireResolver mode) tasks = + case mode of + SynchronousVampireResolution resolve -> resolve tasks + AsynchronousVampireSubmission{} -> + throwIO + (PlanningIntegrityError + "asynchronous Vampire resolver reached synchronous admission") + +validateVampireResolverResultCount + :: Int + -> NonEmpty value + -> Either DeclarationError [value] +validateVampireResolverResultCount expected results + | expected == actual = + Right (NonEmpty.toList results) + | otherwise = + Left (VampireResolverBatchSizeMismatch expected actual) + where + actual = NonEmpty.length results + +data DriverState = DriverState + !VampireResolver + !LogicalBuilder + !PendingModulePrefix + !ValidationRun + +-- | Authority-free semantic state used while lowering checked declarations. +-- Existing admitted facts are projected to their public contracts; no +-- builder-local authorization capability crosses this boundary. +newtype ProspectiveBuilder = ProspectiveBuilder + (BuilderState PlanningEvidence) + +data LoweringState = LoweringState + !VampireResolver + !ProspectiveBuilder + !ValidationRun + +newtype LoweringDriver value = LoweringDriver + { runLoweringStep :: StateT LoweringState IO value + } + deriving newtype (Functor, Applicative, Monad) + +newtype ModuleDriver failure value = ModuleDriver + { runDriverStep + :: ExceptT + (DriverFailure failure) + (StateT DriverState IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +-- | Run one complete authority-free planning action from the current admitted +-- input projection. The prospective state advances throughout the action but +-- never mutates the authoritative module builder. +runProspectiveLoweringDriver + :: LoweringDriver value + -> ModuleDriver failure value +runProspectiveLoweringDriver action = ModuleDriver do + DriverState resolver builder _prefix validation <- State.get + State.lift + (liftIO + (State.evalStateT + (runLoweringStep action) + (LoweringState resolver + (projectLogicalBuilder builder) + validation))) + +projectLogicalBuilder :: LogicalBuilder -> ProspectiveBuilder +projectLogicalBuilder builder = + ProspectiveBuilder + builder + { logicalBuilderFacts = + fmap projectFact (logicalBuilderFacts builder) + } + where + projectFact (FactEntry proposition occurrence _authorization) = + FactEntry proposition occurrence + (PlanningEvidence + (semanticFactAuthority occurrence) + Nothing) + +data DriverFailure failure + = DriverDeclarationFailed !DeclarationError + | DriverActionFailed !failure + deriving stock (Show, Eq) + +data DriverResult failure value + = DriverSucceeded + !value + !SemanticInterface + !PendingModulePrefix + !CheckedObjectClosure + | DriverFailed + !(DriverFailure failure) + !PendingModulePrefix + | DriverSealFailed + !SemanticInterfaceError + !PendingModulePrefix + +data ImportedAliasOrigin = ImportedAliasOrigin + !DeclarationSlot + !SemanticFactOccurrenceFingerprint + deriving stock (Show, Eq) + +data ImportedAliasBinding = ImportedAliasBinding + !SemanticFactOccurrenceFingerprint + !ImportedAliasOrigin + +-- | Opaque evidence produced from a successfully sealed producer. Direct +-- parents retain the semantic DAG; importing folds it deterministically and +-- mints fresh authority for the consuming builder. +data ImportedModuleEvidence = ImportedModuleEvidence + !SemanticInterface + ![ImportedModuleEvidence] + !(Map + SemanticFactOccurrenceFingerprint + (SemanticFactOccurrence, CheckedPropositionContent)) + ![AssertedObject] + +freshImportedModuleEvidence + :: [ImportedModuleEvidence] + -> SemanticInterface + -> PendingModulePrefix + -> ImportedModuleEvidence +freshImportedModuleEvidence parents interface prefix = + ImportedModuleEvidence + interface + parents + (Map.fromList + [ ( semanticFactFingerprint occurrence + , (occurrence, requireProposition occurrence) + ) + | occurrence <- occurrences + ]) + objects + where + batches = pendingModulePrefixBatches prefix + objects = concatMap committedBatchObjects batches + propositions = concatMap committedBatchPropositions batches + propositionMap = + Map.fromList + [ (checkedPropositionId proposition, proposition) + | proposition <- propositions + ] + occurrences = + concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface) + + requireProposition occurrence = + case Map.lookup + (semanticFactProposition occurrence) + propositionMap of + Just proposition -> + proposition + Nothing -> + impossible + ("sealed fact occurrence references absent proposition " + <> show (semanticFactProposition occurrence)) + +-- | Construct import evidence after a trusted producer or validated store +-- installation has supplied the complete canonical proposition payloads. +validateImportedModuleEvidence + :: TheoryId + -> [ImportedModuleEvidence] + -> SemanticInterface + -> [AssertedObject] + -> [CheckedPropositionContent] + -> Either DeclarationError ImportedModuleEvidence +validateImportedModuleEvidence + theory parents interface objects propositions = do + _ <- first ImportedEvidenceInterfaceFailed + (validateSemanticInterface + (semanticInterfaceOwner interface) + (semanticInterfaceDirectInputs interface) + (semanticInterfaceDeclarations interface) + (semanticInterfaceAssertedId interface)) + unless + (semanticInterfaceDirectInputs interface == parentIds) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + parentIds)) + let propositionMap = + Map.fromList + [ (checkedPropositionId proposition, proposition) + | proposition <- propositions + ] + objectMap = + Map.fromList + [ (assertedObjectId object, object) + | object <- objects + ] + localObjectIds = + concatMap + declarationDeltaObjects + (semanticInterfaceDeclarations interface) + parentObjectMap = + foldl' + (Map.unionWith const) + Map.empty + (evidenceObjectMap <$> parents) + localObjects <- traverse + (\identity -> + maybe + (Left (ImportedEvidenceObjectMissing identity)) + Right + (Map.lookup identity objectMap)) + localObjectIds + closure <- first DeclarationObjectValidationFailed + (validateObjectClosure + theory + (Map.elems parentObjectMap <> localObjects)) + let occurrences = + concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface) + pairs <- traverse + (\occurrence -> do + proposition <- maybe + (Left + (ImportedEvidencePropositionMissing + (semanticFactProposition occurrence))) + Right + (Map.lookup + (semanticFactProposition occurrence) + propositionMap) + _ <- first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition))) + _ <- first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + theory + (semanticFactFingerprint occurrence) + occurrence + proposition + (semanticFactAuthority occurrence)) + pure + ( semanticFactFingerprint occurrence + , (occurrence, proposition) + )) + occurrences + let evidence = + ImportedModuleEvidence + interface + parents + (Map.fromList pairs) + localObjects + _ <- validateEvidenceInventory theory closure evidence + pure evidence + where + parentIds = + semanticInterfaceAssertedId . evidenceInterface <$> parents + +validateEvidenceInventory + :: TheoryId + -> CheckedObjectClosure + -> ImportedModuleEvidence + -> Either DeclarationError () +validateEvidenceInventory theory closure evidence = + do + void (foldEvidence Set.empty Map.empty Map.empty evidence) + (_seen, structures) <- + foldStructures Set.empty Map.empty evidence + void (foldGlobals structures Set.empty Map.empty evidence) + where + foldEvidence seen facts aliases current + | identity `Set.member` seen = + Right (seen, facts, aliases) + | otherwise = do + unless + (semanticInterfaceDirectInputs interface == parentIds) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + parentIds)) + (parentsSeen, parentFacts, parentAliases) <- + foldM + (\(seen', facts', aliases') parent -> + foldEvidence seen' facts' aliases' parent) + (seen, facts, aliases) + parents + localFacts <- foldM insertFact parentFacts (Map.elems entries) + localAliases <- foldM + (insertAlias localFacts) + parentAliases + [ ( alias + , ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias) + ) + | delta <- semanticInterfaceDeclarations interface + , alias <- declarationDeltaAliases delta + ] + pure + ( Set.insert identity parentsSeen + , localFacts + , localAliases + ) + where + ImportedModuleEvidence interface parents entries _objects = current + identity = semanticInterfaceAssertedId interface + parentIds = + semanticInterfaceAssertedId . evidenceInterface <$> parents + + insertFact facts pair@(occurrence, proposition) = do + let fingerprint = semanticFactFingerprint occurrence + _ <- first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + theory + fingerprint + occurrence + proposition + (semanticFactAuthority occurrence)) + case Map.lookup fingerprint facts of + Nothing -> + Right (Map.insert fingerprint pair facts) + Just (existingOccurrence, existingProposition) + | existingOccurrence == occurrence + && checkedPropositionId existingProposition + == checkedPropositionId proposition -> + Right facts + | otherwise -> + Left (ImportedFactCollision fingerprint) + + insertAlias facts aliases (alias, origin) = do + let name = semanticAliasName alias + target = semanticAliasTarget alias + unless + (Map.member target facts) + (Left (ImportedAliasTargetMissing target)) + case Map.lookup name aliases of + Nothing -> + Right + (Map.insert + name + (ImportedAliasBinding target origin) + aliases) + Just (ImportedAliasBinding existingTarget existingOrigin) + | existingTarget == target -> + Right aliases + | otherwise -> + Left + (ImportedAliasCollision + name existingOrigin origin) + + foldGlobals structures seen globals current + | identity `Set.member` seen = + Right (seen, globals) + | otherwise = do + (parentsSeen, parentGlobals) <- + foldM + (\(seen', globals') parent -> + foldGlobals structures seen' globals' parent) + (seen, globals) + parents + globals' <- + foldM + (insertGlobal + (structureOperationBindings structures)) + parentGlobals + [ binding + | delta <- semanticInterfaceDeclarations interface + , binding <- semanticEnvironmentBindings + (declarationDeltaEnvironment delta) + ] + pure (Set.insert identity parentsSeen, globals') + where + ImportedModuleEvidence interface parents _entries _objects = current + identity = semanticInterfaceAssertedId interface + + insertGlobal operationBindings globals binding = do + let key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + _ <- + first + (ImportedGlobalTargetInvalid key target) + (validateSemanticGlobalBindingTarget + operationBindings + closure binding) + case Map.lookup key globals of + Nothing -> Right (Map.insert key target globals) + Just existing + | existing == target -> Right globals + | otherwise -> + Left (ImportedGlobalCollision key existing target) + + foldStructures seen structures current + | identity `Set.member` seen = + Right (seen, structures) + | otherwise = do + (parentsSeen, parentStructures) <- + foldM + (\(seen', structures') parent -> + foldStructures seen' structures' parent) + (seen, structures) + parents + structures' <- + foldM + (insertSemanticStructure closure) + parentStructures + [ descriptor + | delta <- semanticInterfaceDeclarations interface + , descriptor <- semanticEnvironmentStructures + (declarationDeltaEnvironment delta) + ] + pure (Set.insert identity parentsSeen, structures') + where + ImportedModuleEvidence interface parents _entries _objects = current + identity = semanticInterfaceAssertedId interface + +evidenceInterface :: ImportedModuleEvidence -> SemanticInterface +evidenceInterface + (ImportedModuleEvidence interface _parents _entries _objects) = + interface + +evidenceObjectMap + :: ImportedModuleEvidence + -> Map ObjectId AssertedObject +evidenceObjectMap + (ImportedModuleEvidence _interface parents _entries objects) = + foldl' + (Map.unionWith const) + (Map.fromList + [ (assertedObjectId object, object) + | object <- objects + ]) + (evidenceObjectMap <$> parents) + +data DriverOpenError + = DriverInitialPrefixError !PrefixContextError + | DriverInitialObjectError !ObjectValidationError + deriving stock (Show, Eq) + +renderDriverOpenError :: DriverOpenError -> Text +renderDriverOpenError = \case + DriverInitialPrefixError{} -> + "the initial semantic prefix is inconsistent" + DriverInitialObjectError{} -> + "the initial object closure is inconsistent" + +runModuleDriver + :: CheckedFoundation + -> ModuleName + -> [SemanticInterfaceId] + -> VampireResolver + -> ValidationRun + -> ModuleDriver failure value + -> IO + (Either + DriverOpenError + (DriverResult failure value)) +runModuleDriver + foundation owner direct resolver validationRun action = do + unique <- BuilderIdentity <$> newUnique + let theory = theoryId foundation + case (,) <$> + first DriverInitialPrefixError + (initialPrefixContextId theory owner direct) + <*> + first DriverInitialObjectError + (validateObjectClosure theory []) of + Left err -> + pure (Left err) + Right (prefix, closure) -> do + let builder = + BuilderState + { logicalBuilderIdentity = unique + , logicalBuilderFoundation = foundation + , logicalBuilderTheory = theory + , logicalBuilderOwner = owner + , logicalBuilderDirectSemanticInputs = direct + , logicalBuilderPrefix = prefix + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = Map.empty + , logicalBuilderAliases = Map.empty + , logicalBuilderGlobals = Map.empty + , logicalBuilderStructures = Map.empty + , logicalBuilderImportedInterfaces = Set.empty + , logicalBuilderDeltas = [] + , logicalBuilderNextDeclaration = 0 + , logicalBuilderNextFact = 0 + , logicalBuilderNextInvocation = 0 + } + initialState = + DriverState + resolver + builder + (PendingModulePrefix prefix []) + validationRun + (result, DriverState _ finalBuilder finalPrefix _) <- + State.runStateT + (Except.runExceptT + (runDriverStep action)) + initialState + case result of + Left err -> + pure (Right (DriverFailed err finalPrefix)) + Right value -> do + case semanticInterface + owner + direct + (reverse + (logicalBuilderDeltas + finalBuilder)) of + Left err -> + pure + (Right + (DriverSealFailed + err + finalPrefix)) + Right interface -> + pure + (Right + (DriverSucceeded + value + interface + finalPrefix + (logicalBuilderObjectClosure + finalBuilder))) + +failModuleDriver :: failure -> ModuleDriver failure value +failModuleDriver err = + ModuleDriver + (Except.throwError + (DriverActionFailed err)) + +failDeclarationDriver :: DeclarationError -> ModuleDriver failure value +failDeclarationDriver err = + ModuleDriver (Except.throwError (DriverDeclarationFailed err)) + +nextDeclarationSlotDriver + :: ModuleDriver failure DeclarationSlot +nextDeclarationSlotDriver = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + (declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder))) + +currentTheoryDriver :: ModuleDriver failure TheoryId +currentTheoryDriver = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + logicalBuilderTheory builder)) + +currentFoundationAxiomDriver + :: FoundationAxiomTag + -> ModuleDriver failure (FrozenCheckedCore Void) +currentFoundationAxiomDriver tag = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag)) + +resolveVisibleFactAliasDriver + :: SemanticName + -> ModuleDriver failure + (Maybe SemanticFactOccurrenceFingerprint) +resolveVisibleFactAliasDriver alias = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure do + ImportedAliasBinding fingerprint _origin <- + Map.lookup alias (logicalBuilderAliases builder) + pure fingerprint + +resolveVisibleFactTargetsDriver + :: FrozenCheckedCore ObjectId + -> ModuleDriver failure + [SemanticFactOccurrenceFingerprint] +resolveVisibleFactTargetsDriver target = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + [ fingerprint + | (fingerprint, FactEntry proposition _occurrence _authorization) <- + Map.toAscList (logicalBuilderFacts builder) + , checkedPropositionTerm proposition == target + ] + +resolveVisibleGlobalDriver + :: SemanticGlobalKey + -> ModuleDriver failure (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobalDriver key = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + ( (\(target, _content, _dependencies) -> + ( target + , fromMaybe + (impossible "visible semantic key has no source type") + (semanticGlobalKeyType key) + )) + <$> resolveVisibleGlobalContent builder key + ) + +resolveVisibleGlobalContentDriver + :: SemanticGlobalKey + -> ModuleDriver failure + (Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + )) +resolveVisibleGlobalContentDriver key = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure (resolveVisibleGlobalContent builder key) + +resolveVisibleStructureDriver + :: SemanticStructurePhrase + -> ModuleDriver failure (Maybe ResolvedStructure) +resolveVisibleStructureDriver structurePhrase = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure (Map.lookup structurePhrase (logicalBuilderStructures builder)) + +resolveVisibleStructureOperationObjectsDriver + :: StructSymbol + -> ModuleDriver failure [ObjectId] +resolveVisibleStructureOperationObjectsDriver symbol = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + ( Set.toAscList + (Set.fromList + (mapMaybe + (resolvedStructureOperation symbol) + (Map.elems (logicalBuilderStructures builder)))) + ) + +resolveVisibleGlobalContent + :: BuilderState evidence + -> SemanticGlobalKey + -> Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + ) +resolveVisibleGlobalContent builder key = do + target <- Map.lookup key (logicalBuilderGlobals builder) + content <- + lookupCheckedObjectContent + (semanticGlobalTargetObject target) + closure + let dependencies = + Map.fromList + [ (identity, requireDependency identity) + | identity <- case content of + TransparentObjectContent _theory _coreType body -> + Set.toAscList (canonicalTermGlobals body) + _ -> [] + ] + pure + ( target + , content + , dependencies + ) + where + closure = logicalBuilderObjectClosure builder + + requireDependency identity = + case lookupCheckedObjectType identity closure of + Just coreType -> coreType + Nothing -> + impossible "checked object dependency is absent" + +objectAvailableDriver + :: ObjectId + -> ModuleDriver failure Bool +objectAvailableDriver identity = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + isJust + (lookupCheckedObjectType + identity + (logicalBuilderObjectClosure builder)))) + +objectTypeDriver + :: ObjectId + -> ModuleDriver failure (Maybe CoreType) +objectTypeDriver identity = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + lookupCheckedObjectType + identity + (logicalBuilderObjectClosure builder))) + +nextDeclarationSlotLowering :: LoweringDriver DeclarationSlot +nextDeclarationSlotLowering = + withLoweringBuilder \builder -> + declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + +currentTheoryLowering :: LoweringDriver TheoryId +currentTheoryLowering = + withLoweringBuilder logicalBuilderTheory + +currentFoundationLowering :: LoweringDriver CheckedFoundation +currentFoundationLowering = + withLoweringBuilder logicalBuilderFoundation + +currentFoundationAxiomLowering + :: FoundationAxiomTag + -> LoweringDriver (FrozenCheckedCore Void) +currentFoundationAxiomLowering tag = + withLoweringBuilder + (\builder -> + foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag) + +resolveVisibleFactAliasLowering + :: SemanticName + -> LoweringDriver (Maybe SemanticFactOccurrenceFingerprint) +resolveVisibleFactAliasLowering alias = + withLoweringBuilder \builder -> do + ImportedAliasBinding fingerprint _origin <- + Map.lookup alias (logicalBuilderAliases builder) + pure fingerprint + +resolveVisibleFactTargetsLowering + :: FrozenCheckedCore ObjectId + -> LoweringDriver [SemanticFactOccurrenceFingerprint] +resolveVisibleFactTargetsLowering target = + withLoweringBuilder \builder -> + [ fingerprint + | (fingerprint, FactEntry proposition _occurrence _evidence) <- + Map.toAscList (logicalBuilderFacts builder) + , checkedPropositionTerm proposition == target + ] + +resolveVisibleGlobalLowering + :: SemanticGlobalKey + -> LoweringDriver (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobalLowering key = + withLoweringBuilder \builder -> + ( (\(target, _content, _dependencies) -> + ( target + , fromMaybe + (impossible "visible semantic key has no source type") + (semanticGlobalKeyType key) + )) + <$> resolveVisibleGlobalContent builder key + ) + +resolveVisibleGlobalContentLowering + :: SemanticGlobalKey + -> LoweringDriver + (Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + )) +resolveVisibleGlobalContentLowering key = + withLoweringBuilder (\builder -> resolveVisibleGlobalContent builder key) + +resolveVisibleStructureLowering + :: SemanticStructurePhrase + -> LoweringDriver (Maybe ResolvedStructure) +resolveVisibleStructureLowering phrase = + withLoweringBuilder (Map.lookup phrase . logicalBuilderStructures) + +resolveVisibleStructureOperationObjectsLowering + :: StructSymbol + -> LoweringDriver [ObjectId] +resolveVisibleStructureOperationObjectsLowering symbol = + withLoweringBuilder \builder -> + Set.toAscList + (Set.fromList + (mapMaybe + (resolvedStructureOperation symbol) + (Map.elems (logicalBuilderStructures builder)))) + +objectAvailableLowering :: ObjectId -> LoweringDriver Bool +objectAvailableLowering identity = + withLoweringBuilder + (isJust + . lookupCheckedObjectType identity + . logicalBuilderObjectClosure) + +objectTypeLowering :: ObjectId -> LoweringDriver (Maybe CoreType) +objectTypeLowering identity = + withLoweringBuilder + (lookupCheckedObjectType identity + . logicalBuilderObjectClosure) + +withLoweringBuilder + :: (BuilderState PlanningEvidence -> value) + -> LoweringDriver value +withLoweringBuilder action = LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- State.get + pure (action builder) + + +data CandidateSpec = CandidateSpec + !CheckedPropositionContent + !FactSearchEligibility + ![SemanticName] + +candidateSpec + :: CheckedPropositionContent + -> FactSearchEligibility + -> [SemanticName] + -> CandidateSpec +candidateSpec = + CandidateSpec + +-- | One strictly earlier candidate in the same checked declaration. The +-- position is structural and becomes a concrete fact slot only while the +-- declaration is planned. +data PlannedCandidatePosition = PlannedCandidatePosition + !Natural + !Natural + deriving stock (Show, Eq, Ord) + +data CandidatePlanningDirect + = PlanningDefinitionEquation !ObjectId + | PlanningSourceAxiom + | PlanningTrustedDatatype !DatatypeCompilationDescriptor + | PlanningKernelConstruction !KernelConstructionDescriptor + | PlanningCheckedSourceProof + | PlanningOmitted + deriving stock (Show, Eq) + +-- | Erased exact request data needed by scheduling and public-contract +-- planning. The family body retains the typed obligation used by admission; +-- this projection carries only its one canonical request and exact global +-- premise fingerprints. +data CheckedPlannedVampireRequest = CheckedPlannedVampireRequest + !Location + !Provers.PreparedVerificationRequest + ![SemanticFactOccurrenceFingerprint] + +data CandidatePlanningSpec = CandidatePlanningSpec + !CandidatePlanningDirect + ![SemanticFactOccurrenceFingerprint] + ![PlannedCandidatePosition] + ![CheckedPlannedVampireRequest] + +-- | One authority-free checked candidate and its exact planning contract. +-- The two parts are constructed together by the declaration-family lowerer +-- and retain no builder capability or publication path. +data CheckedCandidate = CheckedCandidate + !CandidateSpec + !CandidatePlanningSpec + +checkedCandidate + :: CandidateSpec + -> CandidatePlanningSpec + -> CheckedCandidate +checkedCandidate = CheckedCandidate + +checkedDefinitionEquationPlanning :: ObjectId -> CandidatePlanningSpec +checkedDefinitionEquationPlanning identity = + CandidatePlanningSpec + (PlanningDefinitionEquation identity) [] [] [] + +checkedSourceAxiomPlanning :: CandidatePlanningSpec +checkedSourceAxiomPlanning = + CandidatePlanningSpec PlanningSourceAxiom [] [] [] + +checkedDatatypePlanning + :: DatatypeCompilationDescriptor + -> CandidatePlanningSpec +checkedDatatypePlanning descriptor = + CandidatePlanningSpec (PlanningTrustedDatatype descriptor) [] [] [] + +checkedKernelPlanning + :: KernelConstructionDescriptor + -> [SemanticFactOccurrenceFingerprint] + -> CandidatePlanningSpec +checkedKernelPlanning descriptor facts = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + facts + [] + [] + +checkedKernelPlanningWithStaged + :: KernelConstructionDescriptor + -> [SemanticFactOccurrenceFingerprint] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedKernelPlanningWithStaged descriptor facts staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + facts + staged + [] + +checkedStagedKernelPlanning + :: KernelConstructionDescriptor + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedStagedKernelPlanning descriptor staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + [] + staged + [] + +checkedSourceProofPlanning + :: [CheckedPlannedVampireRequest] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedSourceProofPlanning requests staged = + CandidatePlanningSpec + PlanningCheckedSourceProof [] staged requests + +checkedOmittedPlanning + :: [CheckedPlannedVampireRequest] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedOmittedPlanning requests staged = + CandidatePlanningSpec PlanningOmitted [] staged requests + +checkedPlannedVampireRequest + :: Location + -> PreparedVampireObligation local origin + -> CheckedPlannedVampireRequest +checkedPlannedVampireRequest location + (PreparedVampireObligation expected task) = + CheckedPlannedVampireRequest + location + (Provers.preparedTypedProverRequest task) + ( Backend.typedBackendFactReference + <$> Vector.toList + (Backend.typedProblemGlobalPremises expected) + ) + +plannedEarlierCandidate + :: Natural + -> Natural + -> PlannedCandidatePosition +plannedEarlierCandidate = + PlannedCandidatePosition + +data CheckedDeclarationMode + = CheckedProofMode !ProofSyntaxId + | CheckedCompiledMode !DeclarationSyntaxId + +-- | One completely lowered, authority-free declaration transaction. The +-- family body is a closed checked authorization recipe owned by its exact +-- lowerer; structural effects and stable source-ordered candidate stages are +-- common. This value is invocation-local and never serialized. +data CheckedDeclaration body = CheckedDeclaration + !CheckedDeclarationMode + ![AssertedObject] + ![CheckedPropositionContent] + ![SemanticGlobalBinding] + ![SemanticStructureDescriptor] + ![NonEmpty CheckedCandidate] + !body + +checkedProofDeclaration + :: ProofSyntaxId + -> [AssertedObject] + -> [CheckedPropositionContent] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> [NonEmpty CheckedCandidate] + -> body + -> CheckedDeclaration body +checkedProofDeclaration + syntax objects propositions globals structures stages = + CheckedDeclaration + (CheckedProofMode syntax) objects propositions globals structures + stages + +checkedCompiledDeclaration + :: DeclarationSyntaxId + -> [AssertedObject] + -> [CheckedPropositionContent] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> [NonEmpty CheckedCandidate] + -> body + -> CheckedDeclaration body +checkedCompiledDeclaration + syntax objects propositions globals structures stages = + CheckedDeclaration + (CheckedCompiledMode syntax) objects propositions globals structures + stages + +prepareCandidateSpecDriver + :: [AssertedObject] + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareCandidateSpecDriver objects scoped eligibility aliases = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareScopedCandidateSpec + closure scoped eligibility aliases) + +prepareFrozenCandidateSpecDriver + :: [AssertedObject] + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareFrozenCandidateSpecDriver objects frozen eligibility aliases = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareFrozenCandidateSpec + closure frozen eligibility aliases) + +prepareDefinitionEquationSpecDriver + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecDriver objects identity alias = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareDefinitionEquationSpec closure identity alias) + +preparePointwiseDefinitionEquationSpecDriver + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +preparePointwiseDefinitionEquationSpecDriver objects identity alias = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + preparePointwiseDefinitionEquationSpec closure identity alias) + +prepareCandidateSpecLowering + :: [AssertedObject] + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareCandidateSpecLowering objects scoped eligibility aliases = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareScopedCandidateSpec + closure scoped eligibility aliases) + +prepareFrozenCandidateSpecLowering + :: [AssertedObject] + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareFrozenCandidateSpecLowering objects frozen eligibility aliases = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareFrozenCandidateSpec + closure frozen eligibility aliases) + +prepareDefinitionEquationSpecLowering + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecLowering objects identity alias = + prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibilityLowering + :: [AssertedObject] + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecWithEligibilityLowering + objects identity eligibility alias = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias) + +-- | Prepare the unaliased first-order view of one checked, named set +-- construction. The returned descriptor binds direct authorization to the +-- transparent object and the complete checked source decomposition. +prepareNamedSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> NamedSetConstruction ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareNamedSetConstructionSpecLowering objects identity construction = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareNamedSetConstruction + (logicalBuilderFoundation builder) + closure identity construction + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) + +prepareRelationalSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareRelationalSetConstructionSpecLowering + objects identity construction functionality = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + closure identity construction functionality + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) + +preparePointwiseDefinitionEquationSpecLowering + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +preparePointwiseDefinitionEquationSpecLowering objects identity alias = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + preparePointwiseDefinitionEquationSpec closure identity alias) + +-- | Prepare one closed Vampire obligation whose only premise is a +-- conditionally available fact from a strictly earlier candidate stage of +-- the same declaration. The temporary checked stage contains public fact +-- semantics and structural provenance only; admission must still consume the +-- corresponding real reserved candidate before accepting this request. +prepareStagedCandidateVampireDriver + :: Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> ModuleDriver failure + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireDriver + location objects premiseSpec targetSpec = + ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + State.lift + (liftIO + (prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec)) + +prepareStagedCandidateVampireLowering + :: Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> LoweringDriver + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireLowering + location objects premiseSpec targetSpec = + LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- + State.get + liftIO + (prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec) + +prepareStagedCandidateVampireWith + :: BuilderState evidence + -> Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> IO + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec = do + let staged = do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + premise <- + prospectiveStagePremise + builder closure premiseSpec targetSpec + pure (closure, premise) + case staged of + Left failure -> pure (Left failure) + Right (closure, premise) -> do + prepared <- + forceVampirePreparation + (prepareClosedCandidateVampire + builder closure + (candidateSpecProposition targetSpec) + [premise]) + pure + (first + (ProofObligationFailedAt location + . CurrentCandidateVampirePreparationFailed) + prepared) + +candidateSpecProposition :: CandidateSpec -> CheckedPropositionContent +candidateSpecProposition (CandidateSpec proposition _eligibility _aliases) = + proposition + +prospectiveStagePremise + :: BuilderState evidence + -> CheckedObjectClosure + -> CandidateSpec + -> CandidateSpec + -> Either DeclarationError CheckedPropositionContent +prospectiveStagePremise builder closure premiseSpec targetSpec = do + let owner = logicalBuilderOwner builder + declaration = + declarationSlot owner + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + premiseSlot = + factSlot owner + (localFactOrdinal (logicalBuilderNextFact builder)) + targetSlot = + factSlot owner + (localFactOrdinal (logicalBuilderNextFact builder + 1)) + premiseStage = CandidateStage 0 + targetStage = CandidateStage 1 + proposition = candidateSpecProposition premiseSpec + authority = + factAuthority + (theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId proposition)) + cleanAuthoritySafety + CandidateSpec _ eligibility _aliases = premiseSpec + occurrence = + semanticFactOccurrence premiseSlot authority eligibility + stage = + CheckedDeclarationStage declaration closure + (Map.singleton premiseSlot + (FactEntry proposition occurrence + (PlanningEvidence + authority + (Just + (PlanningProvenance + declaration premiseStage premiseSlot))))) + unless + (propositionMatchesClosure closure + (candidateSpecProposition targetSpec)) + (Left (PlanningFactContractMismatch targetSlot)) + useProspectiveStageFact + stage targetStage targetSlot premiseStage premiseSlot + +useProspectiveStageFact + :: CheckedDeclarationStage + -> CandidateStage + -> FactSlot + -> CandidateStage + -> FactSlot + -> Either DeclarationError CheckedPropositionContent +useProspectiveStageFact + (CheckedDeclarationStage ownSlot closure entries) + currentStage currentSlot expectedStage premiseSlot = do + FactEntry proposition occurrence + (PlanningEvidence authority provenance) <- + maybe + (Left (PlanningFactContractMismatch premiseSlot)) + Right + (Map.lookup premiseSlot entries) + unless + ( provenance + == Just + (PlanningProvenance + ownSlot expectedStage premiseSlot) + && expectedStage < currentStage + && semanticFactSlot occurrence == premiseSlot + && semanticFactAuthority occurrence == authority + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch currentSlot)) + pure proposition + +prepareCandidateSpecWithDriverClosure + :: [AssertedObject] + -> (CheckedObjectClosure -> Either DeclarationError CandidateSpec) + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareCandidateSpecWithDriverClosure objects prepare = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + prepare closure + +prepareCandidateSpecWithLoweringClosure + :: [AssertedObject] + -> (CheckedObjectClosure -> Either DeclarationError value) + -> LoweringDriver (Either DeclarationError value) +prepareCandidateSpecWithLoweringClosure objects prepare = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + prepare closure + +data ReservedCandidate = ReservedCandidate + !BuilderIdentity + !PrefixContextId + !DeclarationInvocation + !CandidateStage + !FactSlot + !CandidateSpec + +reservedCandidateSlot :: ReservedCandidate -> FactSlot +reservedCandidateSlot + (ReservedCandidate _ _ _ _ slot _) = + slot + +reservedCandidateStage :: ReservedCandidate -> Natural +reservedCandidateStage + (ReservedCandidate _ _ _ (CandidateStage stage) _ _) = + stage + +candidateCheckedProposition + :: ReservedCandidate + -> CheckedPropositionContent +candidateCheckedProposition + (ReservedCandidate _ _ _ _ _ (CandidateSpec proposition _ _)) = + proposition + +candidateTheoremReference + :: BuilderState evidence + -> ReservedCandidate + -> TheoremRef +candidateTheoremReference builder candidate = + theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId + (candidateCheckedProposition candidate)) + + +data PendingCandidate = PendingCandidate + !ReservedCandidate + !ValidationCertificate + !PendingFactAuthorization + +data DeclarationValidationSelection + = DeclarationValidationUnselected + | FreshDeclarationValidation + | CachedDeclarationValidation + !DeclarationSyntaxId + ![ObjectId] + ![TheoremId] + !DeclarationValidationRecord + !(Map FactSlot Natural) + +data DeclarationState = DeclarationState + { declarationVampireResolver :: !VampireResolver + , declarationValidationRun :: !ValidationRun + , declarationValidationMode :: !ValidationMode + , declarationValidationSelection + :: !DeclarationValidationSelection + , declarationBuilder :: !LogicalBuilder + , declarationOwnSlot :: !DeclarationSlot + , declarationInvocation :: !DeclarationInvocation + , declarationObjectsReversed :: ![AssertedObject] + , declarationObjectClosure :: !(Maybe CheckedObjectClosure) + , declarationPropositionsReversed + :: ![CheckedPropositionContent] + , declarationGlobalBindingsReversed + :: ![SemanticGlobalBinding] + , declarationStructureDescriptorsReversed + :: ![SemanticStructureDescriptor] + , declarationReservations + :: !(Map FactSlot ReservedCandidate) + , declarationPending :: !(Map FactSlot PendingCandidate) + , declarationNextFact :: !Natural + , declarationNextStage :: !Natural + , declarationAuthorizationFrontier :: !Natural + } + +-- | Authority-free view of checked declaration-local semantics. This is the +-- narrow staging substrate for later lowerers: it carries the exact object +-- closure and conditional public fact contracts, but no builder identity, +-- prefix, invocation, pending authorization, admitted alias, or published +-- occurrence. +data CheckedDeclarationStage = CheckedDeclarationStage + !DeclarationSlot + !CheckedObjectClosure + !(Map FactSlot (FactEntry PlanningEvidence)) + +newtype Declaration value = Declaration + { runDeclaration + :: StateT + DeclarationState + (ExceptT DeclarationError IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +failDeclaration :: DeclarationError -> Declaration value +failDeclaration = + Declaration . State.lift . Except.throwError + +addDeclarationObject :: AssertedObject -> Declaration () +addDeclarationObject asserted = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + when + (isJust (declarationObjectClosure state)) + (State.lift + (Except.throwError + DeclarationObjectAddedAfterAuthorization)) + State.put + state + { declarationObjectsReversed = + asserted : declarationObjectsReversed state + } + +addDeclarationProposition + :: CheckedPropositionContent + -> Declaration () +addDeclarationProposition proposition = + Declaration + (State.modify' \state -> + state + { declarationPropositionsReversed = + proposition + : declarationPropositionsReversed state + }) + +resolveVisibleGlobal + :: SemanticGlobalKey + -> Declaration (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobal key = Declaration do + state <- State.get + let builder = declarationBuilder state + pure do + target <- Map.lookup key (logicalBuilderGlobals builder) + coreType <- semanticGlobalKeyType key + pure (target, coreType) + +stageSemanticGlobalBinding + :: SemanticGlobalKey + -> SemanticGlobalTarget + -> Declaration () +stageSemanticGlobalBinding key target = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + when + (any + ((== key) . semanticGlobalBindingKey) + (declarationGlobalBindingsReversed state)) + (State.lift + (Except.throwError + (DeclarationGlobalAlreadyStaged key))) + State.put + state + { declarationGlobalBindingsReversed = + semanticGlobalBinding key target + : declarationGlobalBindingsReversed state + } + +stageSemanticStructureDescriptor + :: SemanticStructureDescriptor + -> Declaration () +stageSemanticStructureDescriptor descriptor = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + let structurePhrase = semanticStructureDescriptorPhrase descriptor + when + (any + ((== structurePhrase) . semanticStructureDescriptorPhrase) + (declarationStructureDescriptorsReversed state)) + (State.lift + (Except.throwError + (DeclarationStructureAlreadyStaged structurePhrase))) + State.put + state + { declarationStructureDescriptorsReversed = + descriptor + : declarationStructureDescriptorsReversed state + } + +prepareScopedCandidateSpec + :: CheckedObjectClosure + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Either DeclarationError CandidateSpec +prepareScopedCandidateSpec closure scoped eligibility aliases = do + frozen <- + maybe (Left CandidatePropositionNotClosed) Right + (closeScopedCore scoped) + prepareFrozenCandidateSpec closure frozen eligibility aliases + +prepareFrozenCandidateSpec + :: CheckedObjectClosure + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Either DeclarationError CandidateSpec +prepareFrozenCandidateSpec closure frozen eligibility aliases = do + unless + (frozenCoreType frozen == TyProp) + (Left + (CandidatePropositionNotProposition + (frozenCoreType frozen))) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent closure (frozenCoreTerm frozen)) + pure (candidateSpec proposition eligibility aliases) + +prepareDefinitionEquationSpec + :: CheckedObjectClosure + -> ObjectId + -> SemanticName + -> Either DeclarationError CandidateSpec +prepareDefinitionEquationSpec closure identity alias = do + prepareDefinitionEquationSpecWithEligibility + closure identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibility + :: CheckedObjectClosure + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> Either DeclarationError CandidateSpec +prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias = do + content <- + maybe + (Left (DefinitionEquationObjectMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + (coreType, body) <- + case content of + TransparentObjectContent _theory objectType objectBody -> + Right (objectType, objectBody) + _ -> + Left (DefinitionEquationObjectNotTransparent identity) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent + closure + (CEq coreType (CGlobal identity) body)) + pure (candidateSpec proposition eligibility [alias]) + +prepareNamedSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> NamedSetConstruction ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareNamedSetConstruction foundation closure identity construction = do + let expectedContent = namedSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction) + pure + ( namedSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (namedSetConstructionFactDescriptor derived) + ) + +prepareRelationalSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareRelationalSetConstruction + foundation closure identity construction functionality = do + let expectedContent = relationalSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (relationalSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction + functionality) + pure + ( relationalSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (relationalSetConstructionFactDescriptor derived) + ) + +preparePointwiseDefinitionEquationSpec + :: CheckedObjectClosure + -> ObjectId + -> SemanticName + -> Either DeclarationError CandidateSpec +preparePointwiseDefinitionEquationSpec closure identity alias = do + content <- + maybe + (Left (DefinitionEquationObjectMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + body <- + case content of + TransparentObjectContent _theory + (TyArrow TySet TyProp) (CLam TySet predicate) -> + Right predicate + _ -> + Left + (DefinitionEquationObjectNotPointwisePredicate identity) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent + closure + (CForall TySet + (CEq TyProp + (CApp (CGlobal identity) (CBound 0)) + body))) + pure (candidateSpec proposition SearchEligible [alias]) + +reserveCandidate + :: CandidateSpec + -> Declaration ReservedCandidate +reserveCandidate spec = + NonEmpty.head <$> reserveCandidateBatch (spec :| []) + +-- | Validate and reserve one closed checked proposition in the current +-- declaration closure. +reservePropositionCandidate + :: ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Declaration ReservedCandidate +reservePropositionCandidate scoped eligibility aliases = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (prepareScopedCandidateSpec + (fromMaybe + (impossible + "prepared proposition closure is absent") + (declarationObjectClosure prepared)) + scoped eligibility aliases)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Validate and reserve one stage of already closed checked propositions in +-- the current declaration closure. +reserveFrozenPropositionCandidateBatch + :: NonEmpty + ( FrozenCheckedCore ObjectId + , FactSearchEligibility + , [SemanticName] + ) + -> Declaration (NonEmpty ReservedCandidate) +reserveFrozenPropositionCandidateBatch inputs = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let closure = + maybe + (impossible "prepared proposition closure is absent") + id + (declarationObjectClosure prepared) + specs <- traverse (prepareInput closure) inputs + State.put prepared + runDeclaration (reserveCandidateBatch specs) + where + prepareInput closure (frozen, eligibility, aliases) = + State.lift + (Except.liftEither + (prepareFrozenCandidateSpec + closure frozen eligibility aliases)) + +reserveCandidateBatch + :: NonEmpty CandidateSpec + -> Declaration (NonEmpty ReservedCandidate) +reserveCandidateBatch specs = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + let builder = declarationBuilder state + stage = CandidateStage (declarationNextStage state) + firstFact = declarationNextFact state + candidates = + NonEmpty.zipWith + (makeReserved builder state stage) + (0 :| [1 ..]) + specs + reservations' = + foldl' + (\reservations candidate -> + Map.insert + (reservedCandidateSlot candidate) + candidate + reservations) + (declarationReservations state) + candidates + candidateCount = fromIntegral (NonEmpty.length specs) + State.put + state + { declarationReservations = reservations' + , declarationNextFact = firstFact + candidateCount + , declarationNextStage = + declarationNextStage state + 1 + } + pure candidates + where + makeReserved builder state stage offset spec = + ReservedCandidate + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + (declarationInvocation state) + stage + (factSlot + (logicalBuilderOwner builder) + (localFactOrdinal + (declarationNextFact state + offset))) + spec + +-- | Construct the one defining equation owned by a checked transparent +-- object. The equation is derived from authoritative object content, not from +-- a caller-supplied proposition. +reserveDefinitionEquationCandidate + :: ObjectId + -> SemanticName + -> Declaration ReservedCandidate +reserveDefinitionEquationCandidate identity alias = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (prepareDefinitionEquationSpec + (fromMaybe + (impossible + "prepared definition closure is absent") + (declarationObjectClosure prepared)) + identity alias)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Construct the pointwise presentation of one unary transparent predicate +-- definition. The candidate remains tied to the object's checked content. +reservePointwiseDefinitionEquationCandidate + :: ObjectId + -> SemanticName + -> Declaration ReservedCandidate +reservePointwiseDefinitionEquationCandidate identity alias = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (preparePointwiseDefinitionEquationSpec + (fromMaybe + (impossible "prepared predicate closure is absent") + (declarationObjectClosure prepared)) + identity alias)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Reserve one defining equation and a nonempty generated-fact batch at the +-- same declaration stage. No candidate in the batch can cite a sibling. +reserveDefinitionEquationCandidateBatch + :: ObjectId + -> SemanticName + -> NonEmpty + ( ScopedCheckedCore ObjectId + , FactSearchEligibility + , [SemanticName] + ) + -> Declaration + ( ReservedCandidate + , NonEmpty ReservedCandidate + ) +reserveDefinitionEquationCandidateBatch identity alias generated = + Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let closure = + maybe + (impossible + "prepared declaration closure is absent") + id + (declarationObjectClosure prepared) + definition <- + State.lift + (Except.liftEither + (prepareDefinitionEquationSpec closure identity alias)) + generatedSpecs <- + traverse + (prepareGeneratedSpec closure) + generated + State.put prepared + candidates <- + runDeclaration + (reserveCandidateBatch + (definition :| toList generatedSpecs)) + case candidates of + definitionCandidate :| firstGenerated : remainingGenerated -> + pure + ( definitionCandidate + , firstGenerated :| remainingGenerated + ) + _ -> + impossible + "a nonempty generated batch produced no candidate" + where + prepareGeneratedSpec closure (scoped, eligibility, aliases) = + State.lift + (Except.liftEither + (prepareScopedCandidateSpec + closure scoped eligibility aliases)) + +-- | Resolve one complete compiled declaration against its exact validation +-- key, then run the source-level authorization action under that selection. +-- Objects and candidates must already be prepared so the lookup key cannot +-- change after a hit or miss is chosen. +authorizeCompiledDeclaration + :: Declaration value + -> Declaration value +authorizeCompiledDeclaration action = Declaration do + unprepared <- State.get + (syntax, objects, theorems, ordinals, prepared) <- + State.lift + (Except.liftEither + (prepareCompiledValidation unprepared)) + let key = + declarationValidationKey + syntax + (logicalBuilderPrefix + (declarationBuilder prepared)) + objects + theorems + cached <- + case declarationValidationRun prepared of + FreshValidation -> + pure Nothing + WarmValidation + (ValidationLookup _lookupProof lookupDeclaration) -> + liftIO (lookupDeclaration key) + traverse_ + (\record -> + case Materialization.checkDeclarationValidationRecord + (logicalBuilderPrefix + (declarationBuilder prepared)) + syntax + objects + theorems + record of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> + pure ()) + cached + let selection = + case cached of + Nothing -> + FreshDeclarationValidation + Just record -> + CachedDeclarationValidation + syntax objects theorems record ordinals + State.put + prepared + { declarationValidationSelection = selection + } + runDeclaration action + +prepareCompiledValidation + :: DeclarationState + -> Either + DeclarationError + ( DeclarationSyntaxId + , [ObjectId] + , [TheoremId] + , Map FactSlot Natural + , DeclarationState + ) +prepareCompiledValidation declaration = do + syntax <- + case declarationValidationMode declaration of + DeclarationValidationMode value -> + Right value + _ -> + Left DeclarationValidationOutsideCompiledDeclaration + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> pure () + _ -> Left DeclarationValidationAlreadySelected + closure <- declarationClosure declaration + let builder = declarationBuilder declaration + candidates = Map.elems (declarationReservations declaration) + objects = + assertedObjectId + <$> reverse + (declarationObjectsReversed declaration) + theorems = + theoremId . candidateTheoremReference builder + <$> candidates + ordinals = + Map.fromList + (zip + (reservedCandidateSlot <$> candidates) + [0 ..]) + pure + ( syntax + , objects + , theorems + , ordinals + , declaration + { declarationObjectClosure = Just closure + } + ) + +lookupProofValidation + :: ReservedCandidate + -> Declaration (ProofSyntaxId, Maybe ProofValidationRecord) +lookupProofValidation candidate = Declaration do + state <- State.get + syntax <- + case declarationValidationMode state of + EnvironmentImportMode -> + State.lift + (Except.throwError + ProofValidationOutsideProofDeclaration) + ProofValidationMode proofSyntax -> + pure proofSyntax + DeclarationValidationMode{} -> + State.lift + (Except.throwError + ProofValidationOutsideProofDeclaration) + let builder = declarationBuilder state + reference = candidateTheoremReference builder candidate + key = + proofValidationKey + (theoremId + (factAuthorityTheorem + (factAuthority + reference + cleanAuthoritySafety))) + syntax + (logicalBuilderPrefix builder) + record <- + case declarationValidationRun state of + FreshValidation -> + pure Nothing + WarmValidation (ValidationLookup lookupProof _lookupDeclaration) -> + State.lift + (liftIO + (lookupProof key)) + pure (syntax, record) +data CandidatePremise = CandidatePremise + !CheckedPropositionContent + +data CandidateProofState = CandidateProofState + { candidateProofDeclaration :: !DeclarationState + , candidateProofObjectClosure :: !CheckedObjectClosure + , candidateProofCandidate :: !ReservedCandidate + , candidateProofCachedValidation + :: !(Maybe Materialization.CandidateValidation) + , candidateProofPremisesReversed :: ![CandidatePremise] + , candidateProofPremiseCount :: !Natural + , candidateProofSafety :: !CandidateSafety + , candidateProofAcceptedRequestsReversed + :: ![PreparedRequestId] + } + +candidateProofBuilder :: CandidateProofState -> LogicalBuilder +candidateProofBuilder = + declarationBuilder . candidateProofDeclaration + +newtype CandidateProof value = CandidateProof + { runCandidateProof + :: StateT + CandidateProofState + (ExceptT DeclarationError IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +-- | Attach source trivia to a proof-obligation failure. The location does +-- not participate in validation or request identity. +locateProofObligation + :: Location + -> CandidateProof value + -> CandidateProof value +locateProofObligation location (CandidateProof action) = + CandidateProof + (State.mapStateT + (Except.withExceptT + (ProofObligationFailedAt location)) + action) + +-- | Record that the current exact proof discharged one goal with @Omitted@. +recordOmittedUse :: CandidateProof () +recordOmittedUse = CandidateProof do + state <- State.get + State.put + state + { candidateProofSafety = + addCandidateEscape + Omitted + (candidateProofSafety state) + } + +data VampirePremiseSelection + = VampireImplicitPremises + | VampireExplicitPremises + !(NonEmpty SemanticFactOccurrenceFingerprint) + | VampireLocalPremises + deriving stock (Show, Eq) + +data VampireObligationPreparationError local + = VampireObligationIndirectTargetNotFalsum + | VampireObligationClaimProjectionFailed + !(Backend.SupportedPropositionProjectionError local) + | VampireObligationLocalProjectionFailed + !Backend.LocalPremiseOrdinal + !(Backend.SupportedPropositionProjectionError local) + | VampireObligationLocalClassificationFailed + !Backend.LocalPremiseOrdinal + !(Backend.BackendClassificationError ObjectId) + | VampireObligationFactNotVisible + !SemanticFactOccurrenceFingerprint + | VampireObligationFactInvalid + !SemanticFactOccurrenceFingerprint + | VampireObligationPlanningFailed + !(Backend.TypedProblemError local ObjectId) + | VampireObligationEncodingFailed + !(Tptp.TypedTptpPreparationError local ObjectId) + deriving stock (Show, Eq) + +data ScopedVampirePremise local origin = ScopedVampirePremise + !Backend.LocalPremiseOrdinal + !origin + !(Vector (local, CoreType)) + !(ScopedCheckedCore ObjectId) + +scopedVampirePremise + :: Backend.LocalPremiseOrdinal + -> origin + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> ScopedVampirePremise local origin +scopedVampirePremise = + ScopedVampirePremise + +data PreparedVampireObligation local origin = + PreparedVampireObligation + !(Backend.TypedProblem + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + !(Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + +-- | Prepare a scoped task for a trusted structural proof checker. This +-- validates the typed problem but does not establish how its local judgments +-- derive from the enclosing theorem. 'Checking.Exact.Proof' owns that +-- composition on the production path. +prepareScopedVampireObligationDriver + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationDriver + claimSupport claim scopedLocals auxiliaryTags selection = + prepareScopedVampireObligationForMode + Provers.DirectTask + claimSupport + claim + scopedLocals + auxiliaryTags + selection + +-- | Prepare the one indirect task admitted by the exact proof compiler. +-- The target check keeps contradictory input from authorizing another goal. +prepareScopedContradictionObligationDriver + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedContradictionObligationDriver + claimSupport claim scopedLocals auxiliaryTags selection + | scopedCoreType claim /= TyProp || scopedCoreTerm claim /= CFalsum = + pure (Left VampireObligationIndirectTargetNotFalsum) + | otherwise = + prepareScopedVampireObligationForMode + Provers.IndirectTask + claimSupport + claim + scopedLocals + auxiliaryTags + selection + +prepareScopedVampireObligationLowering + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationLowering + claimSupport claim scopedLocals auxiliaryTags selection = + prepareScopedVampireObligationForModeLowering + Provers.DirectTask + claimSupport claim scopedLocals auxiliaryTags selection + +prepareScopedContradictionObligationLowering + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedContradictionObligationLowering + claimSupport claim scopedLocals auxiliaryTags selection + | scopedCoreType claim /= TyProp || scopedCoreTerm claim /= CFalsum = + pure (Left VampireObligationIndirectTargetNotFalsum) + | otherwise = + prepareScopedVampireObligationForModeLowering + Provers.IndirectTask + claimSupport claim scopedLocals auxiliaryTags selection + +prepareScopedVampireObligationForModeLowering + :: Ord local + => Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationForModeLowering + taskMode claimSupport claim scopedLocals auxiliaryTags selection = + LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- + State.get + liftIO + (prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection) + +prepareScopedVampireObligationForMode + :: Ord local + => Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationForMode + taskMode claimSupport claim scopedLocals auxiliaryTags selection = + ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + State.lift + (Except.liftIO + (prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection)) + +prepareScopedVampireObligationWith + :: (Ord local) + => BuilderState evidence + -> Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> IO + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection = + forceVampirePreparation preparation + where + closure = logicalBuilderObjectClosure builder + globalType = (`lookupCheckedObjectType` closure) + preparation = do + supportedClaim <- + first VampireObligationClaimProjectionFailed + (Backend.projectSupportedProposition + globalType + claimSupport + claim) + locals <- traverse prepareLocal scopedLocals + prepareVampireObligationWith + taskMode + builder + closure + supportedClaim + locals + auxiliaryTags + selection + + prepareLocal + (ScopedVampirePremise + ordinal origin support proposition) = do + supported <- + first + (VampireObligationLocalProjectionFailed ordinal) + (Backend.projectSupportedProposition + globalType + support + proposition) + first + (VampireObligationLocalClassificationFailed ordinal) + (Backend.typedLocalPremise + globalType + ordinal + origin + supported) + +prepareVampireObligationWith + :: Ord local + => Provers.VampireTaskMode + -> BuilderState evidence + -> CheckedObjectClosure + -> Backend.SupportedProposition local ObjectId + -> [Backend.TypedLocalPremise local origin ObjectId] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin) +prepareVampireObligationWith + taskMode builder closure claim locals auxiliaryTags selection = do + let globalType = (`lookupCheckedObjectType` closure) + selected <- + selectVampireFacts + globalType + builder + selection + let localPremisePolicy = + case selection of + VampireImplicitPremises -> + Backend.FirstOrderLocals + VampireExplicitPremises{} + | any + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> False + Backend.RequiresTh0{} -> True) + selected -> + Backend.CompleteLocals + | otherwise -> + Backend.FirstOrderLocals + VampireLocalPremises -> + Backend.CompleteLocals + higherOrderPolicy = + case selection of + VampireImplicitPremises -> + Backend.ImplicitConstructionJustification + VampireExplicitPremises{} -> + Backend.ExplicitHigherOrderJustification + VampireLocalPremises -> + Backend.ExplicitHigherOrderJustification + propositionDependencies = + foundationAxiomDependencies + . Backend.supportedPropositionTerm + requiredAuxiliaryTags = + Set.toAscList + ( Set.fromList auxiliaryTags + <> propositionDependencies claim + <> foldMap + (propositionDependencies + . Backend.typedBackendFactProposition) + selected + <> foldMap + (propositionDependencies + . Backend.typedLocalPremiseProposition) + (Backend.selectTypedLocalPremises + localPremisePolicy + locals) + ) + auxiliaries = + Backend.typedFoundationAuxiliaryInput + (logicalBuilderFoundation builder) + <$> requiredAuxiliaryTags + problem <- + first VampireObligationPlanningFailed + (Backend.planTypedProblem + globalType + selected + claim + locals + auxiliaries + localPremisePolicy + higherOrderPolicy) + task <- + first VampireObligationEncodingFailed + (Provers.prepareTypedProverTask + taskMode + problem) + pure (PreparedVampireObligation problem task) + +forceVampirePreparation + :: Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin) + -> IO + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +forceVampirePreparation preparation = + Exception.evaluate (forcePrepared preparation) + where + forcePrepared result = + case result of + Left err -> err `seq` result + Right prepared@(PreparedVampireObligation _ task) -> + let request = Provers.preparedTypedProverRequest task + in Provers.preparedVerificationByteCount request `seq` + Provers.preparedVerificationRequestId request `seq` + prepared `seq` + result + +selectVampireFacts + :: (ObjectId -> Maybe CoreType) + -> BuilderState evidence + -> VampirePremiseSelection + -> Either + (VampireObligationPreparationError local) + (Vector + (Backend.TypedBackendFact + SemanticFactOccurrenceFingerprint + ObjectId)) +selectVampireFacts globalType builder selection = + Vector.fromList <$> case selection of + VampireImplicitPremises -> + mapMaybeM prepareImplicit + (Map.toAscList (logicalBuilderFacts builder)) + VampireExplicitPremises fingerprints -> + traverse prepareExplicit + (stableUniqueBy id (toList fingerprints)) + VampireLocalPremises -> + Right [] + where + prepareImplicit (fingerprint, authorized@(FactEntry + _proposition occurrence _authorization)) + | semanticFactSearchEligibility occurrence + /= SearchEligible = + Right Nothing + | otherwise = do + fact <- prepareFact fingerprint authorized + pure case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> Just fact + Backend.RequiresTh0{} -> Nothing + + prepareExplicit fingerprint = + case Map.lookup fingerprint (logicalBuilderFacts builder) of + Nothing -> + Left (VampireObligationFactNotVisible fingerprint) + Just authorized -> + prepareFact fingerprint authorized + + prepareFact fingerprint + (FactEntry proposition occurrence _authorization) + | semanticFactFingerprint occurrence /= fingerprint = + Left (VampireObligationFactInvalid fingerprint) + | otherwise = do + supported <- + first + (const + (VampireObligationFactInvalid fingerprint)) + (Backend.supportedProposition + Vector.empty + (embedClosedCore + [] + (checkedPropositionTerm proposition))) + capability <- + first + (const + (VampireObligationFactInvalid fingerprint)) + (Backend.classifySupportedProposition + globalType + supported) + pure + (Backend.typedBackendFact + fingerprint + supported + capability) + + mapMaybeM action = + fmap catMaybes . traverse action + +data LocalClaim = LocalClaim + !BuilderIdentity + !DeclarationInvocation + !FactSlot + !CheckedPropositionContent + +useAuthorizedFact + :: SemanticFactOccurrenceFingerprint + -> CandidateProof ImportIx +useAuthorizedFact fingerprint = do + proposition <- consumeAuthorizedFact fingerprint + registerKernelImport proposition + +-- | Validate one fact capability and accumulate only its safety effect. +-- Backend use does not register a kernel import. +consumeAuthorizedFact + :: SemanticFactOccurrenceFingerprint + -> CandidateProof CheckedPropositionContent +consumeAuthorizedFact fingerprint = CandidateProof do + state <- State.get + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + staged = + findPendingByFingerprint + fingerprint + (declarationPending declaration) + case staged of + Just pending -> + consumePendingFact pending state + Nothing -> + case Map.lookup + fingerprint + (logicalBuilderFacts builder) of + Nothing -> + State.lift + (Except.throwError + (AuthorizedFactNotVisible fingerprint)) + Just authorized -> + consumeBuilderAuthorizedFact authorized state + +-- | Materialize one sealed direct import and its transitive parents. The +-- interface DAG is folded imported-before-importer and each producer +-- occurrence receives a fresh capability for this consuming builder. +importSealedModule + :: ImportedModuleEvidence + -> Declaration () +importSealedModule evidence = Declaration do + state <- State.get + when + (isJust (declarationObjectClosure state)) + (State.lift + (Except.throwError ImportedModuleAfterAuthorization)) + let builder = declarationBuilder state + interfaceId = + semanticInterfaceAssertedId + (evidenceInterface evidence) + unless + (interfaceId `elem` + logicalBuilderDirectSemanticInputs builder) + (State.lift + (Except.throwError + (ImportedModuleNotDirect interfaceId))) + imported <- + State.lift + (Except.liftEither + (foldImportedEvidence evidence builder)) + State.put + state + { declarationBuilder = imported + , declarationObjectClosure = Nothing + } + +-- The walking path keeps complete aggregate maps. Measure long chains before +-- replacing this representation. +foldImportedEvidence + :: ImportedModuleEvidence + -> LogicalBuilder + -> Either DeclarationError LogicalBuilder +foldImportedEvidence evidence builder + | interfaceId + `Set.member` logicalBuilderImportedInterfaces builder = + Right builder + | otherwise = do + unless + (semanticInterfaceDirectInputs interface + == (semanticInterfaceAssertedId . evidenceInterface + <$> parents)) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + (semanticInterfaceAssertedId . evidenceInterface + <$> parents))) + withParents <- foldM + (flip foldImportedEvidence) + builder + parents + objectClosure <- + first + DeclarationObjectValidationFailed + (extendImportedObjectClosure + (logicalBuilderObjectClosure withParents) + objects) + importedFacts <- foldM + (insertImportedFact withParents) + (logicalBuilderFacts withParents) + (Map.elems entries) + importedAliases <- foldM + (insertImportedAlias importedFacts) + (logicalBuilderAliases withParents) + [ ( alias + , ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias) + ) + | delta <- semanticInterfaceDeclarations interface + , alias <- declarationDeltaAliases delta + ] + importedStructures <- foldM + (insertSemanticStructure objectClosure) + (logicalBuilderStructures withParents) + [ descriptor + | delta <- semanticInterfaceDeclarations interface + , descriptor <- semanticEnvironmentStructures + (declarationDeltaEnvironment delta) + ] + importedGlobals <- foldM + (insertImportedGlobal objectClosure importedStructures) + (logicalBuilderGlobals withParents) + [ binding + | delta <- semanticInterfaceDeclarations interface + , binding <- semanticEnvironmentBindings + (declarationDeltaEnvironment delta) + ] + pure + withParents + { logicalBuilderFacts = importedFacts + , logicalBuilderAliases = importedAliases + , logicalBuilderGlobals = importedGlobals + , logicalBuilderStructures = importedStructures + , logicalBuilderObjectClosure = objectClosure + , logicalBuilderImportedInterfaces = + Set.insert + interfaceId + (logicalBuilderImportedInterfaces withParents) + } + where + ImportedModuleEvidence interface parents entries objects = evidence + interfaceId = semanticInterfaceAssertedId interface + + extendImportedObjectClosure closure asserted = + extendObjectClosure + closure + [ object + | object <- asserted + , assertedObjectId object + `Set.notMember` checkedObjectIds closure + ] + + insertImportedFact + current facts pair = do + let (occurrence, proposition) = pair + fingerprint = semanticFactFingerprint occurrence + authority = semanticFactAuthority occurrence + _ <- + first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + (logicalBuilderTheory current) + fingerprint + occurrence + proposition + authority) + let authorization = + BuilderFactAuthorization + (logicalBuilderIdentity current) + (semanticFactSlot occurrence) + authority + authorized = + FactEntry proposition occurrence authorization + case Map.lookup fingerprint facts of + Nothing -> + pure (Map.insert fingerprint authorized facts) + Just existing + | equivalentAuthorizedFact existing authorized -> + pure facts + | otherwise -> + Left (ImportedFactCollision fingerprint) + + insertImportedAlias facts aliases (alias, origin) = do + let name = semanticAliasName alias + target = semanticAliasTarget alias + unless + (Map.member target facts) + (Left (ImportedAliasTargetMissing target)) + case Map.lookup name aliases of + Nothing -> + pure + (Map.insert + name + (ImportedAliasBinding target origin) + aliases) + Just (ImportedAliasBinding existingTarget existingOrigin) + | existingTarget == target -> + pure aliases + | otherwise -> + Left + (ImportedAliasCollision + name existingOrigin origin) + + insertImportedGlobal closure structures globals binding = do + let key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + _ <- + first + (ImportedGlobalTargetInvalid key target) + (validateSemanticGlobalBindingTarget + (structureOperationBindings structures) + closure binding) + case Map.lookup key globals of + Nothing -> pure (Map.insert key target globals) + Just existing + | existing == target -> pure globals + | otherwise -> + Left (ImportedGlobalCollision key existing target) + +insertSemanticStructure + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> SemanticStructureDescriptor + -> Either + DeclarationError + (Map SemanticStructurePhrase ResolvedStructure) +insertSemanticStructure closure structures descriptor = do + validateSemanticStructureTargets closure descriptor + let structurePhrase = semanticStructureDescriptorPhrase descriptor + case Map.lookup structurePhrase structures of + Just (ResolvedStructure existing _ _) + | existing == descriptor -> Right structures + | otherwise -> + Left + (ImportedStructureCollision + structurePhrase existing descriptor) + Nothing -> do + parents <- traverse resolveParent + (semanticStructureDescriptorParents descriptor) + inherited <- foldM mergeParentOperations Map.empty parents + complete <- foldM insertOwnOperation inherited + (semanticStructureDescriptorOperations descriptor) + let ancestors = + Set.unions + [ Set.insert + (semanticStructureDescriptorPhrase + (resolvedStructureDescriptor parent)) + parentAncestors + | parent@(ResolvedStructure _ parentAncestors _) <- parents + ] + resolved = ResolvedStructure descriptor ancestors complete + Right (Map.insert structurePhrase resolved structures) + where + resolveParent parentPhrase = + maybe + (Left + (SemanticStructureParentMissing + (semanticStructureDescriptorPhrase descriptor) + parentPhrase)) + Right + (Map.lookup parentPhrase structures) + + mergeParentOperations operations + (ResolvedStructure _descriptor _ancestors parentOperations) = + foldM insertInheritedOperation operations + (Map.toAscList parentOperations) + + insertInheritedOperation operations (symbol, operation) = + insertResolvedOperation symbol operation operations + + insertOwnOperation operations operation = + insertResolvedOperation + (semanticStructureOperationSymbol operation) + (ResolvedStructureOperation + (semanticStructureOperationObject operation) + (semanticStructureDescriptorPhrase descriptor)) + operations + + insertResolvedOperation symbol incoming operations = + case Map.lookup symbol operations of + Nothing -> Right (Map.insert symbol incoming operations) + Just (ResolvedStructureOperation existingObject existingOrigin) -> + case incoming of + ResolvedStructureOperation incomingObject incomingOrigin + | existingObject == incomingObject -> Right operations + | otherwise -> + Left + (SemanticStructureOperationConflict + symbol existingOrigin incomingOrigin) + +validateSemanticStructureTargets + :: CheckedObjectClosure + -> SemanticStructureDescriptor + -> Either DeclarationError () +validateSemanticStructureTargets closure descriptor = do + traverse_ validatePredicate + (semanticStructureDescriptorPredicate descriptor) + traverse_ validateOperation + (semanticStructureDescriptorOperations descriptor) + where + validatePredicate object = + validateObjectType + (SemanticStructurePredicateTargetInvalid + (semanticStructureDescriptorPhrase descriptor)) + object + (TyArrow TySet TyProp) + + validateOperation operation = + validateObjectType + (SemanticStructureOperationTargetInvalid + (semanticStructureDescriptorPhrase descriptor) + (semanticStructureOperationSymbol operation)) + (semanticStructureOperationObject operation) + (TyArrow TySet TySet) + + validateObjectType failure object expected = + case lookupCheckedObjectType object closure of + Nothing -> Left (failure object Nothing expected) + Just actual + | actual == expected -> Right () + | otherwise -> Left (failure object (Just actual) expected) + +equivalentAuthorizedFact + :: FactEntry BuilderFactAuthorization + -> FactEntry BuilderFactAuthorization + -> Bool +equivalentAuthorizedFact + (FactEntry leftProposition leftOccurrence + (BuilderFactAuthorization leftIdentity leftSlot leftAuthority)) + (FactEntry rightProposition rightOccurrence + (BuilderFactAuthorization rightIdentity rightSlot rightAuthority)) = + checkedPropositionId leftProposition + == checkedPropositionId rightProposition + && leftOccurrence == rightOccurrence + && leftIdentity == rightIdentity + && leftSlot == rightSlot + && leftAuthority == rightAuthority + +-- | Driver-level form used before the first declaration of a consuming +-- module. It changes only the private builder's imported fact environment; +-- no declaration prefix or durable envelope is emitted. +importSealedModuleDriver + :: ImportedModuleEvidence + -> ModuleDriver failure () +importSealedModuleDriver evidence = ModuleDriver do + DriverState resolver builder prefix validationRun <- + State.get + let declaration = + initialDeclarationState + resolver + validationRun + EnvironmentImportMode + builder + result <- + liftIO + (Except.runExceptT + (State.runStateT + (runDeclaration + (importSealedModule evidence)) + declaration)) + case result of + Left failure -> + Except.throwError (DriverDeclarationFailed failure) + Right (_value, importedState) -> + State.put + (DriverState + resolver + (declarationBuilder importedState) + prefix + validationRun) + +useStagedCandidate + :: ReservedCandidate + -> CandidateProof ImportIx +useStagedCandidate premise = CandidateProof do + state <- State.get + let current = candidateProofCandidate state + declaration = candidateProofDeclaration state + State.lift + (Except.liftEither + (validateReservedCandidate + declaration + premise)) + State.lift + (Except.liftEither + (validateStrictCandidateStage premise current)) + pending <- + maybe + (State.lift + (Except.throwError + (StagedPremiseNotAuthorized + (reservedCandidateSlot premise)))) + pure + (Map.lookup + (reservedCandidateSlot premise) + (declarationPending declaration)) + let proposedAuthority = + validationTarget (pendingCandidateCertificate pending) + checkedStage <- + State.lift + (Except.liftEither + (prepareCheckedDeclarationStage + declaration + (candidateProofObjectClosure state) + [(premise, proposedAuthority)])) + stagedProposition <- + State.lift + (Except.liftEither + (useCheckedStageFact checkedStage current premise)) + proposition <- consumePendingFact pending state + unless + (checkedPropositionId stagedProposition + == checkedPropositionId proposition) + (State.lift + (Except.throwError + (PlanningFactContractMismatch + (reservedCandidateSlot premise)))) + updated <- State.get + appendCandidatePremise proposition updated + +validateStrictCandidateStage + :: ReservedCandidate + -> ReservedCandidate + -> Either DeclarationError () +validateStrictCandidateStage premise current = + unless + (reservedStage premise < reservedStage current) + (Left + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + (reservedCandidateStage premise) + (reservedCandidateSlot current) + (reservedCandidateStage current))) + +prepareCheckedDeclarationStage + :: DeclarationState + -> CheckedObjectClosure + -> [(ReservedCandidate, FactAuthority)] + -> Either DeclarationError CheckedDeclarationStage +prepareCheckedDeclarationStage declaration closure candidates = do + entries <- foldM insertCandidate Map.empty candidates + pure (CheckedDeclarationStage ownSlot closure entries) + where + builder = declarationBuilder declaration + ownSlot = declarationOwnSlot declaration + + insertCandidate entries (candidate, authority) = do + validateReservedCandidate declaration candidate + let slot = reservedCandidateSlot candidate + unless + (factAuthorityTheorem authority + == candidateTheoremReference builder candidate) + (Left (PlanningFactContractMismatch slot)) + when + (Map.member slot entries) + (Left (PlanningFactContractMismatch slot)) + let occurrence = candidateOccurrence candidate authority + evidence = PlanningEvidence + authority + (Just + (PlanningProvenance + ownSlot + (reservedStage candidate) + slot)) + pure + (Map.insert + slot + (FactEntry + (candidateCheckedProposition candidate) + occurrence + evidence) + entries) + +useCheckedStageFact + :: CheckedDeclarationStage + -> ReservedCandidate + -> ReservedCandidate + -> Either DeclarationError CheckedPropositionContent +useCheckedStageFact + (CheckedDeclarationStage ownSlot closure entries) + current + premise = do + validateStrictCandidateStage premise current + let slot = reservedCandidateSlot premise + FactEntry proposition occurrence + (PlanningEvidence authority provenance) <- + maybe + (Left (PlanningFactContractMismatch slot)) + Right + (Map.lookup slot entries) + unless + ( provenance + == Just + (PlanningProvenance + ownSlot + (reservedStage premise) + slot) + && semanticFactSlot occurrence == slot + && semanticFactAuthority occurrence == authority + && checkedPropositionId proposition + == checkedPropositionId + (candidateCheckedProposition premise) + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch slot)) + pure proposition + +propositionMatchesClosure + :: CheckedObjectClosure + -> CheckedPropositionContent + -> Bool +propositionMatchesClosure closure proposition = + case validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm (checkedPropositionTerm proposition)) of + Right _ -> True + Left _ -> False + +candidateOccurrence + :: ReservedCandidate + -> FactAuthority + -> SemanticFactOccurrence +candidateOccurrence + (ReservedCandidate _ _ _ _ slot + (CandidateSpec _ eligibility _aliases)) + authority = + semanticFactOccurrence slot authority eligibility + +candidateAliases :: ReservedCandidate -> [SemanticName] +candidateAliases + (ReservedCandidate _ _ _ _ _ + (CandidateSpec _ _ aliases)) = + aliases + +proveLocalKernelClaim + :: CheckedPropositionContent + -> KernelDerivation ObjectId + -> CandidateProof LocalClaim +proveLocalKernelClaim proposition derivation = CandidateProof do + state <- State.get + void + (State.lift + (Except.liftEither + (replayCandidateKernel proposition derivation state))) + let candidate = candidateProofCandidate state + declaration = candidateProofDeclaration state + pure + (LocalClaim + (logicalBuilderIdentity + (candidateProofBuilder state)) + (declarationInvocation declaration) + (reservedCandidateSlot candidate) + proposition) + +useLocalClaim :: LocalClaim -> CandidateProof ImportIx +useLocalClaim + (LocalClaim identity invocation slot proposition) = + CandidateProof do + state <- State.get + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + candidate = candidateProofCandidate state + unless + ( identity == logicalBuilderIdentity builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot candidate + ) + (State.lift + (Except.throwError LocalClaimOutsideCandidate)) + appendCandidatePremise proposition state + + +authorizeKernelProofCandidate + :: ReservedCandidate + -> CandidateProof (KernelDerivation ObjectId) + -> Declaration () +authorizeKernelProofCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + (derivation, final) <- + State.runStateT (runCandidateProof proof) initial + when + (isNothing (candidateProofCachedValidation final)) + (void + (Except.liftEither + (replayCandidateKernel + (candidateCheckedProposition candidate) + derivation + final))) + completeCandidateWithValidation + candidate + (CheckedSourceProof + (acceptedRequestIds final)) + (candidateProofSafety final) + final + +authorizeKernelConstructionCandidate + :: KernelConstructionDescriptor + -> ReservedCandidate + -> CandidateProof (KernelDerivation ObjectId) + -> Declaration () +authorizeKernelConstructionCandidate descriptor candidate proof = + authorizeOneCandidate candidate \initial -> do + (derivation, final) <- + State.runStateT (runCandidateProof proof) initial + when + (isNothing (candidateProofCachedValidation final)) do + replayed <- + Except.liftEither + (replayCandidateKernel + (candidateCheckedProposition candidate) + derivation + final) + Except.liftEither + (validateKernelConstruction + descriptor + (candidateCheckedProposition candidate) + replayed + final) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety final) + final + +authorizeDefinitionEquationCandidate + :: ObjectId + -> ReservedCandidate + -> Declaration () +authorizeDefinitionEquationCandidate identity candidate = + authorizeOneCandidate candidate \initial -> do + when + (isNothing (candidateProofCachedValidation initial)) + (unless + (matchesDefinitionEquation + identity + (candidateCheckedProposition candidate) + initial) + (Except.throwError + DefinitionEquationCandidateMismatch)) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction + (CheckedDefinitionEquation identity)) + (candidateProofSafety initial) + initial + +-- | Authorize only the extensional fact deterministically derived from the +-- checked source construction and its committed transparent object. +authorizeNamedSetConstructionCandidate + :: ObjectId + -> NamedSetConstruction ObjectId + -> ReservedCandidate + -> Declaration () +authorizeNamedSetConstructionCandidate identity construction candidate = + authorizeOneCandidate candidate \initial -> do + let builder = candidateProofBuilder initial + (expected, descriptor) <- + Except.liftEither + (prepareNamedSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure initial) + identity + construction) + when (isNothing (candidateProofCachedValidation initial)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate)) + ) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety initial) + initial + +-- | Authorize the relational extensional view only after consuming the exact +-- strictly-earlier functionality candidate. The consumed candidate supplies +-- both real authority safety and the proposition rechecked by the confined +-- construction schema; a caller cannot substitute an arbitrary theorem. +authorizeRelationalSetConstructionCandidate + :: ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> ReservedCandidate + -> ReservedCandidate + -> Declaration () +authorizeRelationalSetConstructionCandidate + identity construction functionality candidate = + authorizeOneCandidate candidate \initial -> do + (_used, final) <- + State.runStateT + (runCandidateProof (useStagedCandidate functionality)) + initial + let builder = candidateProofBuilder final + functionalityTerm = + checkedPropositionTerm + (candidateCheckedProposition functionality) + (expected, descriptor) <- + Except.liftEither + (prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure final) + identity + construction + functionalityTerm) + when (isNothing (candidateProofCachedValidation final)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate))) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety final) + final + +authorizeSourceAxiomCandidate + :: ReservedCandidate + -> Declaration () +authorizeSourceAxiomCandidate candidate = + authorizeOneCandidate candidate \initial -> + let safety = + addCandidateEscape + SourceAxiom + initialCandidateSafety + in completeCandidateWithValidation + candidate + SourceAxiomAuthorization + safety + initial + +-- | Complete one exact deterministic datatype as a single trusted family. +-- The descriptor, objects, and complete candidate batch must agree exactly. +-- Law semantics are trusted to the sole production compiler in +-- "Checking.Exact.Datatype"; this boundary validates its complete inventory, +-- not the meaning of each generated proposition. +authorizeDatatypeCompilationCandidates + :: DatatypeCompilationDescriptor + -> ObjectId + -> NonEmpty ObjectId + -> NonEmpty ReservedCandidate + -> Declaration () +authorizeDatatypeCompilationCandidates + suppliedDescriptor carrier constructors candidates = + Declaration do + state <- State.get + let builder = declarationBuilder state + objectInventory = carrier : NonEmpty.toList constructors + declaredObjects = + assertedObjectId + <$> reverse (declarationObjectsReversed state) + reservedCandidates = + Map.elems (declarationReservations state) + theoremInventory = + candidateTheoremReference builder + <$> NonEmpty.toList candidates + expectedDescriptor = + datatypeCompilationDescriptor + carrier + constructors + theoremInventory + stages = + nubOrd + (reservedCandidateStage + <$> NonEmpty.toList candidates) + unless + ( suppliedDescriptor == expectedDescriptor + && declaredObjects == objectInventory + && reservedCandidates == NonEmpty.toList candidates + && length stages == 1 + ) + (State.lift + (Except.throwError + DatatypeCompilationDescriptorMismatch)) + runDeclaration + (traverse_ + (authorizeDatatypeCandidate suppliedDescriptor) + candidates) + +authorizeDatatypeCandidate + :: DatatypeCompilationDescriptor + -> ReservedCandidate + -> Declaration () +authorizeDatatypeCandidate descriptor candidate = + authorizeOneCandidate candidate \initial -> + completeCandidateWithValidation + candidate + (TrustedCompilation + (DatatypeCompilation descriptor)) + initialCandidateSafety + initial + +authorizeOmittedCandidate + :: ReservedCandidate + -> CandidateProof () + -> Declaration () +authorizeOmittedCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + cached <- + selectProofCandidateValidation candidate initial + let preparedInitial = + initial + { candidateProofCachedValidation = cached + } + ((), final) <- + State.runStateT (runCandidateProof proof) preparedInitial + let safety = candidateProofSafety final + unless + (Omitted + `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (candidateSafetyAuthority safety))) + (Except.throwError OmittedProofDidNotRecordUse) + completeCandidateWithValidation + candidate + OmittedAuthorization + safety + final + +-- | Retain the closed candidate-target path while scoped proof composition is +-- introduced. It uses the same environment validation as local obligations. +acceptVampireObligation + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + origin + ObjectId + -> CandidateProof () +acceptVampireObligation prepared = + acceptValidatedVampireTask + (validateCandidateVampireProblem prepared) + prepared + +-- | Validate one internally prepared scoped obligation, then retain its exact +-- accepted request. The trusted caller remains responsible for structural +-- local-proof composition. +acceptPreparedVampireObligation + :: (Eq local, Eq origin) + => PreparedVampireObligation local origin + -> CandidateProof () +acceptPreparedVampireObligation + (PreparedVampireObligation expected prepared) = + acceptValidatedVampireTask + (validatePreparedVampireProblem expected prepared) + prepared + +-- | Prepare and execute the current closed candidate using exactly the +-- staged premises already consumed by its trusted declaration compiler. +acceptCurrentCandidateVampire :: CandidateProof () +acceptCurrentCandidateVampire = + prepareCurrentCandidateVampire + >>= acceptPreparedVampireObligation + +-- | Prepare the current closed candidate without executing its request. The +-- declaration-owned batch authorizer uses this seam only after all strictly +-- earlier staged premises have been consumed. +prepareCurrentCandidateVampire + :: CandidateProof (PreparedVampireObligation Void ()) +prepareCurrentCandidateVampire = CandidateProof do + initial <- State.get + let builder = candidateProofBuilder initial + closure = candidateProofObjectClosure initial + target = candidateCheckedProposition + (candidateProofCandidate initial) + premises = + [ proposition + | CandidatePremise proposition <- + reverse (candidateProofPremisesReversed initial) + ] + preparation = + prepareClosedCandidateVampire + builder closure target premises + preparedResult <- + State.lift + (liftIO + (forceVampirePreparation preparation)) + prepared <- + State.lift + (Except.liftEither + (first + CurrentCandidateVampirePreparationFailed + preparedResult)) + pure prepared + +prepareClosedCandidateVampire + :: BuilderState evidence + -> CheckedObjectClosure + -> CheckedPropositionContent + -> [CheckedPropositionContent] + -> Either + (VampireObligationPreparationError Void) + (PreparedVampireObligation Void ()) +prepareClosedCandidateVampire builder closure target premises = do + supportedTarget <- + first + VampireObligationClaimProjectionFailed + (Backend.projectSupportedProposition + globalType + (Vector.empty :: Vector (Void, CoreType)) + (closed target)) + locals <- + traverse + prepareLocal + (zip [0 :: Natural ..] premises) + prepareVampireObligationWith + Provers.DirectTask + builder + closure + supportedTarget + locals + [] + VampireLocalPremises + where + globalType = (`lookupCheckedObjectType` closure) + closed proposition = + embedClosedCore [] + (checkedPropositionTerm proposition) + + prepareLocal (index, proposition) = do + let ordinal = Backend.localPremiseOrdinal index + supported <- + first + (VampireObligationLocalProjectionFailed ordinal) + (Backend.projectSupportedProposition + globalType + (Vector.empty :: Vector (Void, CoreType)) + (closed proposition)) + first + (VampireObligationLocalClassificationFailed ordinal) + (Backend.typedLocalPremise + globalType ordinal () supported) + +acceptValidatedVampireTask + :: (CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState) + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProof () +acceptValidatedVampireTask validate prepared = CandidateProof do + initial <- State.get + validated <- State.lift (validate initial) + result <- + case candidateProofCachedValidation initial of + Nothing -> do + let resolver = + declarationVampireResolver + (candidateProofDeclaration initial) + Just <$> State.lift (resolveOneVampire resolver prepared) + Just _validation -> + pure Nothing + final <- + State.lift + (acceptVampireBatchMemberResult + prepared result validated) + State.put final + +-- | Complete one checked source candidate after all of its obligations have +-- been accepted in source order. The enclosing proof declaration owns the +-- exact syntax key and selects live or cached execution before this action. +authorizeVampireCandidate + :: ReservedCandidate + -> CandidateProof () + -> Declaration () +authorizeVampireCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + cached <- + selectProofCandidateValidation candidate initial + let preparedInitial = + initial + { candidateProofCachedValidation = cached + } + ((), final) <- + State.runStateT (runCandidateProof proof) preparedInitial + case acceptedRequestIds final of + [] -> + Except.throwError + VampireProofHasNoAcceptedObligations + requests -> + completeCandidateWithValidation + candidate + (CheckedSourceProof requests) + (candidateProofSafety final) + final + +data PreparedVampireCandidateBatchMember = + PreparedVampireCandidateBatchMember + !Location + !ReservedCandidate + !(Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + () + ObjectId) + !CandidateProofState + +data ResolvedVampireCandidateBatchMember = + ResolvedVampireCandidateBatchMember + !PreparedVampireCandidateBatchMember + !(Maybe + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + +-- | Authorize one complete, source-ordered candidate stage whose members are +-- mutually independent and each require exactly one closed Vampire request. +-- Every member is prepared and validated against the same declaration +-- baseline. Results are applied only after the complete live batch returns, +-- so no same-stage sibling can become authority for another member. +authorizeVampireCandidateBatch + :: NonEmpty + ( Location + , ReservedCandidate + , CandidateProof (PreparedVampireObligation Void ()) + ) + -> Declaration () +authorizeVampireCandidateBatch inputs = Declaration do + unprepared <- State.get + baseline <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let supplied = + [ candidate + | (_location, candidate, _prepare) <- NonEmpty.toList inputs + ] + frontier = declarationAuthorizationFrontier baseline + expected = + List.filter + ((== CandidateStage frontier) . reservedStage) + (Map.elems (declarationReservations baseline)) + traverse_ + (State.lift + . Except.liftEither + . validateReservedCandidate baseline) + supplied + traverse_ + (\candidate -> + when + (Map.member + (reservedCandidateSlot candidate) + (declarationPending baseline)) + (State.lift + (Except.throwError + (CandidateAlreadyAuthorized + (reservedCandidateSlot candidate))))) + supplied + unless (supplied == expected) + (State.lift + (Except.throwError + (VampireCandidateBatchMismatch + (reservedCandidateSlot <$> expected) + (reservedCandidateSlot <$> supplied)))) + prepared <- + State.lift + (traverse + (prepareVampireCandidateBatchMember baseline) + inputs) + State.lift + (validateCachedVampireCandidateBatch + (NonEmpty.toList prepared)) + let live = + [ task + | PreparedVampireCandidateBatchMember + _location _candidate task final <- + NonEmpty.toList prepared + , isNothing (candidateProofCachedValidation final) + ] + liveResults <- + case NonEmpty.nonEmpty live of + Nothing -> pure [] + Just nonempty -> do + let resolver = + declarationVampireResolver baseline + results <- + liftIO + (resolveSynchronousVampireBatch resolver nonempty) + State.lift + (Except.liftEither + (validateVampireResolverResultCount + (length live) + results)) + pending <- + State.lift + (completeVampireCandidateBatch + (NonEmpty.toList prepared) + liveResults) + let withPending = + baseline + { declarationPending = + foldl' + (\entries item@(PendingCandidate candidate _ _) -> + Map.insert + (reservedCandidateSlot + candidate) + item + entries) + (declarationPending baseline) + pending + } + State.put (advanceAuthorizationFrontier withPending) + +prepareVampireCandidateBatchMember + :: DeclarationState + -> ( Location + , ReservedCandidate + , CandidateProof (PreparedVampireObligation Void ()) + ) + -> ExceptT DeclarationError IO PreparedVampireCandidateBatchMember +prepareVampireCandidateBatchMember + baseline (location, candidate, prepare) = do + initial <- + Except.liftEither + (initialCandidateProofState baseline candidate) + cached <- selectProofCandidateValidation candidate initial + let selected = + initial{candidateProofCachedValidation = cached} + (obligation, preparedState) <- + State.runStateT + (runCandidateProof + (locateProofObligation location prepare)) + selected + unless (null (acceptedRequestIds preparedState)) + (Except.throwError + (VampireCandidateBatchProofShapeMismatch + (reservedCandidateSlot candidate))) + let PreparedVampireObligation expected task = obligation + validated <- + Except.withExceptT + (ProofObligationFailedAt location) + (validatePreparedVampireProblem + expected task preparedState) + pure + (PreparedVampireCandidateBatchMember + location candidate task validated) + +completeVampireCandidateBatch + :: [PreparedVampireCandidateBatchMember] + -> [Either Provers.ProverProcessError Provers.ProverAnswer] + -> ExceptT DeclarationError IO [PendingCandidate] +completeVampireCandidateBatch members liveResults = do + resolved <- + Except.liftEither + (associateVampireCandidateBatchResults + members liveResults) + -- Integrity dominates ranked proof failure: validate every accepted run + -- before inspecting any ordinary process or prover rejection. + traverse_ validateAcceptedVampireBatchMember resolved + traverse_ rejectOrdinaryVampireBatchMember resolved + traverse completeVampireCandidateBatchMember resolved + +validateCachedVampireCandidateBatch + :: [PreparedVampireCandidateBatchMember] + -> ExceptT DeclarationError IO () +validateCachedVampireCandidateBatch = + traverse_ \member -> + when + (preparedVampireCandidateBatchMemberIsCached member) + (void + (completeVampireCandidateBatchMember + (ResolvedVampireCandidateBatchMember member Nothing))) + +associateVampireCandidateBatchResults + :: [PreparedVampireCandidateBatchMember] + -> [Either Provers.ProverProcessError Provers.ProverAnswer] + -> Either + DeclarationError + [ResolvedVampireCandidateBatchMember] +associateVampireCandidateBatchResults members = + go members + where + go [] [] = Right [] + go [] results = + Left + (VampireResolverBatchSizeMismatch + 0 + (length results)) + go (member : remaining) results + | preparedVampireCandidateBatchMemberIsCached member = + (ResolvedVampireCandidateBatchMember member Nothing :) + <$> go remaining results + | otherwise = + case results of + [] -> + Left (VampireResolverBatchSizeMismatch 1 0) + current : later -> + (ResolvedVampireCandidateBatchMember + member (Just current) :) + <$> go remaining later + +preparedVampireCandidateBatchMemberIsCached + :: PreparedVampireCandidateBatchMember + -> Bool +preparedVampireCandidateBatchMemberIsCached + (PreparedVampireCandidateBatchMember + _location _candidate _task state) = + isJust (candidateProofCachedValidation state) + +validateAcceptedVampireBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO () +validateAcceptedVampireBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location _candidate task _validated) + result) = + Except.withExceptT + (ProofObligationFailedAt location) + (validateAcceptedVampireResult task result) + +rejectOrdinaryVampireBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO () +rejectOrdinaryVampireBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location _candidate _task _validated) + result) = + traverse_ + (Except.throwError . ProofObligationFailedAt location) + (result >>= vampireResultFailure) + +completeVampireCandidateBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO PendingCandidate +completeVampireCandidateBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location candidate task validated) + result) = do + final <- + Except.withExceptT + (ProofObligationFailedAt location) + (applyAcceptedVampireResult task result validated) + completeCandidateWithValidation + candidate + (CheckedSourceProof (acceptedRequestIds final)) + (candidateProofSafety final) + final + +acceptVampireBatchMemberResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +acceptVampireBatchMemberResult prepared result validated = do + validateAcceptedVampireResult prepared result + traverse_ Except.throwError (result >>= vampireResultFailure) + applyAcceptedVampireResult prepared result validated + +validateAcceptedVampireResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> ExceptT DeclarationError IO () +validateAcceptedVampireResult prepared result = do + let request = Provers.preparedTypedProverRequest prepared + traverse_ + (\resolved -> + traverse_ + (\accepted -> + unless + (Provers.acceptedVampireRequestId accepted + == Provers.preparedVerificationRequestId request) + (Except.throwError VampireRequestMismatch)) + (either (const Nothing) Provers.provedVampireRun resolved)) + result + +vampireResultFailure + :: Either Provers.ProverProcessError Provers.ProverAnswer + -> Maybe DeclarationError +vampireResultFailure = \case + Left failure -> + Just (VampireProcessFailed failure) + Right answer -> + case Provers.provedVampireRun answer of + Nothing -> + Just (VampireObligationRejected answer) + Just _accepted -> + Nothing + +applyAcceptedVampireResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +applyAcceptedVampireResult prepared result validated = do + traverse_ + (\resolved -> + case vampireResultFailure resolved of + Just failure -> + Except.throwError failure + Nothing -> + pure ()) + result + let request = Provers.preparedTypedProverRequest prepared + requestId = Provers.preparedVerificationRequestId request + pure + validated + { candidateProofAcceptedRequestsReversed = + requestId + : candidateProofAcceptedRequestsReversed validated + } + +selectProofCandidateValidation + :: ReservedCandidate + -> CandidateProofState + -> ExceptT + DeclarationError + IO + (Maybe Materialization.CandidateValidation) +selectProofCandidateValidation candidate initial = + case declarationValidationMode + (candidateProofDeclaration initial) of + EnvironmentImportMode -> + Except.throwError + ProofValidationOutsideProofDeclaration + ProofValidationMode{} -> do + (syntax, cached) <- + runDeclarationLookup + (lookupProofValidation candidate) + initial + pure + ((\record -> + Materialization.candidateProofValidation + record syntax) + <$> cached) + DeclarationValidationMode{} -> + pure (candidateProofCachedValidation initial) + +completeCandidateWithValidation + :: ReservedCandidate + -> DirectAuthorization + -> CandidateSafety + -> CandidateProofState + -> ExceptT DeclarationError IO PendingCandidate +completeCandidateWithValidation candidate direct safety final = do + pending <- + Except.liftEither + (freshCompletion + candidate + direct + safety + final) + traverse_ + (\validation -> + case Materialization.checkCandidateValidation + (logicalBuilderTheory + (candidateProofBuilder final)) + (logicalBuilderPrefix + (candidateProofBuilder final)) + (candidateCheckedProposition candidate) + (validationTarget + (pendingCandidateCertificate pending)) + direct + validation of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> + pure ()) + (candidateProofCachedValidation final) + pure pending + +runDeclarationLookup + :: Declaration value + -> CandidateProofState + -> ExceptT DeclarationError IO value +runDeclarationLookup action initial = + fst + <$> State.runStateT + (runDeclaration action) + (candidateProofDeclaration initial) + +pendingCandidateCertificate :: PendingCandidate -> ValidationCertificate +pendingCandidateCertificate + (PendingCandidate _ certificate _) = + certificate + +acceptedRequestIds :: CandidateProofState -> [PreparedRequestId] +acceptedRequestIds = + reverse . candidateProofAcceptedRequestsReversed + +freshCompletion + :: ReservedCandidate + -> DirectAuthorization + -> CandidateSafety + -> CandidateProofState + -> Either DeclarationError PendingCandidate +freshCompletion candidate direct safety proofState = do + let builder = candidateProofBuilder proofState + declaration = candidateProofDeclaration proofState + reference = candidateTheoremReference builder candidate + authority = candidateFactAuthority reference safety + void + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + (candidateProofObjectClosure proofState) + (checkedPropositionId + (candidateCheckedProposition candidate)) + (frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate))))) + certificate <- + first ValidationCertificateFailed + (validationCertificate authority direct) + let authorization = + PendingFactAuthorization + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + (declarationInvocation declaration) + (reservedCandidateSlot candidate) + authority + (reservedStage candidate) + pure + (PendingCandidate + candidate + certificate + authorization) + +authorizeOneCandidate + :: ReservedCandidate + -> (CandidateProofState + -> ExceptT DeclarationError IO PendingCandidate) + -> Declaration () +authorizeOneCandidate candidate complete = Declaration do + unprepared <- State.get + state <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + State.lift + (Except.liftEither + (validateReservedCandidate state candidate)) + when + (Map.member + (reservedCandidateSlot candidate) + (declarationPending state)) + (State.lift + (Except.throwError + (CandidateAlreadyAuthorized + (reservedCandidateSlot candidate)))) + unless + (reservedStage candidate + == CandidateStage + (declarationAuthorizationFrontier state)) + (State.lift + (Except.throwError + (CandidateOutsideAuthorizationFrontier + (reservedCandidateSlot candidate) + (reservedCandidateStage candidate) + (declarationAuthorizationFrontier state)))) + initial <- State.lift + (Except.liftEither + (initialCandidateProofState state candidate)) + pending <- State.lift (complete initial) + let state' = + state + { declarationPending = + Map.insert + (reservedCandidateSlot candidate) + pending + (declarationPending state) + } + State.put (advanceAuthorizationFrontier state') + +advanceAuthorizationFrontier + :: DeclarationState + -> DeclarationState +advanceAuthorizationFrontier state + | all stageCompleted currentCandidates = + state + { declarationAuthorizationFrontier = + frontier + 1 + } + | otherwise = + state + where + frontier = declarationAuthorizationFrontier state + currentCandidates = + List.filter + ((== CandidateStage frontier) . reservedStage) + (Map.elems (declarationReservations state)) + stageCompleted candidate = + Map.member + (reservedCandidateSlot candidate) + (declarationPending state) + +initialCandidateProofState + :: DeclarationState + -> ReservedCandidate + -> Either DeclarationError CandidateProofState +initialCandidateProofState declaration candidate = do + closure <- declarationClosure declaration + cached <- + cachedDeclarationCandidateValidation declaration candidate + pure CandidateProofState + { candidateProofDeclaration = declaration + , candidateProofObjectClosure = closure + , candidateProofCandidate = candidate + , candidateProofCachedValidation = cached + , candidateProofPremisesReversed = [] + , candidateProofPremiseCount = 0 + , candidateProofSafety = initialCandidateSafety + , candidateProofAcceptedRequestsReversed = [] + } + +cachedDeclarationCandidateValidation + :: DeclarationState + -> ReservedCandidate + -> Either + DeclarationError + (Maybe Materialization.CandidateValidation) +cachedDeclarationCandidateValidation declaration candidate = + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> + Right Nothing + FreshDeclarationValidation -> + Right Nothing + CachedDeclarationValidation + syntax objects theorems record ordinals -> + maybe + (Left + (CachedDeclarationCandidateMissing + (reservedCandidateSlot candidate))) + (Right + . Just + . Materialization.candidateDeclarationValidation + record syntax objects theorems) + (Map.lookup + (reservedCandidateSlot candidate) + ordinals) + +reservedStage :: ReservedCandidate -> CandidateStage +reservedStage + (ReservedCandidate _ _ _ stage _ _) = + stage + +validateReservedCandidate + :: DeclarationState + -> ReservedCandidate + -> Either DeclarationError () +validateReservedCandidate declaration candidate = do + let builder = declarationBuilder declaration + ReservedCandidate + identity prefix invocation _stage slot _spec = candidate + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && Map.lookup slot + (declarationReservations declaration) + == Just candidate + ) + (Left (CandidateOutsideDeclaration slot)) + +instance Eq ReservedCandidate where + left == right = + reservedCandidateKey left == reservedCandidateKey right + +reservedCandidateKey + :: ReservedCandidate + -> (BuilderIdentity, PrefixContextId, DeclarationInvocation, CandidateStage, FactSlot) +reservedCandidateKey + (ReservedCandidate identity prefix invocation stage slot _spec) = + (identity, prefix, invocation, stage, slot) + + +consumeBuilderAuthorizedFact + :: FactEntry BuilderFactAuthorization + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + CheckedPropositionContent +consumeBuilderAuthorizedFact + (FactEntry proposition occurrence authorization) + state = do + let builder = candidateProofBuilder state + BuilderFactAuthorization + identity slot authority = authorization + unless + ( identity == logicalBuilderIdentity builder + && slot == semanticFactSlot occurrence + && authority == semanticFactAuthority occurrence + ) + (State.lift + (Except.throwError BuilderFactAuthorizationMismatch)) + accumulateAuthorizedSafety + proposition + authority + state + pure proposition + +consumePendingFact + :: PendingCandidate + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + CheckedPropositionContent +consumePendingFact + (PendingCandidate premise certificate authorization) + state = do + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + PendingFactAuthorization + identity prefix invocation slot authority + premiseStageValue = authorization + current = candidateProofCandidate state + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot premise + && authority == validationTarget certificate + && premiseStageValue == reservedStage premise + ) + (State.lift + (Except.throwError PendingFactAuthorizationMismatch)) + unless + (reservedStage premise < reservedStage current) + (State.lift + (Except.throwError + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + (reservedCandidateStage premise) + (reservedCandidateSlot current) + (reservedCandidateStage current)))) + let proposition = candidateCheckedProposition premise + accumulateAuthorizedSafety + proposition + authority + state + pure proposition + +accumulateAuthorizedSafety + :: CheckedPropositionContent + -> FactAuthority + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + () +accumulateAuthorizedSafety proposition authority state = do + let expected = + theoremRef + (logicalBuilderTheory + (candidateProofBuilder state)) + (checkedPropositionId proposition) + safety <- + State.lift + (Except.liftEither + (first FactSafetyFailed + (accumulateFactSafety + expected + authority + (candidateProofSafety state)))) + State.put state{candidateProofSafety = safety} + +registerKernelImport + :: CheckedPropositionContent + -> CandidateProof ImportIx +registerKernelImport proposition = CandidateProof do + state <- State.get + appendCandidatePremise proposition state + +appendCandidatePremise + :: CheckedPropositionContent + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + ImportIx +appendCandidatePremise proposition state = do + let index = candidateProofPremiseCount state + State.put + state + { candidateProofPremisesReversed = + CandidatePremise proposition + : candidateProofPremisesReversed state + , candidateProofPremiseCount = index + 1 + } + pure (importIx index) + +findPendingByFingerprint + :: SemanticFactOccurrenceFingerprint + -> Map FactSlot PendingCandidate + -> Maybe PendingCandidate +findPendingByFingerprint fingerprint = + find + (\(PendingCandidate candidate certificate _authorization) -> + semanticFactOccurrenceFingerprint + (reservedCandidateSlot candidate) + (validationTarget certificate) + == fingerprint) + . Map.elems + +candidateImportJudgments + :: CandidateProofState + -> Either DeclarationError (Vector (DerivationImportJudgment ObjectId)) +candidateImportJudgments state = + Vector.fromList + <$> traverse + (\(CandidatePremise proposition) -> + first DerivationImportFailed + (derivationImportJudgment + (checkedPropositionTerm proposition))) + (reverse + (candidateProofPremisesReversed state)) + +replayCandidateKernel + :: CheckedPropositionContent + -> KernelDerivation ObjectId + -> CandidateProofState + -> Either + DeclarationError + (ReplayedKernelDerivation ObjectId) +replayCandidateKernel proposition derivation state = do + imports <- candidateImportJudgments state + let builder = candidateProofBuilder state + closure = candidateProofObjectClosure state + first KernelCompletionFailed + (replayKernelDerivation + (logicalBuilderFoundation builder) + defaultKernelReplayLimits + (`lookupCheckedObjectType` closure) + imports + (checkedPropositionTerm proposition) + derivation) + +validateKernelConstruction + :: KernelConstructionDescriptor + -> CheckedPropositionContent + -> ReplayedKernelDerivation ObjectId + -> CandidateProofState + -> Either DeclarationError () +validateKernelConstruction descriptor proposition replayed proofState = + unless matches + (Left KernelConstructionDescriptorMismatch) + where + builder = candidateProofBuilder proofState + noImports = Set.null (replayedKernelImportUses replayed) + noFoundation = Set.null (replayedKernelFoundationUses replayed) + noRules = Set.null (replayedKernelRuleUses replayed) + + matches = + case descriptor of + FoundationLeaf tag -> + noImports + && replayedKernelFoundationUses replayed + == Set.singleton tag + && noRules + && checkedPropositionTerm proposition + == mapFrozenGlobals + absurd + (foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag) + GuardedFoundationRules rules -> + replayedKernelRuleUses replayed + == guardedRuleTags rules + CheckedDefinitionEquation identity -> + noImports + && noFoundation + && noRules + && matchesDefinitionEquation identity proposition proofState + CheckedSetConstructionExtensionality{} -> + False + +matchesDefinitionEquation + :: ObjectId + -> CheckedPropositionContent + -> CandidateProofState + -> Bool +matchesDefinitionEquation identity proposition proofState = + case lookupCheckedObjectContent + identity + (candidateProofObjectClosure proofState) of + Just + (TransparentObjectContent + contentTheory coreType body) -> + contentTheory + == logicalBuilderTheory + (candidateProofBuilder proofState) + && frozenCoreTerm (checkedPropositionTerm proposition) + `elem` definitionEquationTargets identity coreType body + _ -> + False + +definitionEquationTargets + :: ObjectId + -> CoreType + -> CanonicalTerm ObjectId + -> [CanonicalTerm ObjectId] +definitionEquationTargets identity coreType body = + CEq coreType (CGlobal identity) body + : case (coreType, body) of + (TyArrow TySet TyProp, CLam TySet predicate) -> + [ CForall TySet + (CEq TyProp + (CApp (CGlobal identity) (CBound 0)) + predicate) + ] + _ -> [] + + +validateCandidateVampireProblem + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validateCandidateVampireProblem prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + target = candidateCheckedProposition + (candidateProofCandidate initial) + Except.liftEither do + unless + ( Vector.null (Backend.supportedPropositionSupport claim) + && Backend.supportedPropositionTerm claim + == frozenCoreTerm (checkedPropositionTerm target) + ) + (Left VampireTargetMismatch) + unless + (Vector.null (Backend.typedProblemLocalPremises problem)) + (Left VampireLocalPremisesNotSupported) + validateVampireProblemEnvironment prepared initial + +validatePreparedVampireProblem + :: (Eq local, Eq origin) + => Backend.TypedProblem + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validatePreparedVampireProblem expectedProblem prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + Except.liftEither + (unless (problem == expectedProblem) + (Left VampireTargetMismatch) + ) + validateVampireProblemEnvironment prepared initial + +validateVampireProblemEnvironment + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validateVampireProblemEnvironment prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + builder = candidateProofBuilder initial + closure = candidateProofObjectClosure initial + Except.liftEither do + traverse_ + (\(identity, reportedType) -> + unless + (lookupCheckedObjectType identity closure + == Just reportedType) + (Left (VampireGlobalTypeMismatch identity))) + (Map.toList (Backend.typedProblemGlobalTypes problem)) + traverse_ + (validateFoundationAuxiliary builder) + (Backend.typedProblemAuxiliaries problem) + execCandidateProof initial do + traverse_ + validatePremise + (Backend.typedProblemGlobalPremises problem) + where + validatePremise selected = do + let fingerprint = Backend.typedBackendFactReference selected + proposition <- consumeAuthorizedFact fingerprint + state <- CandidateProof State.get + unless + ( Backend.supportedPropositionTerm + (Backend.typedBackendFactProposition selected) + == frozenCoreTerm + (checkedPropositionTerm proposition) + ) + (failCandidateProof + (VampirePremiseMismatch fingerprint)) + let closure = + candidateProofObjectClosure state + supported <- + either + (const + (failCandidateProof + (VampirePremiseCapabilityMismatch + fingerprint))) + pure + (Backend.supportedProposition + Vector.empty + (embedClosedCore + [] + (checkedPropositionTerm proposition))) + capability <- + either + (const + (failCandidateProof + (VampirePremiseCapabilityMismatch + fingerprint))) + pure + (Backend.classifySupportedProposition + (`lookupCheckedObjectType` closure) + supported) + unless + (capability + == Backend.typedBackendFactCapability selected) + (failCandidateProof + (VampirePremiseCapabilityMismatch fingerprint)) + + validateFoundationAuxiliary builder auxiliary = do + let tag = Backend.typedProblemAuxiliaryTag auxiliary + actual = + Backend.supportedPropositionTerm + (Backend.typedProblemAuxiliaryProposition auxiliary) + expectedTerm = + frozenCoreTerm + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag)) + unless (actual == expectedTerm) + (Left (VampireFoundationMismatch tag)) + +execCandidateProof + :: CandidateProofState + -> CandidateProof value + -> ExceptT DeclarationError IO CandidateProofState +execCandidateProof initial action = + snd <$> State.runStateT (runCandidateProof action) initial + +failCandidateProof + :: DeclarationError + -> CandidateProof value +failCandidateProof = + CandidateProof . State.lift . Except.throwError + +data ValidationMode + = EnvironmentImportMode + | ProofValidationMode !ProofSyntaxId + | DeclarationValidationMode !DeclarationSyntaxId + +data PlannedVampireDisposition + = PlannedCachedRequest !Provers.PreparedVerificationRequest + | PlannedLiveRequest + !Provers.PreparedVerificationRequest + !Provers.VampireHandle + | PlannedSynchronousRequest !Provers.PreparedVerificationRequest + +data PlannedCandidate = PlannedCandidate + !ReservedCandidate + !FactAuthority + !DirectAuthorization + ![PlannedVampireDisposition] + +data PlannedReplayRequest + = ReplayLive + !Provers.PreparedVerificationRequest + !Provers.VampireHandle + | ReplaySynchronous !Provers.PreparedVerificationRequest + +data PlannedValidationSelection + = PlannedFreshValidation + | PlannedProofValidation + !ProofValidationKey + !ProofValidationRecord + | PlannedCompiledValidation + !DeclarationValidationKey + !DeclarationValidationRecord + +-- | One completely lowered and submitted declaration. It carries no +-- builder authorization or materialized certificate; all authority is +-- reconstructed by the source-ordered admission cursor. +data PlannedDeclaration body = PlannedDeclaration + !(CheckedDeclaration body) + !PrefixContextId + !PrefixContextId + !DeclarationInterfaceDelta + ![AssertedObject] + ![CheckedPropositionContent] + ![NonEmpty PlannedCandidate] + !PlannedValidationSelection + +plannedDeclarationPreviousPrefix + :: PlannedDeclaration body + -> PrefixContextId +plannedDeclarationPreviousPrefix + (PlannedDeclaration _checked previous _next _delta + _objects _propositions _candidates _validation) = + previous + +plannedDeclarationNextPrefix + :: PlannedDeclaration body + -> PrefixContextId +plannedDeclarationNextPrefix + (PlannedDeclaration _checked _previous next _delta + _objects _propositions _candidates _validation) = + next + +plannedDeclarationDelta + :: PlannedDeclaration body + -> DeclarationInterfaceDelta +plannedDeclarationDelta + (PlannedDeclaration _checked _previous _next delta + _objects _propositions _candidates _validation) = + delta + +newtype PlanningIntegrityError = PlanningIntegrityError Text + deriving stock (Show) + +instance Exception.Exception PlanningIntegrityError + +-- | Advance the authority-free semantic projection through one complete +-- checked declaration. Validation selection and every deterministic check +-- finish before the first live request is submitted. +planCheckedDeclaration + :: CheckedDeclaration body + -> LoweringDriver (Either DeclarationError (PlannedDeclaration body)) +planCheckedDeclaration checked@(CheckedDeclaration + mode objects explicitPropositions globals descriptors stages + _body) = LoweringDriver do + state@(LoweringState resolver (ProspectiveBuilder builder) validationRun) <- + State.get + prepared <- liftIO (Except.runExceptT do + closure <- + Except.liftEither + (first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects)) + let reservedStages = + reservePlanningStages builder stages + plannedWithoutDisposition <- + Except.liftEither + (preparePlannedCandidates builder closure reservedStages) + let orderedCandidates = fmap (fmap fst) plannedWithoutDisposition + occurrences = + [ candidateOccurrence reserved authority + | stage <- plannedWithoutDisposition + , (PlannedCandidate reserved authority _direct _requests, + _requestValues) <- toList stage + ] + aliases = + [ semanticAlias alias + (semanticFactFingerprint + (candidateOccurrence reserved authority)) + | stage <- plannedWithoutDisposition + , (PlannedCandidate reserved authority _direct _requests, + _requestValues) <- toList stage + , alias <- candidateAliases reserved + ] + allCandidatePropositions = + candidateCheckedProposition . fst + <$> concatMap toList reservedStages + propositions = + stableUniqueBy checkedPropositionId + (explicitPropositions <> allCandidatePropositions) + objectIds = assertedObjectId <$> objects + propositionIds = checkedPropositionId <$> propositions + ownSlot = declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + traverse_ + (\proposition -> + void + (Except.liftEither + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition)))))) + propositions + (resolvedStructures, delta, next) <- + Except.liftEither + (buildCheckedDeclarationDelta + builder closure ownSlot occurrences aliases objectIds + propositionIds (reverse globals) (reverse descriptors)) + selection <- + selectPlannedValidation + validationRun mode builder objects orderedCandidates + planned <- + submitPlannedCandidates resolver selection + plannedWithoutDisposition + let nextBuilder = + appendProspectiveBuilder + closure resolvedStructures delta next planned builder + declaration = + PlannedDeclaration checked + (logicalBuilderPrefix builder) + next delta objects propositions planned selection + pure (declaration, nextBuilder)) + case prepared of + Left failure -> pure (Left failure) + Right (declaration, nextBuilder) -> do + let LoweringState currentResolver _current currentValidation = state + State.put + (LoweringState + currentResolver + (ProspectiveBuilder nextBuilder) + currentValidation) + pure (Right declaration) + +reservePlanningStages + :: BuilderState PlanningEvidence + -> [NonEmpty CheckedCandidate] + -> [NonEmpty (ReservedCandidate, CandidatePlanningSpec)] +reservePlanningStages builder = + snd . mapAccumPlanning reserveStage (logicalBuilderNextFact builder) + where + invocation = DeclarationInvocation (logicalBuilderNextInvocation builder) + reserveStage nextFact (stageIndex, specs) = + let candidates = + NonEmpty.zipWith + (\offset (CheckedCandidate spec planning) -> + ( ReservedCandidate + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + invocation + (CandidateStage stageIndex) + (factSlot + (logicalBuilderOwner builder) + (localFactOrdinal (nextFact + offset))) + spec + , planning + )) + (0 :| [1..]) + specs + in ( nextFact + fromIntegral (NonEmpty.length specs) + , candidates + ) + + mapAccumPlanning action initial values = + go initial (zip [0..] values) + where + go accumulator [] = (accumulator, []) + go accumulator (value : remaining) = + let (next, result) = action accumulator value + (final, results) = go next remaining + in (final, result : results) + +preparePlannedCandidates + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> [NonEmpty (ReservedCandidate, CandidatePlanningSpec)] + -> Either + DeclarationError + [NonEmpty (PlannedCandidate, [CheckedPlannedVampireRequest])] +preparePlannedCandidates builder closure stages = + snd <$> mapAccumM prepareStage Map.empty (zip [0..] stages) + where + prepareStage earlier (stageIndex, stage) = do + (sameStage, planned) <- + mapAccumM + (prepareCandidate stageIndex earlier) + Map.empty + (zip [0..] (toList stage)) + pure (Map.union earlier sameStage, NonEmpty.fromList planned) + + prepareCandidate stageIndex earlier sameStage + (candidateIndex, (candidate, contract)) = do + let position = PlannedCandidatePosition stageIndex candidateIndex + (direct, safety, requests) <- + prepareCandidatePlanningContract + builder closure earlier position candidate contract + let authority = + candidateFactAuthority + (candidateTheoremReference builder candidate) + safety + planned = PlannedCandidate candidate authority direct [] + pure + ( Map.insert position (candidate, authority) sameStage + , (planned, requests) + ) + + mapAccumM action initial values = + go initial [] values + where + go accumulator outputs = \case + [] -> pure (accumulator, reverse outputs) + value : remaining -> do + (next, output) <- action accumulator value + go next (output : outputs) remaining + +prepareCandidatePlanningContract + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> Map PlannedCandidatePosition (ReservedCandidate, FactAuthority) + -> PlannedCandidatePosition + -> ReservedCandidate + -> CandidatePlanningSpec + -> Either + DeclarationError + ( DirectAuthorization + , CandidateSafety + , [CheckedPlannedVampireRequest] + ) +prepareCandidatePlanningContract builder closure earlier current candidate + (CandidatePlanningSpec direct extraFacts staged requests) = do + safetyWithFacts <- + foldM (accumulatePlanningFact builder closure) + initialCandidateSafety + (stableUniqueBy id + ( extraFacts + <> concatMap requestFacts requests + )) + safetyWithStages <- + foldM consumeStage safetyWithFacts staged + let safety = case direct of + PlanningSourceAxiom -> + addCandidateEscape SourceAxiom safetyWithStages + PlanningOmitted -> + addCandidateEscape Omitted safetyWithStages + _ -> safetyWithStages + requestIds = requestIdentity <$> requests + directAuthorization = case direct of + PlanningDefinitionEquation identity -> + CheckedKernelConstruction + (CheckedDefinitionEquation identity) + PlanningSourceAxiom -> SourceAxiomAuthorization + PlanningTrustedDatatype descriptor -> + TrustedCompilation (DatatypeCompilation descriptor) + PlanningKernelConstruction descriptor -> + CheckedKernelConstruction descriptor + PlanningCheckedSourceProof -> + CheckedSourceProof requestIds + PlanningOmitted -> OmittedAuthorization + validatePlanningDirect directAuthorization safety + pure (directAuthorization, safety, requests) + where + requestFacts + (CheckedPlannedVampireRequest _location _request facts) = facts + requestIdentity + (CheckedPlannedVampireRequest _location request _facts) = + Provers.preparedVerificationRequestId request + + consumeStage safety position = do + (premise, authority) <- + maybe + (Left + (PlanningFactContractMismatch + (reservedCandidateSlot candidate))) + Right + (Map.lookup position earlier) + let PlannedCandidatePosition premiseStage _premiseIndex = position + PlannedCandidatePosition currentStage _currentIndex = current + unless (premiseStage < currentStage) + (Left + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + premiseStage + (reservedCandidateSlot candidate) + currentStage)) + first FactSafetyFailed + (accumulateFactSafety + (candidateTheoremReference builder premise) + authority + safety) + +accumulatePlanningFact + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> CandidateSafety + -> SemanticFactOccurrenceFingerprint + -> Either DeclarationError CandidateSafety +accumulatePlanningFact builder closure safety fingerprint = do + FactEntry proposition occurrence (PlanningEvidence authority _provenance) <- + maybe + (Left (AuthorizedFactNotVisible fingerprint)) + Right + (Map.lookup fingerprint (logicalBuilderFacts builder)) + unless + ( semanticFactFingerprint occurrence == fingerprint + && semanticFactAuthority occurrence == authority + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch (semanticFactSlot occurrence))) + first FactSafetyFailed + (accumulateFactSafety + (theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId proposition)) + authority + safety) + +validatePlanningDirect + :: DirectAuthorization + -> CandidateSafety + -> Either DeclarationError () +validatePlanningDirect direct safety = + case direct of + SourceAxiomAuthorization -> + unless + (candidateSafetyAuthority safety + == authoritySafety (singletonEscapeKind SourceAxiom)) + (Left + (ValidationCertificateFailed + (SourceAxiomSafetyMismatch + (candidateSafetyAuthority safety)))) + OmittedAuthorization -> + unless + (Omitted `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (candidateSafetyAuthority safety))) + (Left + (ValidationCertificateFailed + (OmittedSafetyMissing + (candidateSafetyAuthority safety)))) + _ -> pure () + +selectPlannedValidation + :: ValidationRun + -> CheckedDeclarationMode + -> BuilderState PlanningEvidence + -> [AssertedObject] + -> [NonEmpty PlannedCandidate] + -> ExceptT DeclarationError IO PlannedValidationSelection +selectPlannedValidation validationRun mode builder objects stages = + case mode of + CheckedProofMode syntax -> + case concatMap toList stages of + [planned@(PlannedCandidate _candidate authority _direct _)] -> do + let key = proofValidationKey + (theoremId (factAuthorityTheorem authority)) + syntax + (logicalBuilderPrefix builder) + cached <- case validationRun of + FreshValidation -> pure Nothing + WarmValidation (ValidationLookup lookupProof _) -> + liftIO (lookupProof key) + traverse_ + (validateProof planned syntax) + cached + pure case cached of + Nothing -> PlannedFreshValidation + Just record -> PlannedProofValidation key record + candidates -> + Except.throwError + (CheckedProofCandidateCountMismatch + (length candidates)) + CheckedCompiledMode syntax -> do + let planned = concatMap toList stages + objectIds = assertedObjectId <$> objects + theorems = + theoremId . factAuthorityTheorem . plannedAuthority + <$> planned + key = declarationValidationKey syntax + (logicalBuilderPrefix builder) objectIds theorems + cached <- case validationRun of + FreshValidation -> pure Nothing + WarmValidation (ValidationLookup _ lookupDeclaration) -> + liftIO (lookupDeclaration key) + traverse_ + (validateCompiled planned syntax objectIds theorems) + cached + pure case cached of + Nothing -> PlannedFreshValidation + Just record -> PlannedCompiledValidation key record + where + plannedAuthority (PlannedCandidate _ authority _ _) = authority + + validateProof + (PlannedCandidate candidate authority direct _) + syntax record = + case Materialization.checkCandidateValidation + (logicalBuilderTheory builder) + (logicalBuilderPrefix builder) + (candidateCheckedProposition candidate) + authority direct + (Materialization.candidateProofValidation record syntax) of + Left failure -> + liftIO + (throwIO (CachedValidationIntegrityError failure)) + Right () -> pure () + + validateCompiled planned syntax objectIds theorems record = do + case Materialization.checkDeclarationValidationRecord + (logicalBuilderPrefix builder) + syntax objectIds theorems record of + Left failure -> + liftIO + (throwIO (CachedValidationIntegrityError failure)) + Right () -> pure () + traverse_ + (\(ordinal, + PlannedCandidate candidate authority direct _) -> + case Materialization.checkCandidateValidation + (logicalBuilderTheory builder) + (logicalBuilderPrefix builder) + (candidateCheckedProposition candidate) + authority direct + (Materialization.candidateDeclarationValidation + record syntax objectIds theorems ordinal) of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> pure ()) + (zip [0..] planned) + +submitPlannedCandidates + :: VampireResolver + -> PlannedValidationSelection + -> [NonEmpty (PlannedCandidate, [CheckedPlannedVampireRequest])] + -> ExceptT DeclarationError IO [NonEmpty PlannedCandidate] +submitPlannedCandidates resolver selection candidates + | cached = + pure (fmap (fmap cachedCandidate) candidates) + | otherwise = do + let requests = + [ VampireSubmission location request + | stage <- candidates + , (_candidate, plannedRequests) <- toList stage + , CheckedPlannedVampireRequest + location request _facts <- plannedRequests + ] + case resolver of + VampireResolver SynchronousVampireResolution{} -> + pure (fmap (fmap synchronousCandidate) candidates) + VampireResolver + (AsynchronousVampireSubmission submit) -> do + handles <- case NonEmpty.nonEmpty requests of + Nothing -> pure [] + Just nonempty -> do + submitted <- liftIO (submit nonempty) + unless + (NonEmpty.length submitted == length requests) + (Except.throwError + (VampireResolverBatchSizeMismatch + (length requests) + (NonEmpty.length submitted))) + pure (toList submitted) + let (planned, remaining) = + State.runState + (traverse (traverse liveCandidate) candidates) + handles + unless (null remaining) + (Except.throwError + (VampireResolverBatchSizeMismatch + (length requests) + (length requests + length remaining))) + pure planned + where + cached = case selection of + PlannedFreshValidation -> False + PlannedProofValidation{} -> True + PlannedCompiledValidation{} -> True + + cachedCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = + PlannedCandidate candidate authority direct + [ PlannedCachedRequest request + | CheckedPlannedVampireRequest + _location request _facts <- requests + ] + + liveCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = do + dispositions <- traverse takeHandle requests + pure (PlannedCandidate candidate authority direct dispositions) + + synchronousCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = + PlannedCandidate candidate authority direct + [ PlannedSynchronousRequest request + | CheckedPlannedVampireRequest + _location request _facts <- requests + ] + + takeHandle + (CheckedPlannedVampireRequest _location request _facts) = do + remaining <- State.get + case remaining of + [] -> + impossible + "validated prospective handle count became exhausted" + handle : later -> do + State.put later + pure (PlannedLiveRequest request handle) + +appendProspectiveBuilder + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> DeclarationInterfaceDelta + -> PrefixContextId + -> [NonEmpty PlannedCandidate] + -> BuilderState PlanningEvidence + -> BuilderState PlanningEvidence +appendProspectiveBuilder closure structures delta next planned builder = + builder + { logicalBuilderPrefix = next + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = + foldl' insertPlanningFact + (logicalBuilderFacts builder) + (concatMap toList planned) + , logicalBuilderAliases = + foldl' + (\entries alias -> + Map.insert + (semanticAliasName alias) + (ImportedAliasBinding + (semanticAliasTarget alias) + (ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias))) + entries) + (logicalBuilderAliases builder) + (declarationDeltaAliases delta) + , logicalBuilderGlobals = + foldl' + (\entries binding -> + Map.insert + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding) + entries) + (logicalBuilderGlobals builder) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + , logicalBuilderStructures = structures + , logicalBuilderDeltas = delta : logicalBuilderDeltas builder + , logicalBuilderNextDeclaration = + logicalBuilderNextDeclaration builder + 1 + , logicalBuilderNextFact = + logicalBuilderNextFact builder + + fromIntegral (sum (fmap NonEmpty.length planned)) + , logicalBuilderNextInvocation = + logicalBuilderNextInvocation builder + 1 + } + where + insertPlanningFact entries + (PlannedCandidate candidate authority _direct _requests) = + let occurrence = candidateOccurrence candidate authority + fingerprint = semanticFactFingerprint occurrence + evidence = PlanningEvidence authority + (Just + (PlanningProvenance + (declarationDeltaSlot delta) + (reservedStageValue candidate) + (reservedCandidateSlot candidate))) + in Map.insert fingerprint + (FactEntry + (candidateCheckedProposition candidate) + occurrence + evidence) + entries + + -- Keep the constructor match private while storing exact stage provenance. + reservedStageValue + (ReservedCandidate _identity _prefix _invocation stage _slot _spec) = + stage + +-- | Admit one checked declaration through the existing authoritative +-- source-order cursor. The callback interprets a closed family recipe over +-- freshly reserved stage slots; it is not retained in the checked value. +admitCheckedDeclaration + :: CheckedDeclaration body + -> (body -> [NonEmpty ReservedCandidate] -> Declaration ()) + -> ModuleDriver failure CommittedDeclarationBatch +admitCheckedDeclaration + (CheckedDeclaration + mode objects propositions globals structures stages body) + authorize = + snd <$> do + case mode of + CheckedProofMode syntax -> + commitProofDeclaration syntax do + reserved <- installCheckedStructure + authorize body reserved + CheckedCompiledMode syntax -> + commitCompiledDeclaration syntax do + reserved <- installCheckedStructure + authorizeCompiledDeclaration + (authorize body reserved) + where + installCheckedStructure = do + traverse_ addDeclarationObject objects + traverse_ addDeclarationProposition propositions + traverse_ + (\binding -> + stageSemanticGlobalBinding + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding)) + globals + traverse_ stageSemanticStructureDescriptor structures + traverse + (reserveCandidateBatch . fmap checkedCandidateSemanticSpec) + stages + + checkedCandidateSemanticSpec + (CheckedCandidate spec _planning) = spec + +-- | Admit one retained plan against the real authorized builder. The family +-- callback performs the existing authority checks, but every live resolver +-- result comes from the handle submitted during planning and every validation +-- lookup is the inert selection retained by the plan. +admitPlannedCheckedDeclaration + :: PlannedDeclaration body + -> (body -> [NonEmpty ReservedCandidate] -> Declaration ()) + -> ModuleDriver failure CommittedDeclarationBatch +admitPlannedCheckedDeclaration planned@(PlannedDeclaration + checked previous _expectedNext _expectedDelta _objects _propositions + candidates selection) authorize = ModuleDriver do + DriverState originalResolver builder prefix originalValidation <- + State.get + unless (logicalBuilderPrefix builder == previous) + (liftIO + (throwIO + (PlanningIntegrityError + "planned declaration predecessor does not match the admitted builder"))) + liveRef <- liftIO + (newIORef + [ replay + | stage <- candidates + , PlannedCandidate _candidate _authority _direct dispositions <- + toList stage + , disposition <- dispositions + , replay <- case disposition of + PlannedCachedRequest{} -> [] + PlannedLiveRequest request handle -> + [ReplayLive request handle] + PlannedSynchronousRequest request -> + [ReplaySynchronous request] + ]) + replay <- liftIO (plannedReplayResolver originalResolver liveRef) + let validation = plannedAdmissionValidation selection + State.put (DriverState replay builder prefix validation) + batch <- runDriverStep (admitCheckedDeclaration checked authorize) + remaining <- liftIO (readIORef liveRef) + unless (null remaining) + (liftIO + (throwIO + (PlanningIntegrityError + "admission did not consume every planned live request"))) + liftIO (validateAdmittedPlan planned batch) + DriverState _replay admittedBuilder admittedPrefix _plannedValidation <- + State.get + State.put + (DriverState + originalResolver admittedBuilder admittedPrefix originalValidation) + pure batch + +plannedReplayResolver + :: VampireResolver + -> IORef [PlannedReplayRequest] + -> IO VampireResolver +plannedReplayResolver original liveRef = + pure (vampireBatchResolver resolve) + where + resolve + :: forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + resolve tasks = do + expected <- atomicModifyIORef' liveRef \remaining -> + let amount = NonEmpty.length tasks + (selected, later) = splitAt amount remaining + in (later, selected) + unless (length expected == NonEmpty.length tasks) + (throwIO + (PlanningIntegrityError + "admission requested a different number of live Vampire results")) + traverse_ validateExpected (zip (toList tasks) expected) + case expected of + ReplayLive{} : _ -> do + unless (all isLive expected) + (throwIO + (PlanningIntegrityError + "planned resolver batch mixed execution modes")) + results <- traverse awaitOne expected + maybe + (throwIO + (PlanningIntegrityError + "an admission resolver batch was unexpectedly empty")) + pure + (NonEmpty.nonEmpty results) + ReplaySynchronous{} : _ -> + resolveSynchronousVampireBatch original tasks + [] -> + throwIO + (PlanningIntegrityError + "an admission resolver batch was unexpectedly empty") + + validateExpected (task, replay) = do + let actual = Provers.preparedTypedProverRequest task + expected = replayRequest replay + unless (actual == expected) + (throwIO + (PlanningIntegrityError + "admission request differs from its planned exact request")) + + awaitOne (ReplayLive expected handle) = + Provers.awaitPreparedVampireRequest expected handle + awaitOne ReplaySynchronous{} = + impossible "validated live resolver batch changed execution mode" + + replayRequest = \case + ReplayLive request _handle -> request + ReplaySynchronous request -> request + + isLive = \case + ReplayLive{} -> True + ReplaySynchronous{} -> False + +plannedAdmissionValidation + :: PlannedValidationSelection + -> ValidationRun +plannedAdmissionValidation = \case + PlannedFreshValidation -> FreshValidation + PlannedProofValidation expected record -> + WarmValidation + (validationLookup + (\actual -> + if actual == expected + then pure (Just record) + else throwIO + (PlanningIntegrityError + "proof validation key changed during admission")) + (\_actual -> pure Nothing)) + PlannedCompiledValidation expected record -> + WarmValidation + (validationLookup + (\_actual -> pure Nothing) + (\actual -> + if actual == expected + then pure (Just record) + else throwIO + (PlanningIntegrityError + "declaration validation key changed during admission"))) + +validateAdmittedPlan + :: PlannedDeclaration body + -> CommittedDeclarationBatch + -> IO () +validateAdmittedPlan + (PlannedDeclaration _checked expectedPrevious expectedNext expectedDelta + expectedObjects expectedPropositions candidates selection) + batch = do + let expectedContracts = + [ (authority, direct) + | stage <- candidates + , PlannedCandidate _candidate authority direct _requests <- + toList stage + ] + actualCertificates = + (proofValidationRecordCertificate + <$> committedBatchProofValidations batch) + <> maybe + [] + declarationValidationRecordCertificates + (committedBatchDeclarationValidation batch) + actualContracts = + [ ( validationTarget certificate + , validationDirectAuthorization certificate + ) + | certificate <- actualCertificates + ] + validationAgrees = case selection of + PlannedFreshValidation -> True + PlannedProofValidation _ record -> + committedBatchProofValidations batch == [record] + PlannedCompiledValidation _ record -> + committedBatchDeclarationValidation batch == Just record + unless + ( committedBatchPreviousPrefix batch == expectedPrevious + && committedBatchNextPrefix batch == expectedNext + && committedBatchDelta batch == expectedDelta + && committedBatchObjects batch == expectedObjects + && fmap propositionContract (committedBatchPropositions batch) + == fmap propositionContract expectedPropositions + && actualContracts == expectedContracts + && validationAgrees + ) + (throwIO + (PlanningIntegrityError + "admitted declaration differs from its prospective contract")) + where + propositionContract proposition = + ( checkedPropositionId proposition + , checkedPropositionTerm proposition + ) + +commitProofDeclaration + :: ProofSyntaxId + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitProofDeclaration syntax = + commitDeclaration (ProofValidationMode syntax) + +commitCompiledDeclaration + :: DeclarationSyntaxId + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitCompiledDeclaration syntax = + commitDeclaration (DeclarationValidationMode syntax) + +commitDeclaration + :: ValidationMode + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitDeclaration mode action = ModuleDriver do + DriverState resolver builder pendingPrefix validationRun <- + State.get + let + declaration = + initialDeclarationState + resolver + validationRun + mode + builder + result <- + liftIO + (Except.runExceptT + (State.runStateT + (runDeclaration action) + declaration)) + case result of + Left err -> + Except.throwError (DriverDeclarationFailed err) + Right (value, prepared) -> + case appendDeclaration mode prepared of + Left err -> + Except.throwError (DriverDeclarationFailed err) + Right (builder', batch) -> + let prefix' = appendPendingBatch batch pendingPrefix + in do + State.put + (DriverState + resolver + builder' + prefix' + validationRun) + pure (value, batch) + +initialDeclarationState + :: VampireResolver + -> ValidationRun + -> ValidationMode + -> LogicalBuilder + -> DeclarationState +initialDeclarationState resolver validationRun validationMode builder = + DeclarationState + { declarationVampireResolver = resolver + , declarationValidationRun = validationRun + , declarationValidationMode = validationMode + , declarationValidationSelection = + DeclarationValidationUnselected + , declarationBuilder = builder + , declarationOwnSlot = + declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + , declarationInvocation = + DeclarationInvocation + (logicalBuilderNextInvocation builder) + , declarationObjectsReversed = [] + , declarationObjectClosure = Nothing + , declarationPropositionsReversed = [] + , declarationGlobalBindingsReversed = [] + , declarationStructureDescriptorsReversed = [] + , declarationReservations = Map.empty + , declarationPending = Map.empty + , declarationNextFact = logicalBuilderNextFact builder + , declarationNextStage = 0 + , declarationAuthorizationFrontier = 0 + } + +appendDeclaration + :: ValidationMode + -> DeclarationState + -> Either + DeclarationError + (LogicalBuilder, CommittedDeclarationBatch) +appendDeclaration mode declaration = do + let builder = declarationBuilder declaration + reservations = Map.elems (declarationReservations declaration) + pending = declarationPending declaration + unless + (Map.keysSet pending + == Map.keysSet (declarationReservations declaration)) + (Left DeclarationHasUnauthorizedCandidates) + unless + (declarationAuthorizationFrontier declaration + == declarationNextStage declaration) + (Left DeclarationAuthorizationFrontierIncomplete) + case mode of + DeclarationValidationMode{} -> + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> + Left DeclarationValidationNotSelected + _ -> pure () + _ -> pure () + closure <- declarationClosure declaration + propositions <- validateDeclarationPropositions closure declaration + traverse_ (validatePendingAuthorization declaration) (Map.elems pending) + let orderedPending = + [ pendingCandidate + | reservation <- reservations + , let slot = reservedCandidateSlot reservation + , Just pendingCandidate <- [Map.lookup slot pending] + ] + occurrences = occurrenceFromPending <$> orderedPending + aliases = concatMap aliasesFromPending orderedPending + objectIds = + assertedObjectId + <$> reverse + (declarationObjectsReversed declaration) + propositionIds = + checkedPropositionId <$> propositions + (structures, delta, next) <- + buildCheckedDeclarationDelta + builder + closure + (declarationOwnSlot declaration) + occurrences + aliases + objectIds + propositionIds + (declarationGlobalBindingsReversed declaration) + (declarationStructureDescriptorsReversed declaration) + let previous = logicalBuilderPrefix builder + (proofValidations, declarationValidation) <- + buildValidationRecords + mode previous objectIds orderedPending + let builder' = + appendBuilderState + closure + structures + delta + next + orderedPending + builder + declaration + batch = + CommittedDeclarationBatch + (logicalBuilderOwner builder) + (declarationOwnSlot declaration) + previous + next + delta + (reverse + (declarationObjectsReversed declaration)) + propositions + proofValidations + declarationValidation + pure (builder', batch) + +-- | Construct and collision-check one canonical semantic delta without +-- inspecting fact evidence. This remains the admitted append path now and +-- is the shared delta seam for the later prospective builder. +buildCheckedDeclarationDelta + :: BuilderState evidence + -> CheckedObjectClosure + -> DeclarationSlot + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [ObjectId] + -> [PropositionId] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> Either + DeclarationError + ( Map SemanticStructurePhrase ResolvedStructure + , DeclarationInterfaceDelta + , PrefixContextId + ) +buildCheckedDeclarationDelta + builder closure slot occurrences aliases objectIds propositionIds + reversedBindings reversedDescriptors = do + let bindings = + List.sortOn + semanticGlobalBindingKey + (reverse reversedBindings) + descriptors = + List.sortOn + semanticStructureDescriptorPhrase + (reverse reversedDescriptors) + traverse_ + (\binding -> + first + (DeclarationGlobalTargetInvalid + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding)) + (validateSemanticGlobalBindingTarget + (structureOperationBindings + (logicalBuilderStructures builder)) + closure binding)) + bindings + traverse_ + (\descriptor -> + let structurePhrase = semanticStructureDescriptorPhrase descriptor + in when + (Map.member structurePhrase + (logicalBuilderStructures builder)) + (Left (BuilderStructureCollision structurePhrase))) + descriptors + structures <- foldM + (insertSemanticStructure closure) + (logicalBuilderStructures builder) + descriptors + environment <- + first DeclarationEnvironmentFailed + (semanticEnvironmentWithStructures bindings descriptors) + delta <- + first DeclarationInterfaceFailed + (declarationInterfaceDelta + slot + occurrences + aliases + objectIds + propositionIds + environment) + validateBuilderCollisions builder delta + pure + ( structures + , delta + , nextPrefixContextId (logicalBuilderPrefix builder) delta + ) + +declarationClosure + :: DeclarationState + -> Either DeclarationError CheckedObjectClosure +declarationClosure declaration = + case declarationObjectClosure declaration of + Just closure -> + Right closure + Nothing -> + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure + (declarationBuilder declaration)) + (reverse + (declarationObjectsReversed declaration))) + +prepareDeclarationClosure + :: DeclarationState + -> Either DeclarationError DeclarationState +prepareDeclarationClosure declaration = do + closure <- declarationClosure declaration + pure declaration{declarationObjectClosure = Just closure} + +validateDeclarationPropositions + :: CheckedObjectClosure + -> DeclarationState + -> Either DeclarationError [CheckedPropositionContent] +validateDeclarationPropositions closure declaration = do + let explicit = + reverse + (declarationPropositionsReversed declaration) + reserved = + candidateCheckedProposition + <$> Map.elems + (declarationReservations declaration) + propositions = stableUniqueBy checkedPropositionId (explicit <> reserved) + traverse_ + (\proposition -> + void + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition))))) + propositions + pure propositions + +validatePendingAuthorization + :: DeclarationState + -> PendingCandidate + -> Either DeclarationError () +validatePendingAuthorization declaration + (PendingCandidate candidate certificate authorization) = do + validateReservedCandidate declaration candidate + let builder = declarationBuilder declaration + PendingFactAuthorization + identity prefix invocation slot authority stage = + authorization + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot candidate + && authority == validationTarget certificate + && stage == reservedStage candidate + ) + (Left PendingFactAuthorizationMismatch) + +occurrenceFromPending + :: PendingCandidate + -> SemanticFactOccurrence +occurrenceFromPending + (PendingCandidate candidate certificate _authorization) = + candidateOccurrence candidate (validationTarget certificate) + +aliasesFromPending :: PendingCandidate -> [SemanticAlias] +aliasesFromPending pending@(PendingCandidate + candidate _certificate _authorization) = + let occurrence = occurrenceFromPending pending + fingerprint = semanticFactFingerprint occurrence + in (`semanticAlias` fingerprint) <$> candidateAliases candidate + +buildValidationRecords + :: ValidationMode + -> PrefixContextId + -> [ObjectId] + -> [PendingCandidate] + -> Either + DeclarationError + ([ProofValidationRecord], Maybe DeclarationValidationRecord) +buildValidationRecords mode prefix objects pending = + case mode of + EnvironmentImportMode -> + impossible + "environment import produced declaration validation records" + ProofValidationMode syntax -> + case pending of + [PendingCandidate _ certificate _] -> + let authority = validationTarget certificate + key = + proofValidationKey + (theoremId + (factAuthorityTheorem authority)) + syntax + prefix + in Right + ( [proofValidationRecord key certificate] + , Nothing + ) + _ -> + Left ProofDeclarationMustProduceOneFact + DeclarationValidationMode syntax -> + let certificates = + [ certificate + | PendingCandidate _ certificate _ <- pending + ] + theorems = + theoremId + . factAuthorityTheorem + . validationTarget + <$> certificates + key = + declarationValidationKey + syntax prefix objects theorems + in Right + ( [] + , Just + (declarationValidationRecord + key certificates) + ) + +validateBuilderCollisions + :: BuilderState evidence + -> DeclarationInterfaceDelta + -> Either DeclarationError () +validateBuilderCollisions builder delta = do + traverse_ + (\occurrence -> + when + (Map.member + (semanticFactFingerprint occurrence) + (logicalBuilderFacts builder)) + (Left + (BuilderFactCollision + (semanticFactFingerprint occurrence)))) + (declarationDeltaFacts delta) + traverse_ + (\alias -> + when + (Map.member + (semanticAliasName alias) + (logicalBuilderAliases builder)) + (Left + (BuilderAliasCollision + (semanticAliasName alias)))) + (declarationDeltaAliases delta) + traverse_ + (\identity -> + when + (identity + `Set.member` checkedObjectIds + (logicalBuilderObjectClosure builder)) + (Left (BuilderObjectCollision identity))) + (declarationDeltaObjects delta) + traverse_ + (\binding -> + case Map.lookup + (semanticGlobalBindingKey binding) + (logicalBuilderGlobals builder) of + Nothing -> pure () + Just existing -> + Left + (BuilderGlobalCollision + (semanticGlobalBindingKey binding) + existing)) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + +appendBuilderState + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> DeclarationInterfaceDelta + -> PrefixContextId + -> [PendingCandidate] + -> LogicalBuilder + -> DeclarationState + -> LogicalBuilder +appendBuilderState closure structures delta next pending builder declaration = + builder + { logicalBuilderPrefix = next + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = + foldl' + (insertAuthorizedFact builder) + (logicalBuilderFacts builder) + pending + , logicalBuilderAliases = + foldl' + (\entries alias -> + Map.insert + (semanticAliasName alias) + (ImportedAliasBinding + (semanticAliasTarget alias) + (ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias))) + entries) + (logicalBuilderAliases builder) + (declarationDeltaAliases delta) + , logicalBuilderGlobals = + foldl' + (\entries binding -> + Map.insert + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding) + entries) + (logicalBuilderGlobals builder) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + , logicalBuilderStructures = structures + , logicalBuilderDeltas = + delta : logicalBuilderDeltas builder + , logicalBuilderNextDeclaration = + logicalBuilderNextDeclaration builder + 1 + , logicalBuilderNextFact = + declarationNextFact declaration + , logicalBuilderNextInvocation = + logicalBuilderNextInvocation builder + 1 + } + +insertAuthorizedFact + :: LogicalBuilder + -> Map + SemanticFactOccurrenceFingerprint + (FactEntry BuilderFactAuthorization) + -> PendingCandidate + -> Map + SemanticFactOccurrenceFingerprint + (FactEntry BuilderFactAuthorization) +insertAuthorizedFact builder entries pending@(PendingCandidate + candidate certificate _pendingAuthorization) = + let occurrence = occurrenceFromPending pending + fingerprint = semanticFactFingerprint occurrence + authority = validationTarget certificate + authorization = + BuilderFactAuthorization + (logicalBuilderIdentity builder) + (reservedCandidateSlot candidate) + authority + in Map.insert + fingerprint + (FactEntry + (candidateCheckedProposition candidate) + occurrence + authorization) + entries + +stableUniqueBy :: Ord key => (value -> key) -> [value] -> [value] +stableUniqueBy key = + reverse . snd + . foldl' + (\(seen, values) value -> + let identity = key value + in if identity `Set.member` seen + then (seen, values) + else + ( Set.insert identity seen + , value : values + )) + (Set.empty, []) + + +data DeclarationError + = CandidateOutsideDeclaration !FactSlot + | CandidateAlreadyAuthorized !FactSlot + | CandidateOutsideAuthorizationFrontier + !FactSlot !Natural !Natural + | DeclarationHasUnauthorizedCandidates + | DeclarationAuthorizationFrontierIncomplete + | CandidatePropositionNotClosed + | CandidatePropositionNotProposition !CoreType + | StagedPremiseNotEarlier + !FactSlot !Natural !FactSlot !Natural + | StagedPremiseNotAuthorized !FactSlot + | AuthorizedFactNotVisible + !SemanticFactOccurrenceFingerprint + | BuilderFactAuthorizationMismatch + | PendingFactAuthorizationMismatch + | PlanningFactContractMismatch !FactSlot + | CheckedAuthorizationCandidateShapeMismatch !Int !Int + | CheckedProofCandidateCountMismatch !Int + | LocalClaimOutsideCandidate + | FactSafetyFailed !FactSafetyError + | ValidationCertificateFailed !ValidationCertificateError + | DerivationImportFailed !DerivationImportError + | KernelCompletionFailed !KernelReplayError + | KernelConstructionDescriptorMismatch + | DefinitionEquationObjectMissing !ObjectId + | DefinitionEquationObjectNotTransparent !ObjectId + | DefinitionEquationObjectNotPointwisePredicate !ObjectId + | DefinitionEquationCandidateMismatch + | DatatypeCompilationDescriptorMismatch + | ProofObligationFailedAt !Location !DeclarationError + | VampireProcessFailed !Provers.ProverProcessError + | VampireObligationRejected !Provers.ProverAnswer + | VampireProofHasNoAcceptedObligations + | VampireCandidateBatchMismatch ![FactSlot] ![FactSlot] + | VampireCandidateBatchProofShapeMismatch !FactSlot + | VampireResolverBatchSizeMismatch !Int !Int + | OmittedProofDidNotRecordUse + | VampireRequestMismatch + | VampireTargetMismatch + | VampireLocalPremisesNotSupported + | VampireGlobalTypeMismatch !ObjectId + | VampirePremiseMismatch + !SemanticFactOccurrenceFingerprint + | VampirePremiseCapabilityMismatch + !SemanticFactOccurrenceFingerprint + | VampireFoundationMismatch !FoundationAxiomTag + | CurrentCandidateVampirePreparationFailed + !(VampireObligationPreparationError Void) + | ProofValidationOutsideProofDeclaration + | DeclarationValidationOutsideCompiledDeclaration + | DeclarationValidationAlreadySelected + | DeclarationValidationNotSelected + | DeclarationShapeChangedAfterValidationLookup + | CachedDeclarationCandidateMissing !FactSlot + | ImportedModuleNotDirect !SemanticInterfaceId + | ImportedFactMaterializationFailed + !Materialization.MaterializationError + | ImportedFactCollision + !SemanticFactOccurrenceFingerprint + | ImportedAliasCollision + !SemanticName !ImportedAliasOrigin !ImportedAliasOrigin + | ImportedAliasTargetMissing + !SemanticFactOccurrenceFingerprint + | ImportedGlobalCollision + !SemanticGlobalKey !SemanticGlobalTarget !SemanticGlobalTarget + | ImportedGlobalTargetInvalid + !SemanticGlobalKey + !SemanticGlobalTarget + !SemanticGlobalTargetError + | ImportedStructureCollision + !SemanticStructurePhrase + !SemanticStructureDescriptor + !SemanticStructureDescriptor + | SemanticStructureParentMissing + !SemanticStructurePhrase !SemanticStructurePhrase + | SemanticStructureOperationConflict + !StructSymbol !SemanticStructurePhrase !SemanticStructurePhrase + | SemanticStructurePredicateTargetInvalid + !SemanticStructurePhrase !ObjectId !(Maybe CoreType) !CoreType + | SemanticStructureOperationTargetInvalid + !SemanticStructurePhrase !StructSymbol !ObjectId !(Maybe CoreType) !CoreType + | ImportedEvidenceDirectMismatch + ![SemanticInterfaceId] ![SemanticInterfaceId] + | ImportedEvidenceInterfaceFailed !SemanticInterfaceError + | ImportedEvidenceObjectMissing !ObjectId + | ImportedEvidencePropositionMissing !PropositionId + | ImportedModuleAfterAuthorization + | DeclarationObjectAddedAfterAuthorization + | DeclarationObjectValidationFailed !ObjectValidationError + | DeclarationPropositionValidationFailed + !PropositionValidationError + | DeclarationInterfaceFailed !DeclarationInterfaceError + | DeclarationEnvironmentFailed !SemanticEnvironmentError + | DeclarationGlobalAlreadyStaged !SemanticGlobalKey + | DeclarationStructureAlreadyStaged !SemanticStructurePhrase + | DeclarationGlobalTargetInvalid + !SemanticGlobalKey + !SemanticGlobalTarget + !SemanticGlobalTargetError + | ProofDeclarationMustProduceOneFact + | BuilderFactCollision + !SemanticFactOccurrenceFingerprint + | BuilderAliasCollision !SemanticName + | BuilderObjectCollision !ObjectId + | BuilderGlobalCollision !SemanticGlobalKey !SemanticGlobalTarget + | BuilderStructureCollision !SemanticStructurePhrase + deriving stock (Show, Eq) + +declarationErrorLocation :: DeclarationError -> Maybe Location +declarationErrorLocation = \case + ProofObligationFailedAt location _failure -> + Just location + _failure -> + Nothing + +renderDeclarationError :: DeclarationError -> Text +renderDeclarationError = \case + CandidateOutsideDeclaration slot -> + "candidate " <> shown slot <> " does not belong to this declaration" + CandidateAlreadyAuthorized slot -> + "candidate " <> shown slot <> " was authorized more than once" + CandidateOutsideAuthorizationFrontier slot expected actual -> + "candidate " <> shown slot <> " is outside authorization frontier " + <> shown expected <> " (found " <> shown actual <> ")" + DeclarationHasUnauthorizedCandidates -> + "the declaration has unauthorized candidates" + DeclarationAuthorizationFrontierIncomplete -> + "the declaration authorization frontier is incomplete" + CandidatePropositionNotClosed -> + "the candidate proposition still has open local binders" + CandidatePropositionNotProposition actual -> + "the candidate has type " <> shown actual <> " instead of Prop" + StagedPremiseNotEarlier candidate candidateOrdinal premise premiseOrdinal -> + "candidate " <> shown candidate <> " at stage " <> shown candidateOrdinal + <> " depends on non-earlier premise " <> shown premise + <> " at stage " <> shown premiseOrdinal + StagedPremiseNotAuthorized slot -> + "staged premise " <> shown slot <> " is not authorized" + AuthorizedFactNotVisible fingerprint -> + "authorized fact " <> shown fingerprint <> " is not visible" + BuilderFactAuthorizationMismatch -> + "builder fact authority does not match the checked declaration" + PendingFactAuthorizationMismatch -> + "pending fact authority does not match the checked declaration" + PlanningFactContractMismatch slot -> + "checked declaration-stage fact " <> shown slot + <> " has inconsistent semantic provenance" + CheckedAuthorizationCandidateShapeMismatch expected actual -> + "checked declaration recipe expected " <> shown expected + <> " candidate stages but received " <> shown actual + CheckedProofCandidateCountMismatch actual -> + "checked proof declaration requires exactly one candidate but received " + <> shown actual + LocalClaimOutsideCandidate -> + "proof-local claim was used outside a candidate proof" + FactSafetyFailed{} -> + "fact-safety validation failed" + ValidationCertificateFailed{} -> + "validation-certificate checking failed" + DerivationImportFailed{} -> + "kernel derivation import failed" + KernelCompletionFailed{} -> + "kernel replay failed" + KernelConstructionDescriptorMismatch -> + "kernel construction does not match its checked descriptor" + DefinitionEquationObjectMissing identity -> + "definition equation references missing object " <> shown identity + DefinitionEquationObjectNotTransparent identity -> + "definition equation references non-transparent object " <> shown identity + DefinitionEquationObjectNotPointwisePredicate identity -> + "definition equation object " <> shown identity + <> " is not a unary predicate definition" + DefinitionEquationCandidateMismatch -> + "definition equation does not match its checked object content" + DatatypeCompilationDescriptorMismatch -> + "datatype compilation does not match its complete checked family" + ProofObligationFailedAt location failure -> + locationToText location <> ": " <> renderDeclarationError failure + VampireProcessFailed{} -> + "Vampire process failed while authorizing the declaration" + VampireObligationRejected{} -> + "Vampire did not accept a declaration obligation" + VampireProofHasNoAcceptedObligations -> + "Vampire proof contains no accepted obligations" + VampireCandidateBatchMismatch expected actual -> + "Vampire candidate batch does not match the complete authorization " + <> "stage (expected " <> shown expected + <> ", found " <> shown actual <> ")" + VampireCandidateBatchProofShapeMismatch slot -> + "Vampire candidate " <> shown slot + <> " performed execution before its ready batch" + VampireResolverBatchSizeMismatch expected actual -> + "Vampire resolver returned " <> shown actual + <> " results for " <> shown expected <> " requests" + OmittedProofDidNotRecordUse -> + "omitted proof completion did not record an omission" + VampireRequestMismatch -> + "accepted Vampire run does not match the prepared request" + VampireTargetMismatch -> + "Vampire request target does not match the candidate theorem" + VampireLocalPremisesNotSupported -> + "typed Vampire requests do not yet support local premises" + VampireGlobalTypeMismatch object -> + "Vampire request has the wrong type for global object " <> shown object + VampirePremiseMismatch fingerprint -> + "Vampire request premise does not match visible fact " <> shown fingerprint + VampirePremiseCapabilityMismatch fingerprint -> + "Vampire request lacks authority for premise " <> shown fingerprint + VampireFoundationMismatch tag -> + "Vampire request has inconsistent foundation axiom " <> shown tag + CurrentCandidateVampirePreparationFailed failure -> + "the staged Vampire obligation could not be prepared: " <> shown failure + ProofValidationOutsideProofDeclaration -> + "proof validation requires a proof declaration" + DeclarationValidationOutsideCompiledDeclaration -> + "declaration validation requires a compiled declaration" + DeclarationValidationAlreadySelected -> + "compiled declaration validation was selected more than once" + DeclarationValidationNotSelected -> + "compiled declaration validation was not selected" + DeclarationShapeChangedAfterValidationLookup -> + "compiled declaration shape changed after validation lookup" + CachedDeclarationCandidateMissing slot -> + "cached declaration validation has no candidate for " <> shown slot + ImportedModuleNotDirect interface -> + "sealed semantic interface is not a direct import: " <> shown interface + ImportedFactMaterializationFailed{} -> + "imported fact failed materialization checks" + ImportedFactCollision fingerprint -> + "imported fact " <> shown fingerprint <> " is already registered" + ImportedAliasCollision alias earlier later -> + "imported semantic alias " <> shown alias + <> " conflicts between " <> shown earlier + <> " and " <> shown later + ImportedAliasTargetMissing fingerprint -> + "imported alias targets missing fact " <> shown fingerprint + ImportedGlobalCollision key earlier later -> + "imported global " <> shown key + <> " has conflicting targets " <> shown earlier + <> " and " <> shown later + ImportedGlobalTargetInvalid key target _failure -> + "imported global " <> shown key + <> " has invalid target " <> shown target + ImportedEvidenceDirectMismatch expected actual -> + "imported semantic parents differ: expected " <> shown expected + <> ", found " <> shown actual + ImportedStructureCollision structurePhrase _existing _incoming -> + "structure " <> shown structurePhrase <> " has conflicting descriptors" + SemanticStructureParentMissing structurePhrase parent -> + "structure " <> shown structurePhrase <> " has unknown parent " <> shown parent + SemanticStructureOperationConflict symbol firstOrigin secondOrigin -> + "structure operation " <> shown symbol <> " conflicts between " + <> shown firstOrigin <> " and " <> shown secondOrigin + SemanticStructurePredicateTargetInvalid structurePhrase object _actual expected -> + "structure " <> shown structurePhrase <> " has invalid predicate object " + <> shown object <> " (expected " <> shown expected <> ")" + SemanticStructureOperationTargetInvalid structurePhrase symbol object _actual expected -> + "structure " <> shown structurePhrase <> " has invalid operation " + <> shown symbol <> " object " <> shown object + <> " (expected " <> shown expected <> ")" + ImportedEvidenceInterfaceFailed{} -> + "imported semantic interface failed validation" + ImportedEvidenceObjectMissing identity -> + "imported semantic interface is missing object " <> shown identity + ImportedEvidencePropositionMissing identity -> + "imported semantic interface is missing proposition " <> shown identity + ImportedModuleAfterAuthorization -> + "a sealed module was imported after candidate authorization" + DeclarationObjectAddedAfterAuthorization -> + "the declaration added an object after candidate authorization" + DeclarationObjectValidationFailed{} -> + "declaration object validation failed" + DeclarationPropositionValidationFailed{} -> + "declaration proposition validation failed" + DeclarationInterfaceFailed{} -> + "declaration interface validation failed" + DeclarationEnvironmentFailed{} -> + "declaration environment delta is inconsistent" + DeclarationGlobalAlreadyStaged key -> + "global " <> shown key <> " was staged more than once" + DeclarationStructureAlreadyStaged structurePhrase -> + "structure " <> shown structurePhrase <> " was staged more than once" + DeclarationGlobalTargetInvalid key target _failure -> + "global " <> shown key <> " has invalid target " <> shown target + ProofDeclarationMustProduceOneFact -> + "a proof declaration must produce exactly one fact" + BuilderFactCollision fingerprint -> + "fact " <> shown fingerprint <> " is already registered" + BuilderAliasCollision alias -> + "semantic alias " <> shown alias <> " is already registered" + BuilderObjectCollision object -> + "object " <> shown object <> " is already registered" + BuilderGlobalCollision key object -> + "global " <> shown key <> " is already bound to " <> shown object + BuilderStructureCollision structurePhrase -> + "structure " <> shown structurePhrase <> " is already registered" + where + shown :: Show value => value -> Text + shown = Text.pack . show diff --git a/source/Felix/Checking/Exact.hs b/source/Felix/Checking/Exact.hs new file mode 100644 index 0000000..c829743 --- /dev/null +++ b/source/Felix/Checking/Exact.hs @@ -0,0 +1,3936 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Direct compiler for the first exact monomorphic declaration family. +module Felix.Checking.Exact + ( ExactLocalId + , exactLocalId + , exactLocalIdValue + , ExactBinderContext + , emptyExactBinderContext + , extendExactBinderContext + , extendExactAnonymousBinderContext + , exactBinderContextSupport + , exactBinderContextIndex + , PreparedExactProposition + , preparedExactPropositionCore + , prepareExactProposition + , prepareExactSymbolicBoundConstraints + , prepareExactSymbolicWitnessConstraints + , prepareExactNounWitnessConstraints + , PreparedExactSetExpression + , PreparedExactSetConstruction(..) + , preparedExactSetExpressionCore + , preparedExactSetExpressionConstruction + , prepareExactSetExpression + , PreparedExactLocalFunctionGraph + , preparedExactLocalFunctionGraphCore + , preparedExactLocalFunctionGraphDomain + , preparedExactLocalFunctionGraphMap + , prepareExactLocalFunctionGraph + , PreparedExactClaimEnvelope + , preparedExactClaimTarget + , preparedExactClaimVariables + , preparedExactClaimContext + , preparedExactClaimAntecedentCount + , prepareExactClaimEnvelope + , PreparedExactDeclaration + , preparedExactLocation + , preparedExactGlobalKey + , preparedExactObjectId + , preparedExactObject + , preparedExactSyntaxId + , preparedExactIsDefinition + , prepareExactDeclaration + , lowerPreparedExactBinding + , CheckedExactBindingAuthorization + , authorizeCheckedExactBinding + , PreparedExactStructure + , prepareExactStructure + , CheckedExactStructureAuthorization + , lowerPreparedExactStructure + , authorizeCheckedExactStructure + , PreparedExactSourceAxiom + , prepareExactSourceAxiom + , lowerPreparedExactSourceAxiom + , authorizeCheckedExactSourceAxiom + , ExactCompileError(..) + , exactCompileErrorLocation + , renderExactCompileError + ) where + +import Base hiding (Empty) +import Felix.Cache.Codec +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction +import Felix.Module +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface (CanonicalLexicalEntry(..)) +import Felix.Syntax.Lexicon qualified as Lexicon + +import Control.Monad.Except (ExceptT) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.ByteString (ByteString) +import Data.Bifunctor (first) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +-- | A disposable identity allocated in source order within one proof. +newtype ExactLocalId = ExactLocalId Natural + deriving stock (Show, Eq, Ord) + +exactLocalId :: Natural -> ExactLocalId +exactLocalId = ExactLocalId + +exactLocalIdValue :: ExactLocalId -> Natural +exactLocalIdValue (ExactLocalId value) = value + +data ExactBinder = ExactBinder + !ExactLocalId + !(Maybe Raw.VarSymbol) + !CoreType + !(Maybe ExactStructureAnnotation) + +data ExactStructureAnnotation = ExactStructureAnnotation + !SemanticStructurePhrase + !(Maybe ObjectId) + !(Map.Map Raw.StructSymbol ObjectId) + +-- | The active nearest-first binders of one exact proof scope. +newtype ExactBinderContext = ExactBinderContext [ExactBinder] + +emptyExactBinderContext :: ExactBinderContext +emptyExactBinderContext = ExactBinderContext [] + +extendExactBinderContext + :: NonEmpty (ExactLocalId, Raw.VarSymbol) + -> ExactBinderContext + -> Either ExactCompileError ExactBinderContext +extendExactBinderContext additions (ExactBinderContext initial) = + ExactBinderContext <$> foldM add initial (toList additions) + where + add binders (identity, variable) + | any (sameVariable variable) binders = + Left (ExactDuplicateLocalBinder (locate variable) variable) + | any (sameIdentity identity) binders = + Left (ExactDuplicateLocalIdentity (locate variable) identity) + | otherwise = + Right (ExactBinder identity (Just variable) TySet Nothing : binders) + + sameVariable variable (ExactBinder _identity existing _coreType _structure) = + existing == Just variable + + sameIdentity identity (ExactBinder existing _variable _coreType _structure) = + existing == identity + +-- | Add one proof-owned binder which deliberately has no source-resolvable +-- spelling. This is used for a nameless singular witness; it participates in +-- checked support and de Bruijn weakening but cannot shadow or be looked up by +-- a later source variable. +extendExactAnonymousBinderContext + :: ExactLocalId + -> ExactBinderContext + -> Either ExactCompileError ExactBinderContext +extendExactAnonymousBinderContext identity (ExactBinderContext binders) + | any sameIdentity binders = + Left (ExactDuplicateLocalIdentity Nowhere identity) + | otherwise = + Right + (ExactBinderContext + (ExactBinder identity Nothing TySet Nothing : binders)) + where + sameIdentity (ExactBinder existing _variable _coreType _structure) = + existing == identity + +exactBinderContextSupport + :: ExactBinderContext + -> Vector (ExactLocalId, CoreType) +exactBinderContextSupport (ExactBinderContext binders) = + Vector.fromList + [ (identity, coreType) + | ExactBinder identity _variable coreType _structure <- binders + ] + +exactBinderContextIndex + :: Raw.VarSymbol + -> ExactBinderContext + -> Maybe Natural +exactBinderContextIndex variable (ExactBinderContext binders) = + go 0 binders + where + go _index [] = + Nothing + go index (ExactBinder _identity candidate _coreType _structure : rest) + | candidate == Just variable = Just index + | otherwise = go (index + 1) rest + +newtype PreparedExactProposition = PreparedExactProposition + (ScopedCheckedCore ObjectId) + +preparedExactPropositionCore + :: PreparedExactProposition + -> ScopedCheckedCore ObjectId +preparedExactPropositionCore (PreparedExactProposition proposition) = + proposition + +data PreparedExactSetExpression = PreparedExactSetExpression + !(ScopedCheckedCore ObjectId) + !(Maybe PreparedExactSetConstruction) + +data PreparedExactSetConstruction + = PreparedUnconditionalSetConstruction + !(NamedSetConstruction ObjectId) + | PreparedRelationalSetConstruction + !(CheckedRelationalSetConstruction ObjectId) + +preparedExactSetExpressionCore + :: PreparedExactSetExpression + -> ScopedCheckedCore ObjectId +preparedExactSetExpressionCore (PreparedExactSetExpression expression _construction) = + expression + +preparedExactSetExpressionConstruction + :: PreparedExactSetExpression + -> Maybe PreparedExactSetConstruction +preparedExactSetExpressionConstruction + (PreparedExactSetExpression _expression construction) = + construction + +-- | A checked replacement graph and the two checked arguments used to +-- specialize its foundation characteristic. This is transient proof +-- preparation data, not a declaration or durable object. +data PreparedExactLocalFunctionGraph = PreparedExactLocalFunctionGraph + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + +preparedExactLocalFunctionGraphCore + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphCore + (PreparedExactLocalFunctionGraph graph _domain _function) = + graph + +preparedExactLocalFunctionGraphDomain + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphDomain + (PreparedExactLocalFunctionGraph _graph domain _function) = + domain + +preparedExactLocalFunctionGraphMap + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphMap + (PreparedExactLocalFunctionGraph _graph _domain function) = + function + +-- | One authoritative closed proposition prepared from a top-level claim +-- header and conclusion. The remaining fields are transient opening data for +-- the proof compiler. +data PreparedExactClaimEnvelope = PreparedExactClaimEnvelope + !(ScopedCheckedCore ObjectId) + ![Raw.VarSymbol] + !ExactBinderContext + !Natural + +preparedExactClaimTarget + :: PreparedExactClaimEnvelope + -> ScopedCheckedCore ObjectId +preparedExactClaimTarget + (PreparedExactClaimEnvelope target _variables _context _antecedents) = + target + +preparedExactClaimVariables + :: PreparedExactClaimEnvelope + -> [Raw.VarSymbol] +preparedExactClaimVariables + (PreparedExactClaimEnvelope _target variables _context _antecedents) = + variables + +preparedExactClaimContext + :: PreparedExactClaimEnvelope + -> ExactBinderContext +preparedExactClaimContext + (PreparedExactClaimEnvelope _target _variables context _antecedents) = + context + +preparedExactClaimAntecedentCount + :: PreparedExactClaimEnvelope + -> Natural +preparedExactClaimAntecedentCount + (PreparedExactClaimEnvelope _target _variables _context antecedents) = + antecedents + + +data ExactDeclarationFamily + = ExactSignature + | ExactAbbreviation + | ExactDefinition + deriving stock (Show, Eq, Ord) + +data PreparedExactDeclaration = PreparedExactDeclaration + !Location + !ExactDeclarationFamily + !SemanticGlobalKey + !SemanticGlobalTarget + !(Maybe AssertedObject) + !(Maybe SemanticName) + !(Maybe PreparedExactSetConstruction) + !DeclarationSyntaxId + +preparedExactLocation :: PreparedExactDeclaration -> Location +preparedExactLocation + (PreparedExactDeclaration location _family _key _target _object _alias _construction _syntax) = + location + +preparedExactGlobalKey :: PreparedExactDeclaration -> SemanticGlobalKey +preparedExactGlobalKey + (PreparedExactDeclaration _location _family key _target _object _alias _construction _syntax) = + key + +preparedExactObjectId :: PreparedExactDeclaration -> ObjectId +preparedExactObjectId + (PreparedExactDeclaration _location _family _key target _object _alias _construction _syntax) = + semanticGlobalTargetObject target + +preparedExactObject + :: PreparedExactDeclaration + -> Maybe AssertedObject +preparedExactObject + (PreparedExactDeclaration _location _family _key _target object _alias _construction _syntax) = + object + +preparedExactSyntaxId + :: PreparedExactDeclaration + -> DeclarationSyntaxId +preparedExactSyntaxId + (PreparedExactDeclaration _location _family _key _target _object _alias _construction syntax) = + syntax + +preparedExactIsDefinition :: PreparedExactDeclaration -> Bool +preparedExactIsDefinition + (PreparedExactDeclaration _location family _key _target _object _alias _construction _syntax) = + family == ExactDefinition + +preparedExactGlobalTarget + :: PreparedExactDeclaration + -> SemanticGlobalTarget +preparedExactGlobalTarget + (PreparedExactDeclaration + _location _family _key target _object _alias _construction _syntax) = + target + +preparedDefinitionAlias + :: PreparedExactDeclaration + -> Maybe SemanticName +preparedDefinitionAlias + (PreparedExactDeclaration + _location _family _key _target _object alias _construction _syntax) = + alias + +preparedDefinitionConstruction + :: PreparedExactDeclaration + -> Maybe PreparedExactSetConstruction +preparedDefinitionConstruction + (PreparedExactDeclaration + _location _family _key _target _object _alias construction _syntax) = + construction + +data PreparedExactSourceAxiom = PreparedExactSourceAxiom + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !DeclarationSyntaxId + +data PreparedExactStructureFact = PreparedExactStructureFact + !Location + !(FrozenCheckedCore ObjectId) + !SemanticName + +data PreparedExactStructure = PreparedExactStructure + !Location + ![AssertedObject] + !ObjectId + !SemanticStructureDescriptor + !SemanticName + ![PreparedExactStructureFact] + !DeclarationSyntaxId + +data CheckedExactStructureAuthorization = + CheckedExactStructureAuthorization + !ObjectId + ![(Location, Declaration.PreparedVampireObligation Void ())] + +data ExactCompileError + = ExactUnsupportedDeclaration !Location + | ExactUnsupportedDeclarationBody !Location + | ExactNonCanonicalSetDefinitionAnnotation !Location + | ExactGuardedTransparentDefinition !Location + | ExactGuardedOpaqueSignature !Location + | ExactDefinitionCombinedSymbolicAlias !Location + | ExactRelationalReplacementRequiresNamedDefinition !Location + | ExactDeclarationOccurrenceMissing !Location + | ExactDeclarationOccurrenceAmbiguous !Location + | ExactDeclarationHeadMismatch !Location + | ExactFixedSemanticCollision !Location !SemanticGlobalKey + | ExactGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactGlobalNotVisible !Location !SemanticGlobalKey + | ExactDuplicateParameter !Location !Raw.VarSymbol + | ExactDuplicateLocalBinder !Location !Raw.VarSymbol + | ExactDuplicateLocalIdentity !Location !ExactLocalId + | ExactFreeVariable !Location !Raw.VarSymbol + | ExactApplicationExpectedFunction !Location !CoreType + | ExactApplicationArgumentMismatch + !Location !CoreType !CoreType + | ExactExpressionExpectedSet !Location !CoreType + | ExactFormulaExpectedProposition !Location !CoreType + | ExactCoreCheckFailed !Location !CoreCheckError + | ExactObjectTypeMismatch !Location !CoreType !CoreType + | ExactUnsupportedHeaderAssumption !Location + | ExactQuantifiedTermRequiresPropositionContext !Location + | ExactStructureNotVisible !Location !SemanticStructurePhrase + | ExactBaseStructureNotAssertable !Location !SemanticStructurePhrase + | ExactDuplicateStructureAnnotation !Location !Raw.VarSymbol + | ExactStructureOperationNotAvailable !Location !Raw.StructSymbol + | ExactStructureOperationAmbiguous + !Location !Raw.StructSymbol ![ObjectId] + | ExactContextualExpansionNotAvailable + !Location !SemanticGlobalKey + | ExactContextualRequirementConflict + !Location !Raw.StructSymbol !ObjectId !ObjectId + | ExactStructureOccurrenceMismatch !Location + | ExactStructureSelfParent !Location !SemanticStructurePhrase + | ExactStructureDuplicateParent !Location !SemanticStructurePhrase + | ExactStructureAlreadyVisible !Location !SemanticStructurePhrase + | ExactStructureDuplicateOperation !Location !Raw.StructSymbol + | ExactStructureOperationAlreadyInherited !Location !Raw.StructSymbol + | ExactStructureOperationConflict + !Location !Raw.StructSymbol + !SemanticStructurePhrase !SemanticStructurePhrase + | ExactStructureHasNoCarrier !Location !SemanticStructurePhrase + | ExactStructureDescriptorInvalid !Location !SemanticEnvironmentError + | ExactStructureObjectNotVisible !Location !ObjectId + deriving stock (Show, Eq) + +exactCompileErrorLocation :: ExactCompileError -> Location +exactCompileErrorLocation = \case + ExactUnsupportedDeclaration location -> location + ExactUnsupportedDeclarationBody location -> location + ExactNonCanonicalSetDefinitionAnnotation location -> location + ExactGuardedTransparentDefinition location -> location + ExactGuardedOpaqueSignature location -> location + ExactDefinitionCombinedSymbolicAlias location -> location + ExactRelationalReplacementRequiresNamedDefinition location -> location + ExactDeclarationOccurrenceMissing location -> location + ExactDeclarationOccurrenceAmbiguous location -> location + ExactDeclarationHeadMismatch location -> location + ExactFixedSemanticCollision location _key -> location + ExactGlobalAlreadyVisible location _key -> location + ExactGlobalNotVisible location _key -> location + ExactDuplicateParameter location _parameter -> location + ExactDuplicateLocalBinder location _variable -> location + ExactDuplicateLocalIdentity location _identity -> location + ExactFreeVariable location _variable -> location + ExactApplicationExpectedFunction location _actual -> location + ExactApplicationArgumentMismatch location _expected _actual -> location + ExactExpressionExpectedSet location _actual -> location + ExactFormulaExpectedProposition location _actual -> location + ExactCoreCheckFailed location _failure -> location + ExactObjectTypeMismatch location _expected _actual -> location + ExactUnsupportedHeaderAssumption location -> location + ExactQuantifiedTermRequiresPropositionContext location -> location + ExactStructureNotVisible location _phrase -> location + ExactBaseStructureNotAssertable location _phrase -> location + ExactDuplicateStructureAnnotation location _variable -> location + ExactStructureOperationNotAvailable location _symbol -> location + ExactStructureOperationAmbiguous location _symbol _objects -> location + ExactContextualExpansionNotAvailable location _key -> location + ExactContextualRequirementConflict location _symbol _first _second -> location + ExactStructureOccurrenceMismatch location -> location + ExactStructureSelfParent location _phrase -> location + ExactStructureDuplicateParent location _phrase -> location + ExactStructureAlreadyVisible location _phrase -> location + ExactStructureDuplicateOperation location _symbol -> location + ExactStructureOperationAlreadyInherited location _symbol -> location + ExactStructureOperationConflict location _symbol _first _second -> location + ExactStructureHasNoCarrier location _phrase -> location + ExactStructureDescriptorInvalid location _failure -> location + ExactStructureObjectNotVisible location _object -> location + +renderExactCompileError :: ExactCompileError -> Text +renderExactCompileError = \case + ExactUnsupportedDeclaration location -> + at location <> "this declaration is not yet supported by the typed checker" + ExactUnsupportedDeclarationBody location -> + at location <> "this source form is not yet supported by exact elaboration" + ExactNonCanonicalSetDefinitionAnnotation location -> + at location + <> "only the unmodified built-in noun `set` is a harmless definition annotation; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedTransparentDefinition location -> + at location + <> "a transparent definition cannot have a header assumption; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedOpaqueSignature location -> + at location + <> "an opaque signature cannot have a header assumption; " + <> "state the condition in a following explicit axiom" + ExactDefinitionCombinedSymbolicAlias location -> + at location + <> "a functional definition cannot declare a symbolic equivalent at the same time; " + <> "define the symbolic operator first, then define the functional phrase as an abbreviation applying it" + ExactRelationalReplacementRequiresNamedDefinition location -> + at location + <> "relational replacement is supported only as the outer body of a named definition" + ExactDeclarationOccurrenceMissing location -> + at location <> "the declaration has no associated syntax occurrence" + ExactDeclarationOccurrenceAmbiguous location -> + at location <> "the declaration has more than one semantic head" + ExactDeclarationHeadMismatch location -> + at location <> "the parsed declaration head does not match its syntax occurrence" + ExactFixedSemanticCollision location key -> + at location <> "the declaration collides with fixed semantics for " + <> shown key + ExactGlobalAlreadyVisible location key -> + at location <> "the global " <> shown key <> " is already declared" + ExactGlobalNotVisible location key -> + at location <> "the global " <> shown key <> " is not visible" + ExactDuplicateParameter location parameter -> + at location <> "the declaration parameter " <> shown parameter <> " is repeated" + ExactDuplicateLocalBinder location variable -> + at location <> "the proof binder " <> shown variable <> " is already active" + ExactDuplicateLocalIdentity location identity -> + at location <> "the proof-local identity " <> shown identity <> " is already active" + ExactFreeVariable location variable -> + at location <> "the exact source form contains the free variable " <> shown variable + ExactApplicationExpectedFunction location actual -> + at location <> "an application expected a function, but found " <> shown actual + ExactApplicationArgumentMismatch location expected actual -> + at location <> "an application expected " <> shown expected + <> ", but found " <> shown actual + ExactExpressionExpectedSet location actual -> + at location <> "an expression has type " <> shown actual <> " instead of Set" + ExactFormulaExpectedProposition location actual -> + at location <> "a formula has type " <> shown actual <> " instead of Prop" + ExactCoreCheckFailed location failure -> + at location <> "the checked declaration core is invalid: " <> shown failure + ExactObjectTypeMismatch location expected actual -> + at location <> "the declaration object has type " <> shown actual + <> " instead of " <> shown expected + ExactUnsupportedHeaderAssumption location -> + at location <> "this top-level header assumption is not yet supported by exact elaboration" + ExactQuantifiedTermRequiresPropositionContext location -> + at location + <> "a quantified term requires a containing proposition" + ExactStructureNotVisible location structurePhrase -> + at location <> "the structure " <> shown structurePhrase <> " is not visible" + ExactBaseStructureNotAssertable location structurePhrase -> + at location <> "the metadata-only structure " <> shown structurePhrase + <> " cannot be asserted" + ExactDuplicateStructureAnnotation location variable -> + at location <> "the structure binder " <> shown variable + <> " is annotated more than once" + ExactStructureOperationNotAvailable location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is not available in the active structure scope" + ExactStructureOperationAmbiguous location symbol objects -> + at location <> "the structure operation " <> shown symbol + <> " is ambiguous between " <> shown objects + ExactContextualExpansionNotAvailable location key -> + at location <> "the contextual abbreviation " <> shown key + <> " has no compatible active structure" + ExactContextualRequirementConflict location symbol firstObject secondObject -> + at location <> "the contextual abbreviation requires incompatible " + <> shown symbol <> " operations " <> shown firstObject + <> " and " <> shown secondObject + ExactStructureOccurrenceMismatch location -> + at location <> "the structure syntax occurrences do not match the declaration" + ExactStructureSelfParent location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " cannot inherit from itself" + ExactStructureDuplicateParent location structurePhrase -> + at location <> "the parent structure " <> shown structurePhrase + <> " is repeated" + ExactStructureAlreadyVisible location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " is already declared" + ExactStructureDuplicateOperation location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is repeated" + ExactStructureOperationAlreadyInherited location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is already inherited" + ExactStructureOperationConflict location symbol firstOrigin secondOrigin -> + at location <> "the inherited structure operation " <> shown symbol + <> " conflicts between " <> shown firstOrigin + <> " and " <> shown secondOrigin + ExactStructureHasNoCarrier location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " does not inherit the base carrier operation" + ExactStructureDescriptorInvalid location _failure -> + at location <> "the canonical structure descriptor is inconsistent" + ExactStructureObjectNotVisible location identity -> + at location <> "the structure fact mentions unavailable object " + <> shown identity + where + at location = locationToText location <> ": " + shown :: Show value => value -> Text + shown = Text.pack . show + +data ElaborationState = ElaborationState + { elaborationBinders :: !(Map.Map Raw.VarSymbol Natural) + -- Counts every active de Bruijn binder, including anonymous and + -- contextual binders which have no entry in 'elaborationBinders'. + , elaborationBinderDepth :: !Natural + , elaborationStructures :: !(Map.Map Natural ExactStructureAnnotation) + , elaborationGlobals :: !(Map.Map ObjectId CoreType) + , elaborationContextualBinder :: !(Maybe Natural) + , elaborationContextualRequirements + :: !(Map.Map Raw.StructSymbol ObjectId) + } + +type Elaborate = + StateT + ElaborationState + (ExceptT ExactCompileError (Declaration.LoweringDriver)) + +data PreparedHead = PreparedHead + !SemanticGlobalKey + ![Raw.VarSymbol] + !CoreType + +data PreparedBody + = OpaqueBody + | TransparentBody + !(CanonicalTerm ObjectId) + !(Maybe PreparedExactSetConstruction) + | ContextualTransparentBody + !(Map.Map Raw.StructSymbol ObjectId) + !(CanonicalTerm ObjectId) + +data CompiledBody = CompiledBody + !(CanonicalTerm ObjectId) + !(Maybe CompiledNamedSetConstruction) + +data CompiledNamedSetConstruction + = CompiledSeparationConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + | CompiledFunctionalReplacementConstruction + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + | CompiledRelationalReplacementConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + +prepareExactProposition + :: ExactBinderContext + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactProposition context statement = + prepareExactPropositionTerm + context + (locate statement) + (compileStatement statement) + +-- | Compile the source bound of already-opened symbolic binders. This is the +-- shared checked constraint seam used by quantified statements and proof +-- binders, so relation signs, carrier casts, and global occurrences are +-- elaborated exactly once by the ordinary expression compiler. +prepareExactSymbolicBoundConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicBoundConstraints context variables bound = + prepareExactPropositionTerm + context + (case bound of + Raw.Unbounded -> locate (NonEmpty.head variables) + _ -> locate bound) + (logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound) + +-- | Compile the opened body used by a symbolic existential witness. Its +-- grouping is deliberately identical to 'SymbolicExists': all bound +-- constraints form the existential restriction and the stated proposition is +-- its body. +prepareExactSymbolicWitnessConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicWitnessConstraints context variables bound statement = + prepareExactPropositionTerm context (locate statement) do + constraints <- + logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound + body <- compileStatement statement + pure + (if constraints == logicalTruth + then body + else logicalAnd constraints body) + +-- | Compile the checked constraint of an already-opened noun witness. Named +-- binders are resolved normally; a nameless singular noun uses the nearest +-- anonymous binder and therefore introduces no lookup spelling. +prepareExactNounWitnessConstraints + :: ExactBinderContext + -> Raw.NounPhrase [] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactNounWitnessConstraints context nounPhrase = + case nounPhrase of + Raw.NounPhrase left noun variables right suchThat -> + prepareExactPropositionTerm context (locate noun) do + subjects <- + case NonEmpty.nonEmpty variables of + Just binders -> + toList + <$> traverse compileIntroducedVariable binders + Nothing -> + pure [CBound 0] + compileNounPhraseConstraints + subjects left noun right suchThat + +prepareExactPropositionTerm + :: ExactBinderContext + -> Location + -> Elaborate (CanonicalTerm ObjectId) + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactPropositionTerm context location compile = + Except.runExceptT do + let initialElaboration = initialElaborationState context + (term, finalElaboration) <- + State.runStateT compile initialElaboration + checked <- + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition + location + (scopedCoreType checked))) + pure (PreparedExactProposition checked) + +prepareExactSetExpression + :: ExactBinderContext + -> Raw.Expr + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactSetExpression) +prepareExactSetExpression context expression = + Except.runExceptT do + let initialElaboration = initialElaborationState context + (compiled, finalElaboration) <- + State.runStateT + (compileNamedSetExpression expression) + initialElaboration + let CompiledBody term rawConstruction = compiled + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate expression)) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TySet) + (Except.throwError + (ExactExpressionExpectedSet + (locate expression) + (scopedCoreType checked))) + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (preparedSetConstructionTerm checkedConstruction == checked) + (impossible + "exact named construction disagrees with its checked expression")) + construction + pure (PreparedExactSetExpression checked construction) + +checkCompiledNamedSetConstruction + :: (ObjectId -> Maybe CoreType) + -> [CoreType] + -> CompiledNamedSetConstruction + -> Either ExactCompileError PreparedExactSetConstruction +checkCompiledNamedSetConstruction globalType context = \case + CompiledSeparationConstruction bound predicate -> do + checkedBound <- checkAt context TySet bound + checkedPredicate <- checkAt (TySet : context) TyProp predicate + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedSeparationConstruction + globalType checkedBound checkedPredicate) + CompiledFunctionalReplacementConstruction domains value condition -> do + let domainList = NonEmpty.toList domains + fullContext = replicate (length domainList) TySet <> context + checkedDomains <- + traverse + (\(depth, domain) -> + checkAt + (replicate depth TySet <> context) + TySet + domain) + (zip [0..] domainList) + checkedValue <- checkAt fullContext TySet value + checkedCondition <- traverse (checkAt fullContext TyProp) condition + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedFunctionalReplacementConstruction + globalType + (NonEmpty.fromList checkedDomains) + checkedValue + checkedCondition) + CompiledRelationalReplacementConstruction domain relation -> do + checkedDomain <- checkAt context TySet domain + checkedRelation <- checkAt (TySet : TySet : context) TyProp relation + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedRelationalSetConstruction) + (checkedRelationalReplacementConstruction + globalType checkedDomain checkedRelation) + where + checkAt expectedContext expectedType term = do + checked <- + first + (ExactCoreCheckFailed Nowhere) + (checkScopedCanonicalCore globalType expectedContext term) + unless + (scopedCoreType checked == expectedType) + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType + expectedType + (scopedCoreType checked)))) + pure checked + +preparedSetConstructionTerm + :: PreparedExactSetConstruction + -> ScopedCheckedCore ObjectId +preparedSetConstructionTerm = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionTerm construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionTerm construction + +preparedSetConstructionClosedBody + :: PreparedExactSetConstruction + -> FrozenCheckedCore ObjectId +preparedSetConstructionClosedBody = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionClosedBody construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionClosedBody construction + +prepareExactLocalFunctionGraph + :: Location + -> ExactBinderContext + -> ExactBinderContext + -> Raw.Expr + -> Raw.Expr + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactLocalFunctionGraph) +prepareExactLocalFunctionGraph + location context argumentContext domainExpression valueExpression = + Except.runExceptT do + domain <- + preparedExactSetExpressionCore + <$> ( Except.lift + (prepareExactSetExpression context domainExpression) + >>= Except.liftEither + ) + value <- + preparedExactSetExpressionCore + <$> ( Except.lift + (prepareExactSetExpression + argumentContext valueExpression) + >>= Except.liftEither + ) + pair <- prepareOrderedPair + case scopedReplacementGraph pair domain value of + Just (graph, checkedDomain, function) -> + pure + (PreparedExactLocalFunctionGraph + graph checkedDomain function) + Nothing -> + impossible + "checked local-function components did not form a replacement graph" + where + prepareOrderedPair = do + let initialElaboration = initialElaborationState context + key = + SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol) + expected = TySet `TyArrow` (TySet `TyArrow` TySet) + ((term, actual), finalElaboration) <- + State.runStateT + (applyResolvedTyped location key []) + initialElaboration + unless (actual == expected) + (Except.throwError + (ExactObjectTypeMismatch location expected actual)) + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + +prepareExactClaimEnvelope + :: [Raw.Asm] + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactClaimEnvelope) +prepareExactClaimEnvelope assumptions statement = + discover [] emptyExactBinderContext + where + discover variables context = do + attempted <- prepareExactClaimAttempt context assumptions statement + case attempted of + Left (ExactFreeVariable _location variable) + | variable `elem` variables -> + impossible + "exact claim discovery repeated an active free variable" + | otherwise -> + case extendExactBinderContext + ( ( exactLocalId + (fromIntegral (length variables)) + , variable + ) :| [] + ) + context of + Left failure -> + pure (Left failure) + Right extended -> + discover (variables <> [variable]) extended + Left failure -> + pure (Left failure) + Right (target, antecedentCount, structures) -> + pure + (Right + (PreparedExactClaimEnvelope + target + variables + (annotateBinderContext structures context) + antecedentCount)) + +prepareExactClaimAttempt + :: ExactBinderContext + -> [Raw.Asm] + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either + ExactCompileError + ( ScopedCheckedCore ObjectId + , Natural + , Map.Map Natural ExactStructureAnnotation + )) +prepareExactClaimAttempt context assumptions statement = + Except.runExceptT do + let initialElaboration = initialElaborationState context + ((antecedents, conclusion), finalElaboration) <- + State.runStateT + ( do + antecedents <- + concat <$> traverse compileHeaderAssumption assumptions + conclusion <- compileStatement statement + pure (antecedents, conclusion) + ) + initialElaboration + checkedAntecedents <- + traverse + (uncurry + (checkEnvelopeProposition + finalElaboration + context)) + antecedents + checkedConclusion <- + checkEnvelopeProposition + finalElaboration + context + (locate statement) + conclusion + let implication = + foldr + (\antecedent continuation -> + fromMaybe + (impossible + "checked claim antecedents have unequal contexts") + (implyScopedCore antecedent continuation)) + checkedConclusion + checkedAntecedents + closed = closeClaimBinders implication + unless (null (scopedCoreContext closed)) + (impossible "exact claim closure retained a binder") + pure + ( closed + , fromIntegral (length antecedents) + , elaborationStructures finalElaboration + ) + +checkEnvelopeProposition + :: ElaborationState + -> ExactBinderContext + -> Location + -> CanonicalTerm ObjectId + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + (ScopedCheckedCore ObjectId) +checkEnvelopeProposition elaboration context location term = do + checked <- + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals elaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition + location + (scopedCoreType checked))) + pure checked + +closeClaimBinders + :: ScopedCheckedCore global + -> ScopedCheckedCore global +closeClaimBinders scoped = + case scopedCoreContext scoped of + [] -> scoped + _binder : _remaining -> + closeClaimBinders + (fromMaybe + (impossible + "a checked claim binder could not be closed") + (closeScopedForall scoped)) + +binderIndices :: ExactBinderContext -> Map.Map Raw.VarSymbol Natural +binderIndices (ExactBinderContext binders) = + Map.fromList + [ (variable, fromIntegral index) + | (index, ExactBinder _identity (Just variable) _coreType _structure) <- + zip [0 :: Int ..] binders + ] + +binderStructures + :: ExactBinderContext + -> Map.Map Natural ExactStructureAnnotation +binderStructures (ExactBinderContext binders) = + Map.fromList + [ (fromIntegral index, structure) + | (index, ExactBinder _identity _variable _coreType (Just structure)) <- + zip [0 :: Int ..] binders + ] + +binderTypes :: ExactBinderContext -> [CoreType] +binderTypes (ExactBinderContext binders) = + [ coreType + | ExactBinder _identity _variable coreType _structure <- binders + ] + +initialElaborationState :: ExactBinderContext -> ElaborationState +initialElaborationState context = + ElaborationState + { elaborationBinders = binderIndices context + , elaborationBinderDepth = + fromIntegral (length (binderTypes context)) + , elaborationStructures = binderStructures context + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } + +annotateBinderContext + :: Map.Map Natural ExactStructureAnnotation + -> ExactBinderContext + -> ExactBinderContext +annotateBinderContext structures (ExactBinderContext binders) = + ExactBinderContext + [ ExactBinder identity variable coreType + (Map.lookup (fromIntegral index) structures) + | (index, ExactBinder identity variable coreType _old) <- + zip [0 :: Int ..] binders + ] + +compileHeaderAssumption + :: Raw.Asm + -> Elaborate [(Location, CanonicalTerm ObjectId)] +compileHeaderAssumption = \case + Raw.AsmSuppose statement -> do + proposition <- compileStatement statement + pure [(locate statement, proposition)] + Raw.AsmLetNoun variables nounPhrase + | exactSetNounPhrase nounPhrase -> do + traverse_ compileIntroducedVariable variables + pure [] + | otherwise -> do + subjects <- traverse compileIntroducedVariable variables + constraints <- + traverse (`compileNounPhraseMaybe` nounPhrase) subjects + pure + [ (locate variable, constraint) + | (variable, constraint) <- + zip (toList variables) (toList constraints) + ] + Raw.AsmLetIn variables domain -> do + variableTerms <- traverse compileIntroducedVariable variables + domainTerm <- compileExpressionAsSet domain + traverse + (\(variable, variableTerm) -> do + proposition <- + compileMembership + (locate domain) + Raw.Positive + variableTerm + domainTerm + pure (locate variable, proposition)) + (zip (toList variables) (toList variableTerms)) + Raw.AsmLetEq variable expression -> do + variableTerm <- compileIntroducedVariable variable + expressionTerm <- compileExpressionAsSet expression + pure + [ ( locate variable + , CEq TySet variableTerm expressionTerm + ) + ] + Raw.AsmLetThe variable _function -> + Except.throwError + (ExactUnsupportedHeaderAssumption (locate variable)) + Raw.AsmLetStruct variable structure -> do + subject <- compileIntroducedVariable variable + annotation <- + resolveStructureAnnotation + (locate variable) + structure + index <- + maybe + (impossible "an introduced structure variable is unbound") + pure + =<< Map.lookup variable <$> State.gets elaborationBinders + existing <- State.gets (Map.lookup index . elaborationStructures) + when + (isJust existing) + (Except.throwError + (ExactDuplicateStructureAnnotation + (locate variable) variable)) + State.modify' \state -> + state + { elaborationStructures = + Map.insert index annotation + (elaborationStructures state) + } + predicate <- + maybe + (impossible "an assertable structure has no predicate") + pure + (structureAnnotationPredicate annotation) + recordExactGlobal + predicate + (TyArrow TySet TyProp) + pure + [ ( locate variable + , CApp + (CGlobal predicate) + subject + ) + ] + +compileIntroducedVariable + :: Raw.VarSymbol + -> Elaborate (CanonicalTerm ObjectId) +compileIntroducedVariable variable = + compileExpressionAsSet (Raw.ExprVar variable) + +resolveStructureAnnotation + :: Location + -> Raw.StructPhrase + -> Elaborate ExactStructureAnnotation +resolveStructureAnnotation location rawPhrase = do + let structurePhrase = semanticStructurePhrase rawPhrase + resolved <- + State.lift + (Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase)) + structure <- + maybe + (Except.throwError + (ExactStructureNotVisible location structurePhrase)) + pure + resolved + predicate <- + maybe + (Except.throwError + (ExactBaseStructureNotAssertable location structurePhrase)) + pure + (Declaration.resolvedStructurePredicate structure) + pure + (ExactStructureAnnotation + structurePhrase + (Just predicate) + (Declaration.resolvedStructureOperations structure)) + +structureAnnotationPredicate :: ExactStructureAnnotation -> Maybe ObjectId +structureAnnotationPredicate + (ExactStructureAnnotation _ predicate _operations) = + predicate + +structureAnnotationOperation + :: Raw.StructSymbol + -> ExactStructureAnnotation + -> Maybe ObjectId +structureAnnotationOperation symbol + (ExactStructureAnnotation _phrase _predicate operations) = + Map.lookup symbol operations + +recordExactGlobal :: ObjectId -> CoreType -> Elaborate () +recordExactGlobal identity coreType = do + existing <- State.gets (Map.lookup identity . elaborationGlobals) + case existing of + Nothing -> + State.modify' \state -> + state + { elaborationGlobals = + Map.insert identity coreType + (elaborationGlobals state) + } + Just actual + | actual == coreType -> pure () + | otherwise -> + impossible "one exact global acquired two checked types" + +prepareExactSourceAxiom + :: Raw.Block + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactSourceAxiom) +prepareExactSourceAxiom = \case + Raw.BlockAxiom + location _title (Raw.Marker marker) + (Raw.Axiom assumptions statement) -> do + prepared <- prepareExactClaimEnvelope assumptions statement + pure do + envelope <- prepared + let core = preparedExactClaimTarget envelope + alias = semanticName marker + unless (null (scopedCoreContext core)) + (Left (ExactUnsupportedDeclarationBody location)) + pure + (PreparedExactSourceAxiom + location + alias + core + (declarationSyntaxId + (encodePreparedSourceAxiom core alias))) + block -> + pure (Left (ExactUnsupportedDeclaration (locate block))) + +lowerPreparedExactSourceAxiom + :: PreparedExactSourceAxiom + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration ())) +lowerPreparedExactSourceAxiom + (PreparedExactSourceAxiom _location alias target syntax) = + fmap + (\spec -> + Declaration.checkedCompiledDeclaration + syntax [] [] [] [] + [ Declaration.checkedCandidate + spec + Declaration.checkedSourceAxiomPlanning + :| [] + ] + ()) + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + +authorizeCheckedExactSourceAxiom + :: () + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactSourceAxiom () = \case + [candidate :| []] -> + Declaration.authorizeSourceAxiomCandidate candidate + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +prepareExactDeclaration + :: Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactDeclaration) +prepareExactDeclaration block entries = + Except.runExceptT do + entry <- + case entries of + [] -> Except.throwError + (ExactDeclarationOccurrenceMissing (locate block)) + [single] -> pure single + _ -> Except.throwError + (ExactDeclarationOccurrenceAmbiguous (locate block)) + key <- + maybe + (Except.throwError + (ExactUnsupportedDeclaration (locate block))) + pure + (semanticGlobalKeyFromLexicalEntry entry) + when + (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactFixedSemanticCollision (locate block) key)) + visible <- Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when + (isJust visible) + (Except.throwError + (ExactGlobalAlreadyVisible (locate block) key)) + (head', family, rawBody) <- + prepareHead block key + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + (body, globals) <- + case rawBody of + Nothing -> pure (OpaqueBody, Map.empty) + Just buildBody -> do + let initialElaboration = + ElaborationState + { elaborationBinders = mempty + , elaborationBinderDepth = 0 + , elaborationStructures = mempty + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } + (CompiledBody canonical rawConstruction, finalElaboration) <- + State.runStateT buildBody initialElaboration + let PreparedHead _semanticKey parameters _coreType = head' + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` + elaborationGlobals finalElaboration) + (replicate (length parameters) TySet)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (frozenCoreTerm + (preparedSetConstructionClosedBody + checkedConstruction) + == canonical) + (impossible + "exact named construction disagrees with its transparent body")) + construction + let requirements = + elaborationContextualRequirements finalElaboration + body + | Map.null requirements = + TransparentBody canonical construction + | family == ExactAbbreviation = + ContextualTransparentBody + requirements + (CLam TySet canonical) + | otherwise = + impossible + "a non-abbreviation acquired contextual requirements" + pure (body, elaborationGlobals finalElaboration) + let PreparedHead semanticKey _parameters coreType = head' + unless (semanticKey == key) + (Except.throwError + (ExactDeclarationHeadMismatch (locate block))) + (target, content) <- + case body of + OpaqueBody -> do + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + SignatureDeclaration + (generatedObjectSlot 0) + content' = + OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + pure (GlobalReference identity, content') + TransparentBody canonical _construction -> do + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate block)) + pure + (checkCanonicalCore + (`Map.lookup` globals) + canonical) + unless + (frozenCoreType checked == coreType) + (Except.throwError + (ExactObjectTypeMismatch + (locate block) + coreType + (frozenCoreType checked))) + let content' = + TransparentObjectContent + theory + coreType + canonical + let identity = + transparentObjectId theory coreType canonical + semanticTarget = + case family of + ExactAbbreviation -> + TransparentExpansion identity + ExactDefinition -> GlobalReference identity + ExactSignature -> + impossible + "a signature acquired a transparent body" + pure (semanticTarget, content') + ContextualTransparentBody requirements canonical -> do + let contextualType = TyArrow TySet coreType + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate block)) + pure + (checkCanonicalCore + (`Map.lookup` globals) + canonical) + unless + (frozenCoreType checked == contextualType) + (Except.throwError + (ExactObjectTypeMismatch + (locate block) + contextualType + (frozenCoreType checked))) + let content' = + TransparentObjectContent + theory + contextualType + canonical + identity = + transparentObjectId + theory contextualType canonical + pure + ( ContextualTransparentExpansion + identity requirements + , content' + ) + let targetObject = semanticGlobalTargetObject target + available <- + Except.lift (Declaration.objectAvailableLowering targetObject) + let alias = definitionAlias block + asserted + | available = Nothing + | otherwise = Just (assertedObject targetObject content) + syntax = + declarationSyntaxId + (encodePreparedSyntax family head' body alias) + pure + (PreparedExactDeclaration + (locate block) + family + key + target + asserted + alias + (case family of + ExactDefinition -> case body of + TransparentBody _canonical construction -> construction + _ -> Nothing + _ -> Nothing) + syntax) + +lowerPreparedExactBinding + :: PreparedExactDeclaration + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration CheckedExactBindingAuthorization)) +lowerPreparedExactBinding prepared = + case preparedDefinitionAlias prepared of + Nothing -> + pure + (Right + (checked [] CheckedExactBindingNone)) + Just alias -> case preparedDefinitionConstruction prepared of + Nothing -> + fmap + (\spec -> + checked + [ Declaration.checkedCandidate + spec + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [] + ] + (CheckedExactBindingDefinition identity)) + <$> Declaration.prepareDefinitionEquationSpecLowering + objects identity alias + Just (PreparedUnconditionalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + (extensional, descriptor) <- + Except.lift + (Declaration.prepareNamedSetConstructionSpecLowering + objects identity construction) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + extensional + (Declaration.checkedKernelPlanning + descriptor []) + ] + ] + (CheckedExactBindingConstruction + identity construction)) + Just (PreparedRelationalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + let functionality = + relationalSetConstructionClosedFunctionality + construction + functionalityScoped = + embedClosedCore [] functionality + functionalitySpec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects functionality SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + functionalityScoped + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt location + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + (extensional, descriptor) <- + Except.lift + (Declaration.prepareRelationalSetConstructionSpecLowering + objects identity construction functionality) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + functionalitySpec + (Declaration.checkedSourceProofPlanning + [Declaration.checkedPlannedVampireRequest + location obligation] + []) + ] + , Declaration.checkedCandidate + extensional + (Declaration.checkedStagedKernelPlanning + descriptor + [Declaration.plannedEarlierCandidate 0 1]) + :| [] + ] + (CheckedExactBindingRelationalConstruction + identity construction obligation)) + where + identity = preparedExactObjectId prepared + objects = maybeToList (preparedExactObject prepared) + location = preparedExactLocation prepared + checked stages body = + Declaration.checkedCompiledDeclaration + (preparedExactSyntaxId prepared) + objects + [] + [semanticGlobalBinding + (preparedExactGlobalKey prepared) + (preparedExactGlobalTarget prepared)] + [] + stages + body + +data CheckedExactBindingAuthorization + = CheckedExactBindingNone + | CheckedExactBindingDefinition !ObjectId + | CheckedExactBindingConstruction + !ObjectId + !(NamedSetConstruction ObjectId) + | CheckedExactBindingRelationalConstruction + !ObjectId + !(CheckedRelationalSetConstruction ObjectId) + !(Declaration.PreparedVampireObligation Void ()) + +authorizeCheckedExactBinding + :: CheckedExactBindingAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactBinding body stages = + case (body, stages) of + (CheckedExactBindingNone, []) -> pure () + (CheckedExactBindingDefinition identity, [candidate :| []]) -> + Declaration.authorizeDefinitionEquationCandidate + identity candidate + ( CheckedExactBindingConstruction identity construction + , [equation :| [extensional]] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeNamedSetConstructionCandidate + identity construction extensional + ( CheckedExactBindingRelationalConstruction + identity construction obligation + , [equation :| [functionality], extensional :| []] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeVampireCandidate + functionality + (Declaration.acceptPreparedVampireObligation obligation) + Declaration.authorizeRelationalSetConstructionCandidate + identity construction functionality extensional + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (case body of + CheckedExactBindingNone -> 0 + CheckedExactBindingDefinition{} -> 1 + CheckedExactBindingConstruction{} -> 1 + CheckedExactBindingRelationalConstruction{} -> 2) + (length stages)) + +prepareExactStructure + :: Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactStructure) +prepareExactStructure block entries = + Except.runExceptT do + (location, marker, structure) <- + case block of + Raw.BlockStruct location _title (Raw.Marker marker) structure -> + pure (location, marker, structure) + _ -> Except.throwError + (ExactUnsupportedDeclaration (locate block)) + validateStructureOccurrences location structure entries + let structurePhrase = + semanticStructurePhrase (Raw.structPhrase structure) + parentPhrases = + semanticStructurePhrase <$> Raw.structParents structure + when + (structurePhrase `elem` parentPhrases) + (Except.throwError + (ExactStructureSelfParent location structurePhrase)) + case firstDuplicate parentPhrases of + Just duplicate -> + Except.throwError + (ExactStructureDuplicateParent location duplicate) + Nothing -> pure () + visible <- Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase) + when + (isJust visible) + (Except.throwError + (ExactStructureAlreadyVisible location structurePhrase)) + parents <- traverse (resolveParent location) parentPhrases + inherited <- + foldM mergeParentOperations Map.empty + (zip parentPhrases parents) + case firstDuplicate (Raw.structFixes structure) of + Just duplicate -> + Except.throwError + (ExactStructureDuplicateOperation location duplicate) + Nothing -> pure () + traverse_ + (\symbol -> + when + (Map.member symbol inherited) + (Except.throwError + (ExactStructureOperationAlreadyInherited + location symbol))) + (Raw.structFixes structure) + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + let operationType = TyArrow TySet TySet + makeOperation index symbol = + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot index) + content = OpaqueObjectContent theory seed operationType + identity = opaqueObjectId theory seed operationType + in ( symbol + , identity + , assertedObject identity content + ) + ownOperations = + zipWith makeOperation [0 ..] (Raw.structFixes structure) + operationObjects = + [ asserted + | (_symbol, _identity, asserted) <- ownOperations + ] + completeOperations = + Map.union + (Map.fromList + [ (symbol, identity) + | (symbol, identity, _asserted) <- ownOperations + ]) + (fst <$> inherited) + unless + (Map.member Raw.CarrierSymbol completeOperations) + (Except.throwError + (ExactStructureHasNoCarrier location structurePhrase)) + context <- + either Except.throwError pure + (extendExactBinderContext + ((exactLocalId 0, Raw.structLabel structure) :| []) + emptyExactBinderContext) + let provisionalAnnotation = + ExactStructureAnnotation + structurePhrase Nothing completeOperations + structureContext = + annotateBinderContext + (Map.singleton 0 provisionalAnnotation) + context + checkedAssumptions <- + traverse + (\(assumptionMarker, assumption) -> do + prepared <- Except.lift + (prepareExactProposition structureContext assumption) + proposition <- Except.liftEither prepared + pure + ( locate assumption + , assumptionMarker + , preparedExactPropositionCore proposition + )) + (Raw.structAssumes structure) + parentTerms <- + fmap catMaybes + (traverse + (\parent -> + case Declaration.resolvedStructurePredicate parent of + Nothing -> pure Nothing + Just predicate -> + pure + (Just + (CApp + (CGlobal predicate) + (CBound 0)))) + parents) + let assumptionTerms = + [ scopedCoreTerm proposition + | (_assumptionLocation, _assumptionMarker, proposition) <- + checkedAssumptions + ] + predicateBody = + CLam TySet + (logicalConjunction + (parentTerms <> assumptionTerms)) + predicateType = TyArrow TySet TyProp + predicateContent = + TransparentObjectContent theory predicateType predicateBody + predicate = + transparentObjectId theory predicateType predicateBody + predicateAvailable <- + Except.lift (Declaration.objectAvailableLowering predicate) + let predicateObject = + [ assertedObject predicate predicateContent + | not predicateAvailable + ] + ownBindings = + [ semanticStructureOperation symbol identity + | (symbol, identity, _asserted) <- ownOperations + ] + descriptor <- + Except.liftEither + (first + (ExactStructureDescriptorInvalid location) + (semanticStructureDescriptor + structurePhrase + (Just predicate) + parentPhrases + ownBindings)) + let structureApplication = + CApp (CGlobal predicate) (CBound 0) + inheritance = + [ ( location + , semanticName (marker <> "inherit") + , CForall TySet + (CImp structureApplication + (logicalConjunction parentTerms)) + ) + | not (null parentTerms) + ] + projections = + [ ( assumptionLocation + , semanticName assumptionMarker + , CForall TySet + (CImp structureApplication + (scopedCoreTerm proposition)) + ) + | ( assumptionLocation + , Raw.Marker assumptionMarker + , proposition + ) <- checkedAssumptions + ] + generatedTerms = inheritance <> projections + localTypes = + Map.fromList + ((predicate, predicateType) + : [ (identity, operationType) + | (_symbol, identity, _asserted) <- ownOperations + ]) + resolvedTypes <- + resolveStructureGlobalTypes + localTypes + [ term + | (_factLocation, _alias, term) <- generatedTerms + ] + generated <- + traverse + (\(factLocation, alias, term) -> do + frozen <- + either + (Except.throwError + . ExactCoreCheckFailed factLocation) + pure + (checkCanonicalCore + (`Map.lookup` resolvedTypes) + term) + pure + (PreparedExactStructureFact + factLocation frozen alias)) + generatedTerms + environment <- + Except.liftEither + (first + (ExactStructureDescriptorInvalid location) + (semanticEnvironmentWithStructures [] [descriptor])) + let syntax = + declarationSyntaxId + (encodePreparedStructure + environment + predicate + generated) + pure + (PreparedExactStructure + location + (operationObjects <> predicateObject) + predicate + descriptor + (semanticName marker) + generated + syntax) + where + resolveParent location structurePhrase = do + resolved <- Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase) + maybe + (Except.throwError + (ExactStructureNotVisible location structurePhrase)) + pure + resolved + + mergeParentOperations inherited (parentPhrase, parent) = + foldM + (insertParentOperation parentPhrase) + inherited + (Map.toAscList + (Declaration.resolvedStructureOperations parent)) + + insertParentOperation parentPhrase inherited (symbol, identity) = + case Map.lookup symbol inherited of + Nothing -> + pure + (Map.insert symbol (identity, parentPhrase) inherited) + Just (existing, existingOrigin) + | existing == identity -> pure inherited + | otherwise -> + Except.throwError + (ExactStructureOperationConflict + (locate block) + symbol + existingOrigin + parentPhrase) + + resolveStructureGlobalTypes localTypes terms = do + let dependencies = Set.unions (canonicalTermGlobals <$> terms) + foldM + (\types identity -> + case Map.lookup identity types of + Just{} -> pure types + Nothing -> do + coreType <- Except.lift + (Declaration.objectTypeLowering identity) + case coreType of + Nothing -> + Except.throwError + (ExactStructureObjectNotVisible + (locate block) identity) + Just actual -> + pure (Map.insert identity actual types)) + localTypes + (Set.toAscList dependencies) + +lowerPreparedExactStructure + :: PreparedExactStructure + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactStructureAuthorization)) +lowerPreparedExactStructure + (PreparedExactStructure + _location objects predicate descriptor alias generatedFacts syntax) = + Except.runExceptT do + definition <- + Except.lift + (Declaration.preparePointwiseDefinitionEquationSpecLowering + objects predicate alias) + >>= Except.liftEither + generatedCandidates <- + traverse + (\(PreparedExactStructureFact + factLocation target factAlias) -> do + generatedSpec <- Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects target SearchEligible [factAlias]) + >>= Except.liftEither + obligation <- Except.lift + (Declaration.prepareStagedCandidateVampireLowering + factLocation objects definition generatedSpec) + >>= Except.liftEither + pure + ( Declaration.checkedCandidate generatedSpec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + [ Declaration.plannedEarlierCandidate 0 0 + ]) + , (factLocation, obligation) + )) + generatedFacts + let generatedAuthorizations = + snd <$> generatedCandidates + stages = + [ Declaration.checkedCandidate definition + (Declaration.checkedDefinitionEquationPlanning predicate) + :| [] + ] + <> maybeToList + (NonEmpty.nonEmpty + (fst <$> generatedCandidates)) + body = + CheckedExactStructureAuthorization + predicate + generatedAuthorizations + pure + (Declaration.checkedCompiledDeclaration + syntax objects [] [] [descriptor] stages + body) + +authorizeCheckedExactStructure + :: CheckedExactStructureAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactStructure + (CheckedExactStructureAuthorization predicate obligations) + stages = + case (obligations, stages) of + ([], [definition :| []]) -> + Declaration.authorizeDefinitionEquationCandidate + predicate definition + (_, [definition :| [], generatedCandidates]) + | length obligations == NonEmpty.length generatedCandidates -> do + Declaration.authorizeDefinitionEquationCandidate + predicate definition + Declaration.authorizeVampireCandidateBatch + (NonEmpty.zipWith + (\candidate (factLocation, obligation) -> + ( factLocation + , candidate + , do + void + (Declaration.useStagedCandidate + definition) + pure obligation + )) + generatedCandidates + (NonEmpty.fromList obligations)) + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (if null obligations then 1 else 2) + (length stages)) + +validateStructureOccurrences + :: Location + -> Raw.StructDefn + -> [CanonicalLexicalEntry] + -> ExceptT ExactCompileError (Declaration.LoweringDriver) () +validateStructureOccurrences location structure entries = do + let Raw.LexicalItemSgPl forms structureMarker = + Raw.structPhrase structure + expected = + CanonicalStructureNoun + (Raw.sg forms) + (Raw.pl forms) + structureMarker + : [ CanonicalStructureOperation command + | Raw.StructSymbol command <- Raw.structFixes structure + ] + unless + (entries == expected) + (Except.throwError + (ExactStructureOccurrenceMismatch location)) + +encodePreparedStructure + :: SemanticEnvironmentDelta + -> ObjectId + -> [PreparedExactStructureFact] + -> ByteString +encodePreparedStructure environment predicate generated = + encodeCache do + putCacheTag 0x04 + putSemanticEnvironmentDeltaCache environment + putObjectIdCache predicate + putCacheList + (\(PreparedExactStructureFact _location target alias) -> do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm target) + putCacheText (semanticNameText alias)) + generated + +prepareHead + :: Raw.Block + -> SemanticGlobalKey + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , ExactDeclarationFamily + , Maybe (Elaborate CompiledBody) + ) +prepareHead block key = + case block of + Raw.BlockSig location _title _marker assumptions signature -> do + rejectHeaderAssumptions ExactGuardedOpaqueSignature assumptions + head' <- prepareSignature location key signature + pure (head', ExactSignature, Nothing) + Raw.BlockAbbr location _title _marker abbreviation -> do + (head', buildBody) <- + prepareAbbreviation location key abbreviation + pure (head', ExactAbbreviation, Just buildBody) + Raw.BlockDefn location _title _marker definition -> do + (head', buildBody) <- + prepareDefinition location key definition + pure (head', ExactDefinition, Just buildBody) + _ -> + Except.throwError (ExactUnsupportedDeclaration (locate block)) + +prepareSignature + :: Location + -> SemanticGlobalKey + -> Raw.Signature + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + PreparedHead +prepareSignature location key = \case + Raw.SignatureAdj subject (Raw.Adj _ item arguments) -> do + ensureAdjectiveKey location item key + makePreparedHead + location key (subject : arguments) TyProp + Raw.SignatureSymbolic (Raw.SymbolPattern symbol parameters) nounPhrase -> do + unless + ( key + == SemanticExpressionFunction + (Raw.mixfixPattern symbol) + ) + (Except.throwError (ExactDeclarationHeadMismatch location)) + unless + (exactSetNounPhrase nounPhrase) + (Except.throwError (ExactUnsupportedDeclarationBody location)) + makePreparedHead location key parameters TySet + _ -> + Except.throwError (ExactUnsupportedDeclaration location) + +prepareAbbreviation + :: Location + -> SemanticGlobalKey + -> Raw.Abbreviation + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +prepareAbbreviation location key = \case + Raw.AbbreviationEq (Raw.SymbolPattern symbol parameters) expression -> do + ensureExpressionKey location symbol key + makeContextualTransparentHead + location key parameters TySet + (ordinaryCompiledBody <$> compileExpressionAsSet expression) + Raw.AbbreviationFun (Raw.Fun _ item parameters) term -> do + ensureFunctionPhraseKey location item key + makeContextualTransparentHead + location key parameters TySet + (ordinaryCompiledBody <$> compileTermAsSet term) + Raw.AbbreviationAdj subject (Raw.Adj _ item arguments) statement -> do + ensureAdjectiveKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationVerb subject (Raw.Verb _ item arguments) statement -> do + ensureVerbKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationNoun subject (Raw.Noun _ item arguments) statement -> do + ensureNounKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationRel left relation parameters right statement -> do + ensureRelationKey location relation key + makeContextualTransparentHead + location key (parameters <> [left, right]) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + +prepareDefinition + :: Location + -> SemanticGlobalKey + -> Raw.Defn + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +prepareDefinition location key = \case + Raw.Defn assumptions head' statement -> do + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions + (parameters, resultType) <- + definitionHead location key head' + makeTransparentHead + location key parameters resultType + (ordinaryCompiledBody <$> compileStatement statement) + Raw.DefnFun assumptions (Raw.Fun _ item parameters) symbolic term -> do + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions + traverse_ + (Except.throwError + . ExactDefinitionCombinedSymbolicAlias + . locate) + symbolic + ensureFunctionPhraseKey location item key + makeTransparentHead + location key parameters TySet + (compileNamedSetTerm term) + Raw.DefnOp (Raw.SymbolPattern symbol parameters) expression -> do + ensureExpressionKey location symbol key + makeTransparentHead + location key parameters TySet + (compileNamedSetExpression expression) + +definitionHead + :: Location + -> SemanticGlobalKey + -> Raw.DefnHead + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ([Raw.VarSymbol], CoreType) +definitionHead location key = \case + Raw.DefnAdj annotation subject (Raw.Adj _ item arguments) -> do + validateDefinitionAnnotation annotation + ensureAdjectiveKey location item key + pure (subject : arguments, TyProp) + Raw.DefnVerb annotation subject (Raw.Verb _ item arguments) -> do + validateDefinitionAnnotation annotation + ensureVerbKey location item key + pure (subject : arguments, TyProp) + Raw.DefnNoun subject (Raw.Noun _ item arguments) -> do + ensureNounKey location item key + pure (subject : arguments, TyProp) + Raw.DefnRel left relation parameters right -> do + ensureRelationKey location relation key + pure (parameters <> [left, right], TyProp) + Raw.DefnSymbolicPredicate + (Raw.PrefixPredicate command arity) + _marker + parameters -> do + unless + ( key + == SemanticPrefixPredicate + command + (fromIntegral arity) + ) + (Except.throwError (ExactDeclarationHeadMismatch location)) + pure (toList parameters, TyProp) + +validateDefinitionAnnotation + :: MonadError ExactCompileError monad + => Maybe (Raw.NounPhrase Maybe) + -> monad () +validateDefinitionAnnotation = traverse_ \nounPhrase -> + unless (exactSetNounPhrase nounPhrase) + (throwError + (ExactNonCanonicalSetDefinitionAnnotation + (exactNounPhraseLocation nounPhrase))) + +rejectHeaderAssumptions + :: MonadError ExactCompileError monad + => (Location -> ExactCompileError) + -> [Raw.Asm] + -> monad () +rejectHeaderAssumptions makeError = \case + [] -> pure () + assumption : _ -> + throwError (makeError (exactAssumptionLocation assumption)) + +exactAssumptionLocation :: Raw.Asm -> Location +exactAssumptionLocation = \case + Raw.AsmSuppose statement -> locate statement + Raw.AsmLetNoun variables _nounPhrase -> locate variables + Raw.AsmLetIn variables _expression -> locate variables + Raw.AsmLetThe variable _function -> locate variable + Raw.AsmLetEq variable _expression -> locate variable + Raw.AsmLetStruct variable _structure -> locate variable + +exactNounPhraseLocation :: Raw.NounPhraseOf t argument -> Location +exactNounPhraseLocation + (Raw.NounPhrase _left noun _variables _right _suchThat) = + locate noun + +makeTransparentHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> Elaborate CompiledBody + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +makeTransparentHead location key parameters resultType body = do + (prepared, binders) <- + prepareParameters location key parameters resultType + let close = do + State.modify' \state -> + state + { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + } + CompiledBody body' construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + construction) + pure (prepared, close) + +makeContextualTransparentHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> Elaborate CompiledBody + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +makeContextualTransparentHead location key parameters resultType body = do + (prepared, binders) <- + prepareParameters location key parameters resultType + let close = do + State.modify' \state -> + state + { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + 1 + , elaborationContextualBinder = + Just (fromIntegral (length parameters)) + } + CompiledBody body' _construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + Nothing) + pure (prepared, close) + +makePreparedHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + PreparedHead +makePreparedHead location key parameters resultType = do + (prepared, _binders) <- + prepareParameters location key parameters resultType + pure prepared + +prepareParameters + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Map.Map Raw.VarSymbol Natural + ) +prepareParameters + location key parameters resultType = do + case firstDuplicate parameters of + Just duplicate -> + Except.throwError + (ExactDuplicateParameter location duplicate) + Nothing -> pure () + let indices = + reverse (take (length parameters) [0 ..]) + binders = + Map.fromList + (zip parameters indices) + coreType = foldr (const (TyArrow TySet)) resultType parameters + pure + ( PreparedHead key parameters coreType + , binders + ) + +compileExpressionAsSet + :: Raw.Expr + -> Elaborate (CanonicalTerm ObjectId) +compileExpressionAsSet expression = do + (term, actual) <- compileExpression expression + unless (actual == TySet) + (Except.throwError + (ExactExpressionExpectedSet (locate expression) actual)) + pure term + +-- | Compile one set expression once while retaining the checked-source shape +-- needed only when that expression is subsequently named by a definition. +-- Nested constructions remain ordinary exact terms. +compileNamedSetExpression + :: Raw.Expr + -> Elaborate CompiledBody +compileNamedSetExpression = \case + Raw.ExprSep _location variable bound predicate -> do + (term, bound', predicate') <- + compileSeparation variable bound predicate + pure + (CompiledBody term + (Just + (CompiledSeparationConstruction + bound' predicate'))) + Raw.ExprReplace _location value bounds condition -> do + replacement <- + compileFunctionalReplacement value bounds condition + pure + (CompiledBody + (compiledFunctionalReplacementTerm replacement) + (Just + (CompiledFunctionalReplacementConstruction + (compiledFunctionalReplacementDomains replacement) + (compiledFunctionalReplacementValue replacement) + (compiledFunctionalReplacementCondition replacement)))) + Raw.ExprReplacePred _location range domainVariable bound predicate -> do + (term, domain, relation) <- + compileRelationalReplacement + range domainVariable bound predicate + pure + (CompiledBody term + (Just + (CompiledRelationalReplacementConstruction + domain relation))) + expression -> + (`CompiledBody` Nothing) + <$> compileExpressionAsSet expression + +compileNamedSetTerm :: Raw.Term -> Elaborate CompiledBody +compileNamedSetTerm = \case + Raw.TermExpr expression -> compileNamedSetExpression expression + term -> ordinaryCompiledBody <$> compileTermAsSet term + +ordinaryCompiledBody :: CanonicalTerm ObjectId -> CompiledBody +ordinaryCompiledBody term = CompiledBody term Nothing + +compileTermAsSet + :: Raw.Term + -> Elaborate (CanonicalTerm ObjectId) +compileTermAsSet = \case + Raw.TermExpr expression -> + compileExpressionAsSet expression + Raw.TermFun (Raw.Fun location item arguments) -> do + let patterns = Raw.lexicalItemSgPlPattern item + key = SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns) + compiled <- traverse compileTermAsSet arguments + applyResolved location key compiled + Raw.TermQuantified _quantifier location _nounPhrase -> + Except.throwError + (ExactQuantifiedTermRequiresPropositionContext location) + term -> + Except.throwError + (ExactUnsupportedDeclarationBody (locate term)) + +-- | Compile a source term only at a proposition consumer. Indefinite terms +-- own the continuation, so their noun constraints and quantifier surround +-- exactly the proposition which consumes the resulting set. Function-phrase +-- arguments recurse through the same seam and therefore never masquerade as +-- independently set-valued terms. +compileTermInProposition + :: Raw.Term + -> (CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermInProposition term continuation = + case term of + Raw.TermExpr expression -> + compileExpressionAsSet expression >>= continuation + Raw.TermFun (Raw.Fun location item arguments) -> do + let patterns = Raw.lexicalItemSgPlPattern item + key = + SemanticFunctionPhrase + (Raw.sg patterns) + (Raw.pl patterns) + compileTermsInProposition arguments \compiled -> do + value <- applyResolved location key compiled + continuation value + Raw.TermQuantified quantifier _location nounPhrase -> + compileQuantifiedTermInProposition + quantifier nounPhrase continuation + Raw.TermIota location _variable _statement -> + Except.throwError (ExactUnsupportedDeclarationBody location) + +-- | Compile source-ordered proposition terms. The first source occurrence +-- receives the outermost continuation and therefore the widest scope. +compileTermsInProposition + :: [Raw.Term] + -> ([CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermsInProposition terms continuation = + case terms of + [] -> continuation [] + term : remaining -> + compileTermInProposition term \compiled -> do + compiledDepth <- State.gets elaborationBinderDepth + compileTermsInProposition remaining \rest -> do + compiled' <- + weakenElaboratedTermFrom compiledDepth compiled + continuation (compiled' : rest) + +weakenElaboratedTermFrom + :: Natural + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +weakenElaboratedTermFrom originalDepth term = do + currentDepth <- State.gets elaborationBinderDepth + when (currentDepth < originalDepth) + (impossible + "a proposition-term continuation escaped its binder scope") + pure + (shiftCanonical + (currentDepth - originalDepth) + 0 + term) + +compileExpression + :: Raw.Expr + -> Elaborate (CanonicalTerm ObjectId, CoreType) +compileExpression = \case + Raw.ExprVar variable -> do + binders <- State.gets elaborationBinders + case Map.lookup variable binders of + Just index -> + pure (CBound index, TySet) + Nothing -> + Except.throwError + (ExactFreeVariable (locate variable) variable) + Raw.ExprInteger _location integer -> + pure (COpaqueInteger (toInteger integer), TySet) + Raw.ExprOp location symbol arguments -> do + let key = + SemanticExpressionFunction + (Raw.mixfixPattern symbol) + compiled <- traverse compileExpression arguments + case fixedSemanticMeaning key of + Just (FixedIntrinsic intrinsic) -> + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + Just (FixedNegatedIntrinsic _intrinsic) -> + impossible + "expression key resolved to a negated intrinsic" + Just FixedEquality -> + impossible + "expression key resolved to fixed equality" + Just FixedDisequality -> + impossible + "expression key resolved to fixed disequality" + Nothing -> + applyResolvedTyped + location + key + compiled + Raw.ExprStructOp location symbol maybeArgument -> + compileStructureOperation location symbol maybeArgument + Raw.ExprFiniteSet _location elements -> do + compiled <- traverse compileExpressionAsSet elements + pure + ( foldr + canonicalSetInsert + (CIntrinsic Empty) + compiled + , TySet + ) + Raw.ExprSep _location variable bound predicate -> do + (term, _bound, _predicate) <- + compileSeparation variable bound predicate + pure (term, TySet) + Raw.ExprReplace _location value bounds condition -> do + replacement <- + compileFunctionalReplacement value bounds condition + pure (compiledFunctionalReplacementTerm replacement, TySet) + Raw.ExprReplacePred location _value _variable _bound _predicate -> + Except.throwError + (ExactRelationalReplacementRequiresNamedDefinition location) + +compileStructureOperation + :: Location + -> Raw.StructSymbol + -> Maybe Raw.Expr + -> Elaborate (CanonicalTerm ObjectId, CoreType) +compileStructureOperation location symbol maybeArgument = do + (argument, object) <- + case maybeArgument of + Just expression -> do + term <- compileExpressionAsSet expression + structures <- State.gets elaborationStructures + case termStructureAnnotation term structures of + Just annotation -> do + object <- + maybe + (Except.throwError + (ExactStructureOperationNotAvailable + location symbol)) + pure + (structureAnnotationOperation + symbol annotation) + pure (term, object) + Nothing -> do + object <- + resolveUniqueStructureOperation location symbol + pure (term, object) + Nothing -> do + structures <- State.gets elaborationStructures + case + [ (CBound index, object) + | (index, structure) <- Map.toAscList structures + , Just object <- + [structureAnnotationOperation symbol structure] + ] of + firstMatch : _ -> pure firstMatch + [] -> do + contextual <- State.gets elaborationContextualBinder + case contextual of + Nothing -> + Except.throwError + (ExactStructureOperationNotAvailable + location symbol) + Just index -> do + object <- + resolveUniqueStructureOperation + location symbol + recordContextualRequirement + location symbol object + pure (CBound index, object) + recordExactGlobal object (TyArrow TySet TySet) + pure (CApp (CGlobal object) argument, TySet) + where + termStructureAnnotation term structures = + case term of + CBound index -> Map.lookup index structures + _ -> Nothing + +resolveUniqueStructureOperation + :: Location + -> Raw.StructSymbol + -> Elaborate ObjectId +resolveUniqueStructureOperation location symbol = do + objects <- + State.lift + (Except.lift + (Declaration.resolveVisibleStructureOperationObjectsLowering + symbol)) + case objects of + [] -> + Except.throwError + (ExactStructureOperationNotAvailable location symbol) + [object] -> pure object + _ -> + Except.throwError + (ExactStructureOperationAmbiguous location symbol objects) + +recordContextualRequirement + :: Location + -> Raw.StructSymbol + -> ObjectId + -> Elaborate () +recordContextualRequirement location symbol object = do + existing <- + State.gets + (Map.lookup symbol . elaborationContextualRequirements) + case existing of + Nothing -> + State.modify' \state -> + state + { elaborationContextualRequirements = + Map.insert symbol object + (elaborationContextualRequirements state) + } + Just actual + | actual == object -> pure () + | otherwise -> + Except.throwError + (ExactContextualRequirementConflict + location symbol actual object) + +structureCarrierCast + :: Location + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +structureCarrierCast location term = + case term of + CBound index -> do + annotation <- State.gets (Map.lookup index . elaborationStructures) + case annotation of + Nothing -> pure term + Just structure -> do + carrier <- + maybe + (Except.throwError + (ExactStructureOperationNotAvailable + location Raw.CarrierSymbol)) + pure + (structureAnnotationOperation + Raw.CarrierSymbol structure) + recordExactGlobal carrier (TyArrow TySet TySet) + pure (CApp (CGlobal carrier) term) + _ -> pure term + +compileMembership + :: Location + -> Raw.Sign + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileMembership location sign element set = do + checkedSet <- structureCarrierCast location set + let proposition = + CApp + (CApp (CIntrinsic Member) element) + checkedSet + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition + +compileSeparation + :: Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileSeparation variable bound predicate = do + bound' <- compileExpressionAsSet bound + predicate' <- + withSetBinders (variable :| []) + (compileStatement predicate) + pure + ( CApp + (CApp (CIntrinsic Sep) bound') + (CLam TySet predicate') + , bound' + , predicate' + ) + +compileRelationalReplacement + :: Raw.VarSymbol + -> Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileRelationalReplacement range domainVariable bound predicate = do + domain <- compileExpressionAsSet bound + relation <- + withSetBinders (domainVariable :| [range]) + (compileStatement predicate) + let restrictedDomain = + CApp + (CApp (CIntrinsic Sep) domain) + (CLam TySet (logicalExists relation)) + choiceFunction = + CLam TySet + (CApp (CIntrinsic SetChoose) (CLam TySet relation)) + replacement = + CApp + (CApp (CIntrinsic Repl) restrictedDomain) + choiceFunction + pure (replacement, domain, relation) + +data CompiledFunctionalReplacement = CompiledFunctionalReplacement + !(CanonicalTerm ObjectId) + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + +compiledFunctionalReplacementTerm + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementTerm + (CompiledFunctionalReplacement term _domains _value _condition) = + term + +compiledFunctionalReplacementDomains + :: CompiledFunctionalReplacement + -> NonEmpty (CanonicalTerm ObjectId) +compiledFunctionalReplacementDomains + (CompiledFunctionalReplacement _term domains _value _condition) = + domains + +compiledFunctionalReplacementValue + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementValue + (CompiledFunctionalReplacement _term _domains value _condition) = + value + +compiledFunctionalReplacementCondition + :: CompiledFunctionalReplacement + -> Maybe (CanonicalTerm ObjectId) +compiledFunctionalReplacementCondition + (CompiledFunctionalReplacement _term _domains _value condition) = + condition + +compileFunctionalReplacement + :: Raw.Expr + -> NonEmpty (Raw.VarSymbol, Raw.Expr) + -> Maybe Raw.Stmt + -> Elaborate CompiledFunctionalReplacement +compileFunctionalReplacement + value ((variable, domain) :| remaining) condition = do + domain' <- compileExpressionAsSet domain + case remaining of + [] -> do + (value', condition') <- + withSetBinders (variable :| []) do + value' <- compileExpressionAsSet value + condition' <- traverse compileStatement condition + pure (value', condition') + let filteredDomain = + case condition' of + Nothing -> domain' + Just predicate -> + CApp + (CApp (CIntrinsic Sep) domain') + (CLam TySet predicate) + pure + (CompiledFunctionalReplacement + (CApp + (CApp (CIntrinsic Repl) filteredDomain) + (CLam TySet value')) + (domain' :| []) + value' + condition') + next : rest -> do + nested <- + withSetBinders (variable :| []) + (compileFunctionalReplacement + value (next :| rest) condition) + pure + (CompiledFunctionalReplacement + (CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp (CIntrinsic Repl) domain') + (CLam TySet + (compiledFunctionalReplacementTerm nested)))) + (domain' + NonEmpty.<| + compiledFunctionalReplacementDomains nested) + (compiledFunctionalReplacementValue nested) + (compiledFunctionalReplacementCondition nested)) + +compileStatement + :: Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileStatement = \case + Raw.StmtFormula formula -> + compileFormula formula + Raw.StmtVerbPhrase terms verbPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileVerbPhrase` verbPhrase) subjects + Raw.StmtNoun terms nounPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileNounPhraseMaybe` nounPhrase) subjects + Raw.StmtExists _location nounPhrase -> + compileExistentialNounPhrase nounPhrase + Raw.StmtQuantPhrase + _location + (Raw.QuantPhrase quantifier nounPhrase) + statement -> + compileQuantifiedNounPhrase quantifier nounPhrase statement + Raw.StmtConnected connective location left right -> + compileConnective + (fromMaybe (locate left) location) + connective + compileStatement + left + right + Raw.StmtNeg _location statement -> + logicalNot <$> compileStatement statement + Raw.SymbolicQuantified + _location quantifier variables bound suchThat statement -> + compileSymbolicQuantified + quantifier variables bound suchThat (compileStatement statement) + Raw.StmtStruct term rawPhrase -> + compileTermInProposition term \subject -> do + annotation <- + resolveStructureAnnotation (locate term) rawPhrase + predicate <- + maybe + (impossible "an assertable structure has no predicate") + pure + (structureAnnotationPredicate annotation) + recordExactGlobal + predicate + (TyArrow TySet TyProp) + pure + (CApp + (CGlobal predicate) + subject) + +compileQuantifiedTermInProposition + :: Raw.Quantifier + -> Raw.NounPhrase Maybe + -> (CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileQuantifiedTermInProposition quantifier + (Raw.NounPhrase left noun named right suchThat) + compileBody = + case named of + Nothing -> + withAnonymousSetBinder compileFor + Just variable -> + withSetBinders (variable :| []) do + subject <- compileIntroducedVariable variable + compileFor subject + where + compileFor subject = do + constraints <- + compileNounPhraseConstraints + [subject] left noun right suchThat + body <- compileBody subject + pure (quantifyNounPhrase quantifier 1 constraints body) + +compileSymbolicQuantified + :: Raw.Quantifier + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Maybe Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) + -> Elaborate (CanonicalTerm ObjectId) +compileSymbolicQuantified quantifier variables bound suchThat compileBody = + withSetBinders variables do + boundConstraints <- + compileSymbolicBoundConstraintList variables bound + suchThatConstraints <- + maybeToList <$> traverse compileStatement suchThat + body <- compileBody + pure + (quantifyNounPhrase + quantifier + (length (toList variables)) + (logicalConjunction + (boundConstraints <> suchThatConstraints)) + body) + +compileSymbolicBoundConstraintList + :: NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Elaborate [CanonicalTerm ObjectId] +compileSymbolicBoundConstraintList variables = \case + Raw.Unbounded -> + pure [] + Raw.Bounded _location sign relation domain -> do + subjects <- traverse compileIntroducedVariable variables + domain' <- compileExpressionAsSet domain + traverse + (\subject -> do + proposition <- + compileAtomicRelationTerms subject relation domain' + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition) + (toList subjects) + +compileAtomicRelationTerms + :: CanonicalTerm ObjectId + -> Raw.Relation + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileAtomicRelationTerms left relation right = + case relation of + Raw.Relation location symbol parameters -> do + let key = + SemanticRelation + (Raw.relationSymbolToken symbol) + (Raw.relationSymbolParameterArity symbol) + compiledParameters <- traverse compileExpressionAsSet parameters + case fixedSemanticMeaning key of + Just FixedEquality + | null parameters -> pure (CEq TySet left right) + Just FixedDisequality + | null parameters -> + pure (logicalNot (CEq TySet left right)) + Just (FixedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Positive left right + Just (FixedNegatedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Negative left right + Just (FixedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just (FixedNegatedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure (logicalNot term) + _ -> do + (term, actual) <- + applyResolvedTyped + location key + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Raw.RelationExpr location expression -> + compileRelationExpression location expression left right + +compileVerbPhrase + :: CanonicalTerm ObjectId + -> Raw.VerbPhrase + -> Elaborate (CanonicalTerm ObjectId) +compileVerbPhrase subject = \case + Raw.VPVerb verb -> + compileVerb subject verb + Raw.VPVerbNot verb -> + logicalNot <$> compileVerb subject verb + Raw.VPAdj adjectives -> + logicalConjunction + <$> traverse (compileAdjective subject) adjectives + Raw.VPAdjNot adjectives -> + logicalNot . logicalConjunction + <$> traverse (compileAdjective subject) adjectives + +compilePredicateArguments + :: CanonicalTerm ObjectId + -> [Raw.Term] + -> ( CanonicalTerm ObjectId + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) + ) + -> Elaborate (CanonicalTerm ObjectId) +compilePredicateArguments subject arguments continuation = do + subjectDepth <- State.gets elaborationBinderDepth + compileTermsInProposition arguments \compiled -> do + subject' <- weakenElaboratedTermFrom subjectDepth subject + continuation subject' compiled + +compileVerb + :: CanonicalTerm ObjectId + -> Raw.Verb + -> Elaborate (CanonicalTerm ObjectId) +compileVerb subject (Raw.Verb location item arguments) = do + let patterns = Raw.lexicalItemSgPlPattern item + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) + (subject' : compiled) + +compileAdjective + :: CanonicalTerm ObjectId + -> Raw.Adj + -> Elaborate (CanonicalTerm ObjectId) +compileAdjective subject (Raw.Adj location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicateChoice + location + ( SemanticRightAdjective (Raw.lexicalItemPattern item) + :| [SemanticLeftAdjective (Raw.lexicalItemPattern item)] + ) + (subject' : compiled) + +compileLeftAdjective + :: CanonicalTerm ObjectId + -> Raw.AdjL + -> Elaborate (CanonicalTerm ObjectId) +compileLeftAdjective subject (Raw.AdjL location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticLeftAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) + +compileRightAttribute + :: CanonicalTerm ObjectId + -> Raw.AdjR + -> Elaborate (CanonicalTerm ObjectId) +compileRightAttribute subject = \case + Raw.AdjR location item arguments -> + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticRightAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) + Raw.AttrRThat verbPhrase -> + compileVerbPhrase subject verbPhrase + +compileNoun + :: CanonicalTerm ObjectId + -> Raw.Noun + -> Elaborate (CanonicalTerm ObjectId) +compileNoun subject (Raw.Noun location item arguments) + | Lexicon.isBuiltinSetNoun item = + pure logicalTruth + | otherwise = do + let patterns = Raw.lexicalItemSgPlPattern item + key = SemanticNoun (Raw.sg patterns) (Raw.pl patterns) + compilePredicateArguments subject arguments \subject' compiled -> + case fixedSemanticMeaning key of + Just (FixedIntrinsic Member) -> + case compiled of + [set] -> + compileMembership + location Raw.Positive subject' set + _ -> + impossible + "the fixed element noun does not have one argument" + Just (FixedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\argument -> (argument, TySet)) + <$> (subject' : compiled)) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just{} -> + impossible "a fixed noun is not a predicate intrinsic" + Nothing -> + applyResolvedPredicate + location key (subject' : compiled) + +compileNounPhraseConstraints + :: [CanonicalTerm ObjectId] + -> [Raw.AdjL] + -> Raw.Noun + -> [Raw.AdjR] + -> Maybe Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileNounPhraseConstraints subjects left noun right suchThat = do + nounConstraints <- traverse (`compileNoun` noun) subjects + leftConstraints <- concat + <$> traverse + (\subject -> traverse (compileLeftAdjective subject) left) + subjects + rightConstraints <- concat + <$> traverse + (\subject -> traverse (compileRightAttribute subject) right) + subjects + suchThatConstraint <- traverse compileStatement suchThat + pure + (logicalConjunction + ( nounConstraints + <> leftConstraints + <> rightConstraints + <> maybeToList suchThatConstraint + )) + +compileNounPhraseMaybe + :: CanonicalTerm ObjectId + -> Raw.NounPhrase Maybe + -> Elaborate (CanonicalTerm ObjectId) +compileNounPhraseMaybe subject + (Raw.NounPhrase left noun named right suchThat) = + case named of + Nothing -> + compileNounPhraseConstraints + [subject] left noun right suchThat + Just variable -> do + abstracted <- + withSetBinders (variable :| []) + (compileNounPhraseConstraints + [CBound 0] left noun right suchThat) + pure (instantiateCanonical subject abstracted) + +compileExistentialNounPhrase + :: Raw.NounPhrase [] + -> Elaborate (CanonicalTerm ObjectId) +compileExistentialNounPhrase + (Raw.NounPhrase left noun variables right suchThat) = + case NonEmpty.nonEmpty variables of + Just binders -> + withSetBinders binders do + subjects <- traverse compileIntroducedVariable binders + constraints <- + compileNounPhraseConstraints + (toList subjects) left noun right suchThat + pure + (foldr + (const logicalExists) + constraints + binders) + Nothing -> + withAnonymousSetBinder \subject -> + logicalExists + <$> compileNounPhraseConstraints + [subject] left noun right suchThat + +compileQuantifiedNounPhrase + :: Raw.Quantifier + -> Raw.NounPhrase [] + -> Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileQuantifiedNounPhrase quantifier + (Raw.NounPhrase left noun variables right suchThat) + statement = + case NonEmpty.nonEmpty variables of + Just binders -> + withSetBinders binders do + subjects <- traverse compileIntroducedVariable binders + constraints <- + compileNounPhraseConstraints + (toList subjects) left noun right suchThat + body <- compileStatement statement + pure + (quantifyNounPhrase + quantifier + (length (toList binders)) + constraints + body) + Nothing -> + withAnonymousSetBinder \subject -> do + constraints <- + compileNounPhraseConstraints + [subject] left noun right suchThat + body <- compileStatement statement + pure (quantifyNounPhrase quantifier 1 constraints body) + +quantifyNounPhrase + :: Raw.Quantifier + -> Int + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId +quantifyNounPhrase quantifier binderCount constraints body = + case quantifier of + Raw.Universally -> + quantify + (if constraints == logicalTruth + then body + else CImp constraints body) + Raw.Existentially -> + quantify + (if constraints == logicalTruth + then body + else logicalAnd constraints body) + Raw.Nonexistentially -> + logicalNot + (quantify + (if constraints == logicalTruth + then body + else logicalAnd constraints body)) + where + quantify scoped = + foldr (const binder) scoped [1 .. binderCount] + binder = case quantifier of + Raw.Universally -> CForall TySet + Raw.Existentially -> logicalExists + Raw.Nonexistentially -> logicalExists + +withAnonymousSetBinder + :: (CanonicalTerm ObjectId -> Elaborate value) + -> Elaborate value +withAnonymousSetBinder action = do + outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth + outerStructures <- State.gets elaborationStructures + outerContextual <- State.gets elaborationContextualBinder + State.modify' \state -> + state + { elaborationBinders = (+ 1) <$> outer + , elaborationBinderDepth = outerDepth + 1 + , elaborationStructures = + Map.mapKeysMonotonic (+ 1) outerStructures + , elaborationContextualBinder = (+ 1) <$> outerContextual + } + result <- action (CBound 0) + State.modify' \state -> + state + { elaborationBinders = outer + , elaborationBinderDepth = outerDepth + , elaborationStructures = outerStructures + , elaborationContextualBinder = outerContextual + } + pure result + +withSetBinders + :: NonEmpty Raw.VarSymbol + -> Elaborate value + -> Elaborate value +withSetBinders variables action = do + outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth + outerStructures <- State.gets elaborationStructures + outerContextual <- State.gets elaborationContextualBinder + case firstDuplicate (toList variables) of + Just duplicate -> + Except.throwError + (ExactDuplicateLocalBinder + (locate duplicate) + duplicate) + Nothing -> pure () + case find (`Map.member` outer) (toList variables) of + Just shadowed -> + Except.throwError + (ExactDuplicateLocalBinder + (locate shadowed) + shadowed) + Nothing -> pure () + let binderCount = fromIntegral (length (toList variables)) + shifted = (+ binderCount) <$> outer + introduced = + Map.fromList + (zip + (toList variables) + (reverse [0 .. binderCount - 1])) + State.modify' \state -> + state + { elaborationBinders = introduced <> shifted + , elaborationBinderDepth = outerDepth + binderCount + , elaborationStructures = + Map.mapKeysMonotonic (+ binderCount) outerStructures + , elaborationContextualBinder = + (+ binderCount) <$> outerContextual + } + result <- action + State.modify' \state -> + state + { elaborationBinders = outer + , elaborationBinderDepth = outerDepth + , elaborationStructures = outerStructures + , elaborationContextualBinder = outerContextual + } + pure result + +compileFormula + :: Raw.Formula + -> Elaborate (CanonicalTerm ObjectId) +compileFormula = \case + Raw.FormulaChain chain -> + compileRelationChain chain + Raw.PropositionalConstant _ Raw.IsBottom -> + pure CFalsum + Raw.PropositionalConstant _ Raw.IsTop -> + pure (CImp CFalsum CFalsum) + Raw.FormulaNeg _ formula -> + logicalNot <$> compileFormula formula + Raw.FormulaPredicate + location + (Raw.PrefixPredicate command arity) + _marker + arguments -> do + compiled <- traverse compileExpression arguments + (term, actual) <- + applyResolvedTyped + location + (SemanticPrefixPredicate + command + (fromIntegral arity)) + (toList compiled) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Raw.Connected location connective left right -> + compileConnective + location + connective + compileFormula + left + right + Raw.FormulaQuantified + _location quantifier variables bound formula -> + compileSymbolicQuantified + quantifier variables bound Nothing (compileFormula formula) +compileConnective + :: Location + -> Raw.Connective + -> (input -> Elaborate (CanonicalTerm ObjectId)) + -> input + -> input + -> Elaborate (CanonicalTerm ObjectId) +compileConnective _location connective compile left right = do + left' <- compile left + right' <- compile right + case connective of + Raw.Conjunction -> + pure (logicalAnd left' right') + Raw.Disjunction -> + pure (logicalOr left' right') + Raw.Implication -> + pure (CImp left' right') + Raw.Equivalence -> + pure (CEq TyProp left' right') + Raw.ExclusiveOr -> + pure + (logicalAnd + (logicalOr left' right') + (logicalNot (logicalAnd left' right'))) + Raw.NegatedDisjunction -> + pure (logicalNot (logicalOr left' right')) + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + logicalNot (CImp left (logicalNot right)) + +logicalTruth :: CanonicalTerm global +logicalTruth = + CImp CFalsum CFalsum + +logicalConjunction + :: (Foldable collection, Eq global) + => collection (CanonicalTerm global) + -> CanonicalTerm global +logicalConjunction = + foldr combine logicalTruth + where + combine proposition remaining + | proposition == logicalTruth = remaining + | remaining == logicalTruth = proposition + | otherwise = logicalAnd proposition remaining + +logicalOr + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalOr left right = + CImp (logicalNot left) right + +logicalExists + :: CanonicalTerm global + -> CanonicalTerm global +logicalExists body = + logicalNot (CForall TySet (logicalNot body)) + +compileAtomicRelation + :: NonEmpty Raw.Expr + -> Raw.Relation + -> NonEmpty Raw.Expr + -> Elaborate (CanonicalTerm ObjectId) +compileAtomicRelation left relation right = + case (toList left, relation, toList right) of + ([leftExpression], Raw.Relation location symbol parameters, [rightExpression]) -> do + let key = + SemanticRelation + (Raw.relationSymbolToken symbol) + (Raw.relationSymbolParameterArity symbol) + case fixedSemanticMeaning key of + Just FixedEquality + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + pure (CEq TySet left' right') + | otherwise -> + Except.throwError + (ExactUnsupportedDeclarationBody location) + Just FixedDisequality + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + pure (logicalNot (CEq TySet left' right')) + | otherwise -> + Except.throwError + (ExactUnsupportedDeclarationBody location) + Just (FixedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Positive left' right' + Just (FixedNegatedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Negative left' right' + Just (FixedIntrinsic intrinsic) -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just (FixedNegatedIntrinsic intrinsic) -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure (logicalNot term) + Nothing -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyResolvedTyped location key compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + ([leftExpression], Raw.RelationExpr location expression, [rightExpression]) -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileRelationExpression location expression left' right' + _ -> + Except.throwError + (ExactUnsupportedDeclarationBody (locate relation)) + +compileRelationExpression + :: Location + -> Raw.Expr + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileRelationExpression location expression left right = do + relation <- compileExpressionAsSet expression + pair <- + applyResolved + location + (SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol)) + [left, right] + compileMembership location Raw.Positive pair relation + +compileRelationChain + :: Raw.Chain + -> Elaborate (CanonicalTerm ObjectId) +compileRelationChain chain = + logicalConjunction <$> traverse compileLink (chainLinks chain) + where + compileLink (sign, relation, left, right) = do + proposition <- + compileAtomicRelation + (left :| []) relation (right :| []) + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition + + chainLinks = \case + Raw.ChainBase left sign relation right -> + [ (sign, relation, leftExpression, rightExpression) + | leftExpression <- toList left + , rightExpression <- toList right + ] + Raw.ChainCons left sign relation rest -> + let firstRight = chainFirstLeft rest + in + [ (sign, relation, leftExpression, rightExpression) + | leftExpression <- toList left + , rightExpression <- toList firstRight + ] + <> chainLinks rest + + chainFirstLeft = \case + Raw.ChainBase left _sign _relation _right -> left + Raw.ChainCons left _sign _relation _rest -> left + +applyResolved + :: Location + -> SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolved location key arguments = do + (term, actual) <- + applyResolvedTyped + location key ((\argument -> (argument, TySet)) <$> arguments) + unless (actual == TySet) + (Except.throwError + (ExactExpressionExpectedSet location actual)) + pure term + +applyResolvedPredicate + :: Location + -> SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolvedPredicate location key = + applyResolvedPredicateChoice location (key :| []) + +applyResolvedPredicateChoice + :: Location + -> NonEmpty SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolvedPredicateChoice location keys arguments = do + case firstFixedMeaning (toList keys) of + Just meaning -> + maybe + (impossible + "a fixed equality predicate has an invalid source arity") + pure + (lowerFixedEqualityPredicate meaning arguments) + Nothing -> do + visible <- for (toList keys) \key -> do + found <- + State.lift + (Except.lift + (Declaration.resolveVisibleGlobalLowering key)) + pure ((\target -> (key, target)) <$> found) + case catMaybes visible of + [(key, _target)] -> do + (term, actual) <- + applyResolvedTyped + location key + ((\argument -> (argument, TySet)) <$> arguments) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + [] -> + Except.throwError + (ExactGlobalNotVisible location (NonEmpty.head keys)) + _ -> + impossible + "one adjective surface resolves to several exact globals" + where + firstFixedMeaning = + foldr + (\key found -> fixedSemanticMeaning key <|> found) + Nothing + +applyResolvedTyped + :: Location + -> SemanticGlobalKey + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyResolvedTyped location key arguments = do + visible <- + State.lift + (Except.lift + (Declaration.resolveVisibleGlobalContentLowering key)) + (target, content, dependencies) <- + maybe + (Except.throwError (ExactGlobalNotVisible location key)) + pure + visible + case target of + GlobalReference identity -> do + let coreType = objectContentType content + State.modify' \state -> + state + { elaborationGlobals = + Map.insert + identity coreType + (elaborationGlobals state) + } + applyTyped location (CGlobal identity) coreType arguments + TransparentExpansion _identity -> + case content of + TransparentObjectContent _theory coreType body -> do + State.modify' \state -> + state + { elaborationGlobals = + Map.union + dependencies + (elaborationGlobals state) + } + applyExpandedTyped + location body coreType arguments + _ -> + impossible + "validated transparent expansion has opaque content" + ContextualTransparentExpansion _identity requirements -> + case content of + TransparentObjectContent _theory coreType body -> do + State.modify' \state -> + state + { elaborationGlobals = + Map.union + dependencies + (elaborationGlobals state) + } + contextArgument <- + resolveContextualExpansionArgument + location key requirements + applyExpandedTyped + location body coreType + ((contextArgument, TySet) : arguments) + _ -> + impossible + "validated contextual expansion has opaque content" + +resolveContextualExpansionArgument + :: Location + -> SemanticGlobalKey + -> Map.Map Raw.StructSymbol ObjectId + -> Elaborate (CanonicalTerm ObjectId) +resolveContextualExpansionArgument location key requirements = do + contextual <- State.gets elaborationContextualBinder + case contextual of + Just index -> do + traverse_ + (uncurry (recordContextualRequirement location)) + (Map.toAscList requirements) + pure (CBound index) + Nothing -> do + structures <- State.gets elaborationStructures + case + [ CBound index + | (index, structure) <- Map.toAscList structures + , all + (\(symbol, object) -> + structureAnnotationOperation symbol structure + == Just object) + (Map.toAscList requirements) + ] of + firstMatch : _ -> pure firstMatch + [] -> + Except.throwError + (ExactContextualExpansionNotAvailable location key) + +applyExpandedTyped + :: Location + -> CanonicalTerm ObjectId + -> CoreType + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyExpandedTyped location body coreType arguments = + foldM step (body, coreType) arguments + where + step (current, currentType) (argument, argumentType) = + case currentType of + TyArrow expected result + | expected == argumentType -> + pure + ( case current of + CLam binderType lambdaBody + | binderType == expected -> + instantiateCanonical + argument lambdaBody + _ -> CApp current argument + , result + ) + | otherwise -> + Except.throwError + (ExactApplicationArgumentMismatch + location expected argumentType) + actual -> + Except.throwError + (ExactApplicationExpectedFunction location actual) + +applyTyped + :: Location + -> CanonicalTerm ObjectId + -> CoreType + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyTyped location function functionType arguments = + foldM step (function, functionType) arguments + where + step (currentFunction, currentType) (argument, argumentType) = + case currentType of + TyArrow expected result + | expected == argumentType -> + pure (CApp currentFunction argument, result) + | otherwise -> + Except.throwError + (ExactApplicationArgumentMismatch + location expected argumentType) + actual -> + Except.throwError + (ExactApplicationExpectedFunction location actual) + +logicalNot :: CanonicalTerm global -> CanonicalTerm global +logicalNot proposition = + CImp proposition CFalsum + +ensureExpressionKey + :: MonadError ExactCompileError monad + => Location + -> Raw.FunctionSymbol + -> SemanticGlobalKey + -> monad () +ensureExpressionKey location symbol key = + unless + (key == SemanticExpressionFunction (Raw.mixfixPattern symbol)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureAdjectiveKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItem + -> SemanticGlobalKey + -> monad () +ensureAdjectiveKey location item key = + unless + ( key == SemanticLeftAdjective (Raw.lexicalItemPattern item) + || key == SemanticRightAdjective (Raw.lexicalItemPattern item) + ) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureFunctionPhraseKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureFunctionPhraseKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureNounKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureNounKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticNoun (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureVerbKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureVerbKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureRelationKey + :: MonadError ExactCompileError monad + => Location + -> Raw.RelationSymbol + -> SemanticGlobalKey + -> monad () +ensureRelationKey location relation key = + unless + ( key + == SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + ) + (throwError (ExactDeclarationHeadMismatch location)) + +exactSetNounPhrase :: Raw.NounPhrase Maybe -> Bool +exactSetNounPhrase = \case + Raw.NounPhrase + [] + (Raw.Noun _ item []) + Nothing + [] + Nothing -> + Lexicon.isBuiltinSetNoun item + _ -> False + +encodePreparedSyntax + :: ExactDeclarationFamily + -> PreparedHead + -> PreparedBody + -> Maybe SemanticName + -> ByteString +encodePreparedSyntax + family (PreparedHead key _parameters coreType) body alias = + encodeCache do + putCacheTag case family of + ExactSignature -> 0x00 + ExactAbbreviation -> 0x01 + ExactDefinition -> 0x02 + putSemanticGlobalKeyCache key + putCoreTypeCache coreType + case body of + OpaqueBody -> putCacheTag 0x00 + TransparentBody canonical _construction -> do + putCacheTag 0x01 + putCanonicalTermCache putObjectIdCache canonical + ContextualTransparentBody requirements canonical -> do + putCacheTag 0x02 + putCanonicalCacheMap + (\(Raw.StructSymbol symbol) -> putCacheText symbol) + putObjectIdCache + requirements + putCanonicalTermCache putObjectIdCache canonical + putCacheMaybe + (putCacheText . semanticNameText) + alias + +encodePreparedSourceAxiom + :: ScopedCheckedCore ObjectId + -> SemanticName + -> ByteString +encodePreparedSourceAxiom proposition alias = + encodeCache do + putCacheTag 0x03 + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm proposition) + putCacheText (semanticNameText alias) + +definitionAlias :: Raw.Block -> Maybe SemanticName +definitionAlias = \case + Raw.BlockDefn _location _title (Raw.Marker marker) _definition -> + Just (semanticName marker) + _ -> Nothing + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _seen [] = Nothing + go seen (value : rest) + | value `Set.member` seen = Just value + | otherwise = go (Set.insert value seen) rest diff --git a/source/Felix/Checking/Exact/Datatype.hs b/source/Felix/Checking/Exact/Datatype.hs new file mode 100644 index 0000000..be943cd --- /dev/null +++ b/source/Felix/Checking/Exact/Datatype.hs @@ -0,0 +1,751 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact preparation of deterministic datatype declarations. +module Felix.Checking.Exact.Datatype + ( PreparedExactDatatype + , preparedExactDatatypeObjects + , preparedExactDatatypeBindings + , PreparedExactDatatypeFact + , preparedExactDatatypeFacts + , preparedExactDatatypeFactMarker + , preparedExactDatatypeFactTarget + , preparedExactDatatypeFactReference + , preparedExactDatatypeDescriptor + , prepareExactDatatype + , CheckedExactDatatypeAuthorization + , lowerPreparedExactDatatype + , authorizeCheckedExactDatatype + , ExactDatatypeError(..) + , exactDatatypeErrorLocation + , renderExactDatatypeError + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Datatype qualified as Datatype +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Cache.Codec +import Felix.Module +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (unless, when) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Numeric.Natural (Natural) + + +data PreparedDatatypeObject = PreparedDatatypeObject + !Internal.Symbol + !SemanticGlobalKey + !CoreType + !ObjectId + !AssertedObject + +data PreparedExactDatatypeFact = PreparedExactDatatypeFact + !Internal.Marker + !(FrozenCheckedCore ObjectId) + !TheoremRef + +preparedExactDatatypeFactMarker + :: PreparedExactDatatypeFact + -> Internal.Marker +preparedExactDatatypeFactMarker + (PreparedExactDatatypeFact marker _target _reference) = + marker + +preparedExactDatatypeFactTarget + :: PreparedExactDatatypeFact + -> FrozenCheckedCore ObjectId +preparedExactDatatypeFactTarget + (PreparedExactDatatypeFact _marker target _reference) = + target + +preparedExactDatatypeFactReference + :: PreparedExactDatatypeFact + -> TheoremRef +preparedExactDatatypeFactReference + (PreparedExactDatatypeFact _marker _target reference) = + reference + +data PreparedExactDatatype = PreparedExactDatatype + !Location + !DeclarationSyntaxId + !(NonEmpty PreparedDatatypeObject) + !(NonEmpty PreparedExactDatatypeFact) + !DatatypeCompilationDescriptor + +data CheckedExactDatatypeAuthorization = + CheckedExactDatatypeAuthorization + !DatatypeCompilationDescriptor + !ObjectId + !(NonEmpty ObjectId) + +preparedExactDatatypeObjects + :: PreparedExactDatatype + -> NonEmpty (ObjectId, CoreType) +preparedExactDatatypeObjects + (PreparedExactDatatype _location _syntax objects _facts _descriptor) = + fmap + (\(PreparedDatatypeObject _symbol _key coreType identity _asserted) -> + (identity, coreType)) + objects + +preparedExactDatatypeBindings + :: PreparedExactDatatype + -> NonEmpty (SemanticGlobalKey, SemanticGlobalTarget) +preparedExactDatatypeBindings + (PreparedExactDatatype _location _syntax objects _facts _descriptor) = + fmap + (\(PreparedDatatypeObject _symbol key _coreType identity _asserted) -> + (key, GlobalReference identity)) + objects + +preparedExactDatatypeFacts + :: PreparedExactDatatype + -> NonEmpty PreparedExactDatatypeFact +preparedExactDatatypeFacts + (PreparedExactDatatype _location _syntax _objects facts _descriptor) = + facts + +preparedExactDatatypeDescriptor + :: PreparedExactDatatype + -> DatatypeCompilationDescriptor +preparedExactDatatypeDescriptor + (PreparedExactDatatype _location _syntax _objects _facts descriptor) = + descriptor + +lowerPreparedExactDatatype + :: PreparedExactDatatype + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactDatatypeAuthorization)) +lowerPreparedExactDatatype + (PreparedExactDatatype _location syntax objects facts descriptor) = + do + prepared <- + traverse + (\(PreparedExactDatatypeFact marker target _reference) -> + Declaration.prepareFrozenCandidateSpecLowering + assertedObjects + target + SearchEligible + [markerAlias marker]) + facts + pure (buildChecked <$> sequence prepared) + where + assertedObjects = + toList + (fmap + (\(PreparedDatatypeObject + _symbol _key _coreType _identity asserted) -> asserted) + objects) + bindings = + toList + (fmap + (\(PreparedDatatypeObject + _symbol key _coreType identity _asserted) -> + semanticGlobalBinding key (GlobalReference identity)) + objects) + carrier :| constructors = fmap objectIdentity objects + constructorIds = + case constructors of + firstConstructor : remainingConstructors -> + firstConstructor :| remainingConstructors + [] -> impossible "a prepared datatype has no constructor" + buildChecked specs = + Declaration.checkedCompiledDeclaration + syntax + assertedObjects + [] + bindings + [] + [ fmap + (\spec -> + Declaration.checkedCandidate + spec + (Declaration.checkedDatatypePlanning descriptor)) + specs + ] + (CheckedExactDatatypeAuthorization + descriptor carrier constructorIds) + + markerAlias (Internal.Marker name) = semanticName name + + objectIdentity + (PreparedDatatypeObject + _symbol _key _coreType identity _asserted) = + identity + +authorizeCheckedExactDatatype + :: CheckedExactDatatypeAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactDatatype + (CheckedExactDatatypeAuthorization descriptor carrier constructors) = + \case + [candidates] -> + Declaration.authorizeDatatypeCompilationCandidates + descriptor carrier constructors candidates + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +data ExactDatatypeError + = ExactDatatypeUnsupportedBlock !Location + | ExactDatatypeOccurrenceCountMismatch !Location !Int !Int + | ExactDatatypeOccurrenceMismatch !Location + | ExactDatatypeGlossFailed !Location !Meaning.GlossError + | ExactDatatypeInvalid !Location !Text + | ExactDatatypeDuplicateGlobal !Location !SemanticGlobalKey + | ExactDatatypeFixedSemanticCollision !Location !SemanticGlobalKey + | ExactDatatypeGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactDatatypeObjectAlreadyAvailable !Location !ObjectId + | ExactDatatypeGlobalResolutionFailed + !Location + !ExactGlobal.ExactGlobalResolutionError + | ExactDatatypeLoweringFailed !Location !Typed.TypedInductiveError + | ExactDatatypeExpectedSet !Location !CoreType + | ExactDatatypeExpectedProposition !Location !CoreType + deriving stock (Show, Eq) + +exactDatatypeErrorLocation :: ExactDatatypeError -> Location +exactDatatypeErrorLocation = \case + ExactDatatypeUnsupportedBlock location -> location + ExactDatatypeOccurrenceCountMismatch location _expected _actual -> location + ExactDatatypeOccurrenceMismatch location -> location + ExactDatatypeGlossFailed location _failure -> location + ExactDatatypeInvalid location _message -> location + ExactDatatypeDuplicateGlobal location _key -> location + ExactDatatypeFixedSemanticCollision location _key -> location + ExactDatatypeGlobalAlreadyVisible location _key -> location + ExactDatatypeObjectAlreadyAvailable location _identity -> location + ExactDatatypeGlobalResolutionFailed location _failure -> location + ExactDatatypeLoweringFailed location _failure -> location + ExactDatatypeExpectedSet location _actual -> location + ExactDatatypeExpectedProposition location _actual -> location + +renderExactDatatypeError :: ExactDatatypeError -> Text +renderExactDatatypeError failure = + locationToText (exactDatatypeErrorLocation failure) + <> ": " + <> case failure of + ExactDatatypeUnsupportedBlock{} -> + "this datatype source form is not supported by the typed checker" + ExactDatatypeOccurrenceCountMismatch _location expected actual -> + "the datatype has " <> shown actual + <> " syntax occurrences, but " <> shown expected + <> " are required" + ExactDatatypeOccurrenceMismatch{} -> + "a datatype syntax occurrence does not match its declaration" + ExactDatatypeGlossFailed _location glossFailure -> + "datatype elaboration failed: " <> shown glossFailure + ExactDatatypeInvalid _location message -> + "invalid datatype declaration: " <> message + ExactDatatypeDuplicateGlobal _location key -> + "the datatype declares the semantic key more than once: " + <> shown key + ExactDatatypeFixedSemanticCollision _location key -> + "the datatype collides with fixed semantics for " <> shown key + ExactDatatypeGlobalAlreadyVisible _location key -> + "the datatype global is already visible: " <> shown key + ExactDatatypeObjectAlreadyAvailable _location identity -> + "the datatype opaque object is already available: " + <> shown identity + ExactDatatypeGlobalResolutionFailed _location resolution -> + "datatype global resolution failed: " <> shown resolution + ExactDatatypeLoweringFailed _location typedFailure -> + "typed datatype lowering failed: " <> shown typedFailure + ExactDatatypeExpectedSet _location actual -> + "a datatype premise domain has type " <> shown actual + <> " instead of Set" + ExactDatatypeExpectedProposition _location actual -> + "a generated datatype fact has type " <> shown actual + <> " instead of Prop" + where + shown :: Show value => value -> Text + shown = Text.pack . show + +type Prepare = + ExceptT ExactDatatypeError (Declaration.LoweringDriver) + +type SourceOccurrence = (Location, Raw.Marker, CanonicalLexicalEntry) + +exactDatatypeInvalid + :: Location + -> Datatype.DatatypeValidationError + -> ExactDatatypeError +exactDatatypeInvalid declarationLocation failure = + ExactDatatypeInvalid + (fromMaybe + declarationLocation + (Datatype.datatypeValidationErrorLocation failure)) + (Datatype.renderDatatypeValidationError failure) + +prepareExactDatatype + :: Raw.Block + -> [SourceOccurrence] + -> Declaration.LoweringDriver + (Either ExactDatatypeError PreparedExactDatatype) +prepareExactDatatype block occurrences = + Except.runExceptT do + (location, marker, rawDatatype) <- + case block of + Raw.BlockData blockLocation _title blockMarker datatype -> + pure (blockLocation, blockMarker, datatype) + _ -> + Except.throwError + (ExactDatatypeUnsupportedBlock (locate block)) + keys <- validateOccurrences location marker rawDatatype occurrences + internal <- + case Meaning.meaning [block] of + Right + [Internal.BlockData + _internalLocation _internalMarker datatype] -> + pure datatype + Left failure -> + Except.throwError + (ExactDatatypeGlossFailed location failure) + Right _ -> + Except.throwError + (ExactDatatypeUnsupportedBlock location) + checked <- + -- The new opaque carrier has no semantic binding while its + -- declaration is prepared, so premise recursion cannot depend on + -- abbreviation expansion. Revisit this if forward aliases become + -- available. + Except.lift + (Datatype.prepareCheckedDatatype pure internal) + >>= Except.liftEither + . first (exactDatatypeInvalid location) + let symbols = + Datatype.checkedDatatypeHeadSymbol checked + :| toList + (Datatype.checkedDatatypeConstructorSymbols checked) + views = Datatype.checkedDatatypeClauseViews checked + arities = + 0 :| (length + . Datatype.checkedDatatypeClauseViewArguments + <$> toList views) + unless (NonEmpty.length symbols == NonEmpty.length keys) + (Except.throwError + (ExactDatatypeOccurrenceCountMismatch + location + (NonEmpty.length symbols) + (NonEmpty.length keys))) + validateKeys occurrences keys + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + objects <- + sequence + (NonEmpty.zipWith + (\index (occurrenceLocation, symbol, key, arity) -> + prepareObject + occurrenceLocation + slot theory index symbol key arity) + (0 :| [1 ..]) + (NonEmpty.zipWith + (\occurrenceLocation (symbol, key, arity) -> + (occurrenceLocation, symbol, key, arity)) + (validatedOccurrenceLocations occurrences) + (NonEmpty.zipWith + (\(symbol, key) arity -> + (symbol, key, arity)) + (NonEmpty.zip symbols keys) + arities))) + let ownedSymbols = Set.fromList (toList symbols) + generated = Datatype.checkedDatatypeGeneratedFacts checked + externalSymbols = + (foldMap + (Internal.mentionedSymbols . snd) + generated + <> foldMap premiseSymbols views) + `Set.difference` ownedSymbols + external <- + Except.lift + (ExactGlobal.resolveExactSourceGlobals externalSymbols) + >>= Except.liftEither + . first (ExactDatatypeGlobalResolutionFailed location) + let (externalGlobals, externalTypes) = external + ownedGlobals = + Map.fromList + [ (symbol, Typed.SourceGlobal identity Nothing) + | PreparedDatatypeObject + symbol _key _coreType identity _asserted <- + toList objects + ] + ownedTypes = + Map.fromList + [ (identity, coreType) + | PreparedDatatypeObject + _symbol _key coreType identity _asserted <- + toList objects + ] + sourceGlobals = Map.union ownedGlobals externalGlobals + globalTypes = Map.union ownedTypes externalTypes + resolveGlobal = (`Map.lookup` sourceGlobals) + globalType identity = + fromMaybe + (impossible + "prepared datatype global has no checked type") + (Map.lookup identity globalTypes) + preparedClauses <- + Except.liftEither + (traverse + (prepareClause location globalType resolveGlobal) + views) + facts <- + Except.liftEither + (traverse + (prepareFact location theory globalType resolveGlobal) + generated) + let carrier = objectIdentity (NonEmpty.head objects) + constructors = objectIdentity <$> NonEmpty.tail objects + descriptor = + case NonEmpty.nonEmpty constructors of + Nothing -> + impossible + "a checked datatype has no constructors" + Just nonemptyConstructors -> + datatypeCompilationDescriptor + carrier + nonemptyConstructors + (preparedExactDatatypeFactReference + <$> toList facts) + syntax = + declarationSyntaxId + (encodePreparedDatatype + objects + preparedClauses + facts + descriptor) + pure + (PreparedExactDatatype + location + syntax + objects + facts + descriptor) + where + objectIdentity + (PreparedDatatypeObject _symbol _key _coreType identity _asserted) = + identity + +validateOccurrences + :: Location + -> Raw.Marker + -> Raw.Datatype + -> [SourceOccurrence] + -> Prepare (NonEmpty SemanticGlobalKey) +validateOccurrences location marker datatype occurrences = do + expected <- + Except.liftEither + (expectedOccurrences location marker datatype) + unless (length occurrences == NonEmpty.length expected) + (Except.throwError + (ExactDatatypeOccurrenceCountMismatch + location + (NonEmpty.length expected) + (length occurrences))) + keys <- + sequence + (NonEmpty.zipWith validateOne expected + (case NonEmpty.nonEmpty occurrences of + Just nonempty -> nonempty + Nothing -> + impossible + "equal nonzero occurrence counts became empty")) + pure keys + where + validateOne + (expectedLocation, expectedMarker, expectedPattern) + (actualLocation, actualMarker, entry) = + case entry of + CanonicalExpressionFunction pat marker' _fixity + | actualMarker == expectedMarker + , marker' == expectedMarker + , pat == expectedPattern -> + pure + (SemanticExpressionFunction pat) + _ -> + Except.throwError + (ExactDatatypeOccurrenceMismatch + (bestLocation actualLocation expectedLocation)) + + bestLocation actual expected + | actual == Nowhere = expected + | otherwise = actual + +expectedOccurrences + :: Location + -> Raw.Marker + -> Raw.Datatype + -> Either + ExactDatatypeError + (NonEmpty (Location, Raw.Marker, Raw.Pattern)) +expectedOccurrences location blockMarker datatype = do + headOccurrence <- + expectedSymbol blockMarker (Raw.datatypeHeadExpr datatype) + clauses <- + traverse + (\clause -> + case Raw.datatypeClauseConstructorExpr clause of + Raw.ExprOp constructorLocation symbol _arguments -> + Right + ( constructorLocation + , Raw.mixfixMarker symbol + , Raw.mixfixPattern symbol + ) + expression -> + Left + (ExactDatatypeOccurrenceMismatch + (locate expression))) + (Raw.datatypeClauses datatype) + pure (headOccurrence :| toList clauses) + where + expectedSymbol expectedMarker = \case + Raw.ExprOp symbolLocation symbol [] -> + Right + ( symbolLocation + , expectedMarker + , Raw.mixfixPattern symbol + ) + expression -> + Left + (ExactDatatypeOccurrenceMismatch + (case locate expression of + Nowhere -> location + expressionLocation -> expressionLocation)) + +validateKeys + :: [SourceOccurrence] + -> NonEmpty SemanticGlobalKey + -> Prepare () +validateKeys occurrences keys = do + case duplicateWithLocation of + Just (duplicate, duplicateLocation) -> + Except.throwError + (ExactDatatypeDuplicateGlobal + duplicateLocation + duplicate) + Nothing -> pure () + traverse_ validateOne (NonEmpty.zip locations keys) + where + locations = validatedOccurrenceLocations occurrences + + duplicateWithLocation = + go Set.empty + [ (key, occurrenceLocation) + | (key, (occurrenceLocation, _marker, _entry)) <- + zip (toList keys) occurrences + ] + + go _seen [] = Nothing + go seen ((key, occurrenceLocation) : remaining) + | key `Set.member` seen = Just (key, occurrenceLocation) + | otherwise = go (Set.insert key seen) remaining + + validateOne (occurrenceLocation, key) = do + when (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactDatatypeFixedSemanticCollision occurrenceLocation key)) + visible <- + Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when (isJust visible) + (Except.throwError + (ExactDatatypeGlobalAlreadyVisible occurrenceLocation key)) + +validatedOccurrenceLocations + :: [SourceOccurrence] + -> NonEmpty Location +validatedOccurrenceLocations occurrences = + case NonEmpty.nonEmpty + [ occurrenceLocation + | (occurrenceLocation, _marker, _entry) <- occurrences + ] of + Just nonempty -> nonempty + Nothing -> + impossible "validated datatype occurrences are empty" + +prepareObject + :: Location + -> DeclarationSlot + -> TheoryId + -> Natural + -> Internal.Symbol + -> SemanticGlobalKey + -> Int + -> Prepare PreparedDatatypeObject +prepareObject location slot theory index symbol key arity = do + let coreType = + foldr (const (TyArrow TySet)) TySet [1 .. arity] + seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + DatatypeDeclaration + (generatedObjectSlot index) + content = OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + available <- Except.lift (Declaration.objectAvailableLowering identity) + when available + (Except.throwError + (ExactDatatypeObjectAlreadyAvailable location identity)) + pure + (PreparedDatatypeObject + symbol + key + coreType + identity + (assertedObject identity content)) + +data PreparedClause = PreparedClause + !Internal.FunctionSymbol + ![PreparedPremise] + +data PreparedPremise + = PreparedRecursivePremise !(FrozenCheckedCore ObjectId) + | PreparedNonRecursivePremise !(FrozenCheckedCore ObjectId) + +prepareClause + :: Location + -> (ObjectId -> CoreType) + -> (Internal.Symbol -> Maybe (Typed.SourceGlobal ObjectId)) + -> Datatype.CheckedDatatypeClauseView + -> Either ExactDatatypeError PreparedClause +prepareClause location globalType resolveGlobal view = + PreparedClause + (Datatype.checkedDatatypeClauseViewConstructor view) + <$> traverse preparePremise + (Datatype.checkedDatatypeClauseViewPremises view) + where + preparePremise = \case + Datatype.CheckedRecursiveDatatypePremise _variable domain -> + PreparedRecursivePremise + <$> prepareDomain domain + Datatype.CheckedNonRecursiveDatatypePremise _variable domain -> + PreparedNonRecursivePremise + <$> prepareDomain domain + + prepareDomain domain = do + checked <- + first (ExactDatatypeLoweringFailed location) + (Typed.prepareTypedClosedTerm + globalType + resolveGlobal + domain) + unless (frozenCoreType checked == TySet) + (Left + (ExactDatatypeExpectedSet + location + (frozenCoreType checked))) + pure checked + +prepareFact + :: Location + -> TheoryId + -> (ObjectId -> CoreType) + -> (Internal.Symbol -> Maybe (Typed.SourceGlobal ObjectId)) + -> (Internal.Marker, Internal.Formula) + -> Either ExactDatatypeError PreparedExactDatatypeFact +prepareFact location theory globalType resolveGlobal (marker, formula) = do + checked <- + first (ExactDatatypeLoweringFailed location) + (Typed.prepareTypedClosedFormula + globalType + resolveGlobal + formula) + unless (frozenCoreType checked == TyProp) + (Left + (ExactDatatypeExpectedProposition + location + (frozenCoreType checked))) + pure + (PreparedExactDatatypeFact + marker + checked + (theoremRef theory + (propositionIdOf (frozenCoreTerm checked)))) + +premiseSymbols + :: Datatype.CheckedDatatypeClauseView + -> Set.Set Internal.Symbol +premiseSymbols view = + foldMap symbols + (Datatype.checkedDatatypeClauseViewPremises view) + where + symbols = \case + Datatype.CheckedRecursiveDatatypePremise _variable domain -> + Internal.mentionedSymbols domain + Datatype.CheckedNonRecursiveDatatypePremise _variable domain -> + Internal.mentionedSymbols domain + +encodePreparedDatatype + :: NonEmpty PreparedDatatypeObject + -> NonEmpty PreparedClause + -> NonEmpty PreparedExactDatatypeFact + -> DatatypeCompilationDescriptor + -> ByteString +encodePreparedDatatype objects clauses facts descriptor = + encodeCache do + putCacheTag 0x05 + putCacheList putObject (toList objects) + putCacheList putClause (toList clauses) + putCacheList putFact (toList facts) + putDirectAuthorizationCache + (TrustedCompilation + (DatatypeCompilation descriptor)) + where + putObject + (PreparedDatatypeObject + _symbol key coreType identity _asserted) = do + putSemanticGlobalKeyCache key + putCoreTypeCache coreType + putObjectIdCache identity + + putClause (PreparedClause constructor premises) = do + putSemanticGlobalKeyCache + (SemanticExpressionFunction + (Raw.mixfixPattern constructor)) + putCacheList putPremise premises + + putPremise = \case + PreparedRecursivePremise domain -> do + putCacheTag 0x00 + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm domain) + PreparedNonRecursivePremise domain -> do + putCacheTag 0x01 + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm domain) + + putFact fact = do + let Internal.Marker marker = + preparedExactDatatypeFactMarker fact + putCacheText marker + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (preparedExactDatatypeFactTarget fact)) + putTheoremRefCache + (preparedExactDatatypeFactReference fact) diff --git a/source/Felix/Checking/Exact/Global.hs b/source/Felix/Checking/Exact/Global.hs new file mode 100644 index 0000000..d4040e6 --- /dev/null +++ b/source/Felix/Checking/Exact/Global.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact resolution of source symbols to checked semantic globals. +module Felix.Checking.Exact.Global + ( ExactGlobalResolutionError(..) + , resolveExactSourceGlobals + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (foldM) +import Control.Monad.Except + ( liftEither + , runExceptT + , throwError + ) +import Control.Monad.Trans.Class (lift) +import Data.Bifunctor (first) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set + + +data ExactGlobalResolutionError + = ExactGlobalNotVisible !Internal.Symbol + | ExactGlobalAmbiguous !Internal.Symbol + | ExactGlobalUnsupported !Internal.Symbol + | ExactGlobalContextualUnsupported !Internal.Symbol + | ExactGlobalContentInvalid !CoreCheckError + deriving stock (Show, Eq) + +resolveExactSourceGlobals + :: Set.Set Internal.Symbol + -> Declaration.LoweringDriver + (Either + ExactGlobalResolutionError + ( Map.Map + Internal.Symbol + (Typed.SourceGlobal ObjectId) + , Map.Map ObjectId CoreType + )) +resolveExactSourceGlobals symbols = + runExceptT + (foldM resolve (Map.empty, Map.empty) + (Set.toAscList symbols)) + where + resolve (resolved, types) symbol = + case classifyExactSymbol symbol of + ExactClosedLiteral -> + pure (resolved, types) + ExactFixedPrimitive _meaning -> + pure (resolved, types) + ExactUnsupportedSymbol -> + throwError (ExactGlobalUnsupported symbol) + ExactSourceGlobal keys -> do + matches <- + catMaybes + <$> traverse + (lift + . Declaration.resolveVisibleGlobalContentLowering) + (toList keys) + case matches of + [] -> + throwError (ExactGlobalNotVisible symbol) + [match] -> do + (source, sourceTypes) <- + liftEither (prepareSourceGlobal symbol match) + pure + ( Map.insert symbol source resolved + , Map.union sourceTypes types + ) + _ -> + throwError (ExactGlobalAmbiguous symbol) + +prepareSourceGlobal + :: Internal.Symbol + -> ( SemanticGlobalTarget + , ObjectContent + , Map.Map ObjectId CoreType + ) + -> Either + ExactGlobalResolutionError + (Typed.SourceGlobal ObjectId, Map.Map ObjectId CoreType) +prepareSourceGlobal symbol (target, content, dependencies) = do + body <- + case target of + GlobalReference _identity -> + Right Nothing + TransparentExpansion _identity -> + case content of + TransparentObjectContent _theory _coreType canonical -> + Just + <$> first ExactGlobalContentInvalid + (checkCanonicalCore + (`Map.lookup` dependencies) + canonical) + _ -> + impossible + "validated transparent expansion has opaque content" + ContextualTransparentExpansion _identity _requirements -> + Left (ExactGlobalContextualUnsupported symbol) + let identity = semanticGlobalTargetObject target + types = + Map.insert + identity + (objectContentType content) + dependencies + pure (Typed.SourceGlobal identity body, types) diff --git a/source/Felix/Checking/Exact/Inductive.hs b/source/Felix/Checking/Exact/Inductive.hs new file mode 100644 index 0000000..5817b34 --- /dev/null +++ b/source/Felix/Checking/Exact/Inductive.hs @@ -0,0 +1,838 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact preparation and atomic publication of direct set inductives. +module Felix.Checking.Exact.Inductive + ( PreparedExactInductive + , preparedExactInductiveCarrierId + , preparedExactInductiveCarrierType + , preparedExactInductiveCarrierBody + , preparedExactInductiveGuardTargets + , preparedExactInductiveFacts + , prepareExactInductive + , CheckedExactInductiveAuthorization + , lowerPreparedExactInductive + , authorizeCheckedExactInductive + , ExactInductiveError(..) + , exactInductiveErrorLocation + , renderExactInductiveError + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Cache.Codec +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (unless, when) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector qualified as Vector + + +data PreparedExactInductive = PreparedExactInductive + !Location + !SemanticGlobalKey + !ObjectId + !(Maybe AssertedObject) + !SemanticName + !DeclarationSyntaxId + !(Typed.PreparedTypedInductive ObjectId) + ![SemanticFactOccurrenceFingerprint] + +data CheckedExactInductiveAuthorization = + CheckedExactInductiveAuthorization + !ObjectId + !(Typed.PreparedTypedInductive ObjectId) + ![SemanticFactOccurrenceFingerprint] + ![(Location, Declaration.PreparedVampireObligation Void ())] + +preparedExactInductiveCarrierId + :: PreparedExactInductive + -> ObjectId +preparedExactInductiveCarrierId + (PreparedExactInductive + _location _key identity _asserted _alias _syntax _typed _guards) = + identity + +preparedExactInductiveCarrierType + :: PreparedExactInductive + -> CoreType +preparedExactInductiveCarrierType + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveCarrierType typed + +preparedExactInductiveCarrierBody + :: PreparedExactInductive + -> FrozenCheckedCore ObjectId +preparedExactInductiveCarrierBody + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveCarrierBody typed + +preparedExactInductiveGuardTargets + :: PreparedExactInductive + -> Vector.Vector (FrozenCheckedCore ObjectId) +preparedExactInductiveGuardTargets + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveGuardTargets typed + +preparedExactInductiveFacts + :: PreparedExactInductive + -> NonEmpty (Typed.PreparedTypedInductiveFact ObjectId) +preparedExactInductiveFacts + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveFacts typed + +data ExactInductiveError + = ExactInductiveUnsupportedBlock !Location + | ExactInductiveOccurrenceMissing !Location + | ExactInductiveOccurrenceAmbiguous !Location + | ExactInductiveHeadMismatch !Location + | ExactInductiveGlossFailed !Location !Meaning.GlossError + | ExactInductiveDuplicateParameter !Location !Internal.VarSymbol + | ExactInductiveDomainFreeVariable !Location !Internal.VarSymbol + | ExactInductiveDomainMentionsCarrier !Location + | ExactInductiveResultShape !Location + | ExactInductiveResultMentionsCarrier !Location + | ExactInductiveRecursiveTermMentionsCarrier !Location + | ExactInductiveRecursiveCarrierWrongArguments !Location + | ExactInductiveRecursiveCarrierOutsideMembership !Location + | ExactInductiveUnsupportedRecursiveCarrierContext !Location + | ExactInductiveFixedSemanticCollision !Location !SemanticGlobalKey + | ExactInductiveGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactInductiveGlobalNotVisible !Location !Internal.Symbol + | ExactInductiveGlobalAmbiguous !Location !Internal.Symbol + | ExactInductiveUnsupportedSymbol !Location !Internal.Symbol + | ExactInductiveGlobalContentInvalid !Location !CoreCheckError + | ExactInductivePreparationFailed + !Location + !Typed.TypedInductiveError + | ExactInductiveGuardMissing !Location + | ExactInductiveGuardAmbiguous !Location + deriving stock (Show, Eq) + +exactInductiveErrorLocation :: ExactInductiveError -> Location +exactInductiveErrorLocation = \case + ExactInductiveUnsupportedBlock location -> location + ExactInductiveOccurrenceMissing location -> location + ExactInductiveOccurrenceAmbiguous location -> location + ExactInductiveHeadMismatch location -> location + ExactInductiveGlossFailed location _failure -> location + ExactInductiveDuplicateParameter location _parameter -> location + ExactInductiveDomainFreeVariable location _variable -> location + ExactInductiveDomainMentionsCarrier location -> location + ExactInductiveResultShape location -> location + ExactInductiveResultMentionsCarrier location -> location + ExactInductiveRecursiveTermMentionsCarrier location -> location + ExactInductiveRecursiveCarrierWrongArguments location -> location + ExactInductiveRecursiveCarrierOutsideMembership location -> location + ExactInductiveUnsupportedRecursiveCarrierContext location -> location + ExactInductiveFixedSemanticCollision location _key -> location + ExactInductiveGlobalAlreadyVisible location _key -> location + ExactInductiveGlobalNotVisible location _symbol -> location + ExactInductiveGlobalAmbiguous location _symbol -> location + ExactInductiveUnsupportedSymbol location _symbol -> location + ExactInductiveGlobalContentInvalid location _failure -> location + ExactInductivePreparationFailed location _failure -> location + ExactInductiveGuardMissing location -> location + ExactInductiveGuardAmbiguous location -> location + +renderExactInductiveError :: ExactInductiveError -> Text +renderExactInductiveError failure = + locationToText (exactInductiveErrorLocation failure) + <> ": " + <> case failure of + ExactInductiveUnsupportedBlock{} -> + "this inductive source form is not supported by the typed checker" + ExactInductiveOccurrenceMissing{} -> + "the inductive declaration has no associated syntax occurrence" + ExactInductiveOccurrenceAmbiguous{} -> + "the inductive declaration has more than one semantic head" + ExactInductiveHeadMismatch{} -> + "the inductive head does not match its syntax occurrence" + ExactInductiveGlossFailed _location glossFailure -> + "inductive elaboration failed: " <> shown glossFailure + ExactInductiveDuplicateParameter _location parameter -> + "the inductive parameter is repeated: " <> shown parameter + ExactInductiveDomainFreeVariable _location variable -> + "the inductive domain contains an unbound variable: " + <> shown variable + ExactInductiveDomainMentionsCarrier{} -> + "the inductive domain must be independent of its carrier" + ExactInductiveResultShape{} -> + "an inductive result must have the form t \\in F(args)" + ExactInductiveResultMentionsCarrier{} -> + "an inductive result term must not mention its carrier" + ExactInductiveRecursiveTermMentionsCarrier{} -> + "a recursive occurrence must be in the carrier of a membership premise" + ExactInductiveRecursiveCarrierWrongArguments{} -> + "the inductive carrier occurs with arguments other than its declared parameters" + ExactInductiveRecursiveCarrierOutsideMembership{} -> + "an inductive carrier occurrence must be in the set operand of a membership premise" + ExactInductiveUnsupportedRecursiveCarrierContext{} -> + "this recursive carrier context is outside the supported first-order set-term fragment" + ExactInductiveFixedSemanticCollision _location key -> + "the inductive carrier collides with fixed semantics for " + <> shown key + ExactInductiveGlobalAlreadyVisible _location key -> + "the inductive carrier is already visible: " <> shown key + ExactInductiveGlobalNotVisible _location symbol -> + "an inductive source symbol is not visible: " <> shown symbol + ExactInductiveGlobalAmbiguous _location symbol -> + "an inductive source symbol has more than one meaning: " + <> shown symbol + ExactInductiveUnsupportedSymbol _location symbol -> + "this inductive source symbol is not supported: " + <> shown symbol + ExactInductiveGlobalContentInvalid _location coreFailure -> + "an inductive global has invalid checked content: " + <> shown coreFailure + ExactInductivePreparationFailed _location typedFailure -> + "typed inductive preparation failed: " <> shown typedFailure + ExactInductiveGuardMissing{} -> + "an inductive domain guard has no visible authorized fact" + ExactInductiveGuardAmbiguous{} -> + "an inductive domain guard matches more than one visible fact" + where + shown :: Show value => value -> Text + shown = Text.pack . show + +type Prepare = + ExceptT + ExactInductiveError + (Declaration.LoweringDriver) + +prepareExactInductive + :: CheckedFoundation + -> Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactInductiveError PreparedExactInductive) +prepareExactInductive foundation block entries = + Except.runExceptT do + (location, marker, rawInductive) <- + case block of + Raw.BlockInductive blockLocation _title blockMarker inductive -> + pure (blockLocation, blockMarker, inductive) + _ -> + Except.throwError + (ExactInductiveUnsupportedBlock (locate block)) + key <- validateOccurrence location rawInductive entries + when + (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactInductiveFixedSemanticCollision location key)) + visible <- + Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when (isJust visible) + (Except.throwError + (ExactInductiveGlobalAlreadyVisible location key)) + internal <- + case Meaning.meaning [block] of + Right + [Internal.BlockInductive + _internalLocation _internalMarker inductive] -> + pure inductive + Left failure -> + Except.throwError + (ExactInductiveGlossFailed location failure) + Right _ -> + Except.throwError + (ExactInductiveUnsupportedBlock location) + direct <- + Except.liftEither + (normalizeDirectInductive internal) + (sourceGlobals, globalTypes) <- + resolveSourceGlobals location internal direct + typed <- + Except.liftEither + (first + (ExactInductivePreparationFailed location) + (Typed.prepareTypedInductive + (requireGlobalType globalTypes) + foundation + (`Map.lookup` sourceGlobals) + marker + direct)) + guards <- + traverse + (resolveGuard location) + (Vector.toList + (Typed.typedInductiveGuardTargets typed)) + theory <- Except.lift Declaration.currentTheoryLowering + let carrierType = Typed.typedInductiveCarrierType typed + carrierBody = Typed.typedInductiveCarrierBody typed + carrierTerm = frozenCoreTerm carrierBody + identity = + transparentObjectId theory carrierType carrierTerm + content = + TransparentObjectContent theory carrierType carrierTerm + alias = case marker of + Raw.Marker name -> semanticName name + available <- + Except.lift + (Declaration.objectAvailableLowering identity) + let asserted + | available = Nothing + | otherwise = Just (assertedObject identity content) + syntax = + declarationSyntaxId + (encodePreparedInductive key alias typed) + pure + (PreparedExactInductive + location + key + identity + asserted + alias + syntax + typed + guards) + where + requireGlobalType types identity = + fromMaybe + (impossible + "prepared inductive global has no checked type") + (Map.lookup identity types) + +validateOccurrence + :: Location + -> Raw.Inductive + -> [CanonicalLexicalEntry] + -> Prepare SemanticGlobalKey +validateOccurrence location rawInductive entries = do + entry <- + case entries of + [] -> + Except.throwError + (ExactInductiveOccurrenceMissing location) + [single] -> pure single + _ -> + Except.throwError + (ExactInductiveOccurrenceAmbiguous location) + key <- + maybe + (Except.throwError + (ExactInductiveHeadMismatch location)) + pure + (semanticGlobalKeyFromLexicalEntry entry) + let Raw.SymbolPattern headSymbol _parameters = + Raw.inductiveSymbolPattern rawInductive + expected = + SemanticExpressionFunction + (Raw.mixfixPattern headSymbol) + unless (key == expected) + (Except.throwError + (ExactInductiveHeadMismatch location)) + pure key + +normalizeDirectInductive + :: Internal.Inductive + -> Either ExactInductiveError Typed.DirectInductive +normalizeDirectInductive inductive = do + case firstDuplicate (Internal.inductiveParams inductive) of + Just duplicate -> + Left + (ExactInductiveDuplicateParameter + (locate duplicate) + duplicate) + Nothing -> pure () + let parameters = Internal.inductiveParams inductive + parameterSet = Set.fromList parameters + domain = Internal.inductiveDomain inductive + carrier = Internal.inductiveSymbol inductive + domainVariables = + orderedUnique + (toList domain) + case find (`Set.notMember` parameterSet) domainVariables of + Just variable -> + Left + (ExactInductiveDomainFreeVariable + (locate variable) + variable) + Nothing -> pure () + when + (Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols domain) + (Left + (ExactInductiveDomainMentionsCarrier + (termLocation domain))) + clauses <- + traverse + (normalizeClause carrier parameters) + (Internal.inductiveIntros inductive) + pure + (Typed.DirectInductive + parameters + domain + clauses) + +normalizeClause + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.IntroRule + -> Either ExactInductiveError Typed.DirectInductiveClause +normalizeClause carrier parameters rule = do + conditions <- + traverse + (normalizeCondition carrier parameters) + (Internal.introConditions rule) + result <- + normalizeResult + carrier + parameters + (Internal.introResult rule) + let parameterSet = Set.fromList parameters + variables = + List.filter (`Set.notMember` parameterSet) + (orderedUnique + ( concatMap toList + (Internal.introConditions rule) + <> toList result + )) + pure + (Typed.DirectInductiveClause + variables + conditions + result) + +normalizeResult + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Formula + -> Either ExactInductiveError Internal.Term +normalizeResult carrier parameters = \case + Internal.IsElementOf _location result target + | not (matchesCarrier carrier parameters target) -> + Left (ExactInductiveResultShape (termLocation target)) + | Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols result -> + Left + (ExactInductiveResultMentionsCarrier + (termLocation result)) + | otherwise -> + Right result + formula -> + Left (ExactInductiveResultShape (termLocation formula)) + +normalizeCondition + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Formula + -> Either ExactInductiveError Typed.DirectInductiveCondition +normalizeCondition carrier parameters formula + | not + (Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols formula) = + Right (Typed.DirectSideCondition formula) + | otherwise = + case formula of + Internal.IsElementOf _location recursiveTerm recursiveCarrier + | Internal.SymbolMixfix carrier + `Set.member` + Internal.mentionedSymbols recursiveTerm -> + Left + (ExactInductiveRecursiveTermMentionsCarrier + (termLocation recursiveTerm)) + | otherwise -> do + context <- + first recursiveCarrierContextError + (Typed.prepareRecursiveCarrierContext + carrier parameters recursiveCarrier) + Right + (Typed.DirectRecursiveCondition + recursiveTerm context) + _ -> + Left + (ExactInductiveRecursiveCarrierOutsideMembership + (termLocation formula)) + +recursiveCarrierContextError + :: Typed.RecursiveCarrierContextError + -> ExactInductiveError +recursiveCarrierContextError = \case + Typed.RecursiveCarrierWrongArguments location -> + ExactInductiveRecursiveCarrierWrongArguments location + Typed.RecursiveCarrierUnsupportedContext location -> + ExactInductiveUnsupportedRecursiveCarrierContext location + +matchesCarrier + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Term + -> Bool +matchesCarrier carrier parameters = \case + Internal.TermSymbol _location (Internal.SymbolMixfix actual) arguments -> + actual == carrier + && length arguments == length parameters + && and + (zipWith + (\argument parameter -> + argument == Internal.TermVar parameter) + arguments + parameters) + _ -> False + +resolveSourceGlobals + :: Location + -> Internal.Inductive + -> Typed.DirectInductive + -> Prepare + ( Map.Map + Internal.Symbol + (Typed.SourceGlobal ObjectId) + , Map.Map ObjectId CoreType + ) +resolveSourceGlobals location internal direct = + Except.lift + (ExactGlobal.resolveExactSourceGlobals symbols) + >>= Except.liftEither + . first (exactGlobalError location) + where + carrier = Internal.SymbolMixfix (Internal.inductiveSymbol internal) + symbols = + Set.delete carrier (directSymbols direct) + +exactGlobalError + :: Location + -> ExactGlobal.ExactGlobalResolutionError + -> ExactInductiveError +exactGlobalError location = \case + ExactGlobal.ExactGlobalNotVisible symbol -> + ExactInductiveGlobalNotVisible location symbol + ExactGlobal.ExactGlobalAmbiguous symbol -> + ExactInductiveGlobalAmbiguous location symbol + ExactGlobal.ExactGlobalUnsupported symbol -> + ExactInductiveUnsupportedSymbol location symbol + ExactGlobal.ExactGlobalContextualUnsupported symbol -> + ExactInductiveUnsupportedSymbol location symbol + ExactGlobal.ExactGlobalContentInvalid failure -> + ExactInductiveGlobalContentInvalid location failure + +resolveGuard + :: Location + -> FrozenCheckedCore ObjectId + -> Prepare SemanticFactOccurrenceFingerprint +resolveGuard location target = do + matches <- + Except.lift + (Declaration.resolveVisibleFactTargetsLowering target) + case matches of + [] -> + Except.throwError (ExactInductiveGuardMissing location) + [fingerprint] -> + pure fingerprint + _ -> + Except.throwError (ExactInductiveGuardAmbiguous location) + +directSymbols :: Typed.DirectInductive -> Set.Set Internal.Symbol +directSymbols direct = + Internal.mentionedSymbols (Typed.directInductiveDomain direct) + <> foldMap clauseSymbols + (Typed.directInductiveClauses direct) + where + clauseSymbols clause = + foldMap conditionSymbols + (Typed.directClauseConditions clause) + <> Internal.mentionedSymbols + (Typed.directClauseResult clause) + conditionSymbols = \case + Typed.DirectSideCondition formula -> + Internal.mentionedSymbols formula + Typed.DirectRecursiveCondition term context -> + Internal.mentionedSymbols term + <> Typed.recursiveCarrierContextSymbols context + +lowerPreparedExactInductive + :: PreparedExactInductive + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactInductiveAuthorization)) +lowerPreparedExactInductive + (PreparedExactInductive + _location key identity asserted alias syntax typed guards) = + do + let facts = Typed.typedInductiveFacts typed + monotonicities = + Vector.toList + (Typed.typedInductiveMonotonicities typed) + objects = maybeToList asserted + definition <- + Declaration.prepareDefinitionEquationSpecLowering + objects identity alias + preparedMonotonicities <- + traverse + (\monotonicity -> Except.runExceptT do + let factLocation = + Typed.typedInductiveMonotonicityLocation + monotonicity + target = + Typed.typedInductiveMonotonicityTarget + monotonicity + spec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects target SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + (embedClosedCore [] target) + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt + factLocation + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + pure + ( Declaration.checkedCandidate + spec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + []) + , (factLocation, obligation) + )) + monotonicities + preparedCandidates <- + traverse + (\fact -> do + prepared <- + Declaration.prepareCandidateSpecLowering + objects + (embedClosedCore [] + (Typed.typedInductiveFactTarget fact)) + SearchEligible + [markerAlias + (Typed.typedInductiveFactMarker fact)] + let descriptor = + GuardedFoundationRules + (guardedRuleSet + (Typed.typedInductiveFactRules fact)) + planning + | null monotonicities = + Declaration.checkedKernelPlanning + descriptor guards + | otherwise = + Declaration.checkedKernelPlanningWithStaged + descriptor + guards + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then + [ Declaration.plannedEarlierCandidate + 1 index + | (index, _target) <- + zip [0 ..] monotonicities + ] + else []) + pure + (fmap + (\spec -> + Declaration.checkedCandidate spec planning) + prepared)) + facts + pure do + definitionSpec <- definition + monotonicityCandidates <- sequence preparedMonotonicities + factCandidates <- sequence preparedCandidates + let stages + | null monotonicityCandidates = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| toList factCandidates + ] + | otherwise = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| [] + , NonEmpty.fromList (fst <$> monotonicityCandidates) + , factCandidates + ] + pure + (Declaration.checkedCompiledDeclaration + syntax + objects + [] + [semanticGlobalBinding key (GlobalReference identity)] + [] + stages + (CheckedExactInductiveAuthorization + identity typed guards + (snd <$> monotonicityCandidates))) + where + markerAlias (Raw.Marker name) = + semanticName name + +authorizeCheckedExactInductive + :: CheckedExactInductiveAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactInductive + (CheckedExactInductiveAuthorization + identity typed guards monotonicityObligations) = \case + [definitionCandidate :| candidates] -> do + unless (null monotonicityObligations) + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch 3 1)) + Declaration.authorizeDefinitionEquationCandidate + identity definitionCandidate + let facts = Typed.typedInductiveFacts typed + case NonEmpty.nonEmpty candidates of + Just factCandidates + | NonEmpty.length factCandidates == NonEmpty.length facts -> + sequence_ + (NonEmpty.zipWith + (authorizeFact []) + factCandidates + facts) + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (1 + NonEmpty.length facts) + (1 + length candidates)) + [ definitionCandidate :| [] + , monotonicityCandidates + , factCandidates + ] + | NonEmpty.length monotonicityCandidates + == length monotonicityObligations + , NonEmpty.length factCandidates + == NonEmpty.length (Typed.typedInductiveFacts typed) -> do + obligations <- + maybe + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 0)) + pure + (NonEmpty.nonEmpty monotonicityObligations) + Declaration.authorizeDefinitionEquationCandidate + identity definitionCandidate + Declaration.authorizeVampireCandidateBatch + (NonEmpty.zipWith + (\candidate (factLocation, obligation) -> + (factLocation, candidate, pure obligation)) + monotonicityCandidates + obligations) + sequence_ + (NonEmpty.zipWith + (\candidate fact -> + authorizeFact + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then NonEmpty.toList monotonicityCandidates + else []) + candidate + fact) + factCandidates + (Typed.typedInductiveFacts typed)) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (if null monotonicityObligations then 1 else 3) + (length stages)) + where + authorizeFact monotonicityCandidates candidate fact = + Declaration.authorizeKernelConstructionCandidate + (GuardedFoundationRules + (guardedRuleSet + (Typed.typedInductiveFactRules fact))) + candidate do + traverse_ Declaration.useAuthorizedFact guards + traverse_ + Declaration.useStagedCandidate + monotonicityCandidates + pure (Typed.typedInductiveFactDerivation fact) + + +encodePreparedInductive + :: SemanticGlobalKey + -> SemanticName + -> Typed.PreparedTypedInductive ObjectId + -> ByteString +encodePreparedInductive key alias typed = + encodeCache do + putCacheTag 0x04 + putSemanticGlobalKeyCache key + putCoreTypeCache + (Typed.typedInductiveCarrierType typed) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (Typed.typedInductiveCarrierBody typed)) + putCacheList putFrozenTerm + (Vector.toList + (Typed.typedInductiveContextInventory typed)) + putCacheList + (putFrozenTerm + . Typed.typedInductiveMonotonicityTarget) + (Vector.toList + (Typed.typedInductiveMonotonicities typed)) + putCacheText (semanticNameText alias) + putCacheList putFact + (toList (Typed.typedInductiveFacts typed)) + where + putFrozenTerm = + putCanonicalTermCache putObjectIdCache . frozenCoreTerm + + putFact fact = do + let Raw.Marker marker = + Typed.typedInductiveFactMarker fact + putCacheText marker + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (Typed.typedInductiveFactTarget fact)) + putCacheList + (putCacheBytes . encodeKernelRuleTag) + (toList (Typed.typedInductiveFactRules fact)) + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _seen [] = Nothing + go seen (value : remaining) + | value `Set.member` seen = Just value + | otherwise = + go (Set.insert value seen) remaining + +orderedUnique :: Ord value => [value] -> [value] +orderedUnique = + reverse . snd . foldl' step (Set.empty, []) + where + step (seen, values) value + | value `Set.member` seen = (seen, values) + | otherwise = + (Set.insert value seen, value : values) + +termLocation :: Internal.Expr -> Location +termLocation = Internal.exprLocation diff --git a/source/Felix/Checking/Exact/Proof.hs b/source/Felix/Checking/Exact/Proof.hs new file mode 100644 index 0000000..e2149c4 --- /dev/null +++ b/source/Felix/Checking/Exact/Proof.hs @@ -0,0 +1,2639 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact lowering for the first ordinary theorem/proof fragment. +-- +-- This module is the trusted owner of structural local-proof composition. Its +-- private prepared tree controls when assumptions and proved local claims +-- become available and executes discharges depth-first. The declaration +-- boundary validates typed tasks and authority; it does not reconstruct this +-- derivation. +module Felix.Checking.Exact.Proof + ( PreparedExactProof + , preparedExactProofSyntaxId + , preparedExactProofFirstOmission + , prepareExactProof + , CheckedExactProofAuthorization + , lowerPreparedExactProof + , authorizeCheckedExactProof + , PreparedFinalPreludeFoundationClaim + , prepareFinalPreludeFoundationClaim + , CheckedFinalPreludeFoundationAuthorization + , lowerPreparedFinalPreludeFoundationClaim + , authorizeCheckedFinalPreludeFoundationClaim + , ExactProofError(..) + , exactProofErrorLocation + , renderExactProofError + ) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation (foundationFactDerivation) +import Felix.Checking.Kernel.Proof qualified as KernelProof +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Cache.Codec +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw + +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.ByteString (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +data ExactProofError + = ExactProofUnsupportedClaim !Location + | ExactProofUnsupportedStep !Location + | ExactProofSetInductionVariableRequired !Location + | ExactProofSetInductionVariableNotActive + !Location !Raw.VarSymbol + | ExactProofSetInductionFocusAmbiguous !Location + | ExactProofSetInductionActiveBinderIneligible + !Location !Raw.VarSymbol + | ExactProofSetInductionBinderConflict + !Location !Raw.VarSymbol + | ExactProofSetInductionGoalMismatch !Location + | ExactProofSetExtensionalityGoalMismatch !Location + | ExactProofSetExtensionalityDirectionsUnavailable !Location + | ExactProofExpectedUniversalGoal !Location + | ExactProofExpectedImplicationGoal !Location + | ExactProofGoalStatementMismatch !Location + | ExactProofEmptyCaseSplit !Location + | ExactProofStructuralCompositionFailed + !Location !KernelProof.KernelProofBuildError + | ExactProofLocalFunctionBinderMismatch !Location + | ExactProofLocalFunctionNameConflict !Location + | ExactProofUnknownReference !Location !Raw.Marker + | ExactProofElaborationFailed !Exact.ExactCompileError + | ExactProofObligationPreparationFailed + !Location + !(Declaration.VampireObligationPreparationError + Exact.ExactLocalId) + | ExactProofFoundationLeafRequiresImplicitAuto !Location + | ExactProofFoundationLeafTargetMismatch !Location + | ExactProofFoundationLeafTargetAmbiguous !Location + deriving stock (Show, Eq) + +exactProofErrorLocation :: ExactProofError -> Location +exactProofErrorLocation = \case + ExactProofUnsupportedClaim location -> location + ExactProofUnsupportedStep location -> location + ExactProofSetInductionVariableRequired location -> location + ExactProofSetInductionVariableNotActive location _variable -> + location + ExactProofSetInductionFocusAmbiguous location -> location + ExactProofSetInductionActiveBinderIneligible location _variable -> + location + ExactProofSetInductionBinderConflict location _variable -> + location + ExactProofSetInductionGoalMismatch location -> location + ExactProofSetExtensionalityGoalMismatch location -> location + ExactProofSetExtensionalityDirectionsUnavailable location -> location + ExactProofExpectedUniversalGoal location -> location + ExactProofExpectedImplicationGoal location -> location + ExactProofGoalStatementMismatch location -> location + ExactProofEmptyCaseSplit location -> location + ExactProofStructuralCompositionFailed location _failure -> location + ExactProofLocalFunctionBinderMismatch location -> location + ExactProofLocalFunctionNameConflict location -> location + ExactProofUnknownReference location _marker -> location + ExactProofElaborationFailed failure -> + Exact.exactCompileErrorLocation failure + ExactProofObligationPreparationFailed location _failure -> location + ExactProofFoundationLeafRequiresImplicitAuto location -> location + ExactProofFoundationLeafTargetMismatch location -> location + ExactProofFoundationLeafTargetAmbiguous location -> location + +renderExactProofError :: ExactProofError -> Text +renderExactProofError = \case + ExactProofUnsupportedClaim location -> + at location <> "this claim is not yet supported by the typed checker" + ExactProofUnsupportedStep location -> + at location <> "this proof step is not yet supported by the typed checker" + ExactProofSetInductionVariableRequired location -> + at location <> "exact set induction requires a named set variable" + ExactProofSetInductionVariableNotActive location variable -> + at location <> "the set-induction variable " <> shown variable + <> " is not an eligible exact focus" + ExactProofSetInductionFocusAmbiguous location -> + at location + <> "set induction without an explicit variable has no unique focus" + ExactProofSetInductionActiveBinderIneligible location variable -> + at location <> "the active binder " <> shown variable + <> " is not an eligible set-induction focus" + ExactProofSetInductionBinderConflict location variable -> + at location <> "the leading set-induction binder " <> shown variable + <> " conflicts with an active exact binder" + ExactProofSetInductionGoalMismatch location -> + at location <> "the set-induction variable does not belong to this goal" + ExactProofSetExtensionalityGoalMismatch location -> + at location <> "set extensionality requires a set-equality goal" + ExactProofSetExtensionalityDirectionsUnavailable location -> + at location + <> "set extensionality requires both directions as proved local claims" + ExactProofExpectedUniversalGoal location -> + at location <> "this fix step requires a universal goal" + ExactProofExpectedImplicationGoal location -> + at location <> "this assume step requires an implication goal" + ExactProofGoalStatementMismatch location -> + at location <> "the proof step does not match the current goal" + ExactProofEmptyCaseSplit location -> + at location <> "case analysis requires at least one case" + ExactProofStructuralCompositionFailed location failure -> + at location <> "invalid structural proof composition: " <> shown failure + ExactProofLocalFunctionBinderMismatch location -> + at location <> "the function argument must match its domain binder" + ExactProofLocalFunctionNameConflict location -> + at location <> "the function and argument names must be distinct" + ExactProofUnknownReference location marker -> + at location <> "the cited fact " <> shown marker <> " is not visible" + ExactProofElaborationFailed failure -> + Exact.renderExactCompileError failure + ExactProofObligationPreparationFailed location failure -> + at location <> "the exact proof obligation is invalid: " <> shown failure + ExactProofFoundationLeafRequiresImplicitAuto location -> + at location + <> "a confined foundation claim requires an implicit Auto proof" + ExactProofFoundationLeafTargetMismatch location -> + at location <> "the claim does not exactly match a foundation axiom" + ExactProofFoundationLeafTargetAmbiguous location -> + at location <> "the claim matches more than one foundation axiom" + where + at location = locationToText location <> ": " + shown :: Show value => value -> Text + shown = Text.pack . show + +data ExactLocalOrigin + = ExactAssumption + | ExactDerivedClaim + | ExactLocalDefinition + | ExactLocalConstructionExtensional + | ExactLocalConstructionEquation + deriving stock (Show, Eq, Ord) + +data PreparedLocal = PreparedLocal + !Backend.LocalPremiseOrdinal + !ExactLocalOrigin + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + +data PreparedJustification + = PreparedAuto + | PreparedReferences + !(NonEmpty SemanticFactOccurrenceFingerprint) + | PreparedLocalOnly + +data PreparedDischarge + = PreparedVampireDischarge + !Location + !PreparedJustification + !(ScopedCheckedCore ObjectId) + !(Declaration.PreparedVampireObligation + Exact.ExactLocalId + ExactLocalOrigin) + | PreparedSetExtensionality + !Location + !(ScopedCheckedCore ObjectId) + +data PreparedCalculationLink = PreparedCalculationLink + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +-- The private constructor stores every destination with the discharge derived +-- from its immediately preceding endpoint. Planning and admission can +-- therefore traverse one immutable sequence without re-associating shapes. +data PreparedCalculation = PreparedCheckedCalculation + !CoreType + ![Exact.ExactLocalId] + !(Maybe (ScopedCheckedCore ObjectId)) + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCalculationLink) + !(ScopedCheckedCore ObjectId) + +data PreparedSinceEvidence + = PreparedSinceExisting !PreparedLocal + | PreparedSinceDischarged !PreparedDischarge !PreparedLocal + +data PreparedCase = PreparedCase + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedCaseAnalysis = PreparedCaseAnalysis + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCase) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data InitialSetInductionFocus = InitialSetInductionFocus + !Raw.VarSymbol + !Exact.ExactLocalId + !Natural + +data InitialSetInductionView = InitialSetInductionView + ![InitialSetInductionFocus] + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(Maybe Raw.VarSymbol) + +data SetInductionBoundary + = InitialClaimInduction !InitialSetInductionView + -- A direct source-statement goal may retain only its leading binder name. + -- Recursive proof transformations deliberately discard this hint. + | SourceStatementInduction !(Maybe Raw.VarSymbol) + | RecursiveProofInduction + +data SelectedSetInductionFocus + = SelectedInitialSetInduction !InitialSetInductionFocus + | SelectedLeadingSetInduction !(Maybe Raw.VarSymbol) + +data PreparedSetInductionFocus + = PreparedInitialSetInductionFocus + !Exact.ExactLocalId + !Natural + | PreparedLeadingSetInductionFocus + !Exact.ExactLocalId + +data PreparedSetInduction = PreparedCheckedSetInduction + !PreparedSetInductionFocus + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedProof + = PreparedImplicitAuto !PreparedDischarge + | PreparedQed !PreparedDischarge + | PreparedOmitted + !Location + !(ScopedCheckedCore ObjectId) + | PreparedFix ![Exact.ExactLocalId] !PreparedProof + | PreparedAssume + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedTake + ![Exact.ExactLocalId] + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSetInduction !PreparedSetInduction + | PreparedHave + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSuffices + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedCalculate + !PreparedCalculation + !PreparedProof + | PreparedSince + !(ScopedCheckedCore ObjectId) + !PreparedSinceEvidence + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSubclaim + !(ScopedCheckedCore ObjectId) + !PreparedProof + !PreparedProof + | PreparedDefine + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineRelational + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineFunction + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedByCase !PreparedCaseAnalysis + | PreparedByContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data PreparedExactProof = PreparedExactProof + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !PreparedProof + !ProofSyntaxId + +data PreparedFinalPreludeFoundationClaim = + PreparedFinalPreludeFoundationClaim + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !FoundationAxiomTag + !ProofSyntaxId + +preparedExactProofSyntaxId :: PreparedExactProof -> ProofSyntaxId +preparedExactProofSyntaxId + (PreparedExactProof _location _alias _target _proof syntax) = + syntax + +preparedExactProofFirstOmission :: PreparedExactProof -> Maybe Location +preparedExactProofFirstOmission + (PreparedExactProof _location _alias _target proof _syntax) = + preparedProofFirstOmission proof + +data PrepareState = PrepareState + { prepareNextLocal :: !Natural + , prepareNextPremise :: !Natural + } + +type Prepare = + StateT + PrepareState + (ExceptT ExactProofError (Declaration.LoweringDriver)) + +prepareExactProof + :: Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedExactProof) +prepareExactProof block explicitProof = + Except.runExceptT + (State.evalStateT prepare initialState) + where + initialState = PrepareState 0 0 + + prepare = + case block of + Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) -> do + envelope <- + liftDriver + (Exact.prepareExactClaimEnvelope assumptions statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let targetCore = Exact.preparedExactClaimTarget envelope + unless (null (scopedCoreContext targetCore)) + (throwProof + (ExactProofUnsupportedClaim location)) + (context, openedGoal, identities) <- + openEnvelopeVariables + targetCore + (Exact.preparedExactClaimVariables envelope) + (Exact.preparedExactClaimContext envelope) + (locals, bodyGoal, antecedents) <- + openEnvelopeAntecedents + context + openedGoal + (Exact.preparedExactClaimAntecedentCount envelope) + initialInduction <- + prepareInitialSetInductionView + statement + context + (Exact.preparedExactClaimVariables envelope) + identities + antecedents + bodyGoal + bodyProof <- + case explicitProof of + Nothing -> + PreparedImplicitAuto + <$> prepareDischarge + location + context + locals + bodyGoal + Raw.JustificationEmpty + Just sourceProof -> + prepareProof + location + context + locals + (InitialClaimInduction initialInduction) + bodyGoal + sourceProof + let withAssumptions = + foldr PreparedAssume bodyProof antecedents + proof = + case identities of + [] -> withAssumptions + _ -> PreparedFix identities withAssumptions + pure + (PreparedExactProof + location + (semanticName marker) + targetCore + proof + (proofSyntaxId + (encodePreparedProof proof))) + _ -> + throwProof + (ExactProofUnsupportedClaim (locate block)) + +prepareFinalPreludeFoundationClaim + :: CheckedFoundation + -> Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedFinalPreludeFoundationClaim) +prepareFinalPreludeFoundationClaim foundation block explicitProof = + Except.runExceptT do + case (block, explicitProof) of + ( Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) + , Nothing + ) -> do + envelope <- + Except.lift + (Exact.prepareExactClaimEnvelope + assumptions + statement) + >>= either + (Except.throwError + . ExactProofElaborationFailed) + pure + unless + ( null (Exact.preparedExactClaimVariables envelope) + && Exact.preparedExactClaimAntecedentCount envelope + == 0 + ) + (Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto + location)) + let target = Exact.preparedExactClaimTarget envelope + matches = + [ tag + | tag <- [minBound .. maxBound] + , target == foundationTarget tag + ] + tag <- case matches of + [] -> + Except.throwError + (ExactProofFoundationLeafTargetMismatch location) + [only] -> + pure only + _ -> + Except.throwError + (ExactProofFoundationLeafTargetAmbiguous location) + pure + (PreparedFinalPreludeFoundationClaim + location + (semanticName marker) + target + tag + (implicitAutoProofSyntaxId target)) + (Raw.BlockClaim _kind location _title _marker _claim, Just{}) -> + Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto location) + _ -> + Except.throwError + (ExactProofUnsupportedClaim (locate block)) + where + foundationTarget tag = + embedClosedCore [] + (mapFrozenGlobals + absurd + (foundationAxiomFrozen foundation tag)) + +openEnvelopeVariables + :: ScopedCheckedCore ObjectId + -> [Raw.VarSymbol] + -> Exact.ExactBinderContext + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openEnvelopeVariables target variables preparedContext = + case NonEmpty.nonEmpty variables of + Nothing -> + pure (preparedContext, target, []) + Just nonempty -> do + (_unannotated, opened, identities) <- + openFixedVariables + Exact.emptyExactBinderContext + target + nonempty + let expected = + reverse + (fst <$> toList + (Exact.exactBinderContextSupport preparedContext)) + unless + (identities == expected) + (impossible + "prepared claim annotations do not match opened binders") + pure (preparedContext, opened, identities) + +openEnvelopeAntecedents + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Natural + -> Prepare + ( [PreparedLocal] + , ScopedCheckedCore ObjectId + , [ScopedCheckedCore ObjectId] + ) +openEnvelopeAntecedents context initialGoal initialCount = + go [] [] initialGoal initialCount + where + go locals antecedents goal 0 = + pure (locals, goal, antecedents) + go locals antecedents goal remaining = do + (antecedent, conclusion) <- + maybe + (impossible + "a prepared claim envelope has too few implications") + pure + (openScopedImplication goal) + local <- allocateLocal ExactAssumption context antecedent + go + (locals <> [local]) + (antecedents <> [antecedent]) + conclusion + (remaining - 1) + +prepareInitialSetInductionView + :: Raw.Stmt + -> Exact.ExactBinderContext + -> [Raw.VarSymbol] + -> [Exact.ExactLocalId] + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Prepare InitialSetInductionView +prepareInitialSetInductionView + statement context variables identities antecedents bodyGoal = do + unless (length variables == length identities) + (impossible + "opened claim binders lost their source identity association") + foci <- traverse checkedFocus (zip variables identities) + let property = foldr implyChecked bodyGoal antecedents + support = Exact.exactBinderContextSupport context + unless + ( scopedCoreContext property + == (snd <$> Vector.toList support) + ) + (impossible + "initial set-induction property changed its checked context") + pure + (InitialSetInductionView + foci support property antecedents bodyGoal + (claimLeadingUniversalName statement)) + where + checkedFocus (variable, identity) = do + index <- + maybe + (impossible + "an opened claim binder is absent from its exact context") + pure + (Exact.exactBinderContextIndex variable context) + case Exact.exactBinderContextSupport context + Vector.!? (fromIntegral index) of + Just (actualIdentity, TySet) + | actualIdentity == identity -> + pure + (InitialSetInductionFocus + variable identity index) + _ -> + impossible + "an initial set-induction focus changed identity or type" + + implyChecked antecedent conclusion = + fromMaybe + (impossible + "an exact claim antecedent changed context") + (implyScopedCore antecedent conclusion) + +claimLeadingUniversalName :: Raw.Stmt -> Maybe Raw.VarSymbol +claimLeadingUniversalName = \case + Raw.StmtFormula + (Raw.FormulaQuantified _location Raw.Universally + (variable :| _rest) _bound _formula) -> + Just variable + Raw.SymbolicForall _location (variable :| _rest) + _bound _suchThat _statement -> + Just variable + Raw.StmtQuantPhrase + _location + (Raw.QuantPhrase Raw.Universally + (Raw.NounPhrase _left _noun variables _right _suchThat)) + _statement -> + listToMaybe variables + Raw.StmtVerbPhrase + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _verb -> + variable + Raw.StmtNoun + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _nounPhrase -> + variable + _statement -> + Nothing + +prepareProof + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareProof fallback context locals inductionBoundary goal = \case + Raw.Omitted location -> + pure (PreparedOmitted location goal) + Raw.Qed maybeLocation justification -> + PreparedQed + <$> prepareDischarge + (fromMaybe fallback maybeLocation) + context + locals + goal + justification + Raw.FixSymbolic location variables bound continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + case bound of + Raw.Unbounded -> + PreparedFix identities + <$> prepareProof + fallback + context' + locals + RecursiveProofInduction + goal' + continuation + _ -> do + constraint <- + prepareSymbolicBoundConstraints + context' variables bound + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.FixSuchThat location variables statement continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + constraint <- + Exact.preparedExactPropositionCore + <$> prepareStatement context' statement + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.Assume location statement continuation -> do + supplied <- prepareStatement context statement + when (isNothing (openScopedImplication goal)) + (throwProof (ExactProofExpectedImplicationGoal location)) + (assumption, conclusion) <- + maybe + (throwProof (ExactProofGoalStatementMismatch location)) + pure + (openScopedAssumption + (Exact.preparedExactPropositionCore supplied) + goal) + local <- allocateLocal ExactAssumption context assumption + PreparedAssume assumption + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + Raw.TakeVar location variables bound statement justification continuation -> do + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.TakeNoun location nounPhrase justification continuation -> + prepareNounTake + fallback location context locals goal nounPhrase + justification continuation + Raw.BySetInduction location variable continuation -> + prepareSetInduction + fallback location context locals inductionBoundary goal + variable continuation + Raw.Have location Nothing + (Raw.SymbolicExists _existential variables bound statement) + justification continuation -> + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.Have location Nothing statement justification continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + discharge <- + prepareDischarge + location context locals claim justification + local <- allocateLocal ExactDerivedClaim context claim + PreparedHave claim discharge + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Have location (Just sinceStatement) + statement justification continuation -> do + sinceProposition <- + Exact.preparedExactPropositionCore + <$> prepareStatement context sinceStatement + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + (evidence, sinceLocals) <- + case find (localMatches sinceProposition) locals of + Just existing -> + pure (PreparedSinceExisting existing, locals) + Nothing -> do + discharge <- + prepareDischarge + location + context + locals + sinceProposition + Raw.JustificationLocal + local <- + allocateLocal + ExactDerivedClaim context sinceProposition + pure + ( PreparedSinceDischarged discharge local + , locals <> [local] + ) + claimDischarge <- + prepareDischarge + location context sinceLocals claim justification + claimLocal <- + allocateLocal ExactDerivedClaim context claim + PreparedSince + sinceProposition evidence claim claimDischarge + <$> prepareProof + fallback + context + (sinceLocals <> [claimLocal]) + RecursiveProofInduction + goal + continuation + Raw.Suffices location statement justification continuation -> do + reduction <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + implication <- + maybe + (impossible + "a checked suffices reduction changed lexical context") + pure + (implyScopedCore reduction goal) + discharge <- + prepareDischarge + location context locals implication justification + PreparedSuffices goal reduction implication discharge + <$> prepareProof + fallback + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + reduction + continuation + Raw.Calc location quantifier calculation continuation -> do + prepared <- + prepareCalculation + location context locals quantifier calculation + local <- + allocateLocal + ExactDerivedClaim + context + (preparedCalculationResult prepared) + PreparedCalculate prepared + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Subclaim location statement subproof continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + preparedSubproof <- + prepareProof + location + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + claim + subproof + local <- allocateLocal ExactDerivedClaim context claim + PreparedSubclaim claim preparedSubproof + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Define location variable expression continuation -> do + preparedBody <- + liftDriver + (Exact.prepareExactSetExpression context expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let body = Exact.preparedExactSetExpressionCore preparedBody + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + case Exact.preparedExactSetExpressionConstruction preparedBody of + Nothing -> do + separationCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + SeparationCharacteristic) + definition <- + maybe + (impossible + "an exact set expression did not form a local definition") + pure + (scopedSetDefinition separationCharacteristic body) + local <- + allocateLocal ExactLocalDefinition context' definition + PreparedDefine identity body (definition :| []) + <$> prepareProof + fallback context' (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedUnconditionalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + (extensional, equation) <- + maybe + (impossible + "a checked named construction has no definition views") + pure + (namedSetConstructionLocalViews + characteristics construction) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefine identity body (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedRelationalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + let functionality = + relationalSetConstructionFunctionality construction + discharge <- + prepareDischarge + location context locals functionality + Raw.JustificationEmpty + (extensional, equation) <- + maybe + (impossible + "a checked relational construction has no admitted definition views") + pure + (relationalSetConstructionLocalViews + characteristics construction functionality) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefineRelational + identity body discharge (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.DefineFunction + location function argument value bound domain continuation -> do + unless (argument == bound) + (throwProof + (ExactProofLocalFunctionBinderMismatch (locate bound))) + when (function == argument) + (throwProof + (ExactProofLocalFunctionNameConflict (locate function))) + argumentIdentity <- allocateLocalIdentity + argumentContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((argumentIdentity, argument) :| []) + context) + graph <- + liftDriver + (Exact.prepareExactLocalFunctionGraph + location context argumentContext domain value) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + functionIdentity <- allocateLocalIdentity + functionContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((functionIdentity, function) :| []) + context) + replacementCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + ReplacementCharacteristic) + definition <- + maybe + (impossible + "a checked replacement graph did not form a local definition") + pure + (scopedCharacteristicDefinition + replacementCharacteristic + (Exact.preparedExactLocalFunctionGraphCore graph) + ( Exact.preparedExactLocalFunctionGraphDomain graph + :| [Exact.preparedExactLocalFunctionGraphMap graph] + )) + local <- + allocateLocal ExactLocalDefinition functionContext definition + PreparedDefineFunction + functionIdentity + (Exact.preparedExactLocalFunctionGraphCore graph) + definition + <$> prepareProof + fallback + functionContext + (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.ByCase location sourceCases -> + prepareByCase + location context locals goal sourceCases + Raw.ByContradiction location continuation -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + negation <- + maybe + (structuralFailure + location + "proof by contradiction requires a proposition goal") + pure + (negateScopedCore goal) + local <- allocateLocal ExactAssumption context negation + prepared <- + prepareProof + location + context + (locals <> [local]) + RecursiveProofInduction + falsum + continuation + validateStructuralComposition + location [goal, negation, falsum] + (\foundation globalType -> + KernelProof.validateDoubleNegationComposition + foundation globalType goal negation falsum) + pure + (PreparedByContradiction + goal negation falsum prepared) + Raw.Contradiction location justification -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + discharge <- + prepareDischarge + location + context + locals + falsum + justification + validateStructuralComposition + location [goal, falsum] + (\foundation globalType -> + KernelProof.validateFalsumEliminationComposition + foundation globalType goal falsum) + pure (PreparedContradiction goal falsum discharge) + proof -> + throwProof + (ExactProofUnsupportedStep + (proofLocation fallback proof)) + where + localMatches proposition + (PreparedLocal _ordinal _origin _support local) = + local == proposition + +prepareSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Raw.Proof + -> Prepare PreparedProof +prepareSetInduction + fallback location context locals boundary goal sourceFocus + continuation = do + selected <- + selectSetInductionFocus + location context boundary goal sourceFocus + case selected of + SelectedInitialSetInduction + (InitialSetInductionFocus _variable identity index) -> do + (foci, expectedSupport, property, antecedents, childTarget) <- + case boundary of + InitialClaimInduction + (InitialSetInductionView + foundFoci support foundProperty + foundAntecedents foundTarget _leadingName) -> + pure + ( foundFoci + , support + , foundProperty + , foundAntecedents + , foundTarget + ) + RecursiveProofInduction -> + impossible + "an initial induction focus escaped its claim boundary" + SourceStatementInduction _leadingName -> + impossible + "an initial induction focus escaped its claim boundary" + unless + ( Exact.exactBinderContextSupport context == expectedSupport + && goal == childTarget + && any (sameInitialFocus identity index) foci + ) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + PreparedSetInduction + <$> prepareCheckedSetInduction + fallback location context locals + (PreparedInitialSetInductionFocus identity index) + index property antecedents childTarget continuation + SelectedLeadingSetInduction sourceName -> do + (binderType, property) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + identity <- allocateLocalIdentity + extendedContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (case sourceName of + Just variable -> + Exact.extendExactBinderContext + ((identity, variable) :| []) + context + Nothing -> + Exact.extendExactAnonymousBinderContext + identity context) + let expectedResult = weakenCheckedScopedCore TySet goal + prepared <- prepareCheckedSetInduction + fallback location extendedContext locals + (PreparedLeadingSetInductionFocus identity) + 0 property [] property continuation + unless + (preparedSetInductionResult prepared == expectedResult) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure (PreparedSetInduction prepared) + where + sameInitialFocus expectedIdentity expectedIndex + (InitialSetInductionFocus _variable identity index) = + identity == expectedIdentity && index == expectedIndex + +prepareCheckedSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> PreparedSetInductionFocus + -> Natural + -> ScopedCheckedCore ObjectId + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedSetInduction +prepareCheckedSetInduction + fallback location context locals focus selected property antecedents + childTarget continuation = do + (_predicate, hypothesis, _step, result) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (scopedSetInductionInstance selected property) + validateStructuralComposition + location + (property : hypothesis : result : childTarget : antecedents) + (\foundation globalType -> + KernelProof.validateSetInductionComposition + foundation globalType selected property antecedents + childTarget hypothesis result) + local <- allocateLocal ExactAssumption context hypothesis + child <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + childTarget + continuation + pure + (PreparedCheckedSetInduction + focus property antecedents childTarget hypothesis result child) + +preparedSetInductionResult + :: PreparedSetInduction + -> ScopedCheckedCore ObjectId +preparedSetInductionResult + (PreparedCheckedSetInduction + _focus _property _antecedents _target _hypothesis result _child) = + result + +selectSetInductionFocus + :: Location + -> Exact.ExactBinderContext + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Prepare SelectedSetInductionFocus +selectSetInductionFocus location context boundary goal sourceFocus = do + explicit <- traverse simpleVariable sourceFocus + let (initialFoci, retainedLeadingName) = + case boundary of + InitialClaimInduction + (InitialSetInductionView + foci _support _property _antecedents _target + leadingName) -> + (foci, leadingName) + SourceStatementInduction leadingName -> + ([], leadingName) + RecursiveProofInduction -> + ([], Nothing) + leadingAvailable = + case openScopedForall goal of + Just (TySet, _body) -> True + _ -> False + case explicit of + Just variable -> + case find (initialNamed variable) initialFoci of + Just focus -> + pure (SelectedInitialSetInduction focus) + Nothing + | leadingAvailable + , isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionBinderConflict + location variable) + | leadingAvailable -> + pure + (SelectedLeadingSetInduction + (Just variable)) + | isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionActiveBinderIneligible + location variable) + | otherwise -> + throwProof + (ExactProofSetInductionVariableNotActive + location variable) + Nothing -> + case + ( (SelectedInitialSetInduction <$> initialFoci) + <> [ SelectedLeadingSetInduction retainedLeadingName + | leadingAvailable + ] + ) of + [only] -> pure only + _ -> + throwProof + (ExactProofSetInductionFocusAmbiguous location) + where + simpleVariable = \case + Raw.TermExpr (Raw.ExprVar variable) -> + pure variable + _term -> + throwProof + (ExactProofSetInductionVariableRequired location) + + initialNamed variable + (InitialSetInductionFocus candidate _identity _index) = + candidate == variable + +prepareByCase + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Raw.Case] + -> Prepare PreparedProof +prepareByCase location context locals goal sourceCases = do + cases <- + maybe + (throwProof (ExactProofEmptyCaseSplit location)) + (traverse prepareCase) + (NonEmpty.nonEmpty sourceCases) + exhaustive <- + foldM disjoin + (preparedCaseAssumption (NonEmpty.head cases)) + (preparedCaseAssumption <$> NonEmpty.tail cases) + discharge <- + prepareDischarge + location context locals exhaustive Raw.JustificationEmpty + validateStructuralComposition + location + (goal : exhaustive : (preparedCaseAssumption <$> toList cases)) + (\foundation globalType -> + KernelProof.validateCaseAnalysisComposition + foundation + globalType + goal + (preparedCaseAssumption <$> cases) + exhaustive) + pure + (PreparedByCase + (PreparedCaseAnalysis goal cases exhaustive discharge)) + where + prepareCase (Raw.Case statement child) = do + assumption <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + local <- allocateLocal ExactAssumption context assumption + prepared <- + prepareProof + (locate statement) + context + (locals <> [local]) + RecursiveProofInduction + goal + child + pure (PreparedCase assumption prepared) + + disjoin left right = + maybe + (structuralFailure + location + "case assumptions changed type or lexical context") + pure + (disjoinScopedCore left right) + +preparedCaseAssumption + :: PreparedCase + -> ScopedCheckedCore ObjectId +preparedCaseAssumption (PreparedCase assumption _proof) = + assumption + +preparedCaseProof :: PreparedCase -> PreparedProof +preparedCaseProof (PreparedCase _assumption proof) = + proof + +prepareGuardedFix + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareGuardedFix + fallback location context locals goal identities constraint continuation = do + (antecedent, conclusion) <- + maybe + (throwProof (ExactProofExpectedImplicationGoal location)) + pure + (openScopedImplication goal) + unless (constraint == antecedent) + (throwProof (ExactProofGoalStatementMismatch location)) + local <- allocateLocal ExactAssumption context constraint + prepared <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + pure (PreparedFix identities (PreparedAssume constraint prepared)) + +prepareCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> Maybe Raw.CalcQuantifier + -> Raw.Calc + -> Prepare PreparedCalculation +prepareCalculation location context locals quantifier calculation = do + (identities, calculationContext, calculationGuard) <- + prepareCalculationScope context quantifier + case calculation of + Raw.Equation first destinations -> do + firstChecked <- prepareSetEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + prepareSetEndpoint calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TySet identities calculationGuard + firstChecked checkedDestinations + Raw.Biconditionals first destinations -> do + firstChecked <- preparePropositionEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + preparePropositionEndpoint + calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TyProp identities calculationGuard + firstChecked checkedDestinations + where + prepareSetEndpoint endpointContext expression = + Exact.preparedExactSetExpressionCore + <$> ( liftDriver + (Exact.prepareExactSetExpression + endpointContext expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + + preparePropositionEndpoint endpointContext formula = + Exact.preparedExactPropositionCore + <$> prepareStatement endpointContext (Raw.StmtFormula formula) + +prepareCalculationScope + :: Exact.ExactBinderContext + -> Maybe Raw.CalcQuantifier + -> Prepare + ( [Exact.ExactLocalId] + , Exact.ExactBinderContext + , Maybe (ScopedCheckedCore ObjectId) + ) +prepareCalculationScope context = \case + Nothing -> + pure ([], context, Nothing) + Just (Raw.CalcQuantifier variables bound suchThat) -> do + identities <- traverse (const allocateLocalIdentity) variables + calculationContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + boundGuard <- + prepareSymbolicBoundConstraints + calculationContext variables bound + suchThatGuard <- + traverse + (fmap Exact.preparedExactPropositionCore + . prepareStatement calculationContext) + suchThat + calculationGuard <- + normalizeCalculationGuard + (boundGuard : maybeToList suchThatGuard) + pure (toList identities, calculationContext, calculationGuard) + +normalizeCalculationGuard + :: [ScopedCheckedCore ObjectId] + -> Prepare (Maybe (ScopedCheckedCore ObjectId)) +normalizeCalculationGuard guards = + foldM add Nothing guards + where + add accumulated constraint + | isScopedTruth constraint = pure accumulated + | otherwise = + case accumulated of + Nothing -> pure (Just constraint) + Just previous -> + Just + <$> maybe + (impossible + "checked calculation guards changed context") + pure + (conjoinScopedCore previous constraint) + + isScopedTruth proposition = + scopedCoreType proposition == TyProp + && scopedCoreTerm proposition == CImp CFalsum CFalsum + +finishCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> CoreType + -> [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> NonEmpty + ( Location + , ScopedCheckedCore ObjectId + , Raw.Justification + ) + -> Prepare PreparedCalculation +finishCalculation + fallback context locals operandType identities calculationGuard + first destinations = do + links <- prepareCalculationLinks first destinations + let finalEndpoint = preparedCalculationLinkDestination (NonEmpty.last links) + resultOpen <- + calculationEquality first finalEndpoint + result <- + closeCalculationProposition identities calculationGuard resultOpen + pure + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) + where + prepareCalculationLinks previous (destination :| rest) = do + (next, firstLink) <- prepareCalculationLink previous destination + later <- prepareRemainingCalculationLinks next rest + pure (firstLink :| later) + + prepareRemainingCalculationLinks _previous [] = + pure [] + prepareRemainingCalculationLinks previous (destination : rest) = do + (next, link) <- prepareCalculationLink previous destination + (link :) <$> prepareRemainingCalculationLinks next rest + + prepareCalculationLink previous + (destinationLocation, destination, justification) = do + linkOpen <- calculationEquality previous destination + link <- closeCalculationProposition + identities calculationGuard linkOpen + discharge <- + prepareDischarge + (if destinationLocation == Nowhere + then fallback + else destinationLocation) + context + locals + link + justification + pure + ( destination + , PreparedCalculationLink destination discharge + ) + + calculationEquality left right = + maybe + (impossible + "checked calculation endpoints changed type or context") + pure + (equalScopedCore left right) + +closeCalculationProposition + :: [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> Prepare (ScopedCheckedCore ObjectId) +closeCalculationProposition identities calculationGuard proposition = do + guarded <- + case calculationGuard of + Nothing -> pure proposition + Just constraint -> + maybe + (impossible + "a checked calculation guard changed context") + pure + (implyScopedCore constraint proposition) + pure (closeBinders (length identities) guarded) + where + closeBinders 0 closed = closed + closeBinders remaining open = + closeBinders (remaining - 1) + (fromMaybe + (impossible + "a checked calculation lost a quantified binder") + (closeScopedForall open)) + +preparedCalculationResult + :: PreparedCalculation + -> ScopedCheckedCore ObjectId +preparedCalculationResult + (PreparedCheckedCalculation + _operandType _identities _guard _first _links result) = + result + +preparedCalculationLinkDestination + :: PreparedCalculationLink + -> ScopedCheckedCore ObjectId +preparedCalculationLinkDestination + (PreparedCalculationLink destination _discharge) = + destination + +preparedCalculationLinkDischarge + :: PreparedCalculationLink + -> PreparedDischarge +preparedCalculationLinkDischarge + (PreparedCalculationLink _destination discharge) = + discharge + +preparedDischargeGoal + :: PreparedDischarge + -> ScopedCheckedCore ObjectId +preparedDischargeGoal = \case + PreparedVampireDischarge _location _justification goal _obligation -> + goal + PreparedSetExtensionality _location goal -> + goal + +prepareSymbolicBoundConstraints + :: Exact.ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Prepare (ScopedCheckedCore ObjectId) +prepareSymbolicBoundConstraints context variables bound = + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicBoundConstraints + context variables bound) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + +prepareSymbolicTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation = do + identities <- traverse (const allocateLocalIdentity) variables + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicWitnessConstraints + context' variables bound statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + (toList identities) witness justification continuation + +prepareNounTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.NounPhrase [] + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareNounTake + fallback location context locals goal nounPhrase + justification continuation = do + (identities, context') <- + case nounPhrase of + Raw.NounPhrase _left _noun variables _right _suchThat -> + case NonEmpty.nonEmpty variables of + Just binders -> do + identities <- + traverse (const allocateLocalIdentity) binders + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities binders) + context) + pure (toList identities, context') + Nothing -> do + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactAnonymousBinderContext + identity context) + pure ([identity], context') + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactNounWitnessConstraints + context' nounPhrase) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + identities witness justification continuation + +prepareTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Exact.ExactBinderContext + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareTake + fallback location context locals goal witnessContext + identities witness justification continuation = do + let witnessCount = length identities + existence = closeTakenWitnesses witnessCount witness + goal' = weakenForTakenWitnesses witnessCount goal + discharge <- + prepareDischarge + location context locals existence justification + local <- allocateLocal ExactAssumption witnessContext witness + PreparedTake identities witness discharge + <$> prepareProof + fallback + witnessContext + (locals <> [local]) + RecursiveProofInduction + goal' + continuation + +-- The discharged existential and the opened witness premise are the same +-- checked proposition viewed on opposite sides of existential elimination. +closeTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +closeTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (fromMaybe + (impossible "a taken witness has no checked binder") + (closeScopedExists proposition)) + +weakenForTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +weakenForTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (weakenCheckedScopedCore TySet proposition) + +openFixedVariables + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openFixedVariables initialContext initialGoal variables = + foldM openOne + (initialContext, initialGoal, []) + (toList variables) + where + openOne (context, goal, identities) variable = do + (binderType, body) <- + maybe + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + pure (context', body, identities <> [identity]) + +allocateLocalIdentity :: Prepare Exact.ExactLocalId +allocateLocalIdentity = do + state <- State.get + State.put + state + { prepareNextLocal = prepareNextLocal state + 1 + } + pure (Exact.exactLocalId (prepareNextLocal state)) + +allocateLocal + :: ExactLocalOrigin + -> Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Prepare PreparedLocal +allocateLocal origin context proposition = do + state <- State.get + State.put + state + { prepareNextPremise = prepareNextPremise state + 1 + } + pure + (PreparedLocal + (Backend.localPremiseOrdinal + (prepareNextPremise state)) + origin + (Exact.exactBinderContextSupport context) + proposition) + +prepareConstructionFoundation + :: Prepare SetConstructionFoundation +prepareConstructionFoundation = do + familyUnion <- foundation FamilyUnionCharacteristic + separation <- foundation SeparationCharacteristic + replacement <- foundation ReplacementCharacteristic + setChoose <- foundation SetChooseWitness + pure + (setConstructionFoundation + familyUnion separation replacement setChoose) + where + foundation tag = + liftDriver + (Declaration.currentFoundationAxiomLowering tag) + +prepareDischarge + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischarge location context locals goal justification = + prepareDischargeWith + (dischargeModeFor goal) + [] Nothing location context locals goal justification + +-- A contradictory-axioms answer can establish falsum, but never an unrelated +-- proposition directly. Derive that distinction from the checked target so +-- every surface proof spelling reaches the same guarded request path. +dischargeModeFor :: ScopedCheckedCore ObjectId -> DischargeMode +dischargeModeFor goal + | scopedCoreType goal == TyProp + , scopedCoreTerm goal == CFalsum = + IndirectContradictionDischarge + | otherwise = + DirectDischarge + +data DischargeMode + = DirectDischarge + | IndirectContradictionDischarge + +prepareDischargeWith + :: DischargeMode + -> [FoundationAxiomTag] + -> Maybe Declaration.VampirePremiseSelection + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischargeWith + dischargeMode auxiliaries selectionOverride + location context locals goal justification = + case justification of + Raw.JustificationSetExt -> do + (leftToRight, rightToLeft) <- + maybe + (throwProof + (ExactProofSetExtensionalityGoalMismatch location)) + pure + (splitScopedSetEquality goal) + unless + ( hasDerivedLocal leftToRight + && hasDerivedLocal rightToLeft + ) + (throwProof + (ExactProofSetExtensionalityDirectionsUnavailable + location)) + pure (PreparedSetExtensionality location goal) + _ -> do + preparedJustification <- + prepareJustification location justification + prepared <- + liftDriver + (prepareObligation + (Exact.exactBinderContextSupport context) + goal + (toScopedPremise <$> locals) + auxiliaries + (fromMaybe + (vampirePremiseSelection preparedJustification) + selectionOverride)) + >>= either + (throwProof + . ExactProofObligationPreparationFailed location) + pure + pure + (PreparedVampireDischarge + location + preparedJustification + goal + prepared) + where + prepareObligation = + case dischargeMode of + DirectDischarge -> + Declaration.prepareScopedVampireObligationLowering + IndirectContradictionDischarge -> + Declaration.prepareScopedContradictionObligationLowering + + hasDerivedLocal proposition = + any + (\case + PreparedLocal + _ordinal ExactDerivedClaim _support local -> + local == proposition + PreparedLocal{} -> + False) + locals + + toScopedPremise + (PreparedLocal ordinal origin support proposition) = + Declaration.scopedVampirePremise + ordinal origin support proposition + +prepareJustification + :: Location + -> Raw.Justification + -> Prepare PreparedJustification +prepareJustification _location Raw.JustificationEmpty = + pure PreparedAuto +prepareJustification location (Raw.JustificationRef markers) = do + resolved <- traverse (resolveReference location) (toList markers) + let unique = stableUnique resolved + case unique of + [] -> + impossible "a nonempty citation list resolved to no facts" + first : rest -> + pure (PreparedReferences (first :| rest)) +prepareJustification _location Raw.JustificationLocal = + pure PreparedLocalOnly +prepareJustification location Raw.JustificationSetExt = + throwProof (ExactProofUnsupportedStep location) + +vampirePremiseSelection + :: PreparedJustification + -> Declaration.VampirePremiseSelection +vampirePremiseSelection = \case + PreparedAuto -> + Declaration.VampireImplicitPremises + PreparedReferences fingerprints -> + Declaration.VampireExplicitPremises fingerprints + PreparedLocalOnly -> + Declaration.VampireLocalPremises + +resolveReference + :: Location + -> Raw.Marker + -> Prepare SemanticFactOccurrenceFingerprint +resolveReference location marker@(Raw.Marker name) = do + resolved <- + liftDriver + (Declaration.resolveVisibleFactAliasLowering + (semanticName name)) + maybe + (throwProof + (ExactProofUnknownReference location marker)) + pure + resolved + +prepareStatement + :: Exact.ExactBinderContext + -> Raw.Stmt + -> Prepare Exact.PreparedExactProposition +prepareStatement context statement = + liftDriver + (Exact.prepareExactProposition context statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + +validateStructuralComposition + :: Location + -> [ScopedCheckedCore ObjectId] + -> ( CheckedFoundation + -> (ObjectId -> Maybe CoreType) + -> Either KernelProof.KernelProofBuildError () + ) + -> Prepare () +validateStructuralComposition location propositions validate = do + foundation <- + liftDriver Declaration.currentFoundationLowering + let identities = + Set.toAscList + (Set.unions + ( canonicalTermGlobals . scopedCoreTerm + <$> propositions + )) + types <- + traverse + (\identity -> do + coreType <- + liftDriver + (Declaration.objectTypeLowering identity) + maybe + (impossible + "a checked structural proof lost a global object") + (\availableType -> pure (identity, availableType)) + coreType) + identities + either + (throwProof + . ExactProofStructuralCompositionFailed location) + pure + (validate foundation + (\identity -> Map.lookup identity (Map.fromList types))) + +structuralFailure :: Location -> Text -> Prepare value +structuralFailure location message = + throwProof + (ExactProofStructuralCompositionFailed + location + (KernelProof.ProofStructuralCompositionMismatch message)) + +data CheckedExactProofAuthorization = CheckedExactProofAuthorization + !PreparedProof + !Bool + +lowerPreparedExactProof + :: PreparedExactProof + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration CheckedExactProofAuthorization)) +lowerPreparedExactProof + (PreparedExactProof _location alias target proof syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [Declaration.checkedCandidate spec planning :| []] + (CheckedExactProofAuthorization + proof + (isJust (preparedProofFirstOmission proof))) + where + requests = plannedProofRequests proof + planning + | isJust (preparedProofFirstOmission proof) = + Declaration.checkedOmittedPlanning requests [] + | otherwise = + Declaration.checkedSourceProofPlanning requests [] + +authorizeCheckedExactProof + :: CheckedExactProofAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactProof + (CheckedExactProofAuthorization proof hasOmission) = \case + [candidate :| []] + | hasOmission -> + Declaration.authorizeOmittedCandidate + candidate + (executePreparedProof proof) + | otherwise -> + Declaration.authorizeVampireCandidate + candidate + (executePreparedProof proof) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +data CheckedFinalPreludeFoundationAuthorization = + CheckedFinalPreludeFoundationAuthorization !FoundationAxiomTag + +lowerPreparedFinalPreludeFoundationClaim + :: PreparedFinalPreludeFoundationClaim + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedFinalPreludeFoundationAuthorization)) +lowerPreparedFinalPreludeFoundationClaim + (PreparedFinalPreludeFoundationClaim + _location alias target tag syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [ Declaration.checkedCandidate spec + (Declaration.checkedKernelPlanning + (Authority.FoundationLeaf tag) []) + :| [] + ] + (CheckedFinalPreludeFoundationAuthorization tag) + +authorizeCheckedFinalPreludeFoundationClaim + :: CheckedFinalPreludeFoundationAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedFinalPreludeFoundationClaim + (CheckedFinalPreludeFoundationAuthorization tag) = \case + [candidate :| []] -> + Declaration.authorizeKernelConstructionCandidate + (Authority.FoundationLeaf tag) + candidate + (pure (foundationFactDerivation tag)) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +preparedProofFirstOmission :: PreparedProof -> Maybe Location +preparedProofFirstOmission = \case + PreparedImplicitAuto{} -> Nothing + PreparedQed{} -> Nothing + PreparedOmitted location _goal -> Just location + PreparedFix _identities continuation -> + preparedProofFirstOmission continuation + PreparedAssume _antecedent continuation -> + preparedProofFirstOmission continuation + PreparedTake _identities _witness _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + preparedProofFirstOmission child + PreparedHave _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSuffices _goal _reduction _implication _discharge continuation -> + preparedProofFirstOmission continuation + PreparedCalculate _calculation continuation -> + preparedProofFirstOmission continuation + PreparedSince _since _evidence _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSubclaim _claim subproof continuation -> + preparedProofFirstOmission subproof + <|> preparedProofFirstOmission continuation + PreparedDefine _identity _body _definition continuation -> + preparedProofFirstOmission continuation + PreparedDefineRelational + _identity _body _functionality _definitions continuation -> + preparedProofFirstOmission continuation + PreparedDefineFunction _identity _graph _definition continuation -> + preparedProofFirstOmission continuation + PreparedByCase (PreparedCaseAnalysis _goal cases _exhaustive _discharge) -> + foldr + ((<|>) . preparedProofFirstOmission . preparedCaseProof) + Nothing + cases + PreparedByContradiction _goal _negation _falsum child -> + preparedProofFirstOmission child + PreparedContradiction{} -> Nothing + +plannedProofRequests + :: PreparedProof + -> [Declaration.CheckedPlannedVampireRequest] +plannedProofRequests = \case + PreparedImplicitAuto discharge -> plannedDischargeRequests discharge + PreparedQed discharge -> plannedDischargeRequests discharge + PreparedOmitted{} -> [] + PreparedFix _identities continuation -> + plannedProofRequests continuation + PreparedAssume _antecedent continuation -> + plannedProofRequests continuation + PreparedTake _identities _witness discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + plannedProofRequests child + PreparedHave _claim discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSuffices _goal _reduction _implication discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedCalculate calculation continuation -> + plannedCalculationRequests calculation + <> plannedProofRequests continuation + PreparedSince _since evidence _claim discharge continuation -> + plannedSinceEvidenceRequests evidence + <> plannedDischargeRequests discharge + <> plannedProofRequests continuation + PreparedSubclaim _claim subproof continuation -> + plannedProofRequests subproof <> plannedProofRequests continuation + PreparedDefine _identity _body _definition continuation -> + plannedProofRequests continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> + plannedDischargeRequests functionality + <> plannedProofRequests continuation + PreparedDefineFunction _identity _graph _definition continuation -> + plannedProofRequests continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> + concatMap + (plannedProofRequests . preparedCaseProof) + (toList cases) + <> plannedDischargeRequests discharge + PreparedByContradiction _goal _negation _falsum child -> + plannedProofRequests child + PreparedContradiction _goal _falsum discharge -> + plannedDischargeRequests discharge + +plannedDischargeRequests + :: PreparedDischarge + -> [Declaration.CheckedPlannedVampireRequest] +plannedDischargeRequests = \case + PreparedVampireDischarge location _justification _goal obligation -> + [Declaration.checkedPlannedVampireRequest location obligation] + PreparedSetExtensionality{} -> [] + +plannedCalculationRequests + :: PreparedCalculation + -> [Declaration.CheckedPlannedVampireRequest] +plannedCalculationRequests + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + concatMap + (plannedDischargeRequests . preparedCalculationLinkDischarge) + (toList links) + +plannedSinceEvidenceRequests + :: PreparedSinceEvidence + -> [Declaration.CheckedPlannedVampireRequest] +plannedSinceEvidenceRequests = \case + PreparedSinceExisting{} -> [] + PreparedSinceDischarged discharge _local -> + plannedDischargeRequests discharge + +executePreparedProof + :: PreparedProof + -> Declaration.CandidateProof () +executePreparedProof = \case + PreparedImplicitAuto discharge -> + executeDischarge discharge + PreparedQed discharge -> + executeDischarge discharge + PreparedOmitted _location _goal -> + Declaration.recordOmittedUse + PreparedFix _identities continuation -> + executePreparedProof continuation + PreparedAssume _antecedent continuation -> + executePreparedProof continuation + PreparedTake _identities _witness discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + executePreparedProof child + PreparedHave _claim discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + unless + (implyScopedCore reduction goal == Just implication) + (impossible "a prepared suffices implication diverged") + PreparedCalculate calculation continuation -> do + executePreparedCalculation calculation + executePreparedProof continuation + PreparedSince sinceProposition evidence _claim discharge continuation -> do + executeSinceEvidence sinceProposition evidence + executeDischarge discharge + executePreparedProof continuation + PreparedSubclaim _claim subproof continuation -> do + executePreparedProof subproof + executePreparedProof continuation + PreparedDefine _identity _body _definition continuation -> + executePreparedProof continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> do + executeDischarge functionality + executePreparedProof continuation + PreparedDefineFunction _identity _graph _definition continuation -> + executePreparedProof continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> do + traverse_ (executePreparedProof . preparedCaseProof) cases + executeDischarge discharge + PreparedByContradiction _goal _negation _falsum child -> + executePreparedProof child + PreparedContradiction _goal _falsum discharge -> + executeDischarge discharge + +executeDischarge + :: PreparedDischarge + -> Declaration.CandidateProof () +executeDischarge + (PreparedVampireDischarge + location _justification _goal obligation) = + Declaration.locateProofObligation location + (Declaration.acceptPreparedVampireObligation obligation) +executeDischarge PreparedSetExtensionality{} = + pure () + +executePreparedCalculation + :: PreparedCalculation + -> Declaration.CandidateProof () +executePreparedCalculation + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + traverse_ + (executeDischarge . preparedCalculationLinkDischarge) + links + +executeSinceEvidence + :: ScopedCheckedCore ObjectId + -> PreparedSinceEvidence + -> Declaration.CandidateProof () +executeSinceEvidence proposition = \case + PreparedSinceExisting local -> + unless (preparedLocalProposition local == proposition) + (impossible "a structural since premise diverged") + PreparedSinceDischarged discharge local -> do + executeDischarge discharge + unless + ( preparedDischargeGoal discharge == proposition + && preparedLocalProposition local == proposition + ) + (impossible "a discharged since premise diverged") + +preparedLocalProposition + :: PreparedLocal + -> ScopedCheckedCore ObjectId +preparedLocalProposition + (PreparedLocal _ordinal _origin _support proposition) = + proposition + +encodePreparedProof :: PreparedProof -> ByteString +encodePreparedProof = + encodeCache . putPreparedProof + +putPreparedProof :: PreparedProof -> CachePut +putPreparedProof = \case + PreparedImplicitAuto discharge -> do + putCacheTag 0x00 + putPreparedDischarge discharge + PreparedQed discharge -> do + putCacheTag 0x01 + putPreparedDischarge discharge + PreparedOmitted _location goal -> do + putCacheTag 0x06 + putScopedProposition goal + PreparedFix identities continuation -> do + putCacheTag 0x02 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putPreparedProof continuation + PreparedAssume antecedent continuation -> do + putCacheTag 0x03 + putScopedProposition antecedent + putPreparedProof continuation + PreparedTake identities witness discharge continuation -> do + putCacheTag 0x08 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putScopedProposition witness + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + focus property antecedents target hypothesis result child) -> do + putCacheTag 0x07 + putPreparedSetInductionFocus focus + putScopedProposition property + putCacheList putScopedProposition antecedents + putScopedProposition target + putScopedProposition hypothesis + putScopedProposition result + putPreparedProof child + PreparedHave claim discharge continuation -> do + putCacheTag 0x04 + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + putCacheTag 0x0c + putScopedProposition goal + putScopedProposition reduction + putScopedProposition implication + putPreparedDischarge discharge + putPreparedProof continuation + PreparedCalculate calculation continuation -> do + putCacheTag 0x0d + putPreparedCalculation calculation + putPreparedProof continuation + PreparedSince sinceProposition evidence claim discharge continuation -> do + putCacheTag 0x0e + putScopedProposition sinceProposition + putPreparedSinceEvidence evidence + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSubclaim claim subproof continuation -> do + putCacheTag 0x05 + putScopedProposition claim + putPreparedProof subproof + putPreparedProof continuation + PreparedDefine identity body definitions continuation -> do + putCacheTag 0x09 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedDefineRelational + identity body functionality definitions continuation -> do + putCacheTag 0x11 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putPreparedDischarge functionality + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedByCase caseAnalysis -> do + putCacheTag 0x0f + putPreparedCaseAnalysis caseAnalysis + PreparedByContradiction goal negation falsum child -> do + putCacheTag 0x10 + putScopedProposition goal + putScopedProposition negation + putScopedProposition falsum + putPreparedProof child + PreparedContradiction goal falsum discharge -> do + putCacheTag 0x0a + putScopedProposition goal + putScopedProposition falsum + putPreparedDischarge discharge + PreparedDefineFunction identity graph definition continuation -> do + putCacheTag 0x0b + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm graph + putScopedProposition definition + putPreparedProof continuation + +putPreparedSetInductionFocus + :: PreparedSetInductionFocus + -> CachePut +putPreparedSetInductionFocus = \case + PreparedInitialSetInductionFocus identity index -> do + putCacheTag 0x00 + putCacheNatural (Exact.exactLocalIdValue identity) + putCacheNatural index + PreparedLeadingSetInductionFocus identity -> do + putCacheTag 0x01 + putCacheNatural (Exact.exactLocalIdValue identity) + +putPreparedDischarge :: PreparedDischarge -> CachePut +putPreparedDischarge + (PreparedVampireDischarge + _location justification goal _obligation) = do + putPreparedDischargeSyntax justification goal +putPreparedDischarge + (PreparedSetExtensionality _location goal) = do + putCacheTag 0x03 + putScopedProposition goal + +putPreparedDischargeSyntax + :: PreparedJustification + -> ScopedCheckedCore ObjectId + -> CachePut +putPreparedDischargeSyntax justification goal = do + putPreparedJustification justification + putScopedProposition goal + +putPreparedCalculation :: PreparedCalculation -> CachePut +putPreparedCalculation + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) = do + putCoreTypeCache operandType + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putCacheMaybe putScopedProposition calculationGuard + putCacheList putScopedTerm + (first : (preparedCalculationLinkDestination <$> toList links)) + putCacheList putPreparedDischarge + (preparedCalculationLinkDischarge <$> toList links) + putScopedProposition result + +putPreparedSinceEvidence :: PreparedSinceEvidence -> CachePut +putPreparedSinceEvidence = \case + PreparedSinceExisting local -> do + putCacheTag 0x00 + putPreparedLocalEvidence local + PreparedSinceDischarged discharge local -> do + putCacheTag 0x01 + putPreparedDischarge discharge + putPreparedLocalEvidence local + +putPreparedCaseAnalysis :: PreparedCaseAnalysis -> CachePut +putPreparedCaseAnalysis + (PreparedCaseAnalysis goal cases exhaustive discharge) = do + putScopedProposition goal + putCacheList putPreparedCase (toList cases) + putScopedProposition exhaustive + putPreparedDischarge discharge + +putPreparedCase :: PreparedCase -> CachePut +putPreparedCase (PreparedCase assumption proof) = do + putScopedProposition assumption + putPreparedProof proof + +putPreparedLocalEvidence :: PreparedLocal -> CachePut +putPreparedLocalEvidence + (PreparedLocal ordinal _origin support proposition) = do + putCacheNatural (Backend.localPremiseOrdinalValue ordinal) + putCacheList + (\(identity, coreType) -> do + putCacheNatural (Exact.exactLocalIdValue identity) + putCoreTypeCache coreType) + (Vector.toList support) + putScopedProposition proposition + +implicitAutoProofSyntaxId + :: ScopedCheckedCore ObjectId + -> ProofSyntaxId +implicitAutoProofSyntaxId goal = + proofSyntaxId + (encodeCache do + putCacheTag 0x00 + putPreparedDischargeSyntax PreparedAuto goal) + +putPreparedJustification :: PreparedJustification -> CachePut +putPreparedJustification = \case + PreparedAuto -> + putCacheTag 0x00 + PreparedReferences fingerprints -> do + putCacheTag 0x01 + putCacheList + putSemanticFactOccurrenceFingerprintCache + (toList fingerprints) + PreparedLocalOnly -> + putCacheTag 0x02 + +putScopedProposition + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedProposition proposition = do + putCacheList putCoreTypeCache + (scopedCoreContext proposition) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm proposition) + +putScopedTerm + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedTerm term = do + putCacheList putCoreTypeCache + (scopedCoreContext term) + putCoreTypeCache (scopedCoreType term) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm term) + +proofLocation :: Location -> Raw.Proof -> Location +proofLocation fallback = \case + Raw.Omitted location -> location + Raw.Qed maybeLocation _justification -> + fromMaybe fallback maybeLocation + Raw.Contradiction location _justification -> location + Raw.ByCase location _cases -> location + Raw.ByContradiction location _proof -> location + Raw.BySetInduction location _term _proof -> location + Raw.ByOrdInduction location _proof -> location + Raw.Assume location _statement _proof -> location + Raw.FixSymbolic location _variables _bound _proof -> location + Raw.FixSuchThat location _variables _statement _proof -> location + Raw.Calc location _quantifier _calculation _proof -> location + Raw.TakeVar location _variables _bound _statement _justification _proof -> + location + Raw.TakeNoun location _noun _justification _proof -> location + Raw.Have location _since _statement _justification _proof -> location + Raw.Suffices location _statement _justification _proof -> location + Raw.Subclaim location _statement _subproof _proof -> location + Raw.Define location _variable _expression _proof -> location + Raw.DefineFunction location _function _argument _value _bound _domain _proof -> + location + Raw.DefineFunctionLocal + location _function _argument _value _bound _target _rules _proof -> + location + +throwProof :: ExactProofError -> Prepare value +throwProof = + State.lift . Except.throwError + +liftDriver + :: Declaration.LoweringDriver value + -> Prepare value +liftDriver = + State.lift . Except.lift + +stableUnique :: Ord value => [value] -> [value] +stableUnique = + reverse . snd + . foldl' + (\(seen, reversed) value -> + if value `Set.member` seen + then (seen, reversed) + else + ( Set.insert value seen + , value : reversed + )) + (Set.empty, []) diff --git a/source/Felix/Checking/Exact/Vocabulary.hs b/source/Felix/Checking/Exact/Vocabulary.hs new file mode 100644 index 0000000..a712bf1 --- /dev/null +++ b/source/Felix/Checking/Exact/Vocabulary.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Semantic classification shared by the exact source compilers. +module Felix.Checking.Exact.Vocabulary + ( FixedSemanticMeaning(..) + , fixedSemanticMeaning + , lowerFixedEqualityPredicate + , ExactSymbolClass(..) + , classifyExactSymbol + , FixedSetTermDispatch(..) + , dispatchFixedSetTerm + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Semantic +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map + + +data FixedSemanticMeaning + = FixedEquality + | FixedDisequality + | FixedIntrinsic !CoreIntrinsicTag + | FixedNegatedIntrinsic !CoreIntrinsicTag + deriving stock (Show, Eq) + +fixedSemanticMeaning + :: SemanticGlobalKey + -> Maybe FixedSemanticMeaning +fixedSemanticMeaning key = + Map.lookup key fixedSemanticVocabulary + +-- This inventory owns every exact source form that bypasses global lookup. +fixedSemanticVocabulary + :: Map.Map SemanticGlobalKey FixedSemanticMeaning +fixedSemanticVocabulary = + Map.fromList + [ ( relationKey Raw.EqSymbol + , FixedEquality + ) + , ( SemanticRightAdjective + (Raw.lexicalItemPattern + Lexicon.builtinEqualityRightAdjective) + , FixedEquality + ) + , ( verbKey Lexicon.builtinEqualityVerb + , FixedEquality + ) + , ( relationKey Raw.ElementSymbol + , FixedIntrinsic Member + ) + , ( relationKey Raw.NotElementSymbol + , FixedNegatedIntrinsic Member + ) + , ( relationKey Raw.NeqSymbol + , FixedDisequality + ) + , ( nounKey Lexicon.builtinElementNoun + , FixedIntrinsic Member + ) + , ( expressionKey + (Raw.TokenCons (Raw.Command "emptyset") Raw.End) + , FixedIntrinsic Empty + ) + , ( expressionKey (Raw.mixfixPattern Raw.UnionsSymbol) + , FixedIntrinsic FamilyUnion + ) + , ( expressionKey (unaryCommandPattern "pow") + , FixedIntrinsic PowerSet + ) + , ( expressionKey (unaryCommandPattern "cumul") + , FixedIntrinsic UnivOf + ) + , ( expressionKey (Raw.mixfixPattern Raw.UpairSymbol) + , FixedIntrinsic PairSet + ) + ] + where + relationKey relation = + SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + nounKey item = + let patterns = Raw.lexicalItemSgPlPattern item + in SemanticNoun (Raw.sg patterns) (Raw.pl patterns) + verbKey item = + let patterns = Raw.lexicalItemSgPlPattern item + in SemanticVerb (Raw.sg patterns) (Raw.pl patterns) + expressionKey = SemanticExpressionFunction + +-- | Lower the fixed proposition meanings shared by raw exact elaboration and +-- the reusable internal-formula path. Membership deliberately retains its +-- carrier-aware source lowering and is not handled here. +lowerFixedEqualityPredicate + :: FixedSemanticMeaning + -> [CanonicalTerm global] + -> Maybe (CanonicalTerm global) +lowerFixedEqualityPredicate meaning arguments = + case (meaning, arguments) of + (FixedEquality, [left, right]) -> + Just (CEq TySet left right) + (FixedDisequality, [left, right]) -> + Just (CImp (CEq TySet left right) CFalsum) + _ -> + Nothing + +unaryCommandPattern :: Text -> Raw.Pattern +unaryCommandPattern command = + Raw.TokenCons (Raw.Command command) + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons Raw.InvisibleBraceR Raw.End))) + +data ExactSymbolClass + = ExactClosedLiteral + | ExactFixedPrimitive !FixedSemanticMeaning + | ExactSourceGlobal !(NonEmpty SemanticGlobalKey) + | ExactUnsupportedSymbol + deriving stock (Show, Eq) + +classifyExactSymbol :: Internal.Symbol -> ExactSymbolClass +classifyExactSymbol symbol = + case symbol of + Internal.SymbolInteger{} -> + ExactClosedLiteral + _ -> + case NonEmpty.nonEmpty (semanticKeys symbol) of + Nothing -> + ExactUnsupportedSymbol + Just keys -> + case firstFixed keys of + Just meaning -> + ExactFixedPrimitive meaning + Nothing -> + ExactSourceGlobal keys + where + firstFixed = + foldr + (\key found -> fixedSemanticMeaning key <|> found) + Nothing + +semanticKeys :: Internal.Symbol -> [SemanticGlobalKey] +semanticKeys = \case + Internal.SymbolMixfix symbol -> + [SemanticExpressionFunction (Raw.mixfixPattern symbol)] + Internal.SymbolFun item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns)] + Internal.SymbolPredicate predicate -> + case predicate of + Internal.PredicateAdj item -> + [ SemanticLeftAdjective (Raw.lexicalItemPattern item) + , SemanticRightAdjective (Raw.lexicalItemPattern item) + ] + Internal.PredicateVerb item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticVerb (Raw.sg patterns) (Raw.pl patterns)] + Internal.PredicateNoun item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticNoun (Raw.sg patterns) (Raw.pl patterns)] + Internal.PredicateRelation relation -> + [ SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + ] + Internal.PredicateSymbol{} -> [] + Internal.PredicateNounStruct{} -> [] + Internal.SymbolInteger{} -> [] + +-- | Result of interpreting a symbol already classified by the fixed exact +-- vocabulary as a set-valued term. +data FixedSetTermDispatch global + = NotFixedSetTerm + | LoweredFixedSetTerm !(CanonicalTerm global) + | RejectedFixedSetTerm + deriving stock (Show, Eq) + +-- | Interpret every fixed symbol that can occur in the reusable internal-term +-- lowering. Fixed relations are handled by formula lowering. +dispatchFixedSetTerm + :: Internal.Symbol + -> [CanonicalTerm global] + -> FixedSetTermDispatch global +dispatchFixedSetTerm symbol arguments = + case classifyExactSymbol symbol of + ExactFixedPrimitive meaning -> + case meaning of + FixedIntrinsic intrinsic -> + applyIntrinsic + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + arguments + FixedNegatedIntrinsic _intrinsic -> + RejectedFixedSetTerm + FixedEquality -> + RejectedFixedSetTerm + FixedDisequality -> + RejectedFixedSetTerm + _ -> + NotFixedSetTerm + where + applyIntrinsic term coreType remaining = + case (coreType, remaining) of + (TySet, []) -> + LoweredFixedSetTerm term + (TyArrow TySet resultType, argument : rest) -> + applyIntrinsic + (CApp term argument) + resultType + rest + _ -> + RejectedFixedSetTerm diff --git a/source/Felix/Checking/FinalPrelude.hs b/source/Felix/Checking/FinalPrelude.hs new file mode 100644 index 0000000..9cc43f4 --- /dev/null +++ b/source/Felix/Checking/FinalPrelude.hs @@ -0,0 +1,1266 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Authority-confined construction of the inert final-prelude candidate. +module Felix.Checking.FinalPrelude + ( FinalPreludeCandidate + , finalPreludeParsed + , finalPreludeSyntax + , finalPreludeSemantic + , finalPreludePrefix + , finalPreludeObjects + , PreludePublicRole(..) + , expectedFinalPreludePublicRoles + , FinalPreludeRoleTarget(..) + , finalPreludePublicRole + , FinalPreludeValidationError(..) + , FinalPreludeFailure(..) + , FinalPreludeBuildResult(..) + , buildFinalPreludeCandidate + , buildParsedFinalPreludeCandidate + , validateOmegaFactInventory + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Checking.Semantic qualified as Semantic +import Felix.Module +import Felix.Cache.Codec (CacheDigest) +import Felix.Parse +import Felix.Prelude qualified as Prelude +import Felix.Source (ImportRef) +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon qualified as Lexicon + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + + +data FinalPreludeCandidate = FinalPreludeCandidate + !Prelude.ReservedParsedPrelude + !ModuleSyntaxInterface + !SemanticInterface + !Declaration.PendingModulePrefix + !CheckedObjectClosure + !(Map.Map PreludePublicRole FinalPreludeRoleTarget) + +finalPreludeParsed + :: FinalPreludeCandidate + -> Prelude.ReservedParsedPrelude +finalPreludeParsed + (FinalPreludeCandidate parsed _syntax _semantic _prefix _objects + _roles) = + parsed + +finalPreludeSyntax + :: FinalPreludeCandidate + -> ModuleSyntaxInterface +finalPreludeSyntax + (FinalPreludeCandidate _parsed syntax _semantic _prefix _objects + _roles) = + syntax + +finalPreludeSemantic + :: FinalPreludeCandidate + -> SemanticInterface +finalPreludeSemantic + (FinalPreludeCandidate _parsed _syntax semantic _prefix _objects + _roles) = + semantic + +finalPreludePrefix + :: FinalPreludeCandidate + -> Declaration.PendingModulePrefix +finalPreludePrefix + (FinalPreludeCandidate _parsed _syntax _semantic prefix _objects + _roles) = + prefix + +finalPreludeObjects + :: FinalPreludeCandidate + -> CheckedObjectClosure +finalPreludeObjects + (FinalPreludeCandidate _parsed _syntax _semantic _prefix objects + _roles) = + objects + +data FinalPreludeRoleTarget + = FinalPreludeObjectRole !ObjectId + | FinalPreludeTheoremRole !TheoremRef + deriving stock (Show, Eq, Ord) + +-- | Stable public roles exported by the packaged final prelude. +data PreludePublicRole + = PreludeInfinityTheorem + | PreludeOmegaObject + | PreludeOmegaDefiningEquation + | PreludeNaturalsAlias + | PreludeNaturalsInductiveTheorem + | PreludeNaturalsMinimalTheorem + deriving stock (Show, Eq, Ord, Enum, Bounded) + +expectedFinalPreludePublicRoles :: Set PreludePublicRole +expectedFinalPreludePublicRoles = + Set.fromList [minBound .. maxBound] + +finalPreludePublicRole + :: FinalPreludeCandidate + -> PreludePublicRole + -> Maybe FinalPreludeRoleTarget +finalPreludePublicRole + (FinalPreludeCandidate _parsed _syntax _semantic _prefix _objects + roles) role = + Map.lookup role roles + +data FinalPreludeValidationError + = FinalPreludePackagedInputMismatch + | FinalPreludeSemanticEnvironmentMismatch + | FinalPreludeDeclarationAssociationMismatch + | FinalPreludeUnexpectedObject !ObjectId + | FinalPreludeDeclarationMissing !Text + | FinalPreludeDeclarationDuplicate !Text + | FinalPreludeDeclarationShapeMismatch !Text + | FinalPreludeDefinitionContentMismatch !Text + | FinalPreludeFactContentMismatch !Text + | FinalPreludeValidationInventoryMismatch !DeclarationSlot + | FinalPreludeAuthorityMismatch !DeclarationSlot + | FinalPreludeBaseStructureMismatch + | FinalPreludePublicRoleMismatch !PreludePublicRole + deriving stock (Show, Eq) + +data FinalPreludeFailure + = FinalPreludeWrongOwner !ModuleName + | FinalPreludeHasImports ![ImportRef] + | FinalPreludeHasSyntaxImports ![SyntaxInterfaceId] + | FinalPreludeUnsupportedBlock !Location + | FinalPreludeUnmatchedProof !Location + | FinalPreludeExactDeclarationFailed !Exact.ExactCompileError + | FinalPreludeExactProofFailed !ExactProof.ExactProofError + | FinalPreludeOmittedProof !Location + | FinalPreludeDeclarationFailed !Declaration.DeclarationError + | FinalPreludeSealFailed !SemanticInterfaceError + | FinalPreludeValidationFailed !FinalPreludeValidationError + deriving stock (Show, Eq) + +data FinalPreludeBuildResult + = FinalPreludeSourceLoadFailed !Prelude.PreludeLoadError + | FinalPreludeSourceParseFailed !Prelude.PreludeParseError + | FinalPreludeBuilt !FinalPreludeCandidate + | FinalPreludeBuildFailed + !FinalPreludeFailure + !Declaration.PendingModulePrefix + | FinalPreludeBuildOpenFailed !Declaration.DriverOpenError + +data PlannedPreludeDeclaration + = PlannedPreludeBinding + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) + | PlannedPreludeFoundation + !(Declaration.PlannedDeclaration + ExactProof.CheckedFinalPreludeFoundationAuthorization) + | PlannedPreludeProof + !(Declaration.PlannedDeclaration + ExactProof.CheckedExactProofAuthorization) + | PlannedPreludeBase + !(Declaration.PlannedDeclaration ()) + +data PreludePlanningFailure + = PreludePlanningAction !FinalPreludeFailure + | PreludePlanningDeclaration !Declaration.DeclarationError + +data PreludeModulePlan = PreludeModulePlan + ![PlannedPreludeDeclaration] + !(Maybe PreludePlanningFailure) + +buildFinalPreludeCandidate + :: CheckedFoundation + -> Declaration.VampireResolver + -> IO FinalPreludeBuildResult +buildFinalPreludeCandidate foundation resolver = + Prelude.loadReservedPreludeSourceInput >>= \case + Left failure -> + pure (FinalPreludeSourceLoadFailed failure) + Right source -> + Prelude.parseReservedPreludeSource source >>= \case + Left failure -> + pure (FinalPreludeSourceParseFailed failure) + Right parsed -> + buildParsedFinalPreludeCandidate + foundation parsed resolver + +-- The production acquisition path establishes packaged provenance before +-- passing its already parsed source here. The explicit parsed seam avoids a +-- second load and parse on a cache miss. +buildParsedFinalPreludeCandidate + :: CheckedFoundation + -> Prelude.ReservedParsedPrelude + -> Declaration.VampireResolver + -> IO FinalPreludeBuildResult +buildParsedFinalPreludeCandidate foundation parsed resolver = + case validatePackagedPreludeInput parsed syntax of + Left failure -> do + case emptyPrefix of + Left prefixFailure -> + pure + (FinalPreludeBuildOpenFailed + (Declaration.DriverInitialPrefixError + prefixFailure)) + Right prefix -> + pure (FinalPreludeBuildFailed failure prefix) + Right () -> do + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + resolver + -- The confined builder never consults stored validation. + Declaration.FreshValidation + do + PreludeModulePlan declarations terminal <- + Declaration.runProspectiveLoweringDriver + (planBlocks [] 0 blocks) + traverse_ admitPreludeDeclaration declarations + traverse_ failPreludePlanning terminal + pure case outcome of + Left failure -> + FinalPreludeBuildOpenFailed failure + Right (Declaration.DriverFailed failure prefix) -> + FinalPreludeBuildFailed + (case failure of + Declaration.DriverDeclarationFailed err -> + FinalPreludeDeclarationFailed err + Declaration.DriverActionFailed err -> + err) + prefix + Right (Declaration.DriverSealFailed failure prefix) -> + FinalPreludeBuildFailed + (FinalPreludeSealFailed failure) + prefix + Right (Declaration.DriverSucceeded + () semantic prefix objects) -> + case validateFinalPrelude + foundation parsed semantic prefix objects of + Left failure -> + FinalPreludeBuildFailed + (FinalPreludeValidationFailed failure) + prefix + Right roles -> + FinalPreludeBuilt + (FinalPreludeCandidate + parsed syntax semantic prefix objects roles) + where + identified = Prelude.reservedParsedPreludeModule parsed + blocks = identifiedParsedModuleBlocks identified + occurrences = identifiedParsedModuleSyntaxOccurrences identified + syntax = identifiedParsedModuleSyntaxInterface identified + + emptyPrefix = + Declaration.emptyPendingModulePrefix + <$> initialPrefixContextId + (theoryId foundation) + preludeModuleName + [] + + planBlocks completed _blockIndex [] = do + planBaseStructure >>= \case + Left failure -> + pure + (PreludeModulePlan + (reverse completed) + (Just failure)) + Right base -> + pure + (PreludeModulePlan + (reverse (base : completed)) + Nothing) + planBlocks completed blockIndex (block : remaining) = + case block of + Raw.BlockClaim{} -> + case remaining of + Raw.BlockProof _location proof _end : rest -> do + continue completed (blockIndex + 2) rest + =<< planOrdinaryProof block (Just proof) + _ -> do + continue completed (blockIndex + 1) remaining + =<< planImplicitClaim block + Raw.BlockProof location _proof _end -> + pure + (PreludeModulePlan + (reverse completed) + (Just + (PreludePlanningAction + (FinalPreludeUnmatchedProof location)))) + Raw.BlockAbbr{} -> do + continue completed (blockIndex + 1) remaining + =<< planBinding blockIndex block + Raw.BlockDefn{} -> do + continue completed (blockIndex + 1) remaining + =<< planBinding blockIndex block + _ -> + pure + (PreludeModulePlan + (reverse completed) + (Just + (PreludePlanningAction + (FinalPreludeUnsupportedBlock + (locate block))))) + where + continue accumulated nextIndex rest = \case + Left failure -> + pure + (PreludeModulePlan + (reverse accumulated) + (Just failure)) + Right declaration -> + planBlocks (declaration : accumulated) nextIndex rest + + planBaseStructure = do + slot <- Declaration.nextDeclarationSlotLowering + theory <- Declaration.currentTheoryLowering + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot 0) + coreType = TyArrow TySet TySet + content = OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + asserted = assertedObject identity content + structurePhrase = + semanticStructurePhrase Lexicon._Onesorted + operation = + semanticStructureOperation Raw.CarrierSymbol identity + descriptor <- + either + (pure + . Left + . PreludePlanningDeclaration + . Declaration.DeclarationEnvironmentFailed) + (pure . Right) + (semanticStructureDescriptor + structurePhrase Nothing [] [operation]) + case descriptor of + Left failure -> pure (Left failure) + Right checkedDescriptor -> + planPreludeChecked PlannedPreludeBase + (Declaration.checkedCompiledDeclaration + (declarationSyntaxId + "felix-final-prelude-base-structure-v1") + [asserted] [] [] [checkedDescriptor] [] ()) + + planBinding blockIndex block = do + prepared <- + Exact.prepareExactDeclaration + block + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactDeclarationFailed failure))) + Right declaration -> do + Exact.lowerPreparedExactBinding declaration >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeBinding checked + + planImplicitClaim block = do + foundationClaim <- + ExactProof.prepareFinalPreludeFoundationClaim + foundation block Nothing + case foundationClaim of + Right claim -> do + ExactProof.lowerPreparedFinalPreludeFoundationClaim claim + >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeFoundation checked + Left ExactProof.ExactProofFoundationLeafTargetMismatch{} -> + planOrdinaryProof block Nothing + Left ExactProof.ExactProofFoundationLeafRequiresImplicitAuto{} -> + planOrdinaryProof block Nothing + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactProofFailed failure))) + + planOrdinaryProof block explicitProof = do + prepared <- + ExactProof.prepareExactProof block explicitProof + case prepared of + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactProofFailed failure))) + Right proof + | Just location <- + ExactProof.preparedExactProofFirstOmission proof -> + pure + (Left + (PreludePlanningAction + (FinalPreludeOmittedProof location))) + | otherwise -> + ExactProof.lowerPreparedExactProof proof >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeProof checked + + planPreludeChecked + :: forall body. + (Declaration.PlannedDeclaration body + -> PlannedPreludeDeclaration) + -> Declaration.CheckedDeclaration body + -> Declaration.LoweringDriver + (Either PreludePlanningFailure PlannedPreludeDeclaration) + planPreludeChecked constructor checked = + Declaration.planCheckedDeclaration checked >>= \case + Left failure -> planningDeclarationFailure failure + Right planned -> pure (Right (constructor planned)) + + planningDeclarationFailure = + pure . Left . PreludePlanningDeclaration + + admitPreludeDeclaration = \case + PlannedPreludeBinding planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactBinding) + PlannedPreludeFoundation planned -> + void + (Declaration.admitPlannedCheckedDeclaration planned + ExactProof.authorizeCheckedFinalPreludeFoundationClaim) + PlannedPreludeProof planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactProof.authorizeCheckedExactProof) + PlannedPreludeBase planned -> + void + (Declaration.admitPlannedCheckedDeclaration planned + (\() stages -> + unless + (null stages) + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 0 (length stages))))) + + failPreludePlanning = \case + PreludePlanningAction failure -> + Declaration.failModuleDriver failure + PreludePlanningDeclaration failure -> + Declaration.failDeclarationDriver failure + +data PreludeDeclaration = PreludeDeclaration + !Raw.Block + !Declaration.CommittedDeclarationBatch + +data PreludeDefinitionKind + = PreludeDefinition + | PreludeAbbreviation + +data PreludeDefinitionView = PreludeDefinitionView + !ObjectId + !SemanticGlobalTarget + +validateFinalPrelude + :: CheckedFoundation + -> Prelude.ReservedParsedPrelude + -> SemanticInterface + -> Declaration.PendingModulePrefix + -> CheckedObjectClosure + -> Either + FinalPreludeValidationError + (Map.Map PreludePublicRole FinalPreludeRoleTarget) +validateFinalPrelude foundation parsed semantic prefix objects = do + (declarations, baseStructure) <- + associatePreludeDeclarations parsed prefix + validateConfinedAuthority + foundation semantic objects declarations baseStructure + resolveAndValidatePublicRoles foundation objects declarations + +resolveAndValidatePublicRoles + :: CheckedFoundation + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Either + FinalPreludeValidationError + (Map.Map PreludePublicRole FinalPreludeRoleTarget) +resolveAndValidatePublicRoles foundation objects declarations = do + successor <- + expectDefinition + foundation objects declarations + "prelude_successor" + PreludeDefinition + (TyArrow TySet TySet) + expectedSuccessorBody + let successorId = definitionViewObject successor + + inductive <- + expectDefinition + foundation objects declarations + "prelude_inductive" + PreludeDefinition + (TyArrow TySet TyProp) + (expectedInductiveBody successorId) + let inductiveId = definitionViewObject inductive + + u0 <- + expectDefinition + foundation objects declarations + "prelude_u0" + PreludeDefinition + TySet + (applyIntrinsic UnivOf (CIntrinsic Empty)) + let u0Id = definitionViewObject u0 + + let omegaBody = expectedOmegaBody u0Id inductiveId + omega <- + expectDefinition + foundation objects declarations + "prelude_omega" + PreludeDefinition + TySet + omegaBody + let omegaId = definitionViewObject omega + + omegaConstruction <- + expectedOmegaConstruction objects omegaBody + omegaDerived <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + omegaId + omegaConstruction) + + naturals <- + expectDefinition + foundation objects declarations + "prelude_naturals" + PreludeAbbreviation + TySet + (CGlobal omegaId) + case definitionViewTarget naturals of + TransparentExpansion{} -> pure () + _ -> + Left + (FinalPreludeDefinitionContentMismatch + "prelude_naturals") + + (infinity, infinityTarget) <- + expectClaim declarations "prelude_infinity" + validateInfinityTarget objects inductiveId infinityTarget + omegaDeclaration <- findDeclaration "prelude_omega" declarations + omegaEquation <- + validateOmegaDeclaration + objects + omegaId + omegaBody + omegaDerived + omegaDeclaration + let inductiveOmega = + CApp (CGlobal inductiveId) (CGlobal omegaId) + minimalOmega = expectedMinimality inductiveId omegaId + naturalsInductive <- + fst + <$> expectClaimTarget + declarations + "prelude_naturals_inductive" + inductiveOmega + naturalsMinimal <- + fst + <$> expectClaimTarget + declarations + "prelude_naturals_minimal" + minimalOmega + + let roles = Map.fromList + [ ( PreludeInfinityTheorem + , FinalPreludeTheoremRole infinity + ) + , ( PreludeOmegaObject + , FinalPreludeObjectRole omegaId + ) + , ( PreludeOmegaDefiningEquation + , FinalPreludeTheoremRole omegaEquation + ) + , ( PreludeNaturalsAlias + , FinalPreludeObjectRole omegaId + ) + , ( PreludeNaturalsInductiveTheorem + , FinalPreludeTheoremRole naturalsInductive + ) + , ( PreludeNaturalsMinimalTheorem + , FinalPreludeTheoremRole naturalsMinimal + ) + ] + unless + (Map.keysSet roles == expectedFinalPreludePublicRoles) + (Left + (FinalPreludePublicRoleMismatch + PreludeInfinityTheorem)) + pure roles + +expectedOmegaConstruction + :: CheckedObjectClosure + -> CanonicalTerm ObjectId + -> Either + FinalPreludeValidationError + (NamedSetConstruction ObjectId) +expectedOmegaConstruction objects = \case + CApp (CApp (CIntrinsic Sep) bound) (CLam TySet predicate) -> do + checkedBound <- checked [] bound + checkedPredicate <- checked [TySet] predicate + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (checkedSeparationConstruction + (`lookupCheckedObjectType` objects) + checkedBound + checkedPredicate) + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + where + checked context term = + first + (const + (FinalPreludeFactContentMismatch + "prelude_omega")) + (checkScopedCanonicalCore + (`lookupCheckedObjectType` objects) + context + term) + +validateOmegaDeclaration + :: CheckedObjectClosure + -> ObjectId + -> CanonicalTerm ObjectId + -> NamedSetConstructionFact + -> PreludeDeclaration + -> Either FinalPreludeValidationError TheoremRef +validateOmegaDeclaration objects omegaId omegaBody derived declaration = do + let batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + omegaContent <- case lookupCheckedObjectContent omegaId objects of + Just content@TransparentObjectContent{} -> pure content + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + unless + ( declarationDeltaObjects delta == [omegaId] + && case Declaration.committedBatchObjects batch of + [asserted] -> + assertedObjectId asserted == omegaId + && assertedObjectContent asserted == omegaContent + _ -> False + && null (Declaration.committedBatchProofValidations batch) + ) + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + certificates <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + (Right . declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + validateOmegaFactInventory + omegaId + omegaBody + (namedSetConstructionFactProposition derived) + (namedSetConstructionFactDescriptor derived) + (declarationDeltaFacts delta) + (declarationDeltaAliases delta) + (Declaration.committedBatchPropositions batch) + certificates + +-- | Purpose-specific audit of the distinguished Omega definition. It is +-- deliberately not a general declaration manifest: the confined prelude has +-- exactly one declaration whose public role requires this two-fact shape. +-- The explicit arguments also provide a narrow pure seam for corruption +-- regression tests. +validateOmegaFactInventory + :: ObjectId + -> CanonicalTerm ObjectId + -> FrozenCheckedCore ObjectId + -> CacheDigest + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [CheckedPropositionContent] + -> [Authority.ValidationCertificate] + -> Either FinalPreludeValidationError TheoremRef +validateOmegaFactInventory + omegaId omegaBody expectedExtensional expectedDescriptor + facts aliases propositions certificates = do + (equationOccurrence, extensionalOccurrence) <- + case facts of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + (equationCertificate, extensionalCertificate) <- + case certificates of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + case aliases of + [alias] + | semanticAliasName alias == semanticName "prelude_omega" + , semanticAliasTarget alias + == semanticFactFingerprint equationOccurrence -> + pure () + _ -> mismatch + equation <- propositionFor equationOccurrence + extensional <- propositionFor extensionalOccurrence + unless + ( length propositions == 2 + && semanticFactSearchEligibility equationOccurrence + == SearchIneligible + && frozenCoreTerm (checkedPropositionTerm equation) + == CEq TySet (CGlobal omegaId) omegaBody + && Authority.validationTarget equationCertificate + == semanticFactAuthority equationOccurrence + && Authority.validationDirectAuthorization equationCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation omegaId) + && semanticFactSearchEligibility extensionalOccurrence + == SearchEligible + && checkedPropositionTerm extensional == expectedExtensional + && Authority.validationTarget extensionalCertificate + == semanticFactAuthority extensionalOccurrence + && Authority.validationDirectAuthorization extensionalCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + omegaId expectedDescriptor) + ) + mismatch + pure + (Authority.factAuthorityTheorem + (semanticFactAuthority equationOccurrence)) + where + mismatch = + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + + propositionFor occurrence = + case List.filter + ((== semanticFactProposition occurrence) + . checkedPropositionId) + propositions of + [proposition] -> Right proposition + _ -> mismatch + +validatePackagedPreludeInput + :: Prelude.ReservedParsedPrelude + -> ModuleSyntaxInterface + -> Either FinalPreludeFailure () +validatePackagedPreludeInput parsed syntax + | freshModuleInputOwner input /= preludeModuleName = + Left (FinalPreludeWrongOwner (freshModuleInputOwner input)) + | not (null (freshModuleInputImports input)) = + Left (FinalPreludeHasImports (freshModuleInputImports input)) + | not (null (moduleSyntaxDirectInputs syntax)) = + Left + (FinalPreludeHasSyntaxImports + (moduleSyntaxDirectInputs syntax)) + | otherwise = do + unless + ( freshModuleInputBinding input == FreshReservedSource + && freshModuleInputLocationPath input + == Prelude.preludeDiagnosticLabel + && freshModuleInputSyntaxInterface input == syntax + && identifiedParsedModuleSyntaxInterface identified == syntax + ) + (Left + (FinalPreludeValidationFailed + FinalPreludePackagedInputMismatch)) + where + input = Prelude.reservedParsedPreludeInput parsed + identified = Prelude.reservedParsedPreludeModule parsed + +associatePreludeDeclarations + :: Prelude.ReservedParsedPrelude + -> Declaration.PendingModulePrefix + -> Either + FinalPreludeValidationError + ([PreludeDeclaration], Declaration.CommittedDeclarationBatch) +associatePreludeDeclarations parsed prefix = do + case List.splitAt (length sourceDeclarations) batches of + (sourceBatches, [baseStructure]) + | length sourceBatches == length sourceDeclarations -> + pure + ( zipWith PreludeDeclaration + sourceDeclarations sourceBatches + , baseStructure + ) + _ -> Left FinalPreludeDeclarationAssociationMismatch + where + sourceDeclarations = + [ block + | block <- + identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed) + , case block of + Raw.BlockProof{} -> False + _ -> True + ] + batches = Declaration.pendingModulePrefixBatches prefix + +validateConfinedAuthority + :: CheckedFoundation + -> SemanticInterface + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Declaration.CommittedDeclarationBatch + -> Either FinalPreludeValidationError () +validateConfinedAuthority + foundation semantic objects declarations baseStructure = do + unless + ( semanticInterfaceOwner semantic == preludeModuleName + && null (semanticInterfaceDirectInputs semantic) + ) + (Left FinalPreludeSemanticEnvironmentMismatch) + traverse_ requireTransparent + [ identity + | declaration <- declarations + , identity <- + declarationDeltaObjects + (Declaration.committedBatchDelta + (declarationBatch declaration)) + ] + traverse_ (validateDeclarationAuthority foundation objects) declarations + validateBaseStructure foundation objects baseStructure + where + requireTransparent identity = + case lookupCheckedObjectContent identity objects of + Just TransparentObjectContent{} -> pure () + _ -> Left (FinalPreludeUnexpectedObject identity) + +validateBaseStructure + :: CheckedFoundation + -> CheckedObjectClosure + -> Declaration.CommittedDeclarationBatch + -> Either FinalPreludeValidationError () +validateBaseStructure foundation objects batch = do + let slot = Declaration.committedBatchSlot batch + delta = Declaration.committedBatchDelta batch + environment = declarationDeltaEnvironment delta + structurePhrase = semanticStructurePhrase Lexicon._Onesorted + expectedSeed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot 0) + expectedType = TyArrow TySet TySet + expectedObject = opaqueObjectId (theoryId foundation) expectedSeed expectedType + expectedContent = + OpaqueObjectContent + (theoryId foundation) + expectedSeed + expectedType + descriptor <- + case semanticEnvironmentStructures environment of + [single] -> Right single + _ -> Left FinalPreludeBaseStructureMismatch + expectedDescriptor <- + first (const FinalPreludeBaseStructureMismatch) + (semanticStructureDescriptor + structurePhrase + Nothing + [] + [semanticStructureOperation Raw.CarrierSymbol expectedObject]) + unless + ( declarationSlotModule slot == preludeModuleName + && descriptor == expectedDescriptor + && null (semanticEnvironmentBindings environment) + && declarationDeltaObjects delta == [expectedObject] + && null (declarationDeltaFacts delta) + && null (declarationDeltaAliases delta) + && null (declarationDeltaPropositions delta) + && Declaration.committedBatchObjects batch + == [assertedObject expectedObject expectedContent] + && null (Declaration.committedBatchPropositions batch) + && null (Declaration.committedBatchProofValidations batch) + && maybe + False + (null . declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + && lookupCheckedObjectContent expectedObject objects + == Just expectedContent + ) + (Left FinalPreludeBaseStructureMismatch) + +validateDeclarationAuthority + :: CheckedFoundation + -> CheckedObjectClosure + -> PreludeDeclaration + -> Either FinalPreludeValidationError () +validateDeclarationAuthority foundation objects declaration = do + unless + (fmap Authority.validationTarget certificates + == fmap semanticFactAuthority facts) + (Left (FinalPreludeValidationInventoryMismatch slot)) + traverse_ validateOne (zip facts certificates) + where + batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + slot = Declaration.committedBatchSlot batch + facts = declarationDeltaFacts delta + certificates = + ( Semantic.proofValidationRecordCertificate + <$> Declaration.committedBatchProofValidations batch + ) + <> maybe + [] + Semantic.declarationValidationRecordCertificates + (Declaration.committedBatchDeclarationValidation batch) + + validateOne (occurrence, certificate) = do + unless + (Authority.factAuthoritySafety + (semanticFactAuthority occurrence) + == Authority.cleanAuthoritySafety) + (Left (FinalPreludeAuthorityMismatch slot)) + proposition <- + maybe + (Left (FinalPreludeValidationInventoryMismatch slot)) + Right + (List.find + ((== semanticFactProposition occurrence) + . checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + let target = frozenCoreTerm (checkedPropositionTerm proposition) + case Authority.validationDirectAuthorization certificate of + Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) -> do + let expected = + frozenCoreTerm + (mapFrozenGlobals absurd + (foundationAxiomFrozen foundation tag)) + unless (target == expected) + (Left (FinalPreludeAuthorityMismatch slot)) + Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation identity) -> + case lookupCheckedObjectContent identity objects of + Just (TransparentObjectContent _theory coreType body) -> + unless + (target == CEq coreType (CGlobal identity) body) + (Left (FinalPreludeAuthorityMismatch slot)) + _ -> + Left (FinalPreludeAuthorityMismatch slot) + Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + identity _descriptor) -> + case lookupCheckedObjectContent identity objects of + Just TransparentObjectContent{} + | semanticFactSearchEligibility occurrence + == SearchEligible -> + pure () + _ -> + Left (FinalPreludeAuthorityMismatch slot) + Authority.CheckedSourceProof requests -> + unless + ( not (null requests) + && case declarationBlock declaration of + Raw.BlockClaim{} -> True + _ -> False + ) + (Left (FinalPreludeAuthorityMismatch slot)) + _ -> + Left (FinalPreludeAuthorityMismatch slot) + +expectDefinition + :: CheckedFoundation + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Text + -> PreludeDefinitionKind + -> CoreType + -> CanonicalTerm ObjectId + -> Either FinalPreludeValidationError PreludeDefinitionView +expectDefinition foundation objects declarations marker kind coreType body = do + declaration <- findDeclaration marker declarations + let delta = + Declaration.committedBatchDelta + (declarationBatch declaration) + unless + (case (kind, declarationBlock declaration) of + (PreludeDefinition, Raw.BlockDefn{}) -> True + (PreludeAbbreviation, Raw.BlockAbbr{}) -> True + _ -> False) + (Left (FinalPreludeDeclarationShapeMismatch marker)) + binding <- + case semanticEnvironmentBindings + (declarationDeltaEnvironment delta) of + [single] -> Right single + _ -> Left (FinalPreludeDeclarationShapeMismatch marker) + let target = semanticGlobalBindingTarget binding + identity = semanticGlobalTargetObject target + unless + (case (kind, target) of + (PreludeDefinition, GlobalReference{}) -> True + (PreludeAbbreviation, TransparentExpansion{}) -> True + _ -> False) + (Left (FinalPreludeDefinitionContentMismatch marker)) + content <- + maybe + (Left (FinalPreludeDefinitionContentMismatch marker)) + Right + (lookupCheckedObjectContent identity objects) + let expected = + TransparentObjectContent + (theoryId foundation) + coreType + body + unless (content == expected) + (Left (FinalPreludeDefinitionContentMismatch marker)) + pure (PreludeDefinitionView identity target) + +expectClaim + :: [PreludeDeclaration] + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectClaim declarations marker = do + declaration <- findDeclaration marker declarations + unless + (case declarationBlock declaration of + Raw.BlockClaim{} -> True + _ -> False) + (Left (FinalPreludeDeclarationShapeMismatch marker)) + expectFact declarations marker + +expectClaimTarget + :: [PreludeDeclaration] + -> Text + -> CanonicalTerm ObjectId + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectClaimTarget declarations marker expected = do + result@(_theorem, actual) <- expectClaim declarations marker + unless + (actual == expected) + (Left (FinalPreludeFactContentMismatch marker)) + pure result + +expectFact + :: [PreludeDeclaration] + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectFact declarations marker = do + declaration <- findDeclaration marker declarations + unless + (length + (declarationDeltaFacts + (Declaration.committedBatchDelta + (declarationBatch declaration))) == 1) + (Left (FinalPreludeFactContentMismatch marker)) + expectAliasedFact declaration marker + +expectAliasedFact + :: PreludeDeclaration + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectAliasedFact declaration marker = do + let batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + expectedAlias = semanticName marker + fingerprint <- case declarationDeltaAliases delta of + [alias] + | semanticAliasName alias == expectedAlias -> + Right (semanticAliasTarget alias) + _ -> Left (FinalPreludeFactContentMismatch marker) + occurrence <- case List.filter + ((== fingerprint) . semanticFactFingerprint) + (declarationDeltaFacts delta) of + [single] -> Right single + _ -> Left (FinalPreludeFactContentMismatch marker) + proposition <- + maybe + (Left (FinalPreludeFactContentMismatch marker)) + Right + (List.find + ((== semanticFactProposition occurrence) + . checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + pure + ( Authority.factAuthorityTheorem + (semanticFactAuthority occurrence) + , frozenCoreTerm (checkedPropositionTerm proposition) + ) + +validateInfinityTarget + :: CheckedObjectClosure + -> ObjectId + -> CanonicalTerm ObjectId + -> Either FinalPreludeValidationError () +validateInfinityTarget objects inductive = \case + CApp (CGlobal predicate) (CGlobal witness) + | predicate == inductive -> + case lookupCheckedObjectContent witness objects of + Just TransparentObjectContent{} -> pure () + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_infinity") + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_infinity") + +findDeclaration + :: Text + -> [PreludeDeclaration] + -> Either FinalPreludeValidationError PreludeDeclaration +findDeclaration marker declarations = + case List.filter ((== marker) . declarationMarker) declarations of + [] -> Left (FinalPreludeDeclarationMissing marker) + [single] -> Right single + _ -> Left (FinalPreludeDeclarationDuplicate marker) + +declarationBlock :: PreludeDeclaration -> Raw.Block +declarationBlock (PreludeDeclaration block _batch) = + block + +declarationBatch + :: PreludeDeclaration + -> Declaration.CommittedDeclarationBatch +declarationBatch (PreludeDeclaration _block batch) = + batch + +declarationMarker :: PreludeDeclaration -> Text +declarationMarker = + fromMaybe "<unmarked>" . blockMarkerText . declarationBlock + +definitionViewObject :: PreludeDefinitionView -> ObjectId +definitionViewObject (PreludeDefinitionView identity _target) = + identity + +definitionViewTarget + :: PreludeDefinitionView + -> SemanticGlobalTarget +definitionViewTarget (PreludeDefinitionView _identity target) = + target + +blockMarkerText :: Raw.Block -> Maybe Text +blockMarkerText = fmap (\(Raw.Marker marker) -> marker) . \case + Raw.BlockAxiom _location _title marker _axiom -> Just marker + Raw.BlockClaim _kind _location _title marker _claim -> Just marker + Raw.BlockDefn _location _title marker _definition -> Just marker + Raw.BlockAbbr _location _title marker _abbreviation -> Just marker + Raw.BlockData _location _title marker _datatype -> Just marker + Raw.BlockInductive _location _title marker _inductive -> Just marker + Raw.BlockSig _location _title marker _assumptions _signature -> Just marker + Raw.BlockStruct _location _title marker _structure -> Just marker + Raw.BlockProof{} -> Nothing + +expectedSuccessorBody :: CanonicalTerm ObjectId +expectedSuccessorBody = + CLam TySet + (canonicalSetInsert (CBound 0) (CBound 0)) + +expectedInductiveBody :: ObjectId -> CanonicalTerm ObjectId +expectedInductiveBody successor = + CLam TySet + (logicalAnd + (memberTerm (CIntrinsic Empty) (CBound 0)) + (CForall TySet + (CImp + (memberTerm (CBound 0) (CBound 1)) + (memberTerm + (CApp (CGlobal successor) (CBound 0)) + (CBound 1))))) + +expectedOmegaBody + :: ObjectId + -> ObjectId + -> CanonicalTerm ObjectId +expectedOmegaBody u0 inductive = + CApp + (CApp (CIntrinsic Sep) (CGlobal u0)) + (CLam TySet + (CForall TySet + (CImp + (CApp (CGlobal inductive) (CBound 0)) + (memberTerm (CBound 1) (CBound 0))))) + +expectedMinimality + :: ObjectId + -> ObjectId + -> CanonicalTerm ObjectId +expectedMinimality inductive omega = + CForall TySet + (CImp + (CApp (CGlobal inductive) (CBound 0)) + (CForall TySet + (CImp + (memberTerm (CBound 0) (CGlobal omega)) + (memberTerm (CBound 0) (CBound 1))))) + +applyIntrinsic + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic intrinsic argument = + CApp (CIntrinsic intrinsic) argument + +applyIntrinsic2 + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic2 intrinsic firstArgument secondArgument = + CApp + (CApp (CIntrinsic intrinsic) firstArgument) + secondArgument + +memberTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +memberTerm = + applyIntrinsic2 Member + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + CImp + (CImp left (CImp right CFalsum)) + CFalsum diff --git a/source/Felix/Checking/Foundation.hs b/source/Felix/Checking/Foundation.hs new file mode 100644 index 0000000..5852901 --- /dev/null +++ b/source/Felix/Checking/Foundation.hs @@ -0,0 +1,1037 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The one compiled monomorphic HOL/HOTG foundation. +-- +-- Constructing 'CheckedFoundation' requires exact manifest coverage, closed +-- well-typed schemas, and structural backend classification. This gate +-- certifies manifest conformance only; it is not a consistency proof. +module Felix.Checking.Foundation + ( FoundationAxiomTag(..) + , KernelRuleTag(..) + , KernelRuleSignature(..) + , FoundationRuleInput(..) + , FoundationBackendClass(..) + , FofExclusion(..) + , FoundationAxiomInput(..) + , FoundationManifestError(..) + , FoundationManifestAudit + , auditFoundationManifest + , compiledFoundationIntrinsicRows + , compiledFoundationRuleRows + , compiledFoundationAxiomRows + , CheckedFoundation + , checkedFoundation + , foundationAxiomProposition + , foundationAxiomFrozen + , foundationAxiomBackendClass + , foundationRuleSignature + , foundationAxiomDependencies + , classifyCanonicalFofStructure + , classifyFrozenCore + ) where + +import Base hiding (Empty) +import Felix.Checking.Core + +import Control.Monad (unless) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The complete axiom inventory. Ordinary implication, quantifier, equality, +-- and falsum rules are dedicated kernel operations rather than manifest rows. +data FoundationAxiomTag + = EmptyCharacteristic + | PairSetCharacteristic + | FamilyUnionCharacteristic + | PowerSetCharacteristic + | SeparationCharacteristic + | ReplacementCharacteristic + | SetChooseWitness + | SetExtensionality + | SetInduction + | PropositionalExtensionality + | DoubleNegationElim + | UnivOfContains + | UnivOfTransitive + | UnivOfFamilyUnionClosed + | UnivOfPowerSetClosed + | UnivOfReplacementClosed + | UnivOfMinimal + deriving stock (Show, Eq, Ord, Enum, Bounded) + +-- | The complete guarded-rule inventory. +data KernelRuleTag + = SetLfpBound + | SetLfpLeast + | SetLfpFixed + | SetLfpInduct + deriving stock (Show, Eq, Ord, Enum, Bounded) + +data KernelRuleSignature = KernelRuleSignature + ![CoreType] + !Natural + deriving stock (Show, Eq) + +data FoundationRuleInput = FoundationRuleInput + !KernelRuleTag + !KernelRuleSignature + deriving stock (Show, Eq) + +data FofExclusion + = HigherOrderBinder !CoreType + | HigherOrderEquality !CoreType + | HigherOrderLambda + | HigherOrderIntrinsic !CoreIntrinsicTag + deriving stock (Show, Eq, Ord) + +data FoundationBackendClass + = FoundationFofProjectable + | FoundationRequiresTh0 !(NonEmpty FofExclusion) + deriving stock (Show, Eq) + +-- | One proposed manifest row. This is deliberately not an authority-bearing +-- fact; only the fixed compiled rows can produce 'CheckedFoundation'. +data FoundationAxiomInput = FoundationAxiomInput + !FoundationAxiomTag + !(CoreSyntax Void Natural) + !FoundationBackendClass + +data FoundationManifestError + = MissingFoundationIntrinsic !CoreIntrinsicTag + | DuplicateFoundationIntrinsic !CoreIntrinsicTag + | FoundationIntrinsicTypeMismatch + !CoreIntrinsicTag + !CoreType + !CoreType + | MissingFoundationRule !KernelRuleTag + | DuplicateFoundationRule !KernelRuleTag + | FoundationRuleSignatureMismatch + !KernelRuleTag + !KernelRuleSignature + !KernelRuleSignature + | MissingFoundationAxiom !FoundationAxiomTag + | DuplicateFoundationAxiom !FoundationAxiomTag + | FoundationAxiomIllTyped + !FoundationAxiomTag + !CoreCheckError + | FoundationAxiomFreezeFailed + !FoundationAxiomTag + !FreezeError + | FoundationAxiomStatementMismatch + !FoundationAxiomTag + | FoundationAxiomBackendClassMismatch + !FoundationAxiomTag + !FoundationBackendClass + !FoundationBackendClass + deriving stock (Show, Eq) + +data CheckedFoundationAxiom = CheckedFoundationAxiom + !(ClosedCheckedProposition Void) + !(FrozenCheckedCore Void) + !FoundationBackendClass + +newtype FoundationManifestAudit = FoundationManifestAudit + ( Map FoundationAxiomTag CheckedFoundationAxiom + , Map KernelRuleTag KernelRuleSignature + ) + +data CheckedFoundation = CheckedFoundation + !(Map FoundationAxiomTag CheckedFoundationAxiom) + !(Map KernelRuleTag KernelRuleSignature) + + +compiledFoundationIntrinsicRows + :: [(CoreIntrinsicTag, CoreType)] +compiledFoundationIntrinsicRows = + [ (Member, TySet `TyArrow` (TySet `TyArrow` TyProp)) + , (Empty, TySet) + , (PairSet, TySet `TyArrow` (TySet `TyArrow` TySet)) + , (FamilyUnion, TySet `TyArrow` TySet) + , (PowerSet, TySet `TyArrow` TySet) + , ( Sep + , TySet + `TyArrow` + ((TySet `TyArrow` TyProp) `TyArrow` TySet) + ) + , ( Repl + , TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + ) + , (SetChoose, (TySet `TyArrow` TyProp) `TyArrow` TySet) + , (UnivOf, TySet `TyArrow` TySet) + , ( ISetLfp + , TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + ) + ] + +compiledFoundationRuleRows :: [FoundationRuleInput] +compiledFoundationRuleRows = + [ FoundationRuleInput + tag + (expectedKernelRuleSignature tag) + | tag <- allKernelRuleTags + ] + +compiledFoundationAxiomRows :: [FoundationAxiomInput] +compiledFoundationAxiomRows = + [ FoundationAxiomInput + tag + (foundationAxiomSyntax tag) + (expectedFoundationBackendClass tag) + | tag <- allFoundationAxiomTags + ] + +checkedFoundation + :: Either + (NonEmpty FoundationManifestError) + CheckedFoundation +checkedFoundation = do + FoundationManifestAudit (axioms, rules) <- + auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + compiledFoundationAxiomRows + pure (CheckedFoundation axioms rules) + +-- | Audit arbitrary proposed rows without granting foundation authority. +-- This is also the pure mutation boundary used by conformance tests. +auditFoundationManifest + :: [(CoreIntrinsicTag, CoreType)] + -> [FoundationRuleInput] + -> [FoundationAxiomInput] + -> Either + (NonEmpty FoundationManifestError) + FoundationManifestAudit +auditFoundationManifest intrinsicRows ruleRows axiomRows = + case + intrinsicErrors + <> ruleErrors + <> axiomCoverageErrors + <> axiomErrors of + [] -> + case checkedRows of + Left errors -> + Left errors + Right rows -> + Right + (FoundationManifestAudit + ( Map.fromList rows + , Map.fromList + [ (tag, signature) + | FoundationRuleInput + tag + signature <- + ruleRows + ] + )) + firstError : remainingErrors -> + Left (firstError :| remainingErrors) + where + intrinsicErrors = + coverageErrors + MissingFoundationIntrinsic + DuplicateFoundationIntrinsic + allCoreIntrinsicTags + (fst <$> intrinsicRows) + <> [ FoundationIntrinsicTypeMismatch + tag + (coreIntrinsicType tag) + actual + | (tag, actual) <- intrinsicRows + , actual /= coreIntrinsicType tag + ] + axiomCoverageErrors = + coverageErrors + MissingFoundationAxiom + DuplicateFoundationAxiom + allFoundationAxiomTags + [ tag + | FoundationAxiomInput tag _syntax _backendClass <- + axiomRows + ] + ruleErrors = + coverageErrors + MissingFoundationRule + DuplicateFoundationRule + allKernelRuleTags + [ tag + | FoundationRuleInput tag _signature <- + ruleRows + ] + <> [ FoundationRuleSignatureMismatch + tag + (expectedKernelRuleSignature tag) + actual + | FoundationRuleInput tag actual <- + ruleRows + , actual /= expectedKernelRuleSignature tag + ] + checkedRows = + traverse checkAxiomRow axiomRows + axiomErrors = + case checkedRows of + Left errors -> + toList errors + Right _rows -> + [] + +checkAxiomRow + :: FoundationAxiomInput + -> Either + (NonEmpty FoundationManifestError) + (FoundationAxiomTag, CheckedFoundationAxiom) +checkAxiomRow + (FoundationAxiomInput + tag + syntax + declaredBackendClass) = do + proposition <- + firstOne (FoundationAxiomIllTyped tag) + (checkClosedProposition absurd syntax) + frozen <- + firstOne (FoundationAxiomFreezeFailed tag) + (freezeClosed + (checkedPropositionCore proposition)) + expectedFrozen <- + expectedFoundationAxiom tag + unless + (frozen == expectedFrozen) + (Left + (FoundationAxiomStatementMismatch tag :| [])) + let actualBackendClass = + classifyFrozenCore frozen + unless + (declaredBackendClass == actualBackendClass) + (Left + (FoundationAxiomBackendClassMismatch + tag + declaredBackendClass + actualBackendClass + :| [])) + pure + ( tag + , CheckedFoundationAxiom + proposition + frozen + actualBackendClass + ) + +expectedFoundationAxiom + :: FoundationAxiomTag + -> Either + (NonEmpty FoundationManifestError) + (FrozenCheckedCore Void) +expectedFoundationAxiom tag = do + proposition <- + firstOne (FoundationAxiomIllTyped tag) + (checkClosedProposition + absurd + (foundationAxiomSyntax tag)) + firstOne (FoundationAxiomFreezeFailed tag) + (freezeClosed + (checkedPropositionCore proposition)) + +foundationAxiomProposition + :: CheckedFoundation + -> FoundationAxiomTag + -> ClosedCheckedProposition Void +foundationAxiomProposition foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom proposition _frozen _backendClass -> + proposition + +foundationAxiomFrozen + :: CheckedFoundation + -> FoundationAxiomTag + -> FrozenCheckedCore Void +foundationAxiomFrozen foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom _proposition frozen _backendClass -> + frozen + +foundationAxiomBackendClass + :: CheckedFoundation + -> FoundationAxiomTag + -> FoundationBackendClass +foundationAxiomBackendClass foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom _proposition _frozen backendClass -> + backendClass + +lookupFoundationAxiom + :: CheckedFoundation + -> FoundationAxiomTag + -> CheckedFoundationAxiom +lookupFoundationAxiom + (CheckedFoundation axioms _rules) + tag = + case Map.lookup tag axioms of + Just axiom -> + axiom + Nothing -> + impossible + "checked foundation omitted a validated axiom tag" + +foundationRuleSignature + :: CheckedFoundation + -> KernelRuleTag + -> KernelRuleSignature +foundationRuleSignature + (CheckedFoundation _axioms rules) + tag = + case Map.lookup tag rules of + Just signature -> + signature + Nothing -> + impossible + "checked foundation omitted a validated kernel rule" + + +classifyFrozenCore + :: FrozenCheckedCore global + -> FoundationBackendClass +classifyFrozenCore = + classifyCanonicalFofStructure + . frozenCoreTerm + +classifyCanonicalFofStructure + :: CanonicalTerm global + -> FoundationBackendClass +classifyCanonicalFofStructure term = + case Set.toAscList + (termFofExclusions + term) of + [] -> + FoundationFofProjectable + firstExclusion : remainingExclusions -> + FoundationRequiresTh0 + (firstExclusion :| remainingExclusions) + +foundationAxiomDependencies + :: CanonicalTerm global + -> Set FoundationAxiomTag +foundationAxiomDependencies = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic -> + intrinsicFoundationAxioms intrinsic + COpaqueInteger{} -> + mempty + CApp function argument -> + foundationAxiomDependencies function + <> foundationAxiomDependencies argument + CLam _binderType body -> + foundationAxiomDependencies body + CFalsum -> + mempty + CImp premise conclusion -> + foundationAxiomDependencies premise + <> foundationAxiomDependencies conclusion + CEq _operandType left right -> + foundationAxiomDependencies left + <> foundationAxiomDependencies right + CForall _binderType body -> + foundationAxiomDependencies body + +intrinsicFoundationAxioms + :: CoreIntrinsicTag + -> Set FoundationAxiomTag +intrinsicFoundationAxioms = Set.fromList . \case + Member -> + [] + Empty -> + [EmptyCharacteristic] + PairSet -> + [PairSetCharacteristic] + FamilyUnion -> + [FamilyUnionCharacteristic] + PowerSet -> + [PowerSetCharacteristic] + Sep -> + [SeparationCharacteristic] + Repl -> + [ReplacementCharacteristic] + SetChoose -> + [SetChooseWitness] + UnivOf -> + [] + ISetLfp -> + [] + +termFofExclusions + :: CanonicalTerm global + -> Set FofExclusion +termFofExclusions = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic + | intrinsic `elem` + [Sep, Repl, SetChoose, ISetLfp] -> + Set.singleton + (HigherOrderIntrinsic intrinsic) + | otherwise -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + termFofExclusions function + <> termFofExclusions argument + CLam _binderType body -> + Set.insert HigherOrderLambda + (termFofExclusions body) + CFalsum -> + mempty + CImp premise conclusion -> + termFofExclusions premise + <> termFofExclusions conclusion + CEq operandType left right -> + (case operandType of + TyArrow{} -> + Set.singleton + (HigherOrderEquality operandType) + _ -> + mempty) + <> termFofExclusions left + <> termFofExclusions right + CForall binderType body -> + (case binderType of + TySet -> + mempty + _ -> + Set.singleton + (HigherOrderBinder binderType)) + <> termFofExclusions body + + +allCoreIntrinsicTags :: [CoreIntrinsicTag] +allCoreIntrinsicTags = + [minBound .. maxBound] + +allFoundationAxiomTags :: [FoundationAxiomTag] +allFoundationAxiomTags = + [minBound .. maxBound] + +allKernelRuleTags :: [KernelRuleTag] +allKernelRuleTags = + [minBound .. maxBound] + +expectedKernelRuleSignature + :: KernelRuleTag + -> KernelRuleSignature +expectedKernelRuleSignature = \case + SetLfpBound -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 0 + SetLfpLeast -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet, TySet] + 2 + SetLfpFixed -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 1 + SetLfpInduct -> + KernelRuleSignature + [ TySet + , TySet `TyArrow` TySet + , TySet `TyArrow` TyProp + , TySet + ] + 3 + +coverageErrors + :: Ord tag + => (tag -> error) + -> (tag -> error) + -> [tag] + -> [tag] + -> [error] +coverageErrors missing duplicate expected actual = + [ missing tag + | tag <- expected + , occurrenceCount tag == 0 + ] + <> [ duplicate tag + | tag <- expected + , occurrenceCount tag > 1 + ] + where + occurrenceCount tag = + length (List.filter (== tag) actual) + +firstOne + :: (error -> FoundationManifestError) + -> Either error value + -> Either (NonEmpty FoundationManifestError) value +firstOne wrap = + either + (Left . (:| []) . wrap) + Right + + +type FoundationSyntax = CoreSyntax Void Natural + +foundationAxiomSyntax + :: FoundationAxiomTag + -> FoundationSyntax +foundationAxiomSyntax = \case + EmptyCharacteristic -> + foralls + [(x, TySet)] + (iff + (member (var x) emptySet) + coreFalsum) + PairSetCharacteristic -> + foralls + [(a, TySet), (b, TySet), (x, TySet)] + (iff + (member + (var x) + (pairSet (var a) (var b))) + (orP + (eqSet (var x) (var a)) + (eqSet (var x) (var b)))) + FamilyUnionCharacteristic -> + foralls + [(a, TySet), (x, TySet)] + (iff + (member + (var x) + (familyUnion (var a))) + (exists + b + TySet + (andP + (member (var b) (var a)) + (member (var x) (var b))))) + PowerSetCharacteristic -> + foralls + [(a, TySet), (b, TySet)] + (iff + (member + (var b) + (powerSet (var a))) + (subset (var b) (var a))) + SeparationCharacteristic -> + foralls + [ (a, TySet) + , (p, TySet `TyArrow` TyProp) + , (x, TySet) + ] + (iff + (member + (var x) + (separation (var a) (var p))) + (andP + (member (var x) (var a)) + (apply (var p) (var x)))) + ReplacementCharacteristic -> + foralls + [ (a, TySet) + , (f, TySet `TyArrow` TySet) + , (y, TySet) + ] + (iff + (member + (var y) + (replacement (var a) (var f))) + (exists + x + TySet + (andP + (member (var x) (var a)) + (eqSet + (var y) + (apply (var f) (var x)))))) + SetChooseWitness -> + foralls + [ (p, TySet `TyArrow` TyProp) + , (x, TySet) + ] + (implies + (apply (var p) (var x)) + (apply + (var p) + (setChoose (var p)))) + SetExtensionality -> + foralls + [(a, TySet), (b, TySet)] + (implies + (subset (var a) (var b)) + (implies + (subset (var b) (var a)) + (eqSet (var a) (var b)))) + SetInduction -> + forallOne + p + (TySet `TyArrow` TyProp) + (implies + (forallOne + a + TySet + (implies + (forallOne + x + TySet + (implies + (member (var x) (var a)) + (apply (var p) (var x)))) + (apply (var p) (var a)))) + (forallOne + a + TySet + (apply (var p) (var a)))) + PropositionalExtensionality -> + foralls + [(p, TyProp), (q, TyProp)] + (implies + (implies (var p) (var q)) + (implies + (implies (var q) (var p)) + (coreEquality + TyProp + (var p) + (var q)))) + DoubleNegationElim -> + forallOne + p + TyProp + (implies + (notP (notP (var p))) + (var p)) + UnivOfContains -> + forallOne + n + TySet + (member + (var n) + (univOf (var n))) + UnivOfTransitive -> + forallOne + n + TySet + (transitive (univOf (var n))) + UnivOfFamilyUnionClosed -> + forallOne + n + TySet + (familyUnionClosed + (univOf (var n))) + UnivOfPowerSetClosed -> + forallOne + n + TySet + (powerSetClosed + (univOf (var n))) + UnivOfReplacementClosed -> + forallOne + n + TySet + (replacementClosed + (univOf (var n))) + UnivOfMinimal -> + foralls + [(n, TySet), (u, TySet)] + (implies + (member (var n) (var u)) + (implies + (transitive (var u)) + (implies + (familyUnionClosed (var u)) + (implies + (powerSetClosed (var u)) + (implies + (replacementClosed (var u)) + (subset + (univOf (var n)) + (var u))))))) + +expectedFoundationBackendClass + :: FoundationAxiomTag + -> FoundationBackendClass +expectedFoundationBackendClass = \case + EmptyCharacteristic -> + FoundationFofProjectable + PairSetCharacteristic -> + FoundationFofProjectable + FamilyUnionCharacteristic -> + FoundationFofProjectable + PowerSetCharacteristic -> + FoundationFofProjectable + SeparationCharacteristic -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [HigherOrderIntrinsic Sep] + ReplacementCharacteristic -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + SetChooseWitness -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [HigherOrderIntrinsic SetChoose] + SetExtensionality -> + FoundationFofProjectable + SetInduction -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [] + PropositionalExtensionality -> + requiresTh0 + (HigherOrderBinder TyProp) + [] + DoubleNegationElim -> + requiresTh0 + (HigherOrderBinder TyProp) + [] + UnivOfContains -> + FoundationFofProjectable + UnivOfTransitive -> + FoundationFofProjectable + UnivOfFamilyUnionClosed -> + FoundationFofProjectable + UnivOfPowerSetClosed -> + FoundationFofProjectable + UnivOfReplacementClosed -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + UnivOfMinimal -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + where + requiresTh0 firstExclusion remainingExclusions = + FoundationRequiresTh0 + (firstExclusion :| remainingExclusions) + + +x, y, a, b, p, q, f, n, u :: Natural +x = 0 +y = 1 +a = 2 +b = 3 +p = 4 +q = 5 +f = 6 +n = 7 +u = 8 + +var :: Natural -> FoundationSyntax +var = coreLocal + +apply + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +apply = coreApply + +apply2 + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +apply2 function firstArgument secondArgument = + apply + (apply function firstArgument) + secondArgument + +member + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +member = + apply2 (coreIntrinsic Member) + +emptySet :: FoundationSyntax +emptySet = + coreIntrinsic Empty + +pairSet + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +pairSet = + apply2 (coreIntrinsic PairSet) + +familyUnion :: FoundationSyntax -> FoundationSyntax +familyUnion = + apply (coreIntrinsic FamilyUnion) + +powerSet :: FoundationSyntax -> FoundationSyntax +powerSet = + apply (coreIntrinsic PowerSet) + +separation + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +separation = + apply2 (coreIntrinsic Sep) + +replacement + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +replacement = + apply2 (coreIntrinsic Repl) + +setChoose :: FoundationSyntax -> FoundationSyntax +setChoose = + apply (coreIntrinsic SetChoose) + +univOf :: FoundationSyntax -> FoundationSyntax +univOf = + apply (coreIntrinsic UnivOf) + +implies + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +implies = + coreImplication + +notP :: FoundationSyntax -> FoundationSyntax +notP proposition = + implies proposition coreFalsum + +andP + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +andP left right = + notP + (implies left (notP right)) + +orP + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +orP left right = + implies (notP left) right + +iff + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +iff = + coreEquality TyProp + +eqSet + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +eqSet = + coreEquality TySet + +forallOne + :: Natural + -> CoreType + -> FoundationSyntax + -> FoundationSyntax +forallOne local binderType = + coreForall binderType local + +foralls + :: [(Natural, CoreType)] + -> FoundationSyntax + -> FoundationSyntax +foralls binders body = + foldr + (uncurry forallOne) + body + binders + +exists + :: Natural + -> CoreType + -> FoundationSyntax + -> FoundationSyntax +exists local binderType body = + notP + (forallOne + local + binderType + (notP body)) + +subset + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +subset left right = + forallOne + x + TySet + (implies + (member (var x) left) + (member (var x) right)) + +transitive :: FoundationSyntax -> FoundationSyntax +transitive universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (subset (var a) universe)) + +familyUnionClosed :: FoundationSyntax -> FoundationSyntax +familyUnionClosed universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (member + (familyUnion (var a)) + universe)) + +powerSetClosed :: FoundationSyntax -> FoundationSyntax +powerSetClosed universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (member + (powerSet (var a)) + universe)) + +replacementClosed :: FoundationSyntax -> FoundationSyntax +replacementClosed universe = + foralls + [ (a, TySet) + , (f, TySet `TyArrow` TySet) + ] + (implies + (member (var a) universe) + (implies + (forallOne + x + TySet + (implies + (member (var x) (var a)) + (member + (apply (var f) (var x)) + universe))) + (member + (replacement (var a) (var f)) + universe))) diff --git a/source/Felix/Checking/Identity.hs b/source/Felix/Checking/Identity.hs new file mode 100644 index 0000000..67347a3 --- /dev/null +++ b/source/Felix/Checking/Identity.hs @@ -0,0 +1,1023 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Content-addressed identities for checked mathematical content. +module Felix.Checking.Identity + ( TheoryId + , theoryId + , theoryIdDigest + , encodeFoundationManifest + , foundationManifestTags + , encodeKernelRuleTag + , ObjectFamily(..) + , ObjectId + , objectId + , objectIdFamily + , objectIdDigest + , encodeObjectId + , OpaqueDeclarationSeed + , opaqueDeclarationSeed + , opaqueDeclarationSeedDigest + , ObjectContent(..) + , objectContentTheory + , objectContentType + , intrinsicObjectId + , transparentObjectId + , opaqueObjectId + , AssertedObject + , assertedObject + , assertedObjectId + , assertedObjectContent + , CheckedObjectClosure + , checkedObjectClosureTheory + , checkedObjectIds + , lookupCheckedObjectType + , lookupCheckedObjectContent + , validateObjectClosure + , extendObjectClosure + , ObjectValidationError(..) + , PropositionId + , propositionIdDigest + , CheckedPropositionContent + , checkedPropositionId + , checkedPropositionTerm + , validatePropositionContent + , validateAssertedPropositionContent + , propositionIdOf + , PropositionValidationError(..) + , TheoremRef + , theoremRef + , theoremRefTheory + , theoremRefProposition + , encodeTheoremRef + , TheoremId + , theoremId + , theoremIdDigest + , putTheoryIdCache + , getTheoryIdCache + , putObjectIdCache + , getObjectIdCache + , putObjectContentCache + , getObjectContentCache + , putPropositionIdCache + , getPropositionIdCache + , putTheoremRefCache + , getTheoremRefCache + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module + +import Control.DeepSeq (NFData) +import Control.Monad.State.Strict +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Word (Word8) + + +newtype TheoryId = + TheoryId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +theoryId :: CheckedFoundation -> TheoryId +theoryId foundation = + TheoryId + (codecInvariant + (hashCanonicalFields + "felix-theory" + [encodeFoundationManifest foundation])) + +theoryIdDigest :: TheoryId -> MathematicalDigest +theoryIdDigest (TheoryId digest) = + digest + +-- | Canonical ordered intrinsic/rule/axiom manifest. Backend classification is +-- intentionally absent. +encodeFoundationManifest :: CheckedFoundation -> ByteString +encodeFoundationManifest foundation = + codecInvariant + (encodeSequence + [ codecInvariant (encodeSequence intrinsicRows) + , codecInvariant (encodeSequence ruleRows) + , codecInvariant (encodeSequence axiomRows) + ]) + where + (intrinsicTags, ruleTags, axiomTags) = + foundationManifestTags + + intrinsicRows = + [ encodeCoreIntrinsicTag tag + <> encodeFrame (encodeCoreType (coreIntrinsicType tag)) + | tag <- intrinsicTags + ] + + ruleRows = + [ encodeKernelRuleTag tag + <> encodeFrame + (codecInvariant + (encodeSequence + (encodeCoreType <$> inputTypes))) + <> encodeFrame (encodeNatural binderCount) + | tag <- ruleTags + , let KernelRuleSignature inputTypes binderCount = + foundationRuleSignature foundation tag + ] + + axiomRows = + [ encodeFoundationAxiomTag tag + <> encodeFrame + (encodeCanonicalTerm + absurd + (frozenCoreTerm + (foundationAxiomFrozen foundation tag))) + | tag <- axiomTags + ] + +-- | Exhaustive foundation inventories in their stable encoded-tag order. +foundationManifestTags + :: ( [CoreIntrinsicTag] + , [KernelRuleTag] + , [FoundationAxiomTag] + ) +foundationManifestTags = + ( stableTagOrder + "core intrinsic" + encodeCoreIntrinsicTag + allCoreIntrinsicTags + , stableTagOrder + "kernel rule" + encodeKernelRuleTag + allKernelRuleTags + , stableTagOrder + "foundation axiom" + encodeFoundationAxiomTag + allFoundationAxiomTags + ) + + +data ObjectFamily + = IntrinsicObject + | TransparentObject + | OpaqueObject + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +data ObjectId = ObjectId + !ObjectFamily + !MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +objectId + :: ObjectFamily + -> MathematicalDigest + -> ObjectId +objectId = + ObjectId + +objectIdFamily :: ObjectId -> ObjectFamily +objectIdFamily (ObjectId family _digest) = + family + +objectIdDigest :: ObjectId -> MathematicalDigest +objectIdDigest (ObjectId _family digest) = + digest + +encodeObjectId :: ObjectId -> ByteString +encodeObjectId (ObjectId family digest) = + ByteString.singleton (objectFamilyTag family) + <> mathematicalDigestBytes digest + + +newtype OpaqueDeclarationSeed = + OpaqueDeclarationSeed MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +opaqueDeclarationSeed + :: ModuleName + -> LocalDeclarationOrdinal + -> DeclarationFamilyTag + -> GeneratedObjectSlot + -> OpaqueDeclarationSeed +opaqueDeclarationSeed + owner + declarationOrdinal + family + generatedSlot = + OpaqueDeclarationSeed + (codecInvariant + (hashCanonicalFields + "felix-opaque-declaration-v1" + [ encodeModuleName owner + , encodeNatural + (localDeclarationOrdinalValue + declarationOrdinal) + , encodeDeclarationFamilyTag family + , encodeNatural + (generatedObjectSlotValue + generatedSlot) + ])) + +opaqueDeclarationSeedDigest + :: OpaqueDeclarationSeed + -> MathematicalDigest +opaqueDeclarationSeedDigest + (OpaqueDeclarationSeed digest) = + digest + + +data ObjectContent + = IntrinsicObjectContent + !TheoryId + !CoreIntrinsicTag + !CoreType + | TransparentObjectContent + !TheoryId + !CoreType + !(CanonicalTerm ObjectId) + | OpaqueObjectContent + !TheoryId + !OpaqueDeclarationSeed + !CoreType + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +objectContentTheory :: ObjectContent -> TheoryId +objectContentTheory = \case + IntrinsicObjectContent identity _tag _coreType -> + identity + TransparentObjectContent identity _coreType _body -> + identity + OpaqueObjectContent identity _seed _coreType -> + identity + +objectContentType :: ObjectContent -> CoreType +objectContentType = \case + IntrinsicObjectContent _identity _tag coreType -> + coreType + TransparentObjectContent _identity coreType _body -> + coreType + OpaqueObjectContent _identity _seed coreType -> + coreType + +intrinsicObjectId + :: TheoryId + -> CoreIntrinsicTag + -> CoreType + -> ObjectId +intrinsicObjectId identity tag coreType = + ObjectId + IntrinsicObject + (codecInvariant + (hashCanonicalFields + "felix-intrinsic-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , encodeCoreIntrinsicTag tag + , encodeCoreType coreType + ])) + +transparentObjectId + :: TheoryId + -> CoreType + -> CanonicalTerm ObjectId + -> ObjectId +transparentObjectId identity coreType body = + ObjectId + TransparentObject + (codecInvariant + (hashCanonicalFields + "felix-transparent-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , encodeCoreType coreType + , encodeCanonicalTerm encodeObjectId body + ])) + +opaqueObjectId + :: TheoryId + -> OpaqueDeclarationSeed + -> CoreType + -> ObjectId +opaqueObjectId identity seed coreType = + ObjectId + OpaqueObject + (codecInvariant + (hashCanonicalFields + "felix-opaque-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , mathematicalDigestBytes + (opaqueDeclarationSeedDigest seed) + , encodeCoreType coreType + ])) + + +data AssertedObject = AssertedObject + !ObjectId + !ObjectContent + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +assertedObject :: ObjectId -> ObjectContent -> AssertedObject +assertedObject = + AssertedObject + +assertedObjectId :: AssertedObject -> ObjectId +assertedObjectId (AssertedObject identity _content) = + identity + +assertedObjectContent :: AssertedObject -> ObjectContent +assertedObjectContent (AssertedObject _identity content) = + content + +data CheckedObject = CheckedObject + !ObjectContent + !CoreType + +data CheckedObjectClosure = CheckedObjectClosure + !TheoryId + !(Map ObjectId CheckedObject) + +checkedObjectClosureTheory :: CheckedObjectClosure -> TheoryId +checkedObjectClosureTheory (CheckedObjectClosure identity _objects) = + identity + +checkedObjectIds :: CheckedObjectClosure -> Set ObjectId +checkedObjectIds (CheckedObjectClosure _identity objects) = + Map.keysSet objects + +lookupCheckedObjectType + :: ObjectId + -> CheckedObjectClosure + -> Maybe CoreType +lookupCheckedObjectType identity + (CheckedObjectClosure _theory objects) = + checkedObjectType + <$> Map.lookup identity objects + +lookupCheckedObjectContent + :: ObjectId + -> CheckedObjectClosure + -> Maybe ObjectContent +lookupCheckedObjectContent identity + (CheckedObjectClosure _theory objects) = + checkedObjectContent + <$> Map.lookup identity objects + +checkedObjectType :: CheckedObject -> CoreType +checkedObjectType (CheckedObject _content coreType) = + coreType + +checkedObjectContent :: CheckedObject -> ObjectContent +checkedObjectContent (CheckedObject content _coreType) = + content + + +data ObjectValidationError + = DuplicateAssertedObjectId !ObjectId + | ObjectContentTheoryMismatch + !ObjectId + !TheoryId + !TheoryId + | ObjectContentFamilyMismatch + !ObjectId + !ObjectFamily + !ObjectFamily + | IntrinsicObjectTypeMismatch + !ObjectId + !CoreIntrinsicTag + !CoreType + !CoreType + | TransparentObjectReferenceMissing + !ObjectId + !ObjectId + | TransparentObjectCycle !(NonEmpty ObjectId) + | TransparentObjectCoreCheckError + !ObjectId + !CoreCheckError + | TransparentObjectTypeMismatch + !ObjectId + !CoreType + !CoreType + | ObjectIdPayloadMismatch + !ObjectId + !ObjectId + deriving stock (Show, Eq) + +data ObjectValidationState = ObjectValidationState + { validationStack :: ![ObjectId] + , validatedObjects :: !(Map ObjectId CheckedObject) + } + +validateObjectClosure + :: TheoryId + -> [AssertedObject] + -> Either ObjectValidationError CheckedObjectClosure +validateObjectClosure expectedTheory asserted = do + inventory <- buildObjectInventory asserted + finalState <- + execStateT + (traverse_ (validateOneObject expectedTheory inventory) + (Map.keys inventory)) + (ObjectValidationState [] Map.empty) + pure + (CheckedObjectClosure + expectedTheory + (validatedObjects finalState)) + +-- | Validate one declaration's new objects against an already checked +-- closure. The existing closure is returned unchanged for an empty batch. +extendObjectClosure + :: CheckedObjectClosure + -> [AssertedObject] + -> Either ObjectValidationError CheckedObjectClosure +extendObjectClosure closure [] = + Right closure +extendObjectClosure + (CheckedObjectClosure expectedTheory existing) + asserted = do + additions <- buildObjectInventory asserted + traverse_ + (\identity -> + when + (Map.member identity existing) + (Left (DuplicateAssertedObjectId identity))) + (Map.keys additions) + let existingInventory = + checkedObjectContent <$> existing + inventory = + Map.union additions existingInventory + finalState <- + execStateT + (traverse_ + (validateOneObject expectedTheory inventory) + (Map.keys additions)) + (ObjectValidationState [] existing) + pure + (CheckedObjectClosure + expectedTheory + (validatedObjects finalState)) + +buildObjectInventory + :: [AssertedObject] + -> Either ObjectValidationError (Map ObjectId ObjectContent) +buildObjectInventory = + foldM insertOne Map.empty + where + insertOne inventory (AssertedObject identity content) + | Map.member identity inventory = + Left (DuplicateAssertedObjectId identity) + | otherwise = + Right (Map.insert identity content inventory) + +validateOneObject + :: TheoryId + -> Map ObjectId ObjectContent + -> ObjectId + -> StateT + ObjectValidationState + (Either ObjectValidationError) + () +validateOneObject expectedTheory inventory identity = do + alreadyValidated <- + gets (Map.member identity . validatedObjects) + unless alreadyValidated do + stack <- gets validationStack + when (identity `elem` stack) do + lift + (Left + (TransparentObjectCycle + (cyclePath identity stack))) + content <- + case Map.lookup identity inventory of + Nothing -> + impossible + "object validation root is absent from its inventory" + Just found -> + pure found + unless + (objectContentTheory content == expectedTheory) + (lift + (Left + (ObjectContentTheoryMismatch + identity + expectedTheory + (objectContentTheory content)))) + let expectedFamily = + objectContentFamily content + suppliedFamily = + objectIdFamily identity + unless + (suppliedFamily == expectedFamily) + (lift + (Left + (ObjectContentFamilyMismatch + identity + expectedFamily + suppliedFamily))) + modify' + (\validationState -> + validationState + { validationStack = + identity + : validationStack validationState + }) + checked <- case content of + IntrinsicObjectContent + theory + tag + suppliedType -> do + let expectedType = + coreIntrinsicType tag + unless + (suppliedType == expectedType) + (lift + (Left + (IntrinsicObjectTypeMismatch + identity + tag + expectedType + suppliedType))) + verifyObjectId + identity + (intrinsicObjectId + theory + tag + suppliedType) + pure + (CheckedObject content suppliedType) + TransparentObjectContent + theory + suppliedType + body -> do + traverse_ + (validateDependency expectedTheory inventory identity) + (Set.toAscList (canonicalTermGlobals body)) + resolvedObjects <- + gets validatedObjects + checkedBody <- + lift + (first + (TransparentObjectCoreCheckError + identity) + (checkCanonicalCore + (\reference -> + checkedObjectType + <$> Map.lookup + reference + resolvedObjects) + body)) + let inferredType = + frozenCoreType checkedBody + unless + (inferredType == suppliedType) + (lift + (Left + (TransparentObjectTypeMismatch + identity + suppliedType + inferredType))) + verifyObjectId + identity + (transparentObjectId + theory + suppliedType + body) + pure + (CheckedObject content suppliedType) + OpaqueObjectContent + theory + seed + suppliedType -> do + verifyObjectId + identity + (opaqueObjectId + theory + seed + suppliedType) + pure + (CheckedObject content suppliedType) + modify' + (\validationState -> + validationState + { validationStack = + dropCurrent + identity + (validationStack validationState) + , validatedObjects = + Map.insert + identity + checked + (validatedObjects validationState) + }) + where + verifyObjectId supplied computed = + unless + (supplied == computed) + (lift + (Left + (ObjectIdPayloadMismatch + supplied + computed))) + +validateDependency + :: TheoryId + -> Map ObjectId ObjectContent + -> ObjectId + -> ObjectId + -> StateT + ObjectValidationState + (Either ObjectValidationError) + () +validateDependency expectedTheory inventory parent dependency = + case Map.lookup dependency inventory of + Nothing -> + lift + (Left + (TransparentObjectReferenceMissing + parent + dependency)) + Just _ -> + validateOneObject + expectedTheory + inventory + dependency + +cyclePath :: ObjectId -> [ObjectId] -> NonEmpty ObjectId +cyclePath repeated stack = + case break (== repeated) stack of + (between, _repeated : _outer) -> + repeated :| (reverse between <> [repeated]) + _ -> + impossible "repeated object is absent from validation stack" + +dropCurrent :: ObjectId -> [ObjectId] -> [ObjectId] +dropCurrent expected = \case + current : rest + | current == expected -> + rest + _ -> + impossible "object validation stack is inconsistent" + +objectContentFamily :: ObjectContent -> ObjectFamily +objectContentFamily = \case + IntrinsicObjectContent{} -> + IntrinsicObject + TransparentObjectContent{} -> + TransparentObject + OpaqueObjectContent{} -> + OpaqueObject + +newtype PropositionId = + PropositionId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +propositionIdDigest :: PropositionId -> MathematicalDigest +propositionIdDigest (PropositionId digest) = + digest + +data CheckedPropositionContent = CheckedPropositionContent + !PropositionId + !(FrozenCheckedCore ObjectId) + deriving stock (Generic) + deriving anyclass (NFData) + +checkedPropositionId + :: CheckedPropositionContent + -> PropositionId +checkedPropositionId + (CheckedPropositionContent identity _term) = + identity + +checkedPropositionTerm + :: CheckedPropositionContent + -> FrozenCheckedCore ObjectId +checkedPropositionTerm + (CheckedPropositionContent _identity term) = + term + +data PropositionValidationError + = PropositionObjectMissing !ObjectId + | PropositionCoreCheckError !CoreCheckError + | PropositionIsNotProp !CoreType + | PropositionIdPayloadMismatch + !PropositionId + !PropositionId + deriving stock (Show, Eq) + +validatePropositionContent + :: CheckedObjectClosure + -> CanonicalTerm ObjectId + -> Either + PropositionValidationError + CheckedPropositionContent +validatePropositionContent closure term = do + traverse_ + (\identity -> + unless + (isJust + (lookupCheckedObjectType identity closure)) + (Left (PropositionObjectMissing identity))) + (Set.toAscList (canonicalTermGlobals term)) + checked <- + first PropositionCoreCheckError + (checkCanonicalCore + (\identity -> + lookupCheckedObjectType identity closure) + term) + unless + (frozenCoreType checked == TyProp) + (Left + (PropositionIsNotProp + (frozenCoreType checked))) + let identity = + propositionIdOf term + pure + (CheckedPropositionContent + identity + checked) + +validateAssertedPropositionContent + :: CheckedObjectClosure + -> PropositionId + -> CanonicalTerm ObjectId + -> Either + PropositionValidationError + CheckedPropositionContent +validateAssertedPropositionContent closure supplied term = do + checked <- + validatePropositionContent closure term + let computed = + checkedPropositionId checked + unless + (supplied == computed) + (Left + (PropositionIdPayloadMismatch + supplied + computed)) + pure checked + +propositionIdOf + :: CanonicalTerm ObjectId + -> PropositionId +propositionIdOf term = + PropositionId + (codecInvariant + (hashCanonicalFields + "felix-proposition-v1" + [encodeCanonicalTerm encodeObjectId term])) + + +data TheoremRef = TheoremRef + !TheoryId + !PropositionId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +theoremRef :: TheoryId -> PropositionId -> TheoremRef +theoremRef = + TheoremRef + +theoremRefTheory :: TheoremRef -> TheoryId +theoremRefTheory (TheoremRef identity _proposition) = + identity + +theoremRefProposition :: TheoremRef -> PropositionId +theoremRefProposition (TheoremRef _identity proposition) = + proposition + +encodeTheoremRef :: TheoremRef -> ByteString +encodeTheoremRef (TheoremRef identity proposition) = + encodeFrame + (mathematicalDigestBytes + (theoryIdDigest identity)) + <> encodeFrame + (mathematicalDigestBytes + (propositionIdDigest proposition)) + +newtype TheoremId = + TheoremId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +theoremId :: TheoremRef -> TheoremId +theoremId reference = + TheoremId + (codecInvariant + (hashCanonicalFields + "felix-theorem" + [encodeTheoremRef reference])) + +theoremIdDigest :: TheoremId -> MathematicalDigest +theoremIdDigest (TheoremId digest) = + digest + + +putTheoryIdCache :: TheoryId -> CachePut +putTheoryIdCache = + putMathematicalDigestCache . theoryIdDigest + +getTheoryIdCache :: CacheGet TheoryId +getTheoryIdCache = + TheoryId <$> getMathematicalDigestCache + +putObjectIdCache :: ObjectId -> CachePut +putObjectIdCache (ObjectId family digest) = do + putCacheTag (objectFamilyTag family) + putMathematicalDigestCache digest + +getObjectIdCache :: CacheGet ObjectId +getObjectIdCache = do + family <- getCacheTag >>= \case + 0x00 -> + pure IntrinsicObject + 0x01 -> + pure TransparentObject + 0x02 -> + pure OpaqueObject + tag -> + fail ("unknown cache object-family tag " <> show tag) + ObjectId family <$> getMathematicalDigestCache + +putOpaqueDeclarationSeedCache + :: OpaqueDeclarationSeed + -> CachePut +putOpaqueDeclarationSeedCache = + putMathematicalDigestCache + . opaqueDeclarationSeedDigest + +getOpaqueDeclarationSeedCache + :: CacheGet OpaqueDeclarationSeed +getOpaqueDeclarationSeedCache = + OpaqueDeclarationSeed + <$> getMathematicalDigestCache + +putObjectContentCache :: ObjectContent -> CachePut +putObjectContentCache = \case + IntrinsicObjectContent identity tag coreType -> do + putCacheTag 0x00 + putTheoryIdCache identity + putCoreIntrinsicTagCache tag + putCoreTypeCache coreType + TransparentObjectContent identity coreType body -> do + putCacheTag 0x01 + putTheoryIdCache identity + putCoreTypeCache coreType + putCanonicalTermCache putObjectIdCache body + OpaqueObjectContent identity seed coreType -> do + putCacheTag 0x02 + putTheoryIdCache identity + putOpaqueDeclarationSeedCache seed + putCoreTypeCache coreType + +getObjectContentCache :: CacheGet ObjectContent +getObjectContentCache = + getCacheTag >>= \case + 0x00 -> + IntrinsicObjectContent + <$> getTheoryIdCache + <*> getCoreIntrinsicTagCache + <*> getCoreTypeCache + 0x01 -> + TransparentObjectContent + <$> getTheoryIdCache + <*> getCoreTypeCache + <*> getCanonicalTermCache getObjectIdCache + 0x02 -> + OpaqueObjectContent + <$> getTheoryIdCache + <*> getOpaqueDeclarationSeedCache + <*> getCoreTypeCache + tag -> + fail ("unknown cache object-content tag " <> show tag) + +putPropositionIdCache :: PropositionId -> CachePut +putPropositionIdCache = + putMathematicalDigestCache . propositionIdDigest + +getPropositionIdCache :: CacheGet PropositionId +getPropositionIdCache = + PropositionId <$> getMathematicalDigestCache + +putTheoremRefCache :: TheoremRef -> CachePut +putTheoremRefCache (TheoremRef identity proposition) = do + putTheoryIdCache identity + putPropositionIdCache proposition + +getTheoremRefCache :: CacheGet TheoremRef +getTheoremRefCache = + TheoremRef + <$> getTheoryIdCache + <*> getPropositionIdCache + + +objectFamilyTag :: ObjectFamily -> Word8 +objectFamilyTag = \case + IntrinsicObject -> + 0x00 + TransparentObject -> + 0x01 + OpaqueObject -> + 0x02 + +encodeKernelRuleTag :: KernelRuleTag -> ByteString +encodeKernelRuleTag = + ByteString.singleton . \case + SetLfpBound -> + 0x00 + SetLfpLeast -> + 0x01 + SetLfpFixed -> + 0x02 + SetLfpInduct -> + 0x03 + +encodeFoundationAxiomTag :: FoundationAxiomTag -> ByteString +encodeFoundationAxiomTag = + ByteString.singleton . \case + EmptyCharacteristic -> + 0x00 + PairSetCharacteristic -> + 0x01 + FamilyUnionCharacteristic -> + 0x02 + PowerSetCharacteristic -> + 0x03 + SeparationCharacteristic -> + 0x04 + ReplacementCharacteristic -> + 0x05 + SetChooseWitness -> + 0x06 + SetExtensionality -> + 0x07 + SetInduction -> + 0x08 + PropositionalExtensionality -> + 0x09 + DoubleNegationElim -> + 0x0a + UnivOfContains -> + 0x0b + UnivOfTransitive -> + 0x0c + UnivOfFamilyUnionClosed -> + 0x0d + UnivOfPowerSetClosed -> + 0x0e + UnivOfReplacementClosed -> + 0x0f + UnivOfMinimal -> + 0x10 + +allCoreIntrinsicTags :: [CoreIntrinsicTag] +allCoreIntrinsicTags = + [minBound .. maxBound] + +allKernelRuleTags :: [KernelRuleTag] +allKernelRuleTags = + [minBound .. maxBound] + +allFoundationAxiomTags :: [FoundationAxiomTag] +allFoundationAxiomTags = + [minBound .. maxBound] + +stableTagOrder + :: Show tag + => String + -> (tag -> ByteString) + -> [tag] + -> [tag] +stableTagOrder description encodeTag tags + | Set.size encodedTags == length tags = + List.sortOn encodeTag tags + | otherwise = + impossible + ("duplicate stable " + <> description + <> " tag in " + <> show tags) + where + encodedTags = + Set.fromList (encodeTag <$> tags) + +codecInvariant + :: Either MathematicalCodecError value + -> value +codecInvariant = + either + (impossible . ("canonical codec invariant: " <>) . show) + id diff --git a/source/Felix/Checking/Kernel/Derivation.hs b/source/Felix/Checking/Kernel/Derivation.hs new file mode 100644 index 0000000..e83b376 --- /dev/null +++ b/source/Felix/Checking/Kernel/Derivation.hs @@ -0,0 +1,1264 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Private in-memory proof trees and independent kernel replay. +module Felix.Checking.Kernel.Derivation + ( ImportIx + , importIx + , importIxValue + , HypothesisIx + , hypothesisIx + , DerivationImportJudgment + , derivationImportJudgment + , derivationImportStatement + , KernelDerivation + , mapKernelDerivationGlobals + , importedFactDerivation + , localHypothesisDerivation + , foundationFactDerivation + , implicationEliminationDerivation + , forallEliminationDerivation + , falsumEliminationDerivation + , implicationIntroductionDerivation + , forallIntroductionDerivation + , ConversionPlan + , conversionPlan + , conversionPlanBudget + , ConversionPlanError(..) + , convertJudgmentDerivation + , equalityReflexivityDerivation + , scopedEqualityReflexivityDerivation + , equalityCongruenceApplicationDerivation + , equalityCongruenceLambdaDerivation + , equalityModusPonensDerivation + , setLfpBoundDerivation + , setLfpLeastDerivation + , setLfpFixedDerivation + , setLfpInductDerivation + , weakenDerivationHypotheses + , KernelReplayLimits + , kernelReplayLimits + , defaultKernelReplayLimits + , KernelReplayLimitError(..) + , ReplayedKernelDerivation + , replayKernelDerivation + , replayedKernelTarget + , replayedKernelImportUses + , replayedKernelFoundationUses + , replayedKernelRuleUses + , replayedKernelNodeCount + , replayedKernelMaximumDepth + , DerivationImportError(..) + , KernelReplayError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +newtype ImportIx = ImportIx Natural + deriving stock (Show, Eq, Ord) + +importIx :: Natural -> ImportIx +importIx = ImportIx + +importIxValue :: ImportIx -> Natural +importIxValue (ImportIx index) = + index + +newtype HypothesisIx = HypothesisIx Natural + deriving stock (Show, Eq, Ord) + +hypothesisIx :: Natural -> HypothesisIx +hypothesisIx = HypothesisIx + +newtype DerivationImportJudgment global = + DerivationImportJudgment + (FrozenCheckedCore global) + deriving stock (Eq) + +data DerivationImportError = + DerivationImportIsNotProposition !CoreType + deriving stock (Show, Eq) + +derivationImportJudgment + :: FrozenCheckedCore global + -> Either + DerivationImportError + (DerivationImportJudgment global) +derivationImportJudgment statement + | frozenCoreType statement == TyProp = + Right (DerivationImportJudgment statement) + | otherwise = + Left + (DerivationImportIsNotProposition + (frozenCoreType statement)) + +derivationImportStatement + :: DerivationImportJudgment global + -> FrozenCheckedCore global +derivationImportStatement + (DerivationImportJudgment statement) = + statement + +data KernelDerivation global + = UseImportedFact !ImportIx + | UseLocalHypothesis !HypothesisIx + | UseFoundationFact !FoundationAxiomTag + | ImplicationElimination + !(KernelDerivation global) + !(KernelDerivation global) + | ForallElimination + !(KernelDerivation global) + !(ScopedCheckedCore global) + | FalsumElimination + !(KernelDerivation global) + !(ScopedCheckedCore global) + | ImplicationIntroduction + !(ScopedCheckedCore global) + !(KernelDerivation global) + | ForallIntroduction + !CoreType + !(KernelDerivation global) + | ConvertJudgment + !(KernelDerivation global) + !(ScopedCheckedCore global) + !ConversionPlan + | EqualityReflexivity + !(ScopedCheckedCore global) + | EqualityCongruenceApplication + !(KernelDerivation global) + !(KernelDerivation global) + | EqualityCongruenceLambda + !CoreType + !(KernelDerivation global) + | EqualityModusPonens + !(KernelDerivation global) + !(KernelDerivation global) + | ApplySetLfpBound + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + | ApplySetLfpLeast + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + !(KernelDerivation global) + | ApplySetLfpFixed + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + | ApplySetLfpInduct + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + !(KernelDerivation global) + !(KernelDerivation global) + deriving stock (Eq) + +mapKernelDerivationGlobals + :: (left -> right) + -> KernelDerivation left + -> KernelDerivation right +mapKernelDerivationGlobals transform = go + where + scoped = mapScopedGlobals transform + go = \case + UseImportedFact index -> + UseImportedFact index + UseLocalHypothesis index -> + UseLocalHypothesis index + UseFoundationFact tag -> + UseFoundationFact tag + ImplicationElimination premise implication -> + ImplicationElimination (go premise) (go implication) + ForallElimination proof argument -> + ForallElimination (go proof) (scoped argument) + FalsumElimination proof target -> + FalsumElimination (go proof) (scoped target) + ImplicationIntroduction premise proof -> + ImplicationIntroduction (scoped premise) (go proof) + ForallIntroduction binderType proof -> + ForallIntroduction binderType (go proof) + ConvertJudgment proof target plan -> + ConvertJudgment (go proof) (scoped target) plan + EqualityReflexivity term -> + EqualityReflexivity (scoped term) + EqualityCongruenceApplication function argument -> + EqualityCongruenceApplication (go function) (go argument) + EqualityCongruenceLambda binderType proof -> + EqualityCongruenceLambda binderType (go proof) + EqualityModusPonens equality proof -> + EqualityModusPonens (go equality) (go proof) + ApplySetLfpBound domain operator -> + ApplySetLfpBound (scoped domain) (scoped operator) + ApplySetLfpLeast domain operator candidate bounded closed -> + ApplySetLfpLeast + (scoped domain) + (scoped operator) + (scoped candidate) + (go bounded) + (go closed) + ApplySetLfpFixed domain operator monotone -> + ApplySetLfpFixed + (scoped domain) + (scoped operator) + (go monotone) + ApplySetLfpInduct domain operator predicate element + monotone member closed -> + ApplySetLfpInduct + (scoped domain) + (scoped operator) + (scoped predicate) + (scoped element) + (go monotone) + (go member) + (go closed) + +importedFactDerivation + :: ImportIx + -> KernelDerivation global +importedFactDerivation = + UseImportedFact + +localHypothesisDerivation + :: HypothesisIx + -> KernelDerivation global +localHypothesisDerivation = + UseLocalHypothesis + +foundationFactDerivation + :: FoundationAxiomTag + -> KernelDerivation global +foundationFactDerivation = + UseFoundationFact + +implicationEliminationDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +implicationEliminationDerivation = + ImplicationElimination + +forallEliminationDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> KernelDerivation global +forallEliminationDerivation = + ForallElimination + +falsumEliminationDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> KernelDerivation global +falsumEliminationDerivation = + FalsumElimination + +implicationIntroductionDerivation + :: ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global +implicationIntroductionDerivation = + ImplicationIntroduction + +forallIntroductionDerivation + :: CoreType + -> KernelDerivation global + -> KernelDerivation global +forallIntroductionDerivation = + ForallIntroduction + +newtype ConversionPlan = ConversionPlan Natural + deriving stock (Show, Eq, Ord) + +data ConversionPlanError = + ConversionPlanExceedsLimit !Natural + deriving stock (Show, Eq) + +conversionPlanLimit :: Natural +conversionPlanLimit = + 100000 + +conversionPlan + :: Natural + -> Either ConversionPlanError ConversionPlan +conversionPlan budget + | budget <= conversionPlanLimit = + Right (ConversionPlan budget) + | otherwise = + Left (ConversionPlanExceedsLimit budget) + +conversionPlanBudget :: ConversionPlan -> Natural +conversionPlanBudget (ConversionPlan budget) = + budget + +convertJudgmentDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> ConversionPlan + -> KernelDerivation global +convertJudgmentDerivation = + ConvertJudgment + +equalityReflexivityDerivation + :: FrozenCheckedCore global + -> KernelDerivation global +equalityReflexivityDerivation = + EqualityReflexivity . embedClosedCore [] + +scopedEqualityReflexivityDerivation + :: ScopedCheckedCore global + -> KernelDerivation global +scopedEqualityReflexivityDerivation = + EqualityReflexivity + +equalityCongruenceApplicationDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +equalityCongruenceApplicationDerivation = + EqualityCongruenceApplication + +equalityCongruenceLambdaDerivation + :: CoreType + -> KernelDerivation global + -> KernelDerivation global +equalityCongruenceLambdaDerivation = + EqualityCongruenceLambda + +equalityModusPonensDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +equalityModusPonensDerivation = + EqualityModusPonens + +setLfpBoundDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global +setLfpBoundDerivation = + ApplySetLfpBound + +setLfpLeastDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +setLfpLeastDerivation = + ApplySetLfpLeast + +setLfpFixedDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global +setLfpFixedDerivation = + ApplySetLfpFixed + +setLfpInductDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +setLfpInductDerivation = + ApplySetLfpInduct + +-- | Add hypotheses outside a derivation while preserving hypotheses introduced +-- by implication nodes inside it. +weakenDerivationHypotheses + :: Natural + -> KernelDerivation global + -> KernelDerivation global +weakenDerivationHypotheses amount = + shift 0 + where + shift cutoff = \case + UseImportedFact index -> + UseImportedFact index + UseLocalHypothesis (HypothesisIx index) -> + UseLocalHypothesis + (HypothesisIx + (if index >= cutoff + then index + amount + else index)) + UseFoundationFact tag -> + UseFoundationFact tag + ImplicationElimination implication premise -> + ImplicationElimination + (shift cutoff implication) + (shift cutoff premise) + ForallElimination quantified argument -> + ForallElimination + (shift cutoff quantified) + argument + FalsumElimination falsum target -> + FalsumElimination + (shift cutoff falsum) + target + ImplicationIntroduction premise body -> + ImplicationIntroduction + premise + (shift (cutoff + 1) body) + ForallIntroduction binderType body -> + ForallIntroduction + binderType + (shift cutoff body) + ConvertJudgment source target plan -> + ConvertJudgment + (shift cutoff source) + target + plan + EqualityReflexivity operand -> + EqualityReflexivity operand + EqualityCongruenceApplication function argument -> + EqualityCongruenceApplication + (shift cutoff function) + (shift cutoff argument) + EqualityCongruenceLambda binderType body -> + EqualityCongruenceLambda + binderType + (shift cutoff body) + EqualityModusPonens equality premise -> + EqualityModusPonens + (shift cutoff equality) + (shift cutoff premise) + ApplySetLfpBound domain operator -> + ApplySetLfpBound domain operator + ApplySetLfpLeast + domain operator candidate + closed bounded -> + ApplySetLfpLeast + domain + operator + candidate + (shift cutoff closed) + (shift cutoff bounded) + ApplySetLfpFixed domain operator monotone -> + ApplySetLfpFixed + domain + operator + (shift cutoff monotone) + ApplySetLfpInduct + domain operator predicate element + monotone member closure -> + ApplySetLfpInduct + domain + operator + predicate + element + (shift cutoff monotone) + (shift cutoff member) + (shift cutoff closure) + +data KernelReplayLimits = KernelReplayLimits + !Natural + !Natural + deriving stock (Show, Eq) + +data KernelReplayLimitError + = KernelReplayNodeLimitIsZero + | KernelReplayNodeLimitTooLarge !Natural + | KernelReplayDepthLimitTooLarge !Natural + deriving stock (Show, Eq) + +maximumKernelReplayNodes :: Natural +maximumKernelReplayNodes = + 1000000 + +maximumKernelReplayDepth :: Natural +maximumKernelReplayDepth = + 4096 + +kernelReplayLimits + :: Natural + -> Natural + -> Either KernelReplayLimitError KernelReplayLimits +kernelReplayLimits nodeLimit depthLimit + | nodeLimit == 0 = + Left KernelReplayNodeLimitIsZero + | nodeLimit > maximumKernelReplayNodes = + Left (KernelReplayNodeLimitTooLarge nodeLimit) + | depthLimit > maximumKernelReplayDepth = + Left (KernelReplayDepthLimitTooLarge depthLimit) + | otherwise = + Right + (KernelReplayLimits + nodeLimit + depthLimit) + +defaultKernelReplayLimits :: KernelReplayLimits +defaultKernelReplayLimits = + KernelReplayLimits + 200000 + 2048 + +data ReplayedKernelDerivation global = + ReplayedKernelDerivation + !(FrozenCheckedCore global) + !(Set ImportIx) + !(Set FoundationAxiomTag) + !(Set KernelRuleTag) + !Natural + !Natural + deriving stock (Eq) + +replayedKernelTarget + :: ReplayedKernelDerivation global + -> FrozenCheckedCore global +replayedKernelTarget + (ReplayedKernelDerivation + target + _importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + target + +replayedKernelImportUses + :: ReplayedKernelDerivation global + -> Set ImportIx +replayedKernelImportUses + (ReplayedKernelDerivation + _target + importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + importUses + +replayedKernelFoundationUses + :: ReplayedKernelDerivation global + -> Set FoundationAxiomTag +replayedKernelFoundationUses + (ReplayedKernelDerivation + _target + _importUses + foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + foundationUses + +replayedKernelRuleUses + :: ReplayedKernelDerivation global + -> Set KernelRuleTag +replayedKernelRuleUses + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + ruleUses + _nodeCount + _maximumDepth) = + ruleUses + +replayedKernelNodeCount + :: ReplayedKernelDerivation global + -> Natural +replayedKernelNodeCount + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + _ruleUses + nodeCount + _maximumDepth) = + nodeCount + +replayedKernelMaximumDepth + :: ReplayedKernelDerivation global + -> Natural +replayedKernelMaximumDepth + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + _ruleUses + _nodeCount + maximumDepth) = + maximumDepth + +data ReplayStep global = ReplayStep + !(ScopedCheckedCore global) + !(Set ImportIx) + !(Set FoundationAxiomTag) + !(Set KernelRuleTag) + !Natural + !Natural + +data KernelReplayError + = KernelReplaySemanticsError + !Semantics.KernelSemanticsError + | KernelReplaySetLfpRuleError + !SetLfp.SetLfpRuleError + | KernelReplayImportOutOfBounds !ImportIx + | KernelReplayHypothesisOutOfBounds !HypothesisIx + | KernelReplayStoredContextMismatch + ![CoreType] + ![CoreType] + | KernelReplayStoredTermIllTyped !CoreCheckError + | KernelReplayStoredTypeMismatch + !CoreType + !CoreType + | KernelReplayWeakeningError !CoreCheckError + | KernelReplayNodeLimitExceeded !Natural + | KernelReplayDepthLimitExceeded !Natural + | KernelReplayRootRemainedOpen + | KernelReplayTargetMismatch + deriving stock (Show, Eq) + +replayKernelDerivation + :: Eq global + => CheckedFoundation + -> KernelReplayLimits + -> (global -> Maybe CoreType) + -> Vector (DerivationImportJudgment global) + -> FrozenCheckedCore global + -> KernelDerivation global + -> Either + KernelReplayError + (ReplayedKernelDerivation global) +replayKernelDerivation + checkedFoundationValue + limits + globalType + imports + expectedTarget + derivation = + checkedFoundationValue `seq` do + expectedTarget' <- + recheckClosed expectedTarget + ReplayStep + synthesized + importUses + foundationUses + ruleUses + nodeCount + maximumDepth <- + replay [] [] 0 derivation + closed <- + maybe + (Left KernelReplayRootRemainedOpen) + Right + (closeScopedCore synthesized) + unless + (closed == expectedTarget') + (Left KernelReplayTargetMismatch) + pure + (ReplayedKernelDerivation + closed + importUses + foundationUses + ruleUses + nodeCount + maximumDepth) + where + replay context hypotheses depth derivationNode + | depth > replayDepthLimit = + Left + (KernelReplayDepthLimitExceeded + replayDepthLimit) + | otherwise = do + step <- + replayWithin + context + hypotheses + depth + derivationNode + if stepNodeCount step > replayNodeLimit + then + Left + (KernelReplayNodeLimitExceeded + replayNodeLimit) + else + Right step + + replayWithin context hypotheses depth = \case + UseImportedFact index -> do + judgment <- + lookupImport index + statement <- + recheckStored + context + (embedClosedCore context + (derivationImportStatement + judgment)) + pure + (leaf + depth + statement + (Set.singleton index) + mempty) + UseLocalHypothesis index -> do + hypothesis <- + lookupHypothesis index hypotheses + checkedHypothesis <- + recheckStored context hypothesis + pure + (leaf + depth + checkedHypothesis + mempty + mempty) + UseFoundationFact tag -> do + statement <- + recheckStored + context + (embedClosedCore context + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + checkedFoundationValue + tag))) + pure + (leaf + depth + statement + mempty + (Set.singleton tag)) + ImplicationElimination implication premise -> do + implicationStep <- + replay context hypotheses (depth + 1) implication + premiseStep <- + replay context hypotheses (depth + 1) premise + combine2 depth + (Semantics.implicationElimination + globalType + (stepValue implicationStep) + (stepValue premiseStep)) + implicationStep + premiseStep + ForallElimination quantified argument -> do + argument' <- + recheckStored context argument + quantifiedStep <- + replay context hypotheses (depth + 1) quantified + combine1 depth + (Semantics.forallElimination + globalType + (stepValue quantifiedStep) + argument') + quantifiedStep + FalsumElimination falsum target -> do + target' <- + recheckStored context target + falsumStep <- + replay context hypotheses (depth + 1) falsum + combine1 depth + (Semantics.falsumElimination + globalType + (stepValue falsumStep) + target') + falsumStep + ImplicationIntroduction premise body -> do + premise' <- + recheckStored context premise + bodyStep <- + replay + context + (premise' : hypotheses) + (depth + 1) + body + combine1 depth + (Semantics.implicationIntroduction + globalType + premise' + (stepValue bodyStep)) + bodyStep + ForallIntroduction binderType body -> do + weakenedHypotheses <- + traverse + (first KernelReplayWeakeningError + . weakenScopedCore + globalType + binderType) + hypotheses + bodyStep <- + replay + (binderType : context) + weakenedHypotheses + (depth + 1) + body + combine1 depth + (Semantics.forallIntroduction + globalType + binderType + (stepValue bodyStep)) + bodyStep + ConvertJudgment source target plan -> do + target' <- + recheckStored context target + sourceStep <- + replay + context + hypotheses + (depth + 1) + source + combine1 depth + (Semantics.convertJudgment + globalType + (conversionPlanBudget plan) + (stepValue sourceStep) + target') + sourceStep + EqualityReflexivity operand -> do + operand' <- + recheckStored context operand + value <- + first KernelReplaySemanticsError + (Semantics.equalityReflexivity + globalType + operand') + pure (leaf depth value mempty mempty) + EqualityCongruenceApplication + functionEquality + argumentEquality -> do + functionStep <- + replay + context + hypotheses + (depth + 1) + functionEquality + argumentStep <- + replay + context + hypotheses + (depth + 1) + argumentEquality + combine2 depth + (Semantics.equalityCongruenceApplication + globalType + (stepValue functionStep) + (stepValue argumentStep)) + functionStep + argumentStep + EqualityCongruenceLambda binderType bodyEquality -> do + weakenedHypotheses <- + traverse + (first KernelReplayWeakeningError + . weakenScopedCore + globalType + binderType) + hypotheses + bodyStep <- + replay + (binderType : context) + weakenedHypotheses + (depth + 1) + bodyEquality + combine1 depth + (Semantics.equalityCongruenceLambda + globalType + binderType + (stepValue bodyStep)) + bodyStep + EqualityModusPonens equality premise -> do + equalityStep <- + replay context hypotheses (depth + 1) equality + premiseStep <- + replay context hypotheses (depth + 1) premise + combine2 depth + (Semantics.equalityModusPonens + globalType + (stepValue equalityStep) + (stepValue premiseStep)) + equalityStep + premiseStep + ApplySetLfpBound domain operator -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + value <- + first KernelReplaySetLfpRuleError + (SetLfp.setLfpBound + checkedFoundationValue + globalType + domain' + operator') + pure + (ruleLeaf + depth + SetLfpBound + value) + ApplySetLfpLeast + domain + operator + candidate + closedPremise + boundedPremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + candidate' <- + recheckStored context candidate + closedStep <- + replay + context + hypotheses + (depth + 1) + closedPremise + boundedStep <- + replay + context + hypotheses + (depth + 1) + boundedPremise + combineRule depth SetLfpLeast + (SetLfp.setLfpLeast + checkedFoundationValue + globalType + domain' + operator' + candidate' + (stepValue closedStep) + (stepValue boundedStep)) + [closedStep, boundedStep] + ApplySetLfpFixed domain operator monotonePremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + monotoneStep <- + replay + context + hypotheses + (depth + 1) + monotonePremise + combineRule depth SetLfpFixed + (SetLfp.setLfpFixed + checkedFoundationValue + globalType + domain' + operator' + (stepValue monotoneStep)) + [monotoneStep] + ApplySetLfpInduct + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + predicate' <- + recheckStored context predicate + element' <- + recheckStored context element + monotoneStep <- + replay + context + hypotheses + (depth + 1) + monotonePremise + memberStep <- + replay + context + hypotheses + (depth + 1) + memberPremise + closureStep <- + replay + context + hypotheses + (depth + 1) + closurePremise + combineRule depth SetLfpInduct + (SetLfp.setLfpInduct + checkedFoundationValue + globalType + domain' + operator' + predicate' + element' + (stepValue monotoneStep) + (stepValue memberStep) + (stepValue closureStep)) + [ monotoneStep + , memberStep + , closureStep + ] + + lookupImport index@(ImportIx naturalIndex) + | naturalIndex + > fromIntegral (maxBound :: Int) = + Left + (KernelReplayImportOutOfBounds + index) + | otherwise = + maybe + (Left + (KernelReplayImportOutOfBounds + index)) + Right + (imports + Vector.!? + (fromIntegral naturalIndex)) + + lookupHypothesis + index@(HypothesisIx naturalIndex) + hypotheses = + maybe + (Left + (KernelReplayHypothesisOutOfBounds + index)) + Right + (atNatural naturalIndex hypotheses) + + requireContext expected value + | scopedCoreContext value == expected = + Right () + | otherwise = + Left + (KernelReplayStoredContextMismatch + expected + (scopedCoreContext value)) + + recheckStored expectedContext stored = do + requireContext expectedContext stored + checked <- + first KernelReplayStoredTermIllTyped + (checkScopedCanonicalCore + globalType + expectedContext + (scopedCoreTerm stored)) + unless + (scopedCoreType checked + == scopedCoreType stored) + (Left + (KernelReplayStoredTypeMismatch + (scopedCoreType stored) + (scopedCoreType checked))) + pure checked + + recheckClosed stored = do + checked <- + first KernelReplayStoredTermIllTyped + (checkCanonicalCore + globalType + (frozenCoreTerm stored)) + unless + (frozenCoreType checked + == frozenCoreType stored) + (Left + (KernelReplayStoredTypeMismatch + (frozenCoreType stored) + (frozenCoreType checked))) + pure checked + + replayNodeLimit = + case limits of + KernelReplayLimits nodeLimit _depthLimit -> + nodeLimit + + replayDepthLimit = + case limits of + KernelReplayLimits _nodeLimit depthLimit -> + depthLimit + +leaf + :: Natural + -> ScopedCheckedCore global + -> Set ImportIx + -> Set FoundationAxiomTag + -> ReplayStep global +leaf depth value importUses foundationUses = + ReplayStep + value + importUses + foundationUses + mempty + 1 + depth + +ruleLeaf + :: Natural + -> KernelRuleTag + -> ScopedCheckedCore global + -> ReplayStep global +ruleLeaf depth tag value = + ReplayStep + value + mempty + mempty + (Set.singleton tag) + 1 + depth + +stepValue :: ReplayStep global -> ScopedCheckedCore global +stepValue + (ReplayStep + value + _importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + value + +combine1 + :: Natural + -> Either + Semantics.KernelSemanticsError + (ScopedCheckedCore global) + -> ReplayStep global + -> Either KernelReplayError (ReplayStep global) +combine1 depth synthesized child = do + value <- + first KernelReplaySemanticsError synthesized + pure + (ReplayStep + value + (stepImportUses child) + (stepFoundationUses child) + (stepRuleUses child) + (1 + stepNodeCount child) + (max depth + (stepMaximumDepth child))) + +combine2 + :: Natural + -> Either + Semantics.KernelSemanticsError + (ScopedCheckedCore global) + -> ReplayStep global + -> ReplayStep global + -> Either KernelReplayError (ReplayStep global) +combine2 depth synthesized left right = do + value <- + first KernelReplaySemanticsError synthesized + pure + (ReplayStep + value + (stepImportUses left + <> stepImportUses right) + (stepFoundationUses left + <> stepFoundationUses right) + (stepRuleUses left + <> stepRuleUses right) + (1 + + stepNodeCount left + + stepNodeCount right) + (maximum + [ depth + , stepMaximumDepth left + , stepMaximumDepth right + ])) + +combineRule + :: Natural + -> KernelRuleTag + -> Either + SetLfp.SetLfpRuleError + (ScopedCheckedCore global) + -> [ReplayStep global] + -> Either KernelReplayError (ReplayStep global) +combineRule depth tag synthesized children = do + value <- + first KernelReplaySetLfpRuleError synthesized + pure + (ReplayStep + value + (foldMap stepImportUses children) + (foldMap stepFoundationUses children) + (Set.insert tag + (foldMap stepRuleUses children)) + (1 + sum (stepNodeCount <$> children)) + (maximum + (depth + : (stepMaximumDepth <$> children)))) + +stepImportUses + :: ReplayStep global + -> Set ImportIx +stepImportUses + (ReplayStep + _value + importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + importUses + +stepFoundationUses + :: ReplayStep global + -> Set FoundationAxiomTag +stepFoundationUses + (ReplayStep + _value + _importUses + foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + foundationUses + +stepRuleUses + :: ReplayStep global + -> Set KernelRuleTag +stepRuleUses + (ReplayStep + _value + _importUses + _foundationUses + ruleUses + _nodeCount + _maximumDepth) = + ruleUses + +stepNodeCount :: ReplayStep global -> Natural +stepNodeCount + (ReplayStep + _value + _importUses + _foundationUses + _ruleUses + nodeCount + _maximumDepth) = + nodeCount + +stepMaximumDepth :: ReplayStep global -> Natural +stepMaximumDepth + (ReplayStep + _value + _importUses + _foundationUses + _ruleUses + _nodeCount + maximumDepth) = + maximumDepth + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest diff --git a/source/Felix/Checking/Kernel/Proof.hs b/source/Felix/Checking/Kernel/Proof.hs new file mode 100644 index 0000000..d4ccedc --- /dev/null +++ b/source/Felix/Checking/Kernel/Proof.hs @@ -0,0 +1,1443 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Small proof-producing natural-deduction combinators. Every resulting tree +-- is still replayed independently before it can authorize a fact. +module Felix.Checking.Kernel.Proof + ( ProofContext + , rootProofContext + , proofContextTypes + , scopedTerm + , BuiltProof + , builtProofStatement + , builtProofDerivation + , importedProof + , foundationProof + , hypothesisProof + , implicationEliminationProof + , implicationIntroductionProof + , forallEliminationProof + , forallIntroductionProof + , falsumEliminationProof + , equalityReflexivityProof + , equalityReverseProof + , equalityCongruenceApplicationProof + , equalityModusPonensProof + , conversionProof + , doubleNegationEliminationProof + , conjunctionTerm + , conjunctionIntroductionProof + , conjunctionLeftProof + , conjunctionRightProof + , disjunctionTerm + , disjunctionLeftProof + , disjunctionRightProof + , disjunctionEliminationProof + , validateCaseAnalysisComposition + , validateDoubleNegationComposition + , validateFalsumEliminationComposition + , validateSetInductionComposition + , existentialTerm + , existentialIntroductionProof + , existentialEliminationProof + , setLfpBoundProof + , setLfpFixedProof + , setLfpInductProof + , KernelProofBuildError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Numeric.Natural (Natural) + + +data ProofContext global = ProofContext + !CheckedFoundation + !(global -> Maybe CoreType) + ![CoreType] + ![ScopedCheckedCore global] + +rootProofContext + :: CheckedFoundation + -> (global -> Maybe CoreType) + -> ProofContext global +rootProofContext foundation globalType = + ProofContext foundation globalType [] [] + +proofContextTypes + :: ProofContext global + -> [CoreType] +proofContextTypes + (ProofContext + _foundation + _globalType + context + _hypotheses) = + context + +data BuiltProof global = BuiltProof + !(ScopedCheckedCore global) + !(KernelDerivation global) + +builtProofStatement + :: BuiltProof global + -> ScopedCheckedCore global +builtProofStatement + (BuiltProof statement _derivation) = + statement + +builtProofDerivation + :: BuiltProof global + -> KernelDerivation global +builtProofDerivation + (BuiltProof _statement derivation) = + derivation + +data KernelProofBuildError + = ProofTermIllTyped !CoreCheckError + | ProofSemanticsFailed + !Semantics.KernelSemanticsError + | ProofFoundationArgumentMismatch + !FoundationAxiomTag + | ProofHypothesisNotFound + | ProofExpectedEquality + | ProofExpectedUnaryBinder + | ProofSetLfpRuleFailed !Text + | ProofConversionPlanFailed !Text + | ProofStructuralCompositionMismatch !Text + deriving stock (Show, Eq) + +scopedTerm + :: ProofContext global + -> CanonicalTerm global + -> Either + KernelProofBuildError + (ScopedCheckedCore global) +scopedTerm + (ProofContext + _foundation + globalType + context + _hypotheses) = + first ProofTermIllTyped + . checkScopedCanonicalCore + globalType + context + +importedProof + :: ProofContext global + -> ImportIx + -> FrozenCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +importedProof context index statement = + pure + (BuiltProof + (embedClosedCore + (proofContextTypes context) + statement) + (importedFactDerivation index)) + +foundationProof + :: ProofContext global + -> FoundationAxiomTag + -> Either + KernelProofBuildError + (BuiltProof global) +foundationProof + context@(ProofContext + foundation + _globalType + _types + _hypotheses) + tag = + pure + (BuiltProof + (embedClosedCore + (proofContextTypes context) + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag))) + (foundationFactDerivation tag)) + +hypothesisProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +hypothesisProof + (ProofContext + _foundation + _globalType + _context + hypotheses) + statement = + case List.findIndex (== statement) hypotheses of + Nothing -> + Left ProofHypothesisNotFound + Just index -> + pure + (BuiltProof + statement + (localHypothesisDerivation + (hypothesisIx + (fromIntegral index)))) + +implicationEliminationProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +implicationEliminationProof + (ProofContext + _foundation + globalType + _context + _hypotheses) + implication + premise = do + conclusion <- + first ProofSemanticsFailed + (Semantics.implicationElimination + globalType + (builtProofStatement implication) + (builtProofStatement premise)) + pure + (BuiltProof + conclusion + (implicationEliminationDerivation + (builtProofDerivation implication) + (builtProofDerivation premise))) + +implicationIntroductionProof + :: ProofContext global + -> ScopedCheckedCore global + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +implicationIntroductionProof + (ProofContext + foundation + globalType + types + hypotheses) + premise + buildBody = do + let extended = + ProofContext + foundation + globalType + types + (premise : hypotheses) + premiseProof = + BuiltProof + premise + (localHypothesisDerivation + (hypothesisIx 0)) + body <- + buildBody extended premiseProof + conclusion <- + first ProofSemanticsFailed + (Semantics.implicationIntroduction + globalType + premise + (builtProofStatement body)) + pure + (BuiltProof + conclusion + (implicationIntroductionDerivation + premise + (builtProofDerivation body))) + +forallEliminationProof + :: ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +forallEliminationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + quantified + argument = do + conclusion <- + first ProofSemanticsFailed + (Semantics.forallElimination + globalType + (builtProofStatement quantified) + argument) + pure + (BuiltProof + conclusion + (forallEliminationDerivation + (builtProofDerivation quantified) + argument)) + +forallIntroductionProof + :: ProofContext global + -> CoreType + -> ( ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +forallIntroductionProof + (ProofContext + foundation + globalType + types + hypotheses) + binderType + buildBody = do + weakenedHypotheses <- + traverse + (first ProofTermIllTyped + . weakenScopedCore + globalType + binderType) + hypotheses + let extended = + ProofContext + foundation + globalType + (binderType : types) + weakenedHypotheses + variable <- + scopedTerm extended (CBound 0) + body <- + buildBody extended variable + conclusion <- + first ProofSemanticsFailed + (Semantics.forallIntroduction + globalType + binderType + (builtProofStatement body)) + pure + (BuiltProof + conclusion + (forallIntroductionDerivation + binderType + (builtProofDerivation body))) + +falsumEliminationProof + :: ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +falsumEliminationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + falsum + target = do + conclusion <- + first ProofSemanticsFailed + (Semantics.falsumElimination + globalType + (builtProofStatement falsum) + target) + pure + (BuiltProof + conclusion + (falsumEliminationDerivation + (builtProofDerivation falsum) + target)) + +equalityReflexivityProof + :: ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityReflexivityProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + operand = do + equality <- + first ProofSemanticsFailed + (Semantics.equalityReflexivity + globalType + operand) + pure + (BuiltProof + equality + (scopedEqualityReflexivityDerivation + operand)) + +equalityCongruenceApplicationProof + :: ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityCongruenceApplicationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + functionEquality + argumentEquality = do + equality <- + first ProofSemanticsFailed + (Semantics.equalityCongruenceApplication + globalType + (builtProofStatement functionEquality) + (builtProofStatement argumentEquality)) + pure + (BuiltProof + equality + (equalityCongruenceApplicationDerivation + (builtProofDerivation + functionEquality) + (builtProofDerivation + argumentEquality))) + +equalityModusPonensProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityModusPonensProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + equality + premise = do + conclusion <- + first ProofSemanticsFailed + (Semantics.equalityModusPonens + globalType + (builtProofStatement equality) + (builtProofStatement premise)) + pure + (BuiltProof + conclusion + (equalityModusPonensDerivation + (builtProofDerivation equality) + (builtProofDerivation premise))) + +conversionProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +conversionProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + source + target = do + plan <- + first (ProofConversionPlanFailed . Text.pack . show) + (conversionPlan 100000) + result <- + first ProofSemanticsFailed + (Semantics.convertJudgment + globalType + (conversionPlanBudget plan) + (builtProofStatement source) + target) + pure + (BuiltProof + result + (convertJudgmentDerivation + (builtProofDerivation source) + target + plan)) + +equalityReverseProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityReverseProof context equality = do + (operandType, left, right) <- + equalityParts + (builtProofStatement equality) + leftOperand <- + scopedTerm context left + weakenedLeft <- + first ProofTermIllTyped + (weakenScopedCore + (contextGlobalType context) + operandType + leftOperand) + function <- + scopedTerm context + (CLam operandType + (CEq + operandType + (CBound 0) + (scopedCoreTerm + weakenedLeft))) + functionReflexivity <- + equalityReflexivityProof + context + function + appliedEquality <- + equalityCongruenceApplicationProof + context + functionReflexivity + equality + leftReflexivity <- + equalityReflexivityProof + context + leftOperand + appliedLeft <- + scopedTerm context + (CApp + (scopedCoreTerm function) + left) + appliedLeftReflexivity <- + conversionProof + context + leftReflexivity + appliedLeft + reversedApplication <- + equalityModusPonensProof + context + appliedEquality + appliedLeftReflexivity + expected <- + scopedTerm context + (CEq operandType right left) + conversionProof + context + reversedApplication + expected + +doubleNegationEliminationProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +doubleNegationEliminationProof + context + target + doubleNegation = do + axiom <- + foundationProof + context + DoubleNegationElim + instanceProof <- + forallEliminationProof + context + axiom + target + implicationEliminationProof + context + instanceProof + doubleNegation + +conjunctionTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +conjunctionTerm left right = + CImp + (CImp left + (CImp right CFalsum)) + CFalsum + +conjunctionIntroductionProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionIntroductionProof + context + left + right = do + let leftTerm = + scopedCoreTerm + (builtProofStatement left) + rightTerm = + scopedCoreTerm + (builtProofStatement right) + refuter <- + scopedTerm context + (CImp leftTerm + (CImp rightTerm CFalsum)) + implicationIntroductionProof + context + refuter + (\extended refuterProof -> do + firstApplication <- + implicationEliminationProof + extended + refuterProof + (weakenForHypothesis left) + implicationEliminationProof + extended + firstApplication + (weakenForHypothesis right)) + +conjunctionLeftProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionLeftProof context left right conjunction = do + leftProposition <- + scopedTerm context left + notLeft <- + scopedTerm context + (CImp left CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notLeft + (\withNotLeft _notLeftProof -> do + leftAtRefuter <- + scopedTerm withNotLeft left + refuterProof <- + implicationIntroductionProof + withNotLeft + leftAtRefuter + (\withLeft leftProof -> do + rightProposition <- + scopedTerm withLeft right + implicationIntroductionProof + withLeft + rightProposition + (\withBoth _rightProof -> do + notLeftCurrent <- + hypothesisProof + withBoth + notLeft + implicationEliminationProof + withBoth + notLeftCurrent + (weakenForHypothesis + leftProof))) + implicationEliminationProof + withNotLeft + (weakenForHypothesis conjunction) + refuterProof) + doubleNegationEliminationProof + context + leftProposition + doubleNegation + +conjunctionRightProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionRightProof context left right conjunction = do + rightProposition <- + scopedTerm context right + notRight <- + scopedTerm context + (CImp right CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notRight + (\withNotRight _notRightProof -> do + leftAtRefuter <- + scopedTerm withNotRight left + refuterProof <- + implicationIntroductionProof + withNotRight + leftAtRefuter + (\withLeft _leftProof -> do + rightAtLeft <- + scopedTerm + withLeft + right + implicationIntroductionProof + withLeft + rightAtLeft + (\withBoth rightProof -> do + notRightCurrent <- + hypothesisProof + withBoth + notRight + implicationEliminationProof + withBoth + notRightCurrent + rightProof)) + implicationEliminationProof + withNotRight + (weakenForHypothesis conjunction) + refuterProof) + doubleNegationEliminationProof + context + rightProposition + doubleNegation + +disjunctionTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +disjunctionTerm left right = + CImp + (CImp left CFalsum) + right + +disjunctionLeftProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionLeftProof context right leftProof = do + notLeft <- + scopedTerm context + (CImp + (scopedCoreTerm + (builtProofStatement leftProof)) + CFalsum) + rightTarget <- + scopedTerm context right + implicationIntroductionProof + context + notLeft + (\extended notLeftProof -> do + falsum <- + implicationEliminationProof + extended + notLeftProof + (weakenForHypothesis + leftProof) + falsumEliminationProof + extended + falsum + rightTarget) + +disjunctionRightProof + :: ProofContext global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionRightProof context left rightProof = do + notLeft <- + scopedTerm context + (CImp left CFalsum) + implicationIntroductionProof + context + notLeft + (\_extended _notLeftProof -> + pure + (weakenForHypothesis + rightProof)) + +disjunctionEliminationProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> ScopedCheckedCore global + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionEliminationProof + context + left + right + disjunction + result + leftCase + rightCase = do + leftProposition <- + scopedTerm context left + rightProposition <- + scopedTerm context right + leftImplication <- + implicationIntroductionProof + context + leftProposition + leftCase + rightImplication <- + implicationIntroductionProof + context + rightProposition + rightCase + notResult <- + scopedTerm context + (CImp + (scopedCoreTerm result) + CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notResult + (\extended notResultProof -> do + leftAtNotResult <- + scopedTerm extended left + notLeftProof <- + implicationIntroductionProof + extended + leftAtNotResult + (\withLeft leftProof -> do + resultProof <- + implicationEliminationProof + withLeft + (weakenForHypothesis + (weakenForHypothesis + leftImplication)) + leftProof + implicationEliminationProof + withLeft + (weakenForHypothesis + notResultProof) + resultProof) + rightProof <- + implicationEliminationProof + extended + (weakenForHypothesis + disjunction) + notLeftProof + resultProof <- + implicationEliminationProof + extended + (weakenForHypothesis + rightImplication) + rightProof + implicationEliminationProof + extended + notResultProof + resultProof) + doubleNegationEliminationProof + context + result + doubleNegation + +-- | Validate the one structural rule used by exact source case analysis. +-- The branch proofs and the exhaustive disjunction are represented here by +-- exact hypotheses; the kernel combinators must derive the owned goal from +-- precisely those propositions. No derived proof escapes this check. +validateCaseAnalysisComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateCaseAnalysisComposition + foundation globalType goal cases exhaustive = do + validatePropositionContext "case goal" lexicalContext goal + traverse_ + (validatePropositionContext "case assumption" lexicalContext) + cases + validatePropositionContext + "case exhaustiveness target" lexicalContext exhaustive + let expectedExhaustive = + foldl1 + (\left right -> + CImp + (CImp left CFalsum) + right) + (scopedCoreTerm <$> cases) + unless (scopedCoreTerm exhaustive == expectedExhaustive) + (Left + (ProofStructuralCompositionMismatch + "case exhaustiveness is not the source-ordered disjunction")) + branchImplications <- + traverse + (checkedImplication lexicalContext goal) + cases + let context = + ProofContext + foundation + globalType + lexicalContext + (exhaustive : toList branchImplications) + exhaustiveProof <- hypothesisProof context exhaustive + result <- + eliminateCases + context goal cases exhaustiveProof + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "case elimination did not derive the owned goal")) + where + lexicalContext = scopedCoreContext goal + + checkedImplication expectedContext conclusion antecedent = + case implyScopedCore antecedent conclusion of + Just implication + | scopedCoreContext implication == expectedContext -> + pure implication + _ -> + Left + (ProofStructuralCompositionMismatch + "case branch implication changed context") + + eliminateCases context result (only :| []) caseProof = do + branchImplication <- + scopedTerm context + (CImp + (scopedCoreTerm only) + (scopedCoreTerm result)) + >>= hypothesisProof context + implicationEliminationProof context branchImplication caseProof + eliminateCases context result (firstCase :| rest) disjunctionProof = do + let allCases = firstCase :| rest + leftCases = NonEmpty.fromList (NonEmpty.init allCases) + rightCase = NonEmpty.last allCases + leftTerm = + foldl1 disjunctionTerm + (scopedCoreTerm <$> leftCases) + disjunctionEliminationProof + context + leftTerm + (scopedCoreTerm rightCase) + disjunctionProof + result + (\extended leftProof -> + eliminateCases extended result leftCases leftProof) + (\extended rightProof -> do + branchImplication <- + scopedTerm extended + (CImp + (scopedCoreTerm rightCase) + (scopedCoreTerm result)) + >>= hypothesisProof extended + implicationEliminationProof + extended branchImplication rightProof) + +-- | Validate the exact classical closing step for a proof by contradiction. +-- The only classical input is the confined 'DoubleNegationElim' foundation +-- row already consumed by 'doubleNegationEliminationProof'. +validateDoubleNegationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateDoubleNegationComposition + foundation globalType goal negation falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext + "contradiction negation" lexicalContext negation + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not target falsum")) + expectedNegation <- + checkedNegation lexicalContext goal + unless (negation == expectedNegation) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not own the exact negated goal")) + doubleNegation <- + checkedNegation lexicalContext negation + let context = + ProofContext + foundation globalType lexicalContext [doubleNegation] + hypothesis <- hypothesisProof context doubleNegation + result <- doubleNegationEliminationProof context goal hypothesis + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "double-negation elimination did not derive the owned goal")) + +-- | Validate the exact ex-falso closing step used after a terminal indirect +-- contradiction discharge. +validateFalsumEliminationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateFalsumEliminationComposition foundation globalType goal falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not receive falsum")) + let context = + ProofContext foundation globalType lexicalContext [falsum] + hypothesis <- hypothesisProof context falsum + result <- falsumEliminationProof context hypothesis goal + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not derive the owned goal")) + +-- | Validate the exact structural instance used by source set induction. +-- The admitted child is represented by its generalized step proposition; +-- the checked foundation row must specialize to that exact premise and the +-- owned binder-level result. No induction principle becomes an ATP premise. +validateSetInductionComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> Natural + -> ScopedCheckedCore global + -> [ScopedCheckedCore global] + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateSetInductionComposition + foundation globalType selected property antecedents childTarget + hypothesis result = do + let lexicalContext = scopedCoreContext property + traverse_ + (validatePropositionContext + "set-induction antecedent" lexicalContext) + antecedents + validatePropositionContext + "set-induction property" lexicalContext property + validatePropositionContext + "set-induction child target" lexicalContext childTarget + validatePropositionContext + "set-induction hypothesis" lexicalContext hypothesis + validatePropositionContext + "set-induction result" lexicalContext result + expectedProperty <- + foldrM implyChecked childTarget antecedents + unless (property == expectedProperty) + (Left + (ProofStructuralCompositionMismatch + "set-induction property does not own the child target and guards")) + (predicate, expectedHypothesis, step, expectedResult) <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction focus is not a set-valued ambient binder")) + pure + (scopedSetInductionInstance selected property) + unless (hypothesis == expectedHypothesis) + (Left + (ProofStructuralCompositionMismatch + "set-induction hypothesis does not match the owned property")) + unless (result == expectedResult) + (Left + (ProofStructuralCompositionMismatch + "set-induction result does not close the owned property")) + let context = + ProofContext foundation globalType lexicalContext [step] + stepProof <- hypothesisProof context step + axiom <- foundationProof context SetInduction + instanceProof <- forallEliminationProof context axiom predicate + expectedInstance <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction instance changed lexical context")) + pure + (implyScopedCore step result) + convertedInstance <- + conversionProof context instanceProof expectedInstance + resultProof <- + implicationEliminationProof context convertedInstance stepProof + unless (builtProofStatement resultProof == result) + (Left + (ProofStructuralCompositionMismatch + "set-induction foundation instance did not derive the owned result")) + where + implyChecked antecedent conclusion = + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction guard changed lexical context")) + pure + (implyScopedCore antecedent conclusion) + +validatePropositionContext + :: Text + -> [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validatePropositionContext label expected proposition = + unless + ( scopedCoreType proposition == TyProp + && scopedCoreContext proposition == expected + ) + (Left + (ProofStructuralCompositionMismatch + (label <> " has the wrong type or lexical context"))) + +checkedNegation + :: [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError (ScopedCheckedCore global) +checkedNegation expectedContext proposition = + case negateScopedCore proposition of + Just negation + | scopedCoreContext negation == expectedContext -> + pure negation + _ -> + Left + (ProofStructuralCompositionMismatch + "classical negation changed context") + +existentialTerm + :: CoreType + -> CanonicalTerm global + -> CanonicalTerm global +existentialTerm binderType body = + CImp + (CForall binderType + (CImp body CFalsum)) + CFalsum + +existentialIntroductionProof + :: Eq global + => ProofContext global + -> CoreType + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +existentialIntroductionProof + context + binderType + bodyUnderBinder + witness + bodyAtWitness = do + unless + (proofContextTypes context + == drop 1 + (scopedCoreContext + bodyUnderBinder)) + (Left ProofExpectedUnaryBinder) + universalNegation <- + scopedTerm context + (CForall binderType + (CImp + (scopedCoreTerm + bodyUnderBinder) + CFalsum)) + implicationIntroductionProof + context + universalNegation + (\extended universalProof -> do + negatedBody <- + forallEliminationProof + extended + universalProof + witness + implicationEliminationProof + extended + negatedBody + (weakenForHypothesis + bodyAtWitness)) + +existentialEliminationProof + :: Eq global + => ProofContext global + -> CoreType + -> ScopedCheckedCore global + -> BuiltProof global + -> ScopedCheckedCore global + -> ( ProofContext global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +existentialEliminationProof + context + binderType + bodyUnderBinder + existential + result + bodyCase = do + notResult <- + scopedTerm context + (CImp + (scopedCoreTerm result) + CFalsum) + notResultUnderBinder <- + first ProofTermIllTyped + (weakenScopedCore + (contextGlobalType context) + binderType + notResult) + doubleNegation <- + implicationIntroductionProof + context + notResult + (\withNotResult _notResultProof -> do + universalNegation <- + forallIntroductionProof + withNotResult + binderType + (\withBinder variable -> do + let body = + bodyUnderBinder + implicationIntroductionProof + withBinder + body + (\withBody bodyProof -> do + resultProof <- + bodyCase + withBody + variable + bodyProof + notResultCurrent <- + hypothesisProof + withBody + notResultUnderBinder + implicationEliminationProof + withBody + notResultCurrent + resultProof)) + implicationEliminationProof + withNotResult + (weakenForHypothesis + existential) + universalNegation) + doubleNegationEliminationProof + context + result + doubleNegation + +setLfpBoundProof + :: ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpBoundProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpBound + foundation + globalType + domain + operator) + pure + (BuiltProof + result + (setLfpBoundDerivation + domain + operator)) + +setLfpFixedProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpFixedProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator + monotone = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpFixed + foundation + globalType + domain + operator + (builtProofStatement + monotone)) + pure + (BuiltProof + result + (setLfpFixedDerivation + domain + operator + (builtProofDerivation + monotone))) + +setLfpInductProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpInductProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator + predicate + element + monotone + member + closure = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpInduct + foundation + globalType + domain + operator + predicate + element + (builtProofStatement + monotone) + (builtProofStatement + member) + (builtProofStatement + closure)) + pure + (BuiltProof + result + (setLfpInductDerivation + domain + operator + predicate + element + (builtProofDerivation + monotone) + (builtProofDerivation + member) + (builtProofDerivation + closure))) + +contextGlobalType + :: ProofContext global + -> (global -> Maybe CoreType) +contextGlobalType + (ProofContext + _foundation + globalType + _types + _hypotheses) = + globalType + +equalityParts + :: ScopedCheckedCore global + -> Either + KernelProofBuildError + ( CoreType + , CanonicalTerm global + , CanonicalTerm global + ) +equalityParts equality = + case scopedCoreTerm equality of + CEq operandType left right -> + Right (operandType, left, right) + _ -> + Left ProofExpectedEquality + +weakenForHypothesis + :: BuiltProof global + -> BuiltProof global +weakenForHypothesis + (BuiltProof statement derivation) = + BuiltProof + statement + (weakenDerivationHypotheses 1 derivation) diff --git a/source/Felix/Checking/Kernel/Semantics.hs b/source/Felix/Checking/Kernel/Semantics.hs new file mode 100644 index 0000000..f9cfcfa --- /dev/null +++ b/source/Felix/Checking/Kernel/Semantics.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked logical inference over scoped canonical HOL terms. +module Felix.Checking.Kernel.Semantics + ( implicationElimination + , implicationIntroduction + , forallElimination + , forallIntroduction + , falsumElimination + , equalityReflexivity + , equalityCongruenceApplication + , equalityCongruenceLambda + , equalityModusPonens + , convertJudgment + , KernelSemanticsError(..) + ) where + +import Base +import Felix.Checking.Core + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Numeric.Natural (Natural) + + +data KernelSemanticsError + = KernelContextMismatch + ![CoreType] + ![CoreType] + | KernelBinderContextMismatch + !CoreType + ![CoreType] + | KernelExpectedProposition !CoreType + | KernelExpectedImplication + | KernelImplicationPremiseMismatch + | KernelExpectedForall + | KernelForallArgumentTypeMismatch + !CoreType + !CoreType + | KernelExpectedFalsum + | KernelExpectedEquality + | KernelEqualityOperandTypeMismatch + !CoreType + !CoreType + | KernelExpectedFunctionEquality !CoreType + | KernelEqualityPremiseMismatch + | KernelConversionBudgetExhausted + | KernelConversionMismatch + | KernelConclusionIllTyped !CoreCheckError + deriving stock (Show, Eq) + +implicationElimination + :: Eq global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +implicationElimination globalType implication premise = do + requireSameContext implication premise + requireProposition implication + requireProposition premise + case scopedCoreTerm implication of + CImp expected conclusion + | scopedCoreTerm premise == expected -> + checkConclusion + globalType + (scopedCoreContext implication) + conclusion + | otherwise -> + Left KernelImplicationPremiseMismatch + _ -> + Left KernelExpectedImplication + +implicationIntroduction + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +implicationIntroduction globalType premise conclusion = do + requireSameContext premise conclusion + requireProposition premise + requireProposition conclusion + checkConclusion + globalType + (scopedCoreContext premise) + (CImp + (scopedCoreTerm premise) + (scopedCoreTerm conclusion)) + +forallElimination + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +forallElimination globalType quantified argument = do + requireSameContext quantified argument + requireProposition quantified + case scopedCoreTerm quantified of + CForall binderType body + | scopedCoreType argument == binderType -> + checkConclusion + globalType + (scopedCoreContext quantified) + (instantiateCanonical + (scopedCoreTerm argument) + body) + | otherwise -> + Left + (KernelForallArgumentTypeMismatch + binderType + (scopedCoreType argument)) + _ -> + Left KernelExpectedForall + +forallIntroduction + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +forallIntroduction globalType binderType body = do + requireProposition body + outerContext <- + case scopedCoreContext body of + actualBinder : context + | actualBinder == binderType -> + Right context + | otherwise -> + Left + (KernelBinderContextMismatch + binderType + (scopedCoreContext body)) + [] -> + Left + (KernelBinderContextMismatch + binderType + []) + checkConclusion + globalType + outerContext + (CForall + binderType + (scopedCoreTerm body)) + +falsumElimination + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +falsumElimination _globalType falsum target = do + requireSameContext falsum target + requireProposition falsum + requireProposition target + case scopedCoreTerm falsum of + CFalsum -> + Right target + _ -> + Left KernelExpectedFalsum + +equalityReflexivity + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityReflexivity globalType operand = + checkConclusion + globalType + (scopedCoreContext operand) + (CEq + (scopedCoreType operand) + (scopedCoreTerm operand) + (scopedCoreTerm operand)) + +equalityCongruenceApplication + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityCongruenceApplication + globalType + functionEquality + argumentEquality = do + requireSameContext functionEquality argumentEquality + (functionType, leftFunction, rightFunction) <- + equalityOperands functionEquality + (argumentType, leftArgument, rightArgument) <- + equalityOperands argumentEquality + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + checkConclusion + globalType + (scopedCoreContext functionEquality) + (CEq + resultType + (CApp leftFunction leftArgument) + (CApp rightFunction rightArgument)) + | otherwise -> + Left + (KernelEqualityOperandTypeMismatch + expectedArgument + argumentType) + other -> + Left (KernelExpectedFunctionEquality other) + +equalityCongruenceLambda + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityCongruenceLambda + globalType + binderType + bodyEquality = do + (bodyType, leftBody, rightBody) <- + equalityOperands bodyEquality + outerContext <- + case scopedCoreContext bodyEquality of + actualBinder : context + | actualBinder == binderType -> + Right context + | otherwise -> + Left + (KernelBinderContextMismatch + binderType + (scopedCoreContext bodyEquality)) + [] -> + Left + (KernelBinderContextMismatch + binderType + []) + checkConclusion + globalType + outerContext + (CEq + (TyArrow binderType bodyType) + (CLam binderType leftBody) + (CLam binderType rightBody)) + +equalityModusPonens + :: Eq global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityModusPonens globalType propositionEquality premise = do + requireSameContext propositionEquality premise + requireProposition premise + (operandType, left, right) <- + equalityOperands propositionEquality + unless + (operandType == TyProp) + (Left + (KernelEqualityOperandTypeMismatch + TyProp + operandType)) + unless + (left == scopedCoreTerm premise) + (Left KernelEqualityPremiseMismatch) + checkConclusion + globalType + (scopedCoreContext premise) + right + +-- | Recheck a displayed proposition and independently establish beta +-- conversion within the supplied contraction budget. +convertJudgment + :: Eq global + => (global -> Maybe CoreType) + -> Natural + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +convertJudgment globalType budget source target = do + requireSameContext source target + requireProposition source + requireProposition target + sourceNormal <- + normalizeCanonical budget + (scopedCoreTerm source) + targetNormal <- + normalizeCanonical budget + (scopedCoreTerm target) + unless + (sourceNormal == targetNormal) + (Left KernelConversionMismatch) + checkConclusion + globalType + (scopedCoreContext target) + (scopedCoreTerm target) + +requireSameContext + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelSemanticsError () +requireSameContext left right + | scopedCoreContext left + == scopedCoreContext right = + Right () + | otherwise = + Left + (KernelContextMismatch + (scopedCoreContext left) + (scopedCoreContext right)) + +requireProposition + :: ScopedCheckedCore global + -> Either KernelSemanticsError () +requireProposition value + | scopedCoreType value == TyProp = + Right () + | otherwise = + Left + (KernelExpectedProposition + (scopedCoreType value)) + +equalityOperands + :: ScopedCheckedCore global + -> Either + KernelSemanticsError + (CoreType, CanonicalTerm global, CanonicalTerm global) +equalityOperands equality = do + requireProposition equality + case scopedCoreTerm equality of + CEq operandType left right -> + Right (operandType, left, right) + _ -> + Left KernelExpectedEquality + +checkConclusion + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +checkConclusion globalType context = + first KernelConclusionIllTyped + . checkScopedCanonicalCore globalType context + +normalizeCanonical + :: Natural + -> CanonicalTerm global + -> Either + KernelSemanticsError + (CanonicalTerm global) +normalizeCanonical budget term = + fst <$> normalize budget term + where + normalize remaining = \case + CBound index -> + pure (CBound index, remaining) + CGlobal global -> + pure (CGlobal global, remaining) + CIntrinsic intrinsic -> + pure (CIntrinsic intrinsic, remaining) + COpaqueInteger integer -> + pure (COpaqueInteger integer, remaining) + CApp function argument -> do + (functionNormal, afterFunction) <- + normalize remaining function + case functionNormal of + CLam _binderType body -> do + afterContraction <- + consumeReduction afterFunction + normalize + afterContraction + (instantiateCanonical + argument + body) + _ -> do + (argumentNormal, afterArgument) <- + normalize afterFunction argument + pure + ( CApp + functionNormal + argumentNormal + , afterArgument + ) + CLam binderType body -> do + (bodyNormal, remaining') <- + normalize remaining body + pure + (CLam binderType bodyNormal, remaining') + CFalsum -> + pure (CFalsum, remaining) + CImp premise conclusion -> do + (premiseNormal, afterPremise) <- + normalize remaining premise + (conclusionNormal, afterConclusion) <- + normalize afterPremise conclusion + pure + ( CImp premiseNormal conclusionNormal + , afterConclusion + ) + CEq operandType left right -> do + (leftNormal, afterLeft) <- + normalize remaining left + (rightNormal, afterRight) <- + normalize afterLeft right + pure + ( CEq + operandType + leftNormal + rightNormal + , afterRight + ) + CForall binderType body -> do + (bodyNormal, remaining') <- + normalize remaining body + pure + (CForall binderType bodyNormal, remaining') + + consumeReduction 0 = + Left KernelConversionBudgetExhausted + consumeReduction remaining = + Right (remaining - 1) diff --git a/source/Felix/Checking/Kernel/SetLfp.hs b/source/Felix/Checking/Kernel/SetLfp.hs new file mode 100644 index 0000000..19f6714 --- /dev/null +++ b/source/Felix/Checking/Kernel/SetLfp.hs @@ -0,0 +1,762 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The four checked rules for the bounded set-valued least fixed point. +module Felix.Checking.Kernel.SetLfp + ( setLfpBound + , setLfpLeast + , setLfpFixed + , setLfpInduct + , setLfpTerm + , memberProposition + , subsetProposition + , boundedMonoProposition + , inductionClosureProposition + , SetLfpRuleError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Data.Bifunctor (first) +import Numeric.Natural (Natural) + + +data SetLfpRuleError + = SetLfpRuleSignatureMismatch + !KernelRuleTag + !KernelRuleSignature + !KernelRuleSignature + | SetLfpRuleContextMismatch + !KernelRuleTag + ![CoreType] + ![CoreType] + | SetLfpRuleArgumentTypeMismatch + !KernelRuleTag + !Natural + !CoreType + !CoreType + | SetLfpRulePremiseIsNotProposition + !KernelRuleTag + !Natural + !CoreType + | SetLfpRulePremiseMismatch + !KernelRuleTag + !Natural + | SetLfpRuleConstructionIllTyped + !KernelRuleTag + !CoreCheckError + deriving stock (Show, Eq) + +setLfpBound + :: CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpBound foundation globalType domain operator = do + validateApplication + foundation + SetLfpBound + [domain, operator] + [] + fixedPoint <- + setLfpTermFor + SetLfpBound + globalType + domain + operator + subsetFor + SetLfpBound + globalType + fixedPoint + domain + +setLfpLeast + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpLeast + foundation + globalType + domain + operator + candidate + closedPremise + boundedPremise = do + validateApplication + foundation + SetLfpLeast + [domain, operator, candidate] + [closedPremise, boundedPremise] + operatorCandidate <- + applyFor + SetLfpLeast + globalType + operator + candidate + expectedClosed <- + subsetFor + SetLfpLeast + globalType + operatorCandidate + candidate + expectedBounded <- + subsetFor + SetLfpLeast + globalType + candidate + domain + requirePremise + SetLfpLeast + 0 + expectedClosed + closedPremise + requirePremise + SetLfpLeast + 1 + expectedBounded + boundedPremise + fixedPoint <- + setLfpTermFor + SetLfpLeast + globalType + domain + operator + subsetFor + SetLfpLeast + globalType + fixedPoint + candidate + +setLfpFixed + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpFixed + foundation + globalType + domain + operator + monotonePremise = do + validateApplication + foundation + SetLfpFixed + [domain, operator] + [monotonePremise] + expectedMonotone <- + boundedMonoFor + SetLfpFixed + globalType + domain + operator + requirePremise + SetLfpFixed + 0 + expectedMonotone + monotonePremise + fixedPoint <- + setLfpTermFor + SetLfpFixed + globalType + domain + operator + unfolded <- + applyFor + SetLfpFixed + globalType + operator + fixedPoint + checkedFor + SetLfpFixed + globalType + (scopedCoreContext domain) + (CEq + TySet + (scopedCoreTerm fixedPoint) + (scopedCoreTerm unfolded)) + +setLfpInduct + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpInduct + foundation + globalType + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise = do + validateApplication + foundation + SetLfpInduct + [domain, operator, predicate, element] + [monotonePremise, memberPremise, closurePremise] + expectedMonotone <- + boundedMonoFor + SetLfpInduct + globalType + domain + operator + requirePremise + SetLfpInduct + 0 + expectedMonotone + monotonePremise + fixedPoint <- + setLfpTermFor + SetLfpInduct + globalType + domain + operator + expectedMember <- + memberFor + SetLfpInduct + globalType + element + fixedPoint + requirePremise + SetLfpInduct + 1 + expectedMember + memberPremise + expectedClosure <- + inductionClosureFor + SetLfpInduct + globalType + fixedPoint + operator + predicate + requirePremise + SetLfpInduct + 2 + expectedClosure + closurePremise + applyFor + SetLfpInduct + globalType + predicate + element + +setLfpTerm + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpTerm = + setLfpTermFor SetLfpBound + +memberProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +memberProposition = + memberFor SetLfpInduct + +subsetProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +subsetProposition = + subsetFor SetLfpBound + +boundedMonoProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +boundedMonoProposition = + boundedMonoFor SetLfpFixed + +inductionClosureProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +inductionClosureProposition globalType domain operator predicate = do + fixedPoint <- + setLfpTermFor + SetLfpInduct + globalType + domain + operator + inductionClosureFor + SetLfpInduct + globalType + fixedPoint + operator + predicate + +validateApplication + :: CheckedFoundation + -> KernelRuleTag + -> [ScopedCheckedCore global] + -> [ScopedCheckedCore global] + -> Either SetLfpRuleError () +validateApplication foundation tag arguments premises = do + let expected = + expectedSignature tag + actual = + foundationRuleSignature foundation tag + if actual == expected + then pure () + else + Left + (SetLfpRuleSignatureMismatch + tag + expected + actual) + case arguments of + [] -> + pure () + firstArgument : remainingArguments -> do + traverse_ + (requireContext tag firstArgument) + remainingArguments + traverse_ + (requireContext tag firstArgument) + premises + traverse_ + (uncurry + (requireArgumentType tag)) + (zip [0 ..] arguments) + traverse_ + (uncurry + (requireProposition tag)) + (zip [0 ..] premises) + +expectedSignature :: KernelRuleTag -> KernelRuleSignature +expectedSignature = \case + SetLfpBound -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 0 + SetLfpLeast -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet, TySet] + 2 + SetLfpFixed -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 1 + SetLfpInduct -> + KernelRuleSignature + [ TySet + , TySet `TyArrow` TySet + , TySet `TyArrow` TyProp + , TySet + ] + 3 + +expectedArgumentTypes + :: KernelRuleTag + -> [CoreType] +expectedArgumentTypes tag = + case expectedSignature tag of + KernelRuleSignature argumentTypes _premiseCount -> + argumentTypes + +requireContext + :: KernelRuleTag + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireContext tag expected actual + | scopedCoreContext expected + == scopedCoreContext actual = + Right () + | otherwise = + Left + (SetLfpRuleContextMismatch + tag + (scopedCoreContext expected) + (scopedCoreContext actual)) + +requireArgumentType + :: KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireArgumentType tag index argument = + case atNatural index (expectedArgumentTypes tag) of + Nothing -> + impossible + "fixed-point rule argument inventory is inconsistent" + Just expected + | scopedCoreType argument == expected -> + Right () + | otherwise -> + Left + (SetLfpRuleArgumentTypeMismatch + tag + index + expected + (scopedCoreType argument)) + +requireProposition + :: KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireProposition tag index premise + | scopedCoreType premise == TyProp = + Right () + | otherwise = + Left + (SetLfpRulePremiseIsNotProposition + tag + index + (scopedCoreType premise)) + +requirePremise + :: Eq global + => KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requirePremise tag index expected actual + | expected == actual = + Right () + | otherwise = + Left + (SetLfpRulePremiseMismatch + tag + index) + +setLfpTermFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpTermFor tag globalType domain operator = + checkedFor tag globalType + (scopedCoreContext domain) + (CApp + (CApp + (CIntrinsic ISetLfp) + (scopedCoreTerm domain)) + (scopedCoreTerm operator)) + +applyFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +applyFor tag globalType function argument = do + requireContext tag function argument + checkedFor tag globalType + (scopedCoreContext function) + (CApp + (scopedCoreTerm function) + (scopedCoreTerm argument)) + +memberFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +memberFor tag globalType element set = do + requireContext tag element set + checkedFor tag globalType + (scopedCoreContext element) + (CApp + (CApp + (CIntrinsic Member) + (scopedCoreTerm element)) + (scopedCoreTerm set)) + +subsetFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +subsetFor tag globalType left right = do + requireContext tag left right + left' <- weakenFor tag globalType TySet left + right' <- weakenFor tag globalType TySet right + element <- + checkedFor tag globalType + (TySet : scopedCoreContext left) + (CBound 0) + inLeft <- + memberFor tag globalType element left' + inRight <- + memberFor tag globalType element right' + checkedFor tag globalType + (scopedCoreContext left) + (CForall + TySet + (CImp + (scopedCoreTerm inLeft) + (scopedCoreTerm inRight))) + +boundedMonoFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +boundedMonoFor tag globalType domain operator = do + requireContext tag domain operator + operatorDomain <- + applyFor tag globalType operator domain + bounded <- + subsetFor tag globalType operatorDomain domain + + domainX <- + weakenFor tag globalType TySet domain + operatorX <- + weakenFor tag globalType TySet operator + domainXY <- + weakenFor tag globalType TySet domainX + operatorXY <- + weakenFor tag globalType TySet operatorX + let xyContext = + TySet : TySet : scopedCoreContext domain + x <- + checkedFor tag globalType + xyContext + (CBound 1) + y <- + checkedFor tag globalType + xyContext + (CBound 0) + xSubsetY <- + subsetFor tag globalType x y + ySubsetDomain <- + subsetFor tag globalType y domainXY + antecedent <- + conjunctionFor + tag + globalType + xSubsetY + ySubsetDomain + operatorXValue <- + applyFor tag globalType operatorXY x + operatorYValue <- + applyFor tag globalType operatorXY y + imageSubset <- + subsetFor + tag + globalType + operatorXValue + operatorYValue + monotoneBody <- + implicationFor + tag + globalType + antecedent + imageSubset + quantifiedY <- + closeForallFor tag globalType TySet monotoneBody + quantifiedXY <- + closeForallFor tag globalType TySet quantifiedY + conjunctionFor + tag + globalType + bounded + quantifiedXY + +inductionClosureFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +inductionClosureFor + tag + globalType + fixedPoint + operator + predicate = do + fixedPoint' <- + weakenFor tag globalType TySet fixedPoint + operator' <- + weakenFor tag globalType TySet operator + predicate' <- + weakenFor tag globalType TySet predicate + element <- + checkedFor tag globalType + (TySet : scopedCoreContext fixedPoint) + (CBound 0) + separated <- + checkedFor tag globalType + (scopedCoreContext fixedPoint') + (CApp + (CApp + (CIntrinsic Sep) + (scopedCoreTerm fixedPoint')) + (scopedCoreTerm predicate')) + unfolded <- + applyFor tag globalType operator' separated + memberUnfolded <- + memberFor tag globalType element unfolded + predicateElement <- + applyFor tag globalType predicate' element + body <- + implicationFor + tag + globalType + memberUnfolded + predicateElement + closeForallFor tag globalType TySet body + +conjunctionFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +conjunctionFor tag globalType left right = do + requireContext tag left right + checkedFor tag globalType + (scopedCoreContext left) + (CImp + (CImp + (scopedCoreTerm left) + (CImp + (scopedCoreTerm right) + CFalsum)) + CFalsum) + +implicationFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +implicationFor tag globalType premise conclusion = do + requireContext tag premise conclusion + checkedFor tag globalType + (scopedCoreContext premise) + (CImp + (scopedCoreTerm premise) + (scopedCoreTerm conclusion)) + +closeForallFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +closeForallFor tag globalType binderType body = + case scopedCoreContext body of + actualBinder : outerContext + | actualBinder == binderType -> + checkedFor tag globalType + outerContext + (CForall + binderType + (scopedCoreTerm body)) + _ -> + Left + (SetLfpRuleContextMismatch + tag + (binderType : drop 1 + (scopedCoreContext body)) + (scopedCoreContext body)) + +weakenFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +weakenFor tag globalType binderType = + first + (SetLfpRuleConstructionIllTyped tag) + . weakenScopedCore + globalType + binderType + +checkedFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +checkedFor tag globalType context = + first + (SetLfpRuleConstructionIllTyped tag) + . checkScopedCanonicalCore + globalType + context + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest diff --git a/source/Felix/Checking/Materialization.hs b/source/Felix/Checking/Materialization.hs new file mode 100644 index 0000000..51944a5 --- /dev/null +++ b/source/Felix/Checking/Materialization.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Pure applicability checks for later trusted materialization. +-- +-- Successful checks are inert. Fresh completion and validated loading or +-- sealing own the runtime authority that may publish a fact. +module Felix.Checking.Materialization + ( CandidateValidation + , candidateProofValidation + , candidateDeclarationValidation + , checkDeclarationValidationRecord + , checkCandidateValidation + , checkImportedMembership + , checkImportedOccurrence + , MaterializationError(..) + ) where + +import Base +import Felix.Checking.Authority +import Felix.Checking.Identity +import Felix.Checking.Semantic + +import Control.Monad (unless) +import Numeric.Natural (Natural) + + +data CandidateValidation + = CandidateProofValidation + !ProofValidationRecord + !ProofSyntaxId + | CandidateDeclarationValidation + !DeclarationValidationRecord + !DeclarationSyntaxId + ![ObjectId] + ![TheoremId] + !Natural + deriving stock (Show, Eq) + +candidateProofValidation + :: ProofValidationRecord + -> ProofSyntaxId + -> CandidateValidation +candidateProofValidation = + CandidateProofValidation + +candidateDeclarationValidation + :: DeclarationValidationRecord + -> DeclarationSyntaxId + -> [ObjectId] + -> [TheoremId] + -> Natural + -> CandidateValidation +candidateDeclarationValidation = + CandidateDeclarationValidation + +checkDeclarationValidationRecord + :: PrefixContextId + -> DeclarationSyntaxId + -> [ObjectId] + -> [TheoremId] + -> DeclarationValidationRecord + -> Either MaterializationError () +checkDeclarationValidationRecord prefix syntax objects theorems record = do + let suppliedKey = + declarationValidationRecordKey record + certificates = + declarationValidationRecordCertificates record + expectedKey = + declarationValidationKey + syntax prefix objects theorems + unless + (suppliedKey == expectedKey) + (Left + (DeclarationValidationKeyMismatch + suppliedKey expectedKey)) + let certificateTheorems = + theoremId + . factAuthorityTheorem + . validationTarget + <$> certificates + unless + (certificateTheorems == theorems) + (Left + (DeclarationCertificateTargetsMismatch + theorems certificateTheorems)) + +data MaterializationError + = CandidateValidationIndexMissing !Natural + | ProofValidationKeyMismatch + !ProofValidationKey + !ProofValidationKey + | DeclarationValidationKeyMismatch + !DeclarationValidationKey + !DeclarationValidationKey + | DeclarationCertificateTargetsMismatch + ![TheoremId] + ![TheoremId] + | CandidateCertificateTargetMismatch + !FactAuthority + !FactAuthority + | CandidateDirectAuthorizationMismatch + !DirectAuthorization + !DirectAuthorization + | CandidateTheoryMismatch !TheoryId !TheoryId + | CandidatePropositionMismatch + !PropositionId + !PropositionId + | ImportedOccurrenceMissing + !SemanticFactOccurrenceFingerprint + | ImportedAuthorityMismatch + !FactAuthority + !FactAuthority + | ImportedTheoryMismatch !TheoryId !TheoryId + | ImportedPropositionMismatch + !PropositionId + !PropositionId + deriving stock (Show, Eq) + + +-- | Check whether inert validation data applies to one exact candidate. +-- +-- Success deliberately returns no builder authorization. A fresh trusted +-- completion or compatible validated-store hit must perform this check before +-- its owner mints runtime authority. +checkCandidateValidation + :: TheoryId + -> PrefixContextId + -> CheckedPropositionContent + -> FactAuthority + -> DirectAuthorization + -> CandidateValidation + -> Either MaterializationError () +checkCandidateValidation + theory prefix proposition expectedAuthority + expectedDirect validation = do + certificate <- + candidateCertificate + prefix expectedAuthority validation + validateCertificateTarget + theory proposition expectedAuthority expectedDirect certificate + +candidateCertificate + :: PrefixContextId + -> FactAuthority + -> CandidateValidation + -> Either MaterializationError ValidationCertificate +candidateCertificate prefix authority = \case + CandidateProofValidation record syntax -> do + let suppliedKey = + proofValidationRecordKey record + certificate = + proofValidationRecordCertificate record + expectedKey = + proofValidationKey + (theoremId + (factAuthorityTheorem authority)) + syntax + prefix + unless + (suppliedKey == expectedKey) + (Left + (ProofValidationKeyMismatch + suppliedKey expectedKey)) + pure certificate + CandidateDeclarationValidation + record syntax objects theorems ordinal -> do + checkDeclarationValidationRecord + prefix syntax objects theorems record + maybe + (Left (CandidateValidationIndexMissing ordinal)) + Right + (nthNatural ordinal + (declarationValidationRecordCertificates record)) + +validateCertificateTarget + :: TheoryId + -> CheckedPropositionContent + -> FactAuthority + -> DirectAuthorization + -> ValidationCertificate + -> Either MaterializationError () +validateCertificateTarget + theory proposition expectedAuthority expectedDirect certificate = do + let actualAuthority = + validationTarget certificate + actualDirect = + validationDirectAuthorization certificate + reference = + factAuthorityTheorem actualAuthority + unless + (actualAuthority == expectedAuthority) + (Left + (CandidateCertificateTargetMismatch + expectedAuthority actualAuthority)) + unless + (actualDirect == expectedDirect) + (Left + (CandidateDirectAuthorizationMismatch + expectedDirect actualDirect)) + unless + (theoremRefTheory reference == theory) + (Left + (CandidateTheoryMismatch + theory + (theoremRefTheory reference))) + unless + ( theoremRefProposition reference + == checkedPropositionId proposition + ) + (Left + (CandidatePropositionMismatch + (checkedPropositionId proposition) + (theoremRefProposition reference))) + + +-- | Validate exact membership in inert canonical interface data. +-- +-- Logical sealing or atomic cached installation must additionally supply the +-- opaque runtime evidence before an importer receives builder authority. +checkImportedMembership + :: TheoryId + -> SemanticInterface + -> SemanticFactOccurrenceFingerprint + -> CheckedPropositionContent + -> FactAuthority + -> Either MaterializationError SemanticFactOccurrence +checkImportedMembership + theory interface fingerprint proposition expectedAuthority = do + occurrence <- + maybe + (Left (ImportedOccurrenceMissing fingerprint)) + Right + (find + ((== fingerprint) . semanticFactFingerprint) + (concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface))) + checkImportedOccurrence + theory fingerprint occurrence proposition expectedAuthority + +checkImportedOccurrence + :: TheoryId + -> SemanticFactOccurrenceFingerprint + -> SemanticFactOccurrence + -> CheckedPropositionContent + -> FactAuthority + -> Either MaterializationError SemanticFactOccurrence +checkImportedOccurrence + theory fingerprint occurrence proposition expectedAuthority = do + unless + (semanticFactFingerprint occurrence == fingerprint) + (Left (ImportedOccurrenceMissing fingerprint)) + let actualAuthority = + semanticFactAuthority occurrence + reference = + factAuthorityTheorem actualAuthority + unless + (actualAuthority == expectedAuthority) + (Left + (ImportedAuthorityMismatch + expectedAuthority actualAuthority)) + unless + (theoremRefTheory reference == theory) + (Left + (ImportedTheoryMismatch + theory + (theoremRefTheory reference))) + unless + (theoremRefProposition reference + == checkedPropositionId proposition) + (Left + (ImportedPropositionMismatch + (checkedPropositionId proposition) + (theoremRefProposition reference))) + pure occurrence + + +nthNatural :: Natural -> [value] -> Maybe value +nthNatural ordinal = + go ordinal + where + go _ [] = + Nothing + go 0 (value : _) = + Just value + go remaining (_ : rest) = + go (remaining - 1) rest diff --git a/source/Felix/Checking/Module.hs b/source/Felix/Checking/Module.hs new file mode 100644 index 0000000..88c8fef --- /dev/null +++ b/source/Felix/Checking/Module.hs @@ -0,0 +1,986 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Explicit inputs and sealed outputs for the typed module driver. +module Felix.Checking.Module + ( LiveModuleBinding(..) + , IdentifiedModuleInput + , identifiedPhysicalModule + , identifiedReservedPrelude + , identifiedModuleOwner + , identifiedModuleBinding + , identifiedModuleParsed + , TypedSourceDeclaration + , typedSourceDeclarationBlockIndex + , typedSourceDeclarationHead + , typedSourceDeclarationProof + , typedSourceDeclarations + , SealedTypedModule + , sealedTypedModuleOwner + , sealedTypedModuleSyntax + , sealedTypedModuleSemantic + , sealedTypedModuleEvidence + , CachedTypedModuleError(..) + , renderCachedTypedModuleError + , cachedSealedTypedModule + , sealedTypedModulePrefix + , FinalPreludeSession + , ModuleRootAcquisition(..) + , finalPreludeSource + , finalPreludeInput + , finalPreludeModule + , finalPreludeAcquisition + , FinalPreludeReadiness + , finalPreludeReadiness + , BootstrapPreludeFixture + , bootstrapPreludeInput + , bootstrapPreludeModule + , bootstrapPreludeReadiness + , fixtureFinalPreludeReadinessFromSealed + , BootstrapError(..) + , buildBootstrapPreludeFixture + , FinalPreludeReadinessError(..) + , acquireFinalPreludeSession + , TypedModuleInput + , TypedModuleInputError(..) + , renderTypedModuleInputError + , typedModuleInput + , TypedPathError(..) + , TypedModuleFailure(..) + , typedModuleFailureLocation + , renderTypedModuleFailure + , TypedModuleResult(..) + , runTypedModule + ) where + +import Base +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Module +import Felix.Parse +import Felix.Prelude qualified as Prelude +import Felix.Source +import Felix.Store qualified as Store +import Felix.Report.Location +import Felix.Syntax.Interface +import Felix.Syntax.Abstract qualified as Raw + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.Text qualified as Text + + +data LiveModuleBinding + = PhysicalModuleBinding !ResolvedSource + | ReservedModuleBinding !FileId !FilePath + deriving stock (Show, Eq) + +data IdentifiedModuleInput = IdentifiedModuleInput + !ModuleName + !LiveModuleBinding + !IdentifiedParsedModule + +identifiedPhysicalModule :: ParsedModule -> IdentifiedModuleInput +identifiedPhysicalModule parsed = + IdentifiedModuleInput + (moduleName (parsedModuleAddress parsed)) + (PhysicalModuleBinding (parsedModuleResolved parsed)) + (parsedModuleIdentified parsed) + +identifiedReservedPrelude + :: Prelude.ReservedParsedPrelude + -> IdentifiedModuleInput +identifiedReservedPrelude reserved = + IdentifiedModuleInput + (freshModuleInputOwner input) + (ReservedModuleBinding + (freshModuleInputFileId input) + (freshModuleInputLocationPath input)) + (Prelude.reservedParsedPreludeModule reserved) + where + input = Prelude.reservedParsedPreludeInput reserved + +identifiedModuleOwner :: IdentifiedModuleInput -> ModuleName +identifiedModuleOwner (IdentifiedModuleInput owner _binding _parsed) = + owner + +identifiedModuleBinding + :: IdentifiedModuleInput + -> LiveModuleBinding +identifiedModuleBinding + (IdentifiedModuleInput _owner binding _parsed) = + binding + +identifiedModuleParsed + :: IdentifiedModuleInput + -> IdentifiedParsedModule +identifiedModuleParsed + (IdentifiedModuleInput _owner _binding parsed) = + parsed + + +-- | One source declaration as consumed by the typed module driver. +-- +-- A claim and its immediately following proof occupy one declaration slot. +-- The head block index remains the syntax-occurrence association index. +data TypedSourceDeclaration = TypedSourceDeclaration + !Int + !Raw.Block + !(Maybe Raw.Proof) + +typedSourceDeclarationBlockIndex :: TypedSourceDeclaration -> Int +typedSourceDeclarationBlockIndex + (TypedSourceDeclaration blockIndex _head _proof) = + blockIndex + +typedSourceDeclarationHead :: TypedSourceDeclaration -> Raw.Block +typedSourceDeclarationHead + (TypedSourceDeclaration _blockIndex headBlock _proof) = + headBlock + +typedSourceDeclarationProof + :: TypedSourceDeclaration + -> Maybe Raw.Proof +typedSourceDeclarationProof + (TypedSourceDeclaration _blockIndex _head proof) = + proof + +typedSourceDeclarations + :: IdentifiedParsedModule + -> [TypedSourceDeclaration] +typedSourceDeclarations parsed = + [ declaration + | item <- typedSourceItems (identifiedParsedModuleBlocks parsed) + , Just declaration <- [sourceItemDeclaration item] + ] + +data TypedSourceItem + = TypedSourceDeclarationItem !TypedSourceDeclaration + | TypedUnmatchedSourceProof !Location + +sourceItemDeclaration + :: TypedSourceItem + -> Maybe TypedSourceDeclaration +sourceItemDeclaration = \case + TypedSourceDeclarationItem declaration -> Just declaration + TypedUnmatchedSourceProof{} -> Nothing + +typedSourceItems :: [Raw.Block] -> [TypedSourceItem] +typedSourceItems = go 0 + where + go _blockIndex [] = [] + go blockIndex (block@Raw.BlockClaim{} : remaining) = + case remaining of + Raw.BlockProof _location proof _end : rest -> + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block (Just proof)) + : go (blockIndex + 2) rest + _ -> + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block Nothing) + : go (blockIndex + 1) remaining + go blockIndex (Raw.BlockProof location _proof _end : remaining) = + TypedUnmatchedSourceProof location + : go (blockIndex + 1) remaining + go blockIndex (block : remaining) = + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block Nothing) + : go (blockIndex + 1) remaining + + +data SealedTypedModule = SealedTypedModule + !ModuleName + !ModuleSyntaxInterface + !SemanticInterface + !Declaration.PendingModulePrefix + !Declaration.ImportedModuleEvidence + +sealedTypedModuleOwner :: SealedTypedModule -> ModuleName +sealedTypedModuleOwner (SealedTypedModule owner _syntax _semantic _prefix _evidence) = + owner + +sealedTypedModuleSyntax + :: SealedTypedModule + -> ModuleSyntaxInterface +sealedTypedModuleSyntax + (SealedTypedModule _owner syntax _semantic _prefix _evidence) = + syntax + +sealedTypedModuleSemantic + :: SealedTypedModule + -> SemanticInterface +sealedTypedModuleSemantic + (SealedTypedModule _owner _syntax semantic _prefix _evidence) = + semantic + +sealedTypedModulePrefix + :: SealedTypedModule + -> Declaration.PendingModulePrefix +sealedTypedModulePrefix + (SealedTypedModule _owner _syntax _semantic prefix _evidence) = + prefix + +sealedTypedModuleEvidence + :: SealedTypedModule + -> Declaration.ImportedModuleEvidence +sealedTypedModuleEvidence + (SealedTypedModule _owner _syntax _semantic _prefix evidence) = + evidence + +data CachedTypedModuleError + = CachedTypedModuleEvidenceError !Declaration.DeclarationError + deriving stock (Show, Eq) + +renderCachedTypedModuleError :: CachedTypedModuleError -> Text +renderCachedTypedModuleError = \case + CachedTypedModuleEvidenceError failure -> + Declaration.renderDeclarationError failure + +cachedSealedTypedModule + :: CheckedFoundation + -> [SealedTypedModule] + -> Store.CachedModuleInstallation + -> Either CachedTypedModuleError SealedTypedModule +cachedSealedTypedModule + foundation parents installation = do + evidence <- + first CachedTypedModuleEvidenceError + (Declaration.validateImportedModuleEvidence + (theoryId foundation) + (sealedTypedModuleEvidence <$> parents) + semantic + objects + propositions) + pure + (SealedTypedModule + owner + syntax + semantic + (Declaration.emptyPendingModulePrefix + (Store.cachedInstallationFinalPrefix installation)) + evidence) + where + syntax = Store.cachedInstallationSyntax installation + semantic = Store.cachedInstallationSemantic installation + owner = semanticInterfaceOwner semantic + objects = Store.cachedInstallationObjects installation + propositions = Store.cachedInstallationPropositions installation + + +data ModuleRootAcquisition + = ModuleRootHit + | ModuleRootMiss + deriving stock (Show, Eq) + +data FinalPreludeSession = FinalPreludeSession + !Prelude.ReservedPreludeSourceInput + !IdentifiedModuleInput + !SealedTypedModule + !ModuleRootAcquisition + +finalPreludeSource + :: FinalPreludeSession + -> Prelude.ReservedPreludeSourceInput +finalPreludeSource + (FinalPreludeSession source _input _module _acquisition) = + source + +finalPreludeInput + :: FinalPreludeSession + -> IdentifiedModuleInput +finalPreludeInput (FinalPreludeSession _source input _module _acquisition) = + input + +finalPreludeModule + :: FinalPreludeSession + -> SealedTypedModule +finalPreludeModule (FinalPreludeSession _source _input sealed _acquisition) = + sealed + +finalPreludeAcquisition + :: FinalPreludeSession + -> ModuleRootAcquisition +finalPreludeAcquisition + (FinalPreludeSession _source _input _sealed acquisition) = + acquisition + +newtype FinalPreludeReadiness = FinalPreludeReadiness + SealedTypedModule + +finalPreludeReadiness + :: FinalPreludeSession + -> FinalPreludeReadiness +finalPreludeReadiness = + FinalPreludeReadiness . finalPreludeModule + +-- | Test-only empty-prelude fixture. +-- +-- It is exported for focused exact-compiler tests. Production acquisition is +-- exclusively 'acquireFinalPreludeSession'. +newtype BootstrapPreludeFixture = BootstrapPreludeFixture + FinalPreludeSession + +bootstrapPreludeInput + :: BootstrapPreludeFixture + -> IdentifiedModuleInput +bootstrapPreludeInput (BootstrapPreludeFixture fixture) = + finalPreludeInput fixture + +bootstrapPreludeModule + :: BootstrapPreludeFixture + -> SealedTypedModule +bootstrapPreludeModule (BootstrapPreludeFixture fixture) = + finalPreludeModule fixture + +-- | Test-only seam for the empty bootstrap compiler input. +bootstrapPreludeReadiness + :: BootstrapPreludeFixture + -> FinalPreludeReadiness +bootstrapPreludeReadiness = + FinalPreludeReadiness . bootstrapPreludeModule + +-- | Test-only seam for exercising a synthetic distinguished prelude. +fixtureFinalPreludeReadinessFromSealed + :: SealedTypedModule + -> FinalPreludeReadiness +fixtureFinalPreludeReadinessFromSealed = + FinalPreludeReadiness + +data BootstrapError + = BootstrapParseFailed !Prelude.PreludeParseError + | BootstrapDriverOpenFailed !Declaration.DriverOpenError + | BootstrapDeclarationFailed !Declaration.DeclarationError + | BootstrapSealFailed !SemanticInterfaceError + deriving stock (Show) + +-- | Construct the empty distinguished prelude used only by compiler fixtures. +buildBootstrapPreludeFixture + :: CheckedFoundation + -> Declaration.VampireResolver + -> IO (Either BootstrapError BootstrapPreludeFixture) +buildBootstrapPreludeFixture foundation resolver = do + parsedResult <- + Prelude.parseReservedPreludeSource + Prelude.emptyBootstrapSourceInput + case parsedResult of + Left err -> + pure (Left (BootstrapParseFailed err)) + Right reserved -> do + let input = identifiedReservedPrelude reserved + syntax = + identifiedParsedModuleSyntaxInterface + (identifiedModuleParsed input) + driver <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + resolver + Declaration.FreshValidation + emptyDriver + pure case driver of + Left err -> + Left (BootstrapDriverOpenFailed err) + Right (Declaration.DriverSucceeded + () semantic prefix _closure) -> + Right + (BootstrapPreludeFixture + (FinalPreludeSession + Prelude.emptyBootstrapSourceInput + input + (SealedTypedModule + preludeModuleName + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + [] + semantic + prefix)) + ModuleRootMiss)) + Right + (Declaration.DriverFailed + (Declaration.DriverDeclarationFailed err) + _prefix) -> + Left (BootstrapDeclarationFailed err) + Right (Declaration.DriverSealFailed err _prefix) -> + Left (BootstrapSealFailed err) + where + emptyDriver :: Declaration.ModuleDriver Void () + emptyDriver = pure () + + +data FinalPreludeReadinessError + = FinalPreludeReadinessSourceLoadFailed !Prelude.PreludeLoadError + | FinalPreludeReadinessSourceParseFailed !Prelude.PreludeParseError + | FinalPreludeReadinessBuildFailed !FinalPrelude.FinalPreludeFailure + | FinalPreludeReadinessBuildOpenFailed !Declaration.DriverOpenError + | FinalPreludeReadinessArtifactKeyFailed !ModuleArtifactKeyError + | FinalPreludeReadinessStoreFailed !Store.StoreFailure + | FinalPreludeReadinessCachedModuleFailed !CachedTypedModuleError + | FinalPreludeReadinessAcknowledgementMismatch + !ModuleArtifactResult + !ModuleArtifactResult + deriving stock (Show) + +-- | Acquire the exact packaged final prelude through its ordinary module root. +-- +-- Loading and parsing happen once before the root lookup. A hit is validated +-- and materialized through the generic cached-module boundary; a miss reuses +-- that parsed input for confined construction and atomic publication. +acquireFinalPreludeSession + :: Store.StoreMemo + -> Store.Store + -> CheckedFoundation + -> Declaration.VampireResolver + -> IO (Either FinalPreludeReadinessError FinalPreludeSession) +acquireFinalPreludeSession memo store foundation resolver = + Prelude.loadReservedPreludeSourceInput >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessSourceLoadFailed failure)) + Right source -> + Prelude.parseReservedPreludeSource source >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessSourceParseFailed failure)) + Right parsed -> + acquire source parsed + where + acquire source parsed = + case moduleArtifactKey + preludeModuleName + parsedId + [] + (theoryId foundation) of + Left failure -> + pure (Left (FinalPreludeReadinessArtifactKeyFailed failure)) + Right key -> do + Store.loadCachedModuleInstallation + memo store key (moduleSyntaxAssertedId syntax) >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessStoreFailed failure)) + Right (Just installation) -> + pure do + sealed <- first FinalPreludeReadinessCachedModuleFailed + (cachedSealedTypedModule + foundation [] installation) + pure + (FinalPreludeSession + source + identified sealed ModuleRootHit) + Right Nothing -> + build source parsed key + where + identified = identifiedReservedPrelude parsed + parsedId = identifiedParsedModuleId (identifiedModuleParsed identified) + syntax = identifiedParsedModuleSyntaxInterface + (identifiedModuleParsed identified) + + build source parsed key = + FinalPrelude.buildParsedFinalPreludeCandidate + foundation parsed resolver >>= \case + FinalPrelude.FinalPreludeBuildFailed failure _prefix -> + pure (Left (FinalPreludeReadinessBuildFailed failure)) + FinalPrelude.FinalPreludeBuildOpenFailed failure -> + pure (Left (FinalPreludeReadinessBuildOpenFailed failure)) + FinalPrelude.FinalPreludeBuilt candidate -> + publish source key candidate + FinalPrelude.FinalPreludeSourceLoadFailed failure -> + pure (Left (FinalPreludeReadinessSourceLoadFailed failure)) + FinalPrelude.FinalPreludeSourceParseFailed failure -> + pure (Left (FinalPreludeReadinessSourceParseFailed failure)) + + publish source key candidate = do + let parsed = FinalPrelude.finalPreludeParsed candidate + identified = identifiedReservedPrelude parsed + syntax = FinalPrelude.finalPreludeSyntax candidate + semantic = FinalPrelude.finalPreludeSemantic candidate + prefix = FinalPrelude.finalPreludePrefix candidate + artifact = + moduleArtifactResult + key + (moduleSyntaxAssertedId syntax) + (semanticInterfaceAssertedId semantic) + Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessStoreFailed failure)) + Right acknowledged + | acknowledged /= artifact -> + pure + (Left + (FinalPreludeReadinessAcknowledgementMismatch + artifact + acknowledged)) + | otherwise -> + pure + (Right + (FinalPreludeSession + source + identified + (SealedTypedModule + preludeModuleName + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + [] + semantic + prefix)) + ModuleRootMiss)) + + +data TypedModuleInput = TypedModuleInput + !ModuleName + !IdentifiedModuleInput + !ModuleSyntaxInterface + !CheckedFoundation + !FinalPreludeReadiness + ![SealedTypedModule] + !Declaration.VampireResolver + !Declaration.ValidationRun + +data TypedModuleInputError + = TypedDirectModuleMismatch ![ModuleName] ![ModuleName] + | TypedSyntaxInputMismatch ![SyntaxInterfaceId] ![SyntaxInterfaceId] + deriving stock (Show, Eq) + +renderTypedModuleInputError :: TypedModuleInputError -> Text +renderTypedModuleInputError = \case + TypedDirectModuleMismatch expected actual -> + "direct module inputs differ: expected " <> shown expected + <> ", found " <> shown actual + TypedSyntaxInputMismatch expected actual -> + "direct syntax inputs differ: expected " <> shown expected + <> ", found " <> shown actual + where + shown :: Show value => value -> Text + shown = Text.pack . show + +typedModuleInput + :: CheckedFoundation + -> FinalPreludeReadiness + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> ParsedModule + -> [SealedTypedModule] + -> Either TypedModuleInputError TypedModuleInput +typedModuleInput + foundation readiness resolver validationRun parsed direct = do + unless (expectedOwners == actualOwners) + (Left + (TypedDirectModuleMismatch + expectedOwners + actualOwners)) + unless (expectedSyntax == actualSyntax) + (Left + (TypedSyntaxInputMismatch + expectedSyntax + actualSyntax)) + pure + (TypedModuleInput + owner + identified + syntax + foundation + readiness + direct + resolver + validationRun) + where + identified = identifiedPhysicalModule parsed + owner = identifiedModuleOwner identified + syntax = identifiedParsedModuleSyntaxInterface (identifiedModuleParsed identified) + expectedOwners = + moduleName + <$> nubOrd + (parsedImportedAddress + <$> parsedModuleImports parsed) + actualOwners = sealedTypedModuleOwner <$> direct + expectedSyntax = + nubOrd + ( moduleSyntaxAssertedId + (sealedTypedModuleSyntax prelude) + : ( moduleSyntaxAssertedId + . sealedTypedModuleSyntax + <$> direct + ) + ) + actualSyntax = moduleSyntaxDirectInputs syntax + FinalPreludeReadiness prelude = readiness + +data TypedPathError + = TypedExactCompileFailed !Exact.ExactCompileError + | TypedExactDatatypeFailed !ExactDatatype.ExactDatatypeError + | TypedExactInductiveFailed !ExactInductive.ExactInductiveError + | TypedExactProofFailed !ExactProof.ExactProofError + | TypedUnmatchedProof !Location + deriving stock (Show, Eq) + +data TypedModuleFailure + = TypedDeclarationFailed !Declaration.DeclarationError + | TypedActionFailed !TypedPathError + | TypedSealFailed !SemanticInterfaceError + deriving stock (Show, Eq) + +typedModuleFailureLocation :: TypedModuleFailure -> Maybe Location +typedModuleFailureLocation = \case + TypedActionFailed (TypedExactCompileFailed failure) -> + Just (Exact.exactCompileErrorLocation failure) + TypedActionFailed (TypedExactDatatypeFailed failure) -> + Just (ExactDatatype.exactDatatypeErrorLocation failure) + TypedActionFailed (TypedExactInductiveFailed failure) -> + Just (ExactInductive.exactInductiveErrorLocation failure) + TypedActionFailed (TypedExactProofFailed failure) -> + Just (ExactProof.exactProofErrorLocation failure) + TypedActionFailed (TypedUnmatchedProof location) -> + Just location + TypedDeclarationFailed failure -> + Declaration.declarationErrorLocation failure + TypedSealFailed{} -> + Nothing + +renderTypedModuleFailure :: TypedModuleFailure -> Text +renderTypedModuleFailure = \case + TypedDeclarationFailed failure -> + Declaration.renderDeclarationError failure + TypedActionFailed (TypedExactCompileFailed failure) -> + Exact.renderExactCompileError failure + TypedActionFailed (TypedExactDatatypeFailed failure) -> + ExactDatatype.renderExactDatatypeError failure + TypedActionFailed (TypedExactInductiveFailed failure) -> + ExactInductive.renderExactInductiveError failure + TypedActionFailed (TypedExactProofFailed failure) -> + ExactProof.renderExactProofError failure + TypedActionFailed (TypedUnmatchedProof location) -> + locationToText location + <> ": this proof does not follow a claim" + TypedSealFailed failure -> + renderSemanticInterfaceError failure + +data TypedModuleResult + = TypedModuleOpenFailed !Declaration.DriverOpenError + | TypedModuleSucceeded !SealedTypedModule + | TypedModuleFailed + !TypedModuleFailure + !Declaration.PendingModulePrefix + +data PlannedTypedDeclaration + = PlannedBinding + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) + | PlannedSourceAxiom + !(Declaration.PlannedDeclaration ()) + | PlannedInductive + !(Declaration.PlannedDeclaration + ExactInductive.CheckedExactInductiveAuthorization) + | PlannedDatatype + !(Declaration.PlannedDeclaration + ExactDatatype.CheckedExactDatatypeAuthorization) + | PlannedStructure + !(Declaration.PlannedDeclaration + Exact.CheckedExactStructureAuthorization) + | PlannedProof + !(Declaration.PlannedDeclaration + ExactProof.CheckedExactProofAuthorization) + +data TypedPlanningFailure + = TypedPlanningPathFailure !TypedPathError + | TypedPlanningDeclarationFailure !Declaration.DeclarationError + +data TypedModulePlan = TypedModulePlan + ![PlannedTypedDeclaration] + !(Maybe TypedPlanningFailure) + +runTypedModule :: TypedModuleInput -> IO TypedModuleResult +runTypedModule + (TypedModuleInput + owner identified syntax foundation readiness direct resolver + validationRun) = do + let FinalPreludeReadiness prelude = readiness + action = do + traverse_ + (Declaration.importSealedModuleDriver + . sealedTypedModuleEvidence) + effectiveDirect + TypedModulePlan planned terminal <- + Declaration.runProspectiveLoweringDriver + (planSourceItems [] + (typedSourceItems + (identifiedParsedModuleBlocks + (identifiedModuleParsed identified)))) + traverse_ admitPlannedDeclaration planned + traverse_ failPlanning terminal + semanticDirect = + semanticInterfaceAssertedId + (sealedTypedModuleSemantic prelude) + : ( semanticInterfaceAssertedId + . sealedTypedModuleSemantic + <$> direct + ) + effectiveDirect = + prelude : direct + occurrences = + identifiedParsedModuleSyntaxOccurrences + (identifiedModuleParsed identified) + planSourceItems completed [] = + pure (TypedModulePlan (reverse completed) Nothing) + planSourceItems completed (item : remaining) = + case item of + TypedUnmatchedSourceProof location -> + pure + (TypedModulePlan + (reverse completed) + (Just + (TypedPlanningPathFailure + (TypedUnmatchedProof location)))) + TypedSourceDeclarationItem declaration -> do + planDeclaration declaration >>= \case + Left failure -> + pure + (TypedModulePlan + (reverse completed) + (Just failure)) + Right planned -> + planSourceItems (planned : completed) remaining + + planDeclaration sourceDeclaration = + case block of + Raw.BlockClaim{} -> + planClaim block explicitProof + Raw.BlockProof{} -> + impossible + "typed declaration association retained a proof head" + Raw.BlockSig{} -> + planSelected block + Raw.BlockAbbr{} -> + planSelected block + Raw.BlockDefn{} -> + planSelected block + Raw.BlockAxiom{} -> + planSourceAxiom block + Raw.BlockInductive{} -> + planInductive block + Raw.BlockData{} -> + planDatatype block + Raw.BlockStruct{} -> + planStructure block + where + blockIndex = + typedSourceDeclarationBlockIndex sourceDeclaration + block = typedSourceDeclarationHead sourceDeclaration + explicitProof = + typedSourceDeclarationProof sourceDeclaration + + planSelected selected = do + prepared <- + Exact.prepareExactDeclaration + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right declaration -> do + Exact.lowerPreparedExactBinding declaration >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedBinding checked + + planSourceAxiom selected = do + prepared <- Exact.prepareExactSourceAxiom selected + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right axiom -> do + Exact.lowerPreparedExactSourceAxiom axiom >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedSourceAxiom checked + + planInductive selected = do + prepared <- + ExactInductive.prepareExactInductive + foundation + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactInductiveFailed failure))) + Right inductive -> do + ExactInductive.lowerPreparedExactInductive inductive + >>= \case + Left failure -> + planningDeclarationFailure failure + Right checked -> + planChecked PlannedInductive checked + + planDatatype selected = do + prepared <- + ExactDatatype.prepareExactDatatype + selected + [ ( parsedSyntaxOccurrenceLocation occurrence + , parsedSyntaxOccurrenceMarker occurrence + , parsedSyntaxOccurrenceEntry occurrence + ) + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactDatatypeFailed failure))) + Right datatype -> do + ExactDatatype.lowerPreparedExactDatatype datatype + >>= \case + Left failure -> + planningDeclarationFailure failure + Right checked -> + planChecked PlannedDatatype checked + + planStructure selected = do + prepared <- + Exact.prepareExactStructure + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right structure -> do + Exact.lowerPreparedExactStructure structure >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedStructure checked + + planClaim selected selectedProof = do + prepared <- + ExactProof.prepareExactProof selected selectedProof + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactProofFailed failure))) + Right proof -> do + ExactProof.lowerPreparedExactProof proof >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedProof checked + + planChecked + :: forall body. + (Declaration.PlannedDeclaration body + -> PlannedTypedDeclaration) + -> Declaration.CheckedDeclaration body + -> Declaration.LoweringDriver + (Either TypedPlanningFailure PlannedTypedDeclaration) + planChecked constructor checked = + Declaration.planCheckedDeclaration checked >>= \case + Left failure -> planningDeclarationFailure failure + Right planned -> pure (Right (constructor planned)) + + planningDeclarationFailure = + pure . Left . TypedPlanningDeclarationFailure + + admitPlannedDeclaration = \case + PlannedBinding planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactBinding) + PlannedSourceAxiom planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactSourceAxiom) + PlannedInductive planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned + ExactInductive.authorizeCheckedExactInductive) + PlannedDatatype planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactDatatype.authorizeCheckedExactDatatype) + PlannedStructure planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactStructure) + PlannedProof planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactProof.authorizeCheckedExactProof) + + failPlanning = \case + TypedPlanningPathFailure failure -> + Declaration.failModuleDriver failure + TypedPlanningDeclarationFailure failure -> + Declaration.failDeclarationDriver failure + result <- + Declaration.runModuleDriver + foundation + owner + semanticDirect + resolver + validationRun + action + pure case result of + Left err -> + TypedModuleOpenFailed err + Right (Declaration.DriverSucceeded () semantic prefix _closure) -> + TypedModuleSucceeded + (SealedTypedModule + owner + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + (sealedTypedModuleEvidence <$> effectiveDirect) + semantic + prefix)) + Right + (Declaration.DriverFailed failure prefix) -> + TypedModuleFailed + (case failure of + Declaration.DriverDeclarationFailed err -> + TypedDeclarationFailed err + Declaration.DriverActionFailed err -> + TypedActionFailed err) + prefix + Right (Declaration.DriverSealFailed err prefix) -> + TypedModuleFailed (TypedSealFailed err) prefix diff --git a/source/Felix/Checking/Semantic.hs b/source/Felix/Checking/Semantic.hs new file mode 100644 index 0000000..c9442f3 --- /dev/null +++ b/source/Felix/Checking/Semantic.hs @@ -0,0 +1,1759 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Canonical semantic declaration, prefix, interface, and validation keys. +module Felix.Checking.Semantic + ( DeclarationSlot + , declarationSlot + , declarationSlotModule + , declarationSlotOrdinal + , FactSlot + , factSlot + , factSlotModule + , factSlotOrdinal + , SemanticName + , semanticName + , semanticNameText + , FactSearchEligibility(..) + , SemanticFactOccurrence + , semanticFactOccurrence + , semanticFactSlot + , semanticFactProposition + , semanticFactAuthority + , semanticFactSearchEligibility + , semanticFactFingerprint + , SemanticFactOccurrenceFingerprint + , semanticFactOccurrenceFingerprint + , semanticFactFingerprintDigest + , SemanticAlias + , semanticAlias + , semanticAliasName + , semanticAliasTarget + , SemanticGlobalKey(..) + , semanticGlobalKeyFromLexicalEntry + , semanticGlobalKeyType + , SemanticGlobalTarget(..) + , semanticGlobalTargetObject + , semanticGlobalTargetRequirements + , SemanticGlobalBinding + , semanticGlobalBinding + , semanticGlobalBindingKey + , semanticGlobalBindingTarget + , SemanticGlobalTargetError(..) + , validateSemanticGlobalBindingTarget + , SemanticEnvironmentDelta + , emptySemanticEnvironmentDelta + , semanticEnvironmentDelta + , semanticEnvironmentWithStructures + , semanticEnvironmentBindings + , semanticEnvironmentStructures + , SemanticStructurePhrase + , semanticStructurePhrase + , semanticStructurePhraseSingular + , semanticStructurePhrasePlural + , semanticStructurePhraseMarker + , SemanticStructureOperation + , semanticStructureOperation + , semanticStructureOperationSymbol + , semanticStructureOperationObject + , SemanticStructureDescriptor + , semanticStructureDescriptor + , semanticStructureDescriptorPhrase + , semanticStructureDescriptorPredicate + , semanticStructureDescriptorParents + , semanticStructureDescriptorOperations + , SemanticEnvironmentError(..) + , DeclarationInterfaceDelta + , declarationInterfaceDelta + , declarationDeltaSlot + , declarationDeltaFacts + , declarationDeltaAliases + , declarationDeltaObjects + , declarationDeltaPropositions + , declarationDeltaEnvironment + , DeclarationInterfaceError(..) + , SemanticInterfaceId + , semanticInterfaceIdDigest + , SemanticInterface + , semanticInterface + , semanticInterfaceOwner + , semanticInterfaceDirectInputs + , semanticInterfaceDeclarations + , semanticInterfaceAssertedId + , SemanticInterfaceError(..) + , validateSemanticInterface + , renderSemanticInterfaceError + , PrefixContextId + , initialPrefixContextId + , PrefixContextError(..) + , nextPrefixContextId + , prefixContextIdDigest + , ProofSyntaxId + , proofSyntaxId + , DeclarationSyntaxId + , declarationSyntaxId + , ProofValidationKey + , proofValidationKey + , proofValidationKeyDigest + , ProofValidationRecord + , proofValidationRecord + , proofValidationRecordKey + , proofValidationRecordCertificate + , DeclarationValidationKey + , declarationValidationKey + , declarationValidationKeyDigest + , DeclarationValidationRecord + , declarationValidationRecord + , declarationValidationRecordKey + , declarationValidationRecordCertificates + , ModuleArtifactKey + , moduleArtifactKey + , moduleArtifactKeyOwner + , moduleArtifactKeyDirectSemanticInputs + , moduleArtifactKeyTheory + , ModuleArtifactKeyError(..) + , ModuleArtifactId + , moduleArtifactId + , moduleArtifactIdDigest + , ModuleArtifactResult + , moduleArtifactResult + , moduleArtifactResultId + , moduleArtifactResultSyntax + , moduleArtifactResultSemantic + , putModuleArtifactKeyCache + , getModuleArtifactKeyCache + , putModuleArtifactIdCache + , getModuleArtifactIdCache + , putModuleArtifactResultCache + , getModuleArtifactResultCache + , putSemanticFactOccurrenceFingerprintCache + , getSemanticFactOccurrenceFingerprintCache + , putSemanticFactOccurrenceCache + , getSemanticFactOccurrenceCache + , putSemanticEnvironmentDeltaCache + , getSemanticEnvironmentDeltaCache + , putSemanticGlobalKeyCache + , getSemanticGlobalKeyCache + , putDeclarationInterfaceDeltaCache + , getDeclarationInterfaceDeltaCache + , putSemanticInterfaceCache + , getSemanticInterfaceCache + , putSemanticInterfaceIdCache + , getSemanticInterfaceIdCache + , putPrefixContextIdCache + , getPrefixContextIdCache + , putProofValidationRecordCache + , getProofValidationRecordCache + , putDeclarationValidationRecordCache + , getDeclarationValidationRecordCache + ) where + +import Base +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Identity +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity +import Felix.Source +import Felix.Syntax.Interface +import Felix.Syntax.Abstract + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Numeric.Natural (Natural) +import Data.Set qualified as Set +import Data.Text qualified as Text + + +data DeclarationSlot = DeclarationSlot + !ModuleName + !LocalDeclarationOrdinal + deriving stock (Show, Eq, Ord) + +declarationSlot + :: ModuleName + -> LocalDeclarationOrdinal + -> DeclarationSlot +declarationSlot = + DeclarationSlot + +declarationSlotModule :: DeclarationSlot -> ModuleName +declarationSlotModule (DeclarationSlot owner _) = + owner + +declarationSlotOrdinal + :: DeclarationSlot + -> LocalDeclarationOrdinal +declarationSlotOrdinal (DeclarationSlot _ ordinal) = + ordinal + +data FactSlot = FactSlot + !ModuleName + !LocalFactOrdinal + deriving stock (Show, Eq, Ord) + +factSlot :: ModuleName -> LocalFactOrdinal -> FactSlot +factSlot = + FactSlot + +factSlotModule :: FactSlot -> ModuleName +factSlotModule (FactSlot owner _) = + owner + +factSlotOrdinal :: FactSlot -> LocalFactOrdinal +factSlotOrdinal (FactSlot _ ordinal) = + ordinal + +newtype SemanticName = + SemanticName Text + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticName :: Text -> SemanticName +semanticName = + SemanticName + +semanticNameText :: SemanticName -> Text +semanticNameText (SemanticName name) = + name + +data FactSearchEligibility + = SearchEligible + | SearchIneligible + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +newtype SemanticFactOccurrenceFingerprint = + SemanticFactOccurrenceFingerprint CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticFactOccurrenceFingerprint + :: FactSlot + -> FactAuthority + -> SemanticFactOccurrenceFingerprint +semanticFactOccurrenceFingerprint slot authority = + SemanticFactOccurrenceFingerprint + (hashCacheFields + "felix-semantic-fact-occurrence-v1" + [ encodeCache (putFactSlotCache slot) + , encodeCache (putFactAuthorityCache authority) + ]) + +semanticFactFingerprintDigest + :: SemanticFactOccurrenceFingerprint + -> CacheDigest +semanticFactFingerprintDigest + (SemanticFactOccurrenceFingerprint digest) = + digest + +data SemanticFactOccurrence = SemanticFactOccurrence + !FactSlot + !FactAuthority + !FactSearchEligibility + deriving stock (Show, Eq, Ord, Generic) + +semanticFactOccurrence + :: FactSlot + -> FactAuthority + -> FactSearchEligibility + -> SemanticFactOccurrence +semanticFactOccurrence = + SemanticFactOccurrence + +semanticFactSlot :: SemanticFactOccurrence -> FactSlot +semanticFactSlot + (SemanticFactOccurrence slot _ _) = + slot + +semanticFactProposition + :: SemanticFactOccurrence + -> PropositionId +semanticFactProposition + (SemanticFactOccurrence _ authority _) = + theoremRefProposition + (factAuthorityTheorem authority) + +semanticFactAuthority + :: SemanticFactOccurrence + -> FactAuthority +semanticFactAuthority + (SemanticFactOccurrence _ authority _) = + authority + +semanticFactSearchEligibility + :: SemanticFactOccurrence + -> FactSearchEligibility +semanticFactSearchEligibility + (SemanticFactOccurrence _ _ eligibility) = + eligibility + +semanticFactFingerprint + :: SemanticFactOccurrence + -> SemanticFactOccurrenceFingerprint +semanticFactFingerprint + (SemanticFactOccurrence slot authority _) = + semanticFactOccurrenceFingerprint slot authority + +data SemanticAlias = SemanticAlias + !SemanticName + !SemanticFactOccurrenceFingerprint + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticAlias + :: SemanticName + -> SemanticFactOccurrenceFingerprint + -> SemanticAlias +semanticAlias = + SemanticAlias + +semanticAliasName :: SemanticAlias -> SemanticName +semanticAliasName (SemanticAlias name _) = + name + +semanticAliasTarget + :: SemanticAlias + -> SemanticFactOccurrenceFingerprint +semanticAliasTarget (SemanticAlias _ target) = + target + + +-- | Exact source-level name used to resolve a declared monomorphic object. +-- Presentation markers and expression fixity are deliberately absent. +data SemanticGlobalKey + = SemanticLeftAdjective !Pattern + | SemanticRightAdjective !Pattern + | SemanticFunctionPhrase !Pattern !Pattern + | SemanticNoun !Pattern !Pattern + | SemanticVerb !Pattern !Pattern + | SemanticRelation !Token !ParameterArity + | SemanticExpressionFunction !Pattern + | SemanticPrefixPredicate !Text !Natural + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalKeyType :: SemanticGlobalKey -> Maybe CoreType +semanticGlobalKeyType = \case + SemanticLeftAdjective pat -> + Just (setArguments (1 + patternArity pat) TyProp) + SemanticRightAdjective pat -> + Just (setArguments (1 + patternArity pat) TyProp) + SemanticFunctionPhrase singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (patternArity singular) TySet) + | otherwise -> Nothing + SemanticNoun singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (1 + patternArity singular) TyProp) + | otherwise -> Nothing + SemanticVerb singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (1 + patternArity singular) TyProp) + | otherwise -> Nothing + SemanticRelation _token arity -> + Just + (setArguments + (2 + parameterArityValue arity) + TyProp) + SemanticExpressionFunction pat -> + Just (setArguments (patternArity pat) TySet) + SemanticPrefixPredicate _command arity -> + Just (setArguments arity TyProp) + where + patternArity :: Pattern -> Natural + patternArity = \case + End -> 0 + HoleCons rest -> 1 + patternArity rest + TokenCons _token rest -> patternArity rest + + setArguments :: Natural -> CoreType -> CoreType + setArguments argumentCount result = + foldr + (const (TyArrow TySet)) + result + [1 .. argumentCount] + +semanticGlobalKeyFromLexicalEntry + :: CanonicalLexicalEntry + -> Maybe SemanticGlobalKey +semanticGlobalKeyFromLexicalEntry = \case + CanonicalLeftAdjective pat _marker -> + Just (SemanticLeftAdjective pat) + CanonicalRightAdjective pat _marker -> + Just (SemanticRightAdjective pat) + CanonicalFunctionPhrase singular plural _marker -> + Just (SemanticFunctionPhrase singular plural) + CanonicalNoun singular plural _marker -> + Just (SemanticNoun singular plural) + CanonicalVerb singular plural _marker -> + Just (SemanticVerb singular plural) + CanonicalRelation token arity _marker -> + Just (SemanticRelation token arity) + CanonicalExpressionFunction pat _marker _fixity -> + Just (SemanticExpressionFunction pat) + CanonicalPrefixPredicate command arity _marker -> + Just (SemanticPrefixPredicate command arity) + CanonicalStructureNoun{} -> + Nothing + CanonicalStructureOperation{} -> + Nothing + +data SemanticGlobalTarget + = GlobalReference !ObjectId + | TransparentExpansion !ObjectId + | ContextualTransparentExpansion + !ObjectId + !(Map.Map StructSymbol ObjectId) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalTargetObject :: SemanticGlobalTarget -> ObjectId +semanticGlobalTargetObject = \case + GlobalReference identity -> identity + TransparentExpansion identity -> identity + ContextualTransparentExpansion identity _requirements -> identity + +semanticGlobalTargetRequirements + :: SemanticGlobalTarget + -> Map.Map StructSymbol ObjectId +semanticGlobalTargetRequirements = \case + GlobalReference{} -> Map.empty + TransparentExpansion{} -> Map.empty + ContextualTransparentExpansion _identity requirements -> requirements + +data SemanticGlobalBinding = SemanticGlobalBinding + !SemanticGlobalKey + !SemanticGlobalTarget + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalBinding + :: SemanticGlobalKey + -> SemanticGlobalTarget + -> SemanticGlobalBinding +semanticGlobalBinding = + SemanticGlobalBinding + +semanticGlobalBindingKey + :: SemanticGlobalBinding + -> SemanticGlobalKey +semanticGlobalBindingKey (SemanticGlobalBinding key _target) = + key + +semanticGlobalBindingTarget + :: SemanticGlobalBinding + -> SemanticGlobalTarget +semanticGlobalBindingTarget (SemanticGlobalBinding _key target) = + target + +data SemanticGlobalTargetError + = SemanticGlobalKeyHasInconsistentArity !SemanticGlobalKey + | SemanticGlobalTargetMissing !ObjectId + | SemanticGlobalTargetIsIntrinsic !ObjectId + | SemanticGlobalTargetTypeMismatch !ObjectId !CoreType !CoreType + | SemanticGlobalExpansionNotTransparent !ObjectId + | SemanticGlobalContextualRequirementsEmpty !ObjectId + | SemanticGlobalContextualRequirementMissing !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementIsIntrinsic !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementTypeMismatch + !StructSymbol !ObjectId !CoreType !CoreType + | SemanticGlobalContextualRequirementNotProvided + !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementNotReferenced !StructSymbol !ObjectId + deriving stock (Show, Eq) + +validateSemanticGlobalBindingTarget + :: Set.Set (StructSymbol, ObjectId) + -> CheckedObjectClosure + -> SemanticGlobalBinding + -> Either SemanticGlobalTargetError () +validateSemanticGlobalBindingTarget operationBindings closure binding = do + expected <- + maybe + (Left (SemanticGlobalKeyHasInconsistentArity key)) + Right + (semanticGlobalKeyType key) + content <- + maybe + (Left (SemanticGlobalTargetMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + when + (objectIdFamily identity == IntrinsicObject) + (Left (SemanticGlobalTargetIsIntrinsic identity)) + let targetExpected = + case target of + ContextualTransparentExpansion{} -> + TyArrow TySet expected + _ -> expected + actual = objectContentType content + unless + (actual == targetExpected) + (Left + (SemanticGlobalTargetTypeMismatch + identity targetExpected actual)) + case target of + GlobalReference{} -> pure () + TransparentExpansion{} -> + validateTransparent content + ContextualTransparentExpansion _ requirements -> do + validateTransparent content + when + (Map.null requirements) + (Left (SemanticGlobalContextualRequirementsEmpty identity)) + traverse_ (validateRequirement content) (Map.toAscList requirements) + where + key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + identity = semanticGlobalTargetObject target + + validateTransparent = \case + TransparentObjectContent{} -> pure () + _ -> Left (SemanticGlobalExpansionNotTransparent identity) + + validateRequirement content (symbol, object) = do + operationContent <- + maybe + (Left + (SemanticGlobalContextualRequirementMissing + symbol object)) + Right + (lookupCheckedObjectContent object closure) + when + (objectIdFamily object == IntrinsicObject) + (Left + (SemanticGlobalContextualRequirementIsIntrinsic + symbol object)) + let expectedOperation = TyArrow TySet TySet + actualOperation = objectContentType operationContent + unless + (actualOperation == expectedOperation) + (Left + (SemanticGlobalContextualRequirementTypeMismatch + symbol object expectedOperation actualOperation)) + unless + ((symbol, object) `Set.member` operationBindings) + (Left + (SemanticGlobalContextualRequirementNotProvided + symbol object)) + case content of + TransparentObjectContent _theory _coreType body -> + unless + (object `Set.member` canonicalTermGlobals body) + (Left + (SemanticGlobalContextualRequirementNotReferenced + symbol object)) + _ -> impossible "a contextual expansion was not transparent" + +data SemanticEnvironmentDelta + = EmptySemanticEnvironmentDelta + | SemanticGlobalBindings ![SemanticGlobalBinding] + | SemanticGlobalBindingsAndStructures + ![SemanticGlobalBinding] + ![SemanticStructureDescriptor] + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +data SemanticStructurePhrase = SemanticStructurePhrase + !Pattern + !Pattern + !Marker + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructurePhrase :: LexicalItemSgPl -> SemanticStructurePhrase +semanticStructurePhrase (LexicalItemSgPl forms marker) = + SemanticStructurePhrase (sg forms) (pl forms) marker + +semanticStructurePhraseSingular :: SemanticStructurePhrase -> Pattern +semanticStructurePhraseSingular (SemanticStructurePhrase singular _ _) = + singular + +semanticStructurePhrasePlural :: SemanticStructurePhrase -> Pattern +semanticStructurePhrasePlural (SemanticStructurePhrase _ plural _) = + plural + +semanticStructurePhraseMarker :: SemanticStructurePhrase -> Marker +semanticStructurePhraseMarker (SemanticStructurePhrase _ _ marker) = + marker + +data SemanticStructureOperation = SemanticStructureOperation + !StructSymbol + !ObjectId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructureOperation + :: StructSymbol + -> ObjectId + -> SemanticStructureOperation +semanticStructureOperation = + SemanticStructureOperation + +semanticStructureOperationSymbol + :: SemanticStructureOperation + -> StructSymbol +semanticStructureOperationSymbol (SemanticStructureOperation symbol _) = + symbol + +semanticStructureOperationObject + :: SemanticStructureOperation + -> ObjectId +semanticStructureOperationObject (SemanticStructureOperation _ object) = + object + +data SemanticStructureDescriptor = SemanticStructureDescriptor + !SemanticStructurePhrase + !(Maybe ObjectId) + ![SemanticStructurePhrase] + ![SemanticStructureOperation] + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructureDescriptor + :: SemanticStructurePhrase + -> Maybe ObjectId + -> [SemanticStructurePhrase] + -> [SemanticStructureOperation] + -> Either SemanticEnvironmentError SemanticStructureDescriptor +semanticStructureDescriptor structurePhrase predicate parents operations = do + case firstDuplicate parents of + Just duplicate -> + Left (DuplicateSemanticStructureParent duplicate) + Nothing -> pure () + when + (structurePhrase `elem` parents) + (Left (SelfSemanticStructureParent structurePhrase)) + case firstDuplicate (semanticStructureOperationSymbol <$> operations) of + Just duplicate -> + Left (DuplicateSemanticStructureOperation duplicate) + Nothing -> pure () + pure + (SemanticStructureDescriptor + structurePhrase predicate parents operations) + +semanticStructureDescriptorPhrase + :: SemanticStructureDescriptor + -> SemanticStructurePhrase +semanticStructureDescriptorPhrase + (SemanticStructureDescriptor structurePhrase _ _ _) = + structurePhrase + +semanticStructureDescriptorPredicate + :: SemanticStructureDescriptor + -> Maybe ObjectId +semanticStructureDescriptorPredicate + (SemanticStructureDescriptor _ predicate _ _) = + predicate + +semanticStructureDescriptorParents + :: SemanticStructureDescriptor + -> [SemanticStructurePhrase] +semanticStructureDescriptorParents + (SemanticStructureDescriptor _ _ parents _) = + parents + +semanticStructureDescriptorOperations + :: SemanticStructureDescriptor + -> [SemanticStructureOperation] +semanticStructureDescriptorOperations + (SemanticStructureDescriptor _ _ _ operations) = + operations + +data SemanticEnvironmentError + = DuplicateSemanticGlobalKey !SemanticGlobalKey + | NonCanonicalSemanticGlobalBindingOrder + | DuplicateSemanticStructure !SemanticStructurePhrase + | NonCanonicalSemanticStructureOrder + | DuplicateSemanticStructureParent !SemanticStructurePhrase + | SelfSemanticStructureParent !SemanticStructurePhrase + | DuplicateSemanticStructureOperation !StructSymbol + deriving stock (Show, Eq) + +emptySemanticEnvironmentDelta :: SemanticEnvironmentDelta +emptySemanticEnvironmentDelta = + EmptySemanticEnvironmentDelta + +semanticEnvironmentDelta + :: [SemanticGlobalBinding] + -> Either SemanticEnvironmentError SemanticEnvironmentDelta +semanticEnvironmentDelta bindings = + semanticEnvironmentWithStructures bindings [] + +semanticEnvironmentWithStructures + :: [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> Either SemanticEnvironmentError SemanticEnvironmentDelta +semanticEnvironmentWithStructures [] [] = + Right EmptySemanticEnvironmentDelta +semanticEnvironmentWithStructures bindings structures = do + case firstDuplicate (semanticGlobalBindingKey <$> bindings) of + Just duplicate -> + Left (DuplicateSemanticGlobalKey duplicate) + Nothing -> + pure () + unless + (bindings == List.sortOn semanticGlobalBindingKey bindings) + (Left NonCanonicalSemanticGlobalBindingOrder) + case firstDuplicate (semanticStructureDescriptorPhrase <$> structures) of + Just duplicate -> + Left (DuplicateSemanticStructure duplicate) + Nothing -> pure () + unless + ( structures + == List.sortOn semanticStructureDescriptorPhrase structures + ) + (Left NonCanonicalSemanticStructureOrder) + pure + (case structures of + [] -> SemanticGlobalBindings bindings + _ -> SemanticGlobalBindingsAndStructures bindings structures) + +semanticEnvironmentBindings + :: SemanticEnvironmentDelta + -> [SemanticGlobalBinding] +semanticEnvironmentBindings = \case + EmptySemanticEnvironmentDelta -> [] + SemanticGlobalBindings bindings -> bindings + SemanticGlobalBindingsAndStructures bindings _ -> bindings + +semanticEnvironmentStructures + :: SemanticEnvironmentDelta + -> [SemanticStructureDescriptor] +semanticEnvironmentStructures = \case + EmptySemanticEnvironmentDelta -> [] + SemanticGlobalBindings{} -> [] + SemanticGlobalBindingsAndStructures _ structures -> structures + + +data DeclarationInterfaceDelta = DeclarationInterfaceDelta + !DeclarationSlot + ![SemanticFactOccurrence] + ![SemanticAlias] + ![ObjectId] + ![PropositionId] + !SemanticEnvironmentDelta + deriving stock (Show, Eq, Ord, Generic) + +data DeclarationInterfaceError + = DeclarationFactOwnerMismatch !FactSlot + | DuplicateDeclarationFactSlot !FactSlot + | DuplicateDeclarationFactFingerprint + !SemanticFactOccurrenceFingerprint + | DuplicateDeclarationAlias !SemanticName + | DuplicateDeclarationObject !ObjectId + | DuplicateDeclarationProposition !PropositionId + | DeclarationFactPropositionMissing !PropositionId + deriving stock (Show, Eq) + +declarationInterfaceDelta + :: DeclarationSlot + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [ObjectId] + -> [PropositionId] + -> SemanticEnvironmentDelta + -> Either DeclarationInterfaceError DeclarationInterfaceDelta +declarationInterfaceDelta + slot facts aliases objects propositions environment = do + traverse_ validateFact facts + rejectDuplicate + DuplicateDeclarationFactSlot + (semanticFactSlot <$> facts) + rejectDuplicate + DuplicateDeclarationFactFingerprint + (semanticFactFingerprint <$> facts) + rejectDuplicate + DuplicateDeclarationAlias + (semanticAliasName <$> aliases) + rejectDuplicate DuplicateDeclarationObject objects + rejectDuplicate DuplicateDeclarationProposition propositions + pure + (DeclarationInterfaceDelta + slot facts aliases objects propositions environment) + where + owner = declarationSlotModule slot + propositionSet = Set.fromList propositions + + validateFact occurrence = do + unless + (factSlotModule (semanticFactSlot occurrence) == owner) + (Left + (DeclarationFactOwnerMismatch + (semanticFactSlot occurrence))) + let proposition = + semanticFactProposition occurrence + unless + (proposition `Set.member` propositionSet) + (Left (DeclarationFactPropositionMissing proposition)) + +declarationDeltaSlot + :: DeclarationInterfaceDelta + -> DeclarationSlot +declarationDeltaSlot + (DeclarationInterfaceDelta slot _ _ _ _ _) = + slot + +declarationDeltaFacts + :: DeclarationInterfaceDelta + -> [SemanticFactOccurrence] +declarationDeltaFacts + (DeclarationInterfaceDelta _ facts _ _ _ _) = + facts + +declarationDeltaAliases + :: DeclarationInterfaceDelta + -> [SemanticAlias] +declarationDeltaAliases + (DeclarationInterfaceDelta _ _ aliases _ _ _) = + aliases + +declarationDeltaObjects + :: DeclarationInterfaceDelta + -> [ObjectId] +declarationDeltaObjects + (DeclarationInterfaceDelta _ _ _ objects _ _) = + objects + +declarationDeltaPropositions + :: DeclarationInterfaceDelta + -> [PropositionId] +declarationDeltaPropositions + (DeclarationInterfaceDelta _ _ _ _ propositions _) = + propositions + +declarationDeltaEnvironment + :: DeclarationInterfaceDelta + -> SemanticEnvironmentDelta +declarationDeltaEnvironment + (DeclarationInterfaceDelta _ _ _ _ _ environment) = + environment + + +newtype SemanticInterfaceId = + SemanticInterfaceId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticInterfaceIdDigest + :: SemanticInterfaceId + -> CacheDigest +semanticInterfaceIdDigest (SemanticInterfaceId digest) = + digest + +data SemanticInterface = SemanticInterface + !ModuleName + ![SemanticInterfaceId] + ![DeclarationInterfaceDelta] + !SemanticInterfaceId + deriving stock (Show, Eq, Ord) + +data SemanticInterfaceError + = DuplicateDirectSemanticInterface !SemanticInterfaceId + | SemanticDeclarationOwnerMismatch !DeclarationSlot + | NonIncreasingDeclarationSlots + | NonIncreasingFactSlots + | SemanticInterfaceIdMismatch + !SemanticInterfaceId + !SemanticInterfaceId + deriving stock (Show, Eq) + +renderSemanticInterfaceError :: SemanticInterfaceError -> Text +renderSemanticInterfaceError = \case + DuplicateDirectSemanticInterface interface -> + "direct semantic interface occurs more than once: " + <> Text.pack (show interface) + SemanticDeclarationOwnerMismatch slot -> + "declaration belongs to a different module: " + <> Text.pack (show slot) + NonIncreasingDeclarationSlots -> + "declaration slots are not in increasing order" + NonIncreasingFactSlots -> + "fact slots are not in increasing order" + SemanticInterfaceIdMismatch expected actual -> + "semantic interface identity mismatch: expected " + <> Text.pack (show expected) + <> ", found " <> Text.pack (show actual) + +semanticInterface + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> Either SemanticInterfaceError SemanticInterface +semanticInterface owner direct declarations = do + validateSemanticInterfaceStructure owner direct declarations + let identity = + computeSemanticInterfaceId owner direct declarations + pure (SemanticInterface owner direct declarations identity) + +validateSemanticInterface + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> SemanticInterfaceId + -> Either SemanticInterfaceError SemanticInterface +validateSemanticInterface owner direct declarations asserted = do + validateSemanticInterfaceStructure owner direct declarations + let computed = + computeSemanticInterfaceId + owner direct declarations + unless + (asserted == computed) + (Left + (SemanticInterfaceIdMismatch asserted computed)) + pure + (SemanticInterface + owner direct declarations asserted) + +validateSemanticInterfaceStructure + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> Either SemanticInterfaceError () +validateSemanticInterfaceStructure owner direct declarations = do + rejectDuplicate + DuplicateDirectSemanticInterface + direct + traverse_ + (\delta -> + unless + (declarationSlotModule + (declarationDeltaSlot delta) + == owner) + (Left + (SemanticDeclarationOwnerMismatch + (declarationDeltaSlot delta)))) + declarations + unless + (strictlyIncreasing + ( localDeclarationOrdinalValue + . declarationSlotOrdinal + . declarationDeltaSlot + <$> declarations)) + (Left NonIncreasingDeclarationSlots) + unless + (strictlyIncreasing + ( localFactOrdinalValue + . factSlotOrdinal + . semanticFactSlot + <$> concatMap + declarationDeltaFacts + declarations)) + (Left NonIncreasingFactSlots) + +semanticInterfaceOwner :: SemanticInterface -> ModuleName +semanticInterfaceOwner + (SemanticInterface owner _ _ _) = + owner + +semanticInterfaceDirectInputs + :: SemanticInterface + -> [SemanticInterfaceId] +semanticInterfaceDirectInputs + (SemanticInterface _ direct _ _) = + direct + +semanticInterfaceDeclarations + :: SemanticInterface + -> [DeclarationInterfaceDelta] +semanticInterfaceDeclarations + (SemanticInterface _ _ declarations _) = + declarations + +semanticInterfaceAssertedId + :: SemanticInterface + -> SemanticInterfaceId +semanticInterfaceAssertedId + (SemanticInterface _ _ _ asserted) = + asserted + +computeSemanticInterfaceId + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> SemanticInterfaceId +computeSemanticInterfaceId owner direct declarations = + SemanticInterfaceId + (hashCacheFields + "felix-semantic-interface-v1" + [ encodeCache (putModuleNameCache owner) + , encodeCache + (putCacheList + putSemanticInterfaceIdCache + direct) + , encodeCache + (putCacheList + putDeclarationInterfaceDeltaCache + declarations) + ]) + + +newtype PrefixContextId = + PrefixContextId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +data PrefixContextError + = DuplicateInitialPrefixSemanticInput !SemanticInterfaceId + deriving stock (Show, Eq) + +initialPrefixContextId + :: TheoryId + -> ModuleName + -> [SemanticInterfaceId] + -> Either PrefixContextError PrefixContextId +initialPrefixContextId theory owner direct = do + rejectDuplicate + DuplicateInitialPrefixSemanticInput + direct + pure + (PrefixContextId + (hashCacheFields + "felix-prefix-initial-v1" + [ encodeCache (putTheoryIdCache theory) + , encodeCache (putModuleNameCache owner) + , encodeCache + (putCacheList + putSemanticInterfaceIdCache + direct) + ])) + +nextPrefixContextId + :: PrefixContextId + -> DeclarationInterfaceDelta + -> PrefixContextId +nextPrefixContextId previous delta = + PrefixContextId + (hashCacheFields + "felix-prefix-step-v1" + [ encodeCache (putPrefixContextIdCache previous) + , encodeCache + (putDeclarationInterfaceDeltaCache delta) + ]) + +prefixContextIdDigest :: PrefixContextId -> CacheDigest +prefixContextIdDigest (PrefixContextId digest) = + digest + + +newtype ProofSyntaxId = + ProofSyntaxId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +proofSyntaxId :: ByteString -> ProofSyntaxId +proofSyntaxId bytes = + ProofSyntaxId + (hashCacheFields "felix-proof-syntax-v1" [bytes]) + +newtype DeclarationSyntaxId = + DeclarationSyntaxId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +declarationSyntaxId :: ByteString -> DeclarationSyntaxId +declarationSyntaxId bytes = + DeclarationSyntaxId + (hashCacheFields "felix-declaration-syntax-v1" [bytes]) + +newtype ProofValidationKey = + ProofValidationKey CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +proofValidationKey + :: TheoremId + -> ProofSyntaxId + -> PrefixContextId + -> ProofValidationKey +proofValidationKey theorem (ProofSyntaxId syntax) prefix = + ProofValidationKey + (hashCacheFields + "felix-proof-validation" + [ mathematicalDigestBytes + (theoremIdDigest theorem) + , cacheDigestBytes syntax + , encodeCache (putPrefixContextIdCache prefix) + ]) + +proofValidationKeyDigest + :: ProofValidationKey + -> CacheDigest +proofValidationKeyDigest (ProofValidationKey digest) = + digest + +data ProofValidationRecord = ProofValidationRecord + !ProofValidationKey + !ValidationCertificate + deriving stock (Show, Eq, Ord, Generic) + +proofValidationRecord + :: ProofValidationKey + -> ValidationCertificate + -> ProofValidationRecord +proofValidationRecord = + ProofValidationRecord + +proofValidationRecordKey + :: ProofValidationRecord + -> ProofValidationKey +proofValidationRecordKey + (ProofValidationRecord key _) = + key + +proofValidationRecordCertificate + :: ProofValidationRecord + -> ValidationCertificate +proofValidationRecordCertificate + (ProofValidationRecord _ certificate) = + certificate + +newtype DeclarationValidationKey = + DeclarationValidationKey CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +declarationValidationKey + :: DeclarationSyntaxId + -> PrefixContextId + -> [ObjectId] + -> [TheoremId] + -> DeclarationValidationKey +declarationValidationKey + (DeclarationSyntaxId syntax) + prefix objects theorems = + DeclarationValidationKey + (hashCacheFields + "felix-declaration-validation" + [ cacheDigestBytes syntax + , encodeCache (putPrefixContextIdCache prefix) + , encodeCache (putCacheList putObjectIdCache objects) + , encodeCache + (putCacheList + (putMathematicalDigestCache . theoremIdDigest) + theorems) + ]) + +declarationValidationKeyDigest + :: DeclarationValidationKey + -> CacheDigest +declarationValidationKeyDigest + (DeclarationValidationKey digest) = + digest + +data DeclarationValidationRecord = DeclarationValidationRecord + !DeclarationValidationKey + ![ValidationCertificate] + deriving stock (Show, Eq, Ord, Generic) + +declarationValidationRecord + :: DeclarationValidationKey + -> [ValidationCertificate] + -> DeclarationValidationRecord +declarationValidationRecord = + DeclarationValidationRecord + +declarationValidationRecordKey + :: DeclarationValidationRecord + -> DeclarationValidationKey +declarationValidationRecordKey + (DeclarationValidationRecord key _) = + key + +declarationValidationRecordCertificates + :: DeclarationValidationRecord + -> [ValidationCertificate] +declarationValidationRecordCertificates + (DeclarationValidationRecord _ certificates) = + certificates + + +data ModuleArtifactKey = ModuleArtifactKey + !ModuleName + !ParsedModuleId + ![SemanticInterfaceId] + !TheoryId + deriving stock (Show, Eq, Ord) + +data ModuleArtifactKeyError + = DuplicateModuleArtifactSemanticInput + !SemanticInterfaceId + deriving stock (Show, Eq) + +moduleArtifactKey + :: ModuleName + -> ParsedModuleId + -> [SemanticInterfaceId] + -> TheoryId + -> Either ModuleArtifactKeyError ModuleArtifactKey +moduleArtifactKey owner parsed direct theory = do + rejectDuplicate + DuplicateModuleArtifactSemanticInput + direct + pure (ModuleArtifactKey owner parsed direct theory) + +moduleArtifactKeyOwner :: ModuleArtifactKey -> ModuleName +moduleArtifactKeyOwner (ModuleArtifactKey owner _parsed _direct _theory) = + owner + +moduleArtifactKeyDirectSemanticInputs + :: ModuleArtifactKey + -> [SemanticInterfaceId] +moduleArtifactKeyDirectSemanticInputs + (ModuleArtifactKey _owner _parsed direct _theory) = + direct + +moduleArtifactKeyTheory :: ModuleArtifactKey -> TheoryId +moduleArtifactKeyTheory + (ModuleArtifactKey _owner _parsed _direct theory) = + theory + +newtype ModuleArtifactId = + ModuleArtifactId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +moduleArtifactId :: ModuleArtifactKey -> ModuleArtifactId +moduleArtifactId key = + ModuleArtifactId + (hashCacheFields + "felix-module-artifact-v1" + [encodeCache (putModuleArtifactKeyCache key)]) + +moduleArtifactIdDigest :: ModuleArtifactId -> CacheDigest +moduleArtifactIdDigest (ModuleArtifactId digest) = + digest + +data ModuleArtifactResult = ModuleArtifactResult + !ModuleArtifactId + !SyntaxInterfaceId + !SemanticInterfaceId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +moduleArtifactResult + :: ModuleArtifactKey + -> SyntaxInterfaceId + -> SemanticInterfaceId + -> ModuleArtifactResult +moduleArtifactResult key = + ModuleArtifactResult (moduleArtifactId key) + +moduleArtifactResultId + :: ModuleArtifactResult + -> ModuleArtifactId +moduleArtifactResultId + (ModuleArtifactResult identity _ _) = + identity + +moduleArtifactResultSyntax + :: ModuleArtifactResult + -> SyntaxInterfaceId +moduleArtifactResultSyntax + (ModuleArtifactResult _ syntax _) = + syntax + +moduleArtifactResultSemantic + :: ModuleArtifactResult + -> SemanticInterfaceId +moduleArtifactResultSemantic + (ModuleArtifactResult _ _ semantic) = + semantic + + +putSemanticFactOccurrenceFingerprintCache + :: SemanticFactOccurrenceFingerprint + -> CachePut +putSemanticFactOccurrenceFingerprintCache + (SemanticFactOccurrenceFingerprint digest) = + putCacheDigest digest + +getSemanticFactOccurrenceFingerprintCache + :: CacheGet SemanticFactOccurrenceFingerprint +getSemanticFactOccurrenceFingerprintCache = + SemanticFactOccurrenceFingerprint <$> getCacheDigest + +putSemanticFactOccurrenceCache + :: SemanticFactOccurrence + -> CachePut +putSemanticFactOccurrenceCache + (SemanticFactOccurrence slot authority eligibility) = do + putFactSlotCache slot + putFactAuthorityCache authority + putEligibility eligibility + +getSemanticFactOccurrenceCache + :: CacheGet SemanticFactOccurrence +getSemanticFactOccurrenceCache = + semanticFactOccurrence + <$> getFactSlotCache + <*> getFactAuthorityCache + <*> getEligibility + +putSemanticEnvironmentDeltaCache + :: SemanticEnvironmentDelta + -> CachePut +putSemanticEnvironmentDeltaCache EmptySemanticEnvironmentDelta = + putCacheTag 0x00 +putSemanticEnvironmentDeltaCache (SemanticGlobalBindings bindings) = do + putCacheTag 0x01 + putCacheList putSemanticGlobalBindingCache bindings +putSemanticEnvironmentDeltaCache + (SemanticGlobalBindingsAndStructures bindings structures) = do + putCacheTag 0x02 + putCacheList putSemanticGlobalBindingCache bindings + putCacheList putSemanticStructureDescriptorCache structures + +getSemanticEnvironmentDeltaCache + :: CacheGet SemanticEnvironmentDelta +getSemanticEnvironmentDeltaCache = + getCacheTag >>= \case + 0x00 -> + pure EmptySemanticEnvironmentDelta + 0x01 -> do + bindings <- getCacheList getSemanticGlobalBindingCache + either + (fail . ("invalid semantic environment delta: " <>) . show) + pure + (semanticEnvironmentDelta bindings) + 0x02 -> do + bindings <- getCacheList getSemanticGlobalBindingCache + structures <- getCacheList getSemanticStructureDescriptorCache + either + (fail . ("invalid semantic environment delta: " <>) . show) + pure + (semanticEnvironmentWithStructures bindings structures) + tag -> + fail + ("unknown semantic environment delta tag " + <> show tag) + +putSemanticGlobalKeyCache :: SemanticGlobalKey -> CachePut +putSemanticGlobalKeyCache = \case + SemanticLeftAdjective pat -> do + putCacheTag 0x00 + putPatternCache pat + SemanticRightAdjective pat -> do + putCacheTag 0x01 + putPatternCache pat + SemanticFunctionPhrase singular plural -> do + putCacheTag 0x02 + putPatternCache singular + putPatternCache plural + SemanticNoun singular plural -> do + putCacheTag 0x03 + putPatternCache singular + putPatternCache plural + SemanticVerb singular plural -> do + putCacheTag 0x04 + putPatternCache singular + putPatternCache plural + SemanticRelation token arity -> do + putCacheTag 0x05 + putTokenCache token + putCacheNatural (parameterArityValue arity) + SemanticExpressionFunction pat -> do + putCacheTag 0x06 + putPatternCache pat + SemanticPrefixPredicate command arity -> do + putCacheTag 0x07 + putCacheText command + putCacheNatural arity + +getSemanticGlobalKeyCache :: CacheGet SemanticGlobalKey +getSemanticGlobalKeyCache = + getCacheTag >>= \case + 0x00 -> SemanticLeftAdjective <$> getPatternCache + 0x01 -> SemanticRightAdjective <$> getPatternCache + 0x02 -> + SemanticFunctionPhrase + <$> getPatternCache + <*> getPatternCache + 0x03 -> + SemanticNoun + <$> getPatternCache + <*> getPatternCache + 0x04 -> + SemanticVerb + <$> getPatternCache + <*> getPatternCache + 0x05 -> + SemanticRelation + <$> getTokenCache + <*> (ParameterArity <$> getCacheNatural) + 0x06 -> SemanticExpressionFunction <$> getPatternCache + 0x07 -> + SemanticPrefixPredicate + <$> getCacheText + <*> getCacheNatural + tag -> + fail ("unknown semantic global key tag " <> show tag) + +putSemanticGlobalBindingCache :: SemanticGlobalBinding -> CachePut +putSemanticGlobalBindingCache (SemanticGlobalBinding key target) = do + putSemanticGlobalKeyCache key + case target of + GlobalReference identity -> do + putCacheTag 0x00 + putObjectIdCache identity + TransparentExpansion identity -> do + putCacheTag 0x01 + putObjectIdCache identity + ContextualTransparentExpansion identity requirements -> do + putCacheTag 0x02 + putObjectIdCache identity + putCanonicalCacheMap + (\(StructSymbol symbol) -> putCacheText symbol) + putObjectIdCache + requirements + +getSemanticGlobalBindingCache :: CacheGet SemanticGlobalBinding +getSemanticGlobalBindingCache = + SemanticGlobalBinding + <$> getSemanticGlobalKeyCache + <*> (getCacheTag >>= \case + 0x00 -> GlobalReference <$> getObjectIdCache + 0x01 -> TransparentExpansion <$> getObjectIdCache + 0x02 -> + ContextualTransparentExpansion + <$> getObjectIdCache + <*> getCanonicalCacheMap + (StructSymbol <$> getCacheText) + getObjectIdCache + tag -> + fail + ("unknown semantic global target tag " + <> show tag)) + +putSemanticStructureDescriptorCache + :: SemanticStructureDescriptor + -> CachePut +putSemanticStructureDescriptorCache + (SemanticStructureDescriptor structurePhrase predicate parents operations) = do + putSemanticStructurePhraseCache structurePhrase + putCacheMaybe putObjectIdCache predicate + putCacheList putSemanticStructurePhraseCache parents + putCacheList putSemanticStructureOperationCache operations + +getSemanticStructureDescriptorCache + :: CacheGet SemanticStructureDescriptor +getSemanticStructureDescriptorCache = do + structurePhrase <- getSemanticStructurePhraseCache + predicate <- getCacheMaybe getObjectIdCache + parents <- getCacheList getSemanticStructurePhraseCache + operations <- getCacheList getSemanticStructureOperationCache + either + (fail . ("invalid semantic structure descriptor: " <>) . show) + pure + (semanticStructureDescriptor structurePhrase predicate parents operations) + +putSemanticStructurePhraseCache + :: SemanticStructurePhrase + -> CachePut +putSemanticStructurePhraseCache + (SemanticStructurePhrase singular plural (Marker marker)) = do + putPatternCache singular + putPatternCache plural + putCacheText marker + +getSemanticStructurePhraseCache + :: CacheGet SemanticStructurePhrase +getSemanticStructurePhraseCache = + SemanticStructurePhrase + <$> getPatternCache + <*> getPatternCache + <*> (Marker <$> getCacheText) + +putSemanticStructureOperationCache + :: SemanticStructureOperation + -> CachePut +putSemanticStructureOperationCache + (SemanticStructureOperation (StructSymbol symbol) object) = do + putCacheText symbol + putObjectIdCache object + +getSemanticStructureOperationCache + :: CacheGet SemanticStructureOperation +getSemanticStructureOperationCache = + SemanticStructureOperation + <$> (StructSymbol <$> getCacheText) + <*> getObjectIdCache + +putDeclarationInterfaceDeltaCache + :: DeclarationInterfaceDelta + -> CachePut +putDeclarationInterfaceDeltaCache + (DeclarationInterfaceDelta + slot facts aliases objects propositions environment) = do + putDeclarationSlotCache slot + putCacheList putSemanticFactOccurrenceCache facts + putCacheList putSemanticAliasCache aliases + putCacheList putObjectIdCache objects + putCacheList putPropositionIdCache propositions + putSemanticEnvironmentDeltaCache environment + +getDeclarationInterfaceDeltaCache + :: CacheGet DeclarationInterfaceDelta +getDeclarationInterfaceDeltaCache = do + slot <- getDeclarationSlotCache + facts <- getCacheList getSemanticFactOccurrenceCache + aliases <- getCacheList getSemanticAliasCache + objects <- getCacheList getObjectIdCache + propositions <- getCacheList getPropositionIdCache + environment <- getSemanticEnvironmentDeltaCache + either + (fail . ("invalid declaration interface delta: " <>) . show) + pure + (declarationInterfaceDelta + slot facts aliases objects propositions environment) + +putSemanticInterfaceCache :: SemanticInterface -> CachePut +putSemanticInterfaceCache + (SemanticInterface owner direct declarations asserted) = do + putModuleNameCache owner + putCacheList putSemanticInterfaceIdCache direct + putCacheList putDeclarationInterfaceDeltaCache declarations + putSemanticInterfaceIdCache asserted + +getSemanticInterfaceCache :: CacheGet SemanticInterface +getSemanticInterfaceCache = do + owner <- getModuleNameCache + direct <- getCacheList getSemanticInterfaceIdCache + declarations <- getCacheList getDeclarationInterfaceDeltaCache + asserted <- getSemanticInterfaceIdCache + either + (fail . ("invalid semantic interface: " <>) . show) + pure + (validateSemanticInterface + owner direct declarations asserted) + +putSemanticInterfaceIdCache :: SemanticInterfaceId -> CachePut +putSemanticInterfaceIdCache (SemanticInterfaceId digest) = + putCacheDigest digest + +getSemanticInterfaceIdCache :: CacheGet SemanticInterfaceId +getSemanticInterfaceIdCache = + SemanticInterfaceId <$> getCacheDigest + +putPrefixContextIdCache :: PrefixContextId -> CachePut +putPrefixContextIdCache (PrefixContextId digest) = + putCacheDigest digest + +getPrefixContextIdCache :: CacheGet PrefixContextId +getPrefixContextIdCache = + PrefixContextId <$> getCacheDigest + +putModuleArtifactKeyCache :: ModuleArtifactKey -> CachePut +putModuleArtifactKeyCache = + putModuleArtifactKeyFields + +getModuleArtifactKeyCache :: CacheGet ModuleArtifactKey +getModuleArtifactKeyCache = do + owner <- getModuleNameCache + parsed <- getParsedModuleIdCache + direct <- getCacheList getSemanticInterfaceIdCache + theory <- getTheoryIdCache + either + (fail . ("invalid module artifact key: " <>) . show) + pure + (moduleArtifactKey owner parsed direct theory) + +putModuleArtifactIdCache :: ModuleArtifactId -> CachePut +putModuleArtifactIdCache (ModuleArtifactId digest) = + putCacheDigest digest + +getModuleArtifactIdCache :: CacheGet ModuleArtifactId +getModuleArtifactIdCache = + ModuleArtifactId <$> getCacheDigest + +putModuleArtifactResultCache + :: ModuleArtifactResult + -> CachePut +putModuleArtifactResultCache + (ModuleArtifactResult identity syntax semantic) = do + putModuleArtifactIdCache identity + putSyntaxInterfaceIdCache syntax + putSemanticInterfaceIdCache semantic + +getModuleArtifactResultCache + :: ModuleArtifactId + -> CacheGet ModuleArtifactResult +getModuleArtifactResultCache expected = do + asserted <- getModuleArtifactIdCache + unless + (asserted == expected) + (fail "module artifact result ID mismatch") + ModuleArtifactResult asserted + <$> getSyntaxInterfaceIdCache + <*> getSemanticInterfaceIdCache + +putProofValidationRecordCache + :: ProofValidationRecord + -> CachePut +putProofValidationRecordCache + (ProofValidationRecord key certificate) = do + putProofValidationKeyCache key + putValidationCertificateCache certificate + +getProofValidationRecordCache + :: CacheGet ProofValidationRecord +getProofValidationRecordCache = + ProofValidationRecord + <$> getProofValidationKeyCache + <*> getValidationCertificateCache + +putDeclarationValidationRecordCache + :: DeclarationValidationRecord + -> CachePut +putDeclarationValidationRecordCache + (DeclarationValidationRecord key certificates) = do + putDeclarationValidationKeyCache key + putCacheList putValidationCertificateCache certificates + +getDeclarationValidationRecordCache + :: CacheGet DeclarationValidationRecord +getDeclarationValidationRecordCache = + DeclarationValidationRecord + <$> getDeclarationValidationKeyCache + <*> getCacheList getValidationCertificateCache + + +putDeclarationSlotCache :: DeclarationSlot -> CachePut +putDeclarationSlotCache (DeclarationSlot owner ordinal) = do + putModuleNameCache owner + putCacheNatural (localDeclarationOrdinalValue ordinal) + +getDeclarationSlotCache :: CacheGet DeclarationSlot +getDeclarationSlotCache = + DeclarationSlot + <$> getModuleNameCache + <*> (localDeclarationOrdinal <$> getCacheNatural) + +putFactSlotCache :: FactSlot -> CachePut +putFactSlotCache (FactSlot owner ordinal) = do + putModuleNameCache owner + putCacheNatural (localFactOrdinalValue ordinal) + +getFactSlotCache :: CacheGet FactSlot +getFactSlotCache = + FactSlot + <$> getModuleNameCache + <*> (localFactOrdinal <$> getCacheNatural) + +putModuleNameCache :: ModuleName -> CachePut +putModuleNameCache owner = do + putMathematicalDigestCache + (sourceNamespaceDigest + (moduleNameNamespace owner)) + putCacheText + (Text.pack + (safeRelativePathFilePath + (moduleNameRelativePath owner))) + +getModuleNameCache :: CacheGet ModuleName +getModuleNameCache = do + namespace <- + sourceNamespaceIdFromDigest + <$> getMathematicalDigestCache + rawPath <- Text.unpack <$> getCacheText + relative <- + either + (fail . ("invalid cache module path: " <>) . show) + pure + (safeRelativePath rawPath) + pure (moduleNameFromParts namespace relative) + +putSemanticAliasCache :: SemanticAlias -> CachePut +putSemanticAliasCache (SemanticAlias name target) = do + putSemanticNameCache name + putSemanticFactOccurrenceFingerprintCache target + +getSemanticAliasCache :: CacheGet SemanticAlias +getSemanticAliasCache = + SemanticAlias + <$> getSemanticNameCache + <*> getSemanticFactOccurrenceFingerprintCache + +putSemanticNameCache :: SemanticName -> CachePut +putSemanticNameCache (SemanticName name) = + putCacheText name + +getSemanticNameCache :: CacheGet SemanticName +getSemanticNameCache = + SemanticName <$> getCacheText + +putEligibility :: FactSearchEligibility -> CachePut +putEligibility = \case + SearchEligible -> putCacheTag 0x00 + SearchIneligible -> putCacheTag 0x01 + +getEligibility :: CacheGet FactSearchEligibility +getEligibility = + getCacheTag >>= \case + 0x00 -> pure SearchEligible + 0x01 -> pure SearchIneligible + tag -> + fail ("unknown fact-search eligibility tag " <> show tag) + +putModuleArtifactKeyFields :: ModuleArtifactKey -> CachePut +putModuleArtifactKeyFields + (ModuleArtifactKey owner parsed direct theory) = do + putModuleNameCache owner + putParsedModuleIdCache parsed + putCacheList putSemanticInterfaceIdCache direct + putTheoryIdCache theory + +putProofValidationKeyCache :: ProofValidationKey -> CachePut +putProofValidationKeyCache (ProofValidationKey digest) = + putCacheDigest digest + +getProofValidationKeyCache :: CacheGet ProofValidationKey +getProofValidationKeyCache = + ProofValidationKey <$> getCacheDigest + +putDeclarationValidationKeyCache + :: DeclarationValidationKey + -> CachePut +putDeclarationValidationKeyCache + (DeclarationValidationKey digest) = + putCacheDigest digest + +getDeclarationValidationKeyCache + :: CacheGet DeclarationValidationKey +getDeclarationValidationKeyCache = + DeclarationValidationKey <$> getCacheDigest + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _ [] = + Nothing + go seen (value : rest) + | value `Set.member` seen = + Just value + | otherwise = + go (Set.insert value seen) rest + +rejectDuplicate + :: Ord value + => (value -> error) + -> [value] + -> Either error () +rejectDuplicate makeError values = + maybe + (Right ()) + (Left . makeError) + (firstDuplicate values) + +strictlyIncreasing :: Ord value => [value] -> Bool +strictlyIncreasing values = + and + (zipWith (<) values (drop 1 values)) diff --git a/source/Felix/Checking/SetConstruction.hs b/source/Felix/Checking/SetConstruction.hs new file mode 100644 index 0000000..a5e1d80 --- /dev/null +++ b/source/Felix/Checking/SetConstruction.hs @@ -0,0 +1,1191 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked source semantics for named separation and functional replacement. +-- +-- A value of 'NamedSetConstruction' is the sole transient owner of the +-- source decomposition. Its smart constructors validate the complete +-- telescope and derive one canonical term. Local views, transparent content, +-- direct extensional facts, and cache-scoped descriptors all consume that +-- same checked value. +module Felix.Checking.SetConstruction + ( NamedSetConstruction + , checkedSeparationConstruction + , checkedFunctionalReplacementConstruction + , namedSetConstructionTerm + , namedSetConstructionLocalViews + , namedSetConstructionClosedBody + , SetConstructionFoundation + , setConstructionFoundation + , checkedFoundationSetConstruction + , NamedSetConstructionFact + , namedSetConstructionFactProposition + , namedSetConstructionFactDescriptor + , namedSetConstructionObjectFact + , CheckedRelationalSetConstruction + , checkedRelationalReplacementConstruction + , relationalSetConstructionTerm + , relationalSetConstructionFunctionality + , relationalSetConstructionClosedFunctionality + , relationalSetConstructionLocalViews + , relationalSetConstructionClosedBody + , RelationalSetConstructionFact + , relationalSetConstructionFactProposition + , relationalSetConstructionFactDescriptor + , relationalSetConstructionObjectFact + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Cache.Codec + ( CacheDigest + , encodeCache + , hashCacheFields + , putCanonicalTermCache + , putCoreTypeCache + ) + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The exact fixed rows used by the narrow derived extensionality schema. +-- Proof-local construction obtains these rows through the confined foundation +-- lookup; declaration authorization obtains them from 'CheckedFoundation'. +data SetConstructionFoundation = SetConstructionFoundation + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + +setConstructionFoundation + :: FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> SetConstructionFoundation +setConstructionFoundation = + SetConstructionFoundation + +checkedFoundationSetConstruction + :: CheckedFoundation + -> SetConstructionFoundation +checkedFoundationSetConstruction foundation = + SetConstructionFoundation + (foundationAxiomFrozen foundation FamilyUnionCharacteristic) + (foundationAxiomFrozen foundation SeparationCharacteristic) + (foundationAxiomFrozen foundation ReplacementCharacteristic) + (foundationAxiomFrozen foundation SetChooseWitness) + +data NamedSetConstruction global = NamedSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(NamedSetConstructionShape global) + !(BuiltSetConstruction global) + deriving stock (Eq) + +data NamedSetConstructionShape global + = SeparationShape + !(CanonicalTerm global) + !(CanonicalTerm global) + | FunctionalReplacementShape + !(NonEmpty (CanonicalTerm global)) + !(CanonicalTerm global) + !(Maybe (CanonicalTerm global)) + deriving stock (Eq) + +-- | The one canonical build result retained by the checked construction. +-- Characteristic applications describe the exact primitive rows used by the +-- derived theorem schema; the flattened body is the deterministic composition +-- of those rows for the source telescope. +data BuiltSetConstruction global = BuiltSetConstruction + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +data CheckedCharacteristicApplication global = + CheckedCharacteristicApplication + !CoreIntrinsicTag + ![CoreType] + !(CanonicalTerm global) + !(NonEmpty (CoreType, CanonicalTerm global)) + !(CanonicalTerm global) + deriving stock (Eq) + +-- | One checked relational replacement. Unlike the unconditional named +-- constructions above, its flattened membership theorem is available only +-- after the separately checked functionality proposition has authority. +-- This value owns the source telescope, the one canonical choice/replacement +-- term, and the exact primitive characteristic applications used by that +-- narrow derived schema. +data CheckedRelationalSetConstruction global = + CheckedRelationalSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +-- | Validate one source relational replacement. The relation is checked in +-- the nearest-first context @[range, domain] <> outer@, matching the source +-- binder order @y x A P@ without retaining source syntax. +checkedRelationalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (CheckedRelationalSetConstruction global) +checkedRelationalReplacementConstruction globalType domain relation = do + guard (scopedCoreType domain == TySet) + guard (scopedCoreType relation == TyProp) + let context = scopedCoreContext domain + guard (scopedCoreContext relation == TySet : TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm domain, scopedCoreTerm relation] + let domainTerm = scopedCoreTerm domain + relationTerm = scopedCoreTerm relation + domainPredicate = CLam TySet (logicalExists relationTerm) + restrictedDomain = applyIntrinsic2 Sep domainTerm domainPredicate + choiceFunction = + CLam TySet + (applyIntrinsic SetChoose (CLam TySet relationTerm)) + replacement = applyIntrinsic2 Repl restrictedDomain choiceFunction + functionality = relationalFunctionality domainTerm relationTerm + membership = relationalMembership domainTerm relationTerm + applications = + [ characteristicApplication + Sep context restrictedDomain + [ (TySet, domainTerm) + , (TyArrow TySet TyProp, domainPredicate) + ] + , characteristicApplication + Repl context replacement + [ (TySet, restrictedDomain) + , (TyArrow TySet TySet, choiceFunction) + ] + ] + construction = + CheckedRelationalSetConstruction + context globals domainTerm relationTerm replacement + functionality membership applications + _ <- checkedRelationalDerived construction context TySet replacement + _ <- checkedRelationalDerived construction context TyProp functionality + _ <- checkedRelationalDerived + construction (TySet : context) TyProp membership + pure construction + +-- | Check one source separation. The callback supplies the exact visible +-- type of every global used by its already checked components. +checkedSeparationConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (NamedSetConstruction global) +checkedSeparationConstruction globalType bound predicate = do + guard (scopedCoreType bound == TySet) + guard (scopedCoreType predicate == TyProp) + let context = scopedCoreContext bound + guard (scopedCoreContext predicate == TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm bound, scopedCoreTerm predicate] + finishConstruction + context + globals + (SeparationShape + (scopedCoreTerm bound) + (scopedCoreTerm predicate)) + +-- | Check source-ordered functional replacement once. Domain @i@ is checked +-- beneath exactly the preceding @i - 1@ source binders; the value and optional +-- condition are checked beneath the complete telescope. +checkedFunctionalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) + -> Maybe (NamedSetConstruction global) +checkedFunctionalReplacementConstruction globalType domains value condition = do + let domainList = NonEmpty.toList domains + firstDomain = NonEmpty.head domains + guard (scopedCoreType firstDomain == TySet) + let context = scopedCoreContext firstDomain + expectedDomainContexts = + [ replicate index TySet <> context + | index <- [0 .. length domainList - 1] + ] + valueContext = replicate (length domainList) TySet <> context + guard + (and + (zipWith + (\domain expected -> + scopedCoreType domain == TySet + && scopedCoreContext domain == expected) + domainList + expectedDomainContexts)) + guard + (scopedCoreType value == TySet + && scopedCoreContext value == valueContext) + traverse_ + (\predicate -> + guard + (scopedCoreType predicate == TyProp + && scopedCoreContext predicate == valueContext)) + condition + globals <- + captureGlobalTypes globalType + ( (scopedCoreTerm <$> domainList) + <> [scopedCoreTerm value] + <> maybeToList (scopedCoreTerm <$> condition) + ) + finishConstruction + context + globals + (FunctionalReplacementShape + (scopedCoreTerm <$> domains) + (scopedCoreTerm value) + (scopedCoreTerm <$> condition)) + +namedSetConstructionTerm + :: Ord global + => NamedSetConstruction global + -> ScopedCheckedCore global +namedSetConstructionTerm construction = + fromMaybe + (impossible "a checked construction lost its canonical term") + (checkedDerived + construction + (constructionContext construction) + TySet + (constructionCanonicalTerm construction)) + +-- | Introduce a fresh named set and return adjacent FOF extensional and exact +-- equation locals. Weakening is internal so construction-local binders and +-- source-domain order cannot drift at a caller. +namedSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +namedSetConstructionLocalViews foundation construction = do + weakened <- weakenConstruction TySet construction + let context = TySet : constructionContext construction + target = CBound 0 + extensional <- extensionalView foundation target weakened + equation <- checkedDerived weakened context TyProp + (CEq TySet target (constructionCanonicalTerm weakened)) + pure (extensional, equation) + +-- | Closed transparent content derived from the sole canonical construction +-- term. This retains the pre-existing object-content identity exactly. +namedSetConstructionClosedBody + :: Ord global + => NamedSetConstruction global + -> FrozenCheckedCore global +namedSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked construction did not close") + (freezeDerived construction closedType closedTerm) + where + context = constructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl (flip CLam) (constructionCanonicalTerm construction) context + +data NamedSetConstructionFact = NamedSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +namedSetConstructionFactProposition + :: NamedSetConstructionFact + -> FrozenCheckedCore ObjectId +namedSetConstructionFactProposition + (NamedSetConstructionFact proposition _descriptor) = + proposition + +namedSetConstructionFactDescriptor + :: NamedSetConstructionFact + -> CacheDigest +namedSetConstructionFactDescriptor + (NamedSetConstructionFact _proposition descriptor) = + descriptor + +-- | Derive the only proposition authorized by +-- @CheckedSetConstructionExtensionality@. This is a deliberately small +-- trusted theorem schema over the fixed foundation: every primitive +-- characteristic specialization is checked against its exact membership +-- formula before the source telescope is composed. The caller cannot supply +-- either the resulting proposition or its cache descriptor. +namedSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> NamedSetConstruction ObjectId + -> Maybe NamedSetConstructionFact +namedSetConstructionObjectFact foundation object construction = do + let context = constructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType object objectType (constructionGlobals construction) + let withObject = replaceConstructionGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + view <- extensionalView foundation target withObject + proposition <- freezeDerived withObject TyProp + (foldl + (flip CForall) + (scopedCoreTerm view) + context) + selfView <- extensionalView + foundation + (constructionCanonicalTerm construction) + construction + closedSelf <- freezeDerived construction TyProp + (foldl + (flip CForall) + (scopedCoreTerm selfView) + context) + let closedBody = namedSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (NamedSetConstructionFact proposition descriptor) + +relationalSetConstructionTerm + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionTerm construction = + fromMaybe + (impossible "a checked relational construction lost its canonical term") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TySet + (relationalConstructionCanonicalTerm construction)) + +-- | The exact source functionality obligation, still scoped by the outer +-- definition parameters. It is discharged independently before the derived +-- extensional theorem can be authorized. +relationalSetConstructionFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionFunctionality construction = + fromMaybe + (impossible "a checked relational construction lost functionality") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TyProp + (relationalConstructionFunctionalityTerm construction)) + +relationalSetConstructionClosedFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedFunctionality = + closeRelationalFunctionality + +-- | Introduce a fresh named set. Assuming the exact checked functionality +-- proposition, derive its two local views; no arbitrary proposition can +-- unlock the extensional view. The enclosing proof transaction owns the +-- corresponding authority. +relationalSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +relationalSetConstructionLocalViews foundation construction functionality = do + guard + (functionality + == relationalSetConstructionFunctionality construction) + validateRelationalSchema foundation construction + let context = TySet : relationalConstructionContext construction + target = CBound 0 + extensional <- checkedRelationalDerived construction context TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (CBound 1)) + (shiftCanonical 1 1 + (relationalConstructionMembershipTerm construction)))) + equation <- checkedRelationalDerived construction context TyProp + (CEq TySet + target + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + pure (extensional, equation) + +relationalSetConstructionClosedBody + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked relational construction did not close") + (freezeRelationalDerived construction closedType closedTerm) + where + context = relationalConstructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl + (flip CLam) + (relationalConstructionCanonicalTerm construction) + context + +data RelationalSetConstructionFact = RelationalSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +relationalSetConstructionFactProposition + :: RelationalSetConstructionFact + -> FrozenCheckedCore ObjectId +relationalSetConstructionFactProposition + (RelationalSetConstructionFact proposition _descriptor) = + proposition + +relationalSetConstructionFactDescriptor + :: RelationalSetConstructionFact + -> CacheDigest +relationalSetConstructionFactDescriptor + (RelationalSetConstructionFact _proposition descriptor) = + descriptor + +-- | The direct relational schema is a deterministic theorem over the fixed +-- separation, choice-witness, and replacement rows. The functionality fact +-- is a real strictly-earlier candidate: its exact proposition is checked here +-- and its authority safety is consumed separately by declaration admission. +relationalSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Maybe RelationalSetConstructionFact +relationalSetConstructionObjectFact + foundation object construction functionality = do + let expectedFunctionality = + closeRelationalFunctionality construction + guard (functionality == expectedFunctionality) + validateRelationalSchema foundation construction + let context = relationalConstructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType + object objectType (relationalConstructionGlobals construction) + let withObject = replaceRelationalGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + membership = relationalConstructionMembershipTerm withObject + proposition <- freezeRelationalDerived withObject TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + membership)) + context) + closedSelf <- freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member + (CBound 0) + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + (relationalConstructionMembershipTerm construction))) + context) + let closedBody = relationalSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-relational-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm expectedFunctionality) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (RelationalSetConstructionFact proposition descriptor) + +finishConstruction + :: Ord global + => [CoreType] + -> Map.Map global CoreType + -> NamedSetConstructionShape global + -> Maybe (NamedSetConstruction global) +finishConstruction context globals shape = do + let built = buildConstruction context shape + construction = NamedSetConstruction context globals shape built + _ <- checkedDerived construction context TySet + (builtConstructionTerm built) + _ <- checkedDerived construction (TySet : context) TyProp + (builtConstructionMembership built) + pure construction + +buildConstruction + :: Eq global + => [CoreType] + -> NamedSetConstructionShape global + -> BuiltSetConstruction global +buildConstruction context = \case + SeparationShape bound predicate -> + let function = CLam TySet predicate + term = applyIntrinsic2 Sep bound function + membership = + logicalAnd + (member (CBound 0) (shiftCanonical 1 0 bound)) + predicate + application = + characteristicApplication + Sep context term + [ (TySet, bound) + , (TyArrow TySet TyProp, function) + ] + in BuiltSetConstruction term membership [application] + FunctionalReplacementShape domains value condition -> + let (term, applications) = + buildFunctionalReplacement + context + domains + value + condition + domainList = NonEmpty.toList domains + binderCount = length domainList + terminal = + logicalConjunction + ( maybeToList + (shiftCanonical 1 (fromIntegral binderCount) + <$> condition) + <> [ CEq TySet + (CBound (fromIntegral binderCount)) + (shiftCanonical 1 + (fromIntegral binderCount) + value) + ] + ) + membership = + foldr + (\(depth, domain) rest -> + logicalExists + (logicalAnd + (member + (CBound 0) + (shiftCanonical 1 0 + (shiftCanonical 1 depth domain))) + rest)) + terminal + (zip [0 :: Natural ..] domainList) + in BuiltSetConstruction term membership applications + +-- The only functional-replacement term builder. Its result is reused by the +-- transparent body, exact-content matching, characteristic validation, local +-- views, and descriptor derivation. +buildFunctionalReplacement + :: [CoreType] + -> NonEmpty (CanonicalTerm global) + -> CanonicalTerm global + -> Maybe (CanonicalTerm global) + -> (CanonicalTerm global, [CheckedCharacteristicApplication global]) +buildFunctionalReplacement context (domain :| remaining) value condition = + case remaining of + [] -> + let predicate = CLam TySet <$> condition + filtered = maybe domain + (applyIntrinsic2 Sep domain) + predicate + function = CLam TySet value + replacement = applyIntrinsic2 Repl filtered function + separationApplications = case predicate of + Nothing -> [] + Just checkedPredicate -> + [ characteristicApplication + Sep context filtered + [ (TySet, domain) + , (TyArrow TySet TyProp, checkedPredicate) + ] + ] + replacementApplication = + characteristicApplication + Repl context replacement + [ (TySet, filtered) + , (TyArrow TySet TySet, function) + ] + in + ( replacement + , separationApplications <> [replacementApplication] + ) + next : rest -> + let (nested, nestedApplications) = + buildFunctionalReplacement + (TySet : context) + (next :| rest) + value + condition + function = CLam TySet nested + replacement = applyIntrinsic2 Repl domain function + union = applyIntrinsic FamilyUnion replacement + in + ( union + , characteristicApplication + Repl context replacement + [ (TySet, domain) + , (TyArrow TySet TySet, function) + ] + : characteristicApplication + FamilyUnion context union + [(TySet, replacement)] + : nestedApplications + ) + +characteristicApplication + :: CoreIntrinsicTag + -> [CoreType] + -> CanonicalTerm global + -> [(CoreType, CanonicalTerm global)] + -> CheckedCharacteristicApplication global +characteristicApplication intrinsic context target arguments = + CheckedCharacteristicApplication + intrinsic + context + target + (NonEmpty.fromList arguments) + (expectedCharacteristicBody intrinsic arguments) + +expectedCharacteristicBody + :: CoreIntrinsicTag + -> [(CoreType, CanonicalTerm global)] + -> CanonicalTerm global +expectedCharacteristicBody intrinsic arguments = + case (intrinsic, arguments) of + (Sep, [(_boundType, bound), (_predicateType, CLam TySet predicate)]) -> + logicalAnd + (member (CBound 0) (shiftCanonical 2 0 bound)) + (shiftCanonical 1 1 predicate) + (Repl, [(_domainType, domain), (_functionType, CLam TySet value)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 domain)) + (CEq TySet + (CBound 1) + (shiftCanonical 2 1 value))) + (FamilyUnion, [(_familyType, family)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 family)) + (member (CBound 1) (CBound 0))) + _ -> + impossible "invalid checked set-construction characteristic" + +extensionalView + :: Ord global + => SetConstructionFoundation + -> CanonicalTerm global + -> NamedSetConstruction global + -> Maybe (ScopedCheckedCore global) +extensionalView foundation target construction = do + traverse_ + (validateCharacteristic foundation construction) + (constructionApplications construction) + checkedDerived construction (constructionContext construction) TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + (constructionMembership construction))) + +-- Each primitive step is specialized from the actual fixed row, and the +-- complete normalized membership body is checked. The final flattened view +-- is then the deterministic composition of these exact primitive schemas. +validateCharacteristic + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet + (CEq TyProp actualMembership actualBody) + | actualMembership + == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +characteristicRow + :: SetConstructionFoundation + -> CoreIntrinsicTag + -> Maybe (FrozenCheckedCore Void) +characteristicRow + (SetConstructionFoundation + familyUnion separation replacement _setChoose) = + \case + FamilyUnion -> Just familyUnion + Sep -> Just separation + Repl -> Just replacement + _ -> Nothing + +validateRelationalSchema + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateRelationalSchema foundation construction = do + traverse_ + (validateRelationalCharacteristic foundation construction) + (relationalConstructionApplications construction) + validateChoiceWitness foundation construction + +validateRelationalCharacteristic + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateRelationalCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedRelationalDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedRelationalDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet (CEq TyProp actualMembership actualBody) + | actualMembership == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +validateChoiceWitness + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateChoiceWitness + (SetConstructionFoundation + _familyUnion _separation _replacement setChoose) + construction = do + let context = relationalConstructionContext construction + relation = relationalConstructionRelation construction + predicate = CLam TySet relation + choice = applyIntrinsic SetChoose predicate + witnessContext = TySet : TySet : context + target <- checkedRelationalDerived construction witnessContext TySet + (shiftCanonical 1 0 choice) + checkedPredicate <- + checkedRelationalDerived construction witnessContext + (TyArrow TySet TyProp) + (shiftCanonical 1 0 predicate) + witness <- checkedRelationalDerived construction witnessContext TySet + (CBound 0) + specialized <- + scopedCharacteristicDefinition + setChoose target (checkedPredicate :| [witness]) + guard + (scopedCoreContext specialized + == TySet : TySet : TySet : context) + guard + (scopedCoreTerm specialized + == CImp + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + +relationalFunctionality + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalFunctionality domain relation = + CForall TySet + (CImp + (member (CBound 0) (shiftCanonical 1 0 domain)) + (CForall TySet + (CForall TySet + (CImp + (logicalAnd + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + (CEq TySet (CBound 1) (CBound 0)))))) + +relationalMembership + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalMembership domain relation = + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 2 0 domain)) + (applyRelation + (shiftCanonical 2 0 + (CLam TySet (CLam TySet relation))) + (CBound 0) + (CBound 1))) + where + applyRelation function domainValue rangeValue = + case function of + CLam TySet domainBody -> + case instantiateCanonical domainValue domainBody of + CLam TySet rangeBody -> + instantiateCanonical rangeValue rangeBody + _ -> impossible "a checked relation lost its range binder" + _ -> impossible "a checked relation lost its domain binder" + +weakenConstruction + :: Ord global + => CoreType + -> NamedSetConstruction global + -> Maybe (NamedSetConstruction global) +weakenConstruction binderType construction = + finishConstruction + (binderType : constructionContext construction) + (constructionGlobals construction) + (case constructionShape construction of + SeparationShape bound predicate -> + SeparationShape + (shiftCanonical 1 0 bound) + (shiftCanonical 1 1 predicate) + FunctionalReplacementShape domains value condition -> + let domainList = NonEmpty.toList domains + weakenedDomains = + zipWith + (\depth domain -> shiftCanonical 1 depth domain) + [0..] + domainList + binderDepth = fromIntegral (length domainList) + in FunctionalReplacementShape + (NonEmpty.fromList weakenedDomains) + (shiftCanonical 1 binderDepth value) + (shiftCanonical 1 binderDepth <$> condition)) + +captureGlobalTypes + :: Ord global + => (global -> Maybe CoreType) + -> [CanonicalTerm global] + -> Maybe (Map.Map global CoreType) +captureGlobalTypes globalType terms = + Map.fromList <$> traverse capture + (Set.toAscList (foldMap canonicalTermGlobals terms)) + where + capture global = do + coreType <- globalType global + pure (global, coreType) + +insertGlobalType + :: Ord global + => global + -> CoreType + -> Map.Map global CoreType + -> Maybe (Map.Map global CoreType) +insertGlobalType global coreType globals = + case Map.lookup global globals of + Nothing -> Just (Map.insert global coreType globals) + Just existing + | existing == coreType -> Just globals + | otherwise -> Nothing + +checkedDerived + :: Ord global + => NamedSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` constructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeDerived + :: Ord global + => NamedSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeDerived construction expected term = do + checked <- checkedDerived construction [] expected term + closeScopedCore checked + +checkedRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedRelationalDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` relationalConstructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeRelationalDerived construction expected term = do + checked <- checkedRelationalDerived construction [] expected term + closeScopedCore checked + +closeRelationalFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +closeRelationalFunctionality construction = + fromMaybe + (impossible "a relational functionality proposition did not close") + (freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (relationalConstructionFunctionalityTerm construction) + (relationalConstructionContext construction))) + +replaceRelationalGlobals + :: Map.Map global CoreType + -> CheckedRelationalSetConstruction global + -> CheckedRelationalSetConstruction global +replaceRelationalGlobals globals + (CheckedRelationalSetConstruction + context _oldGlobals domain relation term functionality + membership applications) = + CheckedRelationalSetConstruction + context globals domain relation term functionality membership applications + +relationalConstructionContext + :: CheckedRelationalSetConstruction global + -> [CoreType] +relationalConstructionContext + (CheckedRelationalSetConstruction + context _globals _domain _relation _term _functionality + _membership _applications) = + context + +relationalConstructionGlobals + :: CheckedRelationalSetConstruction global + -> Map.Map global CoreType +relationalConstructionGlobals + (CheckedRelationalSetConstruction + _context globals _domain _relation _term _functionality + _membership _applications) = + globals + +relationalConstructionRelation + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionRelation + (CheckedRelationalSetConstruction + _context _globals _domain relation _term _functionality + _membership _applications) = + relation + +relationalConstructionCanonicalTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionCanonicalTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation term _functionality + _membership _applications) = + term + +relationalConstructionFunctionalityTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionFunctionalityTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term functionality + _membership _applications) = + functionality + +relationalConstructionMembershipTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionMembershipTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + membership _applications) = + membership + +relationalConstructionApplications + :: CheckedRelationalSetConstruction global + -> [CheckedCharacteristicApplication global] +relationalConstructionApplications + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + _membership applications) = + applications + +replaceConstructionGlobals + :: Map.Map global CoreType + -> NamedSetConstruction global + -> NamedSetConstruction global +replaceConstructionGlobals globals + (NamedSetConstruction context _oldGlobals shape built) = + NamedSetConstruction context globals shape built + +constructionContext :: NamedSetConstruction global -> [CoreType] +constructionContext (NamedSetConstruction context _globals _shape _built) = + context + +constructionGlobals + :: NamedSetConstruction global + -> Map.Map global CoreType +constructionGlobals (NamedSetConstruction _context globals _shape _built) = + globals + +constructionShape + :: NamedSetConstruction global + -> NamedSetConstructionShape global +constructionShape (NamedSetConstruction _context _globals shape _built) = + shape + +constructionCanonicalTerm + :: NamedSetConstruction global + -> CanonicalTerm global +constructionCanonicalTerm + (NamedSetConstruction _context _globals _shape built) = + builtConstructionTerm built + +constructionMembership + :: NamedSetConstruction global + -> CanonicalTerm global +constructionMembership + (NamedSetConstruction _context _globals _shape built) = + builtConstructionMembership built + +constructionApplications + :: NamedSetConstruction global + -> [CheckedCharacteristicApplication global] +constructionApplications + (NamedSetConstruction _context _globals _shape built) = + builtConstructionApplications built + +builtConstructionTerm + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionTerm (BuiltSetConstruction term _membership _applications) = + term + +builtConstructionMembership + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionMembership + (BuiltSetConstruction _term membership _applications) = + membership + +builtConstructionApplications + :: BuiltSetConstruction global + -> [CheckedCharacteristicApplication global] +builtConstructionApplications + (BuiltSetConstruction _term _membership applications) = + applications + +applyIntrinsic + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic intrinsic argument = + CApp (CIntrinsic intrinsic) argument + +applyIntrinsic2 + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic2 intrinsic first second = + CApp (CApp (CIntrinsic intrinsic) first) second + +member + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +member = applyIntrinsic2 Member + +logicalNot :: CanonicalTerm global -> CanonicalTerm global +logicalNot proposition = CImp proposition CFalsum + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + logicalNot (CImp left (logicalNot right)) + +logicalTruth :: CanonicalTerm global +logicalTruth = CImp CFalsum CFalsum + +logicalConjunction + :: Eq global + => [CanonicalTerm global] + -> CanonicalTerm global +logicalConjunction = + foldr combine logicalTruth + where + combine proposition remaining + | proposition == logicalTruth = remaining + | remaining == logicalTruth = proposition + | otherwise = logicalAnd proposition remaining + +logicalExists :: CanonicalTerm global -> CanonicalTerm global +logicalExists body = + logicalNot (CForall TySet (logicalNot body)) diff --git a/source/Felix/Checking/Typed/Inductive.hs b/source/Felix/Checking/Typed/Inductive.hs new file mode 100644 index 0000000..4094083 --- /dev/null +++ b/source/Felix/Checking/Typed/Inductive.hs @@ -0,0 +1,4732 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Direct checked lowering of the current one-carrier set-valued inductive +-- declaration. +module Felix.Checking.Typed.Inductive + ( DirectInductive(..) + , DirectInductiveClause(..) + , DirectInductiveCondition(..) + , RecursiveCarrierContext + , RecursiveCarrierContextError(..) + , prepareRecursiveCarrierContext + , directRecursiveCarrierContext + , recursiveCarrierContextSymbols + , SourceGlobal(..) + , PreparedTypedInductive + , typedInductiveCarrierType + , typedInductiveCarrierBody + , typedInductiveGuardTargets + , PreparedTypedInductiveMonotonicity + , typedInductiveMonotonicities + , typedInductiveMonotonicityLocation + , typedInductiveMonotonicityTarget + , typedInductiveContextInventory + , PreparedTypedInductiveFact + , typedInductiveFacts + , typedInductiveFactMarker + , typedInductiveFactTarget + , typedInductiveFactRules + , typedInductiveFactRequiresMonotonicities + , typedInductiveFactDerivation + , prepareTypedClosedTerm + , prepareTypedClosedFormula + , prepareTypedInductive + , TypedInductiveError(..) + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Proof +import Felix.Report.Location (Location) +import Felix.Syntax.Internal + +import Control.Monad ((<=<), foldM) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Bound.Scope (fromScope, instantiate) +import Bound.Var (Var(..)) + + +data DirectInductive = DirectInductive + { directInductiveParams :: ![VarSymbol] + , directInductiveDomain :: !Term + , directInductiveClauses + :: !(NonEmpty DirectInductiveClause) + } + +data DirectInductiveClause = DirectInductiveClause + { directClauseVariables :: ![VarSymbol] + , directClauseConditions + :: ![DirectInductiveCondition] + , directClauseResult :: !Term + } + +data DirectInductiveCondition + = DirectSideCondition !Formula + | DirectRecursiveCondition !Term !RecursiveCarrierContext + +data RecursiveCarrierVariable + = RecursiveCarrierHole + | RecursiveCarrierSourceVariable !VarSymbol + deriving stock (Show, Eq, Ord) + +-- | A validated, capture-free one-hole carrier context in the same +-- first-order set-term fragment lowered by this module. The source carrier +-- application itself has been replaced, so the inductive symbol cannot +-- survive inside this value. +data RecursiveCarrierContext = RecursiveCarrierContext + !Location + !(ExprOf RecursiveCarrierVariable) + deriving stock (Show, Eq, Ord) + +data RecursiveCarrierContextError + = RecursiveCarrierWrongArguments !Location + | RecursiveCarrierUnsupportedContext !Location + deriving stock (Show, Eq) + +prepareRecursiveCarrierContext + :: FunctionSymbol + -> [VarSymbol] + -> Term + -> Either RecursiveCarrierContextError RecursiveCarrierContext +prepareRecursiveCarrierContext carrier parameters source = + RecursiveCarrierContext (exprLocation source) <$> go source + where + carrierSymbol = SymbolMixfix carrier + + go = \case + TermVar variable -> + pure + (TermVar + (RecursiveCarrierSourceVariable variable)) + TermSymbol location symbol arguments + | symbol == carrierSymbol -> + if sameCarrierArguments arguments parameters + then pure (TermVar RecursiveCarrierHole) + else Left (RecursiveCarrierWrongArguments location) + | otherwise -> + TermSymbol location symbol <$> traverse go arguments + unsupported -> + Left + (RecursiveCarrierUnsupportedContext + (exprLocation unsupported)) + + sameCarrierArguments arguments variables = + length arguments == length variables + && and + (zipWith + (\argument variable -> + argument == TermVar variable) + arguments + variables) + +recursiveCarrierContextSymbols + :: RecursiveCarrierContext + -> Set Symbol +recursiveCarrierContextSymbols + (RecursiveCarrierContext _location source) = + mentionedSymbols source + +directRecursiveCarrierContext :: Location -> RecursiveCarrierContext +directRecursiveCarrierContext location = + RecursiveCarrierContext location (TermVar RecursiveCarrierHole) + +data SourceGlobal global = SourceGlobal + !global + !(Maybe (FrozenCheckedCore global)) + +data InductiveGlobal global where + InductiveGlobal + :: Eq global + => !global + -> !CoreType + -> InductiveGlobal global + +instance Eq (InductiveGlobal global) where + InductiveGlobal left _leftType + == InductiveGlobal right _rightType = + left == right + +inductiveGlobalIdentity :: InductiveGlobal global -> global +inductiveGlobalIdentity (InductiveGlobal identity _coreType) = + identity + +inductiveGlobalType :: InductiveGlobal global -> CoreType +inductiveGlobalType (InductiveGlobal _identity coreType) = + coreType + +data PreparedTypedInductive global = PreparedTypedInductive + !CoreType + !(FrozenCheckedCore global) + !(Vector (FrozenCheckedCore global)) + !(Vector (PreparedTypedInductiveMonotonicity global)) + !(Vector (FrozenCheckedCore global)) + !(NonEmpty (PreparedTypedInductiveFact global)) + +data PreparedTypedInductiveMonotonicity global = + PreparedTypedInductiveMonotonicity + !Location + !(FrozenCheckedCore global) + +typedInductiveMonotonicities + :: PreparedTypedInductive global + -> Vector (PreparedTypedInductiveMonotonicity global) +typedInductiveMonotonicities + (PreparedTypedInductive + _carrierType + _body + _guards + monotonicities + _contexts + _facts) = + monotonicities + +typedInductiveMonotonicityLocation + :: PreparedTypedInductiveMonotonicity global + -> Location +typedInductiveMonotonicityLocation + (PreparedTypedInductiveMonotonicity location _target) = + location + +typedInductiveMonotonicityTarget + :: PreparedTypedInductiveMonotonicity global + -> FrozenCheckedCore global +typedInductiveMonotonicityTarget + (PreparedTypedInductiveMonotonicity _location target) = + target + +typedInductiveContextInventory + :: PreparedTypedInductive global + -> Vector (FrozenCheckedCore global) +typedInductiveContextInventory + (PreparedTypedInductive + _carrierType _body _guards _monotonicities contexts _facts) = + contexts + +data CheckedRecursiveCarrierContext global = + CheckedRecursiveCarrierContext + ![VarSymbol] + !(FrozenCheckedCore global) + +data PreparedInductiveSource global = PreparedInductiveSource + { preparedInductiveParams :: ![VarSymbol] + , preparedInductiveDomain :: !Term + , preparedInductiveClauses + :: !(NonEmpty (PreparedInductiveClause global)) + } + +data PreparedInductiveClause global = PreparedInductiveClause + { preparedClauseVariables :: ![VarSymbol] + , preparedClauseConditions + :: ![PreparedInductiveCondition global] + , preparedClauseResult :: !Term + } + +data PreparedInductiveCondition global + = PreparedSideCondition !Formula + | PreparedDirectRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + | PreparedNestedRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + !ImportIx + !(FrozenCheckedCore global) + +data PreparedInductiveGuard global + = PreparedFoundationGuard !FoundationAxiomTag + | PreparedImportedGuard + !ImportIx + !(FrozenCheckedCore global) + +typedInductiveCarrierType + :: PreparedTypedInductive global + -> CoreType +typedInductiveCarrierType + (PreparedTypedInductive + carrierType + _body + _guards + _monotonicities + _contexts + _facts) = + carrierType + +typedInductiveCarrierBody + :: PreparedTypedInductive global + -> FrozenCheckedCore global +typedInductiveCarrierBody + (PreparedTypedInductive + _carrierType + body + _guards + _monotonicities + _contexts + _facts) = + body + +typedInductiveGuardTargets + :: PreparedTypedInductive global + -> Vector (FrozenCheckedCore global) +typedInductiveGuardTargets + (PreparedTypedInductive + _carrierType + _body + guards + _monotonicities + _contexts + _facts) = + guards + +newtype PreparedTypedInductiveFact global = + PreparedTypedInductiveFact + ( Marker + , FrozenCheckedCore global + , NonEmpty KernelRuleTag + , Bool + , KernelDerivation global + ) + +typedInductiveFacts + :: PreparedTypedInductive global + -> NonEmpty (PreparedTypedInductiveFact global) +typedInductiveFacts + (PreparedTypedInductive + _carrierType + _body + _guards + _monotonicities + _contexts + facts) = + facts + +typedInductiveFactMarker + :: PreparedTypedInductiveFact global + -> Marker +typedInductiveFactMarker + (PreparedTypedInductiveFact + (marker, _target, _rule, _monotonicities, _derivation)) = + marker + +typedInductiveFactTarget + :: PreparedTypedInductiveFact global + -> FrozenCheckedCore global +typedInductiveFactTarget + (PreparedTypedInductiveFact + (_marker, target, _rule, _monotonicities, _derivation)) = + target + +typedInductiveFactRules + :: PreparedTypedInductiveFact global + -> NonEmpty KernelRuleTag +typedInductiveFactRules + (PreparedTypedInductiveFact + (_marker, _target, rules, _monotonicities, _derivation)) = + rules + +typedInductiveFactRequiresMonotonicities + :: PreparedTypedInductiveFact global + -> Bool +typedInductiveFactRequiresMonotonicities + (PreparedTypedInductiveFact + (_marker, _target, _rules, required, _derivation)) = + required + +typedInductiveFactDerivation + :: PreparedTypedInductiveFact global + -> KernelDerivation global +typedInductiveFactDerivation + (PreparedTypedInductiveFact + (_marker, _target, _rule, _monotonicities, derivation)) = + derivation + +-- | Lower one closed source formula through the exact primitive/global +-- policy used by the direct-inductive compiler. +prepareTypedClosedFormula + :: Eq global + => (global -> CoreType) + -> (Symbol -> Maybe (SourceGlobal global)) + -> Formula + -> Either TypedInductiveError (FrozenCheckedCore global) +prepareTypedClosedFormula globalType resolveGlobal formula = do + term <- + lowerFormulaWith + True + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + emptyEnvironment + formula + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + term) + pure (mapFrozenGlobals inductiveGlobalIdentity checked) + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +prepareTypedClosedTerm + :: Eq global + => (global -> CoreType) + -> (Symbol -> Maybe (SourceGlobal global)) + -> Term + -> Either TypedInductiveError (FrozenCheckedCore global) +prepareTypedClosedTerm globalType resolveGlobal term = do + canonical <- + lowerTerm + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + emptyEnvironment + term + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + canonical) + pure (mapFrozenGlobals inductiveGlobalIdentity checked) + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +data TypedInductiveError + = TypedInductiveDuplicateBinder !VarSymbol + | TypedInductiveUnknownLocal !VarSymbol + | TypedInductiveUnsupportedExpression !Text + | TypedInductiveCoreError !CoreCheckError + | TypedInductiveProofError !KernelProofBuildError + | TypedInductiveProofRemainedOpen + | TypedInductiveFactPreparationFailed + !Marker + !TypedInductiveError + | TypedInductivePreparationContext + !Text + !TypedInductiveError + deriving stock (Show, Eq) + +data InductiveEnvironment = InductiveEnvironment + !(Map VarSymbol Natural) + +emptyEnvironment :: InductiveEnvironment +emptyEnvironment = + InductiveEnvironment Map.empty + +extendEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +extendEnvironment variable + (InductiveEnvironment variables) + | Map.member variable variables = + Left + (TypedInductiveDuplicateBinder + variable) + | otherwise = + Right + (InductiveEnvironment + (Map.insert variable 0 + (succ <$> variables))) + +lookupEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lookupEnvironment variable + (InductiveEnvironment variables) = + maybe + (Left + (TypedInductiveUnknownLocal + variable)) + (Right . CBound) + (Map.lookup variable variables) + +prepareTypedInductive + :: Eq global + => (global -> CoreType) + -> CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal global)) + -> Marker + -> DirectInductive + -> Either + TypedInductiveError + (PreparedTypedInductive global) +prepareTypedInductive + globalType + foundation + resolveGlobal + marker + inductive = + mapPreparedTypedInductive inductiveGlobalIdentity + <$> prepareTypedInductiveInternal + foundation + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + marker + inductive + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +prepareTypedInductiveInternal + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> DirectInductive + -> Either + TypedInductiveError + (PreparedTypedInductive (InductiveGlobal global)) +prepareTypedInductiveInternal + foundation + resolveGlobal + marker + inductive = do + guards <- + traverse + (prepareDirectGuardTarget + resolveGlobal + inductive) + (directInductiveClauses + inductive) + let preparedGuards = + assignGuardSources foundation + (NonEmpty.toList guards) + nextImport = + fromIntegral + (length + [ () + | PreparedImportedGuard{} <- preparedGuards + ]) + (preparedSource, monotonicities, contexts) <- + prepareInductiveSource + resolveGlobal + nextImport + inductive + carrierBody <- + prepareCarrierBody + resolveGlobal + preparedSource + facts <- + prepareFacts + foundation + resolveGlobal + marker + preparedSource + (case preparedGuards of + firstGuard : remainingGuards -> + firstGuard :| remainingGuards + [] -> + impossible + "a nonempty inductive declaration produced no guards") + pure + (PreparedTypedInductive + carrierType + carrierBody + (Vector.fromList + [ target + | PreparedImportedGuard + _index target <- preparedGuards + ]) + (Vector.fromList monotonicities) + (Vector.fromList contexts) + facts) + where + carrierType = + foldr + TyArrow + TySet + (TySet + <$ directInductiveParams + inductive) + +mapSourceGlobal + :: (left -> right) + -> SourceGlobal left + -> SourceGlobal right +mapSourceGlobal transform (SourceGlobal identity body) = + SourceGlobal + (transform identity) + (mapFrozenGlobals transform <$> body) + +mapPreparedTypedInductive + :: (left -> right) + -> PreparedTypedInductive left + -> PreparedTypedInductive right +mapPreparedTypedInductive transform + (PreparedTypedInductive + carrierType body guards monotonicities contexts facts) = + PreparedTypedInductive + carrierType + (mapFrozenGlobals transform body) + (mapFrozenGlobals transform <$> guards) + (mapMonotonicity transform <$> monotonicities) + (mapFrozenGlobals transform <$> contexts) + (mapPreparedFact transform <$> facts) + where + mapMonotonicity mapGlobal + (PreparedTypedInductiveMonotonicity location target) = + PreparedTypedInductiveMonotonicity + location + (mapFrozenGlobals mapGlobal target) + + mapPreparedFact mapGlobal + (PreparedTypedInductiveFact + (marker, target, rule, requiresMonotonicities, derivation)) = + PreparedTypedInductiveFact + ( marker + , mapFrozenGlobals mapGlobal target + , rule + , requiresMonotonicities + , mapKernelDerivationGlobals mapGlobal derivation + ) + +data MonotonicityInventory global = MonotonicityInventory + ![(FrozenCheckedCore global, ImportIx)] + !Natural + ![PreparedTypedInductiveMonotonicity global] + ![FrozenCheckedCore global] + +prepareInductiveSource + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Natural + -> DirectInductive + -> Either + TypedInductiveError + ( PreparedInductiveSource (InductiveGlobal global) + , [PreparedTypedInductiveMonotonicity (InductiveGlobal global)] + , [FrozenCheckedCore (InductiveGlobal global)] + ) +prepareInductiveSource resolveGlobal firstImport inductive = do + (final, clauses) <- + prepareClauses + (MonotonicityInventory [] firstImport [] []) + (NonEmpty.toList (directInductiveClauses inductive)) + let MonotonicityInventory + _targets _next monotonicities contexts = final + pure + ( PreparedInductiveSource + (directInductiveParams inductive) + (directInductiveDomain inductive) + (NonEmpty.fromList clauses) + , reverse monotonicities + , reverse contexts + ) + where + variablesFor clause = + directInductiveParams inductive + <> directClauseVariables clause + + prepareClauses inventory = \case + [] -> pure (inventory, []) + clause : remaining -> do + (afterClause, preparedClause) <- + prepareClause inventory clause + (final, preparedRemaining) <- + prepareClauses afterClause remaining + pure (final, preparedClause : preparedRemaining) + + prepareClause inventory clause = do + (next, conditions) <- + prepareConditions inventory clause + (directClauseConditions clause) + pure + ( next + , PreparedInductiveClause + (directClauseVariables clause) + conditions + (directClauseResult clause) + ) + + prepareConditions inventory _clause [] = + pure (inventory, []) + prepareConditions inventory clause (condition : remaining) = do + (next, prepared) <- + prepareCondition inventory clause condition + (final, preparedRemaining) <- + prepareConditions next clause remaining + pure (final, prepared : preparedRemaining) + + prepareCondition inventory _clause (DirectSideCondition formula) = + pure (inventory, PreparedSideCondition formula) + prepareCondition + (MonotonicityInventory targets next facts contexts) + clause + (DirectRecursiveCondition recursiveTerm sourceContext) = do + checkedContext <- + prepareRecursiveCarrierTemplate + resolveGlobal + (variablesFor clause) + sourceContext + let template = checkedRecursiveCarrierTemplate checkedContext + withContext currentFacts = + MonotonicityInventory + targets next currentFacts (template : contexts) + if recursiveCarrierContextIsDirect sourceContext + then pure + ( withContext facts + , PreparedDirectRecursiveCondition + recursiveTerm checkedContext + ) + else do + target <- + prepareRecursiveCarrierMonotonicityTarget + checkedContext + let RecursiveCarrierContext location _source = sourceContext + case List.lookup target targets of + Just index -> + pure + ( MonotonicityInventory + targets next facts (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + Nothing -> + let index = importIx next + in pure + ( MonotonicityInventory + ((target, index) : targets) + (next + 1) + (PreparedTypedInductiveMonotonicity + location target : facts) + (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + +checkedRecursiveCarrierTemplate + :: CheckedRecursiveCarrierContext global + -> FrozenCheckedCore global +checkedRecursiveCarrierTemplate + (CheckedRecursiveCarrierContext _variables template) = + template + +recursiveCarrierContextIsDirect :: RecursiveCarrierContext -> Bool +recursiveCarrierContextIsDirect + (RecursiveCarrierContext _location source) = + source == TermVar RecursiveCarrierHole + +prepareRecursiveCarrierTemplate + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> [VarSymbol] + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CheckedRecursiveCarrierContext (InductiveGlobal global)) +prepareRecursiveCarrierTemplate resolveGlobal variables context = do + body <- + buildUnderVariables emptyEnvironment variables \environment -> do + underHole <- shiftEnvironment environment + lowerRecursiveCarrierContext + resolveGlobal underHole (CBound 0) context + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + -- Transparent expansion may leave beta redexes. Freeze one + -- normalized template so routing, generated laws, and kernel + -- transport all see the same first-order shape. + (betaNormalizeCanonical + (closeLambdas (length variables + 1) body))) + pure (CheckedRecursiveCarrierContext variables checked) + +prepareRecursiveCarrierMonotonicityTarget + :: CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareRecursiveCarrierMonotonicityTarget + context@(CheckedRecursiveCarrierContext variables _template) = do + target <- + buildUnderVariables emptyEnvironment variables \environment -> do + underSets <- shiftEnvironment =<< shiftEnvironment environment + left <- + instantiateRecursiveCarrier + underSets (CBound 1) context + right <- + instantiateRecursiveCarrier + underSets (CBound 0) context + pure + (CImp + (subsetTerm (CBound 1) (CBound 0)) + (subsetTerm left right)) + freezeClosedTarget + (closeForalls (length variables + 2) target) + +instantiateRecursiveCarrier + :: InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +instantiateRecursiveCarrier environment replacement + context@(CheckedRecursiveCarrierContext variables _template) = do + arguments <- traverse (`lookupEnvironment` environment) variables + foldM instantiateLambda + (frozenCoreTerm (checkedRecursiveCarrierTemplate context)) + (arguments <> [replacement]) + where + instantiateLambda term argument = + case term of + CLam TySet body -> + pure (instantiateCanonical argument body) + _ -> + Left + (TypedInductiveUnsupportedExpression + "a checked recursive carrier context lost its set telescope") + +lowerRecursiveCarrierContext + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerRecursiveCarrierContext resolveGlobal environment replacement + (RecursiveCarrierContext _location source) = + go source + where + go = \case + TermVar RecursiveCarrierHole -> + pure replacement + TermVar (RecursiveCarrierSourceVariable variable) -> + lookupEnvironment variable environment + TermSymbol _location symbol arguments -> do + lowered <- traverse go arguments + lowerApplicationTerms resolveGlobal symbol lowered + _ -> + Left + (TypedInductiveUnsupportedExpression + "a validated recursive carrier context left the supported set-term fragment") + +prepareCarrierBody + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareCarrierBody resolveGlobal inductive = do + body <- + buildUnderVariables + emptyEnvironment + (preparedInductiveParams + inductive) + (\env -> fixedPointTerm + resolveGlobal + inductive + env) + let closed = + closeLambdas + (length + (preparedInductiveParams + inductive)) + body + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + closed) + pure checked + +prepareDirectGuardTarget + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> DirectInductive + -> DirectInductiveClause + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareDirectGuardTarget + resolveGlobal + inductive + clause = do + target <- + buildUnderVariables + emptyEnvironment + (directInductiveParams inductive + <> directClauseVariables clause) + (\environment -> do + domain <- + lowerTerm + resolveGlobal + environment + (directInductiveDomain + inductive) + conditions <- + traverse + (directConditionTerm + resolveGlobal + environment + domain) + (directClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + environment + (directClauseResult + clause) + pure + (impliesIfNeeded + (conjunctionList + conditions) + (memberTerm + result + domain))) + freezeClosedTarget + (closeForalls + (length + (directInductiveParams inductive + <> directClauseVariables clause)) + target) + +assignGuardSources + :: CheckedFoundation + -> [FrozenCheckedCore (InductiveGlobal global)] + -> [PreparedInductiveGuard (InductiveGlobal global)] +assignGuardSources foundation = + snd . List.mapAccumL assign 0 + where + assign nextImport target = + case matchingFoundationAxiom target of + Just tag -> + (nextImport, PreparedFoundationGuard tag) + Nothing -> + ( nextImport + 1 + , PreparedImportedGuard + (importIx nextImport) + target + ) + + matchingFoundationAxiom target = + List.find + (\tag -> + mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag) + == target) + [minBound .. maxBound] + +prepareFacts + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> NonEmpty (PreparedInductiveGuard (InductiveGlobal global)) + -> Either + TypedInductiveError + (NonEmpty (PreparedTypedInductiveFact (InductiveGlobal global))) +prepareFacts + foundation + resolveGlobal + marker + inductive + guards = do + introductions <- + sequence + (NonEmpty.zipWith + (\clauseIndex pair -> + first + (TypedInductiveFactPreparationFailed + (introMarker + marker + (clauseIndex + 1))) + (prepareIntroductionFact + foundation + resolveGlobal + marker + inductive + clauseIndex + pair)) + (0 :| [1 ..]) + (NonEmpty.zip + guards + (preparedInductiveClauses + inductive))) + domainSubset <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "dom_subset")) + (prepareDomainSubsetFact + foundation + resolveGlobal + marker + inductive) + cases <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "cases")) + (prepareCasesFact + foundation + resolveGlobal + marker + inductive) + induction <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "induct")) + (prepareInductionFact + foundation + resolveGlobal + marker + inductive) + pure + (introductions + <> (domainSubset + :| [cases, induction])) + +prepareIntroductionFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Natural + -> (PreparedInductiveGuard (InductiveGlobal global), PreparedInductiveClause (InductiveGlobal global)) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareIntroductionFact + foundation + resolveGlobal + marker + inductive + clauseIndex + (guardSource, clause) = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams inductive + <> preparedClauseVariables clause) + (\context environment -> do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + fixedPoint <- + checkedTerm context + =<< fixedPointTerm + resolveGlobal + inductive + environment + predicate <- + checkedTerm context + =<< operatorPredicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + appliedOperatorSet <- + checkedTerm context + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm + fixedPoint)) + conditions <- + traverse + (checkedTerm context <=< + conditionTerm + resolveGlobal + environment + (scopedCoreTerm + fixedPoint)) + (preparedClauseConditions + clause) + result <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedClauseResult + clause) + let conditionTerms = + scopedCoreTerm <$> conditions + first + (TypedInductivePreparationContext + "introduction premises") + (provePremises + context + conditionTerms + (\premiseProofs -> do + guardProof <- + preparedGuardProof + context + guardSource + specializedGuard <- + first + (TypedInductivePreparationContext + "introduction guard specialization") + (eliminateWrittenForalls + context + environment + (preparedInductiveParams + inductive + <> preparedClauseVariables + clause) + guardProof) + guardPremiseProofs <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure premiseProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + bound <- + first + TypedInductiveProofError + (setLfpBoundProof + context + domain + operator) + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + implication <- + first + TypedInductiveProofError + (forallEliminationProof + context + bound + recursiveElement) + first + TypedInductiveProofError + (implicationEliminationProof + context + implication + premiseProof) + nested@PreparedNestedRecursiveCondition{} -> do + bound <- + first TypedInductiveProofError + (setLfpBoundProof + context + domain + operator) + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm + nested) + transportNestedRecursiveMembership + context + environment + nested + fixedPoint + domain + recursiveElement + bound + premiseProof + | (condition, premiseProof) <- + zip + (preparedClauseConditions + clause) + premiseProofs + ] + inDomain <- + case conjunctionList + conditionTerms of + Nothing -> + pure specializedGuard + Just _condition -> do + conjunction <- + conjunctionIntroductionList + context + guardPremiseProofs + first + (TypedInductivePreparationContext + "introduction guard application") + (first TypedInductiveProofError + (implicationEliminationProof + context + specializedGuard + conjunction)) + equality <- + first TypedInductiveProofError + (equalityReflexivityProof + context + result) + clauseProof <- + conjunctionIntroductionList + context + (premiseProofs + <> [equality]) + clauseExists <- + first + (TypedInductivePreparationContext + "introduction witnesses") + (introduceClauseWitnesses + resolveGlobal + inductive + clause + context + environment + (scopedCoreTerm + fixedPoint) + result + clauseProof) + alternatives <- + clauseFormulaTerms + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + (scopedCoreTerm + result) + disjunction <- + first + (TypedInductivePreparationContext + "introduction disjunction") + (injectDisjunction + context + clauseIndex + alternatives + clauseExists) + inOperator <- + first + (TypedInductivePreparationContext + "introduction separation") + (separationBackward + context + domain + predicate + result + inDomain + disjunction) + inAppliedTarget <- + checkedTerm context + (memberTerm + (scopedCoreTerm + result) + (scopedCoreTerm + appliedOperatorSet)) + inAppliedOperator <- + first TypedInductiveProofError + (conversionProof + context + inOperator + inAppliedTarget) + monotone <- + first + (TypedInductivePreparationContext + "introduction bounded monotonicity") + (proveBoundedMonotonicity + foundation + resolveGlobal + inductive + context + environment) + fixed <- + first TypedInductiveProofError + (setLfpFixedProof + context + domain + operator + monotone) + reversedFixed <- + first + (TypedInductivePreparationContext + "introduction fixed-point symmetry") + (first TypedInductiveProofError + (equalityReverseProof + context + fixed)) + first + (TypedInductivePreparationContext + "introduction fixed-point transport") + (transportMembership + context + result + reversedFixed + inAppliedOperator)))) + preparedFact + (introMarker + marker + (clauseIndex + 1)) + (if any isRecursiveCondition + (preparedClauseConditions clause) + then SetLfpBound :| [SetLfpFixed] + else SetLfpFixed :| []) + True + proof + where + isRecursiveCondition = \case + PreparedDirectRecursiveCondition{} -> True + PreparedNestedRecursiveCondition{} -> True + PreparedSideCondition{} -> False + +preparedGuardProof + :: ProofContext (InductiveGlobal global) + -> PreparedInductiveGuard (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +preparedGuardProof context = \case + PreparedFoundationGuard tag -> + first TypedInductiveProofError + (foundationProof context tag) + PreparedImportedGuard index target -> + first TypedInductiveProofError + (importedProof context index target) + +prepareDomainSubsetFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareDomainSubsetFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\context environment -> do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + first TypedInductiveProofError + (setLfpBoundProof + context + domain + operator)) + preparedFact + (derivedMarker marker "dom_subset") + (SetLfpBound :| []) + False + proof + +prepareCasesFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareCasesFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\parameterContext parameterEnvironment -> + forallIntroductionTyped + parameterContext + TySet + (\context result -> do + environment <- + shiftEnvironment + parameterEnvironment + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + fixedPoint <- + checkedTerm context + =<< fixedPointTerm + resolveGlobal + inductive + environment + predicate <- + checkedTerm context + =<< operatorPredicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + explicitOperatorSet <- + checkedTerm context + =<< separationSetAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + member <- + checkedTerm context + (memberTerm + (scopedCoreTerm result) + (scopedCoreTerm + fixedPoint)) + implicationIntroductionTyped + context + member + (\withMember memberProof -> do + monotone <- + proveBoundedMonotonicity + foundation + resolveGlobal + inductive + withMember + environment + fixed <- + first TypedInductiveProofError + (setLfpFixedProof + withMember + domain + operator + monotone) + inOperator <- + transportMembership + withMember + result + fixed + memberProof + explicitMembership <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + result) + (scopedCoreTerm + explicitOperatorSet)) + inSeparation <- + first TypedInductiveProofError + (conversionProof + withMember + inOperator + explicitMembership) + separation <- + separationForward + withMember + domain + predicate + result + inSeparation + predicateResult <- + predicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + (scopedCoreTerm + result) + predicateProof <- + first TypedInductiveProofError + (conjunctionRightProof + withMember + (memberTerm + (scopedCoreTerm result) + (scopedCoreTerm + domain)) + (CApp + (scopedCoreTerm + predicate) + (scopedCoreTerm + result)) + separation) + predicateTarget <- + checkedTerm + withMember + predicateResult + first TypedInductiveProofError + (conversionProof + withMember + predicateProof + predicateTarget)))) + preparedFact + (derivedMarker marker "cases") + (SetLfpFixed :| []) + True + proof + +prepareInductionFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareInductionFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\parameterContext parameterEnvironment -> + forallIntroductionTyped + parameterContext + TySet + (\subsetContext subset -> do + environment <- + shiftEnvironment + parameterEnvironment + closures <- + closureTerms + resolveGlobal + inductive + environment + (scopedCoreTerm subset) + closureConjunction <- + checkedTerm subsetContext + (fromMaybe + (CImp CFalsum CFalsum) + (conjunctionList + closures)) + implicationIntroductionTyped + subsetContext + closureConjunction + (\withClosures closuresProof -> do + fixedPoint <- + checkedTerm withClosures + =<< fixedPointTerm + resolveGlobal + inductive + environment + proveSubset + withClosures + fixedPoint + subset + (\elementContext element memberProof -> do + elementEnvironment <- + shiftEnvironment environment + domain <- + checkedTerm elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm elementContext + =<< operatorTerm + resolveGlobal + inductive + elementEnvironment + fixedPointAtElement <- + checkedTerm elementContext + =<< fixedPointTerm + resolveGlobal + inductive + elementEnvironment + subsetAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + predicate <- + membershipPredicate + elementContext + subsetAtElement + monotone <- + first + (TypedInductivePreparationContext + "induction bounded monotonicity") + (proveBoundedMonotonicity + foundation + resolveGlobal + inductive + elementContext + elementEnvironment) + closure <- + first + (TypedInductivePreparationContext + "induction closure") + (proveInductionClosure + foundation + resolveGlobal + inductive + elementContext + elementEnvironment + fixedPointAtElement + operator + subsetAtElement + closures + closuresProof) + inducted <- + first + (TypedInductivePreparationContext + "induction fixed-point rule") + (first TypedInductiveProofError + (setLfpInductProof + elementContext + domain + operator + predicate + element + monotone + memberProof + closure)) + expected <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + subsetAtElement)) + first TypedInductiveProofError + (conversionProof + elementContext + inducted + expected))))) + preparedFact + (derivedMarker marker "induct") + (SetLfpInduct :| []) + True + proof + +proveUnderVariables + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> [VarSymbol] + -> ( ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveUnderVariables context environment variables build = + case variables of + [] -> + build context environment + variable : remaining -> do + extendedEnvironment <- + extendEnvironment + variable + environment + forallIntroductionTyped + context + TySet + (\extended _bound -> + proveUnderVariables + extended + extendedEnvironment + remaining + build) + +checkedTerm + :: ProofContext (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (ScopedCheckedCore (InductiveGlobal global)) +checkedTerm context = + first TypedInductiveProofError + . scopedTerm context + +preparedFact + :: Marker + -> NonEmpty KernelRuleTag + -> Bool + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +preparedFact marker rules requiresMonotonicities proof = do + target <- + maybe + (Left TypedInductiveProofRemainedOpen) + Right + (closeScopedCore + (builtProofStatement proof)) + pure + (PreparedTypedInductiveFact + ( marker + , target + , canonicalRules rules + , requiresMonotonicities + , builtProofDerivation proof + )) + where + canonicalRules supplied = + case Set.toAscList + (Set.fromList (NonEmpty.toList supplied)) of + firstRule : remainingRules -> + firstRule :| remainingRules + [] -> + impossible "a nonempty guarded-rule set became empty" + +introMarker :: Marker -> Natural -> Marker +introMarker (Marker marker) index = + Marker + (marker + <> "_intro_" + <> Text.pack (show index)) + +derivedMarker :: Marker -> Text -> Marker +derivedMarker (Marker marker) suffix = + Marker + (marker <> "_" <> suffix) + +eliminateWrittenForalls + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> [VarSymbol] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateWrittenForalls + context + environment + variables + initial = + foldM + (\proof variable -> do + argument <- + checkedTerm context + =<< lookupEnvironment + variable + environment + first TypedInductiveProofError + (forallEliminationProof + context + proof + argument)) + initial + variables + +provePremises + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> ( [BuiltProof (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +provePremises context premises build = + case conjunctionList premises of + Nothing -> + build [] + Just conjunction -> do + proposition <- + checkedTerm context conjunction + implicationIntroductionTyped + context + proposition + (\extended conjunctionProof -> do + projections <- + projectConjunctionList + extended + premises + conjunctionProof + build projections) + +conjunctionIntroductionList + :: ProofContext (InductiveGlobal global) + -> [BuiltProof (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +conjunctionIntroductionList _context [] = + Left + (TypedInductiveUnsupportedExpression + "an empty conjunction has no introduction proof") +conjunctionIntroductionList context (firstProof : remaining) = + foldM + (\left right -> + first TypedInductiveProofError + (conjunctionIntroductionProof + context + left + right)) + firstProof + remaining + +projectConjunctionList + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + [BuiltProof (InductiveGlobal global)] +projectConjunctionList _context [] _proof = + pure [] +projectConjunctionList _context [_only] proof = + pure [proof] +projectConjunctionList context terms proof = do + let preceding = + List.init terms + final = + List.last terms + precedingTerm = + fromMaybe + CFalsum + (conjunctionList preceding) + precedingProof <- + first TypedInductiveProofError + (conjunctionLeftProof + context + precedingTerm + final + proof) + finalProof <- + first TypedInductiveProofError + (conjunctionRightProof + context + precedingTerm + final + proof) + (<> [finalProof]) + <$> projectConjunctionList + context + preceding + precedingProof + +introduceClauseWitnesses + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +introduceClauseWitnesses + resolveGlobal + _inductive + clause + context + environment + candidate + result + bodyProof = + introduce + (preparedClauseVariables clause) + where + introduce [] = + pure bodyProof + introduce (variable : remaining) = do + inner <- + introduce remaining + witness <- + checkedTerm context + =<< lookupEnvironment + variable + environment + underBinderEnvironment <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + let candidate' = + shiftCanonicalTerm 1 0 candidate + result' = + shiftCanonicalTerm + 1 + 0 + (scopedCoreTerm result) + bodyUnderBinderTerm <- + clauseFormulaWithBinders + resolveGlobal + clause + underBinderEnvironment + candidate' + result' + remaining + bodyUnderBinder <- + first TypedInductiveCoreError + (checkScopedCanonicalCore + (Just . inductiveGlobalType) + (TySet + : proofContextTypes + context) + bodyUnderBinderTerm) + first TypedInductiveProofError + (existentialIntroductionProof + context + TySet + bodyUnderBinder + witness + inner) + +clauseFormulaWithBinders + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [VarSymbol] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clauseFormulaWithBinders + resolveGlobal + clause + environment + candidate + result = \case + [] -> do + conditions <- + traverse + (conditionTerm + resolveGlobal + environment + candidate) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + pure + (fromMaybe + (CEq TySet result clauseResult) + (conjunctionList + (conditions + <> [CEq + TySet + result + clauseResult]))) + variable : remaining -> do + extended <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + body <- + clauseFormulaWithBinders + resolveGlobal + clause + extended + (shiftCanonicalTerm + 1 + 0 + candidate) + (shiftCanonicalTerm + 1 + 0 + result) + remaining + pure (existentialTerm TySet body) + +rebindEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +rebindEnvironment variable + (InductiveEnvironment variables) = + pure + (InductiveEnvironment + (Map.insert variable 0 variables)) + +injectDisjunction + :: ProofContext (InductiveGlobal global) + -> Natural + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +injectDisjunction context index alternatives proof = + case splitAtNatural index alternatives of + Nothing -> + Left + (TypedInductiveUnsupportedExpression + "inductive clause index is outside the source-ordered alternatives") + Just (preceding, _selected, following) -> do + selectedProof <- + case preceding of + [] -> + pure proof + _ -> do + let precedingTerm = + disjunctionList preceding + first TypedInductiveProofError + (disjunctionRightProof + context + precedingTerm + proof) + foldM + (\current followingTerm -> + first TypedInductiveProofError + (disjunctionLeftProof + context + followingTerm + current)) + selectedProof + following + where + splitAtNatural + :: Natural + -> [a] + -> Maybe ([a], a, [a]) + splitAtNatural = + go [] + where + go _preceding _index [] = + Nothing + go preceding 0 (selected : rest) = + Just + ( reverse preceding + , selected + , rest + ) + go preceding current (item : rest) = + go + (item : preceding) + (current - 1) + rest + +closureTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + [CanonicalTerm (InductiveGlobal global)] +closureTerms + resolveGlobal + inductive + environment + subset = + traverse closureFor + (NonEmpty.toList + (preparedInductiveClauses + inductive)) + where + closureFor clause = do + clauseEnvironment <- + extendVariables + environment + (preparedClauseVariables clause) + let binderCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + subset' = + shiftCanonicalTerm + binderCount + 0 + subset + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + subset') + (preparedClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult clause) + pure + (closeForalls + (length + (preparedClauseVariables + clause)) + (impliesIfNeeded + (conjunctionList conditions) + (memberTerm + result + subset'))) + +proveBoundedMonotonicity + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveBoundedMonotonicity + _foundation + resolveGlobal + inductive + context + environment = do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + operatorDomain <- + checkedTerm context + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm domain)) + bounded <- + first + (TypedInductivePreparationContext + "bounded monotonicity range") + (proveSubset + context + operatorDomain + domain + (\elementContext element membership -> do + elementEnvironment <- + shiftEnvironment environment + domainAtElement <- + checkedTerm elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + predicate <- + checkedTerm elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + domainAtElement) + explicitOperator <- + checkedTerm elementContext + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + domainAtElement) + explicitMembership <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm + explicitOperator)) + separatedMembership <- + first TypedInductiveProofError + (conversionProof + elementContext + membership + explicitMembership) + characteristic <- + separationForward + elementContext + domainAtElement + predicate + element + separatedMembership + first TypedInductiveProofError + (conjunctionLeftProof + elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + characteristic))) + monotone <- + first + (TypedInductivePreparationContext + "bounded monotonicity relation") + (forallIntroductionTyped + context + TySet + (\xContext _x -> + forallIntroductionTyped + xContext + TySet + (\xyContext _y -> do + xyEnvironment <- + shiftEnvironment + =<< shiftEnvironment + environment + x <- + checkedTerm xyContext + (CBound 1) + y <- + checkedTerm xyContext + (CBound 0) + domainXY <- + checkedTerm xyContext + =<< lowerTerm + resolveGlobal + xyEnvironment + (preparedInductiveDomain + inductive) + relation <- + checkedTerm xyContext + (conjunctionTerm + (subsetTerm + (scopedCoreTerm x) + (scopedCoreTerm y)) + (subsetTerm + (scopedCoreTerm y) + (scopedCoreTerm + domainXY))) + implicationIntroductionTyped + xyContext + relation + (\relatedContext _relationProof -> do + operatorXY <- + checkedTerm relatedContext + =<< operatorTerm + resolveGlobal + inductive + xyEnvironment + operatorX <- + checkedTerm relatedContext + (CApp + (scopedCoreTerm + operatorXY) + (scopedCoreTerm x)) + operatorY <- + checkedTerm relatedContext + (CApp + (scopedCoreTerm + operatorXY) + (scopedCoreTerm y)) + proveSubset + relatedContext + operatorX + operatorY + (\elementContext element membership -> do + elementEnvironment <- + shiftEnvironment + xyEnvironment + xAtElement <- + checkedTerm + elementContext + (CBound 2) + yAtElement <- + checkedTerm + elementContext + (CBound 1) + domainAtElement <- + checkedTerm + elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + predicateX <- + checkedTerm + elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + predicateY <- + checkedTerm + elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + yAtElement) + explicitX <- + checkedTerm + elementContext + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + memberExplicitX <- + checkedTerm + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + explicitX)) + separatedX <- + first TypedInductiveProofError + (conversionProof + elementContext + membership + memberExplicitX) + characteristicX <- + separationForward + elementContext + domainAtElement + predicateX + element + separatedX + inDomain <- + first + (TypedInductivePreparationContext + "monotonicity domain projection") + (first TypedInductiveProofError + (conjunctionLeftProof + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm + predicateX) + (scopedCoreTerm + element)) + characteristicX)) + satisfiesX <- + first + (TypedInductivePreparationContext + "monotonicity predicate projection") + (first TypedInductiveProofError + (conjunctionRightProof + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm + predicateX) + (scopedCoreTerm + element)) + characteristicX)) + alternativesX <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + (scopedCoreTerm + element) + alternativesY <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + yAtElement) + (scopedCoreTerm + element) + predicateXTarget <- + checkedTerm + elementContext + (disjunctionList + alternativesX) + satisfiesX' <- + first TypedInductiveProofError + (conversionProof + elementContext + satisfiesX + predicateXTarget) + satisfiesY <- + first + (TypedInductivePreparationContext + "monotonicity predicate transport") + (transformPredicateProof + resolveGlobal + inductive + elementContext + elementEnvironment + (scopedCoreTerm + xAtElement) + (scopedCoreTerm + yAtElement) + (scopedCoreTerm + domainAtElement) + (scopedCoreTerm + element) + alternativesX + alternativesY + satisfiesX') + separatedY <- + first + (TypedInductivePreparationContext + "monotonicity separation") + (separationBackward + elementContext + domainAtElement + predicateY + element + inDomain + satisfiesY) + operatorYAtElement <- + first + TypedInductiveCoreError + (weakenScopedCore + (Just + . inductiveGlobalType) + TySet + operatorY) + explicitMembershipY <- + checkedTerm + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + operatorYAtElement)) + first TypedInductiveProofError + (conversionProof + elementContext + separatedY + explicitMembershipY)))))) + first + (TypedInductivePreparationContext + "bounded monotonicity conjunction") + (first TypedInductiveProofError + (conjunctionIntroductionProof + context + bounded + monotone)) + +transformPredicateProof + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transformPredicateProof + resolveGlobal + inductive + context + environment + candidateX + candidateY + domain + result + alternativesX + alternativesY + proof = do + target <- + checkedTerm context + (disjunctionList alternativesY) + first + (TypedInductivePreparationContext + "predicate disjunction elimination") + (eliminateDisjunctionAlternatives + context + alternativesX + proof + target + (\caseContext clauseIndex clauseProof -> do + clause <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive clause inventory changed during proof construction")) + Right + (atNatural + clauseIndex + (NonEmpty.toList + (preparedInductiveClauses + inductive))) + first + (TypedInductivePreparationContext + "predicate witness elimination") + (eliminateClauseWitnesses + resolveGlobal + clause + caseContext + environment + candidateX + result + clauseProof + target + (\depth + leafContext + leafEnvironment + candidateXAtLeaf + resultAtLeaf + bodyProof -> do + let candidateYAtLeaf = + shiftCanonicalTerm + depth + 0 + candidateY + domainAtLeaf = + shiftCanonicalTerm + depth + 0 + domain + alternativesYAtLeaf = + shiftCanonicalTerm + depth + 0 + <$> alternativesY + bodyY <- + first + (TypedInductivePreparationContext + "predicate clause body") + (transformClauseBody + resolveGlobal + clause + leafContext + leafEnvironment + candidateXAtLeaf + candidateYAtLeaf + domainAtLeaf + resultAtLeaf + bodyProof) + resultAtLeaf' <- + checkedTerm + leafContext + resultAtLeaf + alternativeY <- + introduceClauseWitnesses + resolveGlobal + inductive + clause + leafContext + leafEnvironment + candidateYAtLeaf + resultAtLeaf' + bodyY + first + (TypedInductivePreparationContext + "predicate disjunction injection") + (injectDisjunction + leafContext + clauseIndex + alternativesYAtLeaf + alternativeY))))) + +transformClauseBody + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transformClauseBody + resolveGlobal + clause + context + environment + candidateX + candidateY + domain + result + proof = do + conditionsX <- + traverse + (conditionTerm + resolveGlobal + environment + candidateX) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + let equality = + CEq TySet result clauseResult + bodyTermsX = + conditionsX <> [equality] + projections <- + projectConjunctionList + context + bodyTermsX + proof + let (conditionProofs, equalityProofs) = + splitAt + (length conditionsX) + projections + transformedConditions <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure conditionProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + subsetProof <- + subsetRelationHypothesis + context + candidateX + candidateY + domain + implication <- + first TypedInductiveProofError + (forallEliminationProof + context + subsetProof + recursiveElement) + first TypedInductiveProofError + (implicationEliminationProof + context + implication + conditionProof) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + subsetProof <- + subsetRelationHypothesis + context + candidateX + candidateY + domain + left <- checkedTerm context candidateX + right <- checkedTerm context candidateY + transportNestedRecursiveMembership + context + environment + nested + left + right + recursiveElement + subsetProof + conditionProof + | (condition, conditionProof) <- + zip + (preparedClauseConditions clause) + conditionProofs + ] + equalityProof <- + case equalityProofs of + [only] -> + pure only + _ -> + Left + (TypedInductiveUnsupportedExpression + "inductive clause equality projection is inconsistent") + conjunctionIntroductionList + context + (transformedConditions + <> [equalityProof]) + +subsetRelationHypothesis + :: ProofContext (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +subsetRelationHypothesis + context + left + right + domain = do + let leftSubsetRight = + subsetTerm left right + rightSubsetDomain = + subsetTerm right domain + relation = + conjunctionTerm + leftSubsetRight + rightSubsetDomain + relationTerm <- + checkedTerm context relation + relationProof <- + first TypedInductiveProofError + (hypothesisProof + context + relationTerm) + first TypedInductiveProofError + (conjunctionLeftProof + context + leftSubsetRight + rightSubsetDomain + relationProof) + +preparedRecursiveTerm + :: PreparedInductiveCondition global + -> Term +preparedRecursiveTerm = \case + PreparedDirectRecursiveCondition term _context -> term + PreparedNestedRecursiveCondition term _context _index _target -> term + PreparedSideCondition{} -> + impossible "a side condition has no recursive element" + +transportNestedRecursiveMembership + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportNestedRecursiveMembership + context + environment + condition + left + right + element + subsetProof + membership = do + monotonicity <- + nestedRecursiveMonotonicityProof + context environment condition left right subsetProof + implication <- + first TypedInductiveProofError + (forallEliminationProof + context monotonicity element) + first TypedInductiveProofError + (implicationEliminationProof + context implication membership) + +nestedRecursiveMonotonicityProof + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +nestedRecursiveMonotonicityProof + context + environment + (PreparedNestedRecursiveCondition + _term + (CheckedRecursiveCarrierContext variables _template) + index + target) + left + right + subsetProof = do + theorem <- + first TypedInductiveProofError + (importedProof context index target) + specialized <- + eliminateWrittenForalls + context environment variables theorem + atLeft <- + first TypedInductiveProofError + (forallEliminationProof context specialized left) + atRight <- + first TypedInductiveProofError + (forallEliminationProof context atLeft right) + first TypedInductiveProofError + (implicationEliminationProof + context atRight subsetProof) +nestedRecursiveMonotonicityProof + _context _environment _condition _left _right _subsetProof = + Left + (TypedInductiveUnsupportedExpression + "nested carrier transport requires a monotonicity import") + +proveInductionCandidateSubset + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionCandidateSubset + context fixedPoint predicate candidate subset = + proveSubset + context candidate subset + (\elementContext element membership -> do + fixedPointAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + fixedPoint) + predicateAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + predicate) + explicitMembership <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (apply2 + (CIntrinsic Sep) + (scopedCoreTerm fixedPointAtElement) + (scopedCoreTerm predicateAtElement))) + membership' <- + first TypedInductiveProofError + (conversionProof + elementContext membership explicitMembership) + characteristic <- + separationForward + elementContext + fixedPointAtElement + predicateAtElement + element + membership' + satisfies <- + first TypedInductiveProofError + (conjunctionRightProof + elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm fixedPointAtElement)) + (CApp + (scopedCoreTerm predicateAtElement) + (scopedCoreTerm element)) + characteristic) + expected <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + target <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm expected)) + first TypedInductiveProofError + (conversionProof + elementContext satisfies target)) + +eliminateClauseWitnesses + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( Natural + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateClauseWitnesses + resolveGlobal + clause + initialContext + initialEnvironment + initialCandidate + initialResult + initialProof + initialTarget + finish = + go + 0 + initialContext + initialEnvironment + initialCandidate + initialResult + initialProof + initialTarget + (preparedClauseVariables clause) + where + go depth context environment candidate result proof target = \case + [] -> + finish + depth + context + environment + candidate + result + proof + variable : remaining -> do + underBinderEnvironment <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + let candidate' = + shiftCanonicalTerm + 1 + 0 + candidate + result' = + shiftCanonicalTerm + 1 + 0 + result + bodyUnderBinderTerm <- + clauseFormulaWithBinders + resolveGlobal + clause + underBinderEnvironment + candidate' + result' + remaining + bodyUnderBinder <- + first TypedInductiveCoreError + (checkScopedCanonicalCore + (Just . inductiveGlobalType) + (TySet + : proofContextTypes + context) + bodyUnderBinderTerm) + targetUnderBinder <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + target) + first TypedInductiveProofError + (existentialEliminationProof + context + TySet + bodyUnderBinder + proof + target + (\underBinderContext _witness bodyProof -> + first typedAsProofError + (go + (depth + 1) + underBinderContext + underBinderEnvironment + candidate' + result' + bodyProof + targetUnderBinder + remaining))) + +eliminateDisjunctionAlternatives + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> Natural + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateDisjunctionAlternatives + initialContext + alternatives + proof + target + handle = + go initialContext 0 alternatives proof + where + go _context _offset [] _proof = + Left + (TypedInductiveUnsupportedExpression + "an inductive predicate has no alternatives") + go context offset [_only] onlyProof = + handle context offset onlyProof + go context offset current currentProof = do + let preceding = + List.init current + final = + List.last current + precedingTerm = + disjunctionList preceding + finalIndex = + offset + + fromIntegral + (length preceding) + first TypedInductiveProofError + (disjunctionEliminationProof + context + precedingTerm + final + currentProof + target + (\leftContext leftProof -> + first typedAsProofError + (go + leftContext + offset + preceding + leftProof)) + (\rightContext rightProof -> + first typedAsProofError + (handle + rightContext + finalIndex + rightProof))) + +proveInductionClosure + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionClosure + _foundation + resolveGlobal + inductive + context + environment + fixedPoint + operator + subset + closures + _closuresProof = + forallIntroductionTyped + context + TySet + (\elementContext element -> do + elementEnvironment <- + shiftEnvironment environment + fixedPointAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + fixedPoint) + operatorAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + operator) + subsetAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + inductionPredicate <- + membershipPredicate + elementContext + subsetAtElement + candidate <- + checkedTerm elementContext + (apply2 + (CIntrinsic Sep) + (scopedCoreTerm + fixedPointAtElement) + (scopedCoreTerm + inductionPredicate)) + unfolded <- + checkedTerm elementContext + (CApp + (scopedCoreTerm + operatorAtElement) + (scopedCoreTerm + candidate)) + premise <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm unfolded)) + implicationIntroductionTyped + elementContext + premise + (\withMember memberProof -> do + domain <- + checkedTerm withMember + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + operatorPredicate <- + checkedTerm withMember + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + explicitOperator <- + checkedTerm withMember + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + explicitMembership <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + explicitOperator)) + separated <- + first TypedInductiveProofError + (conversionProof + withMember + memberProof + explicitMembership) + characteristic <- + separationForward + withMember + domain + operatorPredicate + element + separated + predicateProof <- + first TypedInductiveProofError + (conjunctionRightProof + withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domain)) + (CApp + (scopedCoreTerm + operatorPredicate) + (scopedCoreTerm + element)) + characteristic) + alternatives <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + (scopedCoreTerm + element) + predicateTarget <- + checkedTerm + withMember + (disjunctionList + alternatives) + predicateProof' <- + first TypedInductiveProofError + (conversionProof + withMember + predicateProof + predicateTarget) + result <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + subsetAtElement)) + subsetMembership <- + first + (TypedInductivePreparationContext + "induction clause alternatives") + (eliminateDisjunctionAlternatives + withMember + alternatives + predicateProof' + result + (\caseContext clauseIndex clauseProof -> do + clause <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive closure clause index is outside the source inventory")) + Right + (atNatural + clauseIndex + (NonEmpty.toList + (preparedInductiveClauses + inductive))) + first + (TypedInductivePreparationContext + "induction clause witnesses") + (eliminateClauseWitnesses + resolveGlobal + clause + caseContext + elementEnvironment + (scopedCoreTerm + candidate) + (scopedCoreTerm + element) + clauseProof + result + (\depth + leafContext + leafEnvironment + _candidateAtLeaf + resultAtLeaf + bodyProof -> + first + (TypedInductivePreparationContext + "induction clause proof") + (proveInductionClause + resolveGlobal + inductive + clauseIndex + clause + leafContext + leafEnvironment + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + fixedPointAtElement)) + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + inductionPredicate)) + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + subsetAtElement)) + (shiftCanonicalTerm + (depth + 2) + 0 + <$> closures) + resultAtLeaf + bodyProof))))) + appliedPredicate <- + checkedTerm withMember + (CApp + (scopedCoreTerm + inductionPredicate) + (scopedCoreTerm + element)) + first TypedInductiveProofError + (conversionProof + withMember + subsetMembership + appliedPredicate))) + +proveInductionClause + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> Natural + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionClause + resolveGlobal + _inductive + clauseIndex + clause + context + environment + fixedPoint + predicate + subset + closures + result + bodyProof = do + conditions <- + traverse + (conditionTerm + resolveGlobal + environment + (apply2 + (CIntrinsic Sep) + fixedPoint + predicate)) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + let equality = + CEq TySet result clauseResult + bodyTerms = + conditions <> [equality] + projections <- + first + (TypedInductivePreparationContext + "induction clause body projections") + (projectConjunctionList + context + bodyTerms + bodyProof) + let (conditionProofs, equalityProofs) = + splitAt + (length conditions) + projections + closureConditionProofs <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure conditionProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + fixedPoint' <- + checkedTerm context fixedPoint + predicate' <- + checkedTerm context predicate + separated <- + separationForward + context + fixedPoint' + predicate' + recursiveElement + conditionProof + predicateMembership <- + first TypedInductiveProofError + (conjunctionRightProof + context + (memberTerm + (scopedCoreTerm + recursiveElement) + fixedPoint) + (CApp + predicate + (scopedCoreTerm + recursiveElement)) + separated) + expected <- + checkedTerm context + (memberTerm + (scopedCoreTerm + recursiveElement) + subset) + first TypedInductiveProofError + (conversionProof + context + predicateMembership + expected) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + fixedPoint' <- checkedTerm context fixedPoint + predicate' <- checkedTerm context predicate + candidate <- + checkedTerm context + (apply2 + (CIntrinsic Sep) + fixedPoint + predicate) + subset' <- checkedTerm context subset + candidateSubset <- + proveInductionCandidateSubset + context + fixedPoint' + predicate' + candidate + subset' + transportNestedRecursiveMembership + context + environment + nested + candidate + subset' + recursiveElement + candidateSubset + conditionProof + | (condition, conditionProof) <- + zip + (preparedClauseConditions clause) + conditionProofs + ] + closureConjunction <- + case conjunctionList closures of + Nothing -> + Left + (TypedInductiveUnsupportedExpression + "inductive closure inventory is empty") + Just conjunction -> + first + (TypedInductivePreparationContext + "induction closure conjunction") + (checkedTerm context conjunction) + allClosures <- + first + (TypedInductivePreparationContext + "induction closure hypothesis") + (first TypedInductiveProofError + (hypothesisProof + context + closureConjunction)) + closureProofs <- + first + (TypedInductivePreparationContext + "induction closure projections") + (projectConjunctionList + context + closures + allClosures) + selectedClosure <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive closure projection is outside the source inventory")) + Right + (atNatural clauseIndex closureProofs) + specializedClosure <- + first + (TypedInductivePreparationContext + "induction closure specialization") + (eliminateWrittenForalls + context + environment + (preparedClauseVariables clause) + selectedClosure) + resultMembership <- + case closureConditionProofs of + [] -> + pure specializedClosure + _ -> do + conjunction <- + conjunctionIntroductionList + context + closureConditionProofs + first TypedInductiveProofError + (implicationEliminationProof + context + specializedClosure + conjunction) + equalityProof <- + case equalityProofs of + [only] -> + pure only + _ -> + Left + (TypedInductiveUnsupportedExpression + "inductive closure equality projection is inconsistent") + subset' <- + first + (TypedInductivePreparationContext + "induction subset target") + (checkedTerm context subset) + first + (TypedInductivePreparationContext + "induction result transport") + (transportElementMembership + context + subset' + equalityProof + resultMembership) + +transportElementMembership + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportElementMembership + context + set + equality + membership = do + (sourceElement, targetElement) <- + case scopedCoreTerm + (builtProofStatement + equality) of + CEq TySet source target -> + Right (source, target) + _ -> + Left + (TypedInductiveUnsupportedExpression + "element transport requires set equality") + predicate <- + membershipPredicate + context + set + predicateReflexivity <- + first TypedInductiveProofError + (equalityReflexivityProof + context + predicate) + propositionEquality <- + first TypedInductiveProofError + (equalityCongruenceApplicationProof + context + predicateReflexivity + equality) + reversed <- + first TypedInductiveProofError + (equalityReverseProof + context + propositionEquality) + appliedTarget <- + checkedTerm context + (CApp + (scopedCoreTerm predicate) + targetElement) + targetMembership <- + first TypedInductiveProofError + (conversionProof + context + membership + appliedTarget) + transported <- + first TypedInductiveProofError + (equalityModusPonensProof + context + reversed + targetMembership) + sourceMembership <- + checkedTerm context + (memberTerm + sourceElement + (scopedCoreTerm set)) + first TypedInductiveProofError + (conversionProof + context + transported + sourceMembership) + +predicateAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +predicateAt + resolveGlobal + inductive + environment + candidate + result = + disjunctionList + <$> clauseFormulaTerms + resolveGlobal + inductive + environment + candidate + result + +clauseFormulaTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + [CanonicalTerm (InductiveGlobal global)] +clauseFormulaTerms + resolveGlobal + inductive + environment + candidate + result = + traverse + (clauseFormulaAt + resolveGlobal + environment + candidate + result) + (NonEmpty.toList + (preparedInductiveClauses + inductive)) + +clauseFormulaAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> PreparedInductiveClause (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clauseFormulaAt + resolveGlobal + environment + candidate + result + clause = do + clauseEnvironment <- + extendVariables + environment + (preparedClauseVariables clause) + let binderCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + candidate' = + shiftCanonicalTerm binderCount 0 candidate + result' = + shiftCanonicalTerm binderCount 0 result + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + candidate') + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult clause) + pure + (closeExistentials + (length + (preparedClauseVariables + clause)) + (fromMaybe + (CEq TySet result' clauseResult) + (conjunctionList + (conditions + <> [CEq + TySet + result' + clauseResult])))) + +extendVariables + :: InductiveEnvironment + -> [VarSymbol] + -> Either + TypedInductiveError + InductiveEnvironment +extendVariables = + go [] + where + go _seen environment [] = + Right environment + go seen environment (variable : remaining) + | variable `elem` seen = + Left + (TypedInductiveDuplicateBinder + variable) + | otherwise = do + extended <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + go + (variable : seen) + extended + remaining + +membershipPredicate + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (ScopedCheckedCore (InductiveGlobal global)) +membershipPredicate context set = do + weakenedSet <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + set) + checkedTerm context + (CLam TySet + (memberTerm + (CBound 0) + (scopedCoreTerm + weakenedSet))) + +operatorPredicateAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +operatorPredicateAt + resolveGlobal + inductive + environment + candidate = do + extended <- + shiftEnvironment environment + body <- + predicateAt + resolveGlobal + inductive + extended + (shiftCanonicalTerm + 1 + 0 + candidate) + (CBound 0) + pure (CLam TySet body) + +separationSetAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +separationSetAt + resolveGlobal + inductive + environment + candidate = do + domain <- + lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + predicate <- + operatorPredicateAt + resolveGlobal + inductive + environment + candidate + pure + (apply2 + (CIntrinsic Sep) + domain + predicate) + +foundationInstance + :: ProofContext (InductiveGlobal global) + -> FoundationAxiomTag + -> [ScopedCheckedCore (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +foundationInstance context tag arguments = do + initial <- + first TypedInductiveProofError + (foundationProof context tag) + foldM + (\proof argument -> + first TypedInductiveProofError + (forallEliminationProof + context + proof + argument)) + initial + arguments + +separationForward + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +separationForward + context + domain + predicate + element + membership = do + characteristic <- + foundationInstance + context + SeparationCharacteristic + [domain, predicate, element] + first TypedInductiveProofError + (equalityModusPonensProof + context + characteristic + membership) + +separationBackward + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +separationBackward + context + domain + predicate + element + inDomain + satisfies = do + characteristic <- + foundationInstance + context + SeparationCharacteristic + [domain, predicate, element] + reversed <- + first TypedInductiveProofError + (equalityReverseProof + context + characteristic) + expectedSatisfies <- + checkedTerm context + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + satisfies' <- + first TypedInductiveProofError + (conversionProof + context + satisfies + expectedSatisfies) + conjunction <- + first TypedInductiveProofError + (conjunctionIntroductionProof + context + inDomain + satisfies') + first TypedInductiveProofError + (equalityModusPonensProof + context + reversed + conjunction) + +transportMembership + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportMembership + context + element + setEquality + membership = do + (sourceSet, targetSet) <- + case scopedCoreTerm + (builtProofStatement + setEquality) of + CEq TySet source target -> + Right (source, target) + _ -> + Left + (TypedInductiveUnsupportedExpression + "membership transport requires set equality") + weakenedElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + element) + function <- + checkedTerm context + (CLam TySet + (memberTerm + (scopedCoreTerm + weakenedElement) + (CBound 0))) + functionReflexivity <- + first TypedInductiveProofError + (equalityReflexivityProof + context + function) + propositionEquality <- + first TypedInductiveProofError + (equalityCongruenceApplicationProof + context + functionReflexivity + setEquality) + appliedSource <- + checkedTerm context + (CApp + (scopedCoreTerm function) + sourceSet) + sourceMembership <- + first TypedInductiveProofError + (conversionProof + context + membership + appliedSource) + transported <- + first TypedInductiveProofError + (equalityModusPonensProof + context + propositionEquality + sourceMembership) + targetMembership <- + checkedTerm context + (memberTerm + (scopedCoreTerm element) + targetSet) + first TypedInductiveProofError + (conversionProof + context + transported + targetMembership) + +proveSubset + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveSubset context left right proveElement = + forallIntroductionTyped + context + TySet + (\extended element -> do + left' <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + left) + right' <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + right) + memberLeft <- + checkedTerm extended + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm left')) + implicationIntroductionTyped + extended + memberLeft + (\withMember memberProof -> + proveElement + withMember + element + memberProof + >>= \result -> do + expected <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + right')) + if builtProofStatement result + == expected + then pure result + else + Left + (TypedInductiveUnsupportedExpression + "subset proof produced the wrong membership target"))) + +typedAsProofError + :: TypedInductiveError + -> KernelProofBuildError +typedAsProofError = \case + TypedInductiveProofError err -> + err + err -> + ProofSetLfpRuleFailed + (Text.pack (show err)) + +implicationIntroductionTyped + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +implicationIntroductionTyped context premise build = + first TypedInductiveProofError + (implicationIntroductionProof + context + premise + (\extended proof -> + first typedAsProofError + (build extended proof))) + +forallIntroductionTyped + :: ProofContext (InductiveGlobal global) + -> CoreType + -> ( ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +forallIntroductionTyped context binderType build = + first TypedInductiveProofError + (forallIntroductionProof + context + binderType + (\extended variable -> + first typedAsProofError + (build extended variable))) + +buildUnderVariables + :: InductiveEnvironment + -> [VarSymbol] + -> ( InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +buildUnderVariables + environment + [] + build = + build environment +buildUnderVariables + environment + (variable : remaining) + build = do + extended <- + extendEnvironment + variable + environment + buildUnderVariables + extended + remaining + build + +fixedPointTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +fixedPointTerm resolveGlobal inductive environment = do + domain <- + lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + operatorTerm + resolveGlobal + inductive + environment + pure + (CApp + (CApp + (CIntrinsic ISetLfp) + domain) + operator) + +operatorTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +operatorTerm resolveGlobal inductive parameterEnvironment = do + candidateEnvironment <- + shiftEnvironment parameterEnvironment + domain <- + lowerTerm + resolveGlobal + candidateEnvironment + (preparedInductiveDomain + inductive) + resultEnvironment <- + shiftEnvironment candidateEnvironment + clauses <- + traverse + (clausePredicateTerm + resolveGlobal + resultEnvironment) + (preparedInductiveClauses + inductive) + pure + (CLam TySet + (CApp + (CApp + (CIntrinsic Sep) + domain) + (CLam TySet + (disjunctionList + (NonEmpty.toList + clauses))))) + +clausePredicateTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> PreparedInductiveClause (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clausePredicateTerm + resolveGlobal + resultEnvironment + clause = do + clauseEnvironment <- + extendVariables + resultEnvironment + (preparedClauseVariables clause) + let variableCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + resultVariable = + CBound variableCount + candidate = + CBound (variableCount + 1) + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + candidate) + (preparedClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult + clause) + pure + (closeExistentials + (length + (preparedClauseVariables clause)) + (fromMaybe + (CEq + TySet + resultVariable + result) + (conjunctionList + (conditions + <> [CEq + TySet + resultVariable + result])))) + +directConditionTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> DirectInductiveCondition + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +directConditionTerm resolveGlobal environment candidate = \case + DirectSideCondition formula -> + lowerFormula resolveGlobal environment formula + DirectRecursiveCondition term context -> do + carrier <- + betaNormalizeCanonical + <$> lowerRecursiveCarrierContext + resolveGlobal environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier + +conditionTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> PreparedInductiveCondition (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +conditionTerm resolveGlobal environment candidate = \case + PreparedSideCondition formula -> + lowerFormula + resolveGlobal + environment + formula + PreparedDirectRecursiveCondition term context -> do + carrier <- + instantiateRecursiveCarrier environment candidate context + memberTerm + <$> lowerTerm + resolveGlobal + environment + term + <*> pure carrier + PreparedNestedRecursiveCondition term context _index _target -> do + carrier <- + instantiateRecursiveCarrier environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier + +shiftEnvironment + :: InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +shiftEnvironment + (InductiveEnvironment variables) = + pure + (InductiveEnvironment + (succ <$> variables)) + +lowerFormula + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Formula + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerFormula = + lowerFormulaWith False + +lowerFormulaWith + :: Bool + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Formula + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerFormulaWith allowQuantified resolveGlobal environment = \case + IsElementOf _location element set -> + memberTerm + <$> lowerTerm + resolveGlobal + environment + element + <*> lowerTerm + resolveGlobal + environment + set + Equals _location left right -> + CEq TySet + <$> lowerTerm resolveGlobal environment left + <*> lowerTerm resolveGlobal environment right + NotEquals _location left right -> + notTerm + <$> (CEq TySet + <$> lowerTerm resolveGlobal environment left + <*> lowerTerm resolveGlobal environment right) + IsSubsetOf _location left right -> do + extended <- + shiftEnvironment environment + left' <- + lowerTerm resolveGlobal extended left + right' <- + lowerTerm resolveGlobal extended right + pure + (CForall TySet + (CImp + (memberTerm + (CBound 0) + left') + (memberTerm + (CBound 0) + right'))) + Bottom -> + pure CFalsum + Top -> + pure (CImp CFalsum CFalsum) + Not _location proposition -> + notTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal + environment + proposition + left `Implies` right -> + CImp + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `And` right -> + conjunctionTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `Or` right -> + disjunctionTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `Iff` right -> + CEq TyProp + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + Atomic _location predicate arguments -> + lowerPredicateApplication + resolveGlobal + environment + (SymbolPredicate predicate) + arguments + Quantified quantifier scope + | allowQuantified -> do + let variables = + nubOrd + [ variable + | B variable <- toList (fromScope scope) + ] + body = instantiate TermVar scope + extended <- extendVariables environment variables + lowered <- + lowerFormulaWith + allowQuantified + resolveGlobal + extended + body + pure + (case quantifier of + Universally -> + closeForalls (length variables) lowered + Existentially -> + closeExistentials (length variables) lowered) + _ -> + Left + (TypedInductiveUnsupportedExpression + "quantified and higher-order side conditions are not supported by the typed inductive slice") + +lowerTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Term + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerTerm resolveGlobal environment = \case + TermVar variable -> + lookupEnvironment + variable + environment + EmptySet _location -> + pure (CIntrinsic Empty) + TermSymbol _location (SymbolInteger integer) [] -> + pure + (COpaqueInteger + (toInteger integer)) + TermSymbol _location symbol arguments -> + lowerApplication + resolveGlobal + environment + symbol + arguments + _ -> + Left + (TypedInductiveUnsupportedExpression + "higher-order source terms are not supported by the typed inductive slice") + +lowerApplication + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Symbol + -> [Expr] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerApplication resolveGlobal environment symbol arguments = do + arguments' <- + traverse + (lowerTerm + resolveGlobal + environment) + arguments + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerPredicateApplication + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Symbol + -> [Expr] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerPredicateApplication resolveGlobal environment symbol arguments = do + arguments' <- + traverse + (lowerTerm + resolveGlobal + environment) + arguments + case classifyExactSymbol symbol of + ExactFixedPrimitive meaning -> + maybe + (lowerApplicationTerms resolveGlobal symbol arguments') + Right + (lowerFixedEqualityPredicate meaning arguments') + _ -> + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerApplicationTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Symbol + -> [CanonicalTerm (InductiveGlobal global)] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerApplicationTerms resolveGlobal symbol arguments' = + case dispatchFixedSetTerm symbol arguments' of + LoweredFixedSetTerm term -> + pure term + RejectedFixedSetTerm -> + Left + (TypedInductiveUnsupportedExpression + ("fixed source symbol is not a supported set term: " + <> symbolText symbol)) + NotFixedSetTerm -> do + SourceGlobal reference body <- + maybe + (Left + (TypedInductiveUnsupportedExpression + ("source symbol is not typed: " + <> symbolText symbol))) + Right + (resolveGlobal symbol) + pure + (foldl' + CApp + (maybe + (CGlobal reference) + frozenCoreTerm + body) + arguments') + +memberTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +memberTerm = + apply2 (CIntrinsic Member) + +subsetTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +subsetTerm left right = + CForall TySet + (CImp + (memberTerm + (CBound 0) + (shiftCanonicalTerm + 1 + 0 + left)) + (memberTerm + (CBound 0) + (shiftCanonicalTerm + 1 + 0 + right))) + +apply2 + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +apply2 function firstArgument secondArgument = + CApp + (CApp function firstArgument) + secondArgument + +notTerm + :: CanonicalTerm global + -> CanonicalTerm global +notTerm proposition = + CImp proposition CFalsum + +conjunctionList + :: [CanonicalTerm global] + -> Maybe (CanonicalTerm global) +conjunctionList = \case + [] -> + Nothing + firstTerm : remaining -> + Just + (foldl' + conjunctionTerm + firstTerm + remaining) + +disjunctionList + :: [CanonicalTerm global] + -> CanonicalTerm global +disjunctionList = \case + [] -> + CFalsum + firstTerm : remaining -> + foldl' + disjunctionTerm + firstTerm + remaining + +impliesIfNeeded + :: Maybe (CanonicalTerm global) + -> CanonicalTerm global + -> CanonicalTerm global +impliesIfNeeded = \case + Nothing -> + id + Just premise -> + CImp premise + +closeLambdas + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeLambdas binderCount body = + foldl' + (\current _ -> + CLam TySet current) + body + [1 .. binderCount] + +closeForalls + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeForalls binderCount body = + foldl' + (\current _ -> + CForall TySet current) + body + [1 .. binderCount] + +closeExistentials + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeExistentials binderCount body = + foldl' + (\current _ -> + existentialTerm TySet current) + body + [1 .. binderCount] + +shiftCanonicalTerm + :: Natural + -> Natural + -> CanonicalTerm global + -> CanonicalTerm global +shiftCanonicalTerm amount cutoff = \case + CBound index + | index >= cutoff -> + CBound (index + amount) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (shiftCanonicalTerm + amount + cutoff + function) + (shiftCanonicalTerm + amount + cutoff + argument) + CLam binderType body -> + CLam binderType + (shiftCanonicalTerm + amount + (cutoff + 1) + body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (shiftCanonicalTerm + amount + cutoff + premise) + (shiftCanonicalTerm + amount + cutoff + conclusion) + CEq operandType left right -> + CEq operandType + (shiftCanonicalTerm + amount + cutoff + left) + (shiftCanonicalTerm + amount + cutoff + right) + CForall binderType body -> + CForall binderType + (shiftCanonicalTerm + amount + (cutoff + 1) + body) + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest + +freezeClosedTarget + :: CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +freezeClosedTarget = + first TypedInductiveCoreError + . checkCanonicalCore + (Just . inductiveGlobalType) + +symbolText :: Symbol -> Text +symbolText = \case + SymbolMixfix symbol -> + case mixfixMarker symbol of + Marker text -> + text + SymbolFun symbol -> + case lexicalItemSgPlMarker symbol of + Marker text -> + text + SymbolInteger integer -> + Text.pack (show integer) + SymbolPredicate predicate -> + case predicateObjectMarker predicate of + Marker text -> + text |