diff options
Diffstat (limited to 'source/Checking')
24 files changed, 0 insertions, 36923 deletions
diff --git a/source/Checking/Authority.hs b/source/Checking/Authority.hs deleted file mode 100644 index fb6cea0..0000000 --- a/source/Checking/Authority.hs +++ /dev/null @@ -1,612 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Compact public fact authority and exact contextual authorization. -module 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 Checking.Foundation -import 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/Checking/Backend/Problem.hs b/source/Checking/Backend/Problem.hs deleted file mode 100644 index 8d3a071..0000000 --- a/source/Checking/Backend/Problem.hs +++ /dev/null @@ -1,1301 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Complete-problem FOF/TH0 classification and construction. -module 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 Checking.Core -import 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/Checking/Backend/Tptp.hs b/source/Checking/Backend/Tptp.hs deleted file mode 100644 index e70277e..0000000 --- a/source/Checking/Backend/Tptp.hs +++ /dev/null @@ -1,1281 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Deterministic task-wide TPTP preparation for checked typed problems. -module Checking.Backend.Tptp - ( TypedFormulaOccurrence(..) - , TypedTptpNameOrigin(..) - , PreparedTypedTptpProblem - , prepareTypedTptpProblem - , preparedTypedTptpRoute - , preparedTypedTptpText - , preparedTypedTptpTextNewline - , preparedTypedTptpConjectureText - , preparedTypedTptpNameOrigins - , TypedTptpPreparationError(..) - ) where - -import Base hiding (Empty) -import Checking.Backend.Problem -import 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/Checking/Core.hs b/source/Checking/Core.hs deleted file mode 100644 index bf5bf3b..0000000 --- a/source/Checking/Core.hs +++ /dev/null @@ -1,1604 +0,0 @@ -{-# 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 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/Checking/Datatype.hs b/source/Checking/Datatype.hs deleted file mode 100644 index a47f93d..0000000 --- a/source/Checking/Datatype.hs +++ /dev/null @@ -1,670 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Checking.Datatype - ( CheckedDatatype - , DatatypeValidationError - , datatypeValidationErrorLocation - , renderDatatypeValidationError - , prepareCheckedDatatype - , checkedDatatypeHeadSymbol - , checkedDatatypeConstructorSymbols - , CheckedDatatypeClauseView(..) - , CheckedDatatypePremiseView(..) - , checkedDatatypeClauseViews - , checkedDatatypeGeneratedFacts - ) where - -import Base -import Report.Location -import Syntax.Internal -import 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/Checking/Declaration.hs b/source/Checking/Declaration.hs deleted file mode 100644 index c1ecd55..0000000 --- a/source/Checking/Declaration.hs +++ /dev/null @@ -1,6770 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - --- | Builder-confined authorization and atomic typed declaration append. -module 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 Checking.Authority -import Checking.Backend.Problem qualified as Backend -import Checking.Backend.Tptp qualified as Tptp -import Checking.Core -import Checking.Foundation -import Checking.Identity -import Checking.Kernel.Derivation -import Checking.Materialization qualified as Materialization -import Checking.Semantic -import Checking.SetConstruction -import Felix.Cache.Codec (encodeCache) -import Felix.Module -import Felix.Provers qualified as Provers -import Report.Location -import 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/Checking/Exact.hs b/source/Checking/Exact.hs deleted file mode 100644 index 47e3859..0000000 --- a/source/Checking/Exact.hs +++ /dev/null @@ -1,3936 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Direct compiler for the first exact monomorphic declaration family. -module 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 Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.SetConstruction -import Checking.Semantic -import Felix.Cache.Codec -import Felix.Module -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface (CanonicalLexicalEntry(..)) -import 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/Checking/Exact/Datatype.hs b/source/Checking/Exact/Datatype.hs deleted file mode 100644 index 61d99e5..0000000 --- a/source/Checking/Exact/Datatype.hs +++ /dev/null @@ -1,751 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Exact preparation of deterministic datatype declarations. -module 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 Checking.Authority -import Checking.Core -import Checking.Datatype qualified as Datatype -import Checking.Declaration qualified as Declaration -import Checking.Exact.Global qualified as ExactGlobal -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed -import Felix.Cache.Codec -import Felix.Module -import Felix.Meaning qualified as Meaning -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import 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/Checking/Exact/Global.hs b/source/Checking/Exact/Global.hs deleted file mode 100644 index 772a7e2..0000000 --- a/source/Checking/Exact/Global.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Exact resolution of source symbols to checked semantic globals. -module Checking.Exact.Global - ( ExactGlobalResolutionError(..) - , resolveExactSourceGlobals - ) where - -import Base -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed -import 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/Checking/Exact/Inductive.hs b/source/Checking/Exact/Inductive.hs deleted file mode 100644 index 441c773..0000000 --- a/source/Checking/Exact/Inductive.hs +++ /dev/null @@ -1,838 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Exact preparation and atomic publication of direct set inductives. -module Checking.Exact.Inductive - ( PreparedExactInductive - , preparedExactInductiveCarrierId - , preparedExactInductiveCarrierType - , preparedExactInductiveCarrierBody - , preparedExactInductiveGuardTargets - , preparedExactInductiveFacts - , prepareExactInductive - , CheckedExactInductiveAuthorization - , lowerPreparedExactInductive - , authorizeCheckedExactInductive - , ExactInductiveError(..) - , exactInductiveErrorLocation - , renderExactInductiveError - ) where - -import Base hiding (Empty) -import Checking.Authority -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Global qualified as ExactGlobal -import Checking.Exact.Vocabulary -import Checking.Foundation -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed -import Felix.Cache.Codec -import Felix.Meaning qualified as Meaning -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import 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/Checking/Exact/Proof.hs b/source/Checking/Exact/Proof.hs deleted file mode 100644 index 92ff500..0000000 --- a/source/Checking/Exact/Proof.hs +++ /dev/null @@ -1,2639 +0,0 @@ -{-# 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 Checking.Exact.Proof - ( PreparedExactProof - , preparedExactProofSyntaxId - , preparedExactProofFirstOmission - , prepareExactProof - , CheckedExactProofAuthorization - , lowerPreparedExactProof - , authorizeCheckedExactProof - , PreparedFinalPreludeFoundationClaim - , prepareFinalPreludeFoundationClaim - , CheckedFinalPreludeFoundationAuthorization - , lowerPreparedFinalPreludeFoundationClaim - , authorizeCheckedFinalPreludeFoundationClaim - , ExactProofError(..) - , exactProofErrorLocation - , renderExactProofError - ) where - -import Base -import Checking.Authority qualified as Authority -import Checking.Backend.Problem qualified as Backend -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Foundation -import Checking.Identity -import Checking.Kernel.Derivation (foundationFactDerivation) -import Checking.Kernel.Proof qualified as KernelProof -import Checking.SetConstruction -import Checking.Semantic -import Felix.Cache.Codec -import Report.Location -import 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/Checking/Exact/Vocabulary.hs b/source/Checking/Exact/Vocabulary.hs deleted file mode 100644 index 45a2844..0000000 --- a/source/Checking/Exact/Vocabulary.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Semantic classification shared by the exact source compilers. -module Checking.Exact.Vocabulary - ( FixedSemanticMeaning(..) - , fixedSemanticMeaning - , lowerFixedEqualityPredicate - , ExactSymbolClass(..) - , classifyExactSymbol - , FixedSetTermDispatch(..) - , dispatchFixedSetTerm - ) where - -import Base hiding (Empty) -import Checking.Core -import Checking.Semantic -import Syntax.Abstract qualified as Raw -import Syntax.Internal qualified as Internal -import 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/Checking/FinalPrelude.hs b/source/Checking/FinalPrelude.hs deleted file mode 100644 index acb3c7b..0000000 --- a/source/Checking/FinalPrelude.hs +++ /dev/null @@ -1,1266 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - --- | Authority-confined construction of the inert final-prelude candidate. -module Checking.FinalPrelude - ( FinalPreludeCandidate - , finalPreludeParsed - , finalPreludeSyntax - , finalPreludeSemantic - , finalPreludePrefix - , finalPreludeObjects - , PreludePublicRole(..) - , expectedFinalPreludePublicRoles - , FinalPreludeRoleTarget(..) - , finalPreludePublicRole - , FinalPreludeValidationError(..) - , FinalPreludeFailure(..) - , FinalPreludeBuildResult(..) - , buildFinalPreludeCandidate - , buildParsedFinalPreludeCandidate - , validateOmegaFactInventory - ) where - -import Base hiding (Empty) -import Checking.Authority qualified as Authority -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Exact.Proof qualified as ExactProof -import Checking.Foundation -import Checking.Identity -import Checking.SetConstruction -import Checking.Semantic -import 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 Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import 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/Checking/Foundation.hs b/source/Checking/Foundation.hs deleted file mode 100644 index 317d1b5..0000000 --- a/source/Checking/Foundation.hs +++ /dev/null @@ -1,1037 +0,0 @@ -{-# 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 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 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/Checking/Identity.hs b/source/Checking/Identity.hs deleted file mode 100644 index fe846dc..0000000 --- a/source/Checking/Identity.hs +++ /dev/null @@ -1,1023 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Content-addressed identities for checked mathematical content. -module 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 Checking.Core -import 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/Checking/Kernel/Derivation.hs b/source/Checking/Kernel/Derivation.hs deleted file mode 100644 index 65bcc25..0000000 --- a/source/Checking/Kernel/Derivation.hs +++ /dev/null @@ -1,1264 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Private in-memory proof trees and independent kernel replay. -module 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 Checking.Core -import Checking.Foundation -import Checking.Kernel.Semantics qualified as Semantics -import 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/Checking/Kernel/Proof.hs b/source/Checking/Kernel/Proof.hs deleted file mode 100644 index 5fc0d96..0000000 --- a/source/Checking/Kernel/Proof.hs +++ /dev/null @@ -1,1443 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Small proof-producing natural-deduction combinators. Every resulting tree --- is still replayed independently before it can authorize a fact. -module 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 Checking.Core -import Checking.Foundation -import Checking.Kernel.Derivation -import Checking.Kernel.Semantics qualified as Semantics -import 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/Checking/Kernel/Semantics.hs b/source/Checking/Kernel/Semantics.hs deleted file mode 100644 index 3306b09..0000000 --- a/source/Checking/Kernel/Semantics.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Checked logical inference over scoped canonical HOL terms. -module Checking.Kernel.Semantics - ( implicationElimination - , implicationIntroduction - , forallElimination - , forallIntroduction - , falsumElimination - , equalityReflexivity - , equalityCongruenceApplication - , equalityCongruenceLambda - , equalityModusPonens - , convertJudgment - , KernelSemanticsError(..) - ) where - -import Base -import 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/Checking/Kernel/SetLfp.hs b/source/Checking/Kernel/SetLfp.hs deleted file mode 100644 index e3fa175..0000000 --- a/source/Checking/Kernel/SetLfp.hs +++ /dev/null @@ -1,762 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | The four checked rules for the bounded set-valued least fixed point. -module Checking.Kernel.SetLfp - ( setLfpBound - , setLfpLeast - , setLfpFixed - , setLfpInduct - , setLfpTerm - , memberProposition - , subsetProposition - , boundedMonoProposition - , inductionClosureProposition - , SetLfpRuleError(..) - ) where - -import Base -import Checking.Core -import 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/Checking/Materialization.hs b/source/Checking/Materialization.hs deleted file mode 100644 index 6dcf1f0..0000000 --- a/source/Checking/Materialization.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# 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 Checking.Materialization - ( CandidateValidation - , candidateProofValidation - , candidateDeclarationValidation - , checkDeclarationValidationRecord - , checkCandidateValidation - , checkImportedMembership - , checkImportedOccurrence - , MaterializationError(..) - ) where - -import Base -import Checking.Authority -import Checking.Identity -import 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/Checking/Module.hs b/source/Checking/Module.hs deleted file mode 100644 index d0e1d52..0000000 --- a/source/Checking/Module.hs +++ /dev/null @@ -1,986 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - --- | Explicit inputs and sealed outputs for the typed module driver. -module 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 Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Exact.Datatype qualified as ExactDatatype -import Checking.Exact.Inductive qualified as ExactInductive -import Checking.Exact.Proof qualified as ExactProof -import Checking.FinalPrelude qualified as FinalPrelude -import Checking.Foundation -import Checking.Identity -import Checking.Semantic -import Felix.Module -import Felix.Parse -import Felix.Prelude qualified as Prelude -import Felix.Source -import Felix.Store qualified as Store -import Report.Location -import Syntax.Interface -import 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/Checking/Semantic.hs b/source/Checking/Semantic.hs deleted file mode 100644 index 7a05f39..0000000 --- a/source/Checking/Semantic.hs +++ /dev/null @@ -1,1759 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Canonical semantic declaration, prefix, interface, and validation keys. -module 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 Checking.Authority -import Checking.Core -import Checking.Identity -import Felix.Cache.Codec -import Felix.Math.Codec -import Felix.Module -import Felix.Parsed.Identity -import Felix.Source -import Syntax.Interface -import 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/Checking/SetConstruction.hs b/source/Checking/SetConstruction.hs deleted file mode 100644 index 4c4b4bc..0000000 --- a/source/Checking/SetConstruction.hs +++ /dev/null @@ -1,1191 +0,0 @@ -{-# 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 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 Checking.Core -import Checking.Foundation -import 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/Checking/Typed/Inductive.hs b/source/Checking/Typed/Inductive.hs deleted file mode 100644 index eb6c0f7..0000000 --- a/source/Checking/Typed/Inductive.hs +++ /dev/null @@ -1,4732 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Direct checked lowering of the current one-carrier set-valued inductive --- declaration. -module 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 Checking.Core -import Checking.Exact.Vocabulary -import Checking.Foundation -import Checking.Kernel.Derivation -import Checking.Kernel.Proof -import Report.Location (Location) -import 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 |