diff options
Diffstat (limited to 'source/Felix')
81 files changed, 76417 insertions, 58 deletions
diff --git a/source/Felix/Cache/Codec.hs b/source/Felix/Cache/Codec.hs index b216576..34f2694 100644 --- a/source/Felix/Cache/Codec.hs +++ b/source/Felix/Cache/Codec.hs @@ -49,7 +49,7 @@ module Felix.Cache.Codec ) where import Base hiding (Empty) -import Checking.Core +import Felix.Checking.Core import Felix.Math.Codec import Control.DeepSeq (NFData) diff --git a/source/Felix/Checking/Authority.hs b/source/Felix/Checking/Authority.hs new file mode 100644 index 0000000..58c123f --- /dev/null +++ b/source/Felix/Checking/Authority.hs @@ -0,0 +1,612 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Compact public fact authority and exact contextual authorization. +module Felix.Checking.Authority + ( EscapeKind(..) + , EscapeKinds + , emptyEscapeKinds + , singletonEscapeKind + , escapeKinds + , escapeKindsToList + , unionEscapeKinds + , AuthoritySafety + , cleanAuthoritySafety + , authoritySafety + , authoritySafetyEscapeKinds + , unionAuthoritySafety + , FactAuthority + , factAuthority + , factAuthorityTheorem + , factAuthoritySafety + , PreparedRequestDialect(..) + , PreparedRequestMode(..) + , PreparedRequestId + , preparedRequestId + , GuardedRuleSet + , guardedRuleSet + , guardedRuleTags + , KernelConstructionDescriptor(..) + , DatatypeCompilationDescriptor + , datatypeCompilationDescriptor + , CompilationDescriptor(..) + , DirectAuthorization(..) + , ValidationCertificate + , validationCertificate + , validationTarget + , validationDirectAuthorization + , ValidationCertificateError(..) + , CandidateSafety + , initialCandidateSafety + , candidateSafetyAuthority + , candidateFactAuthority + , accumulateFactSafety + , addCandidateEscape + , FactSafetyError(..) + , putEscapeKindsCache + , getEscapeKindsCache + , putAuthoritySafetyCache + , getAuthoritySafetyCache + , putFactAuthorityCache + , getFactAuthorityCache + , putPreparedRequestIdCache + , getPreparedRequestIdCache + , putDirectAuthorizationCache + , getDirectAuthorizationCache + , putValidationCertificateCache + , getValidationCertificateCache + ) where + +import Base +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Cache.Codec + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Bits ((.&.), (.|.), bit, complement) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.List (filter) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Data.Word (Word8) + + +data EscapeKind + = SourceAxiom + | Omitted + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +-- | Canonical bounded set. The bit positions are stable cache tags. +newtype EscapeKinds = + EscapeKinds Word8 + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NFData) + +emptyEscapeKinds :: EscapeKinds +emptyEscapeKinds = + EscapeKinds 0 + +singletonEscapeKind :: EscapeKind -> EscapeKinds +singletonEscapeKind = + EscapeKinds . escapeKindBit + +escapeKinds :: Foldable collection => collection EscapeKind -> EscapeKinds +escapeKinds = + foldl' + (\acc kind -> + unionEscapeKinds acc (singletonEscapeKind kind)) + emptyEscapeKinds + +escapeKindsToList :: EscapeKinds -> [EscapeKind] +escapeKindsToList kinds = + filter + (\kind -> + let EscapeKinds bits = kinds + in bits .&. escapeKindBit kind /= 0) + [SourceAxiom, Omitted] + +unionEscapeKinds :: EscapeKinds -> EscapeKinds -> EscapeKinds +unionEscapeKinds (EscapeKinds left) (EscapeKinds right) = + EscapeKinds (left .|. right) + +escapeKindBit :: EscapeKind -> Word8 +escapeKindBit = \case + SourceAxiom -> bit 0 + Omitted -> bit 1 + +allEscapeBits :: Word8 +allEscapeBits = + escapeKindBit SourceAxiom .|. escapeKindBit Omitted + + +data AuthoritySafety + = Clean + | EscapeHatchBacked !EscapeKinds + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +cleanAuthoritySafety :: AuthoritySafety +cleanAuthoritySafety = + Clean + +authoritySafety :: EscapeKinds -> AuthoritySafety +authoritySafety kinds + | kinds == emptyEscapeKinds = Clean + | otherwise = EscapeHatchBacked kinds + +authoritySafetyEscapeKinds :: AuthoritySafety -> EscapeKinds +authoritySafetyEscapeKinds = \case + Clean -> emptyEscapeKinds + EscapeHatchBacked kinds -> kinds + +unionAuthoritySafety + :: AuthoritySafety + -> AuthoritySafety + -> AuthoritySafety +unionAuthoritySafety left right = + authoritySafety + (unionEscapeKinds + (authoritySafetyEscapeKinds left) + (authoritySafetyEscapeKinds right)) + + +data FactAuthority = FactAuthority + !TheoremRef + !AuthoritySafety + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +factAuthority :: TheoremRef -> AuthoritySafety -> FactAuthority +factAuthority = + FactAuthority + +factAuthorityTheorem :: FactAuthority -> TheoremRef +factAuthorityTheorem (FactAuthority reference _) = + reference + +factAuthoritySafety :: FactAuthority -> AuthoritySafety +factAuthoritySafety (FactAuthority _ safety) = + safety + + +data PreparedRequestDialect + = PreparedRequestFof + | PreparedRequestTh0 + deriving stock (Show, Eq, Ord, Generic) + +data PreparedRequestMode + = PreparedRequestDirect + | PreparedRequestIndirect + deriving stock (Show, Eq, Ord, Generic) + +newtype PreparedRequestId = + PreparedRequestId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +preparedRequestId + :: PreparedRequestDialect + -> PreparedRequestMode + -> ByteString + -> PreparedRequestId +preparedRequestId dialect mode bytes = + PreparedRequestId + (hashCacheFields + "felix-prepared-request-v2" + [ ByteString.singleton (preparedRequestDialectTag dialect) + , ByteString.singleton (preparedRequestModeTag mode) + , bytes + ]) + +preparedRequestDialectTag :: PreparedRequestDialect -> Word8 +preparedRequestDialectTag = \case + PreparedRequestFof -> 0x00 + PreparedRequestTh0 -> 0x01 + +preparedRequestModeTag :: PreparedRequestMode -> Word8 +preparedRequestModeTag = \case + PreparedRequestDirect -> 0x00 + PreparedRequestIndirect -> 0x01 + + +-- | A nonempty canonical set of guarded kernel rules. +newtype GuardedRuleSet = + GuardedRuleSet (Set KernelRuleTag) + deriving stock (Show, Eq, Ord, Generic) + +guardedRuleSet :: NonEmpty KernelRuleTag -> GuardedRuleSet +guardedRuleSet = + GuardedRuleSet . Set.fromList . NonEmpty.toList + +guardedRuleTags :: GuardedRuleSet -> Set KernelRuleTag +guardedRuleTags (GuardedRuleSet rules) = + rules + +data KernelConstructionDescriptor + = FoundationLeaf !FoundationAxiomTag + | GuardedFoundationRules !GuardedRuleSet + | CheckedDefinitionEquation !ObjectId + | CheckedSetConstructionExtensionality !ObjectId !CacheDigest + deriving stock (Show, Eq, Ord, Generic) + +-- | Exact semantic members of one trusted datatype compilation. +data DatatypeCompilationDescriptor = + DatatypeCompilationDescriptor + !ObjectId + !(NonEmpty ObjectId) + ![TheoremRef] + deriving stock (Show, Eq, Ord, Generic) + +datatypeCompilationDescriptor + :: ObjectId + -> NonEmpty ObjectId + -> [TheoremRef] + -> DatatypeCompilationDescriptor +datatypeCompilationDescriptor = + DatatypeCompilationDescriptor + +data CompilationDescriptor + = DatatypeCompilation !DatatypeCompilationDescriptor + deriving stock (Show, Eq, Ord, Generic) + +data DirectAuthorization + = CheckedKernelConstruction !KernelConstructionDescriptor + | CheckedSourceProof ![PreparedRequestId] + | TrustedCompilation !CompilationDescriptor + | SourceAxiomAuthorization + | OmittedAuthorization + deriving stock (Show, Eq, Ord, Generic) + + +data ValidationCertificate = ValidationCertificate + !FactAuthority + !DirectAuthorization + deriving stock (Show, Eq, Ord, Generic) + +data ValidationCertificateError + = SourceAxiomSafetyMismatch !AuthoritySafety + | OmittedSafetyMissing !AuthoritySafety + deriving stock (Show, Eq) + +validationCertificate + :: FactAuthority + -> DirectAuthorization + -> Either ValidationCertificateError ValidationCertificate +validationCertificate target direct = do + case direct of + SourceAxiomAuthorization -> + unless + (factAuthoritySafety target + == authoritySafety + (singletonEscapeKind SourceAxiom)) + (Left + (SourceAxiomSafetyMismatch + (factAuthoritySafety target))) + OmittedAuthorization -> + unless + (Omitted + `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (factAuthoritySafety target))) + (Left + (OmittedSafetyMissing + (factAuthoritySafety target))) + CheckedKernelConstruction{} -> pure () + CheckedSourceProof{} -> pure () + TrustedCompilation{} -> pure () + pure (ValidationCertificate target direct) + +validationTarget :: ValidationCertificate -> FactAuthority +validationTarget (ValidationCertificate target _) = + target + +validationDirectAuthorization + :: ValidationCertificate + -> DirectAuthorization +validationDirectAuthorization (ValidationCertificate _ direct) = + direct + + +newtype CandidateSafety = + CandidateSafety AuthoritySafety + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NFData) + +initialCandidateSafety :: CandidateSafety +initialCandidateSafety = + CandidateSafety Clean + +candidateSafetyAuthority :: CandidateSafety -> AuthoritySafety +candidateSafetyAuthority (CandidateSafety safety) = + safety + +-- | Freeze the final safety of one completed candidate into public authority. +-- +-- The trusted completion boundary uses this projection for both the inert +-- validation certificate and its runtime pending authorization. +candidateFactAuthority + :: TheoremRef + -> CandidateSafety + -> FactAuthority +candidateFactAuthority reference (CandidateSafety safety) = + FactAuthority reference safety + +data FactSafetyError + = FactSafetyTheoremMismatch !TheoremRef !TheoremRef + deriving stock (Show, Eq) + +-- | Check theorem agreement and accumulate already-authorized public safety. +-- +-- This operation does not authorize a freely constructed 'FactAuthority'. +-- Callers may use it only after checking opaque global, imported, or staged +-- builder authorization at the boundary that owns that authority. +accumulateFactSafety + :: TheoremRef + -> FactAuthority + -> CandidateSafety + -> Either FactSafetyError CandidateSafety +accumulateFactSafety expected supplied (CandidateSafety current) = do + unless + (factAuthorityTheorem supplied == expected) + (Left + (FactSafetyTheoremMismatch + expected + (factAuthorityTheorem supplied))) + pure + (CandidateSafety + (unionAuthoritySafety + current + (factAuthoritySafety supplied))) + +addCandidateEscape + :: EscapeKind + -> CandidateSafety + -> CandidateSafety +addCandidateEscape kind (CandidateSafety current) = + CandidateSafety + (unionAuthoritySafety + current + (authoritySafety (singletonEscapeKind kind))) + + +putEscapeKindsCache :: EscapeKinds -> CachePut +putEscapeKindsCache (EscapeKinds bits) = + putCacheTag bits + +getEscapeKindsCache :: CacheGet EscapeKinds +getEscapeKindsCache = do + bits <- getCacheTag + unless + (bits .&. complement allEscapeBits == 0) + (fail "unknown cache escape-kind bit") + pure (EscapeKinds bits) + +putAuthoritySafetyCache :: AuthoritySafety -> CachePut +putAuthoritySafetyCache = \case + Clean -> + putCacheTag 0x00 + EscapeHatchBacked kinds -> do + putCacheTag 0x01 + putEscapeKindsCache kinds + +getAuthoritySafetyCache :: CacheGet AuthoritySafety +getAuthoritySafetyCache = + getCacheTag >>= \case + 0x00 -> + pure Clean + 0x01 -> do + kinds <- getEscapeKindsCache + when + (kinds == emptyEscapeKinds) + (fail "empty escape-hatch-backed safety") + pure (EscapeHatchBacked kinds) + tag -> + fail ("unknown cache authority-safety tag " <> show tag) + +putFactAuthorityCache :: FactAuthority -> CachePut +putFactAuthorityCache (FactAuthority reference safety) = do + putTheoremRefCache reference + putAuthoritySafetyCache safety + +getFactAuthorityCache :: CacheGet FactAuthority +getFactAuthorityCache = + FactAuthority + <$> getTheoremRefCache + <*> getAuthoritySafetyCache + +putPreparedRequestIdCache :: PreparedRequestId -> CachePut +putPreparedRequestIdCache (PreparedRequestId digest) = + putCacheDigest digest + +getPreparedRequestIdCache :: CacheGet PreparedRequestId +getPreparedRequestIdCache = + PreparedRequestId <$> getCacheDigest + +putDirectAuthorizationCache :: DirectAuthorization -> CachePut +putDirectAuthorizationCache = \case + CheckedKernelConstruction descriptor -> do + putCacheTag 0x00 + putKernelDescriptor descriptor + CheckedSourceProof requests -> do + putCacheTag 0x01 + putCacheList putPreparedRequestIdCache requests + TrustedCompilation descriptor -> do + putCacheTag 0x02 + putCompilationDescriptor descriptor + SourceAxiomAuthorization -> + putCacheTag 0x03 + OmittedAuthorization -> + putCacheTag 0x04 + +getDirectAuthorizationCache :: CacheGet DirectAuthorization +getDirectAuthorizationCache = + getCacheTag >>= \case + 0x00 -> + CheckedKernelConstruction <$> getKernelDescriptor + 0x01 -> + CheckedSourceProof + <$> getCacheList getPreparedRequestIdCache + 0x02 -> + TrustedCompilation <$> getCompilationDescriptor + 0x03 -> + pure SourceAxiomAuthorization + 0x04 -> + pure OmittedAuthorization + tag -> + fail ("unknown cache direct-authorization tag " <> show tag) + +putValidationCertificateCache :: ValidationCertificate -> CachePut +putValidationCertificateCache + (ValidationCertificate target direct) = do + putFactAuthorityCache target + putDirectAuthorizationCache direct + +getValidationCertificateCache :: CacheGet ValidationCertificate +getValidationCertificateCache = do + target <- getFactAuthorityCache + direct <- getDirectAuthorizationCache + case validationCertificate target direct of + Left err -> + fail ("invalid cache validation certificate: " <> show err) + Right certificate -> + pure certificate + + +putKernelDescriptor :: KernelConstructionDescriptor -> CachePut +putKernelDescriptor = \case + FoundationLeaf tag -> do + putCacheTag 0x00 + putFoundationTag tag + GuardedFoundationRules rules -> do + putCacheTag 0x01 + putCacheList putRuleTag + (Set.toAscList (guardedRuleTags rules)) + CheckedDefinitionEquation identity -> do + putCacheTag 0x02 + putObjectIdCache identity + CheckedSetConstructionExtensionality identity construction -> do + putCacheTag 0x03 + putObjectIdCache identity + putCacheDigest construction + +getKernelDescriptor :: CacheGet KernelConstructionDescriptor +getKernelDescriptor = + getCacheTag >>= \case + 0x00 -> FoundationLeaf <$> getFoundationTag + 0x01 -> do + tags <- getCacheList getRuleTag + rules <- + maybe + (fail "cache guarded-rule set is empty") + pure + (NonEmpty.nonEmpty tags) + unless (strictlyIncreasing tags) + (fail "cache guarded-rule tags are not in canonical order") + pure (GuardedFoundationRules (guardedRuleSet rules)) + 0x02 -> CheckedDefinitionEquation <$> getObjectIdCache + 0x03 -> + CheckedSetConstructionExtensionality + <$> getObjectIdCache + <*> getCacheDigest + tag -> + fail ("unknown cache kernel-construction tag " <> show tag) + +putCompilationDescriptor :: CompilationDescriptor -> CachePut +putCompilationDescriptor + (DatatypeCompilation + (DatatypeCompilationDescriptor + carrier constructors facts)) = do + putCacheTag 0x00 + putObjectIdCache carrier + putCacheList putObjectIdCache (NonEmpty.toList constructors) + putCacheList putTheoremRefCache facts + +getCompilationDescriptor :: CacheGet CompilationDescriptor +getCompilationDescriptor = + getCacheTag >>= \case + 0x00 -> do + carrier <- getObjectIdCache + rawConstructors <- + getCacheList getObjectIdCache + constructors <- + maybe + (fail "cache datatype compilation has no constructors") + pure + (NonEmpty.nonEmpty rawConstructors) + facts <- getCacheList getTheoremRefCache + pure + (DatatypeCompilation + (DatatypeCompilationDescriptor + carrier constructors facts)) + tag -> + fail ("unknown cache compilation tag " <> show tag) + +putFoundationTag :: FoundationAxiomTag -> CachePut +putFoundationTag = + putCacheTag . \case + EmptyCharacteristic -> 0x00 + PairSetCharacteristic -> 0x01 + FamilyUnionCharacteristic -> 0x02 + PowerSetCharacteristic -> 0x03 + SeparationCharacteristic -> 0x04 + ReplacementCharacteristic -> 0x05 + SetChooseWitness -> 0x06 + SetExtensionality -> 0x07 + SetInduction -> 0x08 + PropositionalExtensionality -> 0x09 + DoubleNegationElim -> 0x0a + UnivOfContains -> 0x0b + UnivOfTransitive -> 0x0c + UnivOfFamilyUnionClosed -> 0x0d + UnivOfPowerSetClosed -> 0x0e + UnivOfReplacementClosed -> 0x0f + UnivOfMinimal -> 0x10 + +getFoundationTag :: CacheGet FoundationAxiomTag +getFoundationTag = + getCacheTag >>= \case + 0x00 -> pure EmptyCharacteristic + 0x01 -> pure PairSetCharacteristic + 0x02 -> pure FamilyUnionCharacteristic + 0x03 -> pure PowerSetCharacteristic + 0x04 -> pure SeparationCharacteristic + 0x05 -> pure ReplacementCharacteristic + 0x06 -> pure SetChooseWitness + 0x07 -> pure SetExtensionality + 0x08 -> pure SetInduction + 0x09 -> pure PropositionalExtensionality + 0x0a -> pure DoubleNegationElim + 0x0b -> pure UnivOfContains + 0x0c -> pure UnivOfTransitive + 0x0d -> pure UnivOfFamilyUnionClosed + 0x0e -> pure UnivOfPowerSetClosed + 0x0f -> pure UnivOfReplacementClosed + 0x10 -> pure UnivOfMinimal + tag -> + fail ("unknown cache foundation-axiom tag " <> show tag) + +putRuleTag :: KernelRuleTag -> CachePut +putRuleTag = + putCacheTag . \case + SetLfpBound -> 0x00 + SetLfpLeast -> 0x01 + SetLfpFixed -> 0x02 + SetLfpInduct -> 0x03 + +getRuleTag :: CacheGet KernelRuleTag +getRuleTag = + getCacheTag >>= \case + 0x00 -> pure SetLfpBound + 0x01 -> pure SetLfpLeast + 0x02 -> pure SetLfpFixed + 0x03 -> pure SetLfpInduct + tag -> + fail ("unknown cache kernel-rule tag " <> show tag) + +strictlyIncreasing :: Ord value => [value] -> Bool +strictlyIncreasing values = + and (zipWith (<) values (drop 1 values)) diff --git a/source/Felix/Checking/Backend/Problem.hs b/source/Felix/Checking/Backend/Problem.hs new file mode 100644 index 0000000..0390020 --- /dev/null +++ b/source/Felix/Checking/Backend/Problem.hs @@ -0,0 +1,1301 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Complete-problem FOF/TH0 classification and construction. +module Felix.Checking.Backend.Problem + ( SupportedProposition + , supportedProposition + , projectSupportedProposition + , supportedPropositionSupport + , supportedPropositionTerm + , weakenClosedSupportedProposition + , SupportedPropositionError(..) + , SupportedPropositionProjectionError(..) + , CheckedFofProjection + , checkedFofProjectionProposition + , FofCapability(..) + , BackendFofExclusion(..) + , BackendClassificationError(..) + , classifySupportedProposition + , TypedBackendFact + , typedBackendFact + , typedBackendFactReference + , typedBackendFactProposition + , typedBackendFactCapability + , LocalPremiseOrdinal + , localPremiseOrdinal + , localPremiseOrdinalValue + , TypedLocalPremise + , typedLocalPremise + , typedLocalPremiseOrdinal + , typedLocalPremiseOrigin + , typedLocalPremiseProposition + , typedLocalPremiseCapability + , TypedFoundationAuxiliaryInput + , typedFoundationAuxiliaryInput + , TypedProblemAuxiliary + , typedProblemAuxiliaryOrdinal + , typedProblemAuxiliaryTag + , typedProblemAuxiliaryProposition + , typedProblemAuxiliaryCapability + , LocalPremisePolicy(..) + , HigherOrderJustificationPolicy(..) + , selectTypedLocalPremises + , TypedProblemRoute(..) + , TypedProblem + , planTypedProblem + , typedProblemRoute + , typedProblemClaim + , typedProblemGlobalPremises + , typedProblemLocalPremises + , typedProblemAuxiliaries + , typedProblemGlobalTypes + , typedProblemLocalTypes + , TypedProblemError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Control.Monad (foldM, unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +-- | A proposition under its exact nearest-first ambient-local support. +data SupportedProposition local global = + SupportedProposition + !(Vector (local, CoreType)) + !(ScopedCheckedCore global) + deriving stock (Eq) + +data SupportedPropositionError local + = SupportedPropositionIsNotProposition !CoreType + | SupportedPropositionContextMismatch + ![CoreType] + ![CoreType] + | DuplicateSupportedLocal !local + | UnusedSupportedLocal !local + deriving stock (Show, Eq) + +data SupportedPropositionProjectionError local + = SupportedProjectionContextMismatch + ![CoreType] + ![CoreType] + | SupportedProjectionDuplicateLocal !local + | SupportedProjectionIndexMissing !Natural + | SupportedProjectionCoreCheckFailed !CoreCheckError + | SupportedProjectionValidationFailed + !(SupportedPropositionError local) + deriving stock (Show, Eq) + +supportedProposition + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore global + -> Either + (SupportedPropositionError local) + (SupportedProposition local global) +supportedProposition support statement = do + unless + (scopedCoreType statement == TyProp) + (Left + (SupportedPropositionIsNotProposition + (scopedCoreType statement))) + let expectedContext = + snd <$> Vector.toList support + actualContext = + scopedCoreContext statement + unless + (actualContext == expectedContext) + (Left + (SupportedPropositionContextMismatch + expectedContext + actualContext)) + void + (foldM + (\seen (local, _coreType) -> + if local `Set.member` seen + then + Left + (DuplicateSupportedLocal local) + else + Right (Set.insert local seen)) + Set.empty + support) + case + List.find + (\(ordinal, _entry) -> + fromIntegral ordinal + `Set.notMember` + ambientIndices + (scopedCoreTerm statement)) + (Vector.toList + (Vector.indexed support)) of + Just (_ordinal, (local, _coreType)) -> + Left (UnusedSupportedLocal local) + Nothing -> + pure () + pure + (SupportedProposition + support + statement) + +-- | Retain exactly the ambient locals used by a checked proposition and +-- remap its indices to that dense nearest-first support. +projectSupportedProposition + :: Ord local + => (global -> Maybe CoreType) + -> Vector (local, CoreType) + -> ScopedCheckedCore global + -> Either + (SupportedPropositionProjectionError local) + (SupportedProposition local global) +projectSupportedProposition globalType available statement = do + let expectedContext = snd <$> Vector.toList available + actualContext = scopedCoreContext statement + unless (expectedContext == actualContext) + (Left + (SupportedProjectionContextMismatch + expectedContext + actualContext)) + void + (foldM + (\seen (local, _coreType) -> + if local `Set.member` seen + then Left (SupportedProjectionDuplicateLocal local) + else Right (Set.insert local seen)) + Set.empty + available) + let used = + Set.toAscList + (ambientIndices + (scopedCoreTerm statement)) + selected <- traverse (lookupNatural available) used + let remapping = + Map.fromAscList + (zip used [0 ..]) + remapped <- remapAmbientIndices remapping 0 + (scopedCoreTerm statement) + checked <- + first SupportedProjectionCoreCheckFailed + (checkScopedCanonicalCore + globalType + (snd <$> selected) + remapped) + first SupportedProjectionValidationFailed + (supportedProposition + (Vector.fromList selected) + checked) + where + lookupNatural values index = + maybe + (Left (SupportedProjectionIndexMissing index)) + Right + (go index (Vector.toList values)) + + go _index [] = + Nothing + go 0 (value : _rest) = + Just value + go index (_value : rest) = + go (index - 1) rest + + remapAmbientIndices remapping depth = \case + CBound index + | index < depth -> + Right (CBound index) + | otherwise -> + maybe + (Left + (SupportedProjectionIndexMissing + (index - depth))) + (Right . CBound . (+ depth)) + (Map.lookup (index - depth) remapping) + CGlobal global -> + Right (CGlobal global) + CIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + COpaqueInteger integer -> + Right (COpaqueInteger integer) + CApp function argument -> + CApp + <$> remapAmbientIndices remapping depth function + <*> remapAmbientIndices remapping depth argument + CLam binderType body -> + CLam binderType + <$> remapAmbientIndices remapping (depth + 1) body + CFalsum -> + Right CFalsum + CImp premise conclusion -> + CImp + <$> remapAmbientIndices remapping depth premise + <*> remapAmbientIndices remapping depth conclusion + CEq operandType left right -> + CEq operandType + <$> remapAmbientIndices remapping depth left + <*> remapAmbientIndices remapping depth right + CForall binderType body -> + CForall binderType + <$> remapAmbientIndices remapping (depth + 1) body + +ambientIndices + :: CanonicalTerm global + -> Set Natural +ambientIndices = + go 0 + where + go depth = \case + CBound index + | index < depth -> + mempty + | otherwise -> + Set.singleton (index - depth) + CGlobal{} -> + mempty + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + go depth function <> go depth argument + CLam _binderType body -> + go (depth + 1) body + CFalsum -> + mempty + CImp premise conclusion -> + go depth premise <> go depth conclusion + CEq _operandType left right -> + go depth left <> go depth right + CForall _binderType body -> + go (depth + 1) body + +supportedPropositionSupport + :: SupportedProposition local global + -> Vector (local, CoreType) +supportedPropositionSupport + (SupportedProposition support _statement) = + support + +supportedPropositionTerm + :: SupportedProposition local global + -> CanonicalTerm global +supportedPropositionTerm + (SupportedProposition _support statement) = + scopedCoreTerm statement + +weakenClosedSupportedProposition + :: SupportedProposition Void global + -> SupportedProposition local global +weakenClosedSupportedProposition + (SupportedProposition support statement) = + SupportedProposition + (fmap + (\(local, coreType) -> + (absurd local, coreType)) + support) + statement + + +newtype CheckedFofProjection local global = + CheckedFofProjection + (SupportedProposition local global) + deriving stock (Eq) + +checkedFofProjectionProposition + :: CheckedFofProjection local global + -> SupportedProposition local global +checkedFofProjectionProposition + (CheckedFofProjection proposition) = + proposition + +data FofCapability projection + = FofProjectable !projection + | RequiresTh0 !(NonEmpty BackendFofExclusion) + deriving stock (Eq) + +data BackendFofExclusion + = StructuralFofExclusion !FofExclusion + | HigherOrderGlobalType !CoreType + | HigherOrderAmbientLocal !CoreType + deriving stock (Show, Eq, Ord) + +data BackendClassificationError global + = UnknownBackendGlobal !global + | BackendFofProjectionInvariantFailed + deriving stock (Show, Eq) + +classifySupportedProposition + :: Ord global + => (global -> Maybe CoreType) + -> SupportedProposition local global + -> Either + (BackendClassificationError global) + (FofCapability + (CheckedFofProjection local global)) +classifySupportedProposition globalType proposition = do + globalExclusions <- + foldM + collectGlobal + Set.empty + (Set.toAscList + (canonicalGlobals + (supportedPropositionTerm proposition))) + let structuralExclusions = + case classifyScopedStructure proposition of + FoundationFofProjectable -> + Set.empty + FoundationRequiresTh0 structural -> + Set.fromList + (StructuralFofExclusion + <$> toList structural) + localExclusions = + Set.fromList + [ HigherOrderAmbientLocal coreType + | (_local, coreType) <- + Vector.toList + (supportedPropositionSupport + proposition) + , coreType /= TySet + ] + exclusions = + structuralExclusions + <> globalExclusions + <> localExclusions + case Set.toAscList exclusions of + [] -> + if isFirstOrderProposition + globalType + proposition + then + Right + (FofProjectable + (CheckedFofProjection + proposition)) + else + Left BackendFofProjectionInvariantFailed + firstExclusion : remainingExclusions -> + Right + (RequiresTh0 + (firstExclusion + :| remainingExclusions)) + where + collectGlobal exclusions global = + case globalType global of + Nothing -> + Left (UnknownBackendGlobal global) + Just coreType -> + Right + (if isFirstOrderGlobalType coreType + then exclusions + else + Set.insert + (HigherOrderGlobalType + coreType) + exclusions) + +classifyScopedStructure + :: SupportedProposition local global + -> FoundationBackendClass +classifyScopedStructure = + classifyCanonicalFofStructure + . supportedPropositionTerm + +isFirstOrderGlobalType :: CoreType -> Bool +isFirstOrderGlobalType = + go + where + go = \case + TySet -> + True + TyProp -> + True + TyArrow TySet result -> + go result + TyArrow _argument _result -> + False + +-- The structural and type exclusions make this projection total. This final +-- walk catches an accidentally unsaturated first-order head. +isFirstOrderProposition + :: (global -> Maybe CoreType) + -> SupportedProposition local global + -> Bool +isFirstOrderProposition globalType proposition = + isFormula initialContext + (supportedPropositionTerm proposition) + where + initialContext = + snd + <$> Vector.toList + (supportedPropositionSupport + proposition) + + isFormula context = \case + CFalsum -> + True + CImp premise conclusion -> + isFormula context premise + && isFormula context conclusion + CEq TySet left right -> + isTerm context left + && isTerm context right + CEq TyProp left right -> + isFormula context left + && isFormula context right + CForall TySet body -> + isFormula (TySet : context) body + application -> + case applicationHead application of + (CGlobal global, arguments) -> + maybe + False + (\coreType -> + applicationResult + coreType + arguments + == Just TyProp + && all + (isTerm context) + arguments) + (globalType global) + (CIntrinsic intrinsic, arguments) -> + applicationResult + (coreIntrinsicType intrinsic) + arguments + == Just TyProp + && all + (isTerm context) + arguments + _ -> + False + + isTerm context = \case + CBound index -> + contextAt index context + == Just TySet + CGlobal global -> + globalType global == Just TySet + CIntrinsic intrinsic -> + coreIntrinsicType intrinsic == TySet + COpaqueInteger{} -> + True + application -> + case applicationHead application of + (CGlobal global, arguments) -> + maybe + False + (\coreType -> + applicationResult + coreType + arguments + == Just TySet + && all + (isTerm context) + arguments) + (globalType global) + (CIntrinsic intrinsic, arguments) -> + applicationResult + (coreIntrinsicType intrinsic) + arguments + == Just TySet + && all + (isTerm context) + arguments + _ -> + False + +applicationHead + :: CanonicalTerm global + -> (CanonicalTerm global, [CanonicalTerm global]) +applicationHead = + go [] + where + go arguments = \case + CApp function argument -> + go (argument : arguments) function + headTerm -> + (headTerm, arguments) + +applicationResult + :: CoreType + -> [CanonicalTerm global] + -> Maybe CoreType +applicationResult = + foldM + (\coreType _argument -> + case coreType of + TyArrow TySet result -> + Just result + _ -> + Nothing) + +contextAt :: Natural -> [value] -> Maybe value +contextAt _index [] = + Nothing +contextAt 0 (value : _remaining) = + Just value +contextAt index (_value : remaining) = + contextAt (index - 1) remaining + +canonicalGlobals + :: Ord global + => CanonicalTerm global + -> Set global +canonicalGlobals = \case + CBound{} -> + mempty + CGlobal global -> + Set.singleton global + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalGlobals function + <> canonicalGlobals argument + CLam _binderType body -> + canonicalGlobals body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalGlobals premise + <> canonicalGlobals conclusion + CEq _operandType left right -> + canonicalGlobals left + <> canonicalGlobals right + CForall _binderType body -> + canonicalGlobals body + + +data TypedBackendFact ref global = + TypedBackendFact + !ref + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + deriving stock (Eq) + +typedBackendFact + :: ref + -> SupportedProposition Void global + -> FofCapability + (CheckedFofProjection Void global) + -> TypedBackendFact ref global +typedBackendFact = + TypedBackendFact + +typedBackendFactReference + :: TypedBackendFact ref global + -> ref +typedBackendFactReference + (TypedBackendFact + reference + _proposition + _capability) = + reference + +typedBackendFactProposition + :: TypedBackendFact ref global + -> SupportedProposition Void global +typedBackendFactProposition + (TypedBackendFact + _reference + proposition + _capability) = + proposition + +typedBackendFactCapability + :: TypedBackendFact ref global + -> FofCapability + (CheckedFofProjection Void global) +typedBackendFactCapability + (TypedBackendFact + _reference + _proposition + capability) = + capability + + +newtype LocalPremiseOrdinal = + LocalPremiseOrdinal Natural + deriving stock (Show, Eq, Ord) + +localPremiseOrdinal :: Natural -> LocalPremiseOrdinal +localPremiseOrdinal = + LocalPremiseOrdinal + +localPremiseOrdinalValue + :: LocalPremiseOrdinal + -> Natural +localPremiseOrdinalValue + (LocalPremiseOrdinal ordinal) = + ordinal + +data TypedLocalPremise local origin global = + TypedLocalPremise + !LocalPremiseOrdinal + !origin + !(SupportedProposition local global) + !(FofCapability + (CheckedFofProjection local global)) + deriving stock (Eq) + +typedLocalPremise + :: Ord global + => (global -> Maybe CoreType) + -> LocalPremiseOrdinal + -> origin + -> SupportedProposition local global + -> Either + (BackendClassificationError global) + (TypedLocalPremise local origin global) +typedLocalPremise globalType ordinal premiseOrigin proposition = + TypedLocalPremise + ordinal + premiseOrigin + proposition + <$> classifySupportedProposition + globalType + proposition + +typedLocalPremiseOrdinal + :: TypedLocalPremise local origin global + -> LocalPremiseOrdinal +typedLocalPremiseOrdinal + (TypedLocalPremise + ordinal + _origin + _proposition + _capability) = + ordinal + +typedLocalPremiseOrigin + :: TypedLocalPremise local origin global + -> origin +typedLocalPremiseOrigin + (TypedLocalPremise + _ordinal + premiseOrigin + _proposition + _capability) = + premiseOrigin + +typedLocalPremiseProposition + :: TypedLocalPremise local origin global + -> SupportedProposition local global +typedLocalPremiseProposition + (TypedLocalPremise + _ordinal + _origin + proposition + _capability) = + proposition + +typedLocalPremiseCapability + :: TypedLocalPremise local origin global + -> FofCapability + (CheckedFofProjection local global) +typedLocalPremiseCapability + (TypedLocalPremise + _ordinal + _origin + _proposition + capability) = + capability + + +data TypedFoundationAuxiliaryInput global = + TypedFoundationAuxiliaryInput + !FoundationAxiomTag + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + +typedFoundationAuxiliaryInput + :: CheckedFoundation + -> FoundationAxiomTag + -> TypedFoundationAuxiliaryInput global +typedFoundationAuxiliaryInput foundation tag = + TypedFoundationAuxiliaryInput + tag + proposition + capability + where + proposition = + SupportedProposition + Vector.empty + (embedClosedCore + [] + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag))) + capability = + case foundationAxiomBackendClass + foundation + tag of + FoundationFofProjectable -> + FofProjectable + (CheckedFofProjection + proposition) + FoundationRequiresTh0 exclusions -> + RequiresTh0 + (StructuralFofExclusion + <$> exclusions) + +data TypedProblemAuxiliary global = + TypedProblemAuxiliary + !Natural + !FoundationAxiomTag + !(SupportedProposition Void global) + !(FofCapability + (CheckedFofProjection Void global)) + deriving stock (Eq) + +typedProblemAuxiliaryOrdinal + :: TypedProblemAuxiliary global + -> Natural +typedProblemAuxiliaryOrdinal + (TypedProblemAuxiliary + ordinal + _tag + _proposition + _capability) = + ordinal + +typedProblemAuxiliaryTag + :: TypedProblemAuxiliary global + -> FoundationAxiomTag +typedProblemAuxiliaryTag + (TypedProblemAuxiliary + _ordinal + tag + _proposition + _capability) = + tag + +typedProblemAuxiliaryProposition + :: TypedProblemAuxiliary global + -> SupportedProposition Void global +typedProblemAuxiliaryProposition + (TypedProblemAuxiliary + _ordinal + _tag + proposition + _capability) = + proposition + +typedProblemAuxiliaryCapability + :: TypedProblemAuxiliary global + -> FofCapability + (CheckedFofProjection Void global) +typedProblemAuxiliaryCapability + (TypedProblemAuxiliary + _ordinal + _tag + _proposition + capability) = + capability + + +-- | Source justification policy for premise selection. Higher-order routing +-- is validated separately after the complete selected problem is known. +data LocalPremisePolicy + = FirstOrderLocals + | CompleteLocals + deriving stock (Show, Eq) + +-- | Whether selected higher-order components must be justified by one of the +-- two approved inline construction forms. Premise selection has already +-- happened when this policy is applied. +data HigherOrderJustificationPolicy + = ImplicitConstructionJustification + | ExplicitHigherOrderJustification + deriving stock (Show, Eq) + +selectTypedLocalPremises + :: LocalPremisePolicy + -> [TypedLocalPremise local origin global] + -> Vector (TypedLocalPremise local origin global) +selectTypedLocalPremises selection availableLocals = + Vector.fromList + (List.sortOn + typedLocalPremiseOrdinal + (case selection of + FirstOrderLocals -> + List.filter + (isFofCapability + . typedLocalPremiseCapability) + availableLocals + CompleteLocals -> + availableLocals)) + +data ImplicitHigherOrderConstruction + = ImplicitSeparation + | ImplicitFunctionalReplacement + deriving stock (Show, Eq, Ord) + +data TypedProblemRoute + = RouteFof + | RouteTh0 + deriving stock (Show, Eq) + +data TypedProblem ref local origin global = + TypedProblem + !TypedProblemRoute + !(SupportedProposition local global) + !(Vector (TypedBackendFact ref global)) + !(Vector (TypedLocalPremise local origin global)) + !(Vector (TypedProblemAuxiliary global)) + !(Map global CoreType) + !(Map local CoreType) + deriving stock (Eq) + +data TypedProblemError local global + = TypedProblemClaimClassificationFailed + !(BackendClassificationError global) + | TypedProblemExplicitHigherOrderJustificationRequired + !(NonEmpty BackendFofExclusion) + | TypedProblemDuplicateLocalPremiseOrdinal + !LocalPremiseOrdinal + | TypedProblemLocalTypeMismatch + !local + !CoreType + !CoreType + deriving stock (Show, Eq) + +planTypedProblem + :: (Ord local, Ord global) + => (global -> Maybe CoreType) + -> Vector (TypedBackendFact ref global) + -> SupportedProposition local global + -> [TypedLocalPremise local origin global] + -> [TypedFoundationAuxiliaryInput global] + -> LocalPremisePolicy + -> HigherOrderJustificationPolicy + -> Either + (TypedProblemError local global) + (TypedProblem ref local origin global) +planTypedProblem + globalType + selectedFacts + claim + availableLocals + auxiliaries + localPolicy + higherOrderPolicy = do + validateLocalPremiseOrdinals + availableLocals + claimCapability <- + first + TypedProblemClaimClassificationFailed + (classifySupportedProposition + globalType + claim) + let selectedLocals = + selectTypedLocalPremises + localPolicy + availableLocals + let preparedAuxiliaries = + zipWith + prepareAuxiliary + [0..] + auxiliaries + case higherOrderPolicy of + ImplicitConstructionJustification -> + validateImplicitHigherOrderAdmission + claim + claimCapability + selectedFacts + selectedLocals + preparedAuxiliaries + ExplicitHigherOrderJustification -> + pure () + let selectedFofCapabilities = + isFofCapability claimCapability + : (isFofCapability + . typedBackendFactCapability + <$> Vector.toList selectedFacts) + <> (isFofCapability + . typedLocalPremiseCapability + <$> Vector.toList selectedLocals) + <> (isFofCapability + . typedProblemAuxiliaryCapability + <$> preparedAuxiliaries) + route = + if and selectedFofCapabilities + then RouteFof + else RouteTh0 + globalTypes <- + collectProblemGlobals + globalType + claim + selectedFacts + selectedLocals + preparedAuxiliaries + localTypes <- + collectProblemLocals + claim + selectedLocals + pure + (TypedProblem + route + claim + selectedFacts + selectedLocals + (Vector.fromList preparedAuxiliaries) + globalTypes + localTypes) + where + prepareAuxiliary + ordinal + (TypedFoundationAuxiliaryInput + tag + proposition + capability) = + TypedProblemAuxiliary + ordinal + tag + proposition + capability + +-- | Implicit automation admits higher-order routing only for a checked +-- proposition that itself contains one of the two approved set constructions. +-- This classification selects no premise and grants no authority. +implicitConstructionAdmission + :: SupportedProposition local global + -> FofCapability projection + -> Maybe (Set ImplicitHigherOrderConstruction) +implicitConstructionAdmission proposition capability = + case capability of + FofProjectable{} -> + Nothing + RequiresTh0 exclusions + | Set.null constructions -> + Nothing + | all (admittedExclusion constructions) exclusions -> + Just constructions + | otherwise -> + Nothing + where + dependencies = + foundationAxiomDependencies + (supportedPropositionTerm proposition) + constructions = + Set.fromList + ( [ ImplicitSeparation + | SeparationCharacteristic `Set.member` dependencies + ] + <> [ ImplicitFunctionalReplacement + | ReplacementCharacteristic `Set.member` dependencies + ] + ) + + admittedExclusion allowed = \case + StructuralFofExclusion HigherOrderLambda -> + True + StructuralFofExclusion (HigherOrderIntrinsic Sep) -> + ImplicitSeparation `Set.member` allowed + StructuralFofExclusion (HigherOrderIntrinsic Repl) -> + ImplicitFunctionalReplacement `Set.member` allowed + -- The checked proposition is the deliberate granularity: its typed + -- global occurrences neither select another fact nor grant authority. + HigherOrderGlobalType{} -> + True + StructuralFofExclusion{} -> + False + HigherOrderAmbientLocal{} -> + False + +validateImplicitHigherOrderAdmission + :: SupportedProposition local global + -> FofCapability claimProjection + -> Vector (TypedBackendFact ref global) + -> Vector (TypedLocalPremise local origin global) + -> [TypedProblemAuxiliary global] + -> Either (TypedProblemError local global) () +validateImplicitHigherOrderAdmission + claim claimCapability selectedFacts selectedLocals auxiliaries = do + claimConstructions <- + admittedPropositionConstructions claim claimCapability + traverse_ requireFirstOrderGlobal selectedFacts + localConstructions <- + foldM + (\admitted premise -> + (admitted <>) + <$> admittedPropositionConstructions + (typedLocalPremiseProposition premise) + (typedLocalPremiseCapability premise)) + Set.empty + (Vector.toList selectedLocals) + let admitted = claimConstructions <> localConstructions + traverse_ (requireAdmittedAuxiliary admitted) auxiliaries + where + admittedPropositionConstructions proposition = \case + FofProjectable{} -> + Right Set.empty + RequiresTh0 exclusions -> + maybe + (Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions)) + Right + (implicitConstructionAdmission + proposition + (RequiresTh0 exclusions)) + + requireFirstOrderGlobal fact = + case typedBackendFactCapability fact of + FofProjectable{} -> + Right () + RequiresTh0 exclusions -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + requireAdmittedAuxiliary admitted auxiliary = + case typedProblemAuxiliaryCapability auxiliary of + FofProjectable{} -> + Right () + RequiresTh0 exclusions + | auxiliaryAdmitted admitted + (typedProblemAuxiliaryTag auxiliary) -> + Right () + | otherwise -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + auxiliaryAdmitted admitted = \case + SeparationCharacteristic -> + ImplicitSeparation `Set.member` admitted + ReplacementCharacteristic -> + ImplicitFunctionalReplacement `Set.member` admitted + _ -> + False + +validateLocalPremiseOrdinals + :: [TypedLocalPremise local origin global] + -> Either + (TypedProblemError local global) + () +validateLocalPremiseOrdinals = + void + . foldM + (\seen premise -> + let ordinal = + typedLocalPremiseOrdinal premise + in + if ordinal `Set.member` seen + then + Left + (TypedProblemDuplicateLocalPremiseOrdinal + ordinal) + else + Right + (Set.insert + ordinal + seen)) + Set.empty + +isFofCapability :: FofCapability projection -> Bool +isFofCapability = \case + FofProjectable{} -> + True + RequiresTh0{} -> + False + +collectProblemGlobals + :: Ord global + => (global -> Maybe CoreType) + -> SupportedProposition local global + -> Vector (TypedBackendFact ref global) + -> Vector (TypedLocalPremise local origin global) + -> [TypedProblemAuxiliary global] + -> Either + (TypedProblemError local global) + (Map global CoreType) +collectProblemGlobals + globalType + claim + facts + locals + auxiliaries = + Map.fromAscList + <$> traverse + resolveGlobal + (Set.toAscList globals) + where + globals = + canonicalGlobals + (supportedPropositionTerm claim) + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedBackendFactProposition) + facts + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedLocalPremiseProposition) + locals + <> foldMap + (canonicalGlobals + . supportedPropositionTerm + . typedProblemAuxiliaryProposition) + auxiliaries + + resolveGlobal global = + case globalType global of + Nothing -> + Left + (TypedProblemClaimClassificationFailed + (UnknownBackendGlobal global)) + Just coreType -> + Right (global, coreType) + +collectProblemLocals + :: Ord local + => SupportedProposition local global + -> Vector (TypedLocalPremise local origin global) + -> Either + (TypedProblemError local global) + (Map local CoreType) +collectProblemLocals claim locals = + foldM + insertSupport + Map.empty + supports + where + supports = + Vector.toList + (supportedPropositionSupport claim) + <> concatMap + (Vector.toList + . supportedPropositionSupport + . typedLocalPremiseProposition) + (Vector.toList locals) + + insertSupport current (local, coreType) = + case Map.lookup local current of + Nothing -> + Right + (Map.insert + local + coreType + current) + Just previousType + | previousType == coreType -> + Right current + | otherwise -> + Left + (TypedProblemLocalTypeMismatch + local + previousType + coreType) + +typedProblemRoute + :: TypedProblem ref local origin global + -> TypedProblemRoute +typedProblemRoute + (TypedProblem + route + _claim + _facts + _locals + _auxiliaries + _globals + _localTypes) = + route + +typedProblemClaim + :: TypedProblem ref local origin global + -> SupportedProposition local global +typedProblemClaim + (TypedProblem + _route + claim + _facts + _locals + _auxiliaries + _globals + _localTypes) = + claim + +typedProblemGlobalPremises + :: TypedProblem ref local origin global + -> Vector (TypedBackendFact ref global) +typedProblemGlobalPremises + (TypedProblem + _route + _claim + facts + _locals + _auxiliaries + _globals + _localTypes) = + facts + +typedProblemLocalPremises + :: TypedProblem ref local origin global + -> Vector (TypedLocalPremise local origin global) +typedProblemLocalPremises + (TypedProblem + _route + _claim + _facts + locals + _auxiliaries + _globals + _localTypes) = + locals + +typedProblemAuxiliaries + :: TypedProblem ref local origin global + -> Vector (TypedProblemAuxiliary global) +typedProblemAuxiliaries + (TypedProblem + _route + _claim + _facts + _locals + auxiliaries + _globals + _localTypes) = + auxiliaries + +typedProblemGlobalTypes + :: TypedProblem ref local origin global + -> Map global CoreType +typedProblemGlobalTypes + (TypedProblem + _route + _claim + _facts + _locals + _auxiliaries + globals + _localTypes) = + globals + +typedProblemLocalTypes + :: TypedProblem ref local origin global + -> Map local CoreType +typedProblemLocalTypes + (TypedProblem + _route + _claim + _facts + _locals + _auxiliaries + _globals + localTypes) = + localTypes diff --git a/source/Felix/Checking/Backend/Tptp.hs b/source/Felix/Checking/Backend/Tptp.hs new file mode 100644 index 0000000..a5c0546 --- /dev/null +++ b/source/Felix/Checking/Backend/Tptp.hs @@ -0,0 +1,1281 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Deterministic task-wide TPTP preparation for checked typed problems. +module Felix.Checking.Backend.Tptp + ( TypedFormulaOccurrence(..) + , TypedTptpNameOrigin(..) + , PreparedTypedTptpProblem + , prepareTypedTptpProblem + , preparedTypedTptpRoute + , preparedTypedTptpText + , preparedTypedTptpTextNewline + , preparedTypedTptpConjectureText + , preparedTypedTptpNameOrigins + , TypedTptpPreparationError(..) + ) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Core +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Control.Monad (foldM) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Control.Monad.Trans.Class (lift) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import TextBuilder + + +data TypedFormulaOccurrence ref + = TypedGlobalPremiseOccurrence !ref + | TypedLocalPremiseOccurrence !LocalPremiseOrdinal + | TypedAuxiliaryOccurrence !Natural + | TypedConjectureOccurrence + deriving stock (Show, Eq, Ord) + +data TypedTptpNameOrigin ref local global + = TypedGlobalNameOrigin !global + | TypedLocalNameOrigin !local + | TypedIntrinsicNameOrigin !CoreIntrinsicTag + | TypedIntegerNameOrigin !Integer + | TypedBinderNameOrigin !Natural + | TypedFormulaNameOrigin !(TypedFormulaOccurrence ref) + deriving stock (Show, Eq, Ord) + +data PreparedTypedTptpProblem ref local global = + PreparedTypedTptpProblem + !TypedProblemRoute + !Text + !Text + !(Map + Text + (TypedTptpNameOrigin ref local global)) + deriving stock (Eq) + +preparedTypedTptpRoute + :: PreparedTypedTptpProblem ref local global + -> TypedProblemRoute +preparedTypedTptpRoute + (PreparedTypedTptpProblem + route + _text + _conjecture + _origins) = + route + +preparedTypedTptpText + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpText + (PreparedTypedTptpProblem + _route + problemText + _conjecture + _origins) = + problemText + +preparedTypedTptpTextNewline + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpTextNewline = + (`Text.snoc` '\n') + . preparedTypedTptpText + +preparedTypedTptpConjectureText + :: PreparedTypedTptpProblem ref local global + -> Text +preparedTypedTptpConjectureText + (PreparedTypedTptpProblem + _route + _text + conjecture + _origins) = + conjecture + +preparedTypedTptpNameOrigins + :: PreparedTypedTptpProblem ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) +preparedTypedTptpNameOrigins + (PreparedTypedTptpProblem + _route + _text + _conjecture + origins) = + origins + +data TypedTptpPreparationError local global + = InvalidGeneratedTypedTptpName !Text + | DuplicateGeneratedTypedTptpName !Text + | TypedTptpUnknownGlobal !global + | TypedTptpUnknownLocal !local + | TypedTptpUnboundIndex !Natural + | TypedTptpFofProjectionMismatch + deriving stock (Show, Eq) + + +data NameEnvironment ref local global = + NameEnvironment + !(Map global Tptp.AtomicWord) + !(Map global CoreType) + !(Map local Tptp.AtomicWord) + !(Map CoreIntrinsicTag Tptp.AtomicWord) + !(Map Integer Tptp.AtomicWord) + !(Map + Text + (TypedTptpNameOrigin ref local global)) + +data RenderState ref local global = + RenderState + !Natural + !Natural + !(Map + Text + (TypedTptpNameOrigin ref local global)) + +type Render ref local global = + StateT + (RenderState ref local global) + (Either + (TypedTptpPreparationError local global)) + +data RenderedFormula ref = RenderedFormula + !Tptp.AtomicWord + !(TypedFormulaOccurrence ref) + !TextBuilder + +data BoundTarget + = BoundFofVariable !Tptp.Variable + | BoundTh0Variable !Tptp.Variable + | AmbientConstant !Tptp.AtomicWord + +prepareTypedTptpProblem + :: (Ord local, Ord global) + => TypedProblem ref local origin global + -> Either + (TypedTptpPreparationError local global) + (PreparedTypedTptpProblem ref local global) +prepareTypedTptpProblem problem = do + names <- + allocateNames problem + let initialState = + RenderState + 0 + 0 + (nameEnvironmentOrigins names) + (rendered, finalState) <- + State.runStateT + (renderProblem names problem) + initialState + let (problemBuilder, conjectureBuilder) = + rendered + RenderState _nextBinder _nextHypothesis origins = + finalState + pure + (PreparedTypedTptpProblem + (typedProblemRoute problem) + (TextBuilder.toText problemBuilder) + (TextBuilder.toText conjectureBuilder) + origins) + +allocateNames + :: (Ord local, Ord global) + => TypedProblem ref local origin global + -> Either + (TypedTptpPreparationError local global) + (NameEnvironment ref local global) +allocateNames problem = do + globalAllocations <- + allocateCategory + "tg_g" + TypedGlobalNameOrigin + (Map.keys + (typedProblemGlobalTypes + problem)) + localAllocations <- + allocateCategory + "tg_l" + TypedLocalNameOrigin + (Map.keys + (typedProblemLocalTypes + problem)) + intrinsicAllocations <- + allocateCategory + "tg_i" + TypedIntrinsicNameOrigin + (Set.toAscList + (problemIntrinsics problem)) + integerAllocations <- + allocateCategory + "tg_n" + TypedIntegerNameOrigin + (Set.toAscList + (problemIntegers problem)) + origins <- + foldM + (\current (target, nameOrigin) -> + insertOrigin + (Tptp.atomicWordText target) + nameOrigin + current) + Map.empty + ( [ (target, nameOrigin) + | (_global, target, nameOrigin) <- + globalAllocations + ] + <> [ (target, nameOrigin) + | (_local, target, nameOrigin) <- + localAllocations + ] + <> [ (target, nameOrigin) + | (_intrinsic, target, nameOrigin) <- + intrinsicAllocations + ] + <> [ (target, nameOrigin) + | (_integer, target, nameOrigin) <- + integerAllocations + ] + ) + pure + (NameEnvironment + (Map.fromList + [ (global, target) + | (global, target, _nameOrigin) <- + globalAllocations + ]) + (typedProblemGlobalTypes problem) + (Map.fromList + [ (local, target) + | (local, target, _nameOrigin) <- + localAllocations + ]) + (Map.fromList + [ (intrinsic, target) + | (intrinsic, target, _nameOrigin) <- + intrinsicAllocations + ]) + (Map.fromList + [ (integer, target) + | (integer, target, _nameOrigin) <- + integerAllocations + ]) + origins) + where + allocateCategory prefix makeOrigin semantics = + traverse + (\(ordinal, semantic) -> do + target <- + generatedAtomicWord + (prefix + <> Text.pack + (show ordinal)) + pure + ( semantic + , target + , makeOrigin semantic + )) + (zip [0 :: Int ..] semantics) + +nameEnvironmentOrigins + :: NameEnvironment ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) +nameEnvironmentOrigins + (NameEnvironment + _globals + _globalTypes + _locals + _intrinsics + _integers + origins) = + origins + +generatedAtomicWord + :: Text + -> Either + (TypedTptpPreparationError local global) + Tptp.AtomicWord +generatedAtomicWord target = + maybe + (Left + (InvalidGeneratedTypedTptpName + target)) + Right + (Tptp.atomicWord target) + +generatedVariable + :: Text + -> Either + (TypedTptpPreparationError local global) + Tptp.Variable +generatedVariable target = + maybe + (Left + (InvalidGeneratedTypedTptpName + target)) + Right + (Tptp.variable target) + +insertOrigin + :: Text + -> TypedTptpNameOrigin ref local global + -> Map + Text + (TypedTptpNameOrigin ref local global) + -> Either + (TypedTptpPreparationError local global) + (Map + Text + (TypedTptpNameOrigin ref local global)) +insertOrigin target nameOrigin origins = + if Map.member target origins + then + Left + (DuplicateGeneratedTypedTptpName + target) + else + Right + (Map.insert + target + nameOrigin + origins) + +renderProblem + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + (TextBuilder, TextBuilder) +renderProblem names problem = do + hypotheses <- + renderHypotheses names problem + conjecture <- + renderConjecture names problem + declarations <- + case typedProblemRoute problem of + RouteFof -> + pure [] + RouteTh0 -> + renderTh0Declarations + names + problem + let formulaBuilders = + renderFormulaLine + (typedProblemRoute problem) + "axiom" + <$> hypotheses + conjectureBuilder = + renderFormulaLine + (typedProblemRoute problem) + "conjecture" + conjecture + complete = + intercalate + (char '\n') + (declarations + <> formulaBuilders + <> [conjectureBuilder]) + pure + ( complete + , conjectureBuilder + ) + +renderHypotheses + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + [RenderedFormula ref] +renderHypotheses names problem = do + globalFormulas <- + traverse + (\fact -> + renderOccurrence + names + problem + (TypedGlobalPremiseOccurrence + (typedBackendFactReference + fact)) + (weakenClosedSupportedProposition + (typedBackendFactProposition + fact))) + (Vector.toList + (typedProblemGlobalPremises + problem)) + localFormulas <- + traverse + (\premise -> + renderOccurrence + names + problem + (TypedLocalPremiseOccurrence + (typedLocalPremiseOrdinal + premise)) + (typedLocalPremiseProposition + premise)) + (Vector.toList + (typedProblemLocalPremises + problem)) + auxiliaryFormulas <- + traverse + (\auxiliary -> + renderOccurrence + names + problem + (TypedAuxiliaryOccurrence + (typedProblemAuxiliaryOrdinal + auxiliary)) + (weakenClosedSupportedProposition + (typedProblemAuxiliaryProposition + auxiliary))) + (Vector.toList + (typedProblemAuxiliaries + problem)) + pure + (globalFormulas + <> localFormulas + <> auxiliaryFormulas) + +renderConjecture + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render + ref + local + global + (RenderedFormula ref) +renderConjecture names problem = + renderOccurrence + names + problem + TypedConjectureOccurrence + (typedProblemClaim problem) + +renderOccurrence + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> TypedFormulaOccurrence ref + -> SupportedProposition local global + -> Render + ref + local + global + (RenderedFormula ref) +renderOccurrence names problem occurrence proposition = do + target <- + case occurrence of + TypedConjectureOccurrence -> + liftEither + (generatedAtomicWord "tg_q0") + _ -> do + ordinal <- + nextHypothesisOrdinal + liftEither + (generatedAtomicWord + ("tg_h" + <> Text.pack + (show ordinal))) + registerOrigin + (Tptp.atomicWordText target) + (TypedFormulaNameOrigin occurrence) + bounds <- + initialBounds + names + proposition + formula <- + case typedProblemRoute problem of + RouteFof -> + renderFofFormula + names + bounds + (supportedPropositionTerm + proposition) + RouteTh0 -> + renderTh0Term + names + bounds + (supportedPropositionTerm + proposition) + pure + (RenderedFormula + target + occurrence + formula) + +-- Formula and binder ordinals use separate dense namespaces. +nextHypothesisOrdinal + :: Render ref local global Natural +nextHypothesisOrdinal = do + RenderState nextBinder nextHypothesis origins <- + State.get + State.put + (RenderState + nextBinder + (nextHypothesis + 1) + origins) + pure nextHypothesis + +registerOrigin + :: Text + -> TypedTptpNameOrigin ref local global + -> Render ref local global () +registerOrigin target nameOrigin = do + RenderState nextBinder nextHypothesis origins <- + State.get + origins' <- + liftEither + (insertOrigin + target + nameOrigin + origins) + State.put + (RenderState + nextBinder + nextHypothesis + origins') + +freshBinder + :: Render ref local global Tptp.Variable +freshBinder = do + RenderState nextBinder nextHypothesis origins <- + State.get + let target = + "V" <> Text.pack (show nextBinder) + variable <- + liftEither + (generatedVariable target) + origins' <- + liftEither + (insertOrigin + target + (TypedBinderNameOrigin + nextBinder) + origins) + State.put + (RenderState + (nextBinder + 1) + nextHypothesis + origins') + pure variable + +liftEither + :: Either + (TypedTptpPreparationError local global) + value + -> Render ref local global value +liftEither = + lift + +initialBounds + :: Ord local + => NameEnvironment ref local global + -> SupportedProposition local global + -> Render ref local global [BoundTarget] +initialBounds + (NameEnvironment + _globals + _globalTypes + localNames + _intrinsics + _integers + _origins) + proposition = + traverse + (\(local, _coreType) -> + maybe + (lift + (Left + (TypedTptpUnknownLocal + local))) + (pure . AmbientConstant) + (Map.lookup + local + localNames)) + (Vector.toList + (supportedPropositionSupport + proposition)) + +renderFormulaLine + :: TypedProblemRoute + -> TextBuilder + -> RenderedFormula ref + -> TextBuilder +renderFormulaLine route role + (RenderedFormula target _occurrence formula) = + dialect + <> char '(' + <> Tptp.buildAtomicWord target + <> char ',' + <> role + <> char ',' + <> formula + <> text ")." + where + dialect = + case route of + RouteFof -> + text "fof" + RouteTh0 -> + text "thf" + + +renderFofFormula + :: (Ord global) + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofFormula names bounds = \case + CFalsum -> + pure (text "$false") + CImp premise conclusion -> do + premise' <- + renderFofFormula names bounds premise + conclusion' <- + renderFofFormula names bounds conclusion + pure + (parenthesize + (premise' + <> text "=>" + <> conclusion')) + CEq TySet left right -> do + left' <- + renderFofTerm names bounds left + right' <- + renderFofTerm names bounds right + pure + (parenthesize + (left' + <> char '=' + <> right')) + CEq TyProp left right -> do + left' <- + renderFofFormula names bounds left + right' <- + renderFofFormula names bounds right + pure + (parenthesize + (left' + <> text "<=>" + <> right')) + CForall TySet body -> do + variable <- + freshBinder + body' <- + renderFofFormula + names + (BoundFofVariable variable + : bounds) + body + pure + (parenthesize + (text "![" + <> Tptp.buildVariable variable + <> text "]:" + <> body')) + application -> + renderFofApplication + names + bounds + TyProp + application + +renderFofTerm + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofTerm names bounds = \case + CBound index -> + renderBound index bounds + CGlobal global -> + Tptp.buildAtomicWord + <$> lookupGlobal names global + CIntrinsic intrinsic -> + Tptp.buildAtomicWord + <$> lookupIntrinsic names intrinsic + COpaqueInteger integer -> + Tptp.buildAtomicWord + <$> lookupInteger names integer + application -> + renderFofApplication + names + bounds + TySet + application + +renderFofApplication + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CoreType + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderFofApplication names bounds expected application = + case applicationHead application of + (CGlobal global, arguments) -> do + coreType <- + maybe + (lift + (Left + (TypedTptpUnknownGlobal + global))) + pure + (Map.lookup + global + (nameEnvironmentGlobalTypes + names)) + renderHead + coreType + (lookupGlobal names global) + arguments + (CIntrinsic intrinsic, arguments) -> + renderHead + (coreIntrinsicType intrinsic) + (lookupIntrinsic names intrinsic) + arguments + _ -> + lift + (Left + TypedTptpFofProjectionMismatch) + where + renderHead coreType targetAction arguments = do + unlessFofApplication + expected + coreType + arguments + target <- + targetAction + arguments' <- + traverse + (renderFofTerm names bounds) + arguments + pure + (applyAtomicWord + target + arguments') + +-- Global types are retained in the problem, but names need only the allocated +-- symbols. FOF saturation was already checked by the projection witness. +nameEnvironmentGlobalTypes + :: NameEnvironment ref local global + -> Map global CoreType +nameEnvironmentGlobalTypes + (NameEnvironment + _globals + globalTypes + _locals + _intrinsics + _integers + _origins) = + globalTypes + +unlessFofApplication + :: CoreType + -> CoreType + -> [CanonicalTerm global] + -> Render ref local global () +unlessFofApplication expected coreType arguments = + case consume coreType arguments of + Just result + | result == expected -> + pure () + _ -> + lift + (Left + TypedTptpFofProjectionMismatch) + where + consume current = \case + [] -> + Just current + _argument : remaining -> + case current of + TyArrow TySet result -> + consume result remaining + _ -> + Nothing + +applyAtomicWord + :: Tptp.AtomicWord + -> [TextBuilder] + -> TextBuilder +applyAtomicWord target = \case + [] -> + Tptp.buildAtomicWord target + arguments -> + Tptp.buildAtomicWord target + <> Tptp.buildTuple arguments + +renderBound + :: Natural + -> [BoundTarget] + -> Render ref local global TextBuilder +renderBound index bounds = + case contextAt index bounds of + Nothing -> + lift + (Left + (TypedTptpUnboundIndex + index)) + Just (BoundFofVariable variable) -> + pure + (Tptp.buildVariable + variable) + Just (BoundTh0Variable variable) -> + pure + (Tptp.buildVariable + variable) + Just (AmbientConstant target) -> + pure + (Tptp.buildAtomicWord + target) + + +renderTh0Term + :: Ord global + => NameEnvironment ref local global + -> [BoundTarget] + -> CanonicalTerm global + -> Render ref local global TextBuilder +renderTh0Term names bounds = \case + CBound index -> + renderBound index bounds + CGlobal global -> + Tptp.buildAtomicWord + <$> lookupGlobal names global + CIntrinsic intrinsic -> + Tptp.buildAtomicWord + <$> lookupIntrinsic names intrinsic + COpaqueInteger integer -> + Tptp.buildAtomicWord + <$> lookupInteger names integer + CApp function argument -> do + function' <- + renderTh0Term names bounds function + argument' <- + renderTh0Term names bounds argument + pure + (parenthesize + (function' + <> char '@' + <> argument')) + CLam binderType body -> do + variable <- + freshBinder + body' <- + renderTh0Term + names + (BoundTh0Variable variable + : bounds) + body + pure + (parenthesize + (text "^ [" + <> Tptp.buildVariable variable + <> char ':' + <> renderCoreType binderType + <> text "] : " + <> body')) + CFalsum -> + pure (text "$false") + CImp premise conclusion -> do + premise' <- + renderTh0Term names bounds premise + conclusion' <- + renderTh0Term names bounds conclusion + pure + (parenthesize + (premise' + <> text "=>" + <> conclusion')) + CEq operandType left right -> do + left' <- + renderTh0Term names bounds left + right' <- + renderTh0Term names bounds right + pure + (parenthesize + (left' + <> (case operandType of + TyProp -> text "<=>" + _ -> char '=') + <> right')) + CForall binderType body -> do + variable <- + freshBinder + body' <- + renderTh0Term + names + (BoundTh0Variable variable + : bounds) + body + pure + (parenthesize + (text "! [" + <> Tptp.buildVariable variable + <> char ':' + <> renderCoreType binderType + <> text "] : " + <> body')) + +renderTh0Declarations + :: (Ord local, Ord global) + => NameEnvironment ref local global + -> TypedProblem ref local origin global + -> Render ref local global [TextBuilder] +renderTh0Declarations names problem = do + globalDeclarations <- + traverse + (\(ordinal, (global, coreType)) -> do + target <- + lookupGlobal names global + label <- + liftEither + (generatedAtomicWord + ("tg_g_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType coreType))) + (zip [0 :: Int ..] + (Map.toAscList + (typedProblemGlobalTypes + problem))) + localDeclarations <- + traverse + (\(ordinal, (local, coreType)) -> do + target <- + lookupLocal names local + label <- + liftEither + (generatedAtomicWord + ("tg_l_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType coreType))) + (zip [0 :: Int ..] + (Map.toAscList + (typedProblemLocalTypes + problem))) + intrinsicDeclarations <- + traverse + (\(ordinal, intrinsic) -> do + target <- + lookupIntrinsic names intrinsic + label <- + liftEither + (generatedAtomicWord + ("tg_i_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType + (coreIntrinsicType + intrinsic)))) + (zip [0 :: Int ..] + (Set.toAscList + (problemIntrinsics problem))) + integerDeclarations <- + traverse + (\(ordinal, integer) -> do + target <- + lookupInteger names integer + label <- + liftEither + (generatedAtomicWord + ("tg_n_type_" + <> Text.pack + (show ordinal))) + pure + (typeDeclaration + label + target + (renderCoreType TySet))) + (zip [0 :: Int ..] + (Set.toAscList + (problemIntegers problem))) + pure + (globalDeclarations + <> localDeclarations + <> intrinsicDeclarations + <> integerDeclarations) + +typeDeclaration + :: Tptp.AtomicWord + -> Tptp.AtomicWord + -> TextBuilder + -> TextBuilder +typeDeclaration label target coreType = + text "thf(" + <> Tptp.buildAtomicWord label + <> text ",type,(" + <> Tptp.buildAtomicWord target + <> char ':' + <> coreType + <> text "))." + +renderCoreType :: CoreType -> TextBuilder +renderCoreType = \case + TyProp -> + text "$o" + TySet -> + text "$i" + TyArrow argument result -> + parenthesize + (renderCoreType argument + <> char '>' + <> renderCoreType result) + +parenthesize :: TextBuilder -> TextBuilder +parenthesize builder = + char '(' <> builder <> char ')' + + +lookupGlobal + :: Ord global + => NameEnvironment ref local global + -> global + -> Render ref local global Tptp.AtomicWord +lookupGlobal names global = + maybe + (lift + (Left + (TypedTptpUnknownGlobal + global))) + pure + (lookupGlobalPure names global) + +lookupGlobalPure + :: Ord global + => NameEnvironment ref local global + -> global + -> Maybe Tptp.AtomicWord +lookupGlobalPure + (NameEnvironment + globals + _globalTypes + _locals + _intrinsics + _integers + _origins) = + (`Map.lookup` globals) + +lookupLocalPure + :: Ord local + => NameEnvironment ref local global + -> local + -> Maybe Tptp.AtomicWord +lookupLocalPure + (NameEnvironment + _globals + _globalTypes + locals + _intrinsics + _integers + _origins) = + (`Map.lookup` locals) + +lookupLocal + :: Ord local + => NameEnvironment ref local global + -> local + -> Render ref local global Tptp.AtomicWord +lookupLocal names local = + maybe + (lift + (Left + (TypedTptpUnknownLocal + local))) + pure + (lookupLocalPure names local) + +lookupIntrinsic + :: NameEnvironment ref local global + -> CoreIntrinsicTag + -> Render ref local global Tptp.AtomicWord +lookupIntrinsic names intrinsic = + maybe + (lift + (Left + TypedTptpFofProjectionMismatch)) + pure + (lookupIntrinsicPure names intrinsic) + +lookupIntrinsicPure + :: NameEnvironment ref local global + -> CoreIntrinsicTag + -> Maybe Tptp.AtomicWord +lookupIntrinsicPure + (NameEnvironment + _globals + _globalTypes + _locals + intrinsics + _integers + _origins) = + (`Map.lookup` intrinsics) + +lookupInteger + :: NameEnvironment ref local global + -> Integer + -> Render ref local global Tptp.AtomicWord +lookupInteger names integer = + maybe + (lift + (Left + TypedTptpFofProjectionMismatch)) + pure + (lookupIntegerPure names integer) + +lookupIntegerPure + :: NameEnvironment ref local global + -> Integer + -> Maybe Tptp.AtomicWord +lookupIntegerPure + (NameEnvironment + _globals + _globalTypes + _locals + _intrinsics + integers + _origins) = + (`Map.lookup` integers) + +problemIntrinsics + :: TypedProblem ref local origin global + -> Set CoreIntrinsicTag +problemIntrinsics = + foldMap canonicalIntrinsics + . problemTerms + +problemIntegers + :: TypedProblem ref local origin global + -> Set Integer +problemIntegers = + foldMap canonicalIntegers + . problemTerms + +problemTerms + :: TypedProblem ref local origin global + -> [CanonicalTerm global] +problemTerms problem = + supportedPropositionTerm + (typedProblemClaim problem) + : (supportedPropositionTerm + . typedBackendFactProposition + <$> Vector.toList + (typedProblemGlobalPremises + problem)) + <> (supportedPropositionTerm + . typedLocalPremiseProposition + <$> Vector.toList + (typedProblemLocalPremises + problem)) + <> (supportedPropositionTerm + . typedProblemAuxiliaryProposition + <$> Vector.toList + (typedProblemAuxiliaries + problem)) + +canonicalIntrinsics + :: CanonicalTerm global + -> Set CoreIntrinsicTag +canonicalIntrinsics = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic -> + Set.singleton intrinsic + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalIntrinsics function + <> canonicalIntrinsics argument + CLam _binderType body -> + canonicalIntrinsics body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalIntrinsics premise + <> canonicalIntrinsics conclusion + CEq _operandType left right -> + canonicalIntrinsics left + <> canonicalIntrinsics right + CForall _binderType body -> + canonicalIntrinsics body + +canonicalIntegers + :: CanonicalTerm global + -> Set Integer +canonicalIntegers = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic{} -> + mempty + COpaqueInteger integer -> + Set.singleton integer + CApp function argument -> + canonicalIntegers function + <> canonicalIntegers argument + CLam _binderType body -> + canonicalIntegers body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalIntegers premise + <> canonicalIntegers conclusion + CEq _operandType left right -> + canonicalIntegers left + <> canonicalIntegers right + CForall _binderType body -> + canonicalIntegers body + +applicationHead + :: CanonicalTerm global + -> (CanonicalTerm global, [CanonicalTerm global]) +applicationHead = + go [] + where + go arguments = \case + CApp function argument -> + go (argument : arguments) function + headTerm -> + (headTerm, arguments) + +contextAt :: Natural -> [value] -> Maybe value +contextAt _index [] = + Nothing +contextAt 0 (value : _remaining) = + Just value +contextAt index (_value : remaining) = + contextAt (index - 1) remaining diff --git a/source/Felix/Checking/Core.hs b/source/Felix/Checking/Core.hs new file mode 100644 index 0000000..13ec218 --- /dev/null +++ b/source/Felix/Checking/Core.hs @@ -0,0 +1,1604 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked monomorphic HOL syntax and its nameless in-memory form. +-- +-- Scoped syntax is an operational construction language. Only a checked, +-- frozen value is semantic input to later kernel and backend boundaries. +module Felix.Checking.Core + ( CoreType(..) + , CoreIntrinsicTag(..) + , coreIntrinsicType + , CoreSyntax + , coreLocal + , coreGlobal + , coreIntrinsic + , coreOpaqueInteger + , coreApply + , coreLambda + , coreFalsum + , coreImplication + , coreEquality + , coreForall + , CheckedCore + , checkedCoreType + , checkCore + , checkClosedCore + , ClosedCheckedProposition + , checkedPropositionCore + , checkClosedProposition + , CoreCheckError(..) + , CanonicalTerm(..) + , canonicalSetInsert + , FrozenCheckedCore + , frozenCoreType + , frozenCoreTerm + , thawFrozenCore + , frozenCoreGlobals + , mapFrozenGlobals + , ScopedCheckedCore + , scopedCoreContext + , scopedCoreType + , scopedCoreTerm + , mapScopedGlobals + , checkScopedCanonicalCore + , embedClosedCore + , weakenCheckedScopedCore + , weakenScopedCore + , scopedSetDefinition + , scopedCharacteristicDefinition + , scopedReplacementGraph + , implyScopedCore + , equalScopedCore + , conjoinScopedCore + , disjoinScopedCore + , negateScopedCore + , falsumScopedCore + , splitScopedSetEquality + , scopedSetInductionInstance + , closeScopedForall + , closeScopedExists + , openScopedForall + , openScopedImplication + , openScopedAssumption + , closeScopedCore + , betaNormalizeCanonical + , instantiateCanonical + , shiftCanonical + , mapCanonicalGlobals + , canonicalTermGlobals + , checkCanonicalCore + , freezeClosed + , FreezeError(..) + , referenceFreezeClosed + ) where + +import Base hiding (Empty) + +import Bound +import Control.DeepSeq (NFData) +import Control.Monad (ap, unless) +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The complete monomorphic type grammar of the checked core. +data CoreType + = TyProp + | TySet + | TyArrow !CoreType !CoreType + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + + +-- | The complete set-forming primitive inventory. +data CoreIntrinsicTag + = Member + | Empty + | PairSet + | FamilyUnion + | PowerSet + | Sep + | Repl + | SetChoose + | UnivOf + -- | The bounded set-valued least fixed point. It denotes the elements of + -- its bound that belong to every bounded pre-fixed point of its operator. + | ISetLfp + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +coreIntrinsicType :: CoreIntrinsicTag -> CoreType +coreIntrinsicType = \case + Member -> + TySet `TyArrow` (TySet `TyArrow` TyProp) + Empty -> + TySet + PairSet -> + TySet `TyArrow` (TySet `TyArrow` TySet) + FamilyUnion -> + TySet `TyArrow` TySet + PowerSet -> + TySet `TyArrow` TySet + Sep -> + TySet + `TyArrow` + ((TySet `TyArrow` TyProp) `TyArrow` TySet) + Repl -> + TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + SetChoose -> + (TySet `TyArrow` TyProp) `TyArrow` TySet + UnivOf -> + TySet `TyArrow` TySet + ISetLfp -> + TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + + +-- | Operational scoped syntax. Its constructors remain private because this +-- value is neither a typing certificate nor an authority-bearing term. +data CoreSyntax global local + = CoreLocal local + | CoreGlobal global + | CoreIntrinsic CoreIntrinsicTag + | CoreOpaqueInteger !Integer + | CoreApply + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreLambda + !CoreType + !(Scope () (CoreSyntax global) local) + | CoreFalsum + | CoreImplication + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreEquality + !CoreType + !(CoreSyntax global local) + !(CoreSyntax global local) + | CoreForall + !CoreType + !(Scope () (CoreSyntax global) local) + deriving stock (Functor, Foldable, Traversable) + +instance Applicative (CoreSyntax global) where + pure = CoreLocal + (<*>) = ap + +instance Monad (CoreSyntax global) where + CoreLocal local >>= replace = + replace local + CoreGlobal global >>= _replace = + CoreGlobal global + CoreIntrinsic intrinsic >>= _replace = + CoreIntrinsic intrinsic + CoreOpaqueInteger integer >>= _replace = + CoreOpaqueInteger integer + CoreApply function argument >>= replace = + CoreApply + (function >>= replace) + (argument >>= replace) + CoreLambda binderType body >>= replace = + CoreLambda binderType (body >>>= replace) + CoreFalsum >>= _replace = + CoreFalsum + CoreImplication premise conclusion >>= replace = + CoreImplication + (premise >>= replace) + (conclusion >>= replace) + CoreEquality operandType left right >>= replace = + CoreEquality + operandType + (left >>= replace) + (right >>= replace) + CoreForall binderType body >>= replace = + CoreForall binderType (body >>>= replace) + +coreLocal :: local -> CoreSyntax global local +coreLocal = CoreLocal + +coreGlobal :: global -> CoreSyntax global local +coreGlobal = CoreGlobal + +coreIntrinsic :: CoreIntrinsicTag -> CoreSyntax global local +coreIntrinsic = CoreIntrinsic + +coreOpaqueInteger :: Integer -> CoreSyntax global local +coreOpaqueInteger = CoreOpaqueInteger + +coreApply + :: CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreApply = CoreApply + +coreLambda + :: Eq local + => CoreType + -> local + -> CoreSyntax global local + -> CoreSyntax global local +coreLambda binderType local body = + CoreLambda binderType (abstract1 local body) + +coreFalsum :: CoreSyntax global local +coreFalsum = CoreFalsum + +coreImplication + :: CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreImplication = CoreImplication + +coreEquality + :: CoreType + -> CoreSyntax global local + -> CoreSyntax global local + -> CoreSyntax global local +coreEquality = CoreEquality + +coreForall + :: Eq local + => CoreType + -> local + -> CoreSyntax global local + -> CoreSyntax global local +coreForall binderType local body = + CoreForall binderType (abstract1 local body) + + +data CoreCheckError + = UnknownCoreGlobal + | UnboundCoreLocal + | UnboundCoreIndex !Natural + | AppliedNonFunction !CoreType + | ApplicationArgumentTypeMismatch + !CoreType + !CoreType + | ImplicationOperandTypeMismatch + !CoreType + | EqualityOperandTypeMismatch + !CoreType + !CoreType + | QuantifierBodyTypeMismatch + !CoreType + | ExpectedCoreType + !CoreType + !CoreType + deriving stock (Show, Eq) + + +-- | A scoped term whose complete tree has been type checked. +data CheckedCore global local = CheckedCore + !CoreType + !(CoreSyntax global local) + +checkedCoreType :: CheckedCore global local -> CoreType +checkedCoreType (CheckedCore coreType _syntax) = + coreType + +checkCore + :: (global -> Maybe CoreType) + -> (local -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (CheckedCore global local) +checkCore globalType localType syntax = do + coreType <- + inferCore globalType localType syntax + pure (CheckedCore coreType syntax) + +checkClosedCore + :: (global -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (CheckedCore global Void) +checkClosedCore globalType syntax = do + closedSyntax <- + maybe + (Left UnboundCoreLocal) + Right + (traverse (const Nothing) syntax) + checkCore globalType absurd closedSyntax + +newtype ClosedCheckedProposition global = + ClosedCheckedProposition (CheckedCore global Void) + +checkedPropositionCore + :: ClosedCheckedProposition global + -> CheckedCore global Void +checkedPropositionCore + (ClosedCheckedProposition proposition) = + proposition + +checkClosedProposition + :: (global -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError (ClosedCheckedProposition global) +checkClosedProposition globalType syntax = do + checked <- + checkClosedCore globalType syntax + unless + (checkedCoreType checked == TyProp) + (Left + (ExpectedCoreType + TyProp + (checkedCoreType checked))) + pure (ClosedCheckedProposition checked) + +inferCore + :: forall global local + . (global -> Maybe CoreType) + -> (local -> Maybe CoreType) + -> CoreSyntax global local + -> Either CoreCheckError CoreType +inferCore globalType localType = + infer + (maybe + (Left UnboundCoreLocal) + Right + . localType) + where + infer + :: forall local' + . (local' -> Either CoreCheckError CoreType) + -> CoreSyntax global local' + -> Either CoreCheckError CoreType + infer resolveLocal = \case + CoreLocal local -> + resolveLocal local + CoreGlobal global -> + maybe + (Left UnknownCoreGlobal) + Right + (globalType global) + CoreIntrinsic intrinsic -> + Right (coreIntrinsicType intrinsic) + CoreOpaqueInteger{} -> + Right TySet + CoreApply function argument -> do + functionType <- + infer resolveLocal function + argumentType <- + infer resolveLocal argument + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + Right resultType + | otherwise -> + Left + (ApplicationArgumentTypeMismatch + expectedArgument + argumentType) + other -> + Left (AppliedNonFunction other) + CoreLambda binderType body -> do + bodyType <- + infer + (boundLocalType binderType resolveLocal) + (unscope body) + Right (binderType `TyArrow` bodyType) + CoreFalsum -> + Right TyProp + CoreImplication premise conclusion -> do + premiseType <- + infer resolveLocal premise + unless + (premiseType == TyProp) + (Left + (ImplicationOperandTypeMismatch + premiseType)) + conclusionType <- + infer resolveLocal conclusion + unless + (conclusionType == TyProp) + (Left + (ImplicationOperandTypeMismatch + conclusionType)) + Right TyProp + CoreEquality operandType left right -> do + leftType <- + infer resolveLocal left + unless + (leftType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + leftType)) + rightType <- + infer resolveLocal right + unless + (rightType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + rightType)) + Right TyProp + CoreForall binderType body -> do + bodyType <- + infer + (boundLocalType binderType resolveLocal) + (unscope body) + unless + (bodyType == TyProp) + (Left + (QuantifierBodyTypeMismatch bodyType)) + Right TyProp + + boundLocalType + :: forall local' + . CoreType + -> (local' -> Either CoreCheckError CoreType) + -> Var () (CoreSyntax global local') + -> Either CoreCheckError CoreType + boundLocalType binderType outerType = \case + B () -> + Right binderType + F outerSyntax -> + infer outerType outerSyntax + + +-- | Felix-owned explicit-index syntax. Index zero denotes the nearest +-- enclosing binder. +data CanonicalTerm global + = CBound !Natural + | CGlobal !global + | CIntrinsic !CoreIntrinsicTag + | COpaqueInteger !Integer + | CApp + !(CanonicalTerm global) + !(CanonicalTerm global) + | CLam + !CoreType + !(CanonicalTerm global) + | CFalsum + | CImp + !(CanonicalTerm global) + !(CanonicalTerm global) + | CEq + !CoreType + !(CanonicalTerm global) + !(CanonicalTerm global) + | CForall + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | The fixed checked-core interpretation of set insertion. +-- +-- Finite-set notation uses this intrinsic HOTG adjunction directly. The +-- ordinary source-owned @cons@ function is not consulted during lowering. +canonicalSetInsert + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +canonicalSetInsert element set = + CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp + (CIntrinsic PairSet) + (CApp + (CApp + (CIntrinsic PairSet) + element) + element)) + set) + +data FrozenCheckedCore global = FrozenCheckedCore + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +frozenCoreType :: FrozenCheckedCore global -> CoreType +frozenCoreType (FrozenCheckedCore coreType _term) = + coreType + +frozenCoreTerm :: FrozenCheckedCore global -> CanonicalTerm global +frozenCoreTerm (FrozenCheckedCore _coreType term) = + term + +mapFrozenGlobals + :: (global -> global') + -> FrozenCheckedCore global + -> FrozenCheckedCore global' +mapFrozenGlobals transform + (FrozenCheckedCore coreType term) = + FrozenCheckedCore + coreType + (mapCanonicalGlobals transform term) + +-- | Recover an operational closed term from a checked frozen value. Any caller +-- that extends or substitutes it must check the resulting term again. +thawFrozenCore + :: FrozenCheckedCore global + -> CoreSyntax global Void +thawFrozenCore (FrozenCheckedCore _coreType term) = + case traverse (const Nothing) (go [] term) of + Just closedSyntax -> + closedSyntax + Nothing -> + impossible + "a frozen core term became open while being thawed" + where + go + :: [Natural] + -> CanonicalTerm global + -> CoreSyntax global Natural + go binders = \case + CBound index -> + case lookupBinder index binders of + Just local -> + coreLocal local + Nothing -> + impossible + "a frozen core term contains an unbound index" + CGlobal global -> + coreGlobal global + CIntrinsic intrinsic -> + coreIntrinsic intrinsic + COpaqueInteger integer -> + coreOpaqueInteger integer + CApp function argument -> + coreApply + (go binders function) + (go binders argument) + CLam binderType body -> + let local = + fromIntegral (length binders) + in coreLambda + binderType + local + (go (local : binders) body) + CFalsum -> + coreFalsum + CImp premise conclusion -> + coreImplication + (go binders premise) + (go binders conclusion) + CEq operandType left right -> + coreEquality + operandType + (go binders left) + (go binders right) + CForall binderType body -> + let local = + fromIntegral (length binders) + in coreForall + binderType + local + (go (local : binders) body) + + lookupBinder + :: Natural + -> [Natural] + -> Maybe Natural + lookupBinder _index [] = + Nothing + lookupBinder 0 (local : _rest) = + Just local + lookupBinder index (_local : rest) = + lookupBinder (index - 1) rest + +frozenCoreGlobals + :: Ord global + => FrozenCheckedCore global + -> Set.Set global +frozenCoreGlobals = + canonicalTermGlobals . frozenCoreTerm + +canonicalTermGlobals + :: Ord global + => CanonicalTerm global + -> Set.Set global +canonicalTermGlobals = \case + CBound{} -> + mempty + CGlobal global -> + Set.singleton global + CIntrinsic{} -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + canonicalTermGlobals function + <> canonicalTermGlobals argument + CLam _binderType body -> + canonicalTermGlobals body + CFalsum -> + mempty + CImp premise conclusion -> + canonicalTermGlobals premise + <> canonicalTermGlobals conclusion + CEq _operandType left right -> + canonicalTermGlobals left + <> canonicalTermGlobals right + CForall _binderType body -> + canonicalTermGlobals body + +-- | A checked canonical term relative to the listed nearest-first binders. +-- This is the construction boundary used by kernel replay; it carries no fact +-- authority. +data ScopedCheckedCore global = ScopedCheckedCore + ![CoreType] + !CoreType + !(CanonicalTerm global) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +scopedCoreContext + :: ScopedCheckedCore global + -> [CoreType] +scopedCoreContext + (ScopedCheckedCore context _coreType _term) = + context + +scopedCoreType + :: ScopedCheckedCore global + -> CoreType +scopedCoreType + (ScopedCheckedCore _context coreType _term) = + coreType + +scopedCoreTerm + :: ScopedCheckedCore global + -> CanonicalTerm global +scopedCoreTerm + (ScopedCheckedCore _context _coreType term) = + term + +mapScopedGlobals + :: (left -> right) + -> ScopedCheckedCore left + -> ScopedCheckedCore right +mapScopedGlobals transform + (ScopedCheckedCore context coreType term) = + ScopedCheckedCore + context + coreType + (mapCanonicalGlobals transform term) + +checkScopedCanonicalCore + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either CoreCheckError (ScopedCheckedCore global) +checkScopedCanonicalCore globalType context term = + ScopedCheckedCore context + <$> inferCanonicalCore globalType context term + <*> pure term + +-- | Regard a closed term under a larger lexical context. Closed canonical +-- terms contain no indices, so this does not shift the term. +embedClosedCore + :: [CoreType] + -> FrozenCheckedCore global + -> ScopedCheckedCore global +embedClosedCore context + (FrozenCheckedCore coreType term) = + ScopedCheckedCore context coreType term + +-- | Add one nearest binder to an already checked lexical context. +weakenCheckedScopedCore + :: CoreType + -> ScopedCheckedCore global + -> ScopedCheckedCore global +weakenCheckedScopedCore binderType scoped = + ScopedCheckedCore + (binderType : scopedCoreContext scoped) + (scopedCoreType scoped) + (shiftCanonical 1 0 (scopedCoreTerm scoped)) + +-- | Add one nearest binder to a checked lexical context. +weakenScopedCore + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either CoreCheckError (ScopedCheckedCore global) +weakenScopedCore globalType binderType scoped = + checkScopedCanonicalCore + globalType + (binderType : scopedCoreContext scoped) + (shiftCanonical 1 0 + (scopedCoreTerm scoped)) + +-- | Introduce a fresh set-valued local definition. Separation specializes +-- the checked foundation characteristic so its local premise remains +-- first-order. +scopedSetDefinition + :: Eq global + => FrozenCheckedCore Void + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +scopedSetDefinition + characteristic + expression@(ScopedCheckedCore context TySet term) = + case term of + CApp + (CApp (CIntrinsic Sep) bound) + predicate@(CLam TySet _body) -> + scopedCharacteristicDefinition + characteristic + expression + ( ScopedCheckedCore context TySet bound + :| [ ScopedCheckedCore + context + (TySet `TyArrow` TyProp) + predicate + ] + ) + _ -> + Just + (ScopedCheckedCore + (TySet : context) + TyProp + (CEq + TySet + (CBound 0) + (shiftCanonical 1 0 term))) +scopedSetDefinition _characteristic _expression = + Nothing + +-- | Specialize a checked characteristic and abstract its set-valued target +-- into one fresh nearest binder. Checked substitution and beta reduction +-- preserve the foundation row's proposition type. +scopedCharacteristicDefinition + :: Eq global + => FrozenCheckedCore Void + -> ScopedCheckedCore global + -> NonEmpty (ScopedCheckedCore global) + -> Maybe (ScopedCheckedCore global) +scopedCharacteristicDefinition + (FrozenCheckedCore TyProp frozen) + (ScopedCheckedCore context TySet target) + arguments + | all ((== context) . scopedCoreContext) arguments = do + specialized <- + specialize + (mapCanonicalGlobals absurd frozen) + (toList arguments) + let normalized = betaNormalizeCanonical specialized + (found, abstracted) = abstractTarget 0 normalized + guard found + pure + (ScopedCheckedCore + (TySet : context) + TyProp + abstracted) + where + specialize term [] = + Just term + specialize (CForall binderType body) + (ScopedCheckedCore _ argumentType argument : rest) + | binderType == argumentType = + specialize + (instantiateCanonical argument body) + rest + specialize _term _arguments = + Nothing + + abstractTarget depth term + | term == shiftCanonical depth 0 target = + (True, CBound (fromIntegral depth)) + | otherwise = + case term of + CBound index + | index < fromIntegral depth -> + (False, CBound index) + | otherwise -> + (False, CBound (index + 1)) + CGlobal global -> + (False, CGlobal global) + CIntrinsic intrinsic -> + (False, CIntrinsic intrinsic) + COpaqueInteger integer -> + (False, COpaqueInteger integer) + CApp function argument -> + combine CApp + (abstractTarget depth function) + (abstractTarget depth argument) + CLam binderType body -> + let (found, abstracted) = + abstractTarget (depth + 1) body + in (found, CLam binderType abstracted) + CFalsum -> + (False, CFalsum) + CImp premise conclusion -> + combine CImp + (abstractTarget depth premise) + (abstractTarget depth conclusion) + CEq operandType left right -> + combine (CEq operandType) + (abstractTarget depth left) + (abstractTarget depth right) + CForall binderType body -> + let (found, abstracted) = + abstractTarget (depth + 1) body + in (found, CForall binderType abstracted) + + combine constructor (leftFound, left) (rightFound, right) = + (leftFound || rightFound, constructor left right) +scopedCharacteristicDefinition _characteristic _target _arguments = + Nothing + +-- | Build the replacement graph of one checked set-valued local function. +-- The ordered-pair constructor is an ordinary checked source object. +scopedReplacementGraph + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + ) +scopedReplacementGraph + (ScopedCheckedCore context pairType pair) + domain@(ScopedCheckedCore domainContext TySet domainTerm) + (ScopedCheckedCore valueContext TySet value) + | pairType == TySet `TyArrow` (TySet `TyArrow` TySet) + , domainContext == context + , valueContext == TySet : context = + let pairValue = + CApp + (CApp + (shiftCanonical 1 0 pair) + (CBound 0)) + value + function = CLam TySet pairValue + graph = + CApp + (CApp (CIntrinsic Repl) domainTerm) + function + in Just + ( ScopedCheckedCore context TySet graph + , domain + , ScopedCheckedCore + context + (TySet `TyArrow` TySet) + function + ) +scopedReplacementGraph _pair _domain _value = + Nothing + +betaNormalizeCanonical + :: CanonicalTerm global + -> CanonicalTerm global +betaNormalizeCanonical = \case + CApp function argument -> + case betaNormalizeCanonical function of + CLam _binderType body -> + betaNormalizeCanonical + (instantiateCanonical + (betaNormalizeCanonical argument) + body) + normalizedFunction -> + CApp + normalizedFunction + (betaNormalizeCanonical argument) + CLam binderType body -> + CLam binderType (betaNormalizeCanonical body) + CImp premise conclusion -> + CImp + (betaNormalizeCanonical premise) + (betaNormalizeCanonical conclusion) + CEq operandType left right -> + CEq operandType + (betaNormalizeCanonical left) + (betaNormalizeCanonical right) + CForall binderType body -> + CForall binderType (betaNormalizeCanonical body) + term -> term + +-- | Combine two checked propositions under the same lexical context. +implyScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +implyScopedCore + (ScopedCheckedCore premiseContext TyProp premise) + (ScopedCheckedCore conclusionContext TyProp conclusion) + | premiseContext == conclusionContext = + Just + (ScopedCheckedCore + premiseContext + TyProp + (CImp premise conclusion)) +implyScopedCore _premise _conclusion = + Nothing + +-- | Form an equality between checked operands under the same lexical +-- context. This preserves the checked-core invariant without requiring a +-- caller to recover global types merely to combine already checked terms. +equalScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +equalScopedCore + (ScopedCheckedCore leftContext leftType left) + (ScopedCheckedCore rightContext rightType right) + | leftContext == rightContext + , leftType == rightType = + Just + (ScopedCheckedCore + leftContext + TyProp + (CEq leftType left right)) +equalScopedCore _left _right = + Nothing + +-- | Conjoin two checked propositions under the same lexical context. Truth +-- is normalized away so callers can build an optional source guard without +-- retaining an inert conjunct. +conjoinScopedCore + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +conjoinScopedCore + left@(ScopedCheckedCore leftContext TyProp leftTerm) + right@(ScopedCheckedCore rightContext TyProp rightTerm) + | leftContext == rightContext + , leftTerm == truth = Just right + | leftContext == rightContext + , rightTerm == truth = Just left + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp + (CImp leftTerm (CImp rightTerm CFalsum)) + CFalsum)) + where + truth = CImp CFalsum CFalsum +conjoinScopedCore _left _right = + Nothing + +-- | Disjoin two checked propositions under the same lexical context using +-- the fixed classical encoding owned by the checked core. +disjoinScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +disjoinScopedCore + (ScopedCheckedCore leftContext TyProp left) + (ScopedCheckedCore rightContext TyProp right) + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp (CImp left CFalsum) right)) +disjoinScopedCore _left _right = + Nothing + +-- | Negate a checked proposition without changing its lexical context. +negateScopedCore + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +negateScopedCore (ScopedCheckedCore context TyProp proposition) = + Just + (ScopedCheckedCore + context + TyProp + (CImp proposition CFalsum)) +negateScopedCore _proposition = + Nothing + +-- | Checked falsum at an already established lexical context. +falsumScopedCore :: [CoreType] -> ScopedCheckedCore global +falsumScopedCore context = + ScopedCheckedCore context TyProp CFalsum + +-- | Split a checked set equality into its two extensionality directions. +splitScopedSetEquality + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +splitScopedSetEquality + (ScopedCheckedCore context TyProp (CEq TySet left right)) = + Just (subset left right, subset right left) + where + subset source target = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (memberOf (shiftCanonical 1 0 source)) + (memberOf (shiftCanonical 1 0 target)))) + + memberOf set = + CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + set +splitScopedSetEquality _proposition = + Nothing + +-- | Derive the exact predicate, member-wise hypothesis, induction step, and +-- binder-level result for one set-valued ambient binder. The selected binder +-- is replaced by the newly introduced set variable; every other ambient +-- binder remains a parameter. +scopedSetInductionInstance + :: Natural + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + ) +scopedSetInductionInstance selected + (ScopedCheckedCore context TyProp property) + | binderTypeAt selected context == Just TySet = + Just (predicate, hypothesis, step, result) + where + abstractedProperty = abstractSelected 0 property + predicate = + ScopedCheckedCore + context + (TySet `TyArrow` TyProp) + (CLam TySet abstractedProperty) + hypothesis = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + (CBound (selected + 1))) + abstractedProperty)) + step = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (abstractSelected + 0 + (scopedCoreTerm hypothesis)) + abstractedProperty)) + result = + ScopedCheckedCore + context + TyProp + (CForall TySet abstractedProperty) + + abstractSelected depth = \case + CBound index + | index == depth + selected -> + CBound depth + | index >= depth -> + CBound (index + 1) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (abstractSelected depth function) + (abstractSelected depth argument) + CLam binderType body -> + CLam binderType + (abstractSelected (depth + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (abstractSelected depth premise) + (abstractSelected depth conclusion) + CEq operandType left right -> + CEq operandType + (abstractSelected depth left) + (abstractSelected depth right) + CForall binderType body -> + CForall binderType + (abstractSelected (depth + 1) body) +scopedSetInductionInstance _selected _property = + Nothing + +-- | Close the nearest checked binder as one leading universal. +closeScopedForall + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +closeScopedForall + (ScopedCheckedCore (binderType : context) TyProp body) = + Just + (ScopedCheckedCore + context + TyProp + (CForall binderType body)) +closeScopedForall _scoped = + Nothing + +-- | Close the nearest checked binder as one leading existential. +closeScopedExists + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +closeScopedExists + (ScopedCheckedCore (binderType : context) TyProp body) = + Just + (ScopedCheckedCore + context + TyProp + (CImp + (CForall binderType (CImp body CFalsum)) + CFalsum)) +closeScopedExists _scoped = + Nothing + +-- | Open one checked leading universal without rechecking its body. +openScopedForall + :: ScopedCheckedCore global + -> Maybe (CoreType, ScopedCheckedCore global) +openScopedForall + (ScopedCheckedCore context TyProp + (CForall binderType body)) = + Just + ( binderType + , ScopedCheckedCore + (binderType : context) + TyProp + body + ) +openScopedForall _scoped = + Nothing + +-- | Split one checked implication under its unchanged ambient context. +openScopedImplication + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +openScopedImplication + (ScopedCheckedCore context TyProp + (CImp premise conclusion)) = + Just + ( ScopedCheckedCore context TyProp premise + , ScopedCheckedCore context TyProp conclusion + ) +openScopedImplication _scoped = + Nothing + +-- | Open a checked proof assumption against the current goal. Besides a +-- direct implication antecedent, the source language historically permits +-- either immediate side of one binary conjunction antecedent to be assumed +-- first. The other side remains the next implication antecedent. This is a +-- deliberately shallow structural rule: it neither flattens conjunctions nor +-- treats disjunction as an eliminable assumption. +openScopedAssumption + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +openScopedAssumption supplied goal = do + (antecedent, conclusion) <- openScopedImplication goal + if supplied == antecedent + then pure (antecedent, conclusion) + else do + (left, right) <- splitScopedConjunction antecedent + if supplied == left + then do + remaining <- implyScopedCore right conclusion + pure (left, remaining) + else if supplied == right + then do + remaining <- implyScopedCore left conclusion + pure (right, remaining) + else Nothing + +splitScopedConjunction + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +splitScopedConjunction + (ScopedCheckedCore context TyProp + (CImp (CImp left (CImp right CFalsum)) CFalsum)) = + Just + ( ScopedCheckedCore context TyProp left + , ScopedCheckedCore context TyProp right + ) +splitScopedConjunction _scoped = + Nothing + +closeScopedCore + :: ScopedCheckedCore global + -> Maybe (FrozenCheckedCore global) +closeScopedCore + (ScopedCheckedCore [] coreType term) = + Just (FrozenCheckedCore coreType term) +closeScopedCore ScopedCheckedCore{} = + Nothing + +-- | Substitute an outer-context term for index zero and remove that binder. +instantiateCanonical + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +instantiateCanonical argument = + instantiateAt 0 + where + instantiateAt depth = \case + CBound index + | index == depth -> + shiftCanonical depth 0 argument + | index > depth -> + CBound (index - 1) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function operand -> + CApp + (instantiateAt depth function) + (instantiateAt depth operand) + CLam binderType body -> + CLam binderType + (instantiateAt (depth + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (instantiateAt depth premise) + (instantiateAt depth conclusion) + CEq operandType left right -> + CEq operandType + (instantiateAt depth left) + (instantiateAt depth right) + CForall binderType body -> + CForall binderType + (instantiateAt (depth + 1) body) + +mapCanonicalGlobals + :: (global -> global') + -> CanonicalTerm global + -> CanonicalTerm global' +mapCanonicalGlobals transform = \case + CBound index -> + CBound index + CGlobal global -> + CGlobal (transform global) + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (mapCanonicalGlobals transform function) + (mapCanonicalGlobals transform argument) + CLam binderType body -> + CLam binderType + (mapCanonicalGlobals transform body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (mapCanonicalGlobals transform premise) + (mapCanonicalGlobals transform conclusion) + CEq operandType left right -> + CEq operandType + (mapCanonicalGlobals transform left) + (mapCanonicalGlobals transform right) + CForall binderType body -> + CForall binderType + (mapCanonicalGlobals transform body) + +-- | Recheck a nameless term without exposing the checked wrapper constructor. +checkCanonicalCore + :: (global -> Maybe CoreType) + -> CanonicalTerm global + -> Either CoreCheckError (FrozenCheckedCore global) +checkCanonicalCore globalType term = + FrozenCheckedCore + <$> inferCanonicalCore globalType [] term + <*> pure term + +inferCanonicalCore + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either CoreCheckError CoreType +inferCanonicalCore globalType binders = \case + CBound index -> + maybe + (Left (UnboundCoreIndex index)) + Right + (binderTypeAt index binders) + CGlobal global -> + maybe + (Left UnknownCoreGlobal) + Right + (globalType global) + CIntrinsic intrinsic -> + Right (coreIntrinsicType intrinsic) + COpaqueInteger{} -> + Right TySet + CApp function argument -> do + functionType <- + inferCanonicalCore globalType binders function + argumentType <- + inferCanonicalCore globalType binders argument + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + Right resultType + | otherwise -> + Left + (ApplicationArgumentTypeMismatch + expectedArgument + argumentType) + other -> + Left (AppliedNonFunction other) + CLam binderType body -> do + bodyType <- + inferCanonicalCore + globalType + (binderType : binders) + body + Right (binderType `TyArrow` bodyType) + CFalsum -> + Right TyProp + CImp premise conclusion -> do + premiseType <- + inferCanonicalCore globalType binders premise + unless + (premiseType == TyProp) + (Left + (ImplicationOperandTypeMismatch + premiseType)) + conclusionType <- + inferCanonicalCore globalType binders conclusion + unless + (conclusionType == TyProp) + (Left + (ImplicationOperandTypeMismatch + conclusionType)) + Right TyProp + CEq operandType left right -> do + leftType <- + inferCanonicalCore globalType binders left + unless + (leftType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + leftType)) + rightType <- + inferCanonicalCore globalType binders right + unless + (rightType == operandType) + (Left + (EqualityOperandTypeMismatch + operandType + rightType)) + Right TyProp + CForall binderType body -> do + bodyType <- + inferCanonicalCore + globalType + (binderType : binders) + body + unless + (bodyType == TyProp) + (Left + (QuantifierBodyTypeMismatch bodyType)) + Right TyProp + +binderTypeAt :: Natural -> [CoreType] -> Maybe CoreType +binderTypeAt _index [] = + Nothing +binderTypeAt 0 (binderType : _rest) = + Just binderType +binderTypeAt index (_binderType : rest) = + binderTypeAt (index - 1) rest + +shiftCanonical + :: Natural + -> Natural + -> CanonicalTerm global + -> CanonicalTerm global +shiftCanonical amount cutoff = \case + CBound index + | index >= cutoff -> + CBound (index + amount) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (shiftCanonical amount cutoff function) + (shiftCanonical amount cutoff argument) + CLam binderType body -> + CLam binderType + (shiftCanonical amount (cutoff + 1) body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (shiftCanonical amount cutoff premise) + (shiftCanonical amount cutoff conclusion) + CEq operandType left right -> + CEq operandType + (shiftCanonical amount cutoff left) + (shiftCanonical amount cutoff right) + CForall binderType body -> + CForall binderType + (shiftCanonical amount (cutoff + 1) body) + +data FreezeError + = FreeLocalInClosedCore + deriving stock (Show, Eq) + +-- | Freeze a checked closed term in one traversal of the operational syntax. +freezeClosed + :: CheckedCore global Void + -> Either FreezeError (FrozenCheckedCore global) +freezeClosed (CheckedCore coreType syntax) = + FrozenCheckedCore coreType + <$> optimizedFreeze 0 rootResolver syntax + where + rootResolver _depth = + absurd + +-- | Bounded executable oracle for tests. Production code uses 'freezeClosed'. +referenceFreezeClosed + :: CheckedCore global Void + -> Either FreezeError (FrozenCheckedCore global) +referenceFreezeClosed (CheckedCore coreType syntax) = + FrozenCheckedCore coreType + <$> referenceFreeze 0 rootResolver syntax + where + rootResolver _depth = + absurd + +type VariableResolver local global = + Natural + -> local + -> Either FreezeError (CanonicalTerm global) + +optimizedFreeze + :: Natural + -> VariableResolver local global + -> CoreSyntax global local + -> Either FreezeError (CanonicalTerm global) +optimizedFreeze depth resolve = \case + CoreLocal local -> + resolve depth local + CoreGlobal global -> + Right (CGlobal global) + CoreIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + CoreOpaqueInteger integer -> + Right (COpaqueInteger integer) + CoreApply function argument -> + CApp + <$> optimizedFreeze depth resolve function + <*> optimizedFreeze depth resolve argument + CoreLambda binderType body -> + CLam binderType + <$> optimizedFreeze + (depth + 1) + (resolveGeneralized depth resolve) + (unscope body) + CoreFalsum -> + Right CFalsum + CoreImplication premise conclusion -> + CImp + <$> optimizedFreeze depth resolve premise + <*> optimizedFreeze depth resolve conclusion + CoreEquality operandType left right -> + CEq operandType + <$> optimizedFreeze depth resolve left + <*> optimizedFreeze depth resolve right + CoreForall binderType body -> + CForall binderType + <$> optimizedFreeze + (depth + 1) + (resolveGeneralized depth resolve) + (unscope body) + where + resolveGeneralized + :: Natural + -> VariableResolver local global + -> VariableResolver + (Var () (CoreSyntax global local)) + global + resolveGeneralized binderLevel outerResolve currentDepth = \case + B () -> + Right + (CBound + (currentDepth - binderLevel - 1)) + F outerSyntax -> + optimizedFreeze + currentDepth + outerResolve + outerSyntax + +referenceFreeze + :: Natural + -> VariableResolver local global + -> CoreSyntax global local + -> Either FreezeError (CanonicalTerm global) +referenceFreeze depth resolve = \case + CoreLocal local -> + resolve depth local + CoreGlobal global -> + Right (CGlobal global) + CoreIntrinsic intrinsic -> + Right (CIntrinsic intrinsic) + CoreOpaqueInteger integer -> + Right (COpaqueInteger integer) + CoreApply function argument -> + CApp + <$> referenceFreeze depth resolve function + <*> referenceFreeze depth resolve argument + CoreLambda binderType body -> + CLam binderType + <$> referenceFreeze + (depth + 1) + (resolveNormalized depth resolve) + (fromScope body) + CoreFalsum -> + Right CFalsum + CoreImplication premise conclusion -> + CImp + <$> referenceFreeze depth resolve premise + <*> referenceFreeze depth resolve conclusion + CoreEquality operandType left right -> + CEq operandType + <$> referenceFreeze depth resolve left + <*> referenceFreeze depth resolve right + CoreForall binderType body -> + CForall binderType + <$> referenceFreeze + (depth + 1) + (resolveNormalized depth resolve) + (fromScope body) + where + resolveNormalized + :: Natural + -> VariableResolver local global + -> VariableResolver (Var () local) global + resolveNormalized binderLevel outerResolve currentDepth = \case + B () -> + Right + (CBound + (currentDepth - binderLevel - 1)) + F outerLocal -> + outerResolve currentDepth outerLocal diff --git a/source/Felix/Checking/Datatype.hs b/source/Felix/Checking/Datatype.hs new file mode 100644 index 0000000..66e64db --- /dev/null +++ b/source/Felix/Checking/Datatype.hs @@ -0,0 +1,670 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Felix.Checking.Datatype + ( CheckedDatatype + , DatatypeValidationError + , datatypeValidationErrorLocation + , renderDatatypeValidationError + , prepareCheckedDatatype + , checkedDatatypeHeadSymbol + , checkedDatatypeConstructorSymbols + , CheckedDatatypeClauseView(..) + , CheckedDatatypePremiseView(..) + , checkedDatatypeClauseViews + , checkedDatatypeGeneratedFacts + ) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Internal +import Felix.Syntax.Lexicon + +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Data.Text qualified as Text + + +-- | A datatype whose premise domains have been canonicalized and validated. +data CheckedDatatype = CheckedDatatype + { checkedDatatypeHead :: !FunctionSymbol + , checkedDatatypeClauses :: !(NonEmpty CheckedDatatypeClause) + } + +data CheckedDatatypeClause = CheckedDatatypeClause + { checkedDatatypeClauseConstructor :: !FunctionSymbol + , checkedDatatypeClauseConstructorArgs :: ![VarSymbol] + , checkedDatatypeClausePremises :: ![CheckedDatatypePremise] + } + +-- Direct premises retain their canonical term for generated-fact locations. +data CheckedDatatypePremise + = RecursiveDatatypePremise !VarSymbol !Expr + | NonRecursiveDatatypePremise !VarSymbol !Expr + +data DatatypeValidationError + = InvalidDatatype !Text + | InvalidDatatypePremise !Location !Text + deriving (Show, Eq) + +datatypeValidationErrorLocation + :: DatatypeValidationError + -> Maybe Location +datatypeValidationErrorLocation = \case + InvalidDatatype _message -> Nothing + InvalidDatatypePremise location _message -> Just location + +renderDatatypeValidationError :: DatatypeValidationError -> Text +renderDatatypeValidationError = \case + InvalidDatatype message -> message + InvalidDatatypePremise _location message -> message + +data CanonicalDatatypeClause = CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor :: !SymbolPattern + , canonicalDatatypeClausePremises :: ![(VarSymbol, Location, Expr)] + } + +-- | Read-only normalized clause data for exact typed lowering. +data CheckedDatatypeClauseView = CheckedDatatypeClauseView + { checkedDatatypeClauseViewConstructor :: !FunctionSymbol + , checkedDatatypeClauseViewArguments :: ![VarSymbol] + , checkedDatatypeClauseViewPremises + :: ![CheckedDatatypePremiseView] + } deriving (Show, Eq) + +data CheckedDatatypePremiseView + = CheckedRecursiveDatatypePremise !VarSymbol !Expr + | CheckedNonRecursiveDatatypePremise !VarSymbol !Expr + deriving (Show, Eq) + +-- | Canonicalize every premise domain once, then validate the declaration. +prepareCheckedDatatype + :: Monad m + => (Expr -> m Expr) + -> Datatype + -> m (Either DatatypeValidationError CheckedDatatype) +prepareCheckedDatatype canonicalizeDomain Datatype{datatypeHead, datatypeClauses} = do + canonicalClauses <- traverse canonicalizeClause datatypeClauses + pure (validateDatatype datatypeHead canonicalClauses) + where + canonicalizeClause DatatypeClause + { datatypeClauseConstructor + , datatypeClausePremises + } = do + premises <- + traverse + (\(var, domain) -> + (\canonicalDomain -> + (var, exprLocation domain, canonicalDomain)) + <$> canonicalizeDomain domain) + datatypeClausePremises + pure + CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + datatypeClauseConstructor + , canonicalDatatypeClausePremises = premises + } + +validateDatatype + :: SymbolPattern + -> NonEmpty CanonicalDatatypeClause + -> Either DatatypeValidationError CheckedDatatype +validateDatatype + (SymbolPattern datatypeSymbol datatypeArgs) + datatypeClauses = do + require + (null datatypeArgs) + "datatype head must be nullary" + let constructorSymbols = + [ constructorSymbol + | CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + SymbolPattern constructorSymbol _ + } <- NonEmpty.toList datatypeClauses + ] + duplicateConstructors = + duplicateDatatypeConstructorSymbols constructorSymbols + require + (Set.null duplicateConstructors) + ( "datatype constructor patterns must be distinct: " + <> formatDatatypeConstructors duplicateConstructors + ) + checkedDatatypeClauses <- + traverse (validateDatatypeClause datatypeSymbol) datatypeClauses + pure + CheckedDatatype + { checkedDatatypeHead = datatypeSymbol + , checkedDatatypeClauses + } + +validateDatatypeClause + :: FunctionSymbol + -> CanonicalDatatypeClause + -> Either DatatypeValidationError CheckedDatatypeClause +validateDatatypeClause + datatypeSymbol + CanonicalDatatypeClause + { canonicalDatatypeClauseConstructor = + SymbolPattern constructorSymbol constructorArgs + , canonicalDatatypeClausePremises + } = do + require + (constructorSymbol /= ApplySymbol) + "datatype constructor cannot be function application" + require + (constructorSymbol /= datatypeSymbol) + "datatype constructor cannot reuse the datatype symbol" + let duplicateConstructorArgs = duplicateVars constructorArgs + require + (Set.null duplicateConstructorArgs) + ( "datatype constructor arguments must be linear: " + <> formatVars duplicateConstructorArgs + ) + let premiseVars = + (\(variable, _location, _domain) -> variable) + <$> canonicalDatatypeClausePremises + duplicatePremiseVars = duplicateVars premiseVars + require + (Set.null duplicatePremiseVars) + ( "datatype premise variables must be linear: " + <> formatVars duplicatePremiseVars + ) + let missingPremises = + Set.fromList constructorArgs + `Set.difference` Set.fromList premiseVars + require + (Set.null missingPremises) + ( "datatype constructor argument(s) missing premise: " + <> formatVars missingPremises + ) + checkedDatatypeClausePremises <- + traverse + (validateDatatypePremise datatypeSymbol) + canonicalDatatypeClausePremises + pure + CheckedDatatypeClause + { checkedDatatypeClauseConstructor = constructorSymbol + , checkedDatatypeClauseConstructorArgs = constructorArgs + , checkedDatatypeClausePremises = + checkedDatatypeClausePremises + } + +validateDatatypePremise + :: FunctionSymbol + -> (VarSymbol, Location, Expr) + -> Either DatatypeValidationError CheckedDatatypePremise +validateDatatypePremise datatypeSymbol (var, location, domain) = do + let domainFreeVars = freeVars domain + requirePremise location + (Set.null domainFreeVars) + ( "datatype premise domains must be closed terms: " + <> formatVars domainFreeVars + ) + if equivalent domain datatypeCarrier + then + Right (RecursiveDatatypePremise var domain) + else do + requirePremise location + ( SymbolMixfix datatypeSymbol + `Set.notMember` mentionedSymbols domain + ) + "datatype recursive premise must be direct" + Right (NonRecursiveDatatypePremise var domain) + where + datatypeCarrier = + TermSymbol Nowhere (SymbolMixfix datatypeSymbol) [] + +require :: Bool -> Text -> Either DatatypeValidationError () +require condition message + | condition = + Right () + | otherwise = + Left (InvalidDatatype message) + +requirePremise + :: Location + -> Bool + -> Text + -> Either DatatypeValidationError () +requirePremise location condition message + | condition = + Right () + | otherwise = + Left (InvalidDatatypePremise location message) + +checkedDatatypeHeadSymbol :: CheckedDatatype -> Symbol +checkedDatatypeHeadSymbol = + SymbolMixfix . checkedDatatypeHead + +checkedDatatypeConstructorSymbols + :: CheckedDatatype + -> NonEmpty Symbol +checkedDatatypeConstructorSymbols = + fmap + (SymbolMixfix . checkedDatatypeClauseConstructor) + . checkedDatatypeClauses + +checkedDatatypeClauseViews + :: CheckedDatatype + -> NonEmpty CheckedDatatypeClauseView +checkedDatatypeClauseViews = + fmap clauseView . checkedDatatypeClauses + where + clauseView clause = + CheckedDatatypeClauseView + { checkedDatatypeClauseViewConstructor = + checkedDatatypeClauseConstructor clause + , checkedDatatypeClauseViewArguments = + checkedDatatypeClauseConstructorArgs clause + , checkedDatatypeClauseViewPremises = + premiseView + <$> checkedDatatypeClausePremises clause + } + + premiseView = \case + RecursiveDatatypePremise variable domain -> + CheckedRecursiveDatatypePremise variable domain + NonRecursiveDatatypePremise variable domain -> + CheckedNonRecursiveDatatypePremise variable domain + +checkedDatatypeGeneratedFacts + :: CheckedDatatype + -> NonEmpty (Marker, Formula) +checkedDatatypeGeneratedFacts = + datatypeFacts + +datatypeFacts :: CheckedDatatype -> NonEmpty (Marker, Formula) +datatypeFacts datatype = + appendList + (datatypeIntroFacts datatype) + ( datatypeDistinctFacts datatype + <> datatypeInjectiveFacts datatype + <> [ ( datatypeCasesMarker datatype + , datatypeCasesFormula datatype + ) + , ( datatypeInductMarker datatype + , datatypeInductFormula datatype + ) + ] + ) + where + appendList (first :| rest) trailing = + first :| (rest <> trailing) + +datatypeIntroFacts :: CheckedDatatype -> NonEmpty (Marker, Formula) +datatypeIntroFacts datatype = + fmap + (\clause -> + ( datatypeIntroMarker datatype clause + , datatypeIntroFormula datatype clause + )) + (checkedDatatypeClauses datatype) + +datatypeDistinctFacts :: CheckedDatatype -> [(Marker, Formula)] +datatypeDistinctFacts datatype = + [ ( datatypeDistinctMarker datatype leftClause rightClause + , datatypeDistinctFormula leftClause rightClause + ) + | (leftClause, rightClause) <- + unorderedPairs + (NonEmpty.toList (checkedDatatypeClauses datatype)) + ] + +datatypeInjectiveFacts :: CheckedDatatype -> [(Marker, Formula)] +datatypeInjectiveFacts datatype = + [ ( datatypeInjectiveMarker datatype clause + , datatypeInjectiveFormula clause + ) + | clause <- NonEmpty.toList (checkedDatatypeClauses datatype) + , not (null (checkedDatatypeClauseConstructorArgs clause)) + ] + +datatypeIntroMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> Marker +datatypeIntroMarker datatype clause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText clause + <> "_intro" + ) + +datatypeDistinctMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> CheckedDatatypeClause + -> Marker +datatypeDistinctMarker datatype leftClause rightClause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText leftClause + <> "_" + <> datatypeClauseSymbolText rightClause + <> "_distinct" + ) + +datatypeInjectiveMarker + :: CheckedDatatype + -> CheckedDatatypeClause + -> Marker +datatypeInjectiveMarker datatype clause = + Marker + ( datatypeFactBase datatype + <> "_" + <> datatypeClauseSymbolText clause + <> "_injective" + ) + +datatypeCasesMarker :: CheckedDatatype -> Marker +datatypeCasesMarker datatype = + Marker (datatypeFactBase datatype <> "_cases") + +datatypeInductMarker :: CheckedDatatype -> Marker +datatypeInductMarker datatype = + Marker (datatypeFactBase datatype <> "_induct") + +datatypeFactBase :: CheckedDatatype -> Text +datatypeFactBase = + functionSymbolText . checkedDatatypeHead + +datatypeIntroFormula + :: CheckedDatatype + -> CheckedDatatypeClause + -> Formula +datatypeIntroFormula datatype clause = + forallIfNeeded premiseVars (impliesFrom premises conclusion) + where + premiseVars = datatypeClausePremiseVars clause + premises = datatypeClausePremiseFormulas clause + conclusion = datatypeClauseResultFormula datatype clause + +datatypeDistinctFormula + :: CheckedDatatypeClause + -> CheckedDatatypeClause + -> Formula +datatypeDistinctFormula leftClause rightClause = + forallIfNeeded + (leftVars <> rightVars) + (NotEquals Nowhere leftTerm rightTerm) + where + leftVars = checkedDatatypeClauseConstructorArgs leftClause + rightVars = + renameDatatypeVars + (Set.fromList leftVars) + (checkedDatatypeClauseConstructorArgs rightClause) + leftTerm = datatypeClauseTerm leftClause (TermVar <$> leftVars) + rightTerm = datatypeClauseTerm rightClause (TermVar <$> rightVars) + +datatypeInjectiveFormula :: CheckedDatatypeClause -> Formula +datatypeInjectiveFormula clause = + forallIfNeeded + (leftVars <> rightVars) + ( Equals Nowhere leftTerm rightTerm + `Implies` makeConjunction equalities + ) + where + leftVars = checkedDatatypeClauseConstructorArgs clause + rightVars = renameDatatypeVars (Set.fromList leftVars) leftVars + leftTerm = datatypeClauseTerm clause (TermVar <$> leftVars) + rightTerm = datatypeClauseTerm clause (TermVar <$> rightVars) + equalities = + zipWith + (\leftVar rightVar -> + Equals Nowhere (TermVar leftVar) (TermVar rightVar)) + leftVars + rightVars + +datatypeCasesFormula :: CheckedDatatype -> Formula +datatypeCasesFormula datatype = + makeForall + [witnessVar] + ( isElementOf (TermVar witnessVar) datatypeCarrier + `Implies` makeDisjunction disjuncts + ) + where + usedVars = datatypeUsedVars datatype + witnessVar = freshDatatypeVar usedVars "x" + datatypeCarrier = datatypeCarrierTerm datatype + disjuncts = + datatypeCaseDisjunct witnessVar + <$> NonEmpty.toList (checkedDatatypeClauses datatype) + datatypeCaseDisjunct var clause = + existsIfNeeded + premiseVars + ( makeConjunction + ( premises + <> [ Equals + Nowhere + (TermVar var) + constructorTerm + ] + ) + ) + where + premiseVars = datatypeClausePremiseVars clause + premises = datatypeClausePremiseFormulas clause + constructorTerm = + datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + +datatypeInductFormula :: CheckedDatatype -> Formula +datatypeInductFormula datatype = + makeForall + [subsetVar] + (impliesFrom closureAssumptions conclusion) + where + usedVars = datatypeUsedVars datatype + subsetVar = freshDatatypeVar usedVars "S" + witnessVar = freshDatatypeVar (Set.insert subsetVar usedVars) "x" + datatypeCarrier = datatypeCarrierTerm datatype + conclusion = + makeForall + [witnessVar] + ( isElementOf (TermVar witnessVar) datatypeCarrier + `Implies` isElementOf + (TermVar witnessVar) + (TermVar subsetVar) + ) + closureAssumptions = + datatypeInductionClosure subsetVar + <$> NonEmpty.toList (checkedDatatypeClauses datatype) + +datatypeInductionClosure + :: VarSymbol + -> CheckedDatatypeClause + -> Formula +datatypeInductionClosure subsetVar clause = + forallIfNeeded + premiseVars + (impliesFrom inductionPremises conclusion) + where + premiseVars = datatypeClausePremiseVars clause + inductionPremises = + datatypeInductionPremise subsetVar + <$> checkedDatatypeClausePremises clause + conclusion = + isElementOf + ( datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + ) + (TermVar subsetVar) + +datatypeInductionPremise + :: VarSymbol + -> CheckedDatatypePremise + -> Formula +datatypeInductionPremise subsetVar = \case + RecursiveDatatypePremise var _canonicalDomain -> + isElementOf (TermVar var) (TermVar subsetVar) + NonRecursiveDatatypePremise var domain -> + isElementOf (TermVar var) domain + +datatypeCarrierTerm :: CheckedDatatype -> Expr +datatypeCarrierTerm datatype = + TermSymbol + Nowhere + (SymbolMixfix (checkedDatatypeHead datatype)) + [] + +datatypeClauseResultFormula + :: CheckedDatatype + -> CheckedDatatypeClause + -> Formula +datatypeClauseResultFormula datatype clause = + isElementOf + ( datatypeClauseTerm + clause + (TermVar <$> checkedDatatypeClauseConstructorArgs clause) + ) + (datatypeCarrierTerm datatype) + +datatypeClauseTerm :: CheckedDatatypeClause -> [Expr] -> Expr +datatypeClauseTerm clause args = + TermSymbol + Nowhere + (SymbolMixfix (checkedDatatypeClauseConstructor clause)) + args + +datatypeClausePremiseVars :: CheckedDatatypeClause -> [VarSymbol] +datatypeClausePremiseVars = + fmap datatypePremiseVar . checkedDatatypeClausePremises + +datatypeClausePremiseFormulas + :: CheckedDatatypeClause + -> [Formula] +datatypeClausePremiseFormulas = + fmap datatypePremiseFormula + . checkedDatatypeClausePremises + +datatypePremiseFormula + :: CheckedDatatypePremise + -> Formula +datatypePremiseFormula = \case + RecursiveDatatypePremise var canonicalDomain -> + isElementOf (TermVar var) canonicalDomain + NonRecursiveDatatypePremise var domain -> + isElementOf (TermVar var) domain + +datatypePremiseVar :: CheckedDatatypePremise -> VarSymbol +datatypePremiseVar = \case + RecursiveDatatypePremise var _canonicalDomain -> + var + NonRecursiveDatatypePremise var _domain -> + var + +datatypeClauseSymbolText :: CheckedDatatypeClause -> Text +datatypeClauseSymbolText = + functionSymbolText . checkedDatatypeClauseConstructor + +functionSymbolText :: FunctionSymbol -> Text +functionSymbolText symbol = + case mixfixMarker symbol of + Marker name -> + name + +datatypeUsedVars :: CheckedDatatype -> Set VarSymbol +datatypeUsedVars datatype = + Set.fromList + [ var + | clause <- NonEmpty.toList (checkedDatatypeClauses datatype) + , var <- datatypeClausePremiseVars clause + ] + +duplicateDatatypeConstructorSymbols + :: [FunctionSymbol] + -> Set FunctionSymbol +duplicateDatatypeConstructorSymbols = + snd . foldl' step (Set.empty, Set.empty) + where + step (seen, duplicates) symbol + | symbol `Set.member` seen = + (seen, Set.insert symbol duplicates) + | otherwise = + (Set.insert symbol seen, duplicates) + +duplicateVars :: [VarSymbol] -> Set VarSymbol +duplicateVars = + snd . foldl' step (Set.empty, Set.empty) + where + step (seen, duplicates) var + | var `Set.member` seen = + (seen, Set.insert var duplicates) + | otherwise = + (Set.insert var seen, duplicates) + +formatDatatypeConstructors :: Set FunctionSymbol -> Text +formatDatatypeConstructors symbols = + Text.intercalate + ", " + (functionSymbolText <$> Set.toList symbols) + +formatVars :: Set VarSymbol -> Text +formatVars vars = + Text.intercalate ", " (formatVar <$> Set.toList vars) + +formatVar :: VarSymbol -> Text +formatVar = \case + NamedVar name -> + name + FreshVar index -> + "_" <> Text.pack (show index) + +renameDatatypeVars :: Set VarSymbol -> [VarSymbol] -> [VarSymbol] +renameDatatypeVars _used [] = + [] +renameDatatypeVars used (var:vars) = + let renamed = freshDatatypeLikeVar used var + in renamed : renameDatatypeVars (Set.insert renamed used) vars + +freshDatatypeLikeVar :: Set VarSymbol -> VarSymbol -> VarSymbol +freshDatatypeLikeVar used = \case + NamedVar name -> + freshDatatypeVar used (name <> "_rhs") + FreshVar index -> + freshDatatypeVar + used + ("_" <> Text.pack (show index) <> "_rhs") + +freshDatatypeVar :: Set VarSymbol -> Text -> VarSymbol +freshDatatypeVar used base = + List.head + [ NamedVar candidate + | candidate <- + base + : [ base <> Text.pack (show index) + | index <- [(1 :: Int) ..] + ] + , NamedVar candidate `Set.notMember` used + ] + +forallIfNeeded :: [VarSymbol] -> Formula -> Formula +forallIfNeeded [] formula = + formula +forallIfNeeded vars formula = + makeForall vars formula + +existsIfNeeded :: [VarSymbol] -> Formula -> Formula +existsIfNeeded [] formula = + formula +existsIfNeeded vars formula = + makeExists vars formula + +impliesFrom :: [Formula] -> Formula -> Formula +impliesFrom [] conclusion = + conclusion +impliesFrom premises conclusion = + makeConjunction premises `Implies` conclusion + +unorderedPairs :: [a] -> [(a, a)] +unorderedPairs = \case + [] -> + [] + value:rest -> + [(value, other) | other <- rest] + <> unorderedPairs rest diff --git a/source/Felix/Checking/Declaration.hs b/source/Felix/Checking/Declaration.hs new file mode 100644 index 0000000..15050c7 --- /dev/null +++ b/source/Felix/Checking/Declaration.hs @@ -0,0 +1,6770 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Builder-confined authorization and atomic typed declaration append. +module Felix.Checking.Declaration + ( ModuleDriver + , DriverFailure(..) + , DriverResult(..) + , ImportedModuleEvidence + , ImportedAliasOrigin(..) + , freshImportedModuleEvidence + , validateImportedModuleEvidence + , importSealedModule + , importSealedModuleDriver + , nextDeclarationSlotDriver + , currentTheoryDriver + , currentFoundationAxiomDriver + , resolveVisibleFactAliasDriver + , resolveVisibleFactTargetsDriver + , resolveVisibleGlobalDriver + , resolveVisibleGlobalContentDriver + , ResolvedStructure + , resolvedStructureDescriptor + , resolvedStructurePredicate + , resolvedStructureOperation + , resolvedStructureOperations + , resolveVisibleStructureDriver + , resolveVisibleStructureOperationObjectsDriver + , objectAvailableDriver + , objectTypeDriver + , LoweringDriver + , runProspectiveLoweringDriver + , nextDeclarationSlotLowering + , currentTheoryLowering + , currentFoundationLowering + , currentFoundationAxiomLowering + , resolveVisibleFactAliasLowering + , resolveVisibleFactTargetsLowering + , resolveVisibleGlobalLowering + , resolveVisibleGlobalContentLowering + , resolveVisibleStructureLowering + , resolveVisibleStructureOperationObjectsLowering + , objectAvailableLowering + , objectTypeLowering + , runModuleDriver + , ValidationLookup + , validationLookup + , ValidationRun(..) + , failModuleDriver + , failDeclarationDriver + , VampireResolver + , VampireSubmission(..) + , vampireBatchResolver + , vampireResolver + , vampireSubmissionResolver + , Declaration + , failDeclaration + , addDeclarationObject + , addDeclarationProposition + , resolveVisibleGlobal + , stageSemanticGlobalBinding + , stageSemanticStructureDescriptor + , CandidateSpec + , candidateSpec + , CandidatePlanningSpec + , CheckedCandidate + , checkedCandidate + , checkedDefinitionEquationPlanning + , checkedSourceAxiomPlanning + , checkedDatatypePlanning + , checkedKernelPlanning + , checkedKernelPlanningWithStaged + , checkedStagedKernelPlanning + , checkedSourceProofPlanning + , checkedOmittedPlanning + , CheckedPlannedVampireRequest + , checkedPlannedVampireRequest + , plannedEarlierCandidate + , CheckedDeclaration + , checkedProofDeclaration + , checkedCompiledDeclaration + , admitCheckedDeclaration + , PlannedDeclaration + , planCheckedDeclaration + , admitPlannedCheckedDeclaration + , plannedDeclarationPreviousPrefix + , plannedDeclarationNextPrefix + , plannedDeclarationDelta + , PlanningIntegrityError(..) + , prepareCandidateSpecDriver + , prepareFrozenCandidateSpecDriver + , prepareDefinitionEquationSpecDriver + , preparePointwiseDefinitionEquationSpecDriver + , prepareStagedCandidateVampireDriver + , prepareCandidateSpecLowering + , prepareFrozenCandidateSpecLowering + , prepareDefinitionEquationSpecLowering + , prepareDefinitionEquationSpecWithEligibilityLowering + , prepareNamedSetConstructionSpecLowering + , prepareRelationalSetConstructionSpecLowering + , preparePointwiseDefinitionEquationSpecLowering + , prepareStagedCandidateVampireLowering + , ReservedCandidate + , reserveCandidate + , reserveCandidateBatch + , reservePropositionCandidate + , reserveFrozenPropositionCandidateBatch + , reserveDefinitionEquationCandidate + , reservePointwiseDefinitionEquationCandidate + , reserveDefinitionEquationCandidateBatch + , reservedCandidateSlot + , reservedCandidateStage + , CandidateProof + , locateProofObligation + , recordOmittedUse + , VampirePremiseSelection(..) + , VampireObligationPreparationError(..) + , ScopedVampirePremise + , scopedVampirePremise + , PreparedVampireObligation + , prepareScopedVampireObligationDriver + , prepareScopedContradictionObligationDriver + , prepareScopedVampireObligationLowering + , prepareScopedContradictionObligationLowering + , useAuthorizedFact + , useStagedCandidate + , LocalClaim + , proveLocalKernelClaim + , useLocalClaim + , authorizeKernelProofCandidate + , authorizeKernelConstructionCandidate + , authorizeDefinitionEquationCandidate + , authorizeNamedSetConstructionCandidate + , authorizeRelationalSetConstructionCandidate + , acceptVampireObligation + , acceptPreparedVampireObligation + , acceptCurrentCandidateVampire + , prepareCurrentCandidateVampire + , authorizeVampireCandidate + , authorizeVampireCandidateBatch + , authorizeSourceAxiomCandidate + , authorizeOmittedCandidate + , authorizeDatatypeCompilationCandidates + , authorizeCompiledDeclaration + , commitProofDeclaration + , commitCompiledDeclaration + , CommittedDeclarationBatch + , committedBatchOwner + , committedBatchSlot + , committedBatchPreviousPrefix + , committedBatchNextPrefix + , committedBatchDelta + , committedBatchObjects + , committedBatchPropositions + , committedBatchProofValidations + , committedBatchDeclarationValidation + , PendingModulePrefix + , emptyPendingModulePrefix + , pendingModulePrefixBatches + , pendingModulePrefixCurrent + , ValidationIntegrityError(..) + , renderValidationIntegrityError + , DeclarationError(..) + , declarationErrorLocation + , renderDeclarationError + , DriverOpenError(..) + , renderDriverOpenError + ) where + +import Base +import Felix.Cache.Codec (encodeCache) +import Felix.Checking.Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Backend.Tptp qualified as Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction +import Felix.Module +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract (StructSymbol) + +import Control.Exception qualified as Exception +import Control.DeepSeq (deepseq) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, mapMaybe) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Unique (Unique, newUnique) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +newtype BuilderIdentity = BuilderIdentity Unique + deriving stock (Eq) + +newtype DeclarationInvocation = DeclarationInvocation Natural + deriving stock (Eq) + +newtype CandidateStage = CandidateStage Natural + deriving stock (Show, Eq, Ord) + +data ValidationLookup = ValidationLookup + !(ProofValidationKey -> IO (Maybe ProofValidationRecord)) + !(DeclarationValidationKey + -> IO (Maybe DeclarationValidationRecord)) + +validationLookup + :: (ProofValidationKey -> IO (Maybe ProofValidationRecord)) + -> (DeclarationValidationKey + -> IO (Maybe DeclarationValidationRecord)) + -> ValidationLookup +validationLookup = + ValidationLookup + +data ValidationRun + = FreshValidation + | WarmValidation !ValidationLookup + +data ValidationIntegrityError + = CachedValidationIntegrityError + !Materialization.MaterializationError + deriving stock (Show, Eq) + +instance Exception.Exception ValidationIntegrityError + +renderValidationIntegrityError :: ValidationIntegrityError -> Text +renderValidationIntegrityError = \case + CachedValidationIntegrityError failure -> + "cached validation does not match its exact contextual input: " + <> Text.pack (show failure) + + +data BuilderFactAuthorization = BuilderFactAuthorization + !BuilderIdentity + !FactSlot + !FactAuthority + +data PendingFactAuthorization = PendingFactAuthorization + !BuilderIdentity + !PrefixContextId + !DeclarationInvocation + !FactSlot + !FactAuthority + !CandidateStage + +-- | Checked fact semantics paired with caller-selected evidence. Semantic +-- lookup and request preparation deliberately ignore the evidence parameter; +-- only the admitted builder instantiation may consume capabilities. +data FactEntry evidence = FactEntry + !CheckedPropositionContent + !SemanticFactOccurrence + !evidence + +-- | The shared checked semantic state. The evidence parameter makes the +-- distinction between admitted authority and future inert planning data +-- visible without duplicating lookup, collision, closure, or delta logic. +data BuilderState evidence = BuilderState + { logicalBuilderIdentity :: !BuilderIdentity + , logicalBuilderFoundation :: !CheckedFoundation + , logicalBuilderTheory :: !TheoryId + , logicalBuilderOwner :: !ModuleName + , logicalBuilderDirectSemanticInputs :: ![SemanticInterfaceId] + , logicalBuilderPrefix :: !PrefixContextId + , logicalBuilderObjectClosure :: !CheckedObjectClosure + , logicalBuilderFacts + :: !(Map + SemanticFactOccurrenceFingerprint + (FactEntry evidence)) + , logicalBuilderAliases + :: !(Map SemanticName ImportedAliasBinding) + , logicalBuilderGlobals + :: !(Map SemanticGlobalKey SemanticGlobalTarget) + , logicalBuilderStructures + :: !(Map SemanticStructurePhrase ResolvedStructure) + , logicalBuilderImportedInterfaces :: !(Set SemanticInterfaceId) + , logicalBuilderDeltas :: ![DeclarationInterfaceDelta] + , logicalBuilderNextDeclaration :: !Natural + , logicalBuilderNextFact :: !Natural + , logicalBuilderNextInvocation :: !Natural + } + +-- | The only production builder in this milestone. Capability-consuming +-- operations below accept this admitted instantiation, never a polymorphic +-- 'BuilderState'. +type LogicalBuilder = BuilderState BuilderFactAuthorization + +-- | Public semantic contract and strict declaration-stage provenance for a +-- prospective fact. It deliberately contains no builder identity, prefix, +-- declaration invocation, pending authorization, or minting capability. +data PlanningProvenance = PlanningProvenance + !DeclarationSlot + !CandidateStage + !FactSlot + deriving stock (Eq) + +data PlanningEvidence = PlanningEvidence + !FactAuthority + !(Maybe PlanningProvenance) + +data ResolvedStructureOperation = ResolvedStructureOperation + !ObjectId + !SemanticStructurePhrase + deriving stock (Show, Eq) + +data ResolvedStructure = ResolvedStructure + !SemanticStructureDescriptor + !(Set SemanticStructurePhrase) + !(Map StructSymbol ResolvedStructureOperation) + deriving stock (Show, Eq) + +resolvedStructureDescriptor + :: ResolvedStructure + -> SemanticStructureDescriptor +resolvedStructureDescriptor (ResolvedStructure descriptor _ _) = + descriptor + +resolvedStructurePredicate :: ResolvedStructure -> Maybe ObjectId +resolvedStructurePredicate = + semanticStructureDescriptorPredicate . resolvedStructureDescriptor + +resolvedStructureOperation + :: StructSymbol + -> ResolvedStructure + -> Maybe ObjectId +resolvedStructureOperation symbol (ResolvedStructure _ _ operations) = + operationObject <$> Map.lookup symbol operations + where + operationObject (ResolvedStructureOperation object _origin) = object + +resolvedStructureOperations + :: ResolvedStructure + -> Map StructSymbol ObjectId +resolvedStructureOperations (ResolvedStructure _ _ operations) = + operationObject <$> operations + where + operationObject (ResolvedStructureOperation object _origin) = object + +structureOperationBindings + :: Map SemanticStructurePhrase ResolvedStructure + -> Set (StructSymbol, ObjectId) +structureOperationBindings structures = + Set.fromList + [ (symbol, object) + | structure <- Map.elems structures + , (symbol, object) <- + Map.toAscList (resolvedStructureOperations structure) + ] + + +data CommittedDeclarationBatch = CommittedDeclarationBatch + !ModuleName + !DeclarationSlot + !PrefixContextId + !PrefixContextId + !DeclarationInterfaceDelta + ![AssertedObject] + ![CheckedPropositionContent] + ![ProofValidationRecord] + !(Maybe DeclarationValidationRecord) + +committedBatchOwner :: CommittedDeclarationBatch -> ModuleName +committedBatchOwner + (CommittedDeclarationBatch owner _ _ _ _ _ _ _ _) = + owner + +committedBatchSlot + :: CommittedDeclarationBatch + -> DeclarationSlot +committedBatchSlot + (CommittedDeclarationBatch _ slot _ _ _ _ _ _ _) = + slot + +committedBatchPreviousPrefix + :: CommittedDeclarationBatch + -> PrefixContextId +committedBatchPreviousPrefix + (CommittedDeclarationBatch _ _ previous _ _ _ _ _ _) = + previous + +committedBatchNextPrefix + :: CommittedDeclarationBatch + -> PrefixContextId +committedBatchNextPrefix + (CommittedDeclarationBatch _ _ _ next _ _ _ _ _) = + next + +committedBatchDelta + :: CommittedDeclarationBatch + -> DeclarationInterfaceDelta +committedBatchDelta + (CommittedDeclarationBatch _ _ _ _ delta _ _ _ _) = + delta + +committedBatchObjects + :: CommittedDeclarationBatch + -> [AssertedObject] +committedBatchObjects + (CommittedDeclarationBatch _ _ _ _ _ objects _ _ _) = + objects + +committedBatchPropositions + :: CommittedDeclarationBatch + -> [CheckedPropositionContent] +committedBatchPropositions + (CommittedDeclarationBatch _ _ _ _ _ _ propositions _ _) = + propositions + +committedBatchProofValidations + :: CommittedDeclarationBatch + -> [ProofValidationRecord] +committedBatchProofValidations + (CommittedDeclarationBatch _ _ _ _ _ _ _ validations _) = + validations + +committedBatchDeclarationValidation + :: CommittedDeclarationBatch + -> Maybe DeclarationValidationRecord +committedBatchDeclarationValidation + (CommittedDeclarationBatch _ _ _ _ _ _ _ _ validation) = + validation + + +data PendingModulePrefix = PendingModulePrefix + !PrefixContextId + ![CommittedDeclarationBatch] + +emptyPendingModulePrefix + :: PrefixContextId + -> PendingModulePrefix +emptyPendingModulePrefix prefix = + PendingModulePrefix prefix [] + +instance Show PendingModulePrefix where + show prefix = + "PendingModulePrefix {pendingModulePrefixCurrent = " + <> show (pendingModulePrefixCurrent prefix) + <> ", pendingModulePrefixBatchCount = " + <> show (length (pendingModulePrefixBatches prefix)) + <> "}" + +pendingModulePrefixBatches + :: PendingModulePrefix + -> [CommittedDeclarationBatch] +pendingModulePrefixBatches + (PendingModulePrefix _ batchesReversed) = + reverse batchesReversed + +pendingModulePrefixCurrent + :: PendingModulePrefix + -> PrefixContextId +pendingModulePrefixCurrent + (PendingModulePrefix prefix _batches) = + prefix + +appendPendingBatch + :: CommittedDeclarationBatch + -> PendingModulePrefix + -> PendingModulePrefix +appendPendingBatch batch (PendingModulePrefix _ batches) = + forceCommittedBatch batch `seq` + PendingModulePrefix + (committedBatchNextPrefix batch) + (batch : batches) + +forceCommittedBatch :: CommittedDeclarationBatch -> () +forceCommittedBatch + (CommittedDeclarationBatch + owner slot previous next delta objects propositions + proofValidations declarationValidation) = + owner `seq` + slot `seq` + previous `seq` + next `seq` + ByteString.length + (encodeCache (putDeclarationInterfaceDeltaCache delta)) `seq` + objects `deepseq` + propositions `deepseq` + forceProofValidations proofValidations `seq` + forceDeclarationValidation declarationValidation + where + forceProofValidations = + foldl' + (\() record -> + proofValidationRecordKey record `seq` + ByteString.length + (encodeCache + (putValidationCertificateCache + (proofValidationRecordCertificate + record))) `seq` ()) + () + + forceDeclarationValidation = \case + Nothing -> () + Just record -> + declarationValidationRecordKey record `seq` + foldl' + (\() certificate -> + ByteString.length + (encodeCache + (putValidationCertificateCache + certificate)) `seq` ()) + () + (declarationValidationRecordCertificates record) + + +data VampireResolverMode + = SynchronousVampireResolution + (forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer))) + | AsynchronousVampireSubmission + (NonEmpty VampireSubmission + -> IO (NonEmpty Provers.VampireHandle)) + +data VampireResolver = VampireResolver !VampireResolverMode + +data VampireSubmission = VampireSubmission + !Location + !Provers.PreparedVerificationRequest + +vampireBatchResolver + :: (forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer))) + -> VampireResolver +vampireBatchResolver resolve = + VampireResolver (SynchronousVampireResolution resolve) + +-- | Production submission-only resolver. Retained-plan admission consumes +-- the submitted handles through its private synchronous replay resolver. +vampireSubmissionResolver + :: (NonEmpty VampireSubmission + -> IO (NonEmpty Provers.VampireHandle)) + -> VampireResolver +vampireSubmissionResolver submit = + VampireResolver (AsynchronousVampireSubmission submit) + +vampireResolver + :: (forall local origin. + Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + -> VampireResolver +vampireResolver resolve = + vampireBatchResolver (traverse resolve) + +resolveOneVampire + :: VampireResolver + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> ExceptT DeclarationError IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer) +resolveOneVampire resolver prepared = do + results@(result :| _) <- + liftIO (resolveSynchronousVampireBatch resolver (prepared :| [])) + void + (Except.liftEither + (validateVampireResolverResultCount 1 results)) + pure result + +resolveSynchronousVampireBatch + :: VampireResolver + -> NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) +resolveSynchronousVampireBatch + (VampireResolver mode) tasks = + case mode of + SynchronousVampireResolution resolve -> resolve tasks + AsynchronousVampireSubmission{} -> + throwIO + (PlanningIntegrityError + "asynchronous Vampire resolver reached synchronous admission") + +validateVampireResolverResultCount + :: Int + -> NonEmpty value + -> Either DeclarationError [value] +validateVampireResolverResultCount expected results + | expected == actual = + Right (NonEmpty.toList results) + | otherwise = + Left (VampireResolverBatchSizeMismatch expected actual) + where + actual = NonEmpty.length results + +data DriverState = DriverState + !VampireResolver + !LogicalBuilder + !PendingModulePrefix + !ValidationRun + +-- | Authority-free semantic state used while lowering checked declarations. +-- Existing admitted facts are projected to their public contracts; no +-- builder-local authorization capability crosses this boundary. +newtype ProspectiveBuilder = ProspectiveBuilder + (BuilderState PlanningEvidence) + +data LoweringState = LoweringState + !VampireResolver + !ProspectiveBuilder + !ValidationRun + +newtype LoweringDriver value = LoweringDriver + { runLoweringStep :: StateT LoweringState IO value + } + deriving newtype (Functor, Applicative, Monad) + +newtype ModuleDriver failure value = ModuleDriver + { runDriverStep + :: ExceptT + (DriverFailure failure) + (StateT DriverState IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +-- | Run one complete authority-free planning action from the current admitted +-- input projection. The prospective state advances throughout the action but +-- never mutates the authoritative module builder. +runProspectiveLoweringDriver + :: LoweringDriver value + -> ModuleDriver failure value +runProspectiveLoweringDriver action = ModuleDriver do + DriverState resolver builder _prefix validation <- State.get + State.lift + (liftIO + (State.evalStateT + (runLoweringStep action) + (LoweringState resolver + (projectLogicalBuilder builder) + validation))) + +projectLogicalBuilder :: LogicalBuilder -> ProspectiveBuilder +projectLogicalBuilder builder = + ProspectiveBuilder + builder + { logicalBuilderFacts = + fmap projectFact (logicalBuilderFacts builder) + } + where + projectFact (FactEntry proposition occurrence _authorization) = + FactEntry proposition occurrence + (PlanningEvidence + (semanticFactAuthority occurrence) + Nothing) + +data DriverFailure failure + = DriverDeclarationFailed !DeclarationError + | DriverActionFailed !failure + deriving stock (Show, Eq) + +data DriverResult failure value + = DriverSucceeded + !value + !SemanticInterface + !PendingModulePrefix + !CheckedObjectClosure + | DriverFailed + !(DriverFailure failure) + !PendingModulePrefix + | DriverSealFailed + !SemanticInterfaceError + !PendingModulePrefix + +data ImportedAliasOrigin = ImportedAliasOrigin + !DeclarationSlot + !SemanticFactOccurrenceFingerprint + deriving stock (Show, Eq) + +data ImportedAliasBinding = ImportedAliasBinding + !SemanticFactOccurrenceFingerprint + !ImportedAliasOrigin + +-- | Opaque evidence produced from a successfully sealed producer. Direct +-- parents retain the semantic DAG; importing folds it deterministically and +-- mints fresh authority for the consuming builder. +data ImportedModuleEvidence = ImportedModuleEvidence + !SemanticInterface + ![ImportedModuleEvidence] + !(Map + SemanticFactOccurrenceFingerprint + (SemanticFactOccurrence, CheckedPropositionContent)) + ![AssertedObject] + +freshImportedModuleEvidence + :: [ImportedModuleEvidence] + -> SemanticInterface + -> PendingModulePrefix + -> ImportedModuleEvidence +freshImportedModuleEvidence parents interface prefix = + ImportedModuleEvidence + interface + parents + (Map.fromList + [ ( semanticFactFingerprint occurrence + , (occurrence, requireProposition occurrence) + ) + | occurrence <- occurrences + ]) + objects + where + batches = pendingModulePrefixBatches prefix + objects = concatMap committedBatchObjects batches + propositions = concatMap committedBatchPropositions batches + propositionMap = + Map.fromList + [ (checkedPropositionId proposition, proposition) + | proposition <- propositions + ] + occurrences = + concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface) + + requireProposition occurrence = + case Map.lookup + (semanticFactProposition occurrence) + propositionMap of + Just proposition -> + proposition + Nothing -> + impossible + ("sealed fact occurrence references absent proposition " + <> show (semanticFactProposition occurrence)) + +-- | Construct import evidence after a trusted producer or validated store +-- installation has supplied the complete canonical proposition payloads. +validateImportedModuleEvidence + :: TheoryId + -> [ImportedModuleEvidence] + -> SemanticInterface + -> [AssertedObject] + -> [CheckedPropositionContent] + -> Either DeclarationError ImportedModuleEvidence +validateImportedModuleEvidence + theory parents interface objects propositions = do + _ <- first ImportedEvidenceInterfaceFailed + (validateSemanticInterface + (semanticInterfaceOwner interface) + (semanticInterfaceDirectInputs interface) + (semanticInterfaceDeclarations interface) + (semanticInterfaceAssertedId interface)) + unless + (semanticInterfaceDirectInputs interface == parentIds) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + parentIds)) + let propositionMap = + Map.fromList + [ (checkedPropositionId proposition, proposition) + | proposition <- propositions + ] + objectMap = + Map.fromList + [ (assertedObjectId object, object) + | object <- objects + ] + localObjectIds = + concatMap + declarationDeltaObjects + (semanticInterfaceDeclarations interface) + parentObjectMap = + foldl' + (Map.unionWith const) + Map.empty + (evidenceObjectMap <$> parents) + localObjects <- traverse + (\identity -> + maybe + (Left (ImportedEvidenceObjectMissing identity)) + Right + (Map.lookup identity objectMap)) + localObjectIds + closure <- first DeclarationObjectValidationFailed + (validateObjectClosure + theory + (Map.elems parentObjectMap <> localObjects)) + let occurrences = + concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface) + pairs <- traverse + (\occurrence -> do + proposition <- maybe + (Left + (ImportedEvidencePropositionMissing + (semanticFactProposition occurrence))) + Right + (Map.lookup + (semanticFactProposition occurrence) + propositionMap) + _ <- first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition))) + _ <- first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + theory + (semanticFactFingerprint occurrence) + occurrence + proposition + (semanticFactAuthority occurrence)) + pure + ( semanticFactFingerprint occurrence + , (occurrence, proposition) + )) + occurrences + let evidence = + ImportedModuleEvidence + interface + parents + (Map.fromList pairs) + localObjects + _ <- validateEvidenceInventory theory closure evidence + pure evidence + where + parentIds = + semanticInterfaceAssertedId . evidenceInterface <$> parents + +validateEvidenceInventory + :: TheoryId + -> CheckedObjectClosure + -> ImportedModuleEvidence + -> Either DeclarationError () +validateEvidenceInventory theory closure evidence = + do + void (foldEvidence Set.empty Map.empty Map.empty evidence) + (_seen, structures) <- + foldStructures Set.empty Map.empty evidence + void (foldGlobals structures Set.empty Map.empty evidence) + where + foldEvidence seen facts aliases current + | identity `Set.member` seen = + Right (seen, facts, aliases) + | otherwise = do + unless + (semanticInterfaceDirectInputs interface == parentIds) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + parentIds)) + (parentsSeen, parentFacts, parentAliases) <- + foldM + (\(seen', facts', aliases') parent -> + foldEvidence seen' facts' aliases' parent) + (seen, facts, aliases) + parents + localFacts <- foldM insertFact parentFacts (Map.elems entries) + localAliases <- foldM + (insertAlias localFacts) + parentAliases + [ ( alias + , ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias) + ) + | delta <- semanticInterfaceDeclarations interface + , alias <- declarationDeltaAliases delta + ] + pure + ( Set.insert identity parentsSeen + , localFacts + , localAliases + ) + where + ImportedModuleEvidence interface parents entries _objects = current + identity = semanticInterfaceAssertedId interface + parentIds = + semanticInterfaceAssertedId . evidenceInterface <$> parents + + insertFact facts pair@(occurrence, proposition) = do + let fingerprint = semanticFactFingerprint occurrence + _ <- first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + theory + fingerprint + occurrence + proposition + (semanticFactAuthority occurrence)) + case Map.lookup fingerprint facts of + Nothing -> + Right (Map.insert fingerprint pair facts) + Just (existingOccurrence, existingProposition) + | existingOccurrence == occurrence + && checkedPropositionId existingProposition + == checkedPropositionId proposition -> + Right facts + | otherwise -> + Left (ImportedFactCollision fingerprint) + + insertAlias facts aliases (alias, origin) = do + let name = semanticAliasName alias + target = semanticAliasTarget alias + unless + (Map.member target facts) + (Left (ImportedAliasTargetMissing target)) + case Map.lookup name aliases of + Nothing -> + Right + (Map.insert + name + (ImportedAliasBinding target origin) + aliases) + Just (ImportedAliasBinding existingTarget existingOrigin) + | existingTarget == target -> + Right aliases + | otherwise -> + Left + (ImportedAliasCollision + name existingOrigin origin) + + foldGlobals structures seen globals current + | identity `Set.member` seen = + Right (seen, globals) + | otherwise = do + (parentsSeen, parentGlobals) <- + foldM + (\(seen', globals') parent -> + foldGlobals structures seen' globals' parent) + (seen, globals) + parents + globals' <- + foldM + (insertGlobal + (structureOperationBindings structures)) + parentGlobals + [ binding + | delta <- semanticInterfaceDeclarations interface + , binding <- semanticEnvironmentBindings + (declarationDeltaEnvironment delta) + ] + pure (Set.insert identity parentsSeen, globals') + where + ImportedModuleEvidence interface parents _entries _objects = current + identity = semanticInterfaceAssertedId interface + + insertGlobal operationBindings globals binding = do + let key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + _ <- + first + (ImportedGlobalTargetInvalid key target) + (validateSemanticGlobalBindingTarget + operationBindings + closure binding) + case Map.lookup key globals of + Nothing -> Right (Map.insert key target globals) + Just existing + | existing == target -> Right globals + | otherwise -> + Left (ImportedGlobalCollision key existing target) + + foldStructures seen structures current + | identity `Set.member` seen = + Right (seen, structures) + | otherwise = do + (parentsSeen, parentStructures) <- + foldM + (\(seen', structures') parent -> + foldStructures seen' structures' parent) + (seen, structures) + parents + structures' <- + foldM + (insertSemanticStructure closure) + parentStructures + [ descriptor + | delta <- semanticInterfaceDeclarations interface + , descriptor <- semanticEnvironmentStructures + (declarationDeltaEnvironment delta) + ] + pure (Set.insert identity parentsSeen, structures') + where + ImportedModuleEvidence interface parents _entries _objects = current + identity = semanticInterfaceAssertedId interface + +evidenceInterface :: ImportedModuleEvidence -> SemanticInterface +evidenceInterface + (ImportedModuleEvidence interface _parents _entries _objects) = + interface + +evidenceObjectMap + :: ImportedModuleEvidence + -> Map ObjectId AssertedObject +evidenceObjectMap + (ImportedModuleEvidence _interface parents _entries objects) = + foldl' + (Map.unionWith const) + (Map.fromList + [ (assertedObjectId object, object) + | object <- objects + ]) + (evidenceObjectMap <$> parents) + +data DriverOpenError + = DriverInitialPrefixError !PrefixContextError + | DriverInitialObjectError !ObjectValidationError + deriving stock (Show, Eq) + +renderDriverOpenError :: DriverOpenError -> Text +renderDriverOpenError = \case + DriverInitialPrefixError{} -> + "the initial semantic prefix is inconsistent" + DriverInitialObjectError{} -> + "the initial object closure is inconsistent" + +runModuleDriver + :: CheckedFoundation + -> ModuleName + -> [SemanticInterfaceId] + -> VampireResolver + -> ValidationRun + -> ModuleDriver failure value + -> IO + (Either + DriverOpenError + (DriverResult failure value)) +runModuleDriver + foundation owner direct resolver validationRun action = do + unique <- BuilderIdentity <$> newUnique + let theory = theoryId foundation + case (,) <$> + first DriverInitialPrefixError + (initialPrefixContextId theory owner direct) + <*> + first DriverInitialObjectError + (validateObjectClosure theory []) of + Left err -> + pure (Left err) + Right (prefix, closure) -> do + let builder = + BuilderState + { logicalBuilderIdentity = unique + , logicalBuilderFoundation = foundation + , logicalBuilderTheory = theory + , logicalBuilderOwner = owner + , logicalBuilderDirectSemanticInputs = direct + , logicalBuilderPrefix = prefix + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = Map.empty + , logicalBuilderAliases = Map.empty + , logicalBuilderGlobals = Map.empty + , logicalBuilderStructures = Map.empty + , logicalBuilderImportedInterfaces = Set.empty + , logicalBuilderDeltas = [] + , logicalBuilderNextDeclaration = 0 + , logicalBuilderNextFact = 0 + , logicalBuilderNextInvocation = 0 + } + initialState = + DriverState + resolver + builder + (PendingModulePrefix prefix []) + validationRun + (result, DriverState _ finalBuilder finalPrefix _) <- + State.runStateT + (Except.runExceptT + (runDriverStep action)) + initialState + case result of + Left err -> + pure (Right (DriverFailed err finalPrefix)) + Right value -> do + case semanticInterface + owner + direct + (reverse + (logicalBuilderDeltas + finalBuilder)) of + Left err -> + pure + (Right + (DriverSealFailed + err + finalPrefix)) + Right interface -> + pure + (Right + (DriverSucceeded + value + interface + finalPrefix + (logicalBuilderObjectClosure + finalBuilder))) + +failModuleDriver :: failure -> ModuleDriver failure value +failModuleDriver err = + ModuleDriver + (Except.throwError + (DriverActionFailed err)) + +failDeclarationDriver :: DeclarationError -> ModuleDriver failure value +failDeclarationDriver err = + ModuleDriver (Except.throwError (DriverDeclarationFailed err)) + +nextDeclarationSlotDriver + :: ModuleDriver failure DeclarationSlot +nextDeclarationSlotDriver = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + (declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder))) + +currentTheoryDriver :: ModuleDriver failure TheoryId +currentTheoryDriver = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + logicalBuilderTheory builder)) + +currentFoundationAxiomDriver + :: FoundationAxiomTag + -> ModuleDriver failure (FrozenCheckedCore Void) +currentFoundationAxiomDriver tag = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag)) + +resolveVisibleFactAliasDriver + :: SemanticName + -> ModuleDriver failure + (Maybe SemanticFactOccurrenceFingerprint) +resolveVisibleFactAliasDriver alias = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure do + ImportedAliasBinding fingerprint _origin <- + Map.lookup alias (logicalBuilderAliases builder) + pure fingerprint + +resolveVisibleFactTargetsDriver + :: FrozenCheckedCore ObjectId + -> ModuleDriver failure + [SemanticFactOccurrenceFingerprint] +resolveVisibleFactTargetsDriver target = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + [ fingerprint + | (fingerprint, FactEntry proposition _occurrence _authorization) <- + Map.toAscList (logicalBuilderFacts builder) + , checkedPropositionTerm proposition == target + ] + +resolveVisibleGlobalDriver + :: SemanticGlobalKey + -> ModuleDriver failure (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobalDriver key = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + ( (\(target, _content, _dependencies) -> + ( target + , fromMaybe + (impossible "visible semantic key has no source type") + (semanticGlobalKeyType key) + )) + <$> resolveVisibleGlobalContent builder key + ) + +resolveVisibleGlobalContentDriver + :: SemanticGlobalKey + -> ModuleDriver failure + (Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + )) +resolveVisibleGlobalContentDriver key = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure (resolveVisibleGlobalContent builder key) + +resolveVisibleStructureDriver + :: SemanticStructurePhrase + -> ModuleDriver failure (Maybe ResolvedStructure) +resolveVisibleStructureDriver structurePhrase = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure (Map.lookup structurePhrase (logicalBuilderStructures builder)) + +resolveVisibleStructureOperationObjectsDriver + :: StructSymbol + -> ModuleDriver failure [ObjectId] +resolveVisibleStructureOperationObjectsDriver symbol = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure + ( Set.toAscList + (Set.fromList + (mapMaybe + (resolvedStructureOperation symbol) + (Map.elems (logicalBuilderStructures builder)))) + ) + +resolveVisibleGlobalContent + :: BuilderState evidence + -> SemanticGlobalKey + -> Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + ) +resolveVisibleGlobalContent builder key = do + target <- Map.lookup key (logicalBuilderGlobals builder) + content <- + lookupCheckedObjectContent + (semanticGlobalTargetObject target) + closure + let dependencies = + Map.fromList + [ (identity, requireDependency identity) + | identity <- case content of + TransparentObjectContent _theory _coreType body -> + Set.toAscList (canonicalTermGlobals body) + _ -> [] + ] + pure + ( target + , content + , dependencies + ) + where + closure = logicalBuilderObjectClosure builder + + requireDependency identity = + case lookupCheckedObjectType identity closure of + Just coreType -> coreType + Nothing -> + impossible "checked object dependency is absent" + +objectAvailableDriver + :: ObjectId + -> ModuleDriver failure Bool +objectAvailableDriver identity = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + isJust + (lookupCheckedObjectType + identity + (logicalBuilderObjectClosure builder)))) + +objectTypeDriver + :: ObjectId + -> ModuleDriver failure (Maybe CoreType) +objectTypeDriver identity = + ModuleDriver + (State.gets + (\(DriverState _resolver builder _prefix _validation) -> + lookupCheckedObjectType + identity + (logicalBuilderObjectClosure builder))) + +nextDeclarationSlotLowering :: LoweringDriver DeclarationSlot +nextDeclarationSlotLowering = + withLoweringBuilder \builder -> + declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + +currentTheoryLowering :: LoweringDriver TheoryId +currentTheoryLowering = + withLoweringBuilder logicalBuilderTheory + +currentFoundationLowering :: LoweringDriver CheckedFoundation +currentFoundationLowering = + withLoweringBuilder logicalBuilderFoundation + +currentFoundationAxiomLowering + :: FoundationAxiomTag + -> LoweringDriver (FrozenCheckedCore Void) +currentFoundationAxiomLowering tag = + withLoweringBuilder + (\builder -> + foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag) + +resolveVisibleFactAliasLowering + :: SemanticName + -> LoweringDriver (Maybe SemanticFactOccurrenceFingerprint) +resolveVisibleFactAliasLowering alias = + withLoweringBuilder \builder -> do + ImportedAliasBinding fingerprint _origin <- + Map.lookup alias (logicalBuilderAliases builder) + pure fingerprint + +resolveVisibleFactTargetsLowering + :: FrozenCheckedCore ObjectId + -> LoweringDriver [SemanticFactOccurrenceFingerprint] +resolveVisibleFactTargetsLowering target = + withLoweringBuilder \builder -> + [ fingerprint + | (fingerprint, FactEntry proposition _occurrence _evidence) <- + Map.toAscList (logicalBuilderFacts builder) + , checkedPropositionTerm proposition == target + ] + +resolveVisibleGlobalLowering + :: SemanticGlobalKey + -> LoweringDriver (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobalLowering key = + withLoweringBuilder \builder -> + ( (\(target, _content, _dependencies) -> + ( target + , fromMaybe + (impossible "visible semantic key has no source type") + (semanticGlobalKeyType key) + )) + <$> resolveVisibleGlobalContent builder key + ) + +resolveVisibleGlobalContentLowering + :: SemanticGlobalKey + -> LoweringDriver + (Maybe + ( SemanticGlobalTarget + , ObjectContent + , Map ObjectId CoreType + )) +resolveVisibleGlobalContentLowering key = + withLoweringBuilder (\builder -> resolveVisibleGlobalContent builder key) + +resolveVisibleStructureLowering + :: SemanticStructurePhrase + -> LoweringDriver (Maybe ResolvedStructure) +resolveVisibleStructureLowering phrase = + withLoweringBuilder (Map.lookup phrase . logicalBuilderStructures) + +resolveVisibleStructureOperationObjectsLowering + :: StructSymbol + -> LoweringDriver [ObjectId] +resolveVisibleStructureOperationObjectsLowering symbol = + withLoweringBuilder \builder -> + Set.toAscList + (Set.fromList + (mapMaybe + (resolvedStructureOperation symbol) + (Map.elems (logicalBuilderStructures builder)))) + +objectAvailableLowering :: ObjectId -> LoweringDriver Bool +objectAvailableLowering identity = + withLoweringBuilder + (isJust + . lookupCheckedObjectType identity + . logicalBuilderObjectClosure) + +objectTypeLowering :: ObjectId -> LoweringDriver (Maybe CoreType) +objectTypeLowering identity = + withLoweringBuilder + (lookupCheckedObjectType identity + . logicalBuilderObjectClosure) + +withLoweringBuilder + :: (BuilderState PlanningEvidence -> value) + -> LoweringDriver value +withLoweringBuilder action = LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- State.get + pure (action builder) + + +data CandidateSpec = CandidateSpec + !CheckedPropositionContent + !FactSearchEligibility + ![SemanticName] + +candidateSpec + :: CheckedPropositionContent + -> FactSearchEligibility + -> [SemanticName] + -> CandidateSpec +candidateSpec = + CandidateSpec + +-- | One strictly earlier candidate in the same checked declaration. The +-- position is structural and becomes a concrete fact slot only while the +-- declaration is planned. +data PlannedCandidatePosition = PlannedCandidatePosition + !Natural + !Natural + deriving stock (Show, Eq, Ord) + +data CandidatePlanningDirect + = PlanningDefinitionEquation !ObjectId + | PlanningSourceAxiom + | PlanningTrustedDatatype !DatatypeCompilationDescriptor + | PlanningKernelConstruction !KernelConstructionDescriptor + | PlanningCheckedSourceProof + | PlanningOmitted + deriving stock (Show, Eq) + +-- | Erased exact request data needed by scheduling and public-contract +-- planning. The family body retains the typed obligation used by admission; +-- this projection carries only its one canonical request and exact global +-- premise fingerprints. +data CheckedPlannedVampireRequest = CheckedPlannedVampireRequest + !Location + !Provers.PreparedVerificationRequest + ![SemanticFactOccurrenceFingerprint] + +data CandidatePlanningSpec = CandidatePlanningSpec + !CandidatePlanningDirect + ![SemanticFactOccurrenceFingerprint] + ![PlannedCandidatePosition] + ![CheckedPlannedVampireRequest] + +-- | One authority-free checked candidate and its exact planning contract. +-- The two parts are constructed together by the declaration-family lowerer +-- and retain no builder capability or publication path. +data CheckedCandidate = CheckedCandidate + !CandidateSpec + !CandidatePlanningSpec + +checkedCandidate + :: CandidateSpec + -> CandidatePlanningSpec + -> CheckedCandidate +checkedCandidate = CheckedCandidate + +checkedDefinitionEquationPlanning :: ObjectId -> CandidatePlanningSpec +checkedDefinitionEquationPlanning identity = + CandidatePlanningSpec + (PlanningDefinitionEquation identity) [] [] [] + +checkedSourceAxiomPlanning :: CandidatePlanningSpec +checkedSourceAxiomPlanning = + CandidatePlanningSpec PlanningSourceAxiom [] [] [] + +checkedDatatypePlanning + :: DatatypeCompilationDescriptor + -> CandidatePlanningSpec +checkedDatatypePlanning descriptor = + CandidatePlanningSpec (PlanningTrustedDatatype descriptor) [] [] [] + +checkedKernelPlanning + :: KernelConstructionDescriptor + -> [SemanticFactOccurrenceFingerprint] + -> CandidatePlanningSpec +checkedKernelPlanning descriptor facts = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + facts + [] + [] + +checkedKernelPlanningWithStaged + :: KernelConstructionDescriptor + -> [SemanticFactOccurrenceFingerprint] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedKernelPlanningWithStaged descriptor facts staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + facts + staged + [] + +checkedStagedKernelPlanning + :: KernelConstructionDescriptor + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedStagedKernelPlanning descriptor staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + [] + staged + [] + +checkedSourceProofPlanning + :: [CheckedPlannedVampireRequest] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedSourceProofPlanning requests staged = + CandidatePlanningSpec + PlanningCheckedSourceProof [] staged requests + +checkedOmittedPlanning + :: [CheckedPlannedVampireRequest] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedOmittedPlanning requests staged = + CandidatePlanningSpec PlanningOmitted [] staged requests + +checkedPlannedVampireRequest + :: Location + -> PreparedVampireObligation local origin + -> CheckedPlannedVampireRequest +checkedPlannedVampireRequest location + (PreparedVampireObligation expected task) = + CheckedPlannedVampireRequest + location + (Provers.preparedTypedProverRequest task) + ( Backend.typedBackendFactReference + <$> Vector.toList + (Backend.typedProblemGlobalPremises expected) + ) + +plannedEarlierCandidate + :: Natural + -> Natural + -> PlannedCandidatePosition +plannedEarlierCandidate = + PlannedCandidatePosition + +data CheckedDeclarationMode + = CheckedProofMode !ProofSyntaxId + | CheckedCompiledMode !DeclarationSyntaxId + +-- | One completely lowered, authority-free declaration transaction. The +-- family body is a closed checked authorization recipe owned by its exact +-- lowerer; structural effects and stable source-ordered candidate stages are +-- common. This value is invocation-local and never serialized. +data CheckedDeclaration body = CheckedDeclaration + !CheckedDeclarationMode + ![AssertedObject] + ![CheckedPropositionContent] + ![SemanticGlobalBinding] + ![SemanticStructureDescriptor] + ![NonEmpty CheckedCandidate] + !body + +checkedProofDeclaration + :: ProofSyntaxId + -> [AssertedObject] + -> [CheckedPropositionContent] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> [NonEmpty CheckedCandidate] + -> body + -> CheckedDeclaration body +checkedProofDeclaration + syntax objects propositions globals structures stages = + CheckedDeclaration + (CheckedProofMode syntax) objects propositions globals structures + stages + +checkedCompiledDeclaration + :: DeclarationSyntaxId + -> [AssertedObject] + -> [CheckedPropositionContent] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> [NonEmpty CheckedCandidate] + -> body + -> CheckedDeclaration body +checkedCompiledDeclaration + syntax objects propositions globals structures stages = + CheckedDeclaration + (CheckedCompiledMode syntax) objects propositions globals structures + stages + +prepareCandidateSpecDriver + :: [AssertedObject] + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareCandidateSpecDriver objects scoped eligibility aliases = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareScopedCandidateSpec + closure scoped eligibility aliases) + +prepareFrozenCandidateSpecDriver + :: [AssertedObject] + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareFrozenCandidateSpecDriver objects frozen eligibility aliases = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareFrozenCandidateSpec + closure frozen eligibility aliases) + +prepareDefinitionEquationSpecDriver + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecDriver objects identity alias = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + prepareDefinitionEquationSpec closure identity alias) + +preparePointwiseDefinitionEquationSpecDriver + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +preparePointwiseDefinitionEquationSpecDriver objects identity alias = + prepareCandidateSpecWithDriverClosure objects + (\closure -> + preparePointwiseDefinitionEquationSpec closure identity alias) + +prepareCandidateSpecLowering + :: [AssertedObject] + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareCandidateSpecLowering objects scoped eligibility aliases = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareScopedCandidateSpec + closure scoped eligibility aliases) + +prepareFrozenCandidateSpecLowering + :: [AssertedObject] + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareFrozenCandidateSpecLowering objects frozen eligibility aliases = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareFrozenCandidateSpec + closure frozen eligibility aliases) + +prepareDefinitionEquationSpecLowering + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecLowering objects identity alias = + prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibilityLowering + :: [AssertedObject] + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecWithEligibilityLowering + objects identity eligibility alias = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias) + +-- | Prepare the unaliased first-order view of one checked, named set +-- construction. The returned descriptor binds direct authorization to the +-- transparent object and the complete checked source decomposition. +prepareNamedSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> NamedSetConstruction ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareNamedSetConstructionSpecLowering objects identity construction = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareNamedSetConstruction + (logicalBuilderFoundation builder) + closure identity construction + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) + +prepareRelationalSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareRelationalSetConstructionSpecLowering + objects identity construction functionality = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + closure identity construction functionality + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) + +preparePointwiseDefinitionEquationSpecLowering + :: [AssertedObject] + -> ObjectId + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +preparePointwiseDefinitionEquationSpecLowering objects identity alias = + prepareCandidateSpecWithLoweringClosure objects + (\closure -> + preparePointwiseDefinitionEquationSpec closure identity alias) + +-- | Prepare one closed Vampire obligation whose only premise is a +-- conditionally available fact from a strictly earlier candidate stage of +-- the same declaration. The temporary checked stage contains public fact +-- semantics and structural provenance only; admission must still consume the +-- corresponding real reserved candidate before accepting this request. +prepareStagedCandidateVampireDriver + :: Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> ModuleDriver failure + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireDriver + location objects premiseSpec targetSpec = + ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + State.lift + (liftIO + (prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec)) + +prepareStagedCandidateVampireLowering + :: Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> LoweringDriver + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireLowering + location objects premiseSpec targetSpec = + LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- + State.get + liftIO + (prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec) + +prepareStagedCandidateVampireWith + :: BuilderState evidence + -> Location + -> [AssertedObject] + -> CandidateSpec + -> CandidateSpec + -> IO + (Either + DeclarationError + (PreparedVampireObligation Void ())) +prepareStagedCandidateVampireWith + builder location objects premiseSpec targetSpec = do + let staged = do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + premise <- + prospectiveStagePremise + builder closure premiseSpec targetSpec + pure (closure, premise) + case staged of + Left failure -> pure (Left failure) + Right (closure, premise) -> do + prepared <- + forceVampirePreparation + (prepareClosedCandidateVampire + builder closure + (candidateSpecProposition targetSpec) + [premise]) + pure + (first + (ProofObligationFailedAt location + . CurrentCandidateVampirePreparationFailed) + prepared) + +candidateSpecProposition :: CandidateSpec -> CheckedPropositionContent +candidateSpecProposition (CandidateSpec proposition _eligibility _aliases) = + proposition + +prospectiveStagePremise + :: BuilderState evidence + -> CheckedObjectClosure + -> CandidateSpec + -> CandidateSpec + -> Either DeclarationError CheckedPropositionContent +prospectiveStagePremise builder closure premiseSpec targetSpec = do + let owner = logicalBuilderOwner builder + declaration = + declarationSlot owner + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + premiseSlot = + factSlot owner + (localFactOrdinal (logicalBuilderNextFact builder)) + targetSlot = + factSlot owner + (localFactOrdinal (logicalBuilderNextFact builder + 1)) + premiseStage = CandidateStage 0 + targetStage = CandidateStage 1 + proposition = candidateSpecProposition premiseSpec + authority = + factAuthority + (theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId proposition)) + cleanAuthoritySafety + CandidateSpec _ eligibility _aliases = premiseSpec + occurrence = + semanticFactOccurrence premiseSlot authority eligibility + stage = + CheckedDeclarationStage declaration closure + (Map.singleton premiseSlot + (FactEntry proposition occurrence + (PlanningEvidence + authority + (Just + (PlanningProvenance + declaration premiseStage premiseSlot))))) + unless + (propositionMatchesClosure closure + (candidateSpecProposition targetSpec)) + (Left (PlanningFactContractMismatch targetSlot)) + useProspectiveStageFact + stage targetStage targetSlot premiseStage premiseSlot + +useProspectiveStageFact + :: CheckedDeclarationStage + -> CandidateStage + -> FactSlot + -> CandidateStage + -> FactSlot + -> Either DeclarationError CheckedPropositionContent +useProspectiveStageFact + (CheckedDeclarationStage ownSlot closure entries) + currentStage currentSlot expectedStage premiseSlot = do + FactEntry proposition occurrence + (PlanningEvidence authority provenance) <- + maybe + (Left (PlanningFactContractMismatch premiseSlot)) + Right + (Map.lookup premiseSlot entries) + unless + ( provenance + == Just + (PlanningProvenance + ownSlot expectedStage premiseSlot) + && expectedStage < currentStage + && semanticFactSlot occurrence == premiseSlot + && semanticFactAuthority occurrence == authority + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch currentSlot)) + pure proposition + +prepareCandidateSpecWithDriverClosure + :: [AssertedObject] + -> (CheckedObjectClosure -> Either DeclarationError CandidateSpec) + -> ModuleDriver failure (Either DeclarationError CandidateSpec) +prepareCandidateSpecWithDriverClosure objects prepare = ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + pure do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + prepare closure + +prepareCandidateSpecWithLoweringClosure + :: [AssertedObject] + -> (CheckedObjectClosure -> Either DeclarationError value) + -> LoweringDriver (Either DeclarationError value) +prepareCandidateSpecWithLoweringClosure objects prepare = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + prepare closure + +data ReservedCandidate = ReservedCandidate + !BuilderIdentity + !PrefixContextId + !DeclarationInvocation + !CandidateStage + !FactSlot + !CandidateSpec + +reservedCandidateSlot :: ReservedCandidate -> FactSlot +reservedCandidateSlot + (ReservedCandidate _ _ _ _ slot _) = + slot + +reservedCandidateStage :: ReservedCandidate -> Natural +reservedCandidateStage + (ReservedCandidate _ _ _ (CandidateStage stage) _ _) = + stage + +candidateCheckedProposition + :: ReservedCandidate + -> CheckedPropositionContent +candidateCheckedProposition + (ReservedCandidate _ _ _ _ _ (CandidateSpec proposition _ _)) = + proposition + +candidateTheoremReference + :: BuilderState evidence + -> ReservedCandidate + -> TheoremRef +candidateTheoremReference builder candidate = + theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId + (candidateCheckedProposition candidate)) + + +data PendingCandidate = PendingCandidate + !ReservedCandidate + !ValidationCertificate + !PendingFactAuthorization + +data DeclarationValidationSelection + = DeclarationValidationUnselected + | FreshDeclarationValidation + | CachedDeclarationValidation + !DeclarationSyntaxId + ![ObjectId] + ![TheoremId] + !DeclarationValidationRecord + !(Map FactSlot Natural) + +data DeclarationState = DeclarationState + { declarationVampireResolver :: !VampireResolver + , declarationValidationRun :: !ValidationRun + , declarationValidationMode :: !ValidationMode + , declarationValidationSelection + :: !DeclarationValidationSelection + , declarationBuilder :: !LogicalBuilder + , declarationOwnSlot :: !DeclarationSlot + , declarationInvocation :: !DeclarationInvocation + , declarationObjectsReversed :: ![AssertedObject] + , declarationObjectClosure :: !(Maybe CheckedObjectClosure) + , declarationPropositionsReversed + :: ![CheckedPropositionContent] + , declarationGlobalBindingsReversed + :: ![SemanticGlobalBinding] + , declarationStructureDescriptorsReversed + :: ![SemanticStructureDescriptor] + , declarationReservations + :: !(Map FactSlot ReservedCandidate) + , declarationPending :: !(Map FactSlot PendingCandidate) + , declarationNextFact :: !Natural + , declarationNextStage :: !Natural + , declarationAuthorizationFrontier :: !Natural + } + +-- | Authority-free view of checked declaration-local semantics. This is the +-- narrow staging substrate for later lowerers: it carries the exact object +-- closure and conditional public fact contracts, but no builder identity, +-- prefix, invocation, pending authorization, admitted alias, or published +-- occurrence. +data CheckedDeclarationStage = CheckedDeclarationStage + !DeclarationSlot + !CheckedObjectClosure + !(Map FactSlot (FactEntry PlanningEvidence)) + +newtype Declaration value = Declaration + { runDeclaration + :: StateT + DeclarationState + (ExceptT DeclarationError IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +failDeclaration :: DeclarationError -> Declaration value +failDeclaration = + Declaration . State.lift . Except.throwError + +addDeclarationObject :: AssertedObject -> Declaration () +addDeclarationObject asserted = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + when + (isJust (declarationObjectClosure state)) + (State.lift + (Except.throwError + DeclarationObjectAddedAfterAuthorization)) + State.put + state + { declarationObjectsReversed = + asserted : declarationObjectsReversed state + } + +addDeclarationProposition + :: CheckedPropositionContent + -> Declaration () +addDeclarationProposition proposition = + Declaration + (State.modify' \state -> + state + { declarationPropositionsReversed = + proposition + : declarationPropositionsReversed state + }) + +resolveVisibleGlobal + :: SemanticGlobalKey + -> Declaration (Maybe (SemanticGlobalTarget, CoreType)) +resolveVisibleGlobal key = Declaration do + state <- State.get + let builder = declarationBuilder state + pure do + target <- Map.lookup key (logicalBuilderGlobals builder) + coreType <- semanticGlobalKeyType key + pure (target, coreType) + +stageSemanticGlobalBinding + :: SemanticGlobalKey + -> SemanticGlobalTarget + -> Declaration () +stageSemanticGlobalBinding key target = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + when + (any + ((== key) . semanticGlobalBindingKey) + (declarationGlobalBindingsReversed state)) + (State.lift + (Except.throwError + (DeclarationGlobalAlreadyStaged key))) + State.put + state + { declarationGlobalBindingsReversed = + semanticGlobalBinding key target + : declarationGlobalBindingsReversed state + } + +stageSemanticStructureDescriptor + :: SemanticStructureDescriptor + -> Declaration () +stageSemanticStructureDescriptor descriptor = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + let structurePhrase = semanticStructureDescriptorPhrase descriptor + when + (any + ((== structurePhrase) . semanticStructureDescriptorPhrase) + (declarationStructureDescriptorsReversed state)) + (State.lift + (Except.throwError + (DeclarationStructureAlreadyStaged structurePhrase))) + State.put + state + { declarationStructureDescriptorsReversed = + descriptor + : declarationStructureDescriptorsReversed state + } + +prepareScopedCandidateSpec + :: CheckedObjectClosure + -> ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Either DeclarationError CandidateSpec +prepareScopedCandidateSpec closure scoped eligibility aliases = do + frozen <- + maybe (Left CandidatePropositionNotClosed) Right + (closeScopedCore scoped) + prepareFrozenCandidateSpec closure frozen eligibility aliases + +prepareFrozenCandidateSpec + :: CheckedObjectClosure + -> FrozenCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Either DeclarationError CandidateSpec +prepareFrozenCandidateSpec closure frozen eligibility aliases = do + unless + (frozenCoreType frozen == TyProp) + (Left + (CandidatePropositionNotProposition + (frozenCoreType frozen))) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent closure (frozenCoreTerm frozen)) + pure (candidateSpec proposition eligibility aliases) + +prepareDefinitionEquationSpec + :: CheckedObjectClosure + -> ObjectId + -> SemanticName + -> Either DeclarationError CandidateSpec +prepareDefinitionEquationSpec closure identity alias = do + prepareDefinitionEquationSpecWithEligibility + closure identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibility + :: CheckedObjectClosure + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> Either DeclarationError CandidateSpec +prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias = do + content <- + maybe + (Left (DefinitionEquationObjectMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + (coreType, body) <- + case content of + TransparentObjectContent _theory objectType objectBody -> + Right (objectType, objectBody) + _ -> + Left (DefinitionEquationObjectNotTransparent identity) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent + closure + (CEq coreType (CGlobal identity) body)) + pure (candidateSpec proposition eligibility [alias]) + +prepareNamedSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> NamedSetConstruction ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareNamedSetConstruction foundation closure identity construction = do + let expectedContent = namedSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction) + pure + ( namedSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (namedSetConstructionFactDescriptor derived) + ) + +prepareRelationalSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareRelationalSetConstruction + foundation closure identity construction functionality = do + let expectedContent = relationalSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (relationalSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction + functionality) + pure + ( relationalSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (relationalSetConstructionFactDescriptor derived) + ) + +preparePointwiseDefinitionEquationSpec + :: CheckedObjectClosure + -> ObjectId + -> SemanticName + -> Either DeclarationError CandidateSpec +preparePointwiseDefinitionEquationSpec closure identity alias = do + content <- + maybe + (Left (DefinitionEquationObjectMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + body <- + case content of + TransparentObjectContent _theory + (TyArrow TySet TyProp) (CLam TySet predicate) -> + Right predicate + _ -> + Left + (DefinitionEquationObjectNotPointwisePredicate identity) + proposition <- + first DeclarationPropositionValidationFailed + (validatePropositionContent + closure + (CForall TySet + (CEq TyProp + (CApp (CGlobal identity) (CBound 0)) + body))) + pure (candidateSpec proposition SearchEligible [alias]) + +reserveCandidate + :: CandidateSpec + -> Declaration ReservedCandidate +reserveCandidate spec = + NonEmpty.head <$> reserveCandidateBatch (spec :| []) + +-- | Validate and reserve one closed checked proposition in the current +-- declaration closure. +reservePropositionCandidate + :: ScopedCheckedCore ObjectId + -> FactSearchEligibility + -> [SemanticName] + -> Declaration ReservedCandidate +reservePropositionCandidate scoped eligibility aliases = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (prepareScopedCandidateSpec + (fromMaybe + (impossible + "prepared proposition closure is absent") + (declarationObjectClosure prepared)) + scoped eligibility aliases)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Validate and reserve one stage of already closed checked propositions in +-- the current declaration closure. +reserveFrozenPropositionCandidateBatch + :: NonEmpty + ( FrozenCheckedCore ObjectId + , FactSearchEligibility + , [SemanticName] + ) + -> Declaration (NonEmpty ReservedCandidate) +reserveFrozenPropositionCandidateBatch inputs = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let closure = + maybe + (impossible "prepared proposition closure is absent") + id + (declarationObjectClosure prepared) + specs <- traverse (prepareInput closure) inputs + State.put prepared + runDeclaration (reserveCandidateBatch specs) + where + prepareInput closure (frozen, eligibility, aliases) = + State.lift + (Except.liftEither + (prepareFrozenCandidateSpec + closure frozen eligibility aliases)) + +reserveCandidateBatch + :: NonEmpty CandidateSpec + -> Declaration (NonEmpty ReservedCandidate) +reserveCandidateBatch specs = Declaration do + state <- State.get + case declarationValidationSelection state of + DeclarationValidationUnselected -> pure () + _ -> + State.lift + (Except.throwError + DeclarationShapeChangedAfterValidationLookup) + let builder = declarationBuilder state + stage = CandidateStage (declarationNextStage state) + firstFact = declarationNextFact state + candidates = + NonEmpty.zipWith + (makeReserved builder state stage) + (0 :| [1 ..]) + specs + reservations' = + foldl' + (\reservations candidate -> + Map.insert + (reservedCandidateSlot candidate) + candidate + reservations) + (declarationReservations state) + candidates + candidateCount = fromIntegral (NonEmpty.length specs) + State.put + state + { declarationReservations = reservations' + , declarationNextFact = firstFact + candidateCount + , declarationNextStage = + declarationNextStage state + 1 + } + pure candidates + where + makeReserved builder state stage offset spec = + ReservedCandidate + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + (declarationInvocation state) + stage + (factSlot + (logicalBuilderOwner builder) + (localFactOrdinal + (declarationNextFact state + offset))) + spec + +-- | Construct the one defining equation owned by a checked transparent +-- object. The equation is derived from authoritative object content, not from +-- a caller-supplied proposition. +reserveDefinitionEquationCandidate + :: ObjectId + -> SemanticName + -> Declaration ReservedCandidate +reserveDefinitionEquationCandidate identity alias = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (prepareDefinitionEquationSpec + (fromMaybe + (impossible + "prepared definition closure is absent") + (declarationObjectClosure prepared)) + identity alias)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Construct the pointwise presentation of one unary transparent predicate +-- definition. The candidate remains tied to the object's checked content. +reservePointwiseDefinitionEquationCandidate + :: ObjectId + -> SemanticName + -> Declaration ReservedCandidate +reservePointwiseDefinitionEquationCandidate identity alias = Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + spec <- + State.lift + (Except.liftEither + (preparePointwiseDefinitionEquationSpec + (fromMaybe + (impossible "prepared predicate closure is absent") + (declarationObjectClosure prepared)) + identity alias)) + State.put prepared + runDeclaration (reserveCandidate spec) + +-- | Reserve one defining equation and a nonempty generated-fact batch at the +-- same declaration stage. No candidate in the batch can cite a sibling. +reserveDefinitionEquationCandidateBatch + :: ObjectId + -> SemanticName + -> NonEmpty + ( ScopedCheckedCore ObjectId + , FactSearchEligibility + , [SemanticName] + ) + -> Declaration + ( ReservedCandidate + , NonEmpty ReservedCandidate + ) +reserveDefinitionEquationCandidateBatch identity alias generated = + Declaration do + unprepared <- State.get + prepared <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let closure = + maybe + (impossible + "prepared declaration closure is absent") + id + (declarationObjectClosure prepared) + definition <- + State.lift + (Except.liftEither + (prepareDefinitionEquationSpec closure identity alias)) + generatedSpecs <- + traverse + (prepareGeneratedSpec closure) + generated + State.put prepared + candidates <- + runDeclaration + (reserveCandidateBatch + (definition :| toList generatedSpecs)) + case candidates of + definitionCandidate :| firstGenerated : remainingGenerated -> + pure + ( definitionCandidate + , firstGenerated :| remainingGenerated + ) + _ -> + impossible + "a nonempty generated batch produced no candidate" + where + prepareGeneratedSpec closure (scoped, eligibility, aliases) = + State.lift + (Except.liftEither + (prepareScopedCandidateSpec + closure scoped eligibility aliases)) + +-- | Resolve one complete compiled declaration against its exact validation +-- key, then run the source-level authorization action under that selection. +-- Objects and candidates must already be prepared so the lookup key cannot +-- change after a hit or miss is chosen. +authorizeCompiledDeclaration + :: Declaration value + -> Declaration value +authorizeCompiledDeclaration action = Declaration do + unprepared <- State.get + (syntax, objects, theorems, ordinals, prepared) <- + State.lift + (Except.liftEither + (prepareCompiledValidation unprepared)) + let key = + declarationValidationKey + syntax + (logicalBuilderPrefix + (declarationBuilder prepared)) + objects + theorems + cached <- + case declarationValidationRun prepared of + FreshValidation -> + pure Nothing + WarmValidation + (ValidationLookup _lookupProof lookupDeclaration) -> + liftIO (lookupDeclaration key) + traverse_ + (\record -> + case Materialization.checkDeclarationValidationRecord + (logicalBuilderPrefix + (declarationBuilder prepared)) + syntax + objects + theorems + record of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> + pure ()) + cached + let selection = + case cached of + Nothing -> + FreshDeclarationValidation + Just record -> + CachedDeclarationValidation + syntax objects theorems record ordinals + State.put + prepared + { declarationValidationSelection = selection + } + runDeclaration action + +prepareCompiledValidation + :: DeclarationState + -> Either + DeclarationError + ( DeclarationSyntaxId + , [ObjectId] + , [TheoremId] + , Map FactSlot Natural + , DeclarationState + ) +prepareCompiledValidation declaration = do + syntax <- + case declarationValidationMode declaration of + DeclarationValidationMode value -> + Right value + _ -> + Left DeclarationValidationOutsideCompiledDeclaration + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> pure () + _ -> Left DeclarationValidationAlreadySelected + closure <- declarationClosure declaration + let builder = declarationBuilder declaration + candidates = Map.elems (declarationReservations declaration) + objects = + assertedObjectId + <$> reverse + (declarationObjectsReversed declaration) + theorems = + theoremId . candidateTheoremReference builder + <$> candidates + ordinals = + Map.fromList + (zip + (reservedCandidateSlot <$> candidates) + [0 ..]) + pure + ( syntax + , objects + , theorems + , ordinals + , declaration + { declarationObjectClosure = Just closure + } + ) + +lookupProofValidation + :: ReservedCandidate + -> Declaration (ProofSyntaxId, Maybe ProofValidationRecord) +lookupProofValidation candidate = Declaration do + state <- State.get + syntax <- + case declarationValidationMode state of + EnvironmentImportMode -> + State.lift + (Except.throwError + ProofValidationOutsideProofDeclaration) + ProofValidationMode proofSyntax -> + pure proofSyntax + DeclarationValidationMode{} -> + State.lift + (Except.throwError + ProofValidationOutsideProofDeclaration) + let builder = declarationBuilder state + reference = candidateTheoremReference builder candidate + key = + proofValidationKey + (theoremId + (factAuthorityTheorem + (factAuthority + reference + cleanAuthoritySafety))) + syntax + (logicalBuilderPrefix builder) + record <- + case declarationValidationRun state of + FreshValidation -> + pure Nothing + WarmValidation (ValidationLookup lookupProof _lookupDeclaration) -> + State.lift + (liftIO + (lookupProof key)) + pure (syntax, record) +data CandidatePremise = CandidatePremise + !CheckedPropositionContent + +data CandidateProofState = CandidateProofState + { candidateProofDeclaration :: !DeclarationState + , candidateProofObjectClosure :: !CheckedObjectClosure + , candidateProofCandidate :: !ReservedCandidate + , candidateProofCachedValidation + :: !(Maybe Materialization.CandidateValidation) + , candidateProofPremisesReversed :: ![CandidatePremise] + , candidateProofPremiseCount :: !Natural + , candidateProofSafety :: !CandidateSafety + , candidateProofAcceptedRequestsReversed + :: ![PreparedRequestId] + } + +candidateProofBuilder :: CandidateProofState -> LogicalBuilder +candidateProofBuilder = + declarationBuilder . candidateProofDeclaration + +newtype CandidateProof value = CandidateProof + { runCandidateProof + :: StateT + CandidateProofState + (ExceptT DeclarationError IO) + value + } + deriving newtype (Functor, Applicative, Monad) + +-- | Attach source trivia to a proof-obligation failure. The location does +-- not participate in validation or request identity. +locateProofObligation + :: Location + -> CandidateProof value + -> CandidateProof value +locateProofObligation location (CandidateProof action) = + CandidateProof + (State.mapStateT + (Except.withExceptT + (ProofObligationFailedAt location)) + action) + +-- | Record that the current exact proof discharged one goal with @Omitted@. +recordOmittedUse :: CandidateProof () +recordOmittedUse = CandidateProof do + state <- State.get + State.put + state + { candidateProofSafety = + addCandidateEscape + Omitted + (candidateProofSafety state) + } + +data VampirePremiseSelection + = VampireImplicitPremises + | VampireExplicitPremises + !(NonEmpty SemanticFactOccurrenceFingerprint) + | VampireLocalPremises + deriving stock (Show, Eq) + +data VampireObligationPreparationError local + = VampireObligationIndirectTargetNotFalsum + | VampireObligationClaimProjectionFailed + !(Backend.SupportedPropositionProjectionError local) + | VampireObligationLocalProjectionFailed + !Backend.LocalPremiseOrdinal + !(Backend.SupportedPropositionProjectionError local) + | VampireObligationLocalClassificationFailed + !Backend.LocalPremiseOrdinal + !(Backend.BackendClassificationError ObjectId) + | VampireObligationFactNotVisible + !SemanticFactOccurrenceFingerprint + | VampireObligationFactInvalid + !SemanticFactOccurrenceFingerprint + | VampireObligationPlanningFailed + !(Backend.TypedProblemError local ObjectId) + | VampireObligationEncodingFailed + !(Tptp.TypedTptpPreparationError local ObjectId) + deriving stock (Show, Eq) + +data ScopedVampirePremise local origin = ScopedVampirePremise + !Backend.LocalPremiseOrdinal + !origin + !(Vector (local, CoreType)) + !(ScopedCheckedCore ObjectId) + +scopedVampirePremise + :: Backend.LocalPremiseOrdinal + -> origin + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> ScopedVampirePremise local origin +scopedVampirePremise = + ScopedVampirePremise + +data PreparedVampireObligation local origin = + PreparedVampireObligation + !(Backend.TypedProblem + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + !(Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + +-- | Prepare a scoped task for a trusted structural proof checker. This +-- validates the typed problem but does not establish how its local judgments +-- derive from the enclosing theorem. 'Checking.Exact.Proof' owns that +-- composition on the production path. +prepareScopedVampireObligationDriver + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationDriver + claimSupport claim scopedLocals auxiliaryTags selection = + prepareScopedVampireObligationForMode + Provers.DirectTask + claimSupport + claim + scopedLocals + auxiliaryTags + selection + +-- | Prepare the one indirect task admitted by the exact proof compiler. +-- The target check keeps contradictory input from authorizing another goal. +prepareScopedContradictionObligationDriver + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedContradictionObligationDriver + claimSupport claim scopedLocals auxiliaryTags selection + | scopedCoreType claim /= TyProp || scopedCoreTerm claim /= CFalsum = + pure (Left VampireObligationIndirectTargetNotFalsum) + | otherwise = + prepareScopedVampireObligationForMode + Provers.IndirectTask + claimSupport + claim + scopedLocals + auxiliaryTags + selection + +prepareScopedVampireObligationLowering + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationLowering + claimSupport claim scopedLocals auxiliaryTags selection = + prepareScopedVampireObligationForModeLowering + Provers.DirectTask + claimSupport claim scopedLocals auxiliaryTags selection + +prepareScopedContradictionObligationLowering + :: Ord local + => Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedContradictionObligationLowering + claimSupport claim scopedLocals auxiliaryTags selection + | scopedCoreType claim /= TyProp || scopedCoreTerm claim /= CFalsum = + pure (Left VampireObligationIndirectTargetNotFalsum) + | otherwise = + prepareScopedVampireObligationForModeLowering + Provers.IndirectTask + claimSupport claim scopedLocals auxiliaryTags selection + +prepareScopedVampireObligationForModeLowering + :: Ord local + => Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> LoweringDriver + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationForModeLowering + taskMode claimSupport claim scopedLocals auxiliaryTags selection = + LoweringDriver do + LoweringState _resolver (ProspectiveBuilder builder) _validation <- + State.get + liftIO + (prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection) + +prepareScopedVampireObligationForMode + :: Ord local + => Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> ModuleDriver failure + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationForMode + taskMode claimSupport claim scopedLocals auxiliaryTags selection = + ModuleDriver do + DriverState _resolver builder _prefix _validation <- State.get + State.lift + (Except.liftIO + (prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection)) + +prepareScopedVampireObligationWith + :: (Ord local) + => BuilderState evidence + -> Provers.VampireTaskMode + -> Vector (local, CoreType) + -> ScopedCheckedCore ObjectId + -> [ScopedVampirePremise local origin] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> IO + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +prepareScopedVampireObligationWith + builder taskMode claimSupport claim scopedLocals + auxiliaryTags selection = + forceVampirePreparation preparation + where + closure = logicalBuilderObjectClosure builder + globalType = (`lookupCheckedObjectType` closure) + preparation = do + supportedClaim <- + first VampireObligationClaimProjectionFailed + (Backend.projectSupportedProposition + globalType + claimSupport + claim) + locals <- traverse prepareLocal scopedLocals + prepareVampireObligationWith + taskMode + builder + closure + supportedClaim + locals + auxiliaryTags + selection + + prepareLocal + (ScopedVampirePremise + ordinal origin support proposition) = do + supported <- + first + (VampireObligationLocalProjectionFailed ordinal) + (Backend.projectSupportedProposition + globalType + support + proposition) + first + (VampireObligationLocalClassificationFailed ordinal) + (Backend.typedLocalPremise + globalType + ordinal + origin + supported) + +prepareVampireObligationWith + :: Ord local + => Provers.VampireTaskMode + -> BuilderState evidence + -> CheckedObjectClosure + -> Backend.SupportedProposition local ObjectId + -> [Backend.TypedLocalPremise local origin ObjectId] + -> [FoundationAxiomTag] + -> VampirePremiseSelection + -> Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin) +prepareVampireObligationWith + taskMode builder closure claim locals auxiliaryTags selection = do + let globalType = (`lookupCheckedObjectType` closure) + selected <- + selectVampireFacts + globalType + builder + selection + let localPremisePolicy = + case selection of + VampireImplicitPremises -> + Backend.FirstOrderLocals + VampireExplicitPremises{} + | any + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> False + Backend.RequiresTh0{} -> True) + selected -> + Backend.CompleteLocals + | otherwise -> + Backend.FirstOrderLocals + VampireLocalPremises -> + Backend.CompleteLocals + higherOrderPolicy = + case selection of + VampireImplicitPremises -> + Backend.ImplicitConstructionJustification + VampireExplicitPremises{} -> + Backend.ExplicitHigherOrderJustification + VampireLocalPremises -> + Backend.ExplicitHigherOrderJustification + propositionDependencies = + foundationAxiomDependencies + . Backend.supportedPropositionTerm + requiredAuxiliaryTags = + Set.toAscList + ( Set.fromList auxiliaryTags + <> propositionDependencies claim + <> foldMap + (propositionDependencies + . Backend.typedBackendFactProposition) + selected + <> foldMap + (propositionDependencies + . Backend.typedLocalPremiseProposition) + (Backend.selectTypedLocalPremises + localPremisePolicy + locals) + ) + auxiliaries = + Backend.typedFoundationAuxiliaryInput + (logicalBuilderFoundation builder) + <$> requiredAuxiliaryTags + problem <- + first VampireObligationPlanningFailed + (Backend.planTypedProblem + globalType + selected + claim + locals + auxiliaries + localPremisePolicy + higherOrderPolicy) + task <- + first VampireObligationEncodingFailed + (Provers.prepareTypedProverTask + taskMode + problem) + pure (PreparedVampireObligation problem task) + +forceVampirePreparation + :: Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin) + -> IO + (Either + (VampireObligationPreparationError local) + (PreparedVampireObligation local origin)) +forceVampirePreparation preparation = + Exception.evaluate (forcePrepared preparation) + where + forcePrepared result = + case result of + Left err -> err `seq` result + Right prepared@(PreparedVampireObligation _ task) -> + let request = Provers.preparedTypedProverRequest task + in Provers.preparedVerificationByteCount request `seq` + Provers.preparedVerificationRequestId request `seq` + prepared `seq` + result + +selectVampireFacts + :: (ObjectId -> Maybe CoreType) + -> BuilderState evidence + -> VampirePremiseSelection + -> Either + (VampireObligationPreparationError local) + (Vector + (Backend.TypedBackendFact + SemanticFactOccurrenceFingerprint + ObjectId)) +selectVampireFacts globalType builder selection = + Vector.fromList <$> case selection of + VampireImplicitPremises -> + mapMaybeM prepareImplicit + (Map.toAscList (logicalBuilderFacts builder)) + VampireExplicitPremises fingerprints -> + traverse prepareExplicit + (stableUniqueBy id (toList fingerprints)) + VampireLocalPremises -> + Right [] + where + prepareImplicit (fingerprint, authorized@(FactEntry + _proposition occurrence _authorization)) + | semanticFactSearchEligibility occurrence + /= SearchEligible = + Right Nothing + | otherwise = do + fact <- prepareFact fingerprint authorized + pure case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> Just fact + Backend.RequiresTh0{} -> Nothing + + prepareExplicit fingerprint = + case Map.lookup fingerprint (logicalBuilderFacts builder) of + Nothing -> + Left (VampireObligationFactNotVisible fingerprint) + Just authorized -> + prepareFact fingerprint authorized + + prepareFact fingerprint + (FactEntry proposition occurrence _authorization) + | semanticFactFingerprint occurrence /= fingerprint = + Left (VampireObligationFactInvalid fingerprint) + | otherwise = do + supported <- + first + (const + (VampireObligationFactInvalid fingerprint)) + (Backend.supportedProposition + Vector.empty + (embedClosedCore + [] + (checkedPropositionTerm proposition))) + capability <- + first + (const + (VampireObligationFactInvalid fingerprint)) + (Backend.classifySupportedProposition + globalType + supported) + pure + (Backend.typedBackendFact + fingerprint + supported + capability) + + mapMaybeM action = + fmap catMaybes . traverse action + +data LocalClaim = LocalClaim + !BuilderIdentity + !DeclarationInvocation + !FactSlot + !CheckedPropositionContent + +useAuthorizedFact + :: SemanticFactOccurrenceFingerprint + -> CandidateProof ImportIx +useAuthorizedFact fingerprint = do + proposition <- consumeAuthorizedFact fingerprint + registerKernelImport proposition + +-- | Validate one fact capability and accumulate only its safety effect. +-- Backend use does not register a kernel import. +consumeAuthorizedFact + :: SemanticFactOccurrenceFingerprint + -> CandidateProof CheckedPropositionContent +consumeAuthorizedFact fingerprint = CandidateProof do + state <- State.get + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + staged = + findPendingByFingerprint + fingerprint + (declarationPending declaration) + case staged of + Just pending -> + consumePendingFact pending state + Nothing -> + case Map.lookup + fingerprint + (logicalBuilderFacts builder) of + Nothing -> + State.lift + (Except.throwError + (AuthorizedFactNotVisible fingerprint)) + Just authorized -> + consumeBuilderAuthorizedFact authorized state + +-- | Materialize one sealed direct import and its transitive parents. The +-- interface DAG is folded imported-before-importer and each producer +-- occurrence receives a fresh capability for this consuming builder. +importSealedModule + :: ImportedModuleEvidence + -> Declaration () +importSealedModule evidence = Declaration do + state <- State.get + when + (isJust (declarationObjectClosure state)) + (State.lift + (Except.throwError ImportedModuleAfterAuthorization)) + let builder = declarationBuilder state + interfaceId = + semanticInterfaceAssertedId + (evidenceInterface evidence) + unless + (interfaceId `elem` + logicalBuilderDirectSemanticInputs builder) + (State.lift + (Except.throwError + (ImportedModuleNotDirect interfaceId))) + imported <- + State.lift + (Except.liftEither + (foldImportedEvidence evidence builder)) + State.put + state + { declarationBuilder = imported + , declarationObjectClosure = Nothing + } + +-- The walking path keeps complete aggregate maps. Measure long chains before +-- replacing this representation. +foldImportedEvidence + :: ImportedModuleEvidence + -> LogicalBuilder + -> Either DeclarationError LogicalBuilder +foldImportedEvidence evidence builder + | interfaceId + `Set.member` logicalBuilderImportedInterfaces builder = + Right builder + | otherwise = do + unless + (semanticInterfaceDirectInputs interface + == (semanticInterfaceAssertedId . evidenceInterface + <$> parents)) + (Left + (ImportedEvidenceDirectMismatch + (semanticInterfaceDirectInputs interface) + (semanticInterfaceAssertedId . evidenceInterface + <$> parents))) + withParents <- foldM + (flip foldImportedEvidence) + builder + parents + objectClosure <- + first + DeclarationObjectValidationFailed + (extendImportedObjectClosure + (logicalBuilderObjectClosure withParents) + objects) + importedFacts <- foldM + (insertImportedFact withParents) + (logicalBuilderFacts withParents) + (Map.elems entries) + importedAliases <- foldM + (insertImportedAlias importedFacts) + (logicalBuilderAliases withParents) + [ ( alias + , ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias) + ) + | delta <- semanticInterfaceDeclarations interface + , alias <- declarationDeltaAliases delta + ] + importedStructures <- foldM + (insertSemanticStructure objectClosure) + (logicalBuilderStructures withParents) + [ descriptor + | delta <- semanticInterfaceDeclarations interface + , descriptor <- semanticEnvironmentStructures + (declarationDeltaEnvironment delta) + ] + importedGlobals <- foldM + (insertImportedGlobal objectClosure importedStructures) + (logicalBuilderGlobals withParents) + [ binding + | delta <- semanticInterfaceDeclarations interface + , binding <- semanticEnvironmentBindings + (declarationDeltaEnvironment delta) + ] + pure + withParents + { logicalBuilderFacts = importedFacts + , logicalBuilderAliases = importedAliases + , logicalBuilderGlobals = importedGlobals + , logicalBuilderStructures = importedStructures + , logicalBuilderObjectClosure = objectClosure + , logicalBuilderImportedInterfaces = + Set.insert + interfaceId + (logicalBuilderImportedInterfaces withParents) + } + where + ImportedModuleEvidence interface parents entries objects = evidence + interfaceId = semanticInterfaceAssertedId interface + + extendImportedObjectClosure closure asserted = + extendObjectClosure + closure + [ object + | object <- asserted + , assertedObjectId object + `Set.notMember` checkedObjectIds closure + ] + + insertImportedFact + current facts pair = do + let (occurrence, proposition) = pair + fingerprint = semanticFactFingerprint occurrence + authority = semanticFactAuthority occurrence + _ <- + first ImportedFactMaterializationFailed + (Materialization.checkImportedOccurrence + (logicalBuilderTheory current) + fingerprint + occurrence + proposition + authority) + let authorization = + BuilderFactAuthorization + (logicalBuilderIdentity current) + (semanticFactSlot occurrence) + authority + authorized = + FactEntry proposition occurrence authorization + case Map.lookup fingerprint facts of + Nothing -> + pure (Map.insert fingerprint authorized facts) + Just existing + | equivalentAuthorizedFact existing authorized -> + pure facts + | otherwise -> + Left (ImportedFactCollision fingerprint) + + insertImportedAlias facts aliases (alias, origin) = do + let name = semanticAliasName alias + target = semanticAliasTarget alias + unless + (Map.member target facts) + (Left (ImportedAliasTargetMissing target)) + case Map.lookup name aliases of + Nothing -> + pure + (Map.insert + name + (ImportedAliasBinding target origin) + aliases) + Just (ImportedAliasBinding existingTarget existingOrigin) + | existingTarget == target -> + pure aliases + | otherwise -> + Left + (ImportedAliasCollision + name existingOrigin origin) + + insertImportedGlobal closure structures globals binding = do + let key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + _ <- + first + (ImportedGlobalTargetInvalid key target) + (validateSemanticGlobalBindingTarget + (structureOperationBindings structures) + closure binding) + case Map.lookup key globals of + Nothing -> pure (Map.insert key target globals) + Just existing + | existing == target -> pure globals + | otherwise -> + Left (ImportedGlobalCollision key existing target) + +insertSemanticStructure + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> SemanticStructureDescriptor + -> Either + DeclarationError + (Map SemanticStructurePhrase ResolvedStructure) +insertSemanticStructure closure structures descriptor = do + validateSemanticStructureTargets closure descriptor + let structurePhrase = semanticStructureDescriptorPhrase descriptor + case Map.lookup structurePhrase structures of + Just (ResolvedStructure existing _ _) + | existing == descriptor -> Right structures + | otherwise -> + Left + (ImportedStructureCollision + structurePhrase existing descriptor) + Nothing -> do + parents <- traverse resolveParent + (semanticStructureDescriptorParents descriptor) + inherited <- foldM mergeParentOperations Map.empty parents + complete <- foldM insertOwnOperation inherited + (semanticStructureDescriptorOperations descriptor) + let ancestors = + Set.unions + [ Set.insert + (semanticStructureDescriptorPhrase + (resolvedStructureDescriptor parent)) + parentAncestors + | parent@(ResolvedStructure _ parentAncestors _) <- parents + ] + resolved = ResolvedStructure descriptor ancestors complete + Right (Map.insert structurePhrase resolved structures) + where + resolveParent parentPhrase = + maybe + (Left + (SemanticStructureParentMissing + (semanticStructureDescriptorPhrase descriptor) + parentPhrase)) + Right + (Map.lookup parentPhrase structures) + + mergeParentOperations operations + (ResolvedStructure _descriptor _ancestors parentOperations) = + foldM insertInheritedOperation operations + (Map.toAscList parentOperations) + + insertInheritedOperation operations (symbol, operation) = + insertResolvedOperation symbol operation operations + + insertOwnOperation operations operation = + insertResolvedOperation + (semanticStructureOperationSymbol operation) + (ResolvedStructureOperation + (semanticStructureOperationObject operation) + (semanticStructureDescriptorPhrase descriptor)) + operations + + insertResolvedOperation symbol incoming operations = + case Map.lookup symbol operations of + Nothing -> Right (Map.insert symbol incoming operations) + Just (ResolvedStructureOperation existingObject existingOrigin) -> + case incoming of + ResolvedStructureOperation incomingObject incomingOrigin + | existingObject == incomingObject -> Right operations + | otherwise -> + Left + (SemanticStructureOperationConflict + symbol existingOrigin incomingOrigin) + +validateSemanticStructureTargets + :: CheckedObjectClosure + -> SemanticStructureDescriptor + -> Either DeclarationError () +validateSemanticStructureTargets closure descriptor = do + traverse_ validatePredicate + (semanticStructureDescriptorPredicate descriptor) + traverse_ validateOperation + (semanticStructureDescriptorOperations descriptor) + where + validatePredicate object = + validateObjectType + (SemanticStructurePredicateTargetInvalid + (semanticStructureDescriptorPhrase descriptor)) + object + (TyArrow TySet TyProp) + + validateOperation operation = + validateObjectType + (SemanticStructureOperationTargetInvalid + (semanticStructureDescriptorPhrase descriptor) + (semanticStructureOperationSymbol operation)) + (semanticStructureOperationObject operation) + (TyArrow TySet TySet) + + validateObjectType failure object expected = + case lookupCheckedObjectType object closure of + Nothing -> Left (failure object Nothing expected) + Just actual + | actual == expected -> Right () + | otherwise -> Left (failure object (Just actual) expected) + +equivalentAuthorizedFact + :: FactEntry BuilderFactAuthorization + -> FactEntry BuilderFactAuthorization + -> Bool +equivalentAuthorizedFact + (FactEntry leftProposition leftOccurrence + (BuilderFactAuthorization leftIdentity leftSlot leftAuthority)) + (FactEntry rightProposition rightOccurrence + (BuilderFactAuthorization rightIdentity rightSlot rightAuthority)) = + checkedPropositionId leftProposition + == checkedPropositionId rightProposition + && leftOccurrence == rightOccurrence + && leftIdentity == rightIdentity + && leftSlot == rightSlot + && leftAuthority == rightAuthority + +-- | Driver-level form used before the first declaration of a consuming +-- module. It changes only the private builder's imported fact environment; +-- no declaration prefix or durable envelope is emitted. +importSealedModuleDriver + :: ImportedModuleEvidence + -> ModuleDriver failure () +importSealedModuleDriver evidence = ModuleDriver do + DriverState resolver builder prefix validationRun <- + State.get + let declaration = + initialDeclarationState + resolver + validationRun + EnvironmentImportMode + builder + result <- + liftIO + (Except.runExceptT + (State.runStateT + (runDeclaration + (importSealedModule evidence)) + declaration)) + case result of + Left failure -> + Except.throwError (DriverDeclarationFailed failure) + Right (_value, importedState) -> + State.put + (DriverState + resolver + (declarationBuilder importedState) + prefix + validationRun) + +useStagedCandidate + :: ReservedCandidate + -> CandidateProof ImportIx +useStagedCandidate premise = CandidateProof do + state <- State.get + let current = candidateProofCandidate state + declaration = candidateProofDeclaration state + State.lift + (Except.liftEither + (validateReservedCandidate + declaration + premise)) + State.lift + (Except.liftEither + (validateStrictCandidateStage premise current)) + pending <- + maybe + (State.lift + (Except.throwError + (StagedPremiseNotAuthorized + (reservedCandidateSlot premise)))) + pure + (Map.lookup + (reservedCandidateSlot premise) + (declarationPending declaration)) + let proposedAuthority = + validationTarget (pendingCandidateCertificate pending) + checkedStage <- + State.lift + (Except.liftEither + (prepareCheckedDeclarationStage + declaration + (candidateProofObjectClosure state) + [(premise, proposedAuthority)])) + stagedProposition <- + State.lift + (Except.liftEither + (useCheckedStageFact checkedStage current premise)) + proposition <- consumePendingFact pending state + unless + (checkedPropositionId stagedProposition + == checkedPropositionId proposition) + (State.lift + (Except.throwError + (PlanningFactContractMismatch + (reservedCandidateSlot premise)))) + updated <- State.get + appendCandidatePremise proposition updated + +validateStrictCandidateStage + :: ReservedCandidate + -> ReservedCandidate + -> Either DeclarationError () +validateStrictCandidateStage premise current = + unless + (reservedStage premise < reservedStage current) + (Left + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + (reservedCandidateStage premise) + (reservedCandidateSlot current) + (reservedCandidateStage current))) + +prepareCheckedDeclarationStage + :: DeclarationState + -> CheckedObjectClosure + -> [(ReservedCandidate, FactAuthority)] + -> Either DeclarationError CheckedDeclarationStage +prepareCheckedDeclarationStage declaration closure candidates = do + entries <- foldM insertCandidate Map.empty candidates + pure (CheckedDeclarationStage ownSlot closure entries) + where + builder = declarationBuilder declaration + ownSlot = declarationOwnSlot declaration + + insertCandidate entries (candidate, authority) = do + validateReservedCandidate declaration candidate + let slot = reservedCandidateSlot candidate + unless + (factAuthorityTheorem authority + == candidateTheoremReference builder candidate) + (Left (PlanningFactContractMismatch slot)) + when + (Map.member slot entries) + (Left (PlanningFactContractMismatch slot)) + let occurrence = candidateOccurrence candidate authority + evidence = PlanningEvidence + authority + (Just + (PlanningProvenance + ownSlot + (reservedStage candidate) + slot)) + pure + (Map.insert + slot + (FactEntry + (candidateCheckedProposition candidate) + occurrence + evidence) + entries) + +useCheckedStageFact + :: CheckedDeclarationStage + -> ReservedCandidate + -> ReservedCandidate + -> Either DeclarationError CheckedPropositionContent +useCheckedStageFact + (CheckedDeclarationStage ownSlot closure entries) + current + premise = do + validateStrictCandidateStage premise current + let slot = reservedCandidateSlot premise + FactEntry proposition occurrence + (PlanningEvidence authority provenance) <- + maybe + (Left (PlanningFactContractMismatch slot)) + Right + (Map.lookup slot entries) + unless + ( provenance + == Just + (PlanningProvenance + ownSlot + (reservedStage premise) + slot) + && semanticFactSlot occurrence == slot + && semanticFactAuthority occurrence == authority + && checkedPropositionId proposition + == checkedPropositionId + (candidateCheckedProposition premise) + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch slot)) + pure proposition + +propositionMatchesClosure + :: CheckedObjectClosure + -> CheckedPropositionContent + -> Bool +propositionMatchesClosure closure proposition = + case validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm (checkedPropositionTerm proposition)) of + Right _ -> True + Left _ -> False + +candidateOccurrence + :: ReservedCandidate + -> FactAuthority + -> SemanticFactOccurrence +candidateOccurrence + (ReservedCandidate _ _ _ _ slot + (CandidateSpec _ eligibility _aliases)) + authority = + semanticFactOccurrence slot authority eligibility + +candidateAliases :: ReservedCandidate -> [SemanticName] +candidateAliases + (ReservedCandidate _ _ _ _ _ + (CandidateSpec _ _ aliases)) = + aliases + +proveLocalKernelClaim + :: CheckedPropositionContent + -> KernelDerivation ObjectId + -> CandidateProof LocalClaim +proveLocalKernelClaim proposition derivation = CandidateProof do + state <- State.get + void + (State.lift + (Except.liftEither + (replayCandidateKernel proposition derivation state))) + let candidate = candidateProofCandidate state + declaration = candidateProofDeclaration state + pure + (LocalClaim + (logicalBuilderIdentity + (candidateProofBuilder state)) + (declarationInvocation declaration) + (reservedCandidateSlot candidate) + proposition) + +useLocalClaim :: LocalClaim -> CandidateProof ImportIx +useLocalClaim + (LocalClaim identity invocation slot proposition) = + CandidateProof do + state <- State.get + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + candidate = candidateProofCandidate state + unless + ( identity == logicalBuilderIdentity builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot candidate + ) + (State.lift + (Except.throwError LocalClaimOutsideCandidate)) + appendCandidatePremise proposition state + + +authorizeKernelProofCandidate + :: ReservedCandidate + -> CandidateProof (KernelDerivation ObjectId) + -> Declaration () +authorizeKernelProofCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + (derivation, final) <- + State.runStateT (runCandidateProof proof) initial + when + (isNothing (candidateProofCachedValidation final)) + (void + (Except.liftEither + (replayCandidateKernel + (candidateCheckedProposition candidate) + derivation + final))) + completeCandidateWithValidation + candidate + (CheckedSourceProof + (acceptedRequestIds final)) + (candidateProofSafety final) + final + +authorizeKernelConstructionCandidate + :: KernelConstructionDescriptor + -> ReservedCandidate + -> CandidateProof (KernelDerivation ObjectId) + -> Declaration () +authorizeKernelConstructionCandidate descriptor candidate proof = + authorizeOneCandidate candidate \initial -> do + (derivation, final) <- + State.runStateT (runCandidateProof proof) initial + when + (isNothing (candidateProofCachedValidation final)) do + replayed <- + Except.liftEither + (replayCandidateKernel + (candidateCheckedProposition candidate) + derivation + final) + Except.liftEither + (validateKernelConstruction + descriptor + (candidateCheckedProposition candidate) + replayed + final) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety final) + final + +authorizeDefinitionEquationCandidate + :: ObjectId + -> ReservedCandidate + -> Declaration () +authorizeDefinitionEquationCandidate identity candidate = + authorizeOneCandidate candidate \initial -> do + when + (isNothing (candidateProofCachedValidation initial)) + (unless + (matchesDefinitionEquation + identity + (candidateCheckedProposition candidate) + initial) + (Except.throwError + DefinitionEquationCandidateMismatch)) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction + (CheckedDefinitionEquation identity)) + (candidateProofSafety initial) + initial + +-- | Authorize only the extensional fact deterministically derived from the +-- checked source construction and its committed transparent object. +authorizeNamedSetConstructionCandidate + :: ObjectId + -> NamedSetConstruction ObjectId + -> ReservedCandidate + -> Declaration () +authorizeNamedSetConstructionCandidate identity construction candidate = + authorizeOneCandidate candidate \initial -> do + let builder = candidateProofBuilder initial + (expected, descriptor) <- + Except.liftEither + (prepareNamedSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure initial) + identity + construction) + when (isNothing (candidateProofCachedValidation initial)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate)) + ) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety initial) + initial + +-- | Authorize the relational extensional view only after consuming the exact +-- strictly-earlier functionality candidate. The consumed candidate supplies +-- both real authority safety and the proposition rechecked by the confined +-- construction schema; a caller cannot substitute an arbitrary theorem. +authorizeRelationalSetConstructionCandidate + :: ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> ReservedCandidate + -> ReservedCandidate + -> Declaration () +authorizeRelationalSetConstructionCandidate + identity construction functionality candidate = + authorizeOneCandidate candidate \initial -> do + (_used, final) <- + State.runStateT + (runCandidateProof (useStagedCandidate functionality)) + initial + let builder = candidateProofBuilder final + functionalityTerm = + checkedPropositionTerm + (candidateCheckedProposition functionality) + (expected, descriptor) <- + Except.liftEither + (prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure final) + identity + construction + functionalityTerm) + when (isNothing (candidateProofCachedValidation final)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate))) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety final) + final + +authorizeSourceAxiomCandidate + :: ReservedCandidate + -> Declaration () +authorizeSourceAxiomCandidate candidate = + authorizeOneCandidate candidate \initial -> + let safety = + addCandidateEscape + SourceAxiom + initialCandidateSafety + in completeCandidateWithValidation + candidate + SourceAxiomAuthorization + safety + initial + +-- | Complete one exact deterministic datatype as a single trusted family. +-- The descriptor, objects, and complete candidate batch must agree exactly. +-- Law semantics are trusted to the sole production compiler in +-- "Checking.Exact.Datatype"; this boundary validates its complete inventory, +-- not the meaning of each generated proposition. +authorizeDatatypeCompilationCandidates + :: DatatypeCompilationDescriptor + -> ObjectId + -> NonEmpty ObjectId + -> NonEmpty ReservedCandidate + -> Declaration () +authorizeDatatypeCompilationCandidates + suppliedDescriptor carrier constructors candidates = + Declaration do + state <- State.get + let builder = declarationBuilder state + objectInventory = carrier : NonEmpty.toList constructors + declaredObjects = + assertedObjectId + <$> reverse (declarationObjectsReversed state) + reservedCandidates = + Map.elems (declarationReservations state) + theoremInventory = + candidateTheoremReference builder + <$> NonEmpty.toList candidates + expectedDescriptor = + datatypeCompilationDescriptor + carrier + constructors + theoremInventory + stages = + nubOrd + (reservedCandidateStage + <$> NonEmpty.toList candidates) + unless + ( suppliedDescriptor == expectedDescriptor + && declaredObjects == objectInventory + && reservedCandidates == NonEmpty.toList candidates + && length stages == 1 + ) + (State.lift + (Except.throwError + DatatypeCompilationDescriptorMismatch)) + runDeclaration + (traverse_ + (authorizeDatatypeCandidate suppliedDescriptor) + candidates) + +authorizeDatatypeCandidate + :: DatatypeCompilationDescriptor + -> ReservedCandidate + -> Declaration () +authorizeDatatypeCandidate descriptor candidate = + authorizeOneCandidate candidate \initial -> + completeCandidateWithValidation + candidate + (TrustedCompilation + (DatatypeCompilation descriptor)) + initialCandidateSafety + initial + +authorizeOmittedCandidate + :: ReservedCandidate + -> CandidateProof () + -> Declaration () +authorizeOmittedCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + cached <- + selectProofCandidateValidation candidate initial + let preparedInitial = + initial + { candidateProofCachedValidation = cached + } + ((), final) <- + State.runStateT (runCandidateProof proof) preparedInitial + let safety = candidateProofSafety final + unless + (Omitted + `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (candidateSafetyAuthority safety))) + (Except.throwError OmittedProofDidNotRecordUse) + completeCandidateWithValidation + candidate + OmittedAuthorization + safety + final + +-- | Retain the closed candidate-target path while scoped proof composition is +-- introduced. It uses the same environment validation as local obligations. +acceptVampireObligation + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + origin + ObjectId + -> CandidateProof () +acceptVampireObligation prepared = + acceptValidatedVampireTask + (validateCandidateVampireProblem prepared) + prepared + +-- | Validate one internally prepared scoped obligation, then retain its exact +-- accepted request. The trusted caller remains responsible for structural +-- local-proof composition. +acceptPreparedVampireObligation + :: (Eq local, Eq origin) + => PreparedVampireObligation local origin + -> CandidateProof () +acceptPreparedVampireObligation + (PreparedVampireObligation expected prepared) = + acceptValidatedVampireTask + (validatePreparedVampireProblem expected prepared) + prepared + +-- | Prepare and execute the current closed candidate using exactly the +-- staged premises already consumed by its trusted declaration compiler. +acceptCurrentCandidateVampire :: CandidateProof () +acceptCurrentCandidateVampire = + prepareCurrentCandidateVampire + >>= acceptPreparedVampireObligation + +-- | Prepare the current closed candidate without executing its request. The +-- declaration-owned batch authorizer uses this seam only after all strictly +-- earlier staged premises have been consumed. +prepareCurrentCandidateVampire + :: CandidateProof (PreparedVampireObligation Void ()) +prepareCurrentCandidateVampire = CandidateProof do + initial <- State.get + let builder = candidateProofBuilder initial + closure = candidateProofObjectClosure initial + target = candidateCheckedProposition + (candidateProofCandidate initial) + premises = + [ proposition + | CandidatePremise proposition <- + reverse (candidateProofPremisesReversed initial) + ] + preparation = + prepareClosedCandidateVampire + builder closure target premises + preparedResult <- + State.lift + (liftIO + (forceVampirePreparation preparation)) + prepared <- + State.lift + (Except.liftEither + (first + CurrentCandidateVampirePreparationFailed + preparedResult)) + pure prepared + +prepareClosedCandidateVampire + :: BuilderState evidence + -> CheckedObjectClosure + -> CheckedPropositionContent + -> [CheckedPropositionContent] + -> Either + (VampireObligationPreparationError Void) + (PreparedVampireObligation Void ()) +prepareClosedCandidateVampire builder closure target premises = do + supportedTarget <- + first + VampireObligationClaimProjectionFailed + (Backend.projectSupportedProposition + globalType + (Vector.empty :: Vector (Void, CoreType)) + (closed target)) + locals <- + traverse + prepareLocal + (zip [0 :: Natural ..] premises) + prepareVampireObligationWith + Provers.DirectTask + builder + closure + supportedTarget + locals + [] + VampireLocalPremises + where + globalType = (`lookupCheckedObjectType` closure) + closed proposition = + embedClosedCore [] + (checkedPropositionTerm proposition) + + prepareLocal (index, proposition) = do + let ordinal = Backend.localPremiseOrdinal index + supported <- + first + (VampireObligationLocalProjectionFailed ordinal) + (Backend.projectSupportedProposition + globalType + (Vector.empty :: Vector (Void, CoreType)) + (closed proposition)) + first + (VampireObligationLocalClassificationFailed ordinal) + (Backend.typedLocalPremise + globalType ordinal () supported) + +acceptValidatedVampireTask + :: (CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState) + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProof () +acceptValidatedVampireTask validate prepared = CandidateProof do + initial <- State.get + validated <- State.lift (validate initial) + result <- + case candidateProofCachedValidation initial of + Nothing -> do + let resolver = + declarationVampireResolver + (candidateProofDeclaration initial) + Just <$> State.lift (resolveOneVampire resolver prepared) + Just _validation -> + pure Nothing + final <- + State.lift + (acceptVampireBatchMemberResult + prepared result validated) + State.put final + +-- | Complete one checked source candidate after all of its obligations have +-- been accepted in source order. The enclosing proof declaration owns the +-- exact syntax key and selects live or cached execution before this action. +authorizeVampireCandidate + :: ReservedCandidate + -> CandidateProof () + -> Declaration () +authorizeVampireCandidate candidate proof = + authorizeOneCandidate candidate \initial -> do + cached <- + selectProofCandidateValidation candidate initial + let preparedInitial = + initial + { candidateProofCachedValidation = cached + } + ((), final) <- + State.runStateT (runCandidateProof proof) preparedInitial + case acceptedRequestIds final of + [] -> + Except.throwError + VampireProofHasNoAcceptedObligations + requests -> + completeCandidateWithValidation + candidate + (CheckedSourceProof requests) + (candidateProofSafety final) + final + +data PreparedVampireCandidateBatchMember = + PreparedVampireCandidateBatchMember + !Location + !ReservedCandidate + !(Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + () + ObjectId) + !CandidateProofState + +data ResolvedVampireCandidateBatchMember = + ResolvedVampireCandidateBatchMember + !PreparedVampireCandidateBatchMember + !(Maybe + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + +-- | Authorize one complete, source-ordered candidate stage whose members are +-- mutually independent and each require exactly one closed Vampire request. +-- Every member is prepared and validated against the same declaration +-- baseline. Results are applied only after the complete live batch returns, +-- so no same-stage sibling can become authority for another member. +authorizeVampireCandidateBatch + :: NonEmpty + ( Location + , ReservedCandidate + , CandidateProof (PreparedVampireObligation Void ()) + ) + -> Declaration () +authorizeVampireCandidateBatch inputs = Declaration do + unprepared <- State.get + baseline <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + let supplied = + [ candidate + | (_location, candidate, _prepare) <- NonEmpty.toList inputs + ] + frontier = declarationAuthorizationFrontier baseline + expected = + List.filter + ((== CandidateStage frontier) . reservedStage) + (Map.elems (declarationReservations baseline)) + traverse_ + (State.lift + . Except.liftEither + . validateReservedCandidate baseline) + supplied + traverse_ + (\candidate -> + when + (Map.member + (reservedCandidateSlot candidate) + (declarationPending baseline)) + (State.lift + (Except.throwError + (CandidateAlreadyAuthorized + (reservedCandidateSlot candidate))))) + supplied + unless (supplied == expected) + (State.lift + (Except.throwError + (VampireCandidateBatchMismatch + (reservedCandidateSlot <$> expected) + (reservedCandidateSlot <$> supplied)))) + prepared <- + State.lift + (traverse + (prepareVampireCandidateBatchMember baseline) + inputs) + State.lift + (validateCachedVampireCandidateBatch + (NonEmpty.toList prepared)) + let live = + [ task + | PreparedVampireCandidateBatchMember + _location _candidate task final <- + NonEmpty.toList prepared + , isNothing (candidateProofCachedValidation final) + ] + liveResults <- + case NonEmpty.nonEmpty live of + Nothing -> pure [] + Just nonempty -> do + let resolver = + declarationVampireResolver baseline + results <- + liftIO + (resolveSynchronousVampireBatch resolver nonempty) + State.lift + (Except.liftEither + (validateVampireResolverResultCount + (length live) + results)) + pending <- + State.lift + (completeVampireCandidateBatch + (NonEmpty.toList prepared) + liveResults) + let withPending = + baseline + { declarationPending = + foldl' + (\entries item@(PendingCandidate candidate _ _) -> + Map.insert + (reservedCandidateSlot + candidate) + item + entries) + (declarationPending baseline) + pending + } + State.put (advanceAuthorizationFrontier withPending) + +prepareVampireCandidateBatchMember + :: DeclarationState + -> ( Location + , ReservedCandidate + , CandidateProof (PreparedVampireObligation Void ()) + ) + -> ExceptT DeclarationError IO PreparedVampireCandidateBatchMember +prepareVampireCandidateBatchMember + baseline (location, candidate, prepare) = do + initial <- + Except.liftEither + (initialCandidateProofState baseline candidate) + cached <- selectProofCandidateValidation candidate initial + let selected = + initial{candidateProofCachedValidation = cached} + (obligation, preparedState) <- + State.runStateT + (runCandidateProof + (locateProofObligation location prepare)) + selected + unless (null (acceptedRequestIds preparedState)) + (Except.throwError + (VampireCandidateBatchProofShapeMismatch + (reservedCandidateSlot candidate))) + let PreparedVampireObligation expected task = obligation + validated <- + Except.withExceptT + (ProofObligationFailedAt location) + (validatePreparedVampireProblem + expected task preparedState) + pure + (PreparedVampireCandidateBatchMember + location candidate task validated) + +completeVampireCandidateBatch + :: [PreparedVampireCandidateBatchMember] + -> [Either Provers.ProverProcessError Provers.ProverAnswer] + -> ExceptT DeclarationError IO [PendingCandidate] +completeVampireCandidateBatch members liveResults = do + resolved <- + Except.liftEither + (associateVampireCandidateBatchResults + members liveResults) + -- Integrity dominates ranked proof failure: validate every accepted run + -- before inspecting any ordinary process or prover rejection. + traverse_ validateAcceptedVampireBatchMember resolved + traverse_ rejectOrdinaryVampireBatchMember resolved + traverse completeVampireCandidateBatchMember resolved + +validateCachedVampireCandidateBatch + :: [PreparedVampireCandidateBatchMember] + -> ExceptT DeclarationError IO () +validateCachedVampireCandidateBatch = + traverse_ \member -> + when + (preparedVampireCandidateBatchMemberIsCached member) + (void + (completeVampireCandidateBatchMember + (ResolvedVampireCandidateBatchMember member Nothing))) + +associateVampireCandidateBatchResults + :: [PreparedVampireCandidateBatchMember] + -> [Either Provers.ProverProcessError Provers.ProverAnswer] + -> Either + DeclarationError + [ResolvedVampireCandidateBatchMember] +associateVampireCandidateBatchResults members = + go members + where + go [] [] = Right [] + go [] results = + Left + (VampireResolverBatchSizeMismatch + 0 + (length results)) + go (member : remaining) results + | preparedVampireCandidateBatchMemberIsCached member = + (ResolvedVampireCandidateBatchMember member Nothing :) + <$> go remaining results + | otherwise = + case results of + [] -> + Left (VampireResolverBatchSizeMismatch 1 0) + current : later -> + (ResolvedVampireCandidateBatchMember + member (Just current) :) + <$> go remaining later + +preparedVampireCandidateBatchMemberIsCached + :: PreparedVampireCandidateBatchMember + -> Bool +preparedVampireCandidateBatchMemberIsCached + (PreparedVampireCandidateBatchMember + _location _candidate _task state) = + isJust (candidateProofCachedValidation state) + +validateAcceptedVampireBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO () +validateAcceptedVampireBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location _candidate task _validated) + result) = + Except.withExceptT + (ProofObligationFailedAt location) + (validateAcceptedVampireResult task result) + +rejectOrdinaryVampireBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO () +rejectOrdinaryVampireBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location _candidate _task _validated) + result) = + traverse_ + (Except.throwError . ProofObligationFailedAt location) + (result >>= vampireResultFailure) + +completeVampireCandidateBatchMember + :: ResolvedVampireCandidateBatchMember + -> ExceptT DeclarationError IO PendingCandidate +completeVampireCandidateBatchMember + (ResolvedVampireCandidateBatchMember + (PreparedVampireCandidateBatchMember + location candidate task validated) + result) = do + final <- + Except.withExceptT + (ProofObligationFailedAt location) + (applyAcceptedVampireResult task result validated) + completeCandidateWithValidation + candidate + (CheckedSourceProof (acceptedRequestIds final)) + (candidateProofSafety final) + final + +acceptVampireBatchMemberResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +acceptVampireBatchMemberResult prepared result validated = do + validateAcceptedVampireResult prepared result + traverse_ Except.throwError (result >>= vampireResultFailure) + applyAcceptedVampireResult prepared result validated + +validateAcceptedVampireResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> ExceptT DeclarationError IO () +validateAcceptedVampireResult prepared result = do + let request = Provers.preparedTypedProverRequest prepared + traverse_ + (\resolved -> + traverse_ + (\accepted -> + unless + (Provers.acceptedVampireRequestId accepted + == Provers.preparedVerificationRequestId request) + (Except.throwError VampireRequestMismatch)) + (either (const Nothing) Provers.provedVampireRun resolved)) + result + +vampireResultFailure + :: Either Provers.ProverProcessError Provers.ProverAnswer + -> Maybe DeclarationError +vampireResultFailure = \case + Left failure -> + Just (VampireProcessFailed failure) + Right answer -> + case Provers.provedVampireRun answer of + Nothing -> + Just (VampireObligationRejected answer) + Just _accepted -> + Nothing + +applyAcceptedVampireResult + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Maybe (Either Provers.ProverProcessError Provers.ProverAnswer) + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +applyAcceptedVampireResult prepared result validated = do + traverse_ + (\resolved -> + case vampireResultFailure resolved of + Just failure -> + Except.throwError failure + Nothing -> + pure ()) + result + let request = Provers.preparedTypedProverRequest prepared + requestId = Provers.preparedVerificationRequestId request + pure + validated + { candidateProofAcceptedRequestsReversed = + requestId + : candidateProofAcceptedRequestsReversed validated + } + +selectProofCandidateValidation + :: ReservedCandidate + -> CandidateProofState + -> ExceptT + DeclarationError + IO + (Maybe Materialization.CandidateValidation) +selectProofCandidateValidation candidate initial = + case declarationValidationMode + (candidateProofDeclaration initial) of + EnvironmentImportMode -> + Except.throwError + ProofValidationOutsideProofDeclaration + ProofValidationMode{} -> do + (syntax, cached) <- + runDeclarationLookup + (lookupProofValidation candidate) + initial + pure + ((\record -> + Materialization.candidateProofValidation + record syntax) + <$> cached) + DeclarationValidationMode{} -> + pure (candidateProofCachedValidation initial) + +completeCandidateWithValidation + :: ReservedCandidate + -> DirectAuthorization + -> CandidateSafety + -> CandidateProofState + -> ExceptT DeclarationError IO PendingCandidate +completeCandidateWithValidation candidate direct safety final = do + pending <- + Except.liftEither + (freshCompletion + candidate + direct + safety + final) + traverse_ + (\validation -> + case Materialization.checkCandidateValidation + (logicalBuilderTheory + (candidateProofBuilder final)) + (logicalBuilderPrefix + (candidateProofBuilder final)) + (candidateCheckedProposition candidate) + (validationTarget + (pendingCandidateCertificate pending)) + direct + validation of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> + pure ()) + (candidateProofCachedValidation final) + pure pending + +runDeclarationLookup + :: Declaration value + -> CandidateProofState + -> ExceptT DeclarationError IO value +runDeclarationLookup action initial = + fst + <$> State.runStateT + (runDeclaration action) + (candidateProofDeclaration initial) + +pendingCandidateCertificate :: PendingCandidate -> ValidationCertificate +pendingCandidateCertificate + (PendingCandidate _ certificate _) = + certificate + +acceptedRequestIds :: CandidateProofState -> [PreparedRequestId] +acceptedRequestIds = + reverse . candidateProofAcceptedRequestsReversed + +freshCompletion + :: ReservedCandidate + -> DirectAuthorization + -> CandidateSafety + -> CandidateProofState + -> Either DeclarationError PendingCandidate +freshCompletion candidate direct safety proofState = do + let builder = candidateProofBuilder proofState + declaration = candidateProofDeclaration proofState + reference = candidateTheoremReference builder candidate + authority = candidateFactAuthority reference safety + void + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + (candidateProofObjectClosure proofState) + (checkedPropositionId + (candidateCheckedProposition candidate)) + (frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate))))) + certificate <- + first ValidationCertificateFailed + (validationCertificate authority direct) + let authorization = + PendingFactAuthorization + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + (declarationInvocation declaration) + (reservedCandidateSlot candidate) + authority + (reservedStage candidate) + pure + (PendingCandidate + candidate + certificate + authorization) + +authorizeOneCandidate + :: ReservedCandidate + -> (CandidateProofState + -> ExceptT DeclarationError IO PendingCandidate) + -> Declaration () +authorizeOneCandidate candidate complete = Declaration do + unprepared <- State.get + state <- + State.lift + (Except.liftEither + (prepareDeclarationClosure unprepared)) + State.lift + (Except.liftEither + (validateReservedCandidate state candidate)) + when + (Map.member + (reservedCandidateSlot candidate) + (declarationPending state)) + (State.lift + (Except.throwError + (CandidateAlreadyAuthorized + (reservedCandidateSlot candidate)))) + unless + (reservedStage candidate + == CandidateStage + (declarationAuthorizationFrontier state)) + (State.lift + (Except.throwError + (CandidateOutsideAuthorizationFrontier + (reservedCandidateSlot candidate) + (reservedCandidateStage candidate) + (declarationAuthorizationFrontier state)))) + initial <- State.lift + (Except.liftEither + (initialCandidateProofState state candidate)) + pending <- State.lift (complete initial) + let state' = + state + { declarationPending = + Map.insert + (reservedCandidateSlot candidate) + pending + (declarationPending state) + } + State.put (advanceAuthorizationFrontier state') + +advanceAuthorizationFrontier + :: DeclarationState + -> DeclarationState +advanceAuthorizationFrontier state + | all stageCompleted currentCandidates = + state + { declarationAuthorizationFrontier = + frontier + 1 + } + | otherwise = + state + where + frontier = declarationAuthorizationFrontier state + currentCandidates = + List.filter + ((== CandidateStage frontier) . reservedStage) + (Map.elems (declarationReservations state)) + stageCompleted candidate = + Map.member + (reservedCandidateSlot candidate) + (declarationPending state) + +initialCandidateProofState + :: DeclarationState + -> ReservedCandidate + -> Either DeclarationError CandidateProofState +initialCandidateProofState declaration candidate = do + closure <- declarationClosure declaration + cached <- + cachedDeclarationCandidateValidation declaration candidate + pure CandidateProofState + { candidateProofDeclaration = declaration + , candidateProofObjectClosure = closure + , candidateProofCandidate = candidate + , candidateProofCachedValidation = cached + , candidateProofPremisesReversed = [] + , candidateProofPremiseCount = 0 + , candidateProofSafety = initialCandidateSafety + , candidateProofAcceptedRequestsReversed = [] + } + +cachedDeclarationCandidateValidation + :: DeclarationState + -> ReservedCandidate + -> Either + DeclarationError + (Maybe Materialization.CandidateValidation) +cachedDeclarationCandidateValidation declaration candidate = + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> + Right Nothing + FreshDeclarationValidation -> + Right Nothing + CachedDeclarationValidation + syntax objects theorems record ordinals -> + maybe + (Left + (CachedDeclarationCandidateMissing + (reservedCandidateSlot candidate))) + (Right + . Just + . Materialization.candidateDeclarationValidation + record syntax objects theorems) + (Map.lookup + (reservedCandidateSlot candidate) + ordinals) + +reservedStage :: ReservedCandidate -> CandidateStage +reservedStage + (ReservedCandidate _ _ _ stage _ _) = + stage + +validateReservedCandidate + :: DeclarationState + -> ReservedCandidate + -> Either DeclarationError () +validateReservedCandidate declaration candidate = do + let builder = declarationBuilder declaration + ReservedCandidate + identity prefix invocation _stage slot _spec = candidate + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && Map.lookup slot + (declarationReservations declaration) + == Just candidate + ) + (Left (CandidateOutsideDeclaration slot)) + +instance Eq ReservedCandidate where + left == right = + reservedCandidateKey left == reservedCandidateKey right + +reservedCandidateKey + :: ReservedCandidate + -> (BuilderIdentity, PrefixContextId, DeclarationInvocation, CandidateStage, FactSlot) +reservedCandidateKey + (ReservedCandidate identity prefix invocation stage slot _spec) = + (identity, prefix, invocation, stage, slot) + + +consumeBuilderAuthorizedFact + :: FactEntry BuilderFactAuthorization + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + CheckedPropositionContent +consumeBuilderAuthorizedFact + (FactEntry proposition occurrence authorization) + state = do + let builder = candidateProofBuilder state + BuilderFactAuthorization + identity slot authority = authorization + unless + ( identity == logicalBuilderIdentity builder + && slot == semanticFactSlot occurrence + && authority == semanticFactAuthority occurrence + ) + (State.lift + (Except.throwError BuilderFactAuthorizationMismatch)) + accumulateAuthorizedSafety + proposition + authority + state + pure proposition + +consumePendingFact + :: PendingCandidate + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + CheckedPropositionContent +consumePendingFact + (PendingCandidate premise certificate authorization) + state = do + let builder = candidateProofBuilder state + declaration = candidateProofDeclaration state + PendingFactAuthorization + identity prefix invocation slot authority + premiseStageValue = authorization + current = candidateProofCandidate state + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot premise + && authority == validationTarget certificate + && premiseStageValue == reservedStage premise + ) + (State.lift + (Except.throwError PendingFactAuthorizationMismatch)) + unless + (reservedStage premise < reservedStage current) + (State.lift + (Except.throwError + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + (reservedCandidateStage premise) + (reservedCandidateSlot current) + (reservedCandidateStage current)))) + let proposition = candidateCheckedProposition premise + accumulateAuthorizedSafety + proposition + authority + state + pure proposition + +accumulateAuthorizedSafety + :: CheckedPropositionContent + -> FactAuthority + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + () +accumulateAuthorizedSafety proposition authority state = do + let expected = + theoremRef + (logicalBuilderTheory + (candidateProofBuilder state)) + (checkedPropositionId proposition) + safety <- + State.lift + (Except.liftEither + (first FactSafetyFailed + (accumulateFactSafety + expected + authority + (candidateProofSafety state)))) + State.put state{candidateProofSafety = safety} + +registerKernelImport + :: CheckedPropositionContent + -> CandidateProof ImportIx +registerKernelImport proposition = CandidateProof do + state <- State.get + appendCandidatePremise proposition state + +appendCandidatePremise + :: CheckedPropositionContent + -> CandidateProofState + -> StateT + CandidateProofState + (ExceptT DeclarationError IO) + ImportIx +appendCandidatePremise proposition state = do + let index = candidateProofPremiseCount state + State.put + state + { candidateProofPremisesReversed = + CandidatePremise proposition + : candidateProofPremisesReversed state + , candidateProofPremiseCount = index + 1 + } + pure (importIx index) + +findPendingByFingerprint + :: SemanticFactOccurrenceFingerprint + -> Map FactSlot PendingCandidate + -> Maybe PendingCandidate +findPendingByFingerprint fingerprint = + find + (\(PendingCandidate candidate certificate _authorization) -> + semanticFactOccurrenceFingerprint + (reservedCandidateSlot candidate) + (validationTarget certificate) + == fingerprint) + . Map.elems + +candidateImportJudgments + :: CandidateProofState + -> Either DeclarationError (Vector (DerivationImportJudgment ObjectId)) +candidateImportJudgments state = + Vector.fromList + <$> traverse + (\(CandidatePremise proposition) -> + first DerivationImportFailed + (derivationImportJudgment + (checkedPropositionTerm proposition))) + (reverse + (candidateProofPremisesReversed state)) + +replayCandidateKernel + :: CheckedPropositionContent + -> KernelDerivation ObjectId + -> CandidateProofState + -> Either + DeclarationError + (ReplayedKernelDerivation ObjectId) +replayCandidateKernel proposition derivation state = do + imports <- candidateImportJudgments state + let builder = candidateProofBuilder state + closure = candidateProofObjectClosure state + first KernelCompletionFailed + (replayKernelDerivation + (logicalBuilderFoundation builder) + defaultKernelReplayLimits + (`lookupCheckedObjectType` closure) + imports + (checkedPropositionTerm proposition) + derivation) + +validateKernelConstruction + :: KernelConstructionDescriptor + -> CheckedPropositionContent + -> ReplayedKernelDerivation ObjectId + -> CandidateProofState + -> Either DeclarationError () +validateKernelConstruction descriptor proposition replayed proofState = + unless matches + (Left KernelConstructionDescriptorMismatch) + where + builder = candidateProofBuilder proofState + noImports = Set.null (replayedKernelImportUses replayed) + noFoundation = Set.null (replayedKernelFoundationUses replayed) + noRules = Set.null (replayedKernelRuleUses replayed) + + matches = + case descriptor of + FoundationLeaf tag -> + noImports + && replayedKernelFoundationUses replayed + == Set.singleton tag + && noRules + && checkedPropositionTerm proposition + == mapFrozenGlobals + absurd + (foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag) + GuardedFoundationRules rules -> + replayedKernelRuleUses replayed + == guardedRuleTags rules + CheckedDefinitionEquation identity -> + noImports + && noFoundation + && noRules + && matchesDefinitionEquation identity proposition proofState + CheckedSetConstructionExtensionality{} -> + False + +matchesDefinitionEquation + :: ObjectId + -> CheckedPropositionContent + -> CandidateProofState + -> Bool +matchesDefinitionEquation identity proposition proofState = + case lookupCheckedObjectContent + identity + (candidateProofObjectClosure proofState) of + Just + (TransparentObjectContent + contentTheory coreType body) -> + contentTheory + == logicalBuilderTheory + (candidateProofBuilder proofState) + && frozenCoreTerm (checkedPropositionTerm proposition) + `elem` definitionEquationTargets identity coreType body + _ -> + False + +definitionEquationTargets + :: ObjectId + -> CoreType + -> CanonicalTerm ObjectId + -> [CanonicalTerm ObjectId] +definitionEquationTargets identity coreType body = + CEq coreType (CGlobal identity) body + : case (coreType, body) of + (TyArrow TySet TyProp, CLam TySet predicate) -> + [ CForall TySet + (CEq TyProp + (CApp (CGlobal identity) (CBound 0)) + predicate) + ] + _ -> [] + + +validateCandidateVampireProblem + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + Void + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validateCandidateVampireProblem prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + target = candidateCheckedProposition + (candidateProofCandidate initial) + Except.liftEither do + unless + ( Vector.null (Backend.supportedPropositionSupport claim) + && Backend.supportedPropositionTerm claim + == frozenCoreTerm (checkedPropositionTerm target) + ) + (Left VampireTargetMismatch) + unless + (Vector.null (Backend.typedProblemLocalPremises problem)) + (Left VampireLocalPremisesNotSupported) + validateVampireProblemEnvironment prepared initial + +validatePreparedVampireProblem + :: (Eq local, Eq origin) + => Backend.TypedProblem + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validatePreparedVampireProblem expectedProblem prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + Except.liftEither + (unless (problem == expectedProblem) + (Left VampireTargetMismatch) + ) + validateVampireProblemEnvironment prepared initial + +validateVampireProblemEnvironment + :: Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId + -> CandidateProofState + -> ExceptT DeclarationError IO CandidateProofState +validateVampireProblemEnvironment prepared initial = do + let problem = Provers.preparedTypedProverLogicalProblem prepared + builder = candidateProofBuilder initial + closure = candidateProofObjectClosure initial + Except.liftEither do + traverse_ + (\(identity, reportedType) -> + unless + (lookupCheckedObjectType identity closure + == Just reportedType) + (Left (VampireGlobalTypeMismatch identity))) + (Map.toList (Backend.typedProblemGlobalTypes problem)) + traverse_ + (validateFoundationAuxiliary builder) + (Backend.typedProblemAuxiliaries problem) + execCandidateProof initial do + traverse_ + validatePremise + (Backend.typedProblemGlobalPremises problem) + where + validatePremise selected = do + let fingerprint = Backend.typedBackendFactReference selected + proposition <- consumeAuthorizedFact fingerprint + state <- CandidateProof State.get + unless + ( Backend.supportedPropositionTerm + (Backend.typedBackendFactProposition selected) + == frozenCoreTerm + (checkedPropositionTerm proposition) + ) + (failCandidateProof + (VampirePremiseMismatch fingerprint)) + let closure = + candidateProofObjectClosure state + supported <- + either + (const + (failCandidateProof + (VampirePremiseCapabilityMismatch + fingerprint))) + pure + (Backend.supportedProposition + Vector.empty + (embedClosedCore + [] + (checkedPropositionTerm proposition))) + capability <- + either + (const + (failCandidateProof + (VampirePremiseCapabilityMismatch + fingerprint))) + pure + (Backend.classifySupportedProposition + (`lookupCheckedObjectType` closure) + supported) + unless + (capability + == Backend.typedBackendFactCapability selected) + (failCandidateProof + (VampirePremiseCapabilityMismatch fingerprint)) + + validateFoundationAuxiliary builder auxiliary = do + let tag = Backend.typedProblemAuxiliaryTag auxiliary + actual = + Backend.supportedPropositionTerm + (Backend.typedProblemAuxiliaryProposition auxiliary) + expectedTerm = + frozenCoreTerm + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + (logicalBuilderFoundation builder) + tag)) + unless (actual == expectedTerm) + (Left (VampireFoundationMismatch tag)) + +execCandidateProof + :: CandidateProofState + -> CandidateProof value + -> ExceptT DeclarationError IO CandidateProofState +execCandidateProof initial action = + snd <$> State.runStateT (runCandidateProof action) initial + +failCandidateProof + :: DeclarationError + -> CandidateProof value +failCandidateProof = + CandidateProof . State.lift . Except.throwError + +data ValidationMode + = EnvironmentImportMode + | ProofValidationMode !ProofSyntaxId + | DeclarationValidationMode !DeclarationSyntaxId + +data PlannedVampireDisposition + = PlannedCachedRequest !Provers.PreparedVerificationRequest + | PlannedLiveRequest + !Provers.PreparedVerificationRequest + !Provers.VampireHandle + | PlannedSynchronousRequest !Provers.PreparedVerificationRequest + +data PlannedCandidate = PlannedCandidate + !ReservedCandidate + !FactAuthority + !DirectAuthorization + ![PlannedVampireDisposition] + +data PlannedReplayRequest + = ReplayLive + !Provers.PreparedVerificationRequest + !Provers.VampireHandle + | ReplaySynchronous !Provers.PreparedVerificationRequest + +data PlannedValidationSelection + = PlannedFreshValidation + | PlannedProofValidation + !ProofValidationKey + !ProofValidationRecord + | PlannedCompiledValidation + !DeclarationValidationKey + !DeclarationValidationRecord + +-- | One completely lowered and submitted declaration. It carries no +-- builder authorization or materialized certificate; all authority is +-- reconstructed by the source-ordered admission cursor. +data PlannedDeclaration body = PlannedDeclaration + !(CheckedDeclaration body) + !PrefixContextId + !PrefixContextId + !DeclarationInterfaceDelta + ![AssertedObject] + ![CheckedPropositionContent] + ![NonEmpty PlannedCandidate] + !PlannedValidationSelection + +plannedDeclarationPreviousPrefix + :: PlannedDeclaration body + -> PrefixContextId +plannedDeclarationPreviousPrefix + (PlannedDeclaration _checked previous _next _delta + _objects _propositions _candidates _validation) = + previous + +plannedDeclarationNextPrefix + :: PlannedDeclaration body + -> PrefixContextId +plannedDeclarationNextPrefix + (PlannedDeclaration _checked _previous next _delta + _objects _propositions _candidates _validation) = + next + +plannedDeclarationDelta + :: PlannedDeclaration body + -> DeclarationInterfaceDelta +plannedDeclarationDelta + (PlannedDeclaration _checked _previous _next delta + _objects _propositions _candidates _validation) = + delta + +newtype PlanningIntegrityError = PlanningIntegrityError Text + deriving stock (Show) + +instance Exception.Exception PlanningIntegrityError + +-- | Advance the authority-free semantic projection through one complete +-- checked declaration. Validation selection and every deterministic check +-- finish before the first live request is submitted. +planCheckedDeclaration + :: CheckedDeclaration body + -> LoweringDriver (Either DeclarationError (PlannedDeclaration body)) +planCheckedDeclaration checked@(CheckedDeclaration + mode objects explicitPropositions globals descriptors stages + _body) = LoweringDriver do + state@(LoweringState resolver (ProspectiveBuilder builder) validationRun) <- + State.get + prepared <- liftIO (Except.runExceptT do + closure <- + Except.liftEither + (first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects)) + let reservedStages = + reservePlanningStages builder stages + plannedWithoutDisposition <- + Except.liftEither + (preparePlannedCandidates builder closure reservedStages) + let orderedCandidates = fmap (fmap fst) plannedWithoutDisposition + occurrences = + [ candidateOccurrence reserved authority + | stage <- plannedWithoutDisposition + , (PlannedCandidate reserved authority _direct _requests, + _requestValues) <- toList stage + ] + aliases = + [ semanticAlias alias + (semanticFactFingerprint + (candidateOccurrence reserved authority)) + | stage <- plannedWithoutDisposition + , (PlannedCandidate reserved authority _direct _requests, + _requestValues) <- toList stage + , alias <- candidateAliases reserved + ] + allCandidatePropositions = + candidateCheckedProposition . fst + <$> concatMap toList reservedStages + propositions = + stableUniqueBy checkedPropositionId + (explicitPropositions <> allCandidatePropositions) + objectIds = assertedObjectId <$> objects + propositionIds = checkedPropositionId <$> propositions + ownSlot = declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + traverse_ + (\proposition -> + void + (Except.liftEither + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition)))))) + propositions + (resolvedStructures, delta, next) <- + Except.liftEither + (buildCheckedDeclarationDelta + builder closure ownSlot occurrences aliases objectIds + propositionIds (reverse globals) (reverse descriptors)) + selection <- + selectPlannedValidation + validationRun mode builder objects orderedCandidates + planned <- + submitPlannedCandidates resolver selection + plannedWithoutDisposition + let nextBuilder = + appendProspectiveBuilder + closure resolvedStructures delta next planned builder + declaration = + PlannedDeclaration checked + (logicalBuilderPrefix builder) + next delta objects propositions planned selection + pure (declaration, nextBuilder)) + case prepared of + Left failure -> pure (Left failure) + Right (declaration, nextBuilder) -> do + let LoweringState currentResolver _current currentValidation = state + State.put + (LoweringState + currentResolver + (ProspectiveBuilder nextBuilder) + currentValidation) + pure (Right declaration) + +reservePlanningStages + :: BuilderState PlanningEvidence + -> [NonEmpty CheckedCandidate] + -> [NonEmpty (ReservedCandidate, CandidatePlanningSpec)] +reservePlanningStages builder = + snd . mapAccumPlanning reserveStage (logicalBuilderNextFact builder) + where + invocation = DeclarationInvocation (logicalBuilderNextInvocation builder) + reserveStage nextFact (stageIndex, specs) = + let candidates = + NonEmpty.zipWith + (\offset (CheckedCandidate spec planning) -> + ( ReservedCandidate + (logicalBuilderIdentity builder) + (logicalBuilderPrefix builder) + invocation + (CandidateStage stageIndex) + (factSlot + (logicalBuilderOwner builder) + (localFactOrdinal (nextFact + offset))) + spec + , planning + )) + (0 :| [1..]) + specs + in ( nextFact + fromIntegral (NonEmpty.length specs) + , candidates + ) + + mapAccumPlanning action initial values = + go initial (zip [0..] values) + where + go accumulator [] = (accumulator, []) + go accumulator (value : remaining) = + let (next, result) = action accumulator value + (final, results) = go next remaining + in (final, result : results) + +preparePlannedCandidates + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> [NonEmpty (ReservedCandidate, CandidatePlanningSpec)] + -> Either + DeclarationError + [NonEmpty (PlannedCandidate, [CheckedPlannedVampireRequest])] +preparePlannedCandidates builder closure stages = + snd <$> mapAccumM prepareStage Map.empty (zip [0..] stages) + where + prepareStage earlier (stageIndex, stage) = do + (sameStage, planned) <- + mapAccumM + (prepareCandidate stageIndex earlier) + Map.empty + (zip [0..] (toList stage)) + pure (Map.union earlier sameStage, NonEmpty.fromList planned) + + prepareCandidate stageIndex earlier sameStage + (candidateIndex, (candidate, contract)) = do + let position = PlannedCandidatePosition stageIndex candidateIndex + (direct, safety, requests) <- + prepareCandidatePlanningContract + builder closure earlier position candidate contract + let authority = + candidateFactAuthority + (candidateTheoremReference builder candidate) + safety + planned = PlannedCandidate candidate authority direct [] + pure + ( Map.insert position (candidate, authority) sameStage + , (planned, requests) + ) + + mapAccumM action initial values = + go initial [] values + where + go accumulator outputs = \case + [] -> pure (accumulator, reverse outputs) + value : remaining -> do + (next, output) <- action accumulator value + go next (output : outputs) remaining + +prepareCandidatePlanningContract + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> Map PlannedCandidatePosition (ReservedCandidate, FactAuthority) + -> PlannedCandidatePosition + -> ReservedCandidate + -> CandidatePlanningSpec + -> Either + DeclarationError + ( DirectAuthorization + , CandidateSafety + , [CheckedPlannedVampireRequest] + ) +prepareCandidatePlanningContract builder closure earlier current candidate + (CandidatePlanningSpec direct extraFacts staged requests) = do + safetyWithFacts <- + foldM (accumulatePlanningFact builder closure) + initialCandidateSafety + (stableUniqueBy id + ( extraFacts + <> concatMap requestFacts requests + )) + safetyWithStages <- + foldM consumeStage safetyWithFacts staged + let safety = case direct of + PlanningSourceAxiom -> + addCandidateEscape SourceAxiom safetyWithStages + PlanningOmitted -> + addCandidateEscape Omitted safetyWithStages + _ -> safetyWithStages + requestIds = requestIdentity <$> requests + directAuthorization = case direct of + PlanningDefinitionEquation identity -> + CheckedKernelConstruction + (CheckedDefinitionEquation identity) + PlanningSourceAxiom -> SourceAxiomAuthorization + PlanningTrustedDatatype descriptor -> + TrustedCompilation (DatatypeCompilation descriptor) + PlanningKernelConstruction descriptor -> + CheckedKernelConstruction descriptor + PlanningCheckedSourceProof -> + CheckedSourceProof requestIds + PlanningOmitted -> OmittedAuthorization + validatePlanningDirect directAuthorization safety + pure (directAuthorization, safety, requests) + where + requestFacts + (CheckedPlannedVampireRequest _location _request facts) = facts + requestIdentity + (CheckedPlannedVampireRequest _location request _facts) = + Provers.preparedVerificationRequestId request + + consumeStage safety position = do + (premise, authority) <- + maybe + (Left + (PlanningFactContractMismatch + (reservedCandidateSlot candidate))) + Right + (Map.lookup position earlier) + let PlannedCandidatePosition premiseStage _premiseIndex = position + PlannedCandidatePosition currentStage _currentIndex = current + unless (premiseStage < currentStage) + (Left + (StagedPremiseNotEarlier + (reservedCandidateSlot premise) + premiseStage + (reservedCandidateSlot candidate) + currentStage)) + first FactSafetyFailed + (accumulateFactSafety + (candidateTheoremReference builder premise) + authority + safety) + +accumulatePlanningFact + :: BuilderState PlanningEvidence + -> CheckedObjectClosure + -> CandidateSafety + -> SemanticFactOccurrenceFingerprint + -> Either DeclarationError CandidateSafety +accumulatePlanningFact builder closure safety fingerprint = do + FactEntry proposition occurrence (PlanningEvidence authority _provenance) <- + maybe + (Left (AuthorizedFactNotVisible fingerprint)) + Right + (Map.lookup fingerprint (logicalBuilderFacts builder)) + unless + ( semanticFactFingerprint occurrence == fingerprint + && semanticFactAuthority occurrence == authority + && propositionMatchesClosure closure proposition + ) + (Left (PlanningFactContractMismatch (semanticFactSlot occurrence))) + first FactSafetyFailed + (accumulateFactSafety + (theoremRef + (logicalBuilderTheory builder) + (checkedPropositionId proposition)) + authority + safety) + +validatePlanningDirect + :: DirectAuthorization + -> CandidateSafety + -> Either DeclarationError () +validatePlanningDirect direct safety = + case direct of + SourceAxiomAuthorization -> + unless + (candidateSafetyAuthority safety + == authoritySafety (singletonEscapeKind SourceAxiom)) + (Left + (ValidationCertificateFailed + (SourceAxiomSafetyMismatch + (candidateSafetyAuthority safety)))) + OmittedAuthorization -> + unless + (Omitted `elem` escapeKindsToList + (authoritySafetyEscapeKinds + (candidateSafetyAuthority safety))) + (Left + (ValidationCertificateFailed + (OmittedSafetyMissing + (candidateSafetyAuthority safety)))) + _ -> pure () + +selectPlannedValidation + :: ValidationRun + -> CheckedDeclarationMode + -> BuilderState PlanningEvidence + -> [AssertedObject] + -> [NonEmpty PlannedCandidate] + -> ExceptT DeclarationError IO PlannedValidationSelection +selectPlannedValidation validationRun mode builder objects stages = + case mode of + CheckedProofMode syntax -> + case concatMap toList stages of + [planned@(PlannedCandidate _candidate authority _direct _)] -> do + let key = proofValidationKey + (theoremId (factAuthorityTheorem authority)) + syntax + (logicalBuilderPrefix builder) + cached <- case validationRun of + FreshValidation -> pure Nothing + WarmValidation (ValidationLookup lookupProof _) -> + liftIO (lookupProof key) + traverse_ + (validateProof planned syntax) + cached + pure case cached of + Nothing -> PlannedFreshValidation + Just record -> PlannedProofValidation key record + candidates -> + Except.throwError + (CheckedProofCandidateCountMismatch + (length candidates)) + CheckedCompiledMode syntax -> do + let planned = concatMap toList stages + objectIds = assertedObjectId <$> objects + theorems = + theoremId . factAuthorityTheorem . plannedAuthority + <$> planned + key = declarationValidationKey syntax + (logicalBuilderPrefix builder) objectIds theorems + cached <- case validationRun of + FreshValidation -> pure Nothing + WarmValidation (ValidationLookup _ lookupDeclaration) -> + liftIO (lookupDeclaration key) + traverse_ + (validateCompiled planned syntax objectIds theorems) + cached + pure case cached of + Nothing -> PlannedFreshValidation + Just record -> PlannedCompiledValidation key record + where + plannedAuthority (PlannedCandidate _ authority _ _) = authority + + validateProof + (PlannedCandidate candidate authority direct _) + syntax record = + case Materialization.checkCandidateValidation + (logicalBuilderTheory builder) + (logicalBuilderPrefix builder) + (candidateCheckedProposition candidate) + authority direct + (Materialization.candidateProofValidation record syntax) of + Left failure -> + liftIO + (throwIO (CachedValidationIntegrityError failure)) + Right () -> pure () + + validateCompiled planned syntax objectIds theorems record = do + case Materialization.checkDeclarationValidationRecord + (logicalBuilderPrefix builder) + syntax objectIds theorems record of + Left failure -> + liftIO + (throwIO (CachedValidationIntegrityError failure)) + Right () -> pure () + traverse_ + (\(ordinal, + PlannedCandidate candidate authority direct _) -> + case Materialization.checkCandidateValidation + (logicalBuilderTheory builder) + (logicalBuilderPrefix builder) + (candidateCheckedProposition candidate) + authority direct + (Materialization.candidateDeclarationValidation + record syntax objectIds theorems ordinal) of + Left failure -> + liftIO + (throwIO + (CachedValidationIntegrityError failure)) + Right () -> pure ()) + (zip [0..] planned) + +submitPlannedCandidates + :: VampireResolver + -> PlannedValidationSelection + -> [NonEmpty (PlannedCandidate, [CheckedPlannedVampireRequest])] + -> ExceptT DeclarationError IO [NonEmpty PlannedCandidate] +submitPlannedCandidates resolver selection candidates + | cached = + pure (fmap (fmap cachedCandidate) candidates) + | otherwise = do + let requests = + [ VampireSubmission location request + | stage <- candidates + , (_candidate, plannedRequests) <- toList stage + , CheckedPlannedVampireRequest + location request _facts <- plannedRequests + ] + case resolver of + VampireResolver SynchronousVampireResolution{} -> + pure (fmap (fmap synchronousCandidate) candidates) + VampireResolver + (AsynchronousVampireSubmission submit) -> do + handles <- case NonEmpty.nonEmpty requests of + Nothing -> pure [] + Just nonempty -> do + submitted <- liftIO (submit nonempty) + unless + (NonEmpty.length submitted == length requests) + (Except.throwError + (VampireResolverBatchSizeMismatch + (length requests) + (NonEmpty.length submitted))) + pure (toList submitted) + let (planned, remaining) = + State.runState + (traverse (traverse liveCandidate) candidates) + handles + unless (null remaining) + (Except.throwError + (VampireResolverBatchSizeMismatch + (length requests) + (length requests + length remaining))) + pure planned + where + cached = case selection of + PlannedFreshValidation -> False + PlannedProofValidation{} -> True + PlannedCompiledValidation{} -> True + + cachedCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = + PlannedCandidate candidate authority direct + [ PlannedCachedRequest request + | CheckedPlannedVampireRequest + _location request _facts <- requests + ] + + liveCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = do + dispositions <- traverse takeHandle requests + pure (PlannedCandidate candidate authority direct dispositions) + + synchronousCandidate + (PlannedCandidate candidate authority direct _dispositions, + requests) = + PlannedCandidate candidate authority direct + [ PlannedSynchronousRequest request + | CheckedPlannedVampireRequest + _location request _facts <- requests + ] + + takeHandle + (CheckedPlannedVampireRequest _location request _facts) = do + remaining <- State.get + case remaining of + [] -> + impossible + "validated prospective handle count became exhausted" + handle : later -> do + State.put later + pure (PlannedLiveRequest request handle) + +appendProspectiveBuilder + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> DeclarationInterfaceDelta + -> PrefixContextId + -> [NonEmpty PlannedCandidate] + -> BuilderState PlanningEvidence + -> BuilderState PlanningEvidence +appendProspectiveBuilder closure structures delta next planned builder = + builder + { logicalBuilderPrefix = next + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = + foldl' insertPlanningFact + (logicalBuilderFacts builder) + (concatMap toList planned) + , logicalBuilderAliases = + foldl' + (\entries alias -> + Map.insert + (semanticAliasName alias) + (ImportedAliasBinding + (semanticAliasTarget alias) + (ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias))) + entries) + (logicalBuilderAliases builder) + (declarationDeltaAliases delta) + , logicalBuilderGlobals = + foldl' + (\entries binding -> + Map.insert + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding) + entries) + (logicalBuilderGlobals builder) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + , logicalBuilderStructures = structures + , logicalBuilderDeltas = delta : logicalBuilderDeltas builder + , logicalBuilderNextDeclaration = + logicalBuilderNextDeclaration builder + 1 + , logicalBuilderNextFact = + logicalBuilderNextFact builder + + fromIntegral (sum (fmap NonEmpty.length planned)) + , logicalBuilderNextInvocation = + logicalBuilderNextInvocation builder + 1 + } + where + insertPlanningFact entries + (PlannedCandidate candidate authority _direct _requests) = + let occurrence = candidateOccurrence candidate authority + fingerprint = semanticFactFingerprint occurrence + evidence = PlanningEvidence authority + (Just + (PlanningProvenance + (declarationDeltaSlot delta) + (reservedStageValue candidate) + (reservedCandidateSlot candidate))) + in Map.insert fingerprint + (FactEntry + (candidateCheckedProposition candidate) + occurrence + evidence) + entries + + -- Keep the constructor match private while storing exact stage provenance. + reservedStageValue + (ReservedCandidate _identity _prefix _invocation stage _slot _spec) = + stage + +-- | Admit one checked declaration through the existing authoritative +-- source-order cursor. The callback interprets a closed family recipe over +-- freshly reserved stage slots; it is not retained in the checked value. +admitCheckedDeclaration + :: CheckedDeclaration body + -> (body -> [NonEmpty ReservedCandidate] -> Declaration ()) + -> ModuleDriver failure CommittedDeclarationBatch +admitCheckedDeclaration + (CheckedDeclaration + mode objects propositions globals structures stages body) + authorize = + snd <$> do + case mode of + CheckedProofMode syntax -> + commitProofDeclaration syntax do + reserved <- installCheckedStructure + authorize body reserved + CheckedCompiledMode syntax -> + commitCompiledDeclaration syntax do + reserved <- installCheckedStructure + authorizeCompiledDeclaration + (authorize body reserved) + where + installCheckedStructure = do + traverse_ addDeclarationObject objects + traverse_ addDeclarationProposition propositions + traverse_ + (\binding -> + stageSemanticGlobalBinding + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding)) + globals + traverse_ stageSemanticStructureDescriptor structures + traverse + (reserveCandidateBatch . fmap checkedCandidateSemanticSpec) + stages + + checkedCandidateSemanticSpec + (CheckedCandidate spec _planning) = spec + +-- | Admit one retained plan against the real authorized builder. The family +-- callback performs the existing authority checks, but every live resolver +-- result comes from the handle submitted during planning and every validation +-- lookup is the inert selection retained by the plan. +admitPlannedCheckedDeclaration + :: PlannedDeclaration body + -> (body -> [NonEmpty ReservedCandidate] -> Declaration ()) + -> ModuleDriver failure CommittedDeclarationBatch +admitPlannedCheckedDeclaration planned@(PlannedDeclaration + checked previous _expectedNext _expectedDelta _objects _propositions + candidates selection) authorize = ModuleDriver do + DriverState originalResolver builder prefix originalValidation <- + State.get + unless (logicalBuilderPrefix builder == previous) + (liftIO + (throwIO + (PlanningIntegrityError + "planned declaration predecessor does not match the admitted builder"))) + liveRef <- liftIO + (newIORef + [ replay + | stage <- candidates + , PlannedCandidate _candidate _authority _direct dispositions <- + toList stage + , disposition <- dispositions + , replay <- case disposition of + PlannedCachedRequest{} -> [] + PlannedLiveRequest request handle -> + [ReplayLive request handle] + PlannedSynchronousRequest request -> + [ReplaySynchronous request] + ]) + replay <- liftIO (plannedReplayResolver originalResolver liveRef) + let validation = plannedAdmissionValidation selection + State.put (DriverState replay builder prefix validation) + batch <- runDriverStep (admitCheckedDeclaration checked authorize) + remaining <- liftIO (readIORef liveRef) + unless (null remaining) + (liftIO + (throwIO + (PlanningIntegrityError + "admission did not consume every planned live request"))) + liftIO (validateAdmittedPlan planned batch) + DriverState _replay admittedBuilder admittedPrefix _plannedValidation <- + State.get + State.put + (DriverState + originalResolver admittedBuilder admittedPrefix originalValidation) + pure batch + +plannedReplayResolver + :: VampireResolver + -> IORef [PlannedReplayRequest] + -> IO VampireResolver +plannedReplayResolver original liveRef = + pure (vampireBatchResolver resolve) + where + resolve + :: forall local origin. + NonEmpty + (Provers.PreparedTypedProverTask + SemanticFactOccurrenceFingerprint + local + origin + ObjectId) + -> IO + (NonEmpty + (Either + Provers.ProverProcessError + Provers.ProverAnswer)) + resolve tasks = do + expected <- atomicModifyIORef' liveRef \remaining -> + let amount = NonEmpty.length tasks + (selected, later) = splitAt amount remaining + in (later, selected) + unless (length expected == NonEmpty.length tasks) + (throwIO + (PlanningIntegrityError + "admission requested a different number of live Vampire results")) + traverse_ validateExpected (zip (toList tasks) expected) + case expected of + ReplayLive{} : _ -> do + unless (all isLive expected) + (throwIO + (PlanningIntegrityError + "planned resolver batch mixed execution modes")) + results <- traverse awaitOne expected + maybe + (throwIO + (PlanningIntegrityError + "an admission resolver batch was unexpectedly empty")) + pure + (NonEmpty.nonEmpty results) + ReplaySynchronous{} : _ -> + resolveSynchronousVampireBatch original tasks + [] -> + throwIO + (PlanningIntegrityError + "an admission resolver batch was unexpectedly empty") + + validateExpected (task, replay) = do + let actual = Provers.preparedTypedProverRequest task + expected = replayRequest replay + unless (actual == expected) + (throwIO + (PlanningIntegrityError + "admission request differs from its planned exact request")) + + awaitOne (ReplayLive expected handle) = + Provers.awaitPreparedVampireRequest expected handle + awaitOne ReplaySynchronous{} = + impossible "validated live resolver batch changed execution mode" + + replayRequest = \case + ReplayLive request _handle -> request + ReplaySynchronous request -> request + + isLive = \case + ReplayLive{} -> True + ReplaySynchronous{} -> False + +plannedAdmissionValidation + :: PlannedValidationSelection + -> ValidationRun +plannedAdmissionValidation = \case + PlannedFreshValidation -> FreshValidation + PlannedProofValidation expected record -> + WarmValidation + (validationLookup + (\actual -> + if actual == expected + then pure (Just record) + else throwIO + (PlanningIntegrityError + "proof validation key changed during admission")) + (\_actual -> pure Nothing)) + PlannedCompiledValidation expected record -> + WarmValidation + (validationLookup + (\_actual -> pure Nothing) + (\actual -> + if actual == expected + then pure (Just record) + else throwIO + (PlanningIntegrityError + "declaration validation key changed during admission"))) + +validateAdmittedPlan + :: PlannedDeclaration body + -> CommittedDeclarationBatch + -> IO () +validateAdmittedPlan + (PlannedDeclaration _checked expectedPrevious expectedNext expectedDelta + expectedObjects expectedPropositions candidates selection) + batch = do + let expectedContracts = + [ (authority, direct) + | stage <- candidates + , PlannedCandidate _candidate authority direct _requests <- + toList stage + ] + actualCertificates = + (proofValidationRecordCertificate + <$> committedBatchProofValidations batch) + <> maybe + [] + declarationValidationRecordCertificates + (committedBatchDeclarationValidation batch) + actualContracts = + [ ( validationTarget certificate + , validationDirectAuthorization certificate + ) + | certificate <- actualCertificates + ] + validationAgrees = case selection of + PlannedFreshValidation -> True + PlannedProofValidation _ record -> + committedBatchProofValidations batch == [record] + PlannedCompiledValidation _ record -> + committedBatchDeclarationValidation batch == Just record + unless + ( committedBatchPreviousPrefix batch == expectedPrevious + && committedBatchNextPrefix batch == expectedNext + && committedBatchDelta batch == expectedDelta + && committedBatchObjects batch == expectedObjects + && fmap propositionContract (committedBatchPropositions batch) + == fmap propositionContract expectedPropositions + && actualContracts == expectedContracts + && validationAgrees + ) + (throwIO + (PlanningIntegrityError + "admitted declaration differs from its prospective contract")) + where + propositionContract proposition = + ( checkedPropositionId proposition + , checkedPropositionTerm proposition + ) + +commitProofDeclaration + :: ProofSyntaxId + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitProofDeclaration syntax = + commitDeclaration (ProofValidationMode syntax) + +commitCompiledDeclaration + :: DeclarationSyntaxId + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitCompiledDeclaration syntax = + commitDeclaration (DeclarationValidationMode syntax) + +commitDeclaration + :: ValidationMode + -> Declaration value + -> ModuleDriver failure + (value, CommittedDeclarationBatch) +commitDeclaration mode action = ModuleDriver do + DriverState resolver builder pendingPrefix validationRun <- + State.get + let + declaration = + initialDeclarationState + resolver + validationRun + mode + builder + result <- + liftIO + (Except.runExceptT + (State.runStateT + (runDeclaration action) + declaration)) + case result of + Left err -> + Except.throwError (DriverDeclarationFailed err) + Right (value, prepared) -> + case appendDeclaration mode prepared of + Left err -> + Except.throwError (DriverDeclarationFailed err) + Right (builder', batch) -> + let prefix' = appendPendingBatch batch pendingPrefix + in do + State.put + (DriverState + resolver + builder' + prefix' + validationRun) + pure (value, batch) + +initialDeclarationState + :: VampireResolver + -> ValidationRun + -> ValidationMode + -> LogicalBuilder + -> DeclarationState +initialDeclarationState resolver validationRun validationMode builder = + DeclarationState + { declarationVampireResolver = resolver + , declarationValidationRun = validationRun + , declarationValidationMode = validationMode + , declarationValidationSelection = + DeclarationValidationUnselected + , declarationBuilder = builder + , declarationOwnSlot = + declarationSlot + (logicalBuilderOwner builder) + (localDeclarationOrdinal + (logicalBuilderNextDeclaration builder)) + , declarationInvocation = + DeclarationInvocation + (logicalBuilderNextInvocation builder) + , declarationObjectsReversed = [] + , declarationObjectClosure = Nothing + , declarationPropositionsReversed = [] + , declarationGlobalBindingsReversed = [] + , declarationStructureDescriptorsReversed = [] + , declarationReservations = Map.empty + , declarationPending = Map.empty + , declarationNextFact = logicalBuilderNextFact builder + , declarationNextStage = 0 + , declarationAuthorizationFrontier = 0 + } + +appendDeclaration + :: ValidationMode + -> DeclarationState + -> Either + DeclarationError + (LogicalBuilder, CommittedDeclarationBatch) +appendDeclaration mode declaration = do + let builder = declarationBuilder declaration + reservations = Map.elems (declarationReservations declaration) + pending = declarationPending declaration + unless + (Map.keysSet pending + == Map.keysSet (declarationReservations declaration)) + (Left DeclarationHasUnauthorizedCandidates) + unless + (declarationAuthorizationFrontier declaration + == declarationNextStage declaration) + (Left DeclarationAuthorizationFrontierIncomplete) + case mode of + DeclarationValidationMode{} -> + case declarationValidationSelection declaration of + DeclarationValidationUnselected -> + Left DeclarationValidationNotSelected + _ -> pure () + _ -> pure () + closure <- declarationClosure declaration + propositions <- validateDeclarationPropositions closure declaration + traverse_ (validatePendingAuthorization declaration) (Map.elems pending) + let orderedPending = + [ pendingCandidate + | reservation <- reservations + , let slot = reservedCandidateSlot reservation + , Just pendingCandidate <- [Map.lookup slot pending] + ] + occurrences = occurrenceFromPending <$> orderedPending + aliases = concatMap aliasesFromPending orderedPending + objectIds = + assertedObjectId + <$> reverse + (declarationObjectsReversed declaration) + propositionIds = + checkedPropositionId <$> propositions + (structures, delta, next) <- + buildCheckedDeclarationDelta + builder + closure + (declarationOwnSlot declaration) + occurrences + aliases + objectIds + propositionIds + (declarationGlobalBindingsReversed declaration) + (declarationStructureDescriptorsReversed declaration) + let previous = logicalBuilderPrefix builder + (proofValidations, declarationValidation) <- + buildValidationRecords + mode previous objectIds orderedPending + let builder' = + appendBuilderState + closure + structures + delta + next + orderedPending + builder + declaration + batch = + CommittedDeclarationBatch + (logicalBuilderOwner builder) + (declarationOwnSlot declaration) + previous + next + delta + (reverse + (declarationObjectsReversed declaration)) + propositions + proofValidations + declarationValidation + pure (builder', batch) + +-- | Construct and collision-check one canonical semantic delta without +-- inspecting fact evidence. This remains the admitted append path now and +-- is the shared delta seam for the later prospective builder. +buildCheckedDeclarationDelta + :: BuilderState evidence + -> CheckedObjectClosure + -> DeclarationSlot + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [ObjectId] + -> [PropositionId] + -> [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> Either + DeclarationError + ( Map SemanticStructurePhrase ResolvedStructure + , DeclarationInterfaceDelta + , PrefixContextId + ) +buildCheckedDeclarationDelta + builder closure slot occurrences aliases objectIds propositionIds + reversedBindings reversedDescriptors = do + let bindings = + List.sortOn + semanticGlobalBindingKey + (reverse reversedBindings) + descriptors = + List.sortOn + semanticStructureDescriptorPhrase + (reverse reversedDescriptors) + traverse_ + (\binding -> + first + (DeclarationGlobalTargetInvalid + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding)) + (validateSemanticGlobalBindingTarget + (structureOperationBindings + (logicalBuilderStructures builder)) + closure binding)) + bindings + traverse_ + (\descriptor -> + let structurePhrase = semanticStructureDescriptorPhrase descriptor + in when + (Map.member structurePhrase + (logicalBuilderStructures builder)) + (Left (BuilderStructureCollision structurePhrase))) + descriptors + structures <- foldM + (insertSemanticStructure closure) + (logicalBuilderStructures builder) + descriptors + environment <- + first DeclarationEnvironmentFailed + (semanticEnvironmentWithStructures bindings descriptors) + delta <- + first DeclarationInterfaceFailed + (declarationInterfaceDelta + slot + occurrences + aliases + objectIds + propositionIds + environment) + validateBuilderCollisions builder delta + pure + ( structures + , delta + , nextPrefixContextId (logicalBuilderPrefix builder) delta + ) + +declarationClosure + :: DeclarationState + -> Either DeclarationError CheckedObjectClosure +declarationClosure declaration = + case declarationObjectClosure declaration of + Just closure -> + Right closure + Nothing -> + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure + (declarationBuilder declaration)) + (reverse + (declarationObjectsReversed declaration))) + +prepareDeclarationClosure + :: DeclarationState + -> Either DeclarationError DeclarationState +prepareDeclarationClosure declaration = do + closure <- declarationClosure declaration + pure declaration{declarationObjectClosure = Just closure} + +validateDeclarationPropositions + :: CheckedObjectClosure + -> DeclarationState + -> Either DeclarationError [CheckedPropositionContent] +validateDeclarationPropositions closure declaration = do + let explicit = + reverse + (declarationPropositionsReversed declaration) + reserved = + candidateCheckedProposition + <$> Map.elems + (declarationReservations declaration) + propositions = stableUniqueBy checkedPropositionId (explicit <> reserved) + traverse_ + (\proposition -> + void + (first DeclarationPropositionValidationFailed + (validateAssertedPropositionContent + closure + (checkedPropositionId proposition) + (frozenCoreTerm + (checkedPropositionTerm proposition))))) + propositions + pure propositions + +validatePendingAuthorization + :: DeclarationState + -> PendingCandidate + -> Either DeclarationError () +validatePendingAuthorization declaration + (PendingCandidate candidate certificate authorization) = do + validateReservedCandidate declaration candidate + let builder = declarationBuilder declaration + PendingFactAuthorization + identity prefix invocation slot authority stage = + authorization + unless + ( identity == logicalBuilderIdentity builder + && prefix == logicalBuilderPrefix builder + && invocation == declarationInvocation declaration + && slot == reservedCandidateSlot candidate + && authority == validationTarget certificate + && stage == reservedStage candidate + ) + (Left PendingFactAuthorizationMismatch) + +occurrenceFromPending + :: PendingCandidate + -> SemanticFactOccurrence +occurrenceFromPending + (PendingCandidate candidate certificate _authorization) = + candidateOccurrence candidate (validationTarget certificate) + +aliasesFromPending :: PendingCandidate -> [SemanticAlias] +aliasesFromPending pending@(PendingCandidate + candidate _certificate _authorization) = + let occurrence = occurrenceFromPending pending + fingerprint = semanticFactFingerprint occurrence + in (`semanticAlias` fingerprint) <$> candidateAliases candidate + +buildValidationRecords + :: ValidationMode + -> PrefixContextId + -> [ObjectId] + -> [PendingCandidate] + -> Either + DeclarationError + ([ProofValidationRecord], Maybe DeclarationValidationRecord) +buildValidationRecords mode prefix objects pending = + case mode of + EnvironmentImportMode -> + impossible + "environment import produced declaration validation records" + ProofValidationMode syntax -> + case pending of + [PendingCandidate _ certificate _] -> + let authority = validationTarget certificate + key = + proofValidationKey + (theoremId + (factAuthorityTheorem authority)) + syntax + prefix + in Right + ( [proofValidationRecord key certificate] + , Nothing + ) + _ -> + Left ProofDeclarationMustProduceOneFact + DeclarationValidationMode syntax -> + let certificates = + [ certificate + | PendingCandidate _ certificate _ <- pending + ] + theorems = + theoremId + . factAuthorityTheorem + . validationTarget + <$> certificates + key = + declarationValidationKey + syntax prefix objects theorems + in Right + ( [] + , Just + (declarationValidationRecord + key certificates) + ) + +validateBuilderCollisions + :: BuilderState evidence + -> DeclarationInterfaceDelta + -> Either DeclarationError () +validateBuilderCollisions builder delta = do + traverse_ + (\occurrence -> + when + (Map.member + (semanticFactFingerprint occurrence) + (logicalBuilderFacts builder)) + (Left + (BuilderFactCollision + (semanticFactFingerprint occurrence)))) + (declarationDeltaFacts delta) + traverse_ + (\alias -> + when + (Map.member + (semanticAliasName alias) + (logicalBuilderAliases builder)) + (Left + (BuilderAliasCollision + (semanticAliasName alias)))) + (declarationDeltaAliases delta) + traverse_ + (\identity -> + when + (identity + `Set.member` checkedObjectIds + (logicalBuilderObjectClosure builder)) + (Left (BuilderObjectCollision identity))) + (declarationDeltaObjects delta) + traverse_ + (\binding -> + case Map.lookup + (semanticGlobalBindingKey binding) + (logicalBuilderGlobals builder) of + Nothing -> pure () + Just existing -> + Left + (BuilderGlobalCollision + (semanticGlobalBindingKey binding) + existing)) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + +appendBuilderState + :: CheckedObjectClosure + -> Map SemanticStructurePhrase ResolvedStructure + -> DeclarationInterfaceDelta + -> PrefixContextId + -> [PendingCandidate] + -> LogicalBuilder + -> DeclarationState + -> LogicalBuilder +appendBuilderState closure structures delta next pending builder declaration = + builder + { logicalBuilderPrefix = next + , logicalBuilderObjectClosure = closure + , logicalBuilderFacts = + foldl' + (insertAuthorizedFact builder) + (logicalBuilderFacts builder) + pending + , logicalBuilderAliases = + foldl' + (\entries alias -> + Map.insert + (semanticAliasName alias) + (ImportedAliasBinding + (semanticAliasTarget alias) + (ImportedAliasOrigin + (declarationDeltaSlot delta) + (semanticAliasTarget alias))) + entries) + (logicalBuilderAliases builder) + (declarationDeltaAliases delta) + , logicalBuilderGlobals = + foldl' + (\entries binding -> + Map.insert + (semanticGlobalBindingKey binding) + (semanticGlobalBindingTarget binding) + entries) + (logicalBuilderGlobals builder) + (semanticEnvironmentBindings + (declarationDeltaEnvironment delta)) + , logicalBuilderStructures = structures + , logicalBuilderDeltas = + delta : logicalBuilderDeltas builder + , logicalBuilderNextDeclaration = + logicalBuilderNextDeclaration builder + 1 + , logicalBuilderNextFact = + declarationNextFact declaration + , logicalBuilderNextInvocation = + logicalBuilderNextInvocation builder + 1 + } + +insertAuthorizedFact + :: LogicalBuilder + -> Map + SemanticFactOccurrenceFingerprint + (FactEntry BuilderFactAuthorization) + -> PendingCandidate + -> Map + SemanticFactOccurrenceFingerprint + (FactEntry BuilderFactAuthorization) +insertAuthorizedFact builder entries pending@(PendingCandidate + candidate certificate _pendingAuthorization) = + let occurrence = occurrenceFromPending pending + fingerprint = semanticFactFingerprint occurrence + authority = validationTarget certificate + authorization = + BuilderFactAuthorization + (logicalBuilderIdentity builder) + (reservedCandidateSlot candidate) + authority + in Map.insert + fingerprint + (FactEntry + (candidateCheckedProposition candidate) + occurrence + authorization) + entries + +stableUniqueBy :: Ord key => (value -> key) -> [value] -> [value] +stableUniqueBy key = + reverse . snd + . foldl' + (\(seen, values) value -> + let identity = key value + in if identity `Set.member` seen + then (seen, values) + else + ( Set.insert identity seen + , value : values + )) + (Set.empty, []) + + +data DeclarationError + = CandidateOutsideDeclaration !FactSlot + | CandidateAlreadyAuthorized !FactSlot + | CandidateOutsideAuthorizationFrontier + !FactSlot !Natural !Natural + | DeclarationHasUnauthorizedCandidates + | DeclarationAuthorizationFrontierIncomplete + | CandidatePropositionNotClosed + | CandidatePropositionNotProposition !CoreType + | StagedPremiseNotEarlier + !FactSlot !Natural !FactSlot !Natural + | StagedPremiseNotAuthorized !FactSlot + | AuthorizedFactNotVisible + !SemanticFactOccurrenceFingerprint + | BuilderFactAuthorizationMismatch + | PendingFactAuthorizationMismatch + | PlanningFactContractMismatch !FactSlot + | CheckedAuthorizationCandidateShapeMismatch !Int !Int + | CheckedProofCandidateCountMismatch !Int + | LocalClaimOutsideCandidate + | FactSafetyFailed !FactSafetyError + | ValidationCertificateFailed !ValidationCertificateError + | DerivationImportFailed !DerivationImportError + | KernelCompletionFailed !KernelReplayError + | KernelConstructionDescriptorMismatch + | DefinitionEquationObjectMissing !ObjectId + | DefinitionEquationObjectNotTransparent !ObjectId + | DefinitionEquationObjectNotPointwisePredicate !ObjectId + | DefinitionEquationCandidateMismatch + | DatatypeCompilationDescriptorMismatch + | ProofObligationFailedAt !Location !DeclarationError + | VampireProcessFailed !Provers.ProverProcessError + | VampireObligationRejected !Provers.ProverAnswer + | VampireProofHasNoAcceptedObligations + | VampireCandidateBatchMismatch ![FactSlot] ![FactSlot] + | VampireCandidateBatchProofShapeMismatch !FactSlot + | VampireResolverBatchSizeMismatch !Int !Int + | OmittedProofDidNotRecordUse + | VampireRequestMismatch + | VampireTargetMismatch + | VampireLocalPremisesNotSupported + | VampireGlobalTypeMismatch !ObjectId + | VampirePremiseMismatch + !SemanticFactOccurrenceFingerprint + | VampirePremiseCapabilityMismatch + !SemanticFactOccurrenceFingerprint + | VampireFoundationMismatch !FoundationAxiomTag + | CurrentCandidateVampirePreparationFailed + !(VampireObligationPreparationError Void) + | ProofValidationOutsideProofDeclaration + | DeclarationValidationOutsideCompiledDeclaration + | DeclarationValidationAlreadySelected + | DeclarationValidationNotSelected + | DeclarationShapeChangedAfterValidationLookup + | CachedDeclarationCandidateMissing !FactSlot + | ImportedModuleNotDirect !SemanticInterfaceId + | ImportedFactMaterializationFailed + !Materialization.MaterializationError + | ImportedFactCollision + !SemanticFactOccurrenceFingerprint + | ImportedAliasCollision + !SemanticName !ImportedAliasOrigin !ImportedAliasOrigin + | ImportedAliasTargetMissing + !SemanticFactOccurrenceFingerprint + | ImportedGlobalCollision + !SemanticGlobalKey !SemanticGlobalTarget !SemanticGlobalTarget + | ImportedGlobalTargetInvalid + !SemanticGlobalKey + !SemanticGlobalTarget + !SemanticGlobalTargetError + | ImportedStructureCollision + !SemanticStructurePhrase + !SemanticStructureDescriptor + !SemanticStructureDescriptor + | SemanticStructureParentMissing + !SemanticStructurePhrase !SemanticStructurePhrase + | SemanticStructureOperationConflict + !StructSymbol !SemanticStructurePhrase !SemanticStructurePhrase + | SemanticStructurePredicateTargetInvalid + !SemanticStructurePhrase !ObjectId !(Maybe CoreType) !CoreType + | SemanticStructureOperationTargetInvalid + !SemanticStructurePhrase !StructSymbol !ObjectId !(Maybe CoreType) !CoreType + | ImportedEvidenceDirectMismatch + ![SemanticInterfaceId] ![SemanticInterfaceId] + | ImportedEvidenceInterfaceFailed !SemanticInterfaceError + | ImportedEvidenceObjectMissing !ObjectId + | ImportedEvidencePropositionMissing !PropositionId + | ImportedModuleAfterAuthorization + | DeclarationObjectAddedAfterAuthorization + | DeclarationObjectValidationFailed !ObjectValidationError + | DeclarationPropositionValidationFailed + !PropositionValidationError + | DeclarationInterfaceFailed !DeclarationInterfaceError + | DeclarationEnvironmentFailed !SemanticEnvironmentError + | DeclarationGlobalAlreadyStaged !SemanticGlobalKey + | DeclarationStructureAlreadyStaged !SemanticStructurePhrase + | DeclarationGlobalTargetInvalid + !SemanticGlobalKey + !SemanticGlobalTarget + !SemanticGlobalTargetError + | ProofDeclarationMustProduceOneFact + | BuilderFactCollision + !SemanticFactOccurrenceFingerprint + | BuilderAliasCollision !SemanticName + | BuilderObjectCollision !ObjectId + | BuilderGlobalCollision !SemanticGlobalKey !SemanticGlobalTarget + | BuilderStructureCollision !SemanticStructurePhrase + deriving stock (Show, Eq) + +declarationErrorLocation :: DeclarationError -> Maybe Location +declarationErrorLocation = \case + ProofObligationFailedAt location _failure -> + Just location + _failure -> + Nothing + +renderDeclarationError :: DeclarationError -> Text +renderDeclarationError = \case + CandidateOutsideDeclaration slot -> + "candidate " <> shown slot <> " does not belong to this declaration" + CandidateAlreadyAuthorized slot -> + "candidate " <> shown slot <> " was authorized more than once" + CandidateOutsideAuthorizationFrontier slot expected actual -> + "candidate " <> shown slot <> " is outside authorization frontier " + <> shown expected <> " (found " <> shown actual <> ")" + DeclarationHasUnauthorizedCandidates -> + "the declaration has unauthorized candidates" + DeclarationAuthorizationFrontierIncomplete -> + "the declaration authorization frontier is incomplete" + CandidatePropositionNotClosed -> + "the candidate proposition still has open local binders" + CandidatePropositionNotProposition actual -> + "the candidate has type " <> shown actual <> " instead of Prop" + StagedPremiseNotEarlier candidate candidateOrdinal premise premiseOrdinal -> + "candidate " <> shown candidate <> " at stage " <> shown candidateOrdinal + <> " depends on non-earlier premise " <> shown premise + <> " at stage " <> shown premiseOrdinal + StagedPremiseNotAuthorized slot -> + "staged premise " <> shown slot <> " is not authorized" + AuthorizedFactNotVisible fingerprint -> + "authorized fact " <> shown fingerprint <> " is not visible" + BuilderFactAuthorizationMismatch -> + "builder fact authority does not match the checked declaration" + PendingFactAuthorizationMismatch -> + "pending fact authority does not match the checked declaration" + PlanningFactContractMismatch slot -> + "checked declaration-stage fact " <> shown slot + <> " has inconsistent semantic provenance" + CheckedAuthorizationCandidateShapeMismatch expected actual -> + "checked declaration recipe expected " <> shown expected + <> " candidate stages but received " <> shown actual + CheckedProofCandidateCountMismatch actual -> + "checked proof declaration requires exactly one candidate but received " + <> shown actual + LocalClaimOutsideCandidate -> + "proof-local claim was used outside a candidate proof" + FactSafetyFailed{} -> + "fact-safety validation failed" + ValidationCertificateFailed{} -> + "validation-certificate checking failed" + DerivationImportFailed{} -> + "kernel derivation import failed" + KernelCompletionFailed{} -> + "kernel replay failed" + KernelConstructionDescriptorMismatch -> + "kernel construction does not match its checked descriptor" + DefinitionEquationObjectMissing identity -> + "definition equation references missing object " <> shown identity + DefinitionEquationObjectNotTransparent identity -> + "definition equation references non-transparent object " <> shown identity + DefinitionEquationObjectNotPointwisePredicate identity -> + "definition equation object " <> shown identity + <> " is not a unary predicate definition" + DefinitionEquationCandidateMismatch -> + "definition equation does not match its checked object content" + DatatypeCompilationDescriptorMismatch -> + "datatype compilation does not match its complete checked family" + ProofObligationFailedAt location failure -> + locationToText location <> ": " <> renderDeclarationError failure + VampireProcessFailed{} -> + "Vampire process failed while authorizing the declaration" + VampireObligationRejected{} -> + "Vampire did not accept a declaration obligation" + VampireProofHasNoAcceptedObligations -> + "Vampire proof contains no accepted obligations" + VampireCandidateBatchMismatch expected actual -> + "Vampire candidate batch does not match the complete authorization " + <> "stage (expected " <> shown expected + <> ", found " <> shown actual <> ")" + VampireCandidateBatchProofShapeMismatch slot -> + "Vampire candidate " <> shown slot + <> " performed execution before its ready batch" + VampireResolverBatchSizeMismatch expected actual -> + "Vampire resolver returned " <> shown actual + <> " results for " <> shown expected <> " requests" + OmittedProofDidNotRecordUse -> + "omitted proof completion did not record an omission" + VampireRequestMismatch -> + "accepted Vampire run does not match the prepared request" + VampireTargetMismatch -> + "Vampire request target does not match the candidate theorem" + VampireLocalPremisesNotSupported -> + "typed Vampire requests do not yet support local premises" + VampireGlobalTypeMismatch object -> + "Vampire request has the wrong type for global object " <> shown object + VampirePremiseMismatch fingerprint -> + "Vampire request premise does not match visible fact " <> shown fingerprint + VampirePremiseCapabilityMismatch fingerprint -> + "Vampire request lacks authority for premise " <> shown fingerprint + VampireFoundationMismatch tag -> + "Vampire request has inconsistent foundation axiom " <> shown tag + CurrentCandidateVampirePreparationFailed failure -> + "the staged Vampire obligation could not be prepared: " <> shown failure + ProofValidationOutsideProofDeclaration -> + "proof validation requires a proof declaration" + DeclarationValidationOutsideCompiledDeclaration -> + "declaration validation requires a compiled declaration" + DeclarationValidationAlreadySelected -> + "compiled declaration validation was selected more than once" + DeclarationValidationNotSelected -> + "compiled declaration validation was not selected" + DeclarationShapeChangedAfterValidationLookup -> + "compiled declaration shape changed after validation lookup" + CachedDeclarationCandidateMissing slot -> + "cached declaration validation has no candidate for " <> shown slot + ImportedModuleNotDirect interface -> + "sealed semantic interface is not a direct import: " <> shown interface + ImportedFactMaterializationFailed{} -> + "imported fact failed materialization checks" + ImportedFactCollision fingerprint -> + "imported fact " <> shown fingerprint <> " is already registered" + ImportedAliasCollision alias earlier later -> + "imported semantic alias " <> shown alias + <> " conflicts between " <> shown earlier + <> " and " <> shown later + ImportedAliasTargetMissing fingerprint -> + "imported alias targets missing fact " <> shown fingerprint + ImportedGlobalCollision key earlier later -> + "imported global " <> shown key + <> " has conflicting targets " <> shown earlier + <> " and " <> shown later + ImportedGlobalTargetInvalid key target _failure -> + "imported global " <> shown key + <> " has invalid target " <> shown target + ImportedEvidenceDirectMismatch expected actual -> + "imported semantic parents differ: expected " <> shown expected + <> ", found " <> shown actual + ImportedStructureCollision structurePhrase _existing _incoming -> + "structure " <> shown structurePhrase <> " has conflicting descriptors" + SemanticStructureParentMissing structurePhrase parent -> + "structure " <> shown structurePhrase <> " has unknown parent " <> shown parent + SemanticStructureOperationConflict symbol firstOrigin secondOrigin -> + "structure operation " <> shown symbol <> " conflicts between " + <> shown firstOrigin <> " and " <> shown secondOrigin + SemanticStructurePredicateTargetInvalid structurePhrase object _actual expected -> + "structure " <> shown structurePhrase <> " has invalid predicate object " + <> shown object <> " (expected " <> shown expected <> ")" + SemanticStructureOperationTargetInvalid structurePhrase symbol object _actual expected -> + "structure " <> shown structurePhrase <> " has invalid operation " + <> shown symbol <> " object " <> shown object + <> " (expected " <> shown expected <> ")" + ImportedEvidenceInterfaceFailed{} -> + "imported semantic interface failed validation" + ImportedEvidenceObjectMissing identity -> + "imported semantic interface is missing object " <> shown identity + ImportedEvidencePropositionMissing identity -> + "imported semantic interface is missing proposition " <> shown identity + ImportedModuleAfterAuthorization -> + "a sealed module was imported after candidate authorization" + DeclarationObjectAddedAfterAuthorization -> + "the declaration added an object after candidate authorization" + DeclarationObjectValidationFailed{} -> + "declaration object validation failed" + DeclarationPropositionValidationFailed{} -> + "declaration proposition validation failed" + DeclarationInterfaceFailed{} -> + "declaration interface validation failed" + DeclarationEnvironmentFailed{} -> + "declaration environment delta is inconsistent" + DeclarationGlobalAlreadyStaged key -> + "global " <> shown key <> " was staged more than once" + DeclarationStructureAlreadyStaged structurePhrase -> + "structure " <> shown structurePhrase <> " was staged more than once" + DeclarationGlobalTargetInvalid key target _failure -> + "global " <> shown key <> " has invalid target " <> shown target + ProofDeclarationMustProduceOneFact -> + "a proof declaration must produce exactly one fact" + BuilderFactCollision fingerprint -> + "fact " <> shown fingerprint <> " is already registered" + BuilderAliasCollision alias -> + "semantic alias " <> shown alias <> " is already registered" + BuilderObjectCollision object -> + "object " <> shown object <> " is already registered" + BuilderGlobalCollision key object -> + "global " <> shown key <> " is already bound to " <> shown object + BuilderStructureCollision structurePhrase -> + "structure " <> shown structurePhrase <> " is already registered" + where + shown :: Show value => value -> Text + shown = Text.pack . show diff --git a/source/Felix/Checking/Exact.hs b/source/Felix/Checking/Exact.hs new file mode 100644 index 0000000..c829743 --- /dev/null +++ b/source/Felix/Checking/Exact.hs @@ -0,0 +1,3936 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Direct compiler for the first exact monomorphic declaration family. +module Felix.Checking.Exact + ( ExactLocalId + , exactLocalId + , exactLocalIdValue + , ExactBinderContext + , emptyExactBinderContext + , extendExactBinderContext + , extendExactAnonymousBinderContext + , exactBinderContextSupport + , exactBinderContextIndex + , PreparedExactProposition + , preparedExactPropositionCore + , prepareExactProposition + , prepareExactSymbolicBoundConstraints + , prepareExactSymbolicWitnessConstraints + , prepareExactNounWitnessConstraints + , PreparedExactSetExpression + , PreparedExactSetConstruction(..) + , preparedExactSetExpressionCore + , preparedExactSetExpressionConstruction + , prepareExactSetExpression + , PreparedExactLocalFunctionGraph + , preparedExactLocalFunctionGraphCore + , preparedExactLocalFunctionGraphDomain + , preparedExactLocalFunctionGraphMap + , prepareExactLocalFunctionGraph + , PreparedExactClaimEnvelope + , preparedExactClaimTarget + , preparedExactClaimVariables + , preparedExactClaimContext + , preparedExactClaimAntecedentCount + , prepareExactClaimEnvelope + , PreparedExactDeclaration + , preparedExactLocation + , preparedExactGlobalKey + , preparedExactObjectId + , preparedExactObject + , preparedExactSyntaxId + , preparedExactIsDefinition + , prepareExactDeclaration + , lowerPreparedExactBinding + , CheckedExactBindingAuthorization + , authorizeCheckedExactBinding + , PreparedExactStructure + , prepareExactStructure + , CheckedExactStructureAuthorization + , lowerPreparedExactStructure + , authorizeCheckedExactStructure + , PreparedExactSourceAxiom + , prepareExactSourceAxiom + , lowerPreparedExactSourceAxiom + , authorizeCheckedExactSourceAxiom + , ExactCompileError(..) + , exactCompileErrorLocation + , renderExactCompileError + ) where + +import Base hiding (Empty) +import Felix.Cache.Codec +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction +import Felix.Module +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface (CanonicalLexicalEntry(..)) +import Felix.Syntax.Lexicon qualified as Lexicon + +import Control.Monad.Except (ExceptT) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.ByteString (ByteString) +import Data.Bifunctor (first) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +-- | A disposable identity allocated in source order within one proof. +newtype ExactLocalId = ExactLocalId Natural + deriving stock (Show, Eq, Ord) + +exactLocalId :: Natural -> ExactLocalId +exactLocalId = ExactLocalId + +exactLocalIdValue :: ExactLocalId -> Natural +exactLocalIdValue (ExactLocalId value) = value + +data ExactBinder = ExactBinder + !ExactLocalId + !(Maybe Raw.VarSymbol) + !CoreType + !(Maybe ExactStructureAnnotation) + +data ExactStructureAnnotation = ExactStructureAnnotation + !SemanticStructurePhrase + !(Maybe ObjectId) + !(Map.Map Raw.StructSymbol ObjectId) + +-- | The active nearest-first binders of one exact proof scope. +newtype ExactBinderContext = ExactBinderContext [ExactBinder] + +emptyExactBinderContext :: ExactBinderContext +emptyExactBinderContext = ExactBinderContext [] + +extendExactBinderContext + :: NonEmpty (ExactLocalId, Raw.VarSymbol) + -> ExactBinderContext + -> Either ExactCompileError ExactBinderContext +extendExactBinderContext additions (ExactBinderContext initial) = + ExactBinderContext <$> foldM add initial (toList additions) + where + add binders (identity, variable) + | any (sameVariable variable) binders = + Left (ExactDuplicateLocalBinder (locate variable) variable) + | any (sameIdentity identity) binders = + Left (ExactDuplicateLocalIdentity (locate variable) identity) + | otherwise = + Right (ExactBinder identity (Just variable) TySet Nothing : binders) + + sameVariable variable (ExactBinder _identity existing _coreType _structure) = + existing == Just variable + + sameIdentity identity (ExactBinder existing _variable _coreType _structure) = + existing == identity + +-- | Add one proof-owned binder which deliberately has no source-resolvable +-- spelling. This is used for a nameless singular witness; it participates in +-- checked support and de Bruijn weakening but cannot shadow or be looked up by +-- a later source variable. +extendExactAnonymousBinderContext + :: ExactLocalId + -> ExactBinderContext + -> Either ExactCompileError ExactBinderContext +extendExactAnonymousBinderContext identity (ExactBinderContext binders) + | any sameIdentity binders = + Left (ExactDuplicateLocalIdentity Nowhere identity) + | otherwise = + Right + (ExactBinderContext + (ExactBinder identity Nothing TySet Nothing : binders)) + where + sameIdentity (ExactBinder existing _variable _coreType _structure) = + existing == identity + +exactBinderContextSupport + :: ExactBinderContext + -> Vector (ExactLocalId, CoreType) +exactBinderContextSupport (ExactBinderContext binders) = + Vector.fromList + [ (identity, coreType) + | ExactBinder identity _variable coreType _structure <- binders + ] + +exactBinderContextIndex + :: Raw.VarSymbol + -> ExactBinderContext + -> Maybe Natural +exactBinderContextIndex variable (ExactBinderContext binders) = + go 0 binders + where + go _index [] = + Nothing + go index (ExactBinder _identity candidate _coreType _structure : rest) + | candidate == Just variable = Just index + | otherwise = go (index + 1) rest + +newtype PreparedExactProposition = PreparedExactProposition + (ScopedCheckedCore ObjectId) + +preparedExactPropositionCore + :: PreparedExactProposition + -> ScopedCheckedCore ObjectId +preparedExactPropositionCore (PreparedExactProposition proposition) = + proposition + +data PreparedExactSetExpression = PreparedExactSetExpression + !(ScopedCheckedCore ObjectId) + !(Maybe PreparedExactSetConstruction) + +data PreparedExactSetConstruction + = PreparedUnconditionalSetConstruction + !(NamedSetConstruction ObjectId) + | PreparedRelationalSetConstruction + !(CheckedRelationalSetConstruction ObjectId) + +preparedExactSetExpressionCore + :: PreparedExactSetExpression + -> ScopedCheckedCore ObjectId +preparedExactSetExpressionCore (PreparedExactSetExpression expression _construction) = + expression + +preparedExactSetExpressionConstruction + :: PreparedExactSetExpression + -> Maybe PreparedExactSetConstruction +preparedExactSetExpressionConstruction + (PreparedExactSetExpression _expression construction) = + construction + +-- | A checked replacement graph and the two checked arguments used to +-- specialize its foundation characteristic. This is transient proof +-- preparation data, not a declaration or durable object. +data PreparedExactLocalFunctionGraph = PreparedExactLocalFunctionGraph + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + +preparedExactLocalFunctionGraphCore + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphCore + (PreparedExactLocalFunctionGraph graph _domain _function) = + graph + +preparedExactLocalFunctionGraphDomain + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphDomain + (PreparedExactLocalFunctionGraph _graph domain _function) = + domain + +preparedExactLocalFunctionGraphMap + :: PreparedExactLocalFunctionGraph + -> ScopedCheckedCore ObjectId +preparedExactLocalFunctionGraphMap + (PreparedExactLocalFunctionGraph _graph _domain function) = + function + +-- | One authoritative closed proposition prepared from a top-level claim +-- header and conclusion. The remaining fields are transient opening data for +-- the proof compiler. +data PreparedExactClaimEnvelope = PreparedExactClaimEnvelope + !(ScopedCheckedCore ObjectId) + ![Raw.VarSymbol] + !ExactBinderContext + !Natural + +preparedExactClaimTarget + :: PreparedExactClaimEnvelope + -> ScopedCheckedCore ObjectId +preparedExactClaimTarget + (PreparedExactClaimEnvelope target _variables _context _antecedents) = + target + +preparedExactClaimVariables + :: PreparedExactClaimEnvelope + -> [Raw.VarSymbol] +preparedExactClaimVariables + (PreparedExactClaimEnvelope _target variables _context _antecedents) = + variables + +preparedExactClaimContext + :: PreparedExactClaimEnvelope + -> ExactBinderContext +preparedExactClaimContext + (PreparedExactClaimEnvelope _target _variables context _antecedents) = + context + +preparedExactClaimAntecedentCount + :: PreparedExactClaimEnvelope + -> Natural +preparedExactClaimAntecedentCount + (PreparedExactClaimEnvelope _target _variables _context antecedents) = + antecedents + + +data ExactDeclarationFamily + = ExactSignature + | ExactAbbreviation + | ExactDefinition + deriving stock (Show, Eq, Ord) + +data PreparedExactDeclaration = PreparedExactDeclaration + !Location + !ExactDeclarationFamily + !SemanticGlobalKey + !SemanticGlobalTarget + !(Maybe AssertedObject) + !(Maybe SemanticName) + !(Maybe PreparedExactSetConstruction) + !DeclarationSyntaxId + +preparedExactLocation :: PreparedExactDeclaration -> Location +preparedExactLocation + (PreparedExactDeclaration location _family _key _target _object _alias _construction _syntax) = + location + +preparedExactGlobalKey :: PreparedExactDeclaration -> SemanticGlobalKey +preparedExactGlobalKey + (PreparedExactDeclaration _location _family key _target _object _alias _construction _syntax) = + key + +preparedExactObjectId :: PreparedExactDeclaration -> ObjectId +preparedExactObjectId + (PreparedExactDeclaration _location _family _key target _object _alias _construction _syntax) = + semanticGlobalTargetObject target + +preparedExactObject + :: PreparedExactDeclaration + -> Maybe AssertedObject +preparedExactObject + (PreparedExactDeclaration _location _family _key _target object _alias _construction _syntax) = + object + +preparedExactSyntaxId + :: PreparedExactDeclaration + -> DeclarationSyntaxId +preparedExactSyntaxId + (PreparedExactDeclaration _location _family _key _target _object _alias _construction syntax) = + syntax + +preparedExactIsDefinition :: PreparedExactDeclaration -> Bool +preparedExactIsDefinition + (PreparedExactDeclaration _location family _key _target _object _alias _construction _syntax) = + family == ExactDefinition + +preparedExactGlobalTarget + :: PreparedExactDeclaration + -> SemanticGlobalTarget +preparedExactGlobalTarget + (PreparedExactDeclaration + _location _family _key target _object _alias _construction _syntax) = + target + +preparedDefinitionAlias + :: PreparedExactDeclaration + -> Maybe SemanticName +preparedDefinitionAlias + (PreparedExactDeclaration + _location _family _key _target _object alias _construction _syntax) = + alias + +preparedDefinitionConstruction + :: PreparedExactDeclaration + -> Maybe PreparedExactSetConstruction +preparedDefinitionConstruction + (PreparedExactDeclaration + _location _family _key _target _object _alias construction _syntax) = + construction + +data PreparedExactSourceAxiom = PreparedExactSourceAxiom + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !DeclarationSyntaxId + +data PreparedExactStructureFact = PreparedExactStructureFact + !Location + !(FrozenCheckedCore ObjectId) + !SemanticName + +data PreparedExactStructure = PreparedExactStructure + !Location + ![AssertedObject] + !ObjectId + !SemanticStructureDescriptor + !SemanticName + ![PreparedExactStructureFact] + !DeclarationSyntaxId + +data CheckedExactStructureAuthorization = + CheckedExactStructureAuthorization + !ObjectId + ![(Location, Declaration.PreparedVampireObligation Void ())] + +data ExactCompileError + = ExactUnsupportedDeclaration !Location + | ExactUnsupportedDeclarationBody !Location + | ExactNonCanonicalSetDefinitionAnnotation !Location + | ExactGuardedTransparentDefinition !Location + | ExactGuardedOpaqueSignature !Location + | ExactDefinitionCombinedSymbolicAlias !Location + | ExactRelationalReplacementRequiresNamedDefinition !Location + | ExactDeclarationOccurrenceMissing !Location + | ExactDeclarationOccurrenceAmbiguous !Location + | ExactDeclarationHeadMismatch !Location + | ExactFixedSemanticCollision !Location !SemanticGlobalKey + | ExactGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactGlobalNotVisible !Location !SemanticGlobalKey + | ExactDuplicateParameter !Location !Raw.VarSymbol + | ExactDuplicateLocalBinder !Location !Raw.VarSymbol + | ExactDuplicateLocalIdentity !Location !ExactLocalId + | ExactFreeVariable !Location !Raw.VarSymbol + | ExactApplicationExpectedFunction !Location !CoreType + | ExactApplicationArgumentMismatch + !Location !CoreType !CoreType + | ExactExpressionExpectedSet !Location !CoreType + | ExactFormulaExpectedProposition !Location !CoreType + | ExactCoreCheckFailed !Location !CoreCheckError + | ExactObjectTypeMismatch !Location !CoreType !CoreType + | ExactUnsupportedHeaderAssumption !Location + | ExactQuantifiedTermRequiresPropositionContext !Location + | ExactStructureNotVisible !Location !SemanticStructurePhrase + | ExactBaseStructureNotAssertable !Location !SemanticStructurePhrase + | ExactDuplicateStructureAnnotation !Location !Raw.VarSymbol + | ExactStructureOperationNotAvailable !Location !Raw.StructSymbol + | ExactStructureOperationAmbiguous + !Location !Raw.StructSymbol ![ObjectId] + | ExactContextualExpansionNotAvailable + !Location !SemanticGlobalKey + | ExactContextualRequirementConflict + !Location !Raw.StructSymbol !ObjectId !ObjectId + | ExactStructureOccurrenceMismatch !Location + | ExactStructureSelfParent !Location !SemanticStructurePhrase + | ExactStructureDuplicateParent !Location !SemanticStructurePhrase + | ExactStructureAlreadyVisible !Location !SemanticStructurePhrase + | ExactStructureDuplicateOperation !Location !Raw.StructSymbol + | ExactStructureOperationAlreadyInherited !Location !Raw.StructSymbol + | ExactStructureOperationConflict + !Location !Raw.StructSymbol + !SemanticStructurePhrase !SemanticStructurePhrase + | ExactStructureHasNoCarrier !Location !SemanticStructurePhrase + | ExactStructureDescriptorInvalid !Location !SemanticEnvironmentError + | ExactStructureObjectNotVisible !Location !ObjectId + deriving stock (Show, Eq) + +exactCompileErrorLocation :: ExactCompileError -> Location +exactCompileErrorLocation = \case + ExactUnsupportedDeclaration location -> location + ExactUnsupportedDeclarationBody location -> location + ExactNonCanonicalSetDefinitionAnnotation location -> location + ExactGuardedTransparentDefinition location -> location + ExactGuardedOpaqueSignature location -> location + ExactDefinitionCombinedSymbolicAlias location -> location + ExactRelationalReplacementRequiresNamedDefinition location -> location + ExactDeclarationOccurrenceMissing location -> location + ExactDeclarationOccurrenceAmbiguous location -> location + ExactDeclarationHeadMismatch location -> location + ExactFixedSemanticCollision location _key -> location + ExactGlobalAlreadyVisible location _key -> location + ExactGlobalNotVisible location _key -> location + ExactDuplicateParameter location _parameter -> location + ExactDuplicateLocalBinder location _variable -> location + ExactDuplicateLocalIdentity location _identity -> location + ExactFreeVariable location _variable -> location + ExactApplicationExpectedFunction location _actual -> location + ExactApplicationArgumentMismatch location _expected _actual -> location + ExactExpressionExpectedSet location _actual -> location + ExactFormulaExpectedProposition location _actual -> location + ExactCoreCheckFailed location _failure -> location + ExactObjectTypeMismatch location _expected _actual -> location + ExactUnsupportedHeaderAssumption location -> location + ExactQuantifiedTermRequiresPropositionContext location -> location + ExactStructureNotVisible location _phrase -> location + ExactBaseStructureNotAssertable location _phrase -> location + ExactDuplicateStructureAnnotation location _variable -> location + ExactStructureOperationNotAvailable location _symbol -> location + ExactStructureOperationAmbiguous location _symbol _objects -> location + ExactContextualExpansionNotAvailable location _key -> location + ExactContextualRequirementConflict location _symbol _first _second -> location + ExactStructureOccurrenceMismatch location -> location + ExactStructureSelfParent location _phrase -> location + ExactStructureDuplicateParent location _phrase -> location + ExactStructureAlreadyVisible location _phrase -> location + ExactStructureDuplicateOperation location _symbol -> location + ExactStructureOperationAlreadyInherited location _symbol -> location + ExactStructureOperationConflict location _symbol _first _second -> location + ExactStructureHasNoCarrier location _phrase -> location + ExactStructureDescriptorInvalid location _failure -> location + ExactStructureObjectNotVisible location _object -> location + +renderExactCompileError :: ExactCompileError -> Text +renderExactCompileError = \case + ExactUnsupportedDeclaration location -> + at location <> "this declaration is not yet supported by the typed checker" + ExactUnsupportedDeclarationBody location -> + at location <> "this source form is not yet supported by exact elaboration" + ExactNonCanonicalSetDefinitionAnnotation location -> + at location + <> "only the unmodified built-in noun `set` is a harmless definition annotation; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedTransparentDefinition location -> + at location + <> "a transparent definition cannot have a header assumption; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedOpaqueSignature location -> + at location + <> "an opaque signature cannot have a header assumption; " + <> "state the condition in a following explicit axiom" + ExactDefinitionCombinedSymbolicAlias location -> + at location + <> "a functional definition cannot declare a symbolic equivalent at the same time; " + <> "define the symbolic operator first, then define the functional phrase as an abbreviation applying it" + ExactRelationalReplacementRequiresNamedDefinition location -> + at location + <> "relational replacement is supported only as the outer body of a named definition" + ExactDeclarationOccurrenceMissing location -> + at location <> "the declaration has no associated syntax occurrence" + ExactDeclarationOccurrenceAmbiguous location -> + at location <> "the declaration has more than one semantic head" + ExactDeclarationHeadMismatch location -> + at location <> "the parsed declaration head does not match its syntax occurrence" + ExactFixedSemanticCollision location key -> + at location <> "the declaration collides with fixed semantics for " + <> shown key + ExactGlobalAlreadyVisible location key -> + at location <> "the global " <> shown key <> " is already declared" + ExactGlobalNotVisible location key -> + at location <> "the global " <> shown key <> " is not visible" + ExactDuplicateParameter location parameter -> + at location <> "the declaration parameter " <> shown parameter <> " is repeated" + ExactDuplicateLocalBinder location variable -> + at location <> "the proof binder " <> shown variable <> " is already active" + ExactDuplicateLocalIdentity location identity -> + at location <> "the proof-local identity " <> shown identity <> " is already active" + ExactFreeVariable location variable -> + at location <> "the exact source form contains the free variable " <> shown variable + ExactApplicationExpectedFunction location actual -> + at location <> "an application expected a function, but found " <> shown actual + ExactApplicationArgumentMismatch location expected actual -> + at location <> "an application expected " <> shown expected + <> ", but found " <> shown actual + ExactExpressionExpectedSet location actual -> + at location <> "an expression has type " <> shown actual <> " instead of Set" + ExactFormulaExpectedProposition location actual -> + at location <> "a formula has type " <> shown actual <> " instead of Prop" + ExactCoreCheckFailed location failure -> + at location <> "the checked declaration core is invalid: " <> shown failure + ExactObjectTypeMismatch location expected actual -> + at location <> "the declaration object has type " <> shown actual + <> " instead of " <> shown expected + ExactUnsupportedHeaderAssumption location -> + at location <> "this top-level header assumption is not yet supported by exact elaboration" + ExactQuantifiedTermRequiresPropositionContext location -> + at location + <> "a quantified term requires a containing proposition" + ExactStructureNotVisible location structurePhrase -> + at location <> "the structure " <> shown structurePhrase <> " is not visible" + ExactBaseStructureNotAssertable location structurePhrase -> + at location <> "the metadata-only structure " <> shown structurePhrase + <> " cannot be asserted" + ExactDuplicateStructureAnnotation location variable -> + at location <> "the structure binder " <> shown variable + <> " is annotated more than once" + ExactStructureOperationNotAvailable location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is not available in the active structure scope" + ExactStructureOperationAmbiguous location symbol objects -> + at location <> "the structure operation " <> shown symbol + <> " is ambiguous between " <> shown objects + ExactContextualExpansionNotAvailable location key -> + at location <> "the contextual abbreviation " <> shown key + <> " has no compatible active structure" + ExactContextualRequirementConflict location symbol firstObject secondObject -> + at location <> "the contextual abbreviation requires incompatible " + <> shown symbol <> " operations " <> shown firstObject + <> " and " <> shown secondObject + ExactStructureOccurrenceMismatch location -> + at location <> "the structure syntax occurrences do not match the declaration" + ExactStructureSelfParent location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " cannot inherit from itself" + ExactStructureDuplicateParent location structurePhrase -> + at location <> "the parent structure " <> shown structurePhrase + <> " is repeated" + ExactStructureAlreadyVisible location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " is already declared" + ExactStructureDuplicateOperation location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is repeated" + ExactStructureOperationAlreadyInherited location symbol -> + at location <> "the structure operation " <> shown symbol + <> " is already inherited" + ExactStructureOperationConflict location symbol firstOrigin secondOrigin -> + at location <> "the inherited structure operation " <> shown symbol + <> " conflicts between " <> shown firstOrigin + <> " and " <> shown secondOrigin + ExactStructureHasNoCarrier location structurePhrase -> + at location <> "the structure " <> shown structurePhrase + <> " does not inherit the base carrier operation" + ExactStructureDescriptorInvalid location _failure -> + at location <> "the canonical structure descriptor is inconsistent" + ExactStructureObjectNotVisible location identity -> + at location <> "the structure fact mentions unavailable object " + <> shown identity + where + at location = locationToText location <> ": " + shown :: Show value => value -> Text + shown = Text.pack . show + +data ElaborationState = ElaborationState + { elaborationBinders :: !(Map.Map Raw.VarSymbol Natural) + -- Counts every active de Bruijn binder, including anonymous and + -- contextual binders which have no entry in 'elaborationBinders'. + , elaborationBinderDepth :: !Natural + , elaborationStructures :: !(Map.Map Natural ExactStructureAnnotation) + , elaborationGlobals :: !(Map.Map ObjectId CoreType) + , elaborationContextualBinder :: !(Maybe Natural) + , elaborationContextualRequirements + :: !(Map.Map Raw.StructSymbol ObjectId) + } + +type Elaborate = + StateT + ElaborationState + (ExceptT ExactCompileError (Declaration.LoweringDriver)) + +data PreparedHead = PreparedHead + !SemanticGlobalKey + ![Raw.VarSymbol] + !CoreType + +data PreparedBody + = OpaqueBody + | TransparentBody + !(CanonicalTerm ObjectId) + !(Maybe PreparedExactSetConstruction) + | ContextualTransparentBody + !(Map.Map Raw.StructSymbol ObjectId) + !(CanonicalTerm ObjectId) + +data CompiledBody = CompiledBody + !(CanonicalTerm ObjectId) + !(Maybe CompiledNamedSetConstruction) + +data CompiledNamedSetConstruction + = CompiledSeparationConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + | CompiledFunctionalReplacementConstruction + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + | CompiledRelationalReplacementConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + +prepareExactProposition + :: ExactBinderContext + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactProposition context statement = + prepareExactPropositionTerm + context + (locate statement) + (compileStatement statement) + +-- | Compile the source bound of already-opened symbolic binders. This is the +-- shared checked constraint seam used by quantified statements and proof +-- binders, so relation signs, carrier casts, and global occurrences are +-- elaborated exactly once by the ordinary expression compiler. +prepareExactSymbolicBoundConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicBoundConstraints context variables bound = + prepareExactPropositionTerm + context + (case bound of + Raw.Unbounded -> locate (NonEmpty.head variables) + _ -> locate bound) + (logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound) + +-- | Compile the opened body used by a symbolic existential witness. Its +-- grouping is deliberately identical to 'SymbolicExists': all bound +-- constraints form the existential restriction and the stated proposition is +-- its body. +prepareExactSymbolicWitnessConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicWitnessConstraints context variables bound statement = + prepareExactPropositionTerm context (locate statement) do + constraints <- + logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound + body <- compileStatement statement + pure + (if constraints == logicalTruth + then body + else logicalAnd constraints body) + +-- | Compile the checked constraint of an already-opened noun witness. Named +-- binders are resolved normally; a nameless singular noun uses the nearest +-- anonymous binder and therefore introduces no lookup spelling. +prepareExactNounWitnessConstraints + :: ExactBinderContext + -> Raw.NounPhrase [] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactNounWitnessConstraints context nounPhrase = + case nounPhrase of + Raw.NounPhrase left noun variables right suchThat -> + prepareExactPropositionTerm context (locate noun) do + subjects <- + case NonEmpty.nonEmpty variables of + Just binders -> + toList + <$> traverse compileIntroducedVariable binders + Nothing -> + pure [CBound 0] + compileNounPhraseConstraints + subjects left noun right suchThat + +prepareExactPropositionTerm + :: ExactBinderContext + -> Location + -> Elaborate (CanonicalTerm ObjectId) + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactPropositionTerm context location compile = + Except.runExceptT do + let initialElaboration = initialElaborationState context + (term, finalElaboration) <- + State.runStateT compile initialElaboration + checked <- + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition + location + (scopedCoreType checked))) + pure (PreparedExactProposition checked) + +prepareExactSetExpression + :: ExactBinderContext + -> Raw.Expr + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactSetExpression) +prepareExactSetExpression context expression = + Except.runExceptT do + let initialElaboration = initialElaborationState context + (compiled, finalElaboration) <- + State.runStateT + (compileNamedSetExpression expression) + initialElaboration + let CompiledBody term rawConstruction = compiled + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate expression)) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TySet) + (Except.throwError + (ExactExpressionExpectedSet + (locate expression) + (scopedCoreType checked))) + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (preparedSetConstructionTerm checkedConstruction == checked) + (impossible + "exact named construction disagrees with its checked expression")) + construction + pure (PreparedExactSetExpression checked construction) + +checkCompiledNamedSetConstruction + :: (ObjectId -> Maybe CoreType) + -> [CoreType] + -> CompiledNamedSetConstruction + -> Either ExactCompileError PreparedExactSetConstruction +checkCompiledNamedSetConstruction globalType context = \case + CompiledSeparationConstruction bound predicate -> do + checkedBound <- checkAt context TySet bound + checkedPredicate <- checkAt (TySet : context) TyProp predicate + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedSeparationConstruction + globalType checkedBound checkedPredicate) + CompiledFunctionalReplacementConstruction domains value condition -> do + let domainList = NonEmpty.toList domains + fullContext = replicate (length domainList) TySet <> context + checkedDomains <- + traverse + (\(depth, domain) -> + checkAt + (replicate depth TySet <> context) + TySet + domain) + (zip [0..] domainList) + checkedValue <- checkAt fullContext TySet value + checkedCondition <- traverse (checkAt fullContext TyProp) condition + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedFunctionalReplacementConstruction + globalType + (NonEmpty.fromList checkedDomains) + checkedValue + checkedCondition) + CompiledRelationalReplacementConstruction domain relation -> do + checkedDomain <- checkAt context TySet domain + checkedRelation <- checkAt (TySet : TySet : context) TyProp relation + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedRelationalSetConstruction) + (checkedRelationalReplacementConstruction + globalType checkedDomain checkedRelation) + where + checkAt expectedContext expectedType term = do + checked <- + first + (ExactCoreCheckFailed Nowhere) + (checkScopedCanonicalCore globalType expectedContext term) + unless + (scopedCoreType checked == expectedType) + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType + expectedType + (scopedCoreType checked)))) + pure checked + +preparedSetConstructionTerm + :: PreparedExactSetConstruction + -> ScopedCheckedCore ObjectId +preparedSetConstructionTerm = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionTerm construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionTerm construction + +preparedSetConstructionClosedBody + :: PreparedExactSetConstruction + -> FrozenCheckedCore ObjectId +preparedSetConstructionClosedBody = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionClosedBody construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionClosedBody construction + +prepareExactLocalFunctionGraph + :: Location + -> ExactBinderContext + -> ExactBinderContext + -> Raw.Expr + -> Raw.Expr + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactLocalFunctionGraph) +prepareExactLocalFunctionGraph + location context argumentContext domainExpression valueExpression = + Except.runExceptT do + domain <- + preparedExactSetExpressionCore + <$> ( Except.lift + (prepareExactSetExpression context domainExpression) + >>= Except.liftEither + ) + value <- + preparedExactSetExpressionCore + <$> ( Except.lift + (prepareExactSetExpression + argumentContext valueExpression) + >>= Except.liftEither + ) + pair <- prepareOrderedPair + case scopedReplacementGraph pair domain value of + Just (graph, checkedDomain, function) -> + pure + (PreparedExactLocalFunctionGraph + graph checkedDomain function) + Nothing -> + impossible + "checked local-function components did not form a replacement graph" + where + prepareOrderedPair = do + let initialElaboration = initialElaborationState context + key = + SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol) + expected = TySet `TyArrow` (TySet `TyArrow` TySet) + ((term, actual), finalElaboration) <- + State.runStateT + (applyResolvedTyped location key []) + initialElaboration + unless (actual == expected) + (Except.throwError + (ExactObjectTypeMismatch location expected actual)) + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context) + term) + +prepareExactClaimEnvelope + :: [Raw.Asm] + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactClaimEnvelope) +prepareExactClaimEnvelope assumptions statement = + discover [] emptyExactBinderContext + where + discover variables context = do + attempted <- prepareExactClaimAttempt context assumptions statement + case attempted of + Left (ExactFreeVariable _location variable) + | variable `elem` variables -> + impossible + "exact claim discovery repeated an active free variable" + | otherwise -> + case extendExactBinderContext + ( ( exactLocalId + (fromIntegral (length variables)) + , variable + ) :| [] + ) + context of + Left failure -> + pure (Left failure) + Right extended -> + discover (variables <> [variable]) extended + Left failure -> + pure (Left failure) + Right (target, antecedentCount, structures) -> + pure + (Right + (PreparedExactClaimEnvelope + target + variables + (annotateBinderContext structures context) + antecedentCount)) + +prepareExactClaimAttempt + :: ExactBinderContext + -> [Raw.Asm] + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either + ExactCompileError + ( ScopedCheckedCore ObjectId + , Natural + , Map.Map Natural ExactStructureAnnotation + )) +prepareExactClaimAttempt context assumptions statement = + Except.runExceptT do + let initialElaboration = initialElaborationState context + ((antecedents, conclusion), finalElaboration) <- + State.runStateT + ( do + antecedents <- + concat <$> traverse compileHeaderAssumption assumptions + conclusion <- compileStatement statement + pure (antecedents, conclusion) + ) + initialElaboration + checkedAntecedents <- + traverse + (uncurry + (checkEnvelopeProposition + finalElaboration + context)) + antecedents + checkedConclusion <- + checkEnvelopeProposition + finalElaboration + context + (locate statement) + conclusion + let implication = + foldr + (\antecedent continuation -> + fromMaybe + (impossible + "checked claim antecedents have unequal contexts") + (implyScopedCore antecedent continuation)) + checkedConclusion + checkedAntecedents + closed = closeClaimBinders implication + unless (null (scopedCoreContext closed)) + (impossible "exact claim closure retained a binder") + pure + ( closed + , fromIntegral (length antecedents) + , elaborationStructures finalElaboration + ) + +checkEnvelopeProposition + :: ElaborationState + -> ExactBinderContext + -> Location + -> CanonicalTerm ObjectId + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + (ScopedCheckedCore ObjectId) +checkEnvelopeProposition elaboration context location term = do + checked <- + either + (Except.throwError . ExactCoreCheckFailed location) + pure + (checkScopedCanonicalCore + (`Map.lookup` elaborationGlobals elaboration) + (binderTypes context) + term) + unless (scopedCoreType checked == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition + location + (scopedCoreType checked))) + pure checked + +closeClaimBinders + :: ScopedCheckedCore global + -> ScopedCheckedCore global +closeClaimBinders scoped = + case scopedCoreContext scoped of + [] -> scoped + _binder : _remaining -> + closeClaimBinders + (fromMaybe + (impossible + "a checked claim binder could not be closed") + (closeScopedForall scoped)) + +binderIndices :: ExactBinderContext -> Map.Map Raw.VarSymbol Natural +binderIndices (ExactBinderContext binders) = + Map.fromList + [ (variable, fromIntegral index) + | (index, ExactBinder _identity (Just variable) _coreType _structure) <- + zip [0 :: Int ..] binders + ] + +binderStructures + :: ExactBinderContext + -> Map.Map Natural ExactStructureAnnotation +binderStructures (ExactBinderContext binders) = + Map.fromList + [ (fromIntegral index, structure) + | (index, ExactBinder _identity _variable _coreType (Just structure)) <- + zip [0 :: Int ..] binders + ] + +binderTypes :: ExactBinderContext -> [CoreType] +binderTypes (ExactBinderContext binders) = + [ coreType + | ExactBinder _identity _variable coreType _structure <- binders + ] + +initialElaborationState :: ExactBinderContext -> ElaborationState +initialElaborationState context = + ElaborationState + { elaborationBinders = binderIndices context + , elaborationBinderDepth = + fromIntegral (length (binderTypes context)) + , elaborationStructures = binderStructures context + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } + +annotateBinderContext + :: Map.Map Natural ExactStructureAnnotation + -> ExactBinderContext + -> ExactBinderContext +annotateBinderContext structures (ExactBinderContext binders) = + ExactBinderContext + [ ExactBinder identity variable coreType + (Map.lookup (fromIntegral index) structures) + | (index, ExactBinder identity variable coreType _old) <- + zip [0 :: Int ..] binders + ] + +compileHeaderAssumption + :: Raw.Asm + -> Elaborate [(Location, CanonicalTerm ObjectId)] +compileHeaderAssumption = \case + Raw.AsmSuppose statement -> do + proposition <- compileStatement statement + pure [(locate statement, proposition)] + Raw.AsmLetNoun variables nounPhrase + | exactSetNounPhrase nounPhrase -> do + traverse_ compileIntroducedVariable variables + pure [] + | otherwise -> do + subjects <- traverse compileIntroducedVariable variables + constraints <- + traverse (`compileNounPhraseMaybe` nounPhrase) subjects + pure + [ (locate variable, constraint) + | (variable, constraint) <- + zip (toList variables) (toList constraints) + ] + Raw.AsmLetIn variables domain -> do + variableTerms <- traverse compileIntroducedVariable variables + domainTerm <- compileExpressionAsSet domain + traverse + (\(variable, variableTerm) -> do + proposition <- + compileMembership + (locate domain) + Raw.Positive + variableTerm + domainTerm + pure (locate variable, proposition)) + (zip (toList variables) (toList variableTerms)) + Raw.AsmLetEq variable expression -> do + variableTerm <- compileIntroducedVariable variable + expressionTerm <- compileExpressionAsSet expression + pure + [ ( locate variable + , CEq TySet variableTerm expressionTerm + ) + ] + Raw.AsmLetThe variable _function -> + Except.throwError + (ExactUnsupportedHeaderAssumption (locate variable)) + Raw.AsmLetStruct variable structure -> do + subject <- compileIntroducedVariable variable + annotation <- + resolveStructureAnnotation + (locate variable) + structure + index <- + maybe + (impossible "an introduced structure variable is unbound") + pure + =<< Map.lookup variable <$> State.gets elaborationBinders + existing <- State.gets (Map.lookup index . elaborationStructures) + when + (isJust existing) + (Except.throwError + (ExactDuplicateStructureAnnotation + (locate variable) variable)) + State.modify' \state -> + state + { elaborationStructures = + Map.insert index annotation + (elaborationStructures state) + } + predicate <- + maybe + (impossible "an assertable structure has no predicate") + pure + (structureAnnotationPredicate annotation) + recordExactGlobal + predicate + (TyArrow TySet TyProp) + pure + [ ( locate variable + , CApp + (CGlobal predicate) + subject + ) + ] + +compileIntroducedVariable + :: Raw.VarSymbol + -> Elaborate (CanonicalTerm ObjectId) +compileIntroducedVariable variable = + compileExpressionAsSet (Raw.ExprVar variable) + +resolveStructureAnnotation + :: Location + -> Raw.StructPhrase + -> Elaborate ExactStructureAnnotation +resolveStructureAnnotation location rawPhrase = do + let structurePhrase = semanticStructurePhrase rawPhrase + resolved <- + State.lift + (Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase)) + structure <- + maybe + (Except.throwError + (ExactStructureNotVisible location structurePhrase)) + pure + resolved + predicate <- + maybe + (Except.throwError + (ExactBaseStructureNotAssertable location structurePhrase)) + pure + (Declaration.resolvedStructurePredicate structure) + pure + (ExactStructureAnnotation + structurePhrase + (Just predicate) + (Declaration.resolvedStructureOperations structure)) + +structureAnnotationPredicate :: ExactStructureAnnotation -> Maybe ObjectId +structureAnnotationPredicate + (ExactStructureAnnotation _ predicate _operations) = + predicate + +structureAnnotationOperation + :: Raw.StructSymbol + -> ExactStructureAnnotation + -> Maybe ObjectId +structureAnnotationOperation symbol + (ExactStructureAnnotation _phrase _predicate operations) = + Map.lookup symbol operations + +recordExactGlobal :: ObjectId -> CoreType -> Elaborate () +recordExactGlobal identity coreType = do + existing <- State.gets (Map.lookup identity . elaborationGlobals) + case existing of + Nothing -> + State.modify' \state -> + state + { elaborationGlobals = + Map.insert identity coreType + (elaborationGlobals state) + } + Just actual + | actual == coreType -> pure () + | otherwise -> + impossible "one exact global acquired two checked types" + +prepareExactSourceAxiom + :: Raw.Block + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactSourceAxiom) +prepareExactSourceAxiom = \case + Raw.BlockAxiom + location _title (Raw.Marker marker) + (Raw.Axiom assumptions statement) -> do + prepared <- prepareExactClaimEnvelope assumptions statement + pure do + envelope <- prepared + let core = preparedExactClaimTarget envelope + alias = semanticName marker + unless (null (scopedCoreContext core)) + (Left (ExactUnsupportedDeclarationBody location)) + pure + (PreparedExactSourceAxiom + location + alias + core + (declarationSyntaxId + (encodePreparedSourceAxiom core alias))) + block -> + pure (Left (ExactUnsupportedDeclaration (locate block))) + +lowerPreparedExactSourceAxiom + :: PreparedExactSourceAxiom + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration ())) +lowerPreparedExactSourceAxiom + (PreparedExactSourceAxiom _location alias target syntax) = + fmap + (\spec -> + Declaration.checkedCompiledDeclaration + syntax [] [] [] [] + [ Declaration.checkedCandidate + spec + Declaration.checkedSourceAxiomPlanning + :| [] + ] + ()) + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + +authorizeCheckedExactSourceAxiom + :: () + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactSourceAxiom () = \case + [candidate :| []] -> + Declaration.authorizeSourceAxiomCandidate candidate + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +prepareExactDeclaration + :: Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactDeclaration) +prepareExactDeclaration block entries = + Except.runExceptT do + entry <- + case entries of + [] -> Except.throwError + (ExactDeclarationOccurrenceMissing (locate block)) + [single] -> pure single + _ -> Except.throwError + (ExactDeclarationOccurrenceAmbiguous (locate block)) + key <- + maybe + (Except.throwError + (ExactUnsupportedDeclaration (locate block))) + pure + (semanticGlobalKeyFromLexicalEntry entry) + when + (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactFixedSemanticCollision (locate block) key)) + visible <- Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when + (isJust visible) + (Except.throwError + (ExactGlobalAlreadyVisible (locate block) key)) + (head', family, rawBody) <- + prepareHead block key + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + (body, globals) <- + case rawBody of + Nothing -> pure (OpaqueBody, Map.empty) + Just buildBody -> do + let initialElaboration = + ElaborationState + { elaborationBinders = mempty + , elaborationBinderDepth = 0 + , elaborationStructures = mempty + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } + (CompiledBody canonical rawConstruction, finalElaboration) <- + State.runStateT buildBody initialElaboration + let PreparedHead _semanticKey parameters _coreType = head' + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` + elaborationGlobals finalElaboration) + (replicate (length parameters) TySet)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (frozenCoreTerm + (preparedSetConstructionClosedBody + checkedConstruction) + == canonical) + (impossible + "exact named construction disagrees with its transparent body")) + construction + let requirements = + elaborationContextualRequirements finalElaboration + body + | Map.null requirements = + TransparentBody canonical construction + | family == ExactAbbreviation = + ContextualTransparentBody + requirements + (CLam TySet canonical) + | otherwise = + impossible + "a non-abbreviation acquired contextual requirements" + pure (body, elaborationGlobals finalElaboration) + let PreparedHead semanticKey _parameters coreType = head' + unless (semanticKey == key) + (Except.throwError + (ExactDeclarationHeadMismatch (locate block))) + (target, content) <- + case body of + OpaqueBody -> do + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + SignatureDeclaration + (generatedObjectSlot 0) + content' = + OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + pure (GlobalReference identity, content') + TransparentBody canonical _construction -> do + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate block)) + pure + (checkCanonicalCore + (`Map.lookup` globals) + canonical) + unless + (frozenCoreType checked == coreType) + (Except.throwError + (ExactObjectTypeMismatch + (locate block) + coreType + (frozenCoreType checked))) + let content' = + TransparentObjectContent + theory + coreType + canonical + let identity = + transparentObjectId theory coreType canonical + semanticTarget = + case family of + ExactAbbreviation -> + TransparentExpansion identity + ExactDefinition -> GlobalReference identity + ExactSignature -> + impossible + "a signature acquired a transparent body" + pure (semanticTarget, content') + ContextualTransparentBody requirements canonical -> do + let contextualType = TyArrow TySet coreType + checked <- + either + (Except.throwError + . ExactCoreCheckFailed (locate block)) + pure + (checkCanonicalCore + (`Map.lookup` globals) + canonical) + unless + (frozenCoreType checked == contextualType) + (Except.throwError + (ExactObjectTypeMismatch + (locate block) + contextualType + (frozenCoreType checked))) + let content' = + TransparentObjectContent + theory + contextualType + canonical + identity = + transparentObjectId + theory contextualType canonical + pure + ( ContextualTransparentExpansion + identity requirements + , content' + ) + let targetObject = semanticGlobalTargetObject target + available <- + Except.lift (Declaration.objectAvailableLowering targetObject) + let alias = definitionAlias block + asserted + | available = Nothing + | otherwise = Just (assertedObject targetObject content) + syntax = + declarationSyntaxId + (encodePreparedSyntax family head' body alias) + pure + (PreparedExactDeclaration + (locate block) + family + key + target + asserted + alias + (case family of + ExactDefinition -> case body of + TransparentBody _canonical construction -> construction + _ -> Nothing + _ -> Nothing) + syntax) + +lowerPreparedExactBinding + :: PreparedExactDeclaration + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration CheckedExactBindingAuthorization)) +lowerPreparedExactBinding prepared = + case preparedDefinitionAlias prepared of + Nothing -> + pure + (Right + (checked [] CheckedExactBindingNone)) + Just alias -> case preparedDefinitionConstruction prepared of + Nothing -> + fmap + (\spec -> + checked + [ Declaration.checkedCandidate + spec + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [] + ] + (CheckedExactBindingDefinition identity)) + <$> Declaration.prepareDefinitionEquationSpecLowering + objects identity alias + Just (PreparedUnconditionalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + (extensional, descriptor) <- + Except.lift + (Declaration.prepareNamedSetConstructionSpecLowering + objects identity construction) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + extensional + (Declaration.checkedKernelPlanning + descriptor []) + ] + ] + (CheckedExactBindingConstruction + identity construction)) + Just (PreparedRelationalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + let functionality = + relationalSetConstructionClosedFunctionality + construction + functionalityScoped = + embedClosedCore [] functionality + functionalitySpec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects functionality SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + functionalityScoped + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt location + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + (extensional, descriptor) <- + Except.lift + (Declaration.prepareRelationalSetConstructionSpecLowering + objects identity construction functionality) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + functionalitySpec + (Declaration.checkedSourceProofPlanning + [Declaration.checkedPlannedVampireRequest + location obligation] + []) + ] + , Declaration.checkedCandidate + extensional + (Declaration.checkedStagedKernelPlanning + descriptor + [Declaration.plannedEarlierCandidate 0 1]) + :| [] + ] + (CheckedExactBindingRelationalConstruction + identity construction obligation)) + where + identity = preparedExactObjectId prepared + objects = maybeToList (preparedExactObject prepared) + location = preparedExactLocation prepared + checked stages body = + Declaration.checkedCompiledDeclaration + (preparedExactSyntaxId prepared) + objects + [] + [semanticGlobalBinding + (preparedExactGlobalKey prepared) + (preparedExactGlobalTarget prepared)] + [] + stages + body + +data CheckedExactBindingAuthorization + = CheckedExactBindingNone + | CheckedExactBindingDefinition !ObjectId + | CheckedExactBindingConstruction + !ObjectId + !(NamedSetConstruction ObjectId) + | CheckedExactBindingRelationalConstruction + !ObjectId + !(CheckedRelationalSetConstruction ObjectId) + !(Declaration.PreparedVampireObligation Void ()) + +authorizeCheckedExactBinding + :: CheckedExactBindingAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactBinding body stages = + case (body, stages) of + (CheckedExactBindingNone, []) -> pure () + (CheckedExactBindingDefinition identity, [candidate :| []]) -> + Declaration.authorizeDefinitionEquationCandidate + identity candidate + ( CheckedExactBindingConstruction identity construction + , [equation :| [extensional]] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeNamedSetConstructionCandidate + identity construction extensional + ( CheckedExactBindingRelationalConstruction + identity construction obligation + , [equation :| [functionality], extensional :| []] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeVampireCandidate + functionality + (Declaration.acceptPreparedVampireObligation obligation) + Declaration.authorizeRelationalSetConstructionCandidate + identity construction functionality extensional + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (case body of + CheckedExactBindingNone -> 0 + CheckedExactBindingDefinition{} -> 1 + CheckedExactBindingConstruction{} -> 1 + CheckedExactBindingRelationalConstruction{} -> 2) + (length stages)) + +prepareExactStructure + :: Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactStructure) +prepareExactStructure block entries = + Except.runExceptT do + (location, marker, structure) <- + case block of + Raw.BlockStruct location _title (Raw.Marker marker) structure -> + pure (location, marker, structure) + _ -> Except.throwError + (ExactUnsupportedDeclaration (locate block)) + validateStructureOccurrences location structure entries + let structurePhrase = + semanticStructurePhrase (Raw.structPhrase structure) + parentPhrases = + semanticStructurePhrase <$> Raw.structParents structure + when + (structurePhrase `elem` parentPhrases) + (Except.throwError + (ExactStructureSelfParent location structurePhrase)) + case firstDuplicate parentPhrases of + Just duplicate -> + Except.throwError + (ExactStructureDuplicateParent location duplicate) + Nothing -> pure () + visible <- Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase) + when + (isJust visible) + (Except.throwError + (ExactStructureAlreadyVisible location structurePhrase)) + parents <- traverse (resolveParent location) parentPhrases + inherited <- + foldM mergeParentOperations Map.empty + (zip parentPhrases parents) + case firstDuplicate (Raw.structFixes structure) of + Just duplicate -> + Except.throwError + (ExactStructureDuplicateOperation location duplicate) + Nothing -> pure () + traverse_ + (\symbol -> + when + (Map.member symbol inherited) + (Except.throwError + (ExactStructureOperationAlreadyInherited + location symbol))) + (Raw.structFixes structure) + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + let operationType = TyArrow TySet TySet + makeOperation index symbol = + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot index) + content = OpaqueObjectContent theory seed operationType + identity = opaqueObjectId theory seed operationType + in ( symbol + , identity + , assertedObject identity content + ) + ownOperations = + zipWith makeOperation [0 ..] (Raw.structFixes structure) + operationObjects = + [ asserted + | (_symbol, _identity, asserted) <- ownOperations + ] + completeOperations = + Map.union + (Map.fromList + [ (symbol, identity) + | (symbol, identity, _asserted) <- ownOperations + ]) + (fst <$> inherited) + unless + (Map.member Raw.CarrierSymbol completeOperations) + (Except.throwError + (ExactStructureHasNoCarrier location structurePhrase)) + context <- + either Except.throwError pure + (extendExactBinderContext + ((exactLocalId 0, Raw.structLabel structure) :| []) + emptyExactBinderContext) + let provisionalAnnotation = + ExactStructureAnnotation + structurePhrase Nothing completeOperations + structureContext = + annotateBinderContext + (Map.singleton 0 provisionalAnnotation) + context + checkedAssumptions <- + traverse + (\(assumptionMarker, assumption) -> do + prepared <- Except.lift + (prepareExactProposition structureContext assumption) + proposition <- Except.liftEither prepared + pure + ( locate assumption + , assumptionMarker + , preparedExactPropositionCore proposition + )) + (Raw.structAssumes structure) + parentTerms <- + fmap catMaybes + (traverse + (\parent -> + case Declaration.resolvedStructurePredicate parent of + Nothing -> pure Nothing + Just predicate -> + pure + (Just + (CApp + (CGlobal predicate) + (CBound 0)))) + parents) + let assumptionTerms = + [ scopedCoreTerm proposition + | (_assumptionLocation, _assumptionMarker, proposition) <- + checkedAssumptions + ] + predicateBody = + CLam TySet + (logicalConjunction + (parentTerms <> assumptionTerms)) + predicateType = TyArrow TySet TyProp + predicateContent = + TransparentObjectContent theory predicateType predicateBody + predicate = + transparentObjectId theory predicateType predicateBody + predicateAvailable <- + Except.lift (Declaration.objectAvailableLowering predicate) + let predicateObject = + [ assertedObject predicate predicateContent + | not predicateAvailable + ] + ownBindings = + [ semanticStructureOperation symbol identity + | (symbol, identity, _asserted) <- ownOperations + ] + descriptor <- + Except.liftEither + (first + (ExactStructureDescriptorInvalid location) + (semanticStructureDescriptor + structurePhrase + (Just predicate) + parentPhrases + ownBindings)) + let structureApplication = + CApp (CGlobal predicate) (CBound 0) + inheritance = + [ ( location + , semanticName (marker <> "inherit") + , CForall TySet + (CImp structureApplication + (logicalConjunction parentTerms)) + ) + | not (null parentTerms) + ] + projections = + [ ( assumptionLocation + , semanticName assumptionMarker + , CForall TySet + (CImp structureApplication + (scopedCoreTerm proposition)) + ) + | ( assumptionLocation + , Raw.Marker assumptionMarker + , proposition + ) <- checkedAssumptions + ] + generatedTerms = inheritance <> projections + localTypes = + Map.fromList + ((predicate, predicateType) + : [ (identity, operationType) + | (_symbol, identity, _asserted) <- ownOperations + ]) + resolvedTypes <- + resolveStructureGlobalTypes + localTypes + [ term + | (_factLocation, _alias, term) <- generatedTerms + ] + generated <- + traverse + (\(factLocation, alias, term) -> do + frozen <- + either + (Except.throwError + . ExactCoreCheckFailed factLocation) + pure + (checkCanonicalCore + (`Map.lookup` resolvedTypes) + term) + pure + (PreparedExactStructureFact + factLocation frozen alias)) + generatedTerms + environment <- + Except.liftEither + (first + (ExactStructureDescriptorInvalid location) + (semanticEnvironmentWithStructures [] [descriptor])) + let syntax = + declarationSyntaxId + (encodePreparedStructure + environment + predicate + generated) + pure + (PreparedExactStructure + location + (operationObjects <> predicateObject) + predicate + descriptor + (semanticName marker) + generated + syntax) + where + resolveParent location structurePhrase = do + resolved <- Except.lift + (Declaration.resolveVisibleStructureLowering structurePhrase) + maybe + (Except.throwError + (ExactStructureNotVisible location structurePhrase)) + pure + resolved + + mergeParentOperations inherited (parentPhrase, parent) = + foldM + (insertParentOperation parentPhrase) + inherited + (Map.toAscList + (Declaration.resolvedStructureOperations parent)) + + insertParentOperation parentPhrase inherited (symbol, identity) = + case Map.lookup symbol inherited of + Nothing -> + pure + (Map.insert symbol (identity, parentPhrase) inherited) + Just (existing, existingOrigin) + | existing == identity -> pure inherited + | otherwise -> + Except.throwError + (ExactStructureOperationConflict + (locate block) + symbol + existingOrigin + parentPhrase) + + resolveStructureGlobalTypes localTypes terms = do + let dependencies = Set.unions (canonicalTermGlobals <$> terms) + foldM + (\types identity -> + case Map.lookup identity types of + Just{} -> pure types + Nothing -> do + coreType <- Except.lift + (Declaration.objectTypeLowering identity) + case coreType of + Nothing -> + Except.throwError + (ExactStructureObjectNotVisible + (locate block) identity) + Just actual -> + pure (Map.insert identity actual types)) + localTypes + (Set.toAscList dependencies) + +lowerPreparedExactStructure + :: PreparedExactStructure + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactStructureAuthorization)) +lowerPreparedExactStructure + (PreparedExactStructure + _location objects predicate descriptor alias generatedFacts syntax) = + Except.runExceptT do + definition <- + Except.lift + (Declaration.preparePointwiseDefinitionEquationSpecLowering + objects predicate alias) + >>= Except.liftEither + generatedCandidates <- + traverse + (\(PreparedExactStructureFact + factLocation target factAlias) -> do + generatedSpec <- Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects target SearchEligible [factAlias]) + >>= Except.liftEither + obligation <- Except.lift + (Declaration.prepareStagedCandidateVampireLowering + factLocation objects definition generatedSpec) + >>= Except.liftEither + pure + ( Declaration.checkedCandidate generatedSpec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + [ Declaration.plannedEarlierCandidate 0 0 + ]) + , (factLocation, obligation) + )) + generatedFacts + let generatedAuthorizations = + snd <$> generatedCandidates + stages = + [ Declaration.checkedCandidate definition + (Declaration.checkedDefinitionEquationPlanning predicate) + :| [] + ] + <> maybeToList + (NonEmpty.nonEmpty + (fst <$> generatedCandidates)) + body = + CheckedExactStructureAuthorization + predicate + generatedAuthorizations + pure + (Declaration.checkedCompiledDeclaration + syntax objects [] [] [descriptor] stages + body) + +authorizeCheckedExactStructure + :: CheckedExactStructureAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactStructure + (CheckedExactStructureAuthorization predicate obligations) + stages = + case (obligations, stages) of + ([], [definition :| []]) -> + Declaration.authorizeDefinitionEquationCandidate + predicate definition + (_, [definition :| [], generatedCandidates]) + | length obligations == NonEmpty.length generatedCandidates -> do + Declaration.authorizeDefinitionEquationCandidate + predicate definition + Declaration.authorizeVampireCandidateBatch + (NonEmpty.zipWith + (\candidate (factLocation, obligation) -> + ( factLocation + , candidate + , do + void + (Declaration.useStagedCandidate + definition) + pure obligation + )) + generatedCandidates + (NonEmpty.fromList obligations)) + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (if null obligations then 1 else 2) + (length stages)) + +validateStructureOccurrences + :: Location + -> Raw.StructDefn + -> [CanonicalLexicalEntry] + -> ExceptT ExactCompileError (Declaration.LoweringDriver) () +validateStructureOccurrences location structure entries = do + let Raw.LexicalItemSgPl forms structureMarker = + Raw.structPhrase structure + expected = + CanonicalStructureNoun + (Raw.sg forms) + (Raw.pl forms) + structureMarker + : [ CanonicalStructureOperation command + | Raw.StructSymbol command <- Raw.structFixes structure + ] + unless + (entries == expected) + (Except.throwError + (ExactStructureOccurrenceMismatch location)) + +encodePreparedStructure + :: SemanticEnvironmentDelta + -> ObjectId + -> [PreparedExactStructureFact] + -> ByteString +encodePreparedStructure environment predicate generated = + encodeCache do + putCacheTag 0x04 + putSemanticEnvironmentDeltaCache environment + putObjectIdCache predicate + putCacheList + (\(PreparedExactStructureFact _location target alias) -> do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm target) + putCacheText (semanticNameText alias)) + generated + +prepareHead + :: Raw.Block + -> SemanticGlobalKey + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , ExactDeclarationFamily + , Maybe (Elaborate CompiledBody) + ) +prepareHead block key = + case block of + Raw.BlockSig location _title _marker assumptions signature -> do + rejectHeaderAssumptions ExactGuardedOpaqueSignature assumptions + head' <- prepareSignature location key signature + pure (head', ExactSignature, Nothing) + Raw.BlockAbbr location _title _marker abbreviation -> do + (head', buildBody) <- + prepareAbbreviation location key abbreviation + pure (head', ExactAbbreviation, Just buildBody) + Raw.BlockDefn location _title _marker definition -> do + (head', buildBody) <- + prepareDefinition location key definition + pure (head', ExactDefinition, Just buildBody) + _ -> + Except.throwError (ExactUnsupportedDeclaration (locate block)) + +prepareSignature + :: Location + -> SemanticGlobalKey + -> Raw.Signature + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + PreparedHead +prepareSignature location key = \case + Raw.SignatureAdj subject (Raw.Adj _ item arguments) -> do + ensureAdjectiveKey location item key + makePreparedHead + location key (subject : arguments) TyProp + Raw.SignatureSymbolic (Raw.SymbolPattern symbol parameters) nounPhrase -> do + unless + ( key + == SemanticExpressionFunction + (Raw.mixfixPattern symbol) + ) + (Except.throwError (ExactDeclarationHeadMismatch location)) + unless + (exactSetNounPhrase nounPhrase) + (Except.throwError (ExactUnsupportedDeclarationBody location)) + makePreparedHead location key parameters TySet + _ -> + Except.throwError (ExactUnsupportedDeclaration location) + +prepareAbbreviation + :: Location + -> SemanticGlobalKey + -> Raw.Abbreviation + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +prepareAbbreviation location key = \case + Raw.AbbreviationEq (Raw.SymbolPattern symbol parameters) expression -> do + ensureExpressionKey location symbol key + makeContextualTransparentHead + location key parameters TySet + (ordinaryCompiledBody <$> compileExpressionAsSet expression) + Raw.AbbreviationFun (Raw.Fun _ item parameters) term -> do + ensureFunctionPhraseKey location item key + makeContextualTransparentHead + location key parameters TySet + (ordinaryCompiledBody <$> compileTermAsSet term) + Raw.AbbreviationAdj subject (Raw.Adj _ item arguments) statement -> do + ensureAdjectiveKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationVerb subject (Raw.Verb _ item arguments) statement -> do + ensureVerbKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationNoun subject (Raw.Noun _ item arguments) statement -> do + ensureNounKey location item key + makeContextualTransparentHead + location key (subject : arguments) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + Raw.AbbreviationRel left relation parameters right statement -> do + ensureRelationKey location relation key + makeContextualTransparentHead + location key (parameters <> [left, right]) TyProp + (ordinaryCompiledBody <$> compileStatement statement) + +prepareDefinition + :: Location + -> SemanticGlobalKey + -> Raw.Defn + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +prepareDefinition location key = \case + Raw.Defn assumptions head' statement -> do + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions + (parameters, resultType) <- + definitionHead location key head' + makeTransparentHead + location key parameters resultType + (ordinaryCompiledBody <$> compileStatement statement) + Raw.DefnFun assumptions (Raw.Fun _ item parameters) symbolic term -> do + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions + traverse_ + (Except.throwError + . ExactDefinitionCombinedSymbolicAlias + . locate) + symbolic + ensureFunctionPhraseKey location item key + makeTransparentHead + location key parameters TySet + (compileNamedSetTerm term) + Raw.DefnOp (Raw.SymbolPattern symbol parameters) expression -> do + ensureExpressionKey location symbol key + makeTransparentHead + location key parameters TySet + (compileNamedSetExpression expression) + +definitionHead + :: Location + -> SemanticGlobalKey + -> Raw.DefnHead + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ([Raw.VarSymbol], CoreType) +definitionHead location key = \case + Raw.DefnAdj annotation subject (Raw.Adj _ item arguments) -> do + validateDefinitionAnnotation annotation + ensureAdjectiveKey location item key + pure (subject : arguments, TyProp) + Raw.DefnVerb annotation subject (Raw.Verb _ item arguments) -> do + validateDefinitionAnnotation annotation + ensureVerbKey location item key + pure (subject : arguments, TyProp) + Raw.DefnNoun subject (Raw.Noun _ item arguments) -> do + ensureNounKey location item key + pure (subject : arguments, TyProp) + Raw.DefnRel left relation parameters right -> do + ensureRelationKey location relation key + pure (parameters <> [left, right], TyProp) + Raw.DefnSymbolicPredicate + (Raw.PrefixPredicate command arity) + _marker + parameters -> do + unless + ( key + == SemanticPrefixPredicate + command + (fromIntegral arity) + ) + (Except.throwError (ExactDeclarationHeadMismatch location)) + pure (toList parameters, TyProp) + +validateDefinitionAnnotation + :: MonadError ExactCompileError monad + => Maybe (Raw.NounPhrase Maybe) + -> monad () +validateDefinitionAnnotation = traverse_ \nounPhrase -> + unless (exactSetNounPhrase nounPhrase) + (throwError + (ExactNonCanonicalSetDefinitionAnnotation + (exactNounPhraseLocation nounPhrase))) + +rejectHeaderAssumptions + :: MonadError ExactCompileError monad + => (Location -> ExactCompileError) + -> [Raw.Asm] + -> monad () +rejectHeaderAssumptions makeError = \case + [] -> pure () + assumption : _ -> + throwError (makeError (exactAssumptionLocation assumption)) + +exactAssumptionLocation :: Raw.Asm -> Location +exactAssumptionLocation = \case + Raw.AsmSuppose statement -> locate statement + Raw.AsmLetNoun variables _nounPhrase -> locate variables + Raw.AsmLetIn variables _expression -> locate variables + Raw.AsmLetThe variable _function -> locate variable + Raw.AsmLetEq variable _expression -> locate variable + Raw.AsmLetStruct variable _structure -> locate variable + +exactNounPhraseLocation :: Raw.NounPhraseOf t argument -> Location +exactNounPhraseLocation + (Raw.NounPhrase _left noun _variables _right _suchThat) = + locate noun + +makeTransparentHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> Elaborate CompiledBody + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +makeTransparentHead location key parameters resultType body = do + (prepared, binders) <- + prepareParameters location key parameters resultType + let close = do + State.modify' \state -> + state + { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + } + CompiledBody body' construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + construction) + pure (prepared, close) + +makeContextualTransparentHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> Elaborate CompiledBody + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Elaborate CompiledBody + ) +makeContextualTransparentHead location key parameters resultType body = do + (prepared, binders) <- + prepareParameters location key parameters resultType + let close = do + State.modify' \state -> + state + { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + 1 + , elaborationContextualBinder = + Just (fromIntegral (length parameters)) + } + CompiledBody body' _construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + Nothing) + pure (prepared, close) + +makePreparedHead + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + PreparedHead +makePreparedHead location key parameters resultType = do + (prepared, _binders) <- + prepareParameters location key parameters resultType + pure prepared + +prepareParameters + :: Location + -> SemanticGlobalKey + -> [Raw.VarSymbol] + -> CoreType + -> ExceptT + ExactCompileError + (Declaration.LoweringDriver) + ( PreparedHead + , Map.Map Raw.VarSymbol Natural + ) +prepareParameters + location key parameters resultType = do + case firstDuplicate parameters of + Just duplicate -> + Except.throwError + (ExactDuplicateParameter location duplicate) + Nothing -> pure () + let indices = + reverse (take (length parameters) [0 ..]) + binders = + Map.fromList + (zip parameters indices) + coreType = foldr (const (TyArrow TySet)) resultType parameters + pure + ( PreparedHead key parameters coreType + , binders + ) + +compileExpressionAsSet + :: Raw.Expr + -> Elaborate (CanonicalTerm ObjectId) +compileExpressionAsSet expression = do + (term, actual) <- compileExpression expression + unless (actual == TySet) + (Except.throwError + (ExactExpressionExpectedSet (locate expression) actual)) + pure term + +-- | Compile one set expression once while retaining the checked-source shape +-- needed only when that expression is subsequently named by a definition. +-- Nested constructions remain ordinary exact terms. +compileNamedSetExpression + :: Raw.Expr + -> Elaborate CompiledBody +compileNamedSetExpression = \case + Raw.ExprSep _location variable bound predicate -> do + (term, bound', predicate') <- + compileSeparation variable bound predicate + pure + (CompiledBody term + (Just + (CompiledSeparationConstruction + bound' predicate'))) + Raw.ExprReplace _location value bounds condition -> do + replacement <- + compileFunctionalReplacement value bounds condition + pure + (CompiledBody + (compiledFunctionalReplacementTerm replacement) + (Just + (CompiledFunctionalReplacementConstruction + (compiledFunctionalReplacementDomains replacement) + (compiledFunctionalReplacementValue replacement) + (compiledFunctionalReplacementCondition replacement)))) + Raw.ExprReplacePred _location range domainVariable bound predicate -> do + (term, domain, relation) <- + compileRelationalReplacement + range domainVariable bound predicate + pure + (CompiledBody term + (Just + (CompiledRelationalReplacementConstruction + domain relation))) + expression -> + (`CompiledBody` Nothing) + <$> compileExpressionAsSet expression + +compileNamedSetTerm :: Raw.Term -> Elaborate CompiledBody +compileNamedSetTerm = \case + Raw.TermExpr expression -> compileNamedSetExpression expression + term -> ordinaryCompiledBody <$> compileTermAsSet term + +ordinaryCompiledBody :: CanonicalTerm ObjectId -> CompiledBody +ordinaryCompiledBody term = CompiledBody term Nothing + +compileTermAsSet + :: Raw.Term + -> Elaborate (CanonicalTerm ObjectId) +compileTermAsSet = \case + Raw.TermExpr expression -> + compileExpressionAsSet expression + Raw.TermFun (Raw.Fun location item arguments) -> do + let patterns = Raw.lexicalItemSgPlPattern item + key = SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns) + compiled <- traverse compileTermAsSet arguments + applyResolved location key compiled + Raw.TermQuantified _quantifier location _nounPhrase -> + Except.throwError + (ExactQuantifiedTermRequiresPropositionContext location) + term -> + Except.throwError + (ExactUnsupportedDeclarationBody (locate term)) + +-- | Compile a source term only at a proposition consumer. Indefinite terms +-- own the continuation, so their noun constraints and quantifier surround +-- exactly the proposition which consumes the resulting set. Function-phrase +-- arguments recurse through the same seam and therefore never masquerade as +-- independently set-valued terms. +compileTermInProposition + :: Raw.Term + -> (CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermInProposition term continuation = + case term of + Raw.TermExpr expression -> + compileExpressionAsSet expression >>= continuation + Raw.TermFun (Raw.Fun location item arguments) -> do + let patterns = Raw.lexicalItemSgPlPattern item + key = + SemanticFunctionPhrase + (Raw.sg patterns) + (Raw.pl patterns) + compileTermsInProposition arguments \compiled -> do + value <- applyResolved location key compiled + continuation value + Raw.TermQuantified quantifier _location nounPhrase -> + compileQuantifiedTermInProposition + quantifier nounPhrase continuation + Raw.TermIota location _variable _statement -> + Except.throwError (ExactUnsupportedDeclarationBody location) + +-- | Compile source-ordered proposition terms. The first source occurrence +-- receives the outermost continuation and therefore the widest scope. +compileTermsInProposition + :: [Raw.Term] + -> ([CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermsInProposition terms continuation = + case terms of + [] -> continuation [] + term : remaining -> + compileTermInProposition term \compiled -> do + compiledDepth <- State.gets elaborationBinderDepth + compileTermsInProposition remaining \rest -> do + compiled' <- + weakenElaboratedTermFrom compiledDepth compiled + continuation (compiled' : rest) + +weakenElaboratedTermFrom + :: Natural + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +weakenElaboratedTermFrom originalDepth term = do + currentDepth <- State.gets elaborationBinderDepth + when (currentDepth < originalDepth) + (impossible + "a proposition-term continuation escaped its binder scope") + pure + (shiftCanonical + (currentDepth - originalDepth) + 0 + term) + +compileExpression + :: Raw.Expr + -> Elaborate (CanonicalTerm ObjectId, CoreType) +compileExpression = \case + Raw.ExprVar variable -> do + binders <- State.gets elaborationBinders + case Map.lookup variable binders of + Just index -> + pure (CBound index, TySet) + Nothing -> + Except.throwError + (ExactFreeVariable (locate variable) variable) + Raw.ExprInteger _location integer -> + pure (COpaqueInteger (toInteger integer), TySet) + Raw.ExprOp location symbol arguments -> do + let key = + SemanticExpressionFunction + (Raw.mixfixPattern symbol) + compiled <- traverse compileExpression arguments + case fixedSemanticMeaning key of + Just (FixedIntrinsic intrinsic) -> + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + Just (FixedNegatedIntrinsic _intrinsic) -> + impossible + "expression key resolved to a negated intrinsic" + Just FixedEquality -> + impossible + "expression key resolved to fixed equality" + Just FixedDisequality -> + impossible + "expression key resolved to fixed disequality" + Nothing -> + applyResolvedTyped + location + key + compiled + Raw.ExprStructOp location symbol maybeArgument -> + compileStructureOperation location symbol maybeArgument + Raw.ExprFiniteSet _location elements -> do + compiled <- traverse compileExpressionAsSet elements + pure + ( foldr + canonicalSetInsert + (CIntrinsic Empty) + compiled + , TySet + ) + Raw.ExprSep _location variable bound predicate -> do + (term, _bound, _predicate) <- + compileSeparation variable bound predicate + pure (term, TySet) + Raw.ExprReplace _location value bounds condition -> do + replacement <- + compileFunctionalReplacement value bounds condition + pure (compiledFunctionalReplacementTerm replacement, TySet) + Raw.ExprReplacePred location _value _variable _bound _predicate -> + Except.throwError + (ExactRelationalReplacementRequiresNamedDefinition location) + +compileStructureOperation + :: Location + -> Raw.StructSymbol + -> Maybe Raw.Expr + -> Elaborate (CanonicalTerm ObjectId, CoreType) +compileStructureOperation location symbol maybeArgument = do + (argument, object) <- + case maybeArgument of + Just expression -> do + term <- compileExpressionAsSet expression + structures <- State.gets elaborationStructures + case termStructureAnnotation term structures of + Just annotation -> do + object <- + maybe + (Except.throwError + (ExactStructureOperationNotAvailable + location symbol)) + pure + (structureAnnotationOperation + symbol annotation) + pure (term, object) + Nothing -> do + object <- + resolveUniqueStructureOperation location symbol + pure (term, object) + Nothing -> do + structures <- State.gets elaborationStructures + case + [ (CBound index, object) + | (index, structure) <- Map.toAscList structures + , Just object <- + [structureAnnotationOperation symbol structure] + ] of + firstMatch : _ -> pure firstMatch + [] -> do + contextual <- State.gets elaborationContextualBinder + case contextual of + Nothing -> + Except.throwError + (ExactStructureOperationNotAvailable + location symbol) + Just index -> do + object <- + resolveUniqueStructureOperation + location symbol + recordContextualRequirement + location symbol object + pure (CBound index, object) + recordExactGlobal object (TyArrow TySet TySet) + pure (CApp (CGlobal object) argument, TySet) + where + termStructureAnnotation term structures = + case term of + CBound index -> Map.lookup index structures + _ -> Nothing + +resolveUniqueStructureOperation + :: Location + -> Raw.StructSymbol + -> Elaborate ObjectId +resolveUniqueStructureOperation location symbol = do + objects <- + State.lift + (Except.lift + (Declaration.resolveVisibleStructureOperationObjectsLowering + symbol)) + case objects of + [] -> + Except.throwError + (ExactStructureOperationNotAvailable location symbol) + [object] -> pure object + _ -> + Except.throwError + (ExactStructureOperationAmbiguous location symbol objects) + +recordContextualRequirement + :: Location + -> Raw.StructSymbol + -> ObjectId + -> Elaborate () +recordContextualRequirement location symbol object = do + existing <- + State.gets + (Map.lookup symbol . elaborationContextualRequirements) + case existing of + Nothing -> + State.modify' \state -> + state + { elaborationContextualRequirements = + Map.insert symbol object + (elaborationContextualRequirements state) + } + Just actual + | actual == object -> pure () + | otherwise -> + Except.throwError + (ExactContextualRequirementConflict + location symbol actual object) + +structureCarrierCast + :: Location + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +structureCarrierCast location term = + case term of + CBound index -> do + annotation <- State.gets (Map.lookup index . elaborationStructures) + case annotation of + Nothing -> pure term + Just structure -> do + carrier <- + maybe + (Except.throwError + (ExactStructureOperationNotAvailable + location Raw.CarrierSymbol)) + pure + (structureAnnotationOperation + Raw.CarrierSymbol structure) + recordExactGlobal carrier (TyArrow TySet TySet) + pure (CApp (CGlobal carrier) term) + _ -> pure term + +compileMembership + :: Location + -> Raw.Sign + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileMembership location sign element set = do + checkedSet <- structureCarrierCast location set + let proposition = + CApp + (CApp (CIntrinsic Member) element) + checkedSet + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition + +compileSeparation + :: Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileSeparation variable bound predicate = do + bound' <- compileExpressionAsSet bound + predicate' <- + withSetBinders (variable :| []) + (compileStatement predicate) + pure + ( CApp + (CApp (CIntrinsic Sep) bound') + (CLam TySet predicate') + , bound' + , predicate' + ) + +compileRelationalReplacement + :: Raw.VarSymbol + -> Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileRelationalReplacement range domainVariable bound predicate = do + domain <- compileExpressionAsSet bound + relation <- + withSetBinders (domainVariable :| [range]) + (compileStatement predicate) + let restrictedDomain = + CApp + (CApp (CIntrinsic Sep) domain) + (CLam TySet (logicalExists relation)) + choiceFunction = + CLam TySet + (CApp (CIntrinsic SetChoose) (CLam TySet relation)) + replacement = + CApp + (CApp (CIntrinsic Repl) restrictedDomain) + choiceFunction + pure (replacement, domain, relation) + +data CompiledFunctionalReplacement = CompiledFunctionalReplacement + !(CanonicalTerm ObjectId) + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + +compiledFunctionalReplacementTerm + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementTerm + (CompiledFunctionalReplacement term _domains _value _condition) = + term + +compiledFunctionalReplacementDomains + :: CompiledFunctionalReplacement + -> NonEmpty (CanonicalTerm ObjectId) +compiledFunctionalReplacementDomains + (CompiledFunctionalReplacement _term domains _value _condition) = + domains + +compiledFunctionalReplacementValue + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementValue + (CompiledFunctionalReplacement _term _domains value _condition) = + value + +compiledFunctionalReplacementCondition + :: CompiledFunctionalReplacement + -> Maybe (CanonicalTerm ObjectId) +compiledFunctionalReplacementCondition + (CompiledFunctionalReplacement _term _domains _value condition) = + condition + +compileFunctionalReplacement + :: Raw.Expr + -> NonEmpty (Raw.VarSymbol, Raw.Expr) + -> Maybe Raw.Stmt + -> Elaborate CompiledFunctionalReplacement +compileFunctionalReplacement + value ((variable, domain) :| remaining) condition = do + domain' <- compileExpressionAsSet domain + case remaining of + [] -> do + (value', condition') <- + withSetBinders (variable :| []) do + value' <- compileExpressionAsSet value + condition' <- traverse compileStatement condition + pure (value', condition') + let filteredDomain = + case condition' of + Nothing -> domain' + Just predicate -> + CApp + (CApp (CIntrinsic Sep) domain') + (CLam TySet predicate) + pure + (CompiledFunctionalReplacement + (CApp + (CApp (CIntrinsic Repl) filteredDomain) + (CLam TySet value')) + (domain' :| []) + value' + condition') + next : rest -> do + nested <- + withSetBinders (variable :| []) + (compileFunctionalReplacement + value (next :| rest) condition) + pure + (CompiledFunctionalReplacement + (CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp (CIntrinsic Repl) domain') + (CLam TySet + (compiledFunctionalReplacementTerm nested)))) + (domain' + NonEmpty.<| + compiledFunctionalReplacementDomains nested) + (compiledFunctionalReplacementValue nested) + (compiledFunctionalReplacementCondition nested)) + +compileStatement + :: Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileStatement = \case + Raw.StmtFormula formula -> + compileFormula formula + Raw.StmtVerbPhrase terms verbPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileVerbPhrase` verbPhrase) subjects + Raw.StmtNoun terms nounPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileNounPhraseMaybe` nounPhrase) subjects + Raw.StmtExists _location nounPhrase -> + compileExistentialNounPhrase nounPhrase + Raw.StmtQuantPhrase + _location + (Raw.QuantPhrase quantifier nounPhrase) + statement -> + compileQuantifiedNounPhrase quantifier nounPhrase statement + Raw.StmtConnected connective location left right -> + compileConnective + (fromMaybe (locate left) location) + connective + compileStatement + left + right + Raw.StmtNeg _location statement -> + logicalNot <$> compileStatement statement + Raw.SymbolicQuantified + _location quantifier variables bound suchThat statement -> + compileSymbolicQuantified + quantifier variables bound suchThat (compileStatement statement) + Raw.StmtStruct term rawPhrase -> + compileTermInProposition term \subject -> do + annotation <- + resolveStructureAnnotation (locate term) rawPhrase + predicate <- + maybe + (impossible "an assertable structure has no predicate") + pure + (structureAnnotationPredicate annotation) + recordExactGlobal + predicate + (TyArrow TySet TyProp) + pure + (CApp + (CGlobal predicate) + subject) + +compileQuantifiedTermInProposition + :: Raw.Quantifier + -> Raw.NounPhrase Maybe + -> (CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileQuantifiedTermInProposition quantifier + (Raw.NounPhrase left noun named right suchThat) + compileBody = + case named of + Nothing -> + withAnonymousSetBinder compileFor + Just variable -> + withSetBinders (variable :| []) do + subject <- compileIntroducedVariable variable + compileFor subject + where + compileFor subject = do + constraints <- + compileNounPhraseConstraints + [subject] left noun right suchThat + body <- compileBody subject + pure (quantifyNounPhrase quantifier 1 constraints body) + +compileSymbolicQuantified + :: Raw.Quantifier + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Maybe Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) + -> Elaborate (CanonicalTerm ObjectId) +compileSymbolicQuantified quantifier variables bound suchThat compileBody = + withSetBinders variables do + boundConstraints <- + compileSymbolicBoundConstraintList variables bound + suchThatConstraints <- + maybeToList <$> traverse compileStatement suchThat + body <- compileBody + pure + (quantifyNounPhrase + quantifier + (length (toList variables)) + (logicalConjunction + (boundConstraints <> suchThatConstraints)) + body) + +compileSymbolicBoundConstraintList + :: NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Elaborate [CanonicalTerm ObjectId] +compileSymbolicBoundConstraintList variables = \case + Raw.Unbounded -> + pure [] + Raw.Bounded _location sign relation domain -> do + subjects <- traverse compileIntroducedVariable variables + domain' <- compileExpressionAsSet domain + traverse + (\subject -> do + proposition <- + compileAtomicRelationTerms subject relation domain' + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition) + (toList subjects) + +compileAtomicRelationTerms + :: CanonicalTerm ObjectId + -> Raw.Relation + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileAtomicRelationTerms left relation right = + case relation of + Raw.Relation location symbol parameters -> do + let key = + SemanticRelation + (Raw.relationSymbolToken symbol) + (Raw.relationSymbolParameterArity symbol) + compiledParameters <- traverse compileExpressionAsSet parameters + case fixedSemanticMeaning key of + Just FixedEquality + | null parameters -> pure (CEq TySet left right) + Just FixedDisequality + | null parameters -> + pure (logicalNot (CEq TySet left right)) + Just (FixedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Positive left right + Just (FixedNegatedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Negative left right + Just (FixedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just (FixedNegatedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure (logicalNot term) + _ -> do + (term, actual) <- + applyResolvedTyped + location key + ((\term -> (term, TySet)) + <$> (compiledParameters <> [left, right])) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Raw.RelationExpr location expression -> + compileRelationExpression location expression left right + +compileVerbPhrase + :: CanonicalTerm ObjectId + -> Raw.VerbPhrase + -> Elaborate (CanonicalTerm ObjectId) +compileVerbPhrase subject = \case + Raw.VPVerb verb -> + compileVerb subject verb + Raw.VPVerbNot verb -> + logicalNot <$> compileVerb subject verb + Raw.VPAdj adjectives -> + logicalConjunction + <$> traverse (compileAdjective subject) adjectives + Raw.VPAdjNot adjectives -> + logicalNot . logicalConjunction + <$> traverse (compileAdjective subject) adjectives + +compilePredicateArguments + :: CanonicalTerm ObjectId + -> [Raw.Term] + -> ( CanonicalTerm ObjectId + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) + ) + -> Elaborate (CanonicalTerm ObjectId) +compilePredicateArguments subject arguments continuation = do + subjectDepth <- State.gets elaborationBinderDepth + compileTermsInProposition arguments \compiled -> do + subject' <- weakenElaboratedTermFrom subjectDepth subject + continuation subject' compiled + +compileVerb + :: CanonicalTerm ObjectId + -> Raw.Verb + -> Elaborate (CanonicalTerm ObjectId) +compileVerb subject (Raw.Verb location item arguments) = do + let patterns = Raw.lexicalItemSgPlPattern item + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) + (subject' : compiled) + +compileAdjective + :: CanonicalTerm ObjectId + -> Raw.Adj + -> Elaborate (CanonicalTerm ObjectId) +compileAdjective subject (Raw.Adj location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicateChoice + location + ( SemanticRightAdjective (Raw.lexicalItemPattern item) + :| [SemanticLeftAdjective (Raw.lexicalItemPattern item)] + ) + (subject' : compiled) + +compileLeftAdjective + :: CanonicalTerm ObjectId + -> Raw.AdjL + -> Elaborate (CanonicalTerm ObjectId) +compileLeftAdjective subject (Raw.AdjL location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticLeftAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) + +compileRightAttribute + :: CanonicalTerm ObjectId + -> Raw.AdjR + -> Elaborate (CanonicalTerm ObjectId) +compileRightAttribute subject = \case + Raw.AdjR location item arguments -> + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticRightAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) + Raw.AttrRThat verbPhrase -> + compileVerbPhrase subject verbPhrase + +compileNoun + :: CanonicalTerm ObjectId + -> Raw.Noun + -> Elaborate (CanonicalTerm ObjectId) +compileNoun subject (Raw.Noun location item arguments) + | Lexicon.isBuiltinSetNoun item = + pure logicalTruth + | otherwise = do + let patterns = Raw.lexicalItemSgPlPattern item + key = SemanticNoun (Raw.sg patterns) (Raw.pl patterns) + compilePredicateArguments subject arguments \subject' compiled -> + case fixedSemanticMeaning key of + Just (FixedIntrinsic Member) -> + case compiled of + [set] -> + compileMembership + location Raw.Positive subject' set + _ -> + impossible + "the fixed element noun does not have one argument" + Just (FixedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\argument -> (argument, TySet)) + <$> (subject' : compiled)) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just{} -> + impossible "a fixed noun is not a predicate intrinsic" + Nothing -> + applyResolvedPredicate + location key (subject' : compiled) + +compileNounPhraseConstraints + :: [CanonicalTerm ObjectId] + -> [Raw.AdjL] + -> Raw.Noun + -> [Raw.AdjR] + -> Maybe Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileNounPhraseConstraints subjects left noun right suchThat = do + nounConstraints <- traverse (`compileNoun` noun) subjects + leftConstraints <- concat + <$> traverse + (\subject -> traverse (compileLeftAdjective subject) left) + subjects + rightConstraints <- concat + <$> traverse + (\subject -> traverse (compileRightAttribute subject) right) + subjects + suchThatConstraint <- traverse compileStatement suchThat + pure + (logicalConjunction + ( nounConstraints + <> leftConstraints + <> rightConstraints + <> maybeToList suchThatConstraint + )) + +compileNounPhraseMaybe + :: CanonicalTerm ObjectId + -> Raw.NounPhrase Maybe + -> Elaborate (CanonicalTerm ObjectId) +compileNounPhraseMaybe subject + (Raw.NounPhrase left noun named right suchThat) = + case named of + Nothing -> + compileNounPhraseConstraints + [subject] left noun right suchThat + Just variable -> do + abstracted <- + withSetBinders (variable :| []) + (compileNounPhraseConstraints + [CBound 0] left noun right suchThat) + pure (instantiateCanonical subject abstracted) + +compileExistentialNounPhrase + :: Raw.NounPhrase [] + -> Elaborate (CanonicalTerm ObjectId) +compileExistentialNounPhrase + (Raw.NounPhrase left noun variables right suchThat) = + case NonEmpty.nonEmpty variables of + Just binders -> + withSetBinders binders do + subjects <- traverse compileIntroducedVariable binders + constraints <- + compileNounPhraseConstraints + (toList subjects) left noun right suchThat + pure + (foldr + (const logicalExists) + constraints + binders) + Nothing -> + withAnonymousSetBinder \subject -> + logicalExists + <$> compileNounPhraseConstraints + [subject] left noun right suchThat + +compileQuantifiedNounPhrase + :: Raw.Quantifier + -> Raw.NounPhrase [] + -> Raw.Stmt + -> Elaborate (CanonicalTerm ObjectId) +compileQuantifiedNounPhrase quantifier + (Raw.NounPhrase left noun variables right suchThat) + statement = + case NonEmpty.nonEmpty variables of + Just binders -> + withSetBinders binders do + subjects <- traverse compileIntroducedVariable binders + constraints <- + compileNounPhraseConstraints + (toList subjects) left noun right suchThat + body <- compileStatement statement + pure + (quantifyNounPhrase + quantifier + (length (toList binders)) + constraints + body) + Nothing -> + withAnonymousSetBinder \subject -> do + constraints <- + compileNounPhraseConstraints + [subject] left noun right suchThat + body <- compileStatement statement + pure (quantifyNounPhrase quantifier 1 constraints body) + +quantifyNounPhrase + :: Raw.Quantifier + -> Int + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId +quantifyNounPhrase quantifier binderCount constraints body = + case quantifier of + Raw.Universally -> + quantify + (if constraints == logicalTruth + then body + else CImp constraints body) + Raw.Existentially -> + quantify + (if constraints == logicalTruth + then body + else logicalAnd constraints body) + Raw.Nonexistentially -> + logicalNot + (quantify + (if constraints == logicalTruth + then body + else logicalAnd constraints body)) + where + quantify scoped = + foldr (const binder) scoped [1 .. binderCount] + binder = case quantifier of + Raw.Universally -> CForall TySet + Raw.Existentially -> logicalExists + Raw.Nonexistentially -> logicalExists + +withAnonymousSetBinder + :: (CanonicalTerm ObjectId -> Elaborate value) + -> Elaborate value +withAnonymousSetBinder action = do + outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth + outerStructures <- State.gets elaborationStructures + outerContextual <- State.gets elaborationContextualBinder + State.modify' \state -> + state + { elaborationBinders = (+ 1) <$> outer + , elaborationBinderDepth = outerDepth + 1 + , elaborationStructures = + Map.mapKeysMonotonic (+ 1) outerStructures + , elaborationContextualBinder = (+ 1) <$> outerContextual + } + result <- action (CBound 0) + State.modify' \state -> + state + { elaborationBinders = outer + , elaborationBinderDepth = outerDepth + , elaborationStructures = outerStructures + , elaborationContextualBinder = outerContextual + } + pure result + +withSetBinders + :: NonEmpty Raw.VarSymbol + -> Elaborate value + -> Elaborate value +withSetBinders variables action = do + outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth + outerStructures <- State.gets elaborationStructures + outerContextual <- State.gets elaborationContextualBinder + case firstDuplicate (toList variables) of + Just duplicate -> + Except.throwError + (ExactDuplicateLocalBinder + (locate duplicate) + duplicate) + Nothing -> pure () + case find (`Map.member` outer) (toList variables) of + Just shadowed -> + Except.throwError + (ExactDuplicateLocalBinder + (locate shadowed) + shadowed) + Nothing -> pure () + let binderCount = fromIntegral (length (toList variables)) + shifted = (+ binderCount) <$> outer + introduced = + Map.fromList + (zip + (toList variables) + (reverse [0 .. binderCount - 1])) + State.modify' \state -> + state + { elaborationBinders = introduced <> shifted + , elaborationBinderDepth = outerDepth + binderCount + , elaborationStructures = + Map.mapKeysMonotonic (+ binderCount) outerStructures + , elaborationContextualBinder = + (+ binderCount) <$> outerContextual + } + result <- action + State.modify' \state -> + state + { elaborationBinders = outer + , elaborationBinderDepth = outerDepth + , elaborationStructures = outerStructures + , elaborationContextualBinder = outerContextual + } + pure result + +compileFormula + :: Raw.Formula + -> Elaborate (CanonicalTerm ObjectId) +compileFormula = \case + Raw.FormulaChain chain -> + compileRelationChain chain + Raw.PropositionalConstant _ Raw.IsBottom -> + pure CFalsum + Raw.PropositionalConstant _ Raw.IsTop -> + pure (CImp CFalsum CFalsum) + Raw.FormulaNeg _ formula -> + logicalNot <$> compileFormula formula + Raw.FormulaPredicate + location + (Raw.PrefixPredicate command arity) + _marker + arguments -> do + compiled <- traverse compileExpression arguments + (term, actual) <- + applyResolvedTyped + location + (SemanticPrefixPredicate + command + (fromIntegral arity)) + (toList compiled) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Raw.Connected location connective left right -> + compileConnective + location + connective + compileFormula + left + right + Raw.FormulaQuantified + _location quantifier variables bound formula -> + compileSymbolicQuantified + quantifier variables bound Nothing (compileFormula formula) +compileConnective + :: Location + -> Raw.Connective + -> (input -> Elaborate (CanonicalTerm ObjectId)) + -> input + -> input + -> Elaborate (CanonicalTerm ObjectId) +compileConnective _location connective compile left right = do + left' <- compile left + right' <- compile right + case connective of + Raw.Conjunction -> + pure (logicalAnd left' right') + Raw.Disjunction -> + pure (logicalOr left' right') + Raw.Implication -> + pure (CImp left' right') + Raw.Equivalence -> + pure (CEq TyProp left' right') + Raw.ExclusiveOr -> + pure + (logicalAnd + (logicalOr left' right') + (logicalNot (logicalAnd left' right'))) + Raw.NegatedDisjunction -> + pure (logicalNot (logicalOr left' right')) + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + logicalNot (CImp left (logicalNot right)) + +logicalTruth :: CanonicalTerm global +logicalTruth = + CImp CFalsum CFalsum + +logicalConjunction + :: (Foldable collection, Eq global) + => collection (CanonicalTerm global) + -> CanonicalTerm global +logicalConjunction = + foldr combine logicalTruth + where + combine proposition remaining + | proposition == logicalTruth = remaining + | remaining == logicalTruth = proposition + | otherwise = logicalAnd proposition remaining + +logicalOr + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalOr left right = + CImp (logicalNot left) right + +logicalExists + :: CanonicalTerm global + -> CanonicalTerm global +logicalExists body = + logicalNot (CForall TySet (logicalNot body)) + +compileAtomicRelation + :: NonEmpty Raw.Expr + -> Raw.Relation + -> NonEmpty Raw.Expr + -> Elaborate (CanonicalTerm ObjectId) +compileAtomicRelation left relation right = + case (toList left, relation, toList right) of + ([leftExpression], Raw.Relation location symbol parameters, [rightExpression]) -> do + let key = + SemanticRelation + (Raw.relationSymbolToken symbol) + (Raw.relationSymbolParameterArity symbol) + case fixedSemanticMeaning key of + Just FixedEquality + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + pure (CEq TySet left' right') + | otherwise -> + Except.throwError + (ExactUnsupportedDeclarationBody location) + Just FixedDisequality + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + pure (logicalNot (CEq TySet left' right')) + | otherwise -> + Except.throwError + (ExactUnsupportedDeclarationBody location) + Just (FixedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Positive left' right' + Just (FixedNegatedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Negative left' right' + Just (FixedIntrinsic intrinsic) -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just (FixedNegatedIntrinsic intrinsic) -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure (logicalNot term) + Nothing -> do + compiled <- traverse compileExpression + (parameters <> [leftExpression, rightExpression]) + (term, actual) <- + applyResolvedTyped location key compiled + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + ([leftExpression], Raw.RelationExpr location expression, [rightExpression]) -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileRelationExpression location expression left' right' + _ -> + Except.throwError + (ExactUnsupportedDeclarationBody (locate relation)) + +compileRelationExpression + :: Location + -> Raw.Expr + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileRelationExpression location expression left right = do + relation <- compileExpressionAsSet expression + pair <- + applyResolved + location + (SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol)) + [left, right] + compileMembership location Raw.Positive pair relation + +compileRelationChain + :: Raw.Chain + -> Elaborate (CanonicalTerm ObjectId) +compileRelationChain chain = + logicalConjunction <$> traverse compileLink (chainLinks chain) + where + compileLink (sign, relation, left, right) = do + proposition <- + compileAtomicRelation + (left :| []) relation (right :| []) + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition + + chainLinks = \case + Raw.ChainBase left sign relation right -> + [ (sign, relation, leftExpression, rightExpression) + | leftExpression <- toList left + , rightExpression <- toList right + ] + Raw.ChainCons left sign relation rest -> + let firstRight = chainFirstLeft rest + in + [ (sign, relation, leftExpression, rightExpression) + | leftExpression <- toList left + , rightExpression <- toList firstRight + ] + <> chainLinks rest + + chainFirstLeft = \case + Raw.ChainBase left _sign _relation _right -> left + Raw.ChainCons left _sign _relation _rest -> left + +applyResolved + :: Location + -> SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolved location key arguments = do + (term, actual) <- + applyResolvedTyped + location key ((\argument -> (argument, TySet)) <$> arguments) + unless (actual == TySet) + (Except.throwError + (ExactExpressionExpectedSet location actual)) + pure term + +applyResolvedPredicate + :: Location + -> SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolvedPredicate location key = + applyResolvedPredicateChoice location (key :| []) + +applyResolvedPredicateChoice + :: Location + -> NonEmpty SemanticGlobalKey + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) +applyResolvedPredicateChoice location keys arguments = do + case firstFixedMeaning (toList keys) of + Just meaning -> + maybe + (impossible + "a fixed equality predicate has an invalid source arity") + pure + (lowerFixedEqualityPredicate meaning arguments) + Nothing -> do + visible <- for (toList keys) \key -> do + found <- + State.lift + (Except.lift + (Declaration.resolveVisibleGlobalLowering key)) + pure ((\target -> (key, target)) <$> found) + case catMaybes visible of + [(key, _target)] -> do + (term, actual) <- + applyResolvedTyped + location key + ((\argument -> (argument, TySet)) <$> arguments) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + [] -> + Except.throwError + (ExactGlobalNotVisible location (NonEmpty.head keys)) + _ -> + impossible + "one adjective surface resolves to several exact globals" + where + firstFixedMeaning = + foldr + (\key found -> fixedSemanticMeaning key <|> found) + Nothing + +applyResolvedTyped + :: Location + -> SemanticGlobalKey + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyResolvedTyped location key arguments = do + visible <- + State.lift + (Except.lift + (Declaration.resolveVisibleGlobalContentLowering key)) + (target, content, dependencies) <- + maybe + (Except.throwError (ExactGlobalNotVisible location key)) + pure + visible + case target of + GlobalReference identity -> do + let coreType = objectContentType content + State.modify' \state -> + state + { elaborationGlobals = + Map.insert + identity coreType + (elaborationGlobals state) + } + applyTyped location (CGlobal identity) coreType arguments + TransparentExpansion _identity -> + case content of + TransparentObjectContent _theory coreType body -> do + State.modify' \state -> + state + { elaborationGlobals = + Map.union + dependencies + (elaborationGlobals state) + } + applyExpandedTyped + location body coreType arguments + _ -> + impossible + "validated transparent expansion has opaque content" + ContextualTransparentExpansion _identity requirements -> + case content of + TransparentObjectContent _theory coreType body -> do + State.modify' \state -> + state + { elaborationGlobals = + Map.union + dependencies + (elaborationGlobals state) + } + contextArgument <- + resolveContextualExpansionArgument + location key requirements + applyExpandedTyped + location body coreType + ((contextArgument, TySet) : arguments) + _ -> + impossible + "validated contextual expansion has opaque content" + +resolveContextualExpansionArgument + :: Location + -> SemanticGlobalKey + -> Map.Map Raw.StructSymbol ObjectId + -> Elaborate (CanonicalTerm ObjectId) +resolveContextualExpansionArgument location key requirements = do + contextual <- State.gets elaborationContextualBinder + case contextual of + Just index -> do + traverse_ + (uncurry (recordContextualRequirement location)) + (Map.toAscList requirements) + pure (CBound index) + Nothing -> do + structures <- State.gets elaborationStructures + case + [ CBound index + | (index, structure) <- Map.toAscList structures + , all + (\(symbol, object) -> + structureAnnotationOperation symbol structure + == Just object) + (Map.toAscList requirements) + ] of + firstMatch : _ -> pure firstMatch + [] -> + Except.throwError + (ExactContextualExpansionNotAvailable location key) + +applyExpandedTyped + :: Location + -> CanonicalTerm ObjectId + -> CoreType + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyExpandedTyped location body coreType arguments = + foldM step (body, coreType) arguments + where + step (current, currentType) (argument, argumentType) = + case currentType of + TyArrow expected result + | expected == argumentType -> + pure + ( case current of + CLam binderType lambdaBody + | binderType == expected -> + instantiateCanonical + argument lambdaBody + _ -> CApp current argument + , result + ) + | otherwise -> + Except.throwError + (ExactApplicationArgumentMismatch + location expected argumentType) + actual -> + Except.throwError + (ExactApplicationExpectedFunction location actual) + +applyTyped + :: Location + -> CanonicalTerm ObjectId + -> CoreType + -> [(CanonicalTerm ObjectId, CoreType)] + -> Elaborate (CanonicalTerm ObjectId, CoreType) +applyTyped location function functionType arguments = + foldM step (function, functionType) arguments + where + step (currentFunction, currentType) (argument, argumentType) = + case currentType of + TyArrow expected result + | expected == argumentType -> + pure (CApp currentFunction argument, result) + | otherwise -> + Except.throwError + (ExactApplicationArgumentMismatch + location expected argumentType) + actual -> + Except.throwError + (ExactApplicationExpectedFunction location actual) + +logicalNot :: CanonicalTerm global -> CanonicalTerm global +logicalNot proposition = + CImp proposition CFalsum + +ensureExpressionKey + :: MonadError ExactCompileError monad + => Location + -> Raw.FunctionSymbol + -> SemanticGlobalKey + -> monad () +ensureExpressionKey location symbol key = + unless + (key == SemanticExpressionFunction (Raw.mixfixPattern symbol)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureAdjectiveKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItem + -> SemanticGlobalKey + -> monad () +ensureAdjectiveKey location item key = + unless + ( key == SemanticLeftAdjective (Raw.lexicalItemPattern item) + || key == SemanticRightAdjective (Raw.lexicalItemPattern item) + ) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureFunctionPhraseKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureFunctionPhraseKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureNounKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureNounKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticNoun (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureVerbKey + :: MonadError ExactCompileError monad + => Location + -> Raw.LexicalItemSgPl + -> SemanticGlobalKey + -> monad () +ensureVerbKey location item key = + let patterns = Raw.lexicalItemSgPlPattern item + in unless + (key == SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) + (throwError (ExactDeclarationHeadMismatch location)) + +ensureRelationKey + :: MonadError ExactCompileError monad + => Location + -> Raw.RelationSymbol + -> SemanticGlobalKey + -> monad () +ensureRelationKey location relation key = + unless + ( key + == SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + ) + (throwError (ExactDeclarationHeadMismatch location)) + +exactSetNounPhrase :: Raw.NounPhrase Maybe -> Bool +exactSetNounPhrase = \case + Raw.NounPhrase + [] + (Raw.Noun _ item []) + Nothing + [] + Nothing -> + Lexicon.isBuiltinSetNoun item + _ -> False + +encodePreparedSyntax + :: ExactDeclarationFamily + -> PreparedHead + -> PreparedBody + -> Maybe SemanticName + -> ByteString +encodePreparedSyntax + family (PreparedHead key _parameters coreType) body alias = + encodeCache do + putCacheTag case family of + ExactSignature -> 0x00 + ExactAbbreviation -> 0x01 + ExactDefinition -> 0x02 + putSemanticGlobalKeyCache key + putCoreTypeCache coreType + case body of + OpaqueBody -> putCacheTag 0x00 + TransparentBody canonical _construction -> do + putCacheTag 0x01 + putCanonicalTermCache putObjectIdCache canonical + ContextualTransparentBody requirements canonical -> do + putCacheTag 0x02 + putCanonicalCacheMap + (\(Raw.StructSymbol symbol) -> putCacheText symbol) + putObjectIdCache + requirements + putCanonicalTermCache putObjectIdCache canonical + putCacheMaybe + (putCacheText . semanticNameText) + alias + +encodePreparedSourceAxiom + :: ScopedCheckedCore ObjectId + -> SemanticName + -> ByteString +encodePreparedSourceAxiom proposition alias = + encodeCache do + putCacheTag 0x03 + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm proposition) + putCacheText (semanticNameText alias) + +definitionAlias :: Raw.Block -> Maybe SemanticName +definitionAlias = \case + Raw.BlockDefn _location _title (Raw.Marker marker) _definition -> + Just (semanticName marker) + _ -> Nothing + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _seen [] = Nothing + go seen (value : rest) + | value `Set.member` seen = Just value + | otherwise = go (Set.insert value seen) rest diff --git a/source/Felix/Checking/Exact/Datatype.hs b/source/Felix/Checking/Exact/Datatype.hs new file mode 100644 index 0000000..be943cd --- /dev/null +++ b/source/Felix/Checking/Exact/Datatype.hs @@ -0,0 +1,751 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact preparation of deterministic datatype declarations. +module Felix.Checking.Exact.Datatype + ( PreparedExactDatatype + , preparedExactDatatypeObjects + , preparedExactDatatypeBindings + , PreparedExactDatatypeFact + , preparedExactDatatypeFacts + , preparedExactDatatypeFactMarker + , preparedExactDatatypeFactTarget + , preparedExactDatatypeFactReference + , preparedExactDatatypeDescriptor + , prepareExactDatatype + , CheckedExactDatatypeAuthorization + , lowerPreparedExactDatatype + , authorizeCheckedExactDatatype + , ExactDatatypeError(..) + , exactDatatypeErrorLocation + , renderExactDatatypeError + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Datatype qualified as Datatype +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Cache.Codec +import Felix.Module +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (unless, when) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Numeric.Natural (Natural) + + +data PreparedDatatypeObject = PreparedDatatypeObject + !Internal.Symbol + !SemanticGlobalKey + !CoreType + !ObjectId + !AssertedObject + +data PreparedExactDatatypeFact = PreparedExactDatatypeFact + !Internal.Marker + !(FrozenCheckedCore ObjectId) + !TheoremRef + +preparedExactDatatypeFactMarker + :: PreparedExactDatatypeFact + -> Internal.Marker +preparedExactDatatypeFactMarker + (PreparedExactDatatypeFact marker _target _reference) = + marker + +preparedExactDatatypeFactTarget + :: PreparedExactDatatypeFact + -> FrozenCheckedCore ObjectId +preparedExactDatatypeFactTarget + (PreparedExactDatatypeFact _marker target _reference) = + target + +preparedExactDatatypeFactReference + :: PreparedExactDatatypeFact + -> TheoremRef +preparedExactDatatypeFactReference + (PreparedExactDatatypeFact _marker _target reference) = + reference + +data PreparedExactDatatype = PreparedExactDatatype + !Location + !DeclarationSyntaxId + !(NonEmpty PreparedDatatypeObject) + !(NonEmpty PreparedExactDatatypeFact) + !DatatypeCompilationDescriptor + +data CheckedExactDatatypeAuthorization = + CheckedExactDatatypeAuthorization + !DatatypeCompilationDescriptor + !ObjectId + !(NonEmpty ObjectId) + +preparedExactDatatypeObjects + :: PreparedExactDatatype + -> NonEmpty (ObjectId, CoreType) +preparedExactDatatypeObjects + (PreparedExactDatatype _location _syntax objects _facts _descriptor) = + fmap + (\(PreparedDatatypeObject _symbol _key coreType identity _asserted) -> + (identity, coreType)) + objects + +preparedExactDatatypeBindings + :: PreparedExactDatatype + -> NonEmpty (SemanticGlobalKey, SemanticGlobalTarget) +preparedExactDatatypeBindings + (PreparedExactDatatype _location _syntax objects _facts _descriptor) = + fmap + (\(PreparedDatatypeObject _symbol key _coreType identity _asserted) -> + (key, GlobalReference identity)) + objects + +preparedExactDatatypeFacts + :: PreparedExactDatatype + -> NonEmpty PreparedExactDatatypeFact +preparedExactDatatypeFacts + (PreparedExactDatatype _location _syntax _objects facts _descriptor) = + facts + +preparedExactDatatypeDescriptor + :: PreparedExactDatatype + -> DatatypeCompilationDescriptor +preparedExactDatatypeDescriptor + (PreparedExactDatatype _location _syntax _objects _facts descriptor) = + descriptor + +lowerPreparedExactDatatype + :: PreparedExactDatatype + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactDatatypeAuthorization)) +lowerPreparedExactDatatype + (PreparedExactDatatype _location syntax objects facts descriptor) = + do + prepared <- + traverse + (\(PreparedExactDatatypeFact marker target _reference) -> + Declaration.prepareFrozenCandidateSpecLowering + assertedObjects + target + SearchEligible + [markerAlias marker]) + facts + pure (buildChecked <$> sequence prepared) + where + assertedObjects = + toList + (fmap + (\(PreparedDatatypeObject + _symbol _key _coreType _identity asserted) -> asserted) + objects) + bindings = + toList + (fmap + (\(PreparedDatatypeObject + _symbol key _coreType identity _asserted) -> + semanticGlobalBinding key (GlobalReference identity)) + objects) + carrier :| constructors = fmap objectIdentity objects + constructorIds = + case constructors of + firstConstructor : remainingConstructors -> + firstConstructor :| remainingConstructors + [] -> impossible "a prepared datatype has no constructor" + buildChecked specs = + Declaration.checkedCompiledDeclaration + syntax + assertedObjects + [] + bindings + [] + [ fmap + (\spec -> + Declaration.checkedCandidate + spec + (Declaration.checkedDatatypePlanning descriptor)) + specs + ] + (CheckedExactDatatypeAuthorization + descriptor carrier constructorIds) + + markerAlias (Internal.Marker name) = semanticName name + + objectIdentity + (PreparedDatatypeObject + _symbol _key _coreType identity _asserted) = + identity + +authorizeCheckedExactDatatype + :: CheckedExactDatatypeAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactDatatype + (CheckedExactDatatypeAuthorization descriptor carrier constructors) = + \case + [candidates] -> + Declaration.authorizeDatatypeCompilationCandidates + descriptor carrier constructors candidates + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +data ExactDatatypeError + = ExactDatatypeUnsupportedBlock !Location + | ExactDatatypeOccurrenceCountMismatch !Location !Int !Int + | ExactDatatypeOccurrenceMismatch !Location + | ExactDatatypeGlossFailed !Location !Meaning.GlossError + | ExactDatatypeInvalid !Location !Text + | ExactDatatypeDuplicateGlobal !Location !SemanticGlobalKey + | ExactDatatypeFixedSemanticCollision !Location !SemanticGlobalKey + | ExactDatatypeGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactDatatypeObjectAlreadyAvailable !Location !ObjectId + | ExactDatatypeGlobalResolutionFailed + !Location + !ExactGlobal.ExactGlobalResolutionError + | ExactDatatypeLoweringFailed !Location !Typed.TypedInductiveError + | ExactDatatypeExpectedSet !Location !CoreType + | ExactDatatypeExpectedProposition !Location !CoreType + deriving stock (Show, Eq) + +exactDatatypeErrorLocation :: ExactDatatypeError -> Location +exactDatatypeErrorLocation = \case + ExactDatatypeUnsupportedBlock location -> location + ExactDatatypeOccurrenceCountMismatch location _expected _actual -> location + ExactDatatypeOccurrenceMismatch location -> location + ExactDatatypeGlossFailed location _failure -> location + ExactDatatypeInvalid location _message -> location + ExactDatatypeDuplicateGlobal location _key -> location + ExactDatatypeFixedSemanticCollision location _key -> location + ExactDatatypeGlobalAlreadyVisible location _key -> location + ExactDatatypeObjectAlreadyAvailable location _identity -> location + ExactDatatypeGlobalResolutionFailed location _failure -> location + ExactDatatypeLoweringFailed location _failure -> location + ExactDatatypeExpectedSet location _actual -> location + ExactDatatypeExpectedProposition location _actual -> location + +renderExactDatatypeError :: ExactDatatypeError -> Text +renderExactDatatypeError failure = + locationToText (exactDatatypeErrorLocation failure) + <> ": " + <> case failure of + ExactDatatypeUnsupportedBlock{} -> + "this datatype source form is not supported by the typed checker" + ExactDatatypeOccurrenceCountMismatch _location expected actual -> + "the datatype has " <> shown actual + <> " syntax occurrences, but " <> shown expected + <> " are required" + ExactDatatypeOccurrenceMismatch{} -> + "a datatype syntax occurrence does not match its declaration" + ExactDatatypeGlossFailed _location glossFailure -> + "datatype elaboration failed: " <> shown glossFailure + ExactDatatypeInvalid _location message -> + "invalid datatype declaration: " <> message + ExactDatatypeDuplicateGlobal _location key -> + "the datatype declares the semantic key more than once: " + <> shown key + ExactDatatypeFixedSemanticCollision _location key -> + "the datatype collides with fixed semantics for " <> shown key + ExactDatatypeGlobalAlreadyVisible _location key -> + "the datatype global is already visible: " <> shown key + ExactDatatypeObjectAlreadyAvailable _location identity -> + "the datatype opaque object is already available: " + <> shown identity + ExactDatatypeGlobalResolutionFailed _location resolution -> + "datatype global resolution failed: " <> shown resolution + ExactDatatypeLoweringFailed _location typedFailure -> + "typed datatype lowering failed: " <> shown typedFailure + ExactDatatypeExpectedSet _location actual -> + "a datatype premise domain has type " <> shown actual + <> " instead of Set" + ExactDatatypeExpectedProposition _location actual -> + "a generated datatype fact has type " <> shown actual + <> " instead of Prop" + where + shown :: Show value => value -> Text + shown = Text.pack . show + +type Prepare = + ExceptT ExactDatatypeError (Declaration.LoweringDriver) + +type SourceOccurrence = (Location, Raw.Marker, CanonicalLexicalEntry) + +exactDatatypeInvalid + :: Location + -> Datatype.DatatypeValidationError + -> ExactDatatypeError +exactDatatypeInvalid declarationLocation failure = + ExactDatatypeInvalid + (fromMaybe + declarationLocation + (Datatype.datatypeValidationErrorLocation failure)) + (Datatype.renderDatatypeValidationError failure) + +prepareExactDatatype + :: Raw.Block + -> [SourceOccurrence] + -> Declaration.LoweringDriver + (Either ExactDatatypeError PreparedExactDatatype) +prepareExactDatatype block occurrences = + Except.runExceptT do + (location, marker, rawDatatype) <- + case block of + Raw.BlockData blockLocation _title blockMarker datatype -> + pure (blockLocation, blockMarker, datatype) + _ -> + Except.throwError + (ExactDatatypeUnsupportedBlock (locate block)) + keys <- validateOccurrences location marker rawDatatype occurrences + internal <- + case Meaning.meaning [block] of + Right + [Internal.BlockData + _internalLocation _internalMarker datatype] -> + pure datatype + Left failure -> + Except.throwError + (ExactDatatypeGlossFailed location failure) + Right _ -> + Except.throwError + (ExactDatatypeUnsupportedBlock location) + checked <- + -- The new opaque carrier has no semantic binding while its + -- declaration is prepared, so premise recursion cannot depend on + -- abbreviation expansion. Revisit this if forward aliases become + -- available. + Except.lift + (Datatype.prepareCheckedDatatype pure internal) + >>= Except.liftEither + . first (exactDatatypeInvalid location) + let symbols = + Datatype.checkedDatatypeHeadSymbol checked + :| toList + (Datatype.checkedDatatypeConstructorSymbols checked) + views = Datatype.checkedDatatypeClauseViews checked + arities = + 0 :| (length + . Datatype.checkedDatatypeClauseViewArguments + <$> toList views) + unless (NonEmpty.length symbols == NonEmpty.length keys) + (Except.throwError + (ExactDatatypeOccurrenceCountMismatch + location + (NonEmpty.length symbols) + (NonEmpty.length keys))) + validateKeys occurrences keys + slot <- Except.lift Declaration.nextDeclarationSlotLowering + theory <- Except.lift Declaration.currentTheoryLowering + objects <- + sequence + (NonEmpty.zipWith + (\index (occurrenceLocation, symbol, key, arity) -> + prepareObject + occurrenceLocation + slot theory index symbol key arity) + (0 :| [1 ..]) + (NonEmpty.zipWith + (\occurrenceLocation (symbol, key, arity) -> + (occurrenceLocation, symbol, key, arity)) + (validatedOccurrenceLocations occurrences) + (NonEmpty.zipWith + (\(symbol, key) arity -> + (symbol, key, arity)) + (NonEmpty.zip symbols keys) + arities))) + let ownedSymbols = Set.fromList (toList symbols) + generated = Datatype.checkedDatatypeGeneratedFacts checked + externalSymbols = + (foldMap + (Internal.mentionedSymbols . snd) + generated + <> foldMap premiseSymbols views) + `Set.difference` ownedSymbols + external <- + Except.lift + (ExactGlobal.resolveExactSourceGlobals externalSymbols) + >>= Except.liftEither + . first (ExactDatatypeGlobalResolutionFailed location) + let (externalGlobals, externalTypes) = external + ownedGlobals = + Map.fromList + [ (symbol, Typed.SourceGlobal identity Nothing) + | PreparedDatatypeObject + symbol _key _coreType identity _asserted <- + toList objects + ] + ownedTypes = + Map.fromList + [ (identity, coreType) + | PreparedDatatypeObject + _symbol _key coreType identity _asserted <- + toList objects + ] + sourceGlobals = Map.union ownedGlobals externalGlobals + globalTypes = Map.union ownedTypes externalTypes + resolveGlobal = (`Map.lookup` sourceGlobals) + globalType identity = + fromMaybe + (impossible + "prepared datatype global has no checked type") + (Map.lookup identity globalTypes) + preparedClauses <- + Except.liftEither + (traverse + (prepareClause location globalType resolveGlobal) + views) + facts <- + Except.liftEither + (traverse + (prepareFact location theory globalType resolveGlobal) + generated) + let carrier = objectIdentity (NonEmpty.head objects) + constructors = objectIdentity <$> NonEmpty.tail objects + descriptor = + case NonEmpty.nonEmpty constructors of + Nothing -> + impossible + "a checked datatype has no constructors" + Just nonemptyConstructors -> + datatypeCompilationDescriptor + carrier + nonemptyConstructors + (preparedExactDatatypeFactReference + <$> toList facts) + syntax = + declarationSyntaxId + (encodePreparedDatatype + objects + preparedClauses + facts + descriptor) + pure + (PreparedExactDatatype + location + syntax + objects + facts + descriptor) + where + objectIdentity + (PreparedDatatypeObject _symbol _key _coreType identity _asserted) = + identity + +validateOccurrences + :: Location + -> Raw.Marker + -> Raw.Datatype + -> [SourceOccurrence] + -> Prepare (NonEmpty SemanticGlobalKey) +validateOccurrences location marker datatype occurrences = do + expected <- + Except.liftEither + (expectedOccurrences location marker datatype) + unless (length occurrences == NonEmpty.length expected) + (Except.throwError + (ExactDatatypeOccurrenceCountMismatch + location + (NonEmpty.length expected) + (length occurrences))) + keys <- + sequence + (NonEmpty.zipWith validateOne expected + (case NonEmpty.nonEmpty occurrences of + Just nonempty -> nonempty + Nothing -> + impossible + "equal nonzero occurrence counts became empty")) + pure keys + where + validateOne + (expectedLocation, expectedMarker, expectedPattern) + (actualLocation, actualMarker, entry) = + case entry of + CanonicalExpressionFunction pat marker' _fixity + | actualMarker == expectedMarker + , marker' == expectedMarker + , pat == expectedPattern -> + pure + (SemanticExpressionFunction pat) + _ -> + Except.throwError + (ExactDatatypeOccurrenceMismatch + (bestLocation actualLocation expectedLocation)) + + bestLocation actual expected + | actual == Nowhere = expected + | otherwise = actual + +expectedOccurrences + :: Location + -> Raw.Marker + -> Raw.Datatype + -> Either + ExactDatatypeError + (NonEmpty (Location, Raw.Marker, Raw.Pattern)) +expectedOccurrences location blockMarker datatype = do + headOccurrence <- + expectedSymbol blockMarker (Raw.datatypeHeadExpr datatype) + clauses <- + traverse + (\clause -> + case Raw.datatypeClauseConstructorExpr clause of + Raw.ExprOp constructorLocation symbol _arguments -> + Right + ( constructorLocation + , Raw.mixfixMarker symbol + , Raw.mixfixPattern symbol + ) + expression -> + Left + (ExactDatatypeOccurrenceMismatch + (locate expression))) + (Raw.datatypeClauses datatype) + pure (headOccurrence :| toList clauses) + where + expectedSymbol expectedMarker = \case + Raw.ExprOp symbolLocation symbol [] -> + Right + ( symbolLocation + , expectedMarker + , Raw.mixfixPattern symbol + ) + expression -> + Left + (ExactDatatypeOccurrenceMismatch + (case locate expression of + Nowhere -> location + expressionLocation -> expressionLocation)) + +validateKeys + :: [SourceOccurrence] + -> NonEmpty SemanticGlobalKey + -> Prepare () +validateKeys occurrences keys = do + case duplicateWithLocation of + Just (duplicate, duplicateLocation) -> + Except.throwError + (ExactDatatypeDuplicateGlobal + duplicateLocation + duplicate) + Nothing -> pure () + traverse_ validateOne (NonEmpty.zip locations keys) + where + locations = validatedOccurrenceLocations occurrences + + duplicateWithLocation = + go Set.empty + [ (key, occurrenceLocation) + | (key, (occurrenceLocation, _marker, _entry)) <- + zip (toList keys) occurrences + ] + + go _seen [] = Nothing + go seen ((key, occurrenceLocation) : remaining) + | key `Set.member` seen = Just (key, occurrenceLocation) + | otherwise = go (Set.insert key seen) remaining + + validateOne (occurrenceLocation, key) = do + when (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactDatatypeFixedSemanticCollision occurrenceLocation key)) + visible <- + Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when (isJust visible) + (Except.throwError + (ExactDatatypeGlobalAlreadyVisible occurrenceLocation key)) + +validatedOccurrenceLocations + :: [SourceOccurrence] + -> NonEmpty Location +validatedOccurrenceLocations occurrences = + case NonEmpty.nonEmpty + [ occurrenceLocation + | (occurrenceLocation, _marker, _entry) <- occurrences + ] of + Just nonempty -> nonempty + Nothing -> + impossible "validated datatype occurrences are empty" + +prepareObject + :: Location + -> DeclarationSlot + -> TheoryId + -> Natural + -> Internal.Symbol + -> SemanticGlobalKey + -> Int + -> Prepare PreparedDatatypeObject +prepareObject location slot theory index symbol key arity = do + let coreType = + foldr (const (TyArrow TySet)) TySet [1 .. arity] + seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + DatatypeDeclaration + (generatedObjectSlot index) + content = OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + available <- Except.lift (Declaration.objectAvailableLowering identity) + when available + (Except.throwError + (ExactDatatypeObjectAlreadyAvailable location identity)) + pure + (PreparedDatatypeObject + symbol + key + coreType + identity + (assertedObject identity content)) + +data PreparedClause = PreparedClause + !Internal.FunctionSymbol + ![PreparedPremise] + +data PreparedPremise + = PreparedRecursivePremise !(FrozenCheckedCore ObjectId) + | PreparedNonRecursivePremise !(FrozenCheckedCore ObjectId) + +prepareClause + :: Location + -> (ObjectId -> CoreType) + -> (Internal.Symbol -> Maybe (Typed.SourceGlobal ObjectId)) + -> Datatype.CheckedDatatypeClauseView + -> Either ExactDatatypeError PreparedClause +prepareClause location globalType resolveGlobal view = + PreparedClause + (Datatype.checkedDatatypeClauseViewConstructor view) + <$> traverse preparePremise + (Datatype.checkedDatatypeClauseViewPremises view) + where + preparePremise = \case + Datatype.CheckedRecursiveDatatypePremise _variable domain -> + PreparedRecursivePremise + <$> prepareDomain domain + Datatype.CheckedNonRecursiveDatatypePremise _variable domain -> + PreparedNonRecursivePremise + <$> prepareDomain domain + + prepareDomain domain = do + checked <- + first (ExactDatatypeLoweringFailed location) + (Typed.prepareTypedClosedTerm + globalType + resolveGlobal + domain) + unless (frozenCoreType checked == TySet) + (Left + (ExactDatatypeExpectedSet + location + (frozenCoreType checked))) + pure checked + +prepareFact + :: Location + -> TheoryId + -> (ObjectId -> CoreType) + -> (Internal.Symbol -> Maybe (Typed.SourceGlobal ObjectId)) + -> (Internal.Marker, Internal.Formula) + -> Either ExactDatatypeError PreparedExactDatatypeFact +prepareFact location theory globalType resolveGlobal (marker, formula) = do + checked <- + first (ExactDatatypeLoweringFailed location) + (Typed.prepareTypedClosedFormula + globalType + resolveGlobal + formula) + unless (frozenCoreType checked == TyProp) + (Left + (ExactDatatypeExpectedProposition + location + (frozenCoreType checked))) + pure + (PreparedExactDatatypeFact + marker + checked + (theoremRef theory + (propositionIdOf (frozenCoreTerm checked)))) + +premiseSymbols + :: Datatype.CheckedDatatypeClauseView + -> Set.Set Internal.Symbol +premiseSymbols view = + foldMap symbols + (Datatype.checkedDatatypeClauseViewPremises view) + where + symbols = \case + Datatype.CheckedRecursiveDatatypePremise _variable domain -> + Internal.mentionedSymbols domain + Datatype.CheckedNonRecursiveDatatypePremise _variable domain -> + Internal.mentionedSymbols domain + +encodePreparedDatatype + :: NonEmpty PreparedDatatypeObject + -> NonEmpty PreparedClause + -> NonEmpty PreparedExactDatatypeFact + -> DatatypeCompilationDescriptor + -> ByteString +encodePreparedDatatype objects clauses facts descriptor = + encodeCache do + putCacheTag 0x05 + putCacheList putObject (toList objects) + putCacheList putClause (toList clauses) + putCacheList putFact (toList facts) + putDirectAuthorizationCache + (TrustedCompilation + (DatatypeCompilation descriptor)) + where + putObject + (PreparedDatatypeObject + _symbol key coreType identity _asserted) = do + putSemanticGlobalKeyCache key + putCoreTypeCache coreType + putObjectIdCache identity + + putClause (PreparedClause constructor premises) = do + putSemanticGlobalKeyCache + (SemanticExpressionFunction + (Raw.mixfixPattern constructor)) + putCacheList putPremise premises + + putPremise = \case + PreparedRecursivePremise domain -> do + putCacheTag 0x00 + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm domain) + PreparedNonRecursivePremise domain -> do + putCacheTag 0x01 + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm domain) + + putFact fact = do + let Internal.Marker marker = + preparedExactDatatypeFactMarker fact + putCacheText marker + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (preparedExactDatatypeFactTarget fact)) + putTheoremRefCache + (preparedExactDatatypeFactReference fact) diff --git a/source/Felix/Checking/Exact/Global.hs b/source/Felix/Checking/Exact/Global.hs new file mode 100644 index 0000000..d4040e6 --- /dev/null +++ b/source/Felix/Checking/Exact/Global.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact resolution of source symbols to checked semantic globals. +module Felix.Checking.Exact.Global + ( ExactGlobalResolutionError(..) + , resolveExactSourceGlobals + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (foldM) +import Control.Monad.Except + ( liftEither + , runExceptT + , throwError + ) +import Control.Monad.Trans.Class (lift) +import Data.Bifunctor (first) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set + + +data ExactGlobalResolutionError + = ExactGlobalNotVisible !Internal.Symbol + | ExactGlobalAmbiguous !Internal.Symbol + | ExactGlobalUnsupported !Internal.Symbol + | ExactGlobalContextualUnsupported !Internal.Symbol + | ExactGlobalContentInvalid !CoreCheckError + deriving stock (Show, Eq) + +resolveExactSourceGlobals + :: Set.Set Internal.Symbol + -> Declaration.LoweringDriver + (Either + ExactGlobalResolutionError + ( Map.Map + Internal.Symbol + (Typed.SourceGlobal ObjectId) + , Map.Map ObjectId CoreType + )) +resolveExactSourceGlobals symbols = + runExceptT + (foldM resolve (Map.empty, Map.empty) + (Set.toAscList symbols)) + where + resolve (resolved, types) symbol = + case classifyExactSymbol symbol of + ExactClosedLiteral -> + pure (resolved, types) + ExactFixedPrimitive _meaning -> + pure (resolved, types) + ExactUnsupportedSymbol -> + throwError (ExactGlobalUnsupported symbol) + ExactSourceGlobal keys -> do + matches <- + catMaybes + <$> traverse + (lift + . Declaration.resolveVisibleGlobalContentLowering) + (toList keys) + case matches of + [] -> + throwError (ExactGlobalNotVisible symbol) + [match] -> do + (source, sourceTypes) <- + liftEither (prepareSourceGlobal symbol match) + pure + ( Map.insert symbol source resolved + , Map.union sourceTypes types + ) + _ -> + throwError (ExactGlobalAmbiguous symbol) + +prepareSourceGlobal + :: Internal.Symbol + -> ( SemanticGlobalTarget + , ObjectContent + , Map.Map ObjectId CoreType + ) + -> Either + ExactGlobalResolutionError + (Typed.SourceGlobal ObjectId, Map.Map ObjectId CoreType) +prepareSourceGlobal symbol (target, content, dependencies) = do + body <- + case target of + GlobalReference _identity -> + Right Nothing + TransparentExpansion _identity -> + case content of + TransparentObjectContent _theory _coreType canonical -> + Just + <$> first ExactGlobalContentInvalid + (checkCanonicalCore + (`Map.lookup` dependencies) + canonical) + _ -> + impossible + "validated transparent expansion has opaque content" + ContextualTransparentExpansion _identity _requirements -> + Left (ExactGlobalContextualUnsupported symbol) + let identity = semanticGlobalTargetObject target + types = + Map.insert + identity + (objectContentType content) + dependencies + pure (Typed.SourceGlobal identity body, types) diff --git a/source/Felix/Checking/Exact/Inductive.hs b/source/Felix/Checking/Exact/Inductive.hs new file mode 100644 index 0000000..5817b34 --- /dev/null +++ b/source/Felix/Checking/Exact/Inductive.hs @@ -0,0 +1,838 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact preparation and atomic publication of direct set inductives. +module Felix.Checking.Exact.Inductive + ( PreparedExactInductive + , preparedExactInductiveCarrierId + , preparedExactInductiveCarrierType + , preparedExactInductiveCarrierBody + , preparedExactInductiveGuardTargets + , preparedExactInductiveFacts + , prepareExactInductive + , CheckedExactInductiveAuthorization + , lowerPreparedExactInductive + , authorizeCheckedExactInductive + , ExactInductiveError(..) + , exactInductiveErrorLocation + , renderExactInductiveError + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Cache.Codec +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal + +import Control.Monad (unless, when) +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector qualified as Vector + + +data PreparedExactInductive = PreparedExactInductive + !Location + !SemanticGlobalKey + !ObjectId + !(Maybe AssertedObject) + !SemanticName + !DeclarationSyntaxId + !(Typed.PreparedTypedInductive ObjectId) + ![SemanticFactOccurrenceFingerprint] + +data CheckedExactInductiveAuthorization = + CheckedExactInductiveAuthorization + !ObjectId + !(Typed.PreparedTypedInductive ObjectId) + ![SemanticFactOccurrenceFingerprint] + ![(Location, Declaration.PreparedVampireObligation Void ())] + +preparedExactInductiveCarrierId + :: PreparedExactInductive + -> ObjectId +preparedExactInductiveCarrierId + (PreparedExactInductive + _location _key identity _asserted _alias _syntax _typed _guards) = + identity + +preparedExactInductiveCarrierType + :: PreparedExactInductive + -> CoreType +preparedExactInductiveCarrierType + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveCarrierType typed + +preparedExactInductiveCarrierBody + :: PreparedExactInductive + -> FrozenCheckedCore ObjectId +preparedExactInductiveCarrierBody + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveCarrierBody typed + +preparedExactInductiveGuardTargets + :: PreparedExactInductive + -> Vector.Vector (FrozenCheckedCore ObjectId) +preparedExactInductiveGuardTargets + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveGuardTargets typed + +preparedExactInductiveFacts + :: PreparedExactInductive + -> NonEmpty (Typed.PreparedTypedInductiveFact ObjectId) +preparedExactInductiveFacts + (PreparedExactInductive + _location _key _identity _asserted _alias _syntax typed _guards) = + Typed.typedInductiveFacts typed + +data ExactInductiveError + = ExactInductiveUnsupportedBlock !Location + | ExactInductiveOccurrenceMissing !Location + | ExactInductiveOccurrenceAmbiguous !Location + | ExactInductiveHeadMismatch !Location + | ExactInductiveGlossFailed !Location !Meaning.GlossError + | ExactInductiveDuplicateParameter !Location !Internal.VarSymbol + | ExactInductiveDomainFreeVariable !Location !Internal.VarSymbol + | ExactInductiveDomainMentionsCarrier !Location + | ExactInductiveResultShape !Location + | ExactInductiveResultMentionsCarrier !Location + | ExactInductiveRecursiveTermMentionsCarrier !Location + | ExactInductiveRecursiveCarrierWrongArguments !Location + | ExactInductiveRecursiveCarrierOutsideMembership !Location + | ExactInductiveUnsupportedRecursiveCarrierContext !Location + | ExactInductiveFixedSemanticCollision !Location !SemanticGlobalKey + | ExactInductiveGlobalAlreadyVisible !Location !SemanticGlobalKey + | ExactInductiveGlobalNotVisible !Location !Internal.Symbol + | ExactInductiveGlobalAmbiguous !Location !Internal.Symbol + | ExactInductiveUnsupportedSymbol !Location !Internal.Symbol + | ExactInductiveGlobalContentInvalid !Location !CoreCheckError + | ExactInductivePreparationFailed + !Location + !Typed.TypedInductiveError + | ExactInductiveGuardMissing !Location + | ExactInductiveGuardAmbiguous !Location + deriving stock (Show, Eq) + +exactInductiveErrorLocation :: ExactInductiveError -> Location +exactInductiveErrorLocation = \case + ExactInductiveUnsupportedBlock location -> location + ExactInductiveOccurrenceMissing location -> location + ExactInductiveOccurrenceAmbiguous location -> location + ExactInductiveHeadMismatch location -> location + ExactInductiveGlossFailed location _failure -> location + ExactInductiveDuplicateParameter location _parameter -> location + ExactInductiveDomainFreeVariable location _variable -> location + ExactInductiveDomainMentionsCarrier location -> location + ExactInductiveResultShape location -> location + ExactInductiveResultMentionsCarrier location -> location + ExactInductiveRecursiveTermMentionsCarrier location -> location + ExactInductiveRecursiveCarrierWrongArguments location -> location + ExactInductiveRecursiveCarrierOutsideMembership location -> location + ExactInductiveUnsupportedRecursiveCarrierContext location -> location + ExactInductiveFixedSemanticCollision location _key -> location + ExactInductiveGlobalAlreadyVisible location _key -> location + ExactInductiveGlobalNotVisible location _symbol -> location + ExactInductiveGlobalAmbiguous location _symbol -> location + ExactInductiveUnsupportedSymbol location _symbol -> location + ExactInductiveGlobalContentInvalid location _failure -> location + ExactInductivePreparationFailed location _failure -> location + ExactInductiveGuardMissing location -> location + ExactInductiveGuardAmbiguous location -> location + +renderExactInductiveError :: ExactInductiveError -> Text +renderExactInductiveError failure = + locationToText (exactInductiveErrorLocation failure) + <> ": " + <> case failure of + ExactInductiveUnsupportedBlock{} -> + "this inductive source form is not supported by the typed checker" + ExactInductiveOccurrenceMissing{} -> + "the inductive declaration has no associated syntax occurrence" + ExactInductiveOccurrenceAmbiguous{} -> + "the inductive declaration has more than one semantic head" + ExactInductiveHeadMismatch{} -> + "the inductive head does not match its syntax occurrence" + ExactInductiveGlossFailed _location glossFailure -> + "inductive elaboration failed: " <> shown glossFailure + ExactInductiveDuplicateParameter _location parameter -> + "the inductive parameter is repeated: " <> shown parameter + ExactInductiveDomainFreeVariable _location variable -> + "the inductive domain contains an unbound variable: " + <> shown variable + ExactInductiveDomainMentionsCarrier{} -> + "the inductive domain must be independent of its carrier" + ExactInductiveResultShape{} -> + "an inductive result must have the form t \\in F(args)" + ExactInductiveResultMentionsCarrier{} -> + "an inductive result term must not mention its carrier" + ExactInductiveRecursiveTermMentionsCarrier{} -> + "a recursive occurrence must be in the carrier of a membership premise" + ExactInductiveRecursiveCarrierWrongArguments{} -> + "the inductive carrier occurs with arguments other than its declared parameters" + ExactInductiveRecursiveCarrierOutsideMembership{} -> + "an inductive carrier occurrence must be in the set operand of a membership premise" + ExactInductiveUnsupportedRecursiveCarrierContext{} -> + "this recursive carrier context is outside the supported first-order set-term fragment" + ExactInductiveFixedSemanticCollision _location key -> + "the inductive carrier collides with fixed semantics for " + <> shown key + ExactInductiveGlobalAlreadyVisible _location key -> + "the inductive carrier is already visible: " <> shown key + ExactInductiveGlobalNotVisible _location symbol -> + "an inductive source symbol is not visible: " <> shown symbol + ExactInductiveGlobalAmbiguous _location symbol -> + "an inductive source symbol has more than one meaning: " + <> shown symbol + ExactInductiveUnsupportedSymbol _location symbol -> + "this inductive source symbol is not supported: " + <> shown symbol + ExactInductiveGlobalContentInvalid _location coreFailure -> + "an inductive global has invalid checked content: " + <> shown coreFailure + ExactInductivePreparationFailed _location typedFailure -> + "typed inductive preparation failed: " <> shown typedFailure + ExactInductiveGuardMissing{} -> + "an inductive domain guard has no visible authorized fact" + ExactInductiveGuardAmbiguous{} -> + "an inductive domain guard matches more than one visible fact" + where + shown :: Show value => value -> Text + shown = Text.pack . show + +type Prepare = + ExceptT + ExactInductiveError + (Declaration.LoweringDriver) + +prepareExactInductive + :: CheckedFoundation + -> Raw.Block + -> [CanonicalLexicalEntry] + -> Declaration.LoweringDriver + (Either ExactInductiveError PreparedExactInductive) +prepareExactInductive foundation block entries = + Except.runExceptT do + (location, marker, rawInductive) <- + case block of + Raw.BlockInductive blockLocation _title blockMarker inductive -> + pure (blockLocation, blockMarker, inductive) + _ -> + Except.throwError + (ExactInductiveUnsupportedBlock (locate block)) + key <- validateOccurrence location rawInductive entries + when + (isJust (fixedSemanticMeaning key)) + (Except.throwError + (ExactInductiveFixedSemanticCollision location key)) + visible <- + Except.lift + (Declaration.resolveVisibleGlobalLowering key) + when (isJust visible) + (Except.throwError + (ExactInductiveGlobalAlreadyVisible location key)) + internal <- + case Meaning.meaning [block] of + Right + [Internal.BlockInductive + _internalLocation _internalMarker inductive] -> + pure inductive + Left failure -> + Except.throwError + (ExactInductiveGlossFailed location failure) + Right _ -> + Except.throwError + (ExactInductiveUnsupportedBlock location) + direct <- + Except.liftEither + (normalizeDirectInductive internal) + (sourceGlobals, globalTypes) <- + resolveSourceGlobals location internal direct + typed <- + Except.liftEither + (first + (ExactInductivePreparationFailed location) + (Typed.prepareTypedInductive + (requireGlobalType globalTypes) + foundation + (`Map.lookup` sourceGlobals) + marker + direct)) + guards <- + traverse + (resolveGuard location) + (Vector.toList + (Typed.typedInductiveGuardTargets typed)) + theory <- Except.lift Declaration.currentTheoryLowering + let carrierType = Typed.typedInductiveCarrierType typed + carrierBody = Typed.typedInductiveCarrierBody typed + carrierTerm = frozenCoreTerm carrierBody + identity = + transparentObjectId theory carrierType carrierTerm + content = + TransparentObjectContent theory carrierType carrierTerm + alias = case marker of + Raw.Marker name -> semanticName name + available <- + Except.lift + (Declaration.objectAvailableLowering identity) + let asserted + | available = Nothing + | otherwise = Just (assertedObject identity content) + syntax = + declarationSyntaxId + (encodePreparedInductive key alias typed) + pure + (PreparedExactInductive + location + key + identity + asserted + alias + syntax + typed + guards) + where + requireGlobalType types identity = + fromMaybe + (impossible + "prepared inductive global has no checked type") + (Map.lookup identity types) + +validateOccurrence + :: Location + -> Raw.Inductive + -> [CanonicalLexicalEntry] + -> Prepare SemanticGlobalKey +validateOccurrence location rawInductive entries = do + entry <- + case entries of + [] -> + Except.throwError + (ExactInductiveOccurrenceMissing location) + [single] -> pure single + _ -> + Except.throwError + (ExactInductiveOccurrenceAmbiguous location) + key <- + maybe + (Except.throwError + (ExactInductiveHeadMismatch location)) + pure + (semanticGlobalKeyFromLexicalEntry entry) + let Raw.SymbolPattern headSymbol _parameters = + Raw.inductiveSymbolPattern rawInductive + expected = + SemanticExpressionFunction + (Raw.mixfixPattern headSymbol) + unless (key == expected) + (Except.throwError + (ExactInductiveHeadMismatch location)) + pure key + +normalizeDirectInductive + :: Internal.Inductive + -> Either ExactInductiveError Typed.DirectInductive +normalizeDirectInductive inductive = do + case firstDuplicate (Internal.inductiveParams inductive) of + Just duplicate -> + Left + (ExactInductiveDuplicateParameter + (locate duplicate) + duplicate) + Nothing -> pure () + let parameters = Internal.inductiveParams inductive + parameterSet = Set.fromList parameters + domain = Internal.inductiveDomain inductive + carrier = Internal.inductiveSymbol inductive + domainVariables = + orderedUnique + (toList domain) + case find (`Set.notMember` parameterSet) domainVariables of + Just variable -> + Left + (ExactInductiveDomainFreeVariable + (locate variable) + variable) + Nothing -> pure () + when + (Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols domain) + (Left + (ExactInductiveDomainMentionsCarrier + (termLocation domain))) + clauses <- + traverse + (normalizeClause carrier parameters) + (Internal.inductiveIntros inductive) + pure + (Typed.DirectInductive + parameters + domain + clauses) + +normalizeClause + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.IntroRule + -> Either ExactInductiveError Typed.DirectInductiveClause +normalizeClause carrier parameters rule = do + conditions <- + traverse + (normalizeCondition carrier parameters) + (Internal.introConditions rule) + result <- + normalizeResult + carrier + parameters + (Internal.introResult rule) + let parameterSet = Set.fromList parameters + variables = + List.filter (`Set.notMember` parameterSet) + (orderedUnique + ( concatMap toList + (Internal.introConditions rule) + <> toList result + )) + pure + (Typed.DirectInductiveClause + variables + conditions + result) + +normalizeResult + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Formula + -> Either ExactInductiveError Internal.Term +normalizeResult carrier parameters = \case + Internal.IsElementOf _location result target + | not (matchesCarrier carrier parameters target) -> + Left (ExactInductiveResultShape (termLocation target)) + | Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols result -> + Left + (ExactInductiveResultMentionsCarrier + (termLocation result)) + | otherwise -> + Right result + formula -> + Left (ExactInductiveResultShape (termLocation formula)) + +normalizeCondition + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Formula + -> Either ExactInductiveError Typed.DirectInductiveCondition +normalizeCondition carrier parameters formula + | not + (Internal.SymbolMixfix carrier + `Set.member` Internal.mentionedSymbols formula) = + Right (Typed.DirectSideCondition formula) + | otherwise = + case formula of + Internal.IsElementOf _location recursiveTerm recursiveCarrier + | Internal.SymbolMixfix carrier + `Set.member` + Internal.mentionedSymbols recursiveTerm -> + Left + (ExactInductiveRecursiveTermMentionsCarrier + (termLocation recursiveTerm)) + | otherwise -> do + context <- + first recursiveCarrierContextError + (Typed.prepareRecursiveCarrierContext + carrier parameters recursiveCarrier) + Right + (Typed.DirectRecursiveCondition + recursiveTerm context) + _ -> + Left + (ExactInductiveRecursiveCarrierOutsideMembership + (termLocation formula)) + +recursiveCarrierContextError + :: Typed.RecursiveCarrierContextError + -> ExactInductiveError +recursiveCarrierContextError = \case + Typed.RecursiveCarrierWrongArguments location -> + ExactInductiveRecursiveCarrierWrongArguments location + Typed.RecursiveCarrierUnsupportedContext location -> + ExactInductiveUnsupportedRecursiveCarrierContext location + +matchesCarrier + :: Internal.FunctionSymbol + -> [Internal.VarSymbol] + -> Internal.Term + -> Bool +matchesCarrier carrier parameters = \case + Internal.TermSymbol _location (Internal.SymbolMixfix actual) arguments -> + actual == carrier + && length arguments == length parameters + && and + (zipWith + (\argument parameter -> + argument == Internal.TermVar parameter) + arguments + parameters) + _ -> False + +resolveSourceGlobals + :: Location + -> Internal.Inductive + -> Typed.DirectInductive + -> Prepare + ( Map.Map + Internal.Symbol + (Typed.SourceGlobal ObjectId) + , Map.Map ObjectId CoreType + ) +resolveSourceGlobals location internal direct = + Except.lift + (ExactGlobal.resolveExactSourceGlobals symbols) + >>= Except.liftEither + . first (exactGlobalError location) + where + carrier = Internal.SymbolMixfix (Internal.inductiveSymbol internal) + symbols = + Set.delete carrier (directSymbols direct) + +exactGlobalError + :: Location + -> ExactGlobal.ExactGlobalResolutionError + -> ExactInductiveError +exactGlobalError location = \case + ExactGlobal.ExactGlobalNotVisible symbol -> + ExactInductiveGlobalNotVisible location symbol + ExactGlobal.ExactGlobalAmbiguous symbol -> + ExactInductiveGlobalAmbiguous location symbol + ExactGlobal.ExactGlobalUnsupported symbol -> + ExactInductiveUnsupportedSymbol location symbol + ExactGlobal.ExactGlobalContextualUnsupported symbol -> + ExactInductiveUnsupportedSymbol location symbol + ExactGlobal.ExactGlobalContentInvalid failure -> + ExactInductiveGlobalContentInvalid location failure + +resolveGuard + :: Location + -> FrozenCheckedCore ObjectId + -> Prepare SemanticFactOccurrenceFingerprint +resolveGuard location target = do + matches <- + Except.lift + (Declaration.resolveVisibleFactTargetsLowering target) + case matches of + [] -> + Except.throwError (ExactInductiveGuardMissing location) + [fingerprint] -> + pure fingerprint + _ -> + Except.throwError (ExactInductiveGuardAmbiguous location) + +directSymbols :: Typed.DirectInductive -> Set.Set Internal.Symbol +directSymbols direct = + Internal.mentionedSymbols (Typed.directInductiveDomain direct) + <> foldMap clauseSymbols + (Typed.directInductiveClauses direct) + where + clauseSymbols clause = + foldMap conditionSymbols + (Typed.directClauseConditions clause) + <> Internal.mentionedSymbols + (Typed.directClauseResult clause) + conditionSymbols = \case + Typed.DirectSideCondition formula -> + Internal.mentionedSymbols formula + Typed.DirectRecursiveCondition term context -> + Internal.mentionedSymbols term + <> Typed.recursiveCarrierContextSymbols context + +lowerPreparedExactInductive + :: PreparedExactInductive + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedExactInductiveAuthorization)) +lowerPreparedExactInductive + (PreparedExactInductive + _location key identity asserted alias syntax typed guards) = + do + let facts = Typed.typedInductiveFacts typed + monotonicities = + Vector.toList + (Typed.typedInductiveMonotonicities typed) + objects = maybeToList asserted + definition <- + Declaration.prepareDefinitionEquationSpecLowering + objects identity alias + preparedMonotonicities <- + traverse + (\monotonicity -> Except.runExceptT do + let factLocation = + Typed.typedInductiveMonotonicityLocation + monotonicity + target = + Typed.typedInductiveMonotonicityTarget + monotonicity + spec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects target SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + (embedClosedCore [] target) + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt + factLocation + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + pure + ( Declaration.checkedCandidate + spec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + []) + , (factLocation, obligation) + )) + monotonicities + preparedCandidates <- + traverse + (\fact -> do + prepared <- + Declaration.prepareCandidateSpecLowering + objects + (embedClosedCore [] + (Typed.typedInductiveFactTarget fact)) + SearchEligible + [markerAlias + (Typed.typedInductiveFactMarker fact)] + let descriptor = + GuardedFoundationRules + (guardedRuleSet + (Typed.typedInductiveFactRules fact)) + planning + | null monotonicities = + Declaration.checkedKernelPlanning + descriptor guards + | otherwise = + Declaration.checkedKernelPlanningWithStaged + descriptor + guards + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then + [ Declaration.plannedEarlierCandidate + 1 index + | (index, _target) <- + zip [0 ..] monotonicities + ] + else []) + pure + (fmap + (\spec -> + Declaration.checkedCandidate spec planning) + prepared)) + facts + pure do + definitionSpec <- definition + monotonicityCandidates <- sequence preparedMonotonicities + factCandidates <- sequence preparedCandidates + let stages + | null monotonicityCandidates = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| toList factCandidates + ] + | otherwise = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| [] + , NonEmpty.fromList (fst <$> monotonicityCandidates) + , factCandidates + ] + pure + (Declaration.checkedCompiledDeclaration + syntax + objects + [] + [semanticGlobalBinding key (GlobalReference identity)] + [] + stages + (CheckedExactInductiveAuthorization + identity typed guards + (snd <$> monotonicityCandidates))) + where + markerAlias (Raw.Marker name) = + semanticName name + +authorizeCheckedExactInductive + :: CheckedExactInductiveAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactInductive + (CheckedExactInductiveAuthorization + identity typed guards monotonicityObligations) = \case + [definitionCandidate :| candidates] -> do + unless (null monotonicityObligations) + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch 3 1)) + Declaration.authorizeDefinitionEquationCandidate + identity definitionCandidate + let facts = Typed.typedInductiveFacts typed + case NonEmpty.nonEmpty candidates of + Just factCandidates + | NonEmpty.length factCandidates == NonEmpty.length facts -> + sequence_ + (NonEmpty.zipWith + (authorizeFact []) + factCandidates + facts) + _ -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (1 + NonEmpty.length facts) + (1 + length candidates)) + [ definitionCandidate :| [] + , monotonicityCandidates + , factCandidates + ] + | NonEmpty.length monotonicityCandidates + == length monotonicityObligations + , NonEmpty.length factCandidates + == NonEmpty.length (Typed.typedInductiveFacts typed) -> do + obligations <- + maybe + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 0)) + pure + (NonEmpty.nonEmpty monotonicityObligations) + Declaration.authorizeDefinitionEquationCandidate + identity definitionCandidate + Declaration.authorizeVampireCandidateBatch + (NonEmpty.zipWith + (\candidate (factLocation, obligation) -> + (factLocation, candidate, pure obligation)) + monotonicityCandidates + obligations) + sequence_ + (NonEmpty.zipWith + (\candidate fact -> + authorizeFact + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then NonEmpty.toList monotonicityCandidates + else []) + candidate + fact) + factCandidates + (Typed.typedInductiveFacts typed)) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + (if null monotonicityObligations then 1 else 3) + (length stages)) + where + authorizeFact monotonicityCandidates candidate fact = + Declaration.authorizeKernelConstructionCandidate + (GuardedFoundationRules + (guardedRuleSet + (Typed.typedInductiveFactRules fact))) + candidate do + traverse_ Declaration.useAuthorizedFact guards + traverse_ + Declaration.useStagedCandidate + monotonicityCandidates + pure (Typed.typedInductiveFactDerivation fact) + + +encodePreparedInductive + :: SemanticGlobalKey + -> SemanticName + -> Typed.PreparedTypedInductive ObjectId + -> ByteString +encodePreparedInductive key alias typed = + encodeCache do + putCacheTag 0x04 + putSemanticGlobalKeyCache key + putCoreTypeCache + (Typed.typedInductiveCarrierType typed) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (Typed.typedInductiveCarrierBody typed)) + putCacheList putFrozenTerm + (Vector.toList + (Typed.typedInductiveContextInventory typed)) + putCacheList + (putFrozenTerm + . Typed.typedInductiveMonotonicityTarget) + (Vector.toList + (Typed.typedInductiveMonotonicities typed)) + putCacheText (semanticNameText alias) + putCacheList putFact + (toList (Typed.typedInductiveFacts typed)) + where + putFrozenTerm = + putCanonicalTermCache putObjectIdCache . frozenCoreTerm + + putFact fact = do + let Raw.Marker marker = + Typed.typedInductiveFactMarker fact + putCacheText marker + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm + (Typed.typedInductiveFactTarget fact)) + putCacheList + (putCacheBytes . encodeKernelRuleTag) + (toList (Typed.typedInductiveFactRules fact)) + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _seen [] = Nothing + go seen (value : remaining) + | value `Set.member` seen = Just value + | otherwise = + go (Set.insert value seen) remaining + +orderedUnique :: Ord value => [value] -> [value] +orderedUnique = + reverse . snd . foldl' step (Set.empty, []) + where + step (seen, values) value + | value `Set.member` seen = (seen, values) + | otherwise = + (Set.insert value seen, value : values) + +termLocation :: Internal.Expr -> Location +termLocation = Internal.exprLocation diff --git a/source/Felix/Checking/Exact/Proof.hs b/source/Felix/Checking/Exact/Proof.hs new file mode 100644 index 0000000..e2149c4 --- /dev/null +++ b/source/Felix/Checking/Exact/Proof.hs @@ -0,0 +1,2639 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact lowering for the first ordinary theorem/proof fragment. +-- +-- This module is the trusted owner of structural local-proof composition. Its +-- private prepared tree controls when assumptions and proved local claims +-- become available and executes discharges depth-first. The declaration +-- boundary validates typed tasks and authority; it does not reconstruct this +-- derivation. +module Felix.Checking.Exact.Proof + ( PreparedExactProof + , preparedExactProofSyntaxId + , preparedExactProofFirstOmission + , prepareExactProof + , CheckedExactProofAuthorization + , lowerPreparedExactProof + , authorizeCheckedExactProof + , PreparedFinalPreludeFoundationClaim + , prepareFinalPreludeFoundationClaim + , CheckedFinalPreludeFoundationAuthorization + , lowerPreparedFinalPreludeFoundationClaim + , authorizeCheckedFinalPreludeFoundationClaim + , ExactProofError(..) + , exactProofErrorLocation + , renderExactProofError + ) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation (foundationFactDerivation) +import Felix.Checking.Kernel.Proof qualified as KernelProof +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Cache.Codec +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw + +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.ByteString (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +data ExactProofError + = ExactProofUnsupportedClaim !Location + | ExactProofUnsupportedStep !Location + | ExactProofSetInductionVariableRequired !Location + | ExactProofSetInductionVariableNotActive + !Location !Raw.VarSymbol + | ExactProofSetInductionFocusAmbiguous !Location + | ExactProofSetInductionActiveBinderIneligible + !Location !Raw.VarSymbol + | ExactProofSetInductionBinderConflict + !Location !Raw.VarSymbol + | ExactProofSetInductionGoalMismatch !Location + | ExactProofSetExtensionalityGoalMismatch !Location + | ExactProofSetExtensionalityDirectionsUnavailable !Location + | ExactProofExpectedUniversalGoal !Location + | ExactProofExpectedImplicationGoal !Location + | ExactProofGoalStatementMismatch !Location + | ExactProofEmptyCaseSplit !Location + | ExactProofStructuralCompositionFailed + !Location !KernelProof.KernelProofBuildError + | ExactProofLocalFunctionBinderMismatch !Location + | ExactProofLocalFunctionNameConflict !Location + | ExactProofUnknownReference !Location !Raw.Marker + | ExactProofElaborationFailed !Exact.ExactCompileError + | ExactProofObligationPreparationFailed + !Location + !(Declaration.VampireObligationPreparationError + Exact.ExactLocalId) + | ExactProofFoundationLeafRequiresImplicitAuto !Location + | ExactProofFoundationLeafTargetMismatch !Location + | ExactProofFoundationLeafTargetAmbiguous !Location + deriving stock (Show, Eq) + +exactProofErrorLocation :: ExactProofError -> Location +exactProofErrorLocation = \case + ExactProofUnsupportedClaim location -> location + ExactProofUnsupportedStep location -> location + ExactProofSetInductionVariableRequired location -> location + ExactProofSetInductionVariableNotActive location _variable -> + location + ExactProofSetInductionFocusAmbiguous location -> location + ExactProofSetInductionActiveBinderIneligible location _variable -> + location + ExactProofSetInductionBinderConflict location _variable -> + location + ExactProofSetInductionGoalMismatch location -> location + ExactProofSetExtensionalityGoalMismatch location -> location + ExactProofSetExtensionalityDirectionsUnavailable location -> location + ExactProofExpectedUniversalGoal location -> location + ExactProofExpectedImplicationGoal location -> location + ExactProofGoalStatementMismatch location -> location + ExactProofEmptyCaseSplit location -> location + ExactProofStructuralCompositionFailed location _failure -> location + ExactProofLocalFunctionBinderMismatch location -> location + ExactProofLocalFunctionNameConflict location -> location + ExactProofUnknownReference location _marker -> location + ExactProofElaborationFailed failure -> + Exact.exactCompileErrorLocation failure + ExactProofObligationPreparationFailed location _failure -> location + ExactProofFoundationLeafRequiresImplicitAuto location -> location + ExactProofFoundationLeafTargetMismatch location -> location + ExactProofFoundationLeafTargetAmbiguous location -> location + +renderExactProofError :: ExactProofError -> Text +renderExactProofError = \case + ExactProofUnsupportedClaim location -> + at location <> "this claim is not yet supported by the typed checker" + ExactProofUnsupportedStep location -> + at location <> "this proof step is not yet supported by the typed checker" + ExactProofSetInductionVariableRequired location -> + at location <> "exact set induction requires a named set variable" + ExactProofSetInductionVariableNotActive location variable -> + at location <> "the set-induction variable " <> shown variable + <> " is not an eligible exact focus" + ExactProofSetInductionFocusAmbiguous location -> + at location + <> "set induction without an explicit variable has no unique focus" + ExactProofSetInductionActiveBinderIneligible location variable -> + at location <> "the active binder " <> shown variable + <> " is not an eligible set-induction focus" + ExactProofSetInductionBinderConflict location variable -> + at location <> "the leading set-induction binder " <> shown variable + <> " conflicts with an active exact binder" + ExactProofSetInductionGoalMismatch location -> + at location <> "the set-induction variable does not belong to this goal" + ExactProofSetExtensionalityGoalMismatch location -> + at location <> "set extensionality requires a set-equality goal" + ExactProofSetExtensionalityDirectionsUnavailable location -> + at location + <> "set extensionality requires both directions as proved local claims" + ExactProofExpectedUniversalGoal location -> + at location <> "this fix step requires a universal goal" + ExactProofExpectedImplicationGoal location -> + at location <> "this assume step requires an implication goal" + ExactProofGoalStatementMismatch location -> + at location <> "the proof step does not match the current goal" + ExactProofEmptyCaseSplit location -> + at location <> "case analysis requires at least one case" + ExactProofStructuralCompositionFailed location failure -> + at location <> "invalid structural proof composition: " <> shown failure + ExactProofLocalFunctionBinderMismatch location -> + at location <> "the function argument must match its domain binder" + ExactProofLocalFunctionNameConflict location -> + at location <> "the function and argument names must be distinct" + ExactProofUnknownReference location marker -> + at location <> "the cited fact " <> shown marker <> " is not visible" + ExactProofElaborationFailed failure -> + Exact.renderExactCompileError failure + ExactProofObligationPreparationFailed location failure -> + at location <> "the exact proof obligation is invalid: " <> shown failure + ExactProofFoundationLeafRequiresImplicitAuto location -> + at location + <> "a confined foundation claim requires an implicit Auto proof" + ExactProofFoundationLeafTargetMismatch location -> + at location <> "the claim does not exactly match a foundation axiom" + ExactProofFoundationLeafTargetAmbiguous location -> + at location <> "the claim matches more than one foundation axiom" + where + at location = locationToText location <> ": " + shown :: Show value => value -> Text + shown = Text.pack . show + +data ExactLocalOrigin + = ExactAssumption + | ExactDerivedClaim + | ExactLocalDefinition + | ExactLocalConstructionExtensional + | ExactLocalConstructionEquation + deriving stock (Show, Eq, Ord) + +data PreparedLocal = PreparedLocal + !Backend.LocalPremiseOrdinal + !ExactLocalOrigin + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + +data PreparedJustification + = PreparedAuto + | PreparedReferences + !(NonEmpty SemanticFactOccurrenceFingerprint) + | PreparedLocalOnly + +data PreparedDischarge + = PreparedVampireDischarge + !Location + !PreparedJustification + !(ScopedCheckedCore ObjectId) + !(Declaration.PreparedVampireObligation + Exact.ExactLocalId + ExactLocalOrigin) + | PreparedSetExtensionality + !Location + !(ScopedCheckedCore ObjectId) + +data PreparedCalculationLink = PreparedCalculationLink + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +-- The private constructor stores every destination with the discharge derived +-- from its immediately preceding endpoint. Planning and admission can +-- therefore traverse one immutable sequence without re-associating shapes. +data PreparedCalculation = PreparedCheckedCalculation + !CoreType + ![Exact.ExactLocalId] + !(Maybe (ScopedCheckedCore ObjectId)) + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCalculationLink) + !(ScopedCheckedCore ObjectId) + +data PreparedSinceEvidence + = PreparedSinceExisting !PreparedLocal + | PreparedSinceDischarged !PreparedDischarge !PreparedLocal + +data PreparedCase = PreparedCase + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedCaseAnalysis = PreparedCaseAnalysis + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCase) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data InitialSetInductionFocus = InitialSetInductionFocus + !Raw.VarSymbol + !Exact.ExactLocalId + !Natural + +data InitialSetInductionView = InitialSetInductionView + ![InitialSetInductionFocus] + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(Maybe Raw.VarSymbol) + +data SetInductionBoundary + = InitialClaimInduction !InitialSetInductionView + -- A direct source-statement goal may retain only its leading binder name. + -- Recursive proof transformations deliberately discard this hint. + | SourceStatementInduction !(Maybe Raw.VarSymbol) + | RecursiveProofInduction + +data SelectedSetInductionFocus + = SelectedInitialSetInduction !InitialSetInductionFocus + | SelectedLeadingSetInduction !(Maybe Raw.VarSymbol) + +data PreparedSetInductionFocus + = PreparedInitialSetInductionFocus + !Exact.ExactLocalId + !Natural + | PreparedLeadingSetInductionFocus + !Exact.ExactLocalId + +data PreparedSetInduction = PreparedCheckedSetInduction + !PreparedSetInductionFocus + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedProof + = PreparedImplicitAuto !PreparedDischarge + | PreparedQed !PreparedDischarge + | PreparedOmitted + !Location + !(ScopedCheckedCore ObjectId) + | PreparedFix ![Exact.ExactLocalId] !PreparedProof + | PreparedAssume + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedTake + ![Exact.ExactLocalId] + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSetInduction !PreparedSetInduction + | PreparedHave + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSuffices + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedCalculate + !PreparedCalculation + !PreparedProof + | PreparedSince + !(ScopedCheckedCore ObjectId) + !PreparedSinceEvidence + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSubclaim + !(ScopedCheckedCore ObjectId) + !PreparedProof + !PreparedProof + | PreparedDefine + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineRelational + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineFunction + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedByCase !PreparedCaseAnalysis + | PreparedByContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data PreparedExactProof = PreparedExactProof + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !PreparedProof + !ProofSyntaxId + +data PreparedFinalPreludeFoundationClaim = + PreparedFinalPreludeFoundationClaim + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !FoundationAxiomTag + !ProofSyntaxId + +preparedExactProofSyntaxId :: PreparedExactProof -> ProofSyntaxId +preparedExactProofSyntaxId + (PreparedExactProof _location _alias _target _proof syntax) = + syntax + +preparedExactProofFirstOmission :: PreparedExactProof -> Maybe Location +preparedExactProofFirstOmission + (PreparedExactProof _location _alias _target proof _syntax) = + preparedProofFirstOmission proof + +data PrepareState = PrepareState + { prepareNextLocal :: !Natural + , prepareNextPremise :: !Natural + } + +type Prepare = + StateT + PrepareState + (ExceptT ExactProofError (Declaration.LoweringDriver)) + +prepareExactProof + :: Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedExactProof) +prepareExactProof block explicitProof = + Except.runExceptT + (State.evalStateT prepare initialState) + where + initialState = PrepareState 0 0 + + prepare = + case block of + Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) -> do + envelope <- + liftDriver + (Exact.prepareExactClaimEnvelope assumptions statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let targetCore = Exact.preparedExactClaimTarget envelope + unless (null (scopedCoreContext targetCore)) + (throwProof + (ExactProofUnsupportedClaim location)) + (context, openedGoal, identities) <- + openEnvelopeVariables + targetCore + (Exact.preparedExactClaimVariables envelope) + (Exact.preparedExactClaimContext envelope) + (locals, bodyGoal, antecedents) <- + openEnvelopeAntecedents + context + openedGoal + (Exact.preparedExactClaimAntecedentCount envelope) + initialInduction <- + prepareInitialSetInductionView + statement + context + (Exact.preparedExactClaimVariables envelope) + identities + antecedents + bodyGoal + bodyProof <- + case explicitProof of + Nothing -> + PreparedImplicitAuto + <$> prepareDischarge + location + context + locals + bodyGoal + Raw.JustificationEmpty + Just sourceProof -> + prepareProof + location + context + locals + (InitialClaimInduction initialInduction) + bodyGoal + sourceProof + let withAssumptions = + foldr PreparedAssume bodyProof antecedents + proof = + case identities of + [] -> withAssumptions + _ -> PreparedFix identities withAssumptions + pure + (PreparedExactProof + location + (semanticName marker) + targetCore + proof + (proofSyntaxId + (encodePreparedProof proof))) + _ -> + throwProof + (ExactProofUnsupportedClaim (locate block)) + +prepareFinalPreludeFoundationClaim + :: CheckedFoundation + -> Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedFinalPreludeFoundationClaim) +prepareFinalPreludeFoundationClaim foundation block explicitProof = + Except.runExceptT do + case (block, explicitProof) of + ( Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) + , Nothing + ) -> do + envelope <- + Except.lift + (Exact.prepareExactClaimEnvelope + assumptions + statement) + >>= either + (Except.throwError + . ExactProofElaborationFailed) + pure + unless + ( null (Exact.preparedExactClaimVariables envelope) + && Exact.preparedExactClaimAntecedentCount envelope + == 0 + ) + (Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto + location)) + let target = Exact.preparedExactClaimTarget envelope + matches = + [ tag + | tag <- [minBound .. maxBound] + , target == foundationTarget tag + ] + tag <- case matches of + [] -> + Except.throwError + (ExactProofFoundationLeafTargetMismatch location) + [only] -> + pure only + _ -> + Except.throwError + (ExactProofFoundationLeafTargetAmbiguous location) + pure + (PreparedFinalPreludeFoundationClaim + location + (semanticName marker) + target + tag + (implicitAutoProofSyntaxId target)) + (Raw.BlockClaim _kind location _title _marker _claim, Just{}) -> + Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto location) + _ -> + Except.throwError + (ExactProofUnsupportedClaim (locate block)) + where + foundationTarget tag = + embedClosedCore [] + (mapFrozenGlobals + absurd + (foundationAxiomFrozen foundation tag)) + +openEnvelopeVariables + :: ScopedCheckedCore ObjectId + -> [Raw.VarSymbol] + -> Exact.ExactBinderContext + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openEnvelopeVariables target variables preparedContext = + case NonEmpty.nonEmpty variables of + Nothing -> + pure (preparedContext, target, []) + Just nonempty -> do + (_unannotated, opened, identities) <- + openFixedVariables + Exact.emptyExactBinderContext + target + nonempty + let expected = + reverse + (fst <$> toList + (Exact.exactBinderContextSupport preparedContext)) + unless + (identities == expected) + (impossible + "prepared claim annotations do not match opened binders") + pure (preparedContext, opened, identities) + +openEnvelopeAntecedents + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Natural + -> Prepare + ( [PreparedLocal] + , ScopedCheckedCore ObjectId + , [ScopedCheckedCore ObjectId] + ) +openEnvelopeAntecedents context initialGoal initialCount = + go [] [] initialGoal initialCount + where + go locals antecedents goal 0 = + pure (locals, goal, antecedents) + go locals antecedents goal remaining = do + (antecedent, conclusion) <- + maybe + (impossible + "a prepared claim envelope has too few implications") + pure + (openScopedImplication goal) + local <- allocateLocal ExactAssumption context antecedent + go + (locals <> [local]) + (antecedents <> [antecedent]) + conclusion + (remaining - 1) + +prepareInitialSetInductionView + :: Raw.Stmt + -> Exact.ExactBinderContext + -> [Raw.VarSymbol] + -> [Exact.ExactLocalId] + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Prepare InitialSetInductionView +prepareInitialSetInductionView + statement context variables identities antecedents bodyGoal = do + unless (length variables == length identities) + (impossible + "opened claim binders lost their source identity association") + foci <- traverse checkedFocus (zip variables identities) + let property = foldr implyChecked bodyGoal antecedents + support = Exact.exactBinderContextSupport context + unless + ( scopedCoreContext property + == (snd <$> Vector.toList support) + ) + (impossible + "initial set-induction property changed its checked context") + pure + (InitialSetInductionView + foci support property antecedents bodyGoal + (claimLeadingUniversalName statement)) + where + checkedFocus (variable, identity) = do + index <- + maybe + (impossible + "an opened claim binder is absent from its exact context") + pure + (Exact.exactBinderContextIndex variable context) + case Exact.exactBinderContextSupport context + Vector.!? (fromIntegral index) of + Just (actualIdentity, TySet) + | actualIdentity == identity -> + pure + (InitialSetInductionFocus + variable identity index) + _ -> + impossible + "an initial set-induction focus changed identity or type" + + implyChecked antecedent conclusion = + fromMaybe + (impossible + "an exact claim antecedent changed context") + (implyScopedCore antecedent conclusion) + +claimLeadingUniversalName :: Raw.Stmt -> Maybe Raw.VarSymbol +claimLeadingUniversalName = \case + Raw.StmtFormula + (Raw.FormulaQuantified _location Raw.Universally + (variable :| _rest) _bound _formula) -> + Just variable + Raw.SymbolicForall _location (variable :| _rest) + _bound _suchThat _statement -> + Just variable + Raw.StmtQuantPhrase + _location + (Raw.QuantPhrase Raw.Universally + (Raw.NounPhrase _left _noun variables _right _suchThat)) + _statement -> + listToMaybe variables + Raw.StmtVerbPhrase + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _verb -> + variable + Raw.StmtNoun + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _nounPhrase -> + variable + _statement -> + Nothing + +prepareProof + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareProof fallback context locals inductionBoundary goal = \case + Raw.Omitted location -> + pure (PreparedOmitted location goal) + Raw.Qed maybeLocation justification -> + PreparedQed + <$> prepareDischarge + (fromMaybe fallback maybeLocation) + context + locals + goal + justification + Raw.FixSymbolic location variables bound continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + case bound of + Raw.Unbounded -> + PreparedFix identities + <$> prepareProof + fallback + context' + locals + RecursiveProofInduction + goal' + continuation + _ -> do + constraint <- + prepareSymbolicBoundConstraints + context' variables bound + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.FixSuchThat location variables statement continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + constraint <- + Exact.preparedExactPropositionCore + <$> prepareStatement context' statement + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.Assume location statement continuation -> do + supplied <- prepareStatement context statement + when (isNothing (openScopedImplication goal)) + (throwProof (ExactProofExpectedImplicationGoal location)) + (assumption, conclusion) <- + maybe + (throwProof (ExactProofGoalStatementMismatch location)) + pure + (openScopedAssumption + (Exact.preparedExactPropositionCore supplied) + goal) + local <- allocateLocal ExactAssumption context assumption + PreparedAssume assumption + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + Raw.TakeVar location variables bound statement justification continuation -> do + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.TakeNoun location nounPhrase justification continuation -> + prepareNounTake + fallback location context locals goal nounPhrase + justification continuation + Raw.BySetInduction location variable continuation -> + prepareSetInduction + fallback location context locals inductionBoundary goal + variable continuation + Raw.Have location Nothing + (Raw.SymbolicExists _existential variables bound statement) + justification continuation -> + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.Have location Nothing statement justification continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + discharge <- + prepareDischarge + location context locals claim justification + local <- allocateLocal ExactDerivedClaim context claim + PreparedHave claim discharge + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Have location (Just sinceStatement) + statement justification continuation -> do + sinceProposition <- + Exact.preparedExactPropositionCore + <$> prepareStatement context sinceStatement + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + (evidence, sinceLocals) <- + case find (localMatches sinceProposition) locals of + Just existing -> + pure (PreparedSinceExisting existing, locals) + Nothing -> do + discharge <- + prepareDischarge + location + context + locals + sinceProposition + Raw.JustificationLocal + local <- + allocateLocal + ExactDerivedClaim context sinceProposition + pure + ( PreparedSinceDischarged discharge local + , locals <> [local] + ) + claimDischarge <- + prepareDischarge + location context sinceLocals claim justification + claimLocal <- + allocateLocal ExactDerivedClaim context claim + PreparedSince + sinceProposition evidence claim claimDischarge + <$> prepareProof + fallback + context + (sinceLocals <> [claimLocal]) + RecursiveProofInduction + goal + continuation + Raw.Suffices location statement justification continuation -> do + reduction <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + implication <- + maybe + (impossible + "a checked suffices reduction changed lexical context") + pure + (implyScopedCore reduction goal) + discharge <- + prepareDischarge + location context locals implication justification + PreparedSuffices goal reduction implication discharge + <$> prepareProof + fallback + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + reduction + continuation + Raw.Calc location quantifier calculation continuation -> do + prepared <- + prepareCalculation + location context locals quantifier calculation + local <- + allocateLocal + ExactDerivedClaim + context + (preparedCalculationResult prepared) + PreparedCalculate prepared + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Subclaim location statement subproof continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + preparedSubproof <- + prepareProof + location + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + claim + subproof + local <- allocateLocal ExactDerivedClaim context claim + PreparedSubclaim claim preparedSubproof + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Define location variable expression continuation -> do + preparedBody <- + liftDriver + (Exact.prepareExactSetExpression context expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let body = Exact.preparedExactSetExpressionCore preparedBody + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + case Exact.preparedExactSetExpressionConstruction preparedBody of + Nothing -> do + separationCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + SeparationCharacteristic) + definition <- + maybe + (impossible + "an exact set expression did not form a local definition") + pure + (scopedSetDefinition separationCharacteristic body) + local <- + allocateLocal ExactLocalDefinition context' definition + PreparedDefine identity body (definition :| []) + <$> prepareProof + fallback context' (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedUnconditionalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + (extensional, equation) <- + maybe + (impossible + "a checked named construction has no definition views") + pure + (namedSetConstructionLocalViews + characteristics construction) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefine identity body (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedRelationalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + let functionality = + relationalSetConstructionFunctionality construction + discharge <- + prepareDischarge + location context locals functionality + Raw.JustificationEmpty + (extensional, equation) <- + maybe + (impossible + "a checked relational construction has no admitted definition views") + pure + (relationalSetConstructionLocalViews + characteristics construction functionality) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefineRelational + identity body discharge (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.DefineFunction + location function argument value bound domain continuation -> do + unless (argument == bound) + (throwProof + (ExactProofLocalFunctionBinderMismatch (locate bound))) + when (function == argument) + (throwProof + (ExactProofLocalFunctionNameConflict (locate function))) + argumentIdentity <- allocateLocalIdentity + argumentContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((argumentIdentity, argument) :| []) + context) + graph <- + liftDriver + (Exact.prepareExactLocalFunctionGraph + location context argumentContext domain value) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + functionIdentity <- allocateLocalIdentity + functionContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((functionIdentity, function) :| []) + context) + replacementCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + ReplacementCharacteristic) + definition <- + maybe + (impossible + "a checked replacement graph did not form a local definition") + pure + (scopedCharacteristicDefinition + replacementCharacteristic + (Exact.preparedExactLocalFunctionGraphCore graph) + ( Exact.preparedExactLocalFunctionGraphDomain graph + :| [Exact.preparedExactLocalFunctionGraphMap graph] + )) + local <- + allocateLocal ExactLocalDefinition functionContext definition + PreparedDefineFunction + functionIdentity + (Exact.preparedExactLocalFunctionGraphCore graph) + definition + <$> prepareProof + fallback + functionContext + (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.ByCase location sourceCases -> + prepareByCase + location context locals goal sourceCases + Raw.ByContradiction location continuation -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + negation <- + maybe + (structuralFailure + location + "proof by contradiction requires a proposition goal") + pure + (negateScopedCore goal) + local <- allocateLocal ExactAssumption context negation + prepared <- + prepareProof + location + context + (locals <> [local]) + RecursiveProofInduction + falsum + continuation + validateStructuralComposition + location [goal, negation, falsum] + (\foundation globalType -> + KernelProof.validateDoubleNegationComposition + foundation globalType goal negation falsum) + pure + (PreparedByContradiction + goal negation falsum prepared) + Raw.Contradiction location justification -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + discharge <- + prepareDischarge + location + context + locals + falsum + justification + validateStructuralComposition + location [goal, falsum] + (\foundation globalType -> + KernelProof.validateFalsumEliminationComposition + foundation globalType goal falsum) + pure (PreparedContradiction goal falsum discharge) + proof -> + throwProof + (ExactProofUnsupportedStep + (proofLocation fallback proof)) + where + localMatches proposition + (PreparedLocal _ordinal _origin _support local) = + local == proposition + +prepareSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Raw.Proof + -> Prepare PreparedProof +prepareSetInduction + fallback location context locals boundary goal sourceFocus + continuation = do + selected <- + selectSetInductionFocus + location context boundary goal sourceFocus + case selected of + SelectedInitialSetInduction + (InitialSetInductionFocus _variable identity index) -> do + (foci, expectedSupport, property, antecedents, childTarget) <- + case boundary of + InitialClaimInduction + (InitialSetInductionView + foundFoci support foundProperty + foundAntecedents foundTarget _leadingName) -> + pure + ( foundFoci + , support + , foundProperty + , foundAntecedents + , foundTarget + ) + RecursiveProofInduction -> + impossible + "an initial induction focus escaped its claim boundary" + SourceStatementInduction _leadingName -> + impossible + "an initial induction focus escaped its claim boundary" + unless + ( Exact.exactBinderContextSupport context == expectedSupport + && goal == childTarget + && any (sameInitialFocus identity index) foci + ) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + PreparedSetInduction + <$> prepareCheckedSetInduction + fallback location context locals + (PreparedInitialSetInductionFocus identity index) + index property antecedents childTarget continuation + SelectedLeadingSetInduction sourceName -> do + (binderType, property) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + identity <- allocateLocalIdentity + extendedContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (case sourceName of + Just variable -> + Exact.extendExactBinderContext + ((identity, variable) :| []) + context + Nothing -> + Exact.extendExactAnonymousBinderContext + identity context) + let expectedResult = weakenCheckedScopedCore TySet goal + prepared <- prepareCheckedSetInduction + fallback location extendedContext locals + (PreparedLeadingSetInductionFocus identity) + 0 property [] property continuation + unless + (preparedSetInductionResult prepared == expectedResult) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure (PreparedSetInduction prepared) + where + sameInitialFocus expectedIdentity expectedIndex + (InitialSetInductionFocus _variable identity index) = + identity == expectedIdentity && index == expectedIndex + +prepareCheckedSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> PreparedSetInductionFocus + -> Natural + -> ScopedCheckedCore ObjectId + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedSetInduction +prepareCheckedSetInduction + fallback location context locals focus selected property antecedents + childTarget continuation = do + (_predicate, hypothesis, _step, result) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (scopedSetInductionInstance selected property) + validateStructuralComposition + location + (property : hypothesis : result : childTarget : antecedents) + (\foundation globalType -> + KernelProof.validateSetInductionComposition + foundation globalType selected property antecedents + childTarget hypothesis result) + local <- allocateLocal ExactAssumption context hypothesis + child <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + childTarget + continuation + pure + (PreparedCheckedSetInduction + focus property antecedents childTarget hypothesis result child) + +preparedSetInductionResult + :: PreparedSetInduction + -> ScopedCheckedCore ObjectId +preparedSetInductionResult + (PreparedCheckedSetInduction + _focus _property _antecedents _target _hypothesis result _child) = + result + +selectSetInductionFocus + :: Location + -> Exact.ExactBinderContext + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Prepare SelectedSetInductionFocus +selectSetInductionFocus location context boundary goal sourceFocus = do + explicit <- traverse simpleVariable sourceFocus + let (initialFoci, retainedLeadingName) = + case boundary of + InitialClaimInduction + (InitialSetInductionView + foci _support _property _antecedents _target + leadingName) -> + (foci, leadingName) + SourceStatementInduction leadingName -> + ([], leadingName) + RecursiveProofInduction -> + ([], Nothing) + leadingAvailable = + case openScopedForall goal of + Just (TySet, _body) -> True + _ -> False + case explicit of + Just variable -> + case find (initialNamed variable) initialFoci of + Just focus -> + pure (SelectedInitialSetInduction focus) + Nothing + | leadingAvailable + , isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionBinderConflict + location variable) + | leadingAvailable -> + pure + (SelectedLeadingSetInduction + (Just variable)) + | isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionActiveBinderIneligible + location variable) + | otherwise -> + throwProof + (ExactProofSetInductionVariableNotActive + location variable) + Nothing -> + case + ( (SelectedInitialSetInduction <$> initialFoci) + <> [ SelectedLeadingSetInduction retainedLeadingName + | leadingAvailable + ] + ) of + [only] -> pure only + _ -> + throwProof + (ExactProofSetInductionFocusAmbiguous location) + where + simpleVariable = \case + Raw.TermExpr (Raw.ExprVar variable) -> + pure variable + _term -> + throwProof + (ExactProofSetInductionVariableRequired location) + + initialNamed variable + (InitialSetInductionFocus candidate _identity _index) = + candidate == variable + +prepareByCase + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Raw.Case] + -> Prepare PreparedProof +prepareByCase location context locals goal sourceCases = do + cases <- + maybe + (throwProof (ExactProofEmptyCaseSplit location)) + (traverse prepareCase) + (NonEmpty.nonEmpty sourceCases) + exhaustive <- + foldM disjoin + (preparedCaseAssumption (NonEmpty.head cases)) + (preparedCaseAssumption <$> NonEmpty.tail cases) + discharge <- + prepareDischarge + location context locals exhaustive Raw.JustificationEmpty + validateStructuralComposition + location + (goal : exhaustive : (preparedCaseAssumption <$> toList cases)) + (\foundation globalType -> + KernelProof.validateCaseAnalysisComposition + foundation + globalType + goal + (preparedCaseAssumption <$> cases) + exhaustive) + pure + (PreparedByCase + (PreparedCaseAnalysis goal cases exhaustive discharge)) + where + prepareCase (Raw.Case statement child) = do + assumption <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + local <- allocateLocal ExactAssumption context assumption + prepared <- + prepareProof + (locate statement) + context + (locals <> [local]) + RecursiveProofInduction + goal + child + pure (PreparedCase assumption prepared) + + disjoin left right = + maybe + (structuralFailure + location + "case assumptions changed type or lexical context") + pure + (disjoinScopedCore left right) + +preparedCaseAssumption + :: PreparedCase + -> ScopedCheckedCore ObjectId +preparedCaseAssumption (PreparedCase assumption _proof) = + assumption + +preparedCaseProof :: PreparedCase -> PreparedProof +preparedCaseProof (PreparedCase _assumption proof) = + proof + +prepareGuardedFix + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareGuardedFix + fallback location context locals goal identities constraint continuation = do + (antecedent, conclusion) <- + maybe + (throwProof (ExactProofExpectedImplicationGoal location)) + pure + (openScopedImplication goal) + unless (constraint == antecedent) + (throwProof (ExactProofGoalStatementMismatch location)) + local <- allocateLocal ExactAssumption context constraint + prepared <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + pure (PreparedFix identities (PreparedAssume constraint prepared)) + +prepareCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> Maybe Raw.CalcQuantifier + -> Raw.Calc + -> Prepare PreparedCalculation +prepareCalculation location context locals quantifier calculation = do + (identities, calculationContext, calculationGuard) <- + prepareCalculationScope context quantifier + case calculation of + Raw.Equation first destinations -> do + firstChecked <- prepareSetEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + prepareSetEndpoint calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TySet identities calculationGuard + firstChecked checkedDestinations + Raw.Biconditionals first destinations -> do + firstChecked <- preparePropositionEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + preparePropositionEndpoint + calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TyProp identities calculationGuard + firstChecked checkedDestinations + where + prepareSetEndpoint endpointContext expression = + Exact.preparedExactSetExpressionCore + <$> ( liftDriver + (Exact.prepareExactSetExpression + endpointContext expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + + preparePropositionEndpoint endpointContext formula = + Exact.preparedExactPropositionCore + <$> prepareStatement endpointContext (Raw.StmtFormula formula) + +prepareCalculationScope + :: Exact.ExactBinderContext + -> Maybe Raw.CalcQuantifier + -> Prepare + ( [Exact.ExactLocalId] + , Exact.ExactBinderContext + , Maybe (ScopedCheckedCore ObjectId) + ) +prepareCalculationScope context = \case + Nothing -> + pure ([], context, Nothing) + Just (Raw.CalcQuantifier variables bound suchThat) -> do + identities <- traverse (const allocateLocalIdentity) variables + calculationContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + boundGuard <- + prepareSymbolicBoundConstraints + calculationContext variables bound + suchThatGuard <- + traverse + (fmap Exact.preparedExactPropositionCore + . prepareStatement calculationContext) + suchThat + calculationGuard <- + normalizeCalculationGuard + (boundGuard : maybeToList suchThatGuard) + pure (toList identities, calculationContext, calculationGuard) + +normalizeCalculationGuard + :: [ScopedCheckedCore ObjectId] + -> Prepare (Maybe (ScopedCheckedCore ObjectId)) +normalizeCalculationGuard guards = + foldM add Nothing guards + where + add accumulated constraint + | isScopedTruth constraint = pure accumulated + | otherwise = + case accumulated of + Nothing -> pure (Just constraint) + Just previous -> + Just + <$> maybe + (impossible + "checked calculation guards changed context") + pure + (conjoinScopedCore previous constraint) + + isScopedTruth proposition = + scopedCoreType proposition == TyProp + && scopedCoreTerm proposition == CImp CFalsum CFalsum + +finishCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> CoreType + -> [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> NonEmpty + ( Location + , ScopedCheckedCore ObjectId + , Raw.Justification + ) + -> Prepare PreparedCalculation +finishCalculation + fallback context locals operandType identities calculationGuard + first destinations = do + links <- prepareCalculationLinks first destinations + let finalEndpoint = preparedCalculationLinkDestination (NonEmpty.last links) + resultOpen <- + calculationEquality first finalEndpoint + result <- + closeCalculationProposition identities calculationGuard resultOpen + pure + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) + where + prepareCalculationLinks previous (destination :| rest) = do + (next, firstLink) <- prepareCalculationLink previous destination + later <- prepareRemainingCalculationLinks next rest + pure (firstLink :| later) + + prepareRemainingCalculationLinks _previous [] = + pure [] + prepareRemainingCalculationLinks previous (destination : rest) = do + (next, link) <- prepareCalculationLink previous destination + (link :) <$> prepareRemainingCalculationLinks next rest + + prepareCalculationLink previous + (destinationLocation, destination, justification) = do + linkOpen <- calculationEquality previous destination + link <- closeCalculationProposition + identities calculationGuard linkOpen + discharge <- + prepareDischarge + (if destinationLocation == Nowhere + then fallback + else destinationLocation) + context + locals + link + justification + pure + ( destination + , PreparedCalculationLink destination discharge + ) + + calculationEquality left right = + maybe + (impossible + "checked calculation endpoints changed type or context") + pure + (equalScopedCore left right) + +closeCalculationProposition + :: [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> Prepare (ScopedCheckedCore ObjectId) +closeCalculationProposition identities calculationGuard proposition = do + guarded <- + case calculationGuard of + Nothing -> pure proposition + Just constraint -> + maybe + (impossible + "a checked calculation guard changed context") + pure + (implyScopedCore constraint proposition) + pure (closeBinders (length identities) guarded) + where + closeBinders 0 closed = closed + closeBinders remaining open = + closeBinders (remaining - 1) + (fromMaybe + (impossible + "a checked calculation lost a quantified binder") + (closeScopedForall open)) + +preparedCalculationResult + :: PreparedCalculation + -> ScopedCheckedCore ObjectId +preparedCalculationResult + (PreparedCheckedCalculation + _operandType _identities _guard _first _links result) = + result + +preparedCalculationLinkDestination + :: PreparedCalculationLink + -> ScopedCheckedCore ObjectId +preparedCalculationLinkDestination + (PreparedCalculationLink destination _discharge) = + destination + +preparedCalculationLinkDischarge + :: PreparedCalculationLink + -> PreparedDischarge +preparedCalculationLinkDischarge + (PreparedCalculationLink _destination discharge) = + discharge + +preparedDischargeGoal + :: PreparedDischarge + -> ScopedCheckedCore ObjectId +preparedDischargeGoal = \case + PreparedVampireDischarge _location _justification goal _obligation -> + goal + PreparedSetExtensionality _location goal -> + goal + +prepareSymbolicBoundConstraints + :: Exact.ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Prepare (ScopedCheckedCore ObjectId) +prepareSymbolicBoundConstraints context variables bound = + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicBoundConstraints + context variables bound) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + +prepareSymbolicTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation = do + identities <- traverse (const allocateLocalIdentity) variables + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicWitnessConstraints + context' variables bound statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + (toList identities) witness justification continuation + +prepareNounTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.NounPhrase [] + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareNounTake + fallback location context locals goal nounPhrase + justification continuation = do + (identities, context') <- + case nounPhrase of + Raw.NounPhrase _left _noun variables _right _suchThat -> + case NonEmpty.nonEmpty variables of + Just binders -> do + identities <- + traverse (const allocateLocalIdentity) binders + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities binders) + context) + pure (toList identities, context') + Nothing -> do + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactAnonymousBinderContext + identity context) + pure ([identity], context') + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactNounWitnessConstraints + context' nounPhrase) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + identities witness justification continuation + +prepareTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Exact.ExactBinderContext + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareTake + fallback location context locals goal witnessContext + identities witness justification continuation = do + let witnessCount = length identities + existence = closeTakenWitnesses witnessCount witness + goal' = weakenForTakenWitnesses witnessCount goal + discharge <- + prepareDischarge + location context locals existence justification + local <- allocateLocal ExactAssumption witnessContext witness + PreparedTake identities witness discharge + <$> prepareProof + fallback + witnessContext + (locals <> [local]) + RecursiveProofInduction + goal' + continuation + +-- The discharged existential and the opened witness premise are the same +-- checked proposition viewed on opposite sides of existential elimination. +closeTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +closeTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (fromMaybe + (impossible "a taken witness has no checked binder") + (closeScopedExists proposition)) + +weakenForTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +weakenForTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (weakenCheckedScopedCore TySet proposition) + +openFixedVariables + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openFixedVariables initialContext initialGoal variables = + foldM openOne + (initialContext, initialGoal, []) + (toList variables) + where + openOne (context, goal, identities) variable = do + (binderType, body) <- + maybe + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + pure (context', body, identities <> [identity]) + +allocateLocalIdentity :: Prepare Exact.ExactLocalId +allocateLocalIdentity = do + state <- State.get + State.put + state + { prepareNextLocal = prepareNextLocal state + 1 + } + pure (Exact.exactLocalId (prepareNextLocal state)) + +allocateLocal + :: ExactLocalOrigin + -> Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Prepare PreparedLocal +allocateLocal origin context proposition = do + state <- State.get + State.put + state + { prepareNextPremise = prepareNextPremise state + 1 + } + pure + (PreparedLocal + (Backend.localPremiseOrdinal + (prepareNextPremise state)) + origin + (Exact.exactBinderContextSupport context) + proposition) + +prepareConstructionFoundation + :: Prepare SetConstructionFoundation +prepareConstructionFoundation = do + familyUnion <- foundation FamilyUnionCharacteristic + separation <- foundation SeparationCharacteristic + replacement <- foundation ReplacementCharacteristic + setChoose <- foundation SetChooseWitness + pure + (setConstructionFoundation + familyUnion separation replacement setChoose) + where + foundation tag = + liftDriver + (Declaration.currentFoundationAxiomLowering tag) + +prepareDischarge + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischarge location context locals goal justification = + prepareDischargeWith + (dischargeModeFor goal) + [] Nothing location context locals goal justification + +-- A contradictory-axioms answer can establish falsum, but never an unrelated +-- proposition directly. Derive that distinction from the checked target so +-- every surface proof spelling reaches the same guarded request path. +dischargeModeFor :: ScopedCheckedCore ObjectId -> DischargeMode +dischargeModeFor goal + | scopedCoreType goal == TyProp + , scopedCoreTerm goal == CFalsum = + IndirectContradictionDischarge + | otherwise = + DirectDischarge + +data DischargeMode + = DirectDischarge + | IndirectContradictionDischarge + +prepareDischargeWith + :: DischargeMode + -> [FoundationAxiomTag] + -> Maybe Declaration.VampirePremiseSelection + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischargeWith + dischargeMode auxiliaries selectionOverride + location context locals goal justification = + case justification of + Raw.JustificationSetExt -> do + (leftToRight, rightToLeft) <- + maybe + (throwProof + (ExactProofSetExtensionalityGoalMismatch location)) + pure + (splitScopedSetEquality goal) + unless + ( hasDerivedLocal leftToRight + && hasDerivedLocal rightToLeft + ) + (throwProof + (ExactProofSetExtensionalityDirectionsUnavailable + location)) + pure (PreparedSetExtensionality location goal) + _ -> do + preparedJustification <- + prepareJustification location justification + prepared <- + liftDriver + (prepareObligation + (Exact.exactBinderContextSupport context) + goal + (toScopedPremise <$> locals) + auxiliaries + (fromMaybe + (vampirePremiseSelection preparedJustification) + selectionOverride)) + >>= either + (throwProof + . ExactProofObligationPreparationFailed location) + pure + pure + (PreparedVampireDischarge + location + preparedJustification + goal + prepared) + where + prepareObligation = + case dischargeMode of + DirectDischarge -> + Declaration.prepareScopedVampireObligationLowering + IndirectContradictionDischarge -> + Declaration.prepareScopedContradictionObligationLowering + + hasDerivedLocal proposition = + any + (\case + PreparedLocal + _ordinal ExactDerivedClaim _support local -> + local == proposition + PreparedLocal{} -> + False) + locals + + toScopedPremise + (PreparedLocal ordinal origin support proposition) = + Declaration.scopedVampirePremise + ordinal origin support proposition + +prepareJustification + :: Location + -> Raw.Justification + -> Prepare PreparedJustification +prepareJustification _location Raw.JustificationEmpty = + pure PreparedAuto +prepareJustification location (Raw.JustificationRef markers) = do + resolved <- traverse (resolveReference location) (toList markers) + let unique = stableUnique resolved + case unique of + [] -> + impossible "a nonempty citation list resolved to no facts" + first : rest -> + pure (PreparedReferences (first :| rest)) +prepareJustification _location Raw.JustificationLocal = + pure PreparedLocalOnly +prepareJustification location Raw.JustificationSetExt = + throwProof (ExactProofUnsupportedStep location) + +vampirePremiseSelection + :: PreparedJustification + -> Declaration.VampirePremiseSelection +vampirePremiseSelection = \case + PreparedAuto -> + Declaration.VampireImplicitPremises + PreparedReferences fingerprints -> + Declaration.VampireExplicitPremises fingerprints + PreparedLocalOnly -> + Declaration.VampireLocalPremises + +resolveReference + :: Location + -> Raw.Marker + -> Prepare SemanticFactOccurrenceFingerprint +resolveReference location marker@(Raw.Marker name) = do + resolved <- + liftDriver + (Declaration.resolveVisibleFactAliasLowering + (semanticName name)) + maybe + (throwProof + (ExactProofUnknownReference location marker)) + pure + resolved + +prepareStatement + :: Exact.ExactBinderContext + -> Raw.Stmt + -> Prepare Exact.PreparedExactProposition +prepareStatement context statement = + liftDriver + (Exact.prepareExactProposition context statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + +validateStructuralComposition + :: Location + -> [ScopedCheckedCore ObjectId] + -> ( CheckedFoundation + -> (ObjectId -> Maybe CoreType) + -> Either KernelProof.KernelProofBuildError () + ) + -> Prepare () +validateStructuralComposition location propositions validate = do + foundation <- + liftDriver Declaration.currentFoundationLowering + let identities = + Set.toAscList + (Set.unions + ( canonicalTermGlobals . scopedCoreTerm + <$> propositions + )) + types <- + traverse + (\identity -> do + coreType <- + liftDriver + (Declaration.objectTypeLowering identity) + maybe + (impossible + "a checked structural proof lost a global object") + (\availableType -> pure (identity, availableType)) + coreType) + identities + either + (throwProof + . ExactProofStructuralCompositionFailed location) + pure + (validate foundation + (\identity -> Map.lookup identity (Map.fromList types))) + +structuralFailure :: Location -> Text -> Prepare value +structuralFailure location message = + throwProof + (ExactProofStructuralCompositionFailed + location + (KernelProof.ProofStructuralCompositionMismatch message)) + +data CheckedExactProofAuthorization = CheckedExactProofAuthorization + !PreparedProof + !Bool + +lowerPreparedExactProof + :: PreparedExactProof + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration CheckedExactProofAuthorization)) +lowerPreparedExactProof + (PreparedExactProof _location alias target proof syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [Declaration.checkedCandidate spec planning :| []] + (CheckedExactProofAuthorization + proof + (isJust (preparedProofFirstOmission proof))) + where + requests = plannedProofRequests proof + planning + | isJust (preparedProofFirstOmission proof) = + Declaration.checkedOmittedPlanning requests [] + | otherwise = + Declaration.checkedSourceProofPlanning requests [] + +authorizeCheckedExactProof + :: CheckedExactProofAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactProof + (CheckedExactProofAuthorization proof hasOmission) = \case + [candidate :| []] + | hasOmission -> + Declaration.authorizeOmittedCandidate + candidate + (executePreparedProof proof) + | otherwise -> + Declaration.authorizeVampireCandidate + candidate + (executePreparedProof proof) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +data CheckedFinalPreludeFoundationAuthorization = + CheckedFinalPreludeFoundationAuthorization !FoundationAxiomTag + +lowerPreparedFinalPreludeFoundationClaim + :: PreparedFinalPreludeFoundationClaim + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedFinalPreludeFoundationAuthorization)) +lowerPreparedFinalPreludeFoundationClaim + (PreparedFinalPreludeFoundationClaim + _location alias target tag syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [ Declaration.checkedCandidate spec + (Declaration.checkedKernelPlanning + (Authority.FoundationLeaf tag) []) + :| [] + ] + (CheckedFinalPreludeFoundationAuthorization tag) + +authorizeCheckedFinalPreludeFoundationClaim + :: CheckedFinalPreludeFoundationAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedFinalPreludeFoundationClaim + (CheckedFinalPreludeFoundationAuthorization tag) = \case + [candidate :| []] -> + Declaration.authorizeKernelConstructionCandidate + (Authority.FoundationLeaf tag) + candidate + (pure (foundationFactDerivation tag)) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +preparedProofFirstOmission :: PreparedProof -> Maybe Location +preparedProofFirstOmission = \case + PreparedImplicitAuto{} -> Nothing + PreparedQed{} -> Nothing + PreparedOmitted location _goal -> Just location + PreparedFix _identities continuation -> + preparedProofFirstOmission continuation + PreparedAssume _antecedent continuation -> + preparedProofFirstOmission continuation + PreparedTake _identities _witness _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + preparedProofFirstOmission child + PreparedHave _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSuffices _goal _reduction _implication _discharge continuation -> + preparedProofFirstOmission continuation + PreparedCalculate _calculation continuation -> + preparedProofFirstOmission continuation + PreparedSince _since _evidence _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSubclaim _claim subproof continuation -> + preparedProofFirstOmission subproof + <|> preparedProofFirstOmission continuation + PreparedDefine _identity _body _definition continuation -> + preparedProofFirstOmission continuation + PreparedDefineRelational + _identity _body _functionality _definitions continuation -> + preparedProofFirstOmission continuation + PreparedDefineFunction _identity _graph _definition continuation -> + preparedProofFirstOmission continuation + PreparedByCase (PreparedCaseAnalysis _goal cases _exhaustive _discharge) -> + foldr + ((<|>) . preparedProofFirstOmission . preparedCaseProof) + Nothing + cases + PreparedByContradiction _goal _negation _falsum child -> + preparedProofFirstOmission child + PreparedContradiction{} -> Nothing + +plannedProofRequests + :: PreparedProof + -> [Declaration.CheckedPlannedVampireRequest] +plannedProofRequests = \case + PreparedImplicitAuto discharge -> plannedDischargeRequests discharge + PreparedQed discharge -> plannedDischargeRequests discharge + PreparedOmitted{} -> [] + PreparedFix _identities continuation -> + plannedProofRequests continuation + PreparedAssume _antecedent continuation -> + plannedProofRequests continuation + PreparedTake _identities _witness discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + plannedProofRequests child + PreparedHave _claim discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSuffices _goal _reduction _implication discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedCalculate calculation continuation -> + plannedCalculationRequests calculation + <> plannedProofRequests continuation + PreparedSince _since evidence _claim discharge continuation -> + plannedSinceEvidenceRequests evidence + <> plannedDischargeRequests discharge + <> plannedProofRequests continuation + PreparedSubclaim _claim subproof continuation -> + plannedProofRequests subproof <> plannedProofRequests continuation + PreparedDefine _identity _body _definition continuation -> + plannedProofRequests continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> + plannedDischargeRequests functionality + <> plannedProofRequests continuation + PreparedDefineFunction _identity _graph _definition continuation -> + plannedProofRequests continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> + concatMap + (plannedProofRequests . preparedCaseProof) + (toList cases) + <> plannedDischargeRequests discharge + PreparedByContradiction _goal _negation _falsum child -> + plannedProofRequests child + PreparedContradiction _goal _falsum discharge -> + plannedDischargeRequests discharge + +plannedDischargeRequests + :: PreparedDischarge + -> [Declaration.CheckedPlannedVampireRequest] +plannedDischargeRequests = \case + PreparedVampireDischarge location _justification _goal obligation -> + [Declaration.checkedPlannedVampireRequest location obligation] + PreparedSetExtensionality{} -> [] + +plannedCalculationRequests + :: PreparedCalculation + -> [Declaration.CheckedPlannedVampireRequest] +plannedCalculationRequests + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + concatMap + (plannedDischargeRequests . preparedCalculationLinkDischarge) + (toList links) + +plannedSinceEvidenceRequests + :: PreparedSinceEvidence + -> [Declaration.CheckedPlannedVampireRequest] +plannedSinceEvidenceRequests = \case + PreparedSinceExisting{} -> [] + PreparedSinceDischarged discharge _local -> + plannedDischargeRequests discharge + +executePreparedProof + :: PreparedProof + -> Declaration.CandidateProof () +executePreparedProof = \case + PreparedImplicitAuto discharge -> + executeDischarge discharge + PreparedQed discharge -> + executeDischarge discharge + PreparedOmitted _location _goal -> + Declaration.recordOmittedUse + PreparedFix _identities continuation -> + executePreparedProof continuation + PreparedAssume _antecedent continuation -> + executePreparedProof continuation + PreparedTake _identities _witness discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + executePreparedProof child + PreparedHave _claim discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + unless + (implyScopedCore reduction goal == Just implication) + (impossible "a prepared suffices implication diverged") + PreparedCalculate calculation continuation -> do + executePreparedCalculation calculation + executePreparedProof continuation + PreparedSince sinceProposition evidence _claim discharge continuation -> do + executeSinceEvidence sinceProposition evidence + executeDischarge discharge + executePreparedProof continuation + PreparedSubclaim _claim subproof continuation -> do + executePreparedProof subproof + executePreparedProof continuation + PreparedDefine _identity _body _definition continuation -> + executePreparedProof continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> do + executeDischarge functionality + executePreparedProof continuation + PreparedDefineFunction _identity _graph _definition continuation -> + executePreparedProof continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> do + traverse_ (executePreparedProof . preparedCaseProof) cases + executeDischarge discharge + PreparedByContradiction _goal _negation _falsum child -> + executePreparedProof child + PreparedContradiction _goal _falsum discharge -> + executeDischarge discharge + +executeDischarge + :: PreparedDischarge + -> Declaration.CandidateProof () +executeDischarge + (PreparedVampireDischarge + location _justification _goal obligation) = + Declaration.locateProofObligation location + (Declaration.acceptPreparedVampireObligation obligation) +executeDischarge PreparedSetExtensionality{} = + pure () + +executePreparedCalculation + :: PreparedCalculation + -> Declaration.CandidateProof () +executePreparedCalculation + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + traverse_ + (executeDischarge . preparedCalculationLinkDischarge) + links + +executeSinceEvidence + :: ScopedCheckedCore ObjectId + -> PreparedSinceEvidence + -> Declaration.CandidateProof () +executeSinceEvidence proposition = \case + PreparedSinceExisting local -> + unless (preparedLocalProposition local == proposition) + (impossible "a structural since premise diverged") + PreparedSinceDischarged discharge local -> do + executeDischarge discharge + unless + ( preparedDischargeGoal discharge == proposition + && preparedLocalProposition local == proposition + ) + (impossible "a discharged since premise diverged") + +preparedLocalProposition + :: PreparedLocal + -> ScopedCheckedCore ObjectId +preparedLocalProposition + (PreparedLocal _ordinal _origin _support proposition) = + proposition + +encodePreparedProof :: PreparedProof -> ByteString +encodePreparedProof = + encodeCache . putPreparedProof + +putPreparedProof :: PreparedProof -> CachePut +putPreparedProof = \case + PreparedImplicitAuto discharge -> do + putCacheTag 0x00 + putPreparedDischarge discharge + PreparedQed discharge -> do + putCacheTag 0x01 + putPreparedDischarge discharge + PreparedOmitted _location goal -> do + putCacheTag 0x06 + putScopedProposition goal + PreparedFix identities continuation -> do + putCacheTag 0x02 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putPreparedProof continuation + PreparedAssume antecedent continuation -> do + putCacheTag 0x03 + putScopedProposition antecedent + putPreparedProof continuation + PreparedTake identities witness discharge continuation -> do + putCacheTag 0x08 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putScopedProposition witness + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + focus property antecedents target hypothesis result child) -> do + putCacheTag 0x07 + putPreparedSetInductionFocus focus + putScopedProposition property + putCacheList putScopedProposition antecedents + putScopedProposition target + putScopedProposition hypothesis + putScopedProposition result + putPreparedProof child + PreparedHave claim discharge continuation -> do + putCacheTag 0x04 + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + putCacheTag 0x0c + putScopedProposition goal + putScopedProposition reduction + putScopedProposition implication + putPreparedDischarge discharge + putPreparedProof continuation + PreparedCalculate calculation continuation -> do + putCacheTag 0x0d + putPreparedCalculation calculation + putPreparedProof continuation + PreparedSince sinceProposition evidence claim discharge continuation -> do + putCacheTag 0x0e + putScopedProposition sinceProposition + putPreparedSinceEvidence evidence + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSubclaim claim subproof continuation -> do + putCacheTag 0x05 + putScopedProposition claim + putPreparedProof subproof + putPreparedProof continuation + PreparedDefine identity body definitions continuation -> do + putCacheTag 0x09 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedDefineRelational + identity body functionality definitions continuation -> do + putCacheTag 0x11 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putPreparedDischarge functionality + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedByCase caseAnalysis -> do + putCacheTag 0x0f + putPreparedCaseAnalysis caseAnalysis + PreparedByContradiction goal negation falsum child -> do + putCacheTag 0x10 + putScopedProposition goal + putScopedProposition negation + putScopedProposition falsum + putPreparedProof child + PreparedContradiction goal falsum discharge -> do + putCacheTag 0x0a + putScopedProposition goal + putScopedProposition falsum + putPreparedDischarge discharge + PreparedDefineFunction identity graph definition continuation -> do + putCacheTag 0x0b + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm graph + putScopedProposition definition + putPreparedProof continuation + +putPreparedSetInductionFocus + :: PreparedSetInductionFocus + -> CachePut +putPreparedSetInductionFocus = \case + PreparedInitialSetInductionFocus identity index -> do + putCacheTag 0x00 + putCacheNatural (Exact.exactLocalIdValue identity) + putCacheNatural index + PreparedLeadingSetInductionFocus identity -> do + putCacheTag 0x01 + putCacheNatural (Exact.exactLocalIdValue identity) + +putPreparedDischarge :: PreparedDischarge -> CachePut +putPreparedDischarge + (PreparedVampireDischarge + _location justification goal _obligation) = do + putPreparedDischargeSyntax justification goal +putPreparedDischarge + (PreparedSetExtensionality _location goal) = do + putCacheTag 0x03 + putScopedProposition goal + +putPreparedDischargeSyntax + :: PreparedJustification + -> ScopedCheckedCore ObjectId + -> CachePut +putPreparedDischargeSyntax justification goal = do + putPreparedJustification justification + putScopedProposition goal + +putPreparedCalculation :: PreparedCalculation -> CachePut +putPreparedCalculation + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) = do + putCoreTypeCache operandType + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putCacheMaybe putScopedProposition calculationGuard + putCacheList putScopedTerm + (first : (preparedCalculationLinkDestination <$> toList links)) + putCacheList putPreparedDischarge + (preparedCalculationLinkDischarge <$> toList links) + putScopedProposition result + +putPreparedSinceEvidence :: PreparedSinceEvidence -> CachePut +putPreparedSinceEvidence = \case + PreparedSinceExisting local -> do + putCacheTag 0x00 + putPreparedLocalEvidence local + PreparedSinceDischarged discharge local -> do + putCacheTag 0x01 + putPreparedDischarge discharge + putPreparedLocalEvidence local + +putPreparedCaseAnalysis :: PreparedCaseAnalysis -> CachePut +putPreparedCaseAnalysis + (PreparedCaseAnalysis goal cases exhaustive discharge) = do + putScopedProposition goal + putCacheList putPreparedCase (toList cases) + putScopedProposition exhaustive + putPreparedDischarge discharge + +putPreparedCase :: PreparedCase -> CachePut +putPreparedCase (PreparedCase assumption proof) = do + putScopedProposition assumption + putPreparedProof proof + +putPreparedLocalEvidence :: PreparedLocal -> CachePut +putPreparedLocalEvidence + (PreparedLocal ordinal _origin support proposition) = do + putCacheNatural (Backend.localPremiseOrdinalValue ordinal) + putCacheList + (\(identity, coreType) -> do + putCacheNatural (Exact.exactLocalIdValue identity) + putCoreTypeCache coreType) + (Vector.toList support) + putScopedProposition proposition + +implicitAutoProofSyntaxId + :: ScopedCheckedCore ObjectId + -> ProofSyntaxId +implicitAutoProofSyntaxId goal = + proofSyntaxId + (encodeCache do + putCacheTag 0x00 + putPreparedDischargeSyntax PreparedAuto goal) + +putPreparedJustification :: PreparedJustification -> CachePut +putPreparedJustification = \case + PreparedAuto -> + putCacheTag 0x00 + PreparedReferences fingerprints -> do + putCacheTag 0x01 + putCacheList + putSemanticFactOccurrenceFingerprintCache + (toList fingerprints) + PreparedLocalOnly -> + putCacheTag 0x02 + +putScopedProposition + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedProposition proposition = do + putCacheList putCoreTypeCache + (scopedCoreContext proposition) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm proposition) + +putScopedTerm + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedTerm term = do + putCacheList putCoreTypeCache + (scopedCoreContext term) + putCoreTypeCache (scopedCoreType term) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm term) + +proofLocation :: Location -> Raw.Proof -> Location +proofLocation fallback = \case + Raw.Omitted location -> location + Raw.Qed maybeLocation _justification -> + fromMaybe fallback maybeLocation + Raw.Contradiction location _justification -> location + Raw.ByCase location _cases -> location + Raw.ByContradiction location _proof -> location + Raw.BySetInduction location _term _proof -> location + Raw.ByOrdInduction location _proof -> location + Raw.Assume location _statement _proof -> location + Raw.FixSymbolic location _variables _bound _proof -> location + Raw.FixSuchThat location _variables _statement _proof -> location + Raw.Calc location _quantifier _calculation _proof -> location + Raw.TakeVar location _variables _bound _statement _justification _proof -> + location + Raw.TakeNoun location _noun _justification _proof -> location + Raw.Have location _since _statement _justification _proof -> location + Raw.Suffices location _statement _justification _proof -> location + Raw.Subclaim location _statement _subproof _proof -> location + Raw.Define location _variable _expression _proof -> location + Raw.DefineFunction location _function _argument _value _bound _domain _proof -> + location + Raw.DefineFunctionLocal + location _function _argument _value _bound _target _rules _proof -> + location + +throwProof :: ExactProofError -> Prepare value +throwProof = + State.lift . Except.throwError + +liftDriver + :: Declaration.LoweringDriver value + -> Prepare value +liftDriver = + State.lift . Except.lift + +stableUnique :: Ord value => [value] -> [value] +stableUnique = + reverse . snd + . foldl' + (\(seen, reversed) value -> + if value `Set.member` seen + then (seen, reversed) + else + ( Set.insert value seen + , value : reversed + )) + (Set.empty, []) diff --git a/source/Felix/Checking/Exact/Vocabulary.hs b/source/Felix/Checking/Exact/Vocabulary.hs new file mode 100644 index 0000000..a712bf1 --- /dev/null +++ b/source/Felix/Checking/Exact/Vocabulary.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Semantic classification shared by the exact source compilers. +module Felix.Checking.Exact.Vocabulary + ( FixedSemanticMeaning(..) + , fixedSemanticMeaning + , lowerFixedEqualityPredicate + , ExactSymbolClass(..) + , classifyExactSymbol + , FixedSetTermDispatch(..) + , dispatchFixedSetTerm + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Semantic +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map + + +data FixedSemanticMeaning + = FixedEquality + | FixedDisequality + | FixedIntrinsic !CoreIntrinsicTag + | FixedNegatedIntrinsic !CoreIntrinsicTag + deriving stock (Show, Eq) + +fixedSemanticMeaning + :: SemanticGlobalKey + -> Maybe FixedSemanticMeaning +fixedSemanticMeaning key = + Map.lookup key fixedSemanticVocabulary + +-- This inventory owns every exact source form that bypasses global lookup. +fixedSemanticVocabulary + :: Map.Map SemanticGlobalKey FixedSemanticMeaning +fixedSemanticVocabulary = + Map.fromList + [ ( relationKey Raw.EqSymbol + , FixedEquality + ) + , ( SemanticRightAdjective + (Raw.lexicalItemPattern + Lexicon.builtinEqualityRightAdjective) + , FixedEquality + ) + , ( verbKey Lexicon.builtinEqualityVerb + , FixedEquality + ) + , ( relationKey Raw.ElementSymbol + , FixedIntrinsic Member + ) + , ( relationKey Raw.NotElementSymbol + , FixedNegatedIntrinsic Member + ) + , ( relationKey Raw.NeqSymbol + , FixedDisequality + ) + , ( nounKey Lexicon.builtinElementNoun + , FixedIntrinsic Member + ) + , ( expressionKey + (Raw.TokenCons (Raw.Command "emptyset") Raw.End) + , FixedIntrinsic Empty + ) + , ( expressionKey (Raw.mixfixPattern Raw.UnionsSymbol) + , FixedIntrinsic FamilyUnion + ) + , ( expressionKey (unaryCommandPattern "pow") + , FixedIntrinsic PowerSet + ) + , ( expressionKey (unaryCommandPattern "cumul") + , FixedIntrinsic UnivOf + ) + , ( expressionKey (Raw.mixfixPattern Raw.UpairSymbol) + , FixedIntrinsic PairSet + ) + ] + where + relationKey relation = + SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + nounKey item = + let patterns = Raw.lexicalItemSgPlPattern item + in SemanticNoun (Raw.sg patterns) (Raw.pl patterns) + verbKey item = + let patterns = Raw.lexicalItemSgPlPattern item + in SemanticVerb (Raw.sg patterns) (Raw.pl patterns) + expressionKey = SemanticExpressionFunction + +-- | Lower the fixed proposition meanings shared by raw exact elaboration and +-- the reusable internal-formula path. Membership deliberately retains its +-- carrier-aware source lowering and is not handled here. +lowerFixedEqualityPredicate + :: FixedSemanticMeaning + -> [CanonicalTerm global] + -> Maybe (CanonicalTerm global) +lowerFixedEqualityPredicate meaning arguments = + case (meaning, arguments) of + (FixedEquality, [left, right]) -> + Just (CEq TySet left right) + (FixedDisequality, [left, right]) -> + Just (CImp (CEq TySet left right) CFalsum) + _ -> + Nothing + +unaryCommandPattern :: Text -> Raw.Pattern +unaryCommandPattern command = + Raw.TokenCons (Raw.Command command) + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons Raw.InvisibleBraceR Raw.End))) + +data ExactSymbolClass + = ExactClosedLiteral + | ExactFixedPrimitive !FixedSemanticMeaning + | ExactSourceGlobal !(NonEmpty SemanticGlobalKey) + | ExactUnsupportedSymbol + deriving stock (Show, Eq) + +classifyExactSymbol :: Internal.Symbol -> ExactSymbolClass +classifyExactSymbol symbol = + case symbol of + Internal.SymbolInteger{} -> + ExactClosedLiteral + _ -> + case NonEmpty.nonEmpty (semanticKeys symbol) of + Nothing -> + ExactUnsupportedSymbol + Just keys -> + case firstFixed keys of + Just meaning -> + ExactFixedPrimitive meaning + Nothing -> + ExactSourceGlobal keys + where + firstFixed = + foldr + (\key found -> fixedSemanticMeaning key <|> found) + Nothing + +semanticKeys :: Internal.Symbol -> [SemanticGlobalKey] +semanticKeys = \case + Internal.SymbolMixfix symbol -> + [SemanticExpressionFunction (Raw.mixfixPattern symbol)] + Internal.SymbolFun item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticFunctionPhrase (Raw.sg patterns) (Raw.pl patterns)] + Internal.SymbolPredicate predicate -> + case predicate of + Internal.PredicateAdj item -> + [ SemanticLeftAdjective (Raw.lexicalItemPattern item) + , SemanticRightAdjective (Raw.lexicalItemPattern item) + ] + Internal.PredicateVerb item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticVerb (Raw.sg patterns) (Raw.pl patterns)] + Internal.PredicateNoun item -> + let patterns = Raw.lexicalItemSgPlPattern item + in [SemanticNoun (Raw.sg patterns) (Raw.pl patterns)] + Internal.PredicateRelation relation -> + [ SemanticRelation + (Raw.relationSymbolToken relation) + (Raw.relationSymbolParameterArity relation) + ] + Internal.PredicateSymbol{} -> [] + Internal.PredicateNounStruct{} -> [] + Internal.SymbolInteger{} -> [] + +-- | Result of interpreting a symbol already classified by the fixed exact +-- vocabulary as a set-valued term. +data FixedSetTermDispatch global + = NotFixedSetTerm + | LoweredFixedSetTerm !(CanonicalTerm global) + | RejectedFixedSetTerm + deriving stock (Show, Eq) + +-- | Interpret every fixed symbol that can occur in the reusable internal-term +-- lowering. Fixed relations are handled by formula lowering. +dispatchFixedSetTerm + :: Internal.Symbol + -> [CanonicalTerm global] + -> FixedSetTermDispatch global +dispatchFixedSetTerm symbol arguments = + case classifyExactSymbol symbol of + ExactFixedPrimitive meaning -> + case meaning of + FixedIntrinsic intrinsic -> + applyIntrinsic + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + arguments + FixedNegatedIntrinsic _intrinsic -> + RejectedFixedSetTerm + FixedEquality -> + RejectedFixedSetTerm + FixedDisequality -> + RejectedFixedSetTerm + _ -> + NotFixedSetTerm + where + applyIntrinsic term coreType remaining = + case (coreType, remaining) of + (TySet, []) -> + LoweredFixedSetTerm term + (TyArrow TySet resultType, argument : rest) -> + applyIntrinsic + (CApp term argument) + resultType + rest + _ -> + RejectedFixedSetTerm diff --git a/source/Felix/Checking/FinalPrelude.hs b/source/Felix/Checking/FinalPrelude.hs new file mode 100644 index 0000000..9cc43f4 --- /dev/null +++ b/source/Felix/Checking/FinalPrelude.hs @@ -0,0 +1,1266 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Authority-confined construction of the inert final-prelude candidate. +module Felix.Checking.FinalPrelude + ( FinalPreludeCandidate + , finalPreludeParsed + , finalPreludeSyntax + , finalPreludeSemantic + , finalPreludePrefix + , finalPreludeObjects + , PreludePublicRole(..) + , expectedFinalPreludePublicRoles + , FinalPreludeRoleTarget(..) + , finalPreludePublicRole + , FinalPreludeValidationError(..) + , FinalPreludeFailure(..) + , FinalPreludeBuildResult(..) + , buildFinalPreludeCandidate + , buildParsedFinalPreludeCandidate + , validateOmegaFactInventory + ) where + +import Base hiding (Empty) +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Checking.Semantic qualified as Semantic +import Felix.Module +import Felix.Cache.Codec (CacheDigest) +import Felix.Parse +import Felix.Prelude qualified as Prelude +import Felix.Source (ImportRef) +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon qualified as Lexicon + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + + +data FinalPreludeCandidate = FinalPreludeCandidate + !Prelude.ReservedParsedPrelude + !ModuleSyntaxInterface + !SemanticInterface + !Declaration.PendingModulePrefix + !CheckedObjectClosure + !(Map.Map PreludePublicRole FinalPreludeRoleTarget) + +finalPreludeParsed + :: FinalPreludeCandidate + -> Prelude.ReservedParsedPrelude +finalPreludeParsed + (FinalPreludeCandidate parsed _syntax _semantic _prefix _objects + _roles) = + parsed + +finalPreludeSyntax + :: FinalPreludeCandidate + -> ModuleSyntaxInterface +finalPreludeSyntax + (FinalPreludeCandidate _parsed syntax _semantic _prefix _objects + _roles) = + syntax + +finalPreludeSemantic + :: FinalPreludeCandidate + -> SemanticInterface +finalPreludeSemantic + (FinalPreludeCandidate _parsed _syntax semantic _prefix _objects + _roles) = + semantic + +finalPreludePrefix + :: FinalPreludeCandidate + -> Declaration.PendingModulePrefix +finalPreludePrefix + (FinalPreludeCandidate _parsed _syntax _semantic prefix _objects + _roles) = + prefix + +finalPreludeObjects + :: FinalPreludeCandidate + -> CheckedObjectClosure +finalPreludeObjects + (FinalPreludeCandidate _parsed _syntax _semantic _prefix objects + _roles) = + objects + +data FinalPreludeRoleTarget + = FinalPreludeObjectRole !ObjectId + | FinalPreludeTheoremRole !TheoremRef + deriving stock (Show, Eq, Ord) + +-- | Stable public roles exported by the packaged final prelude. +data PreludePublicRole + = PreludeInfinityTheorem + | PreludeOmegaObject + | PreludeOmegaDefiningEquation + | PreludeNaturalsAlias + | PreludeNaturalsInductiveTheorem + | PreludeNaturalsMinimalTheorem + deriving stock (Show, Eq, Ord, Enum, Bounded) + +expectedFinalPreludePublicRoles :: Set PreludePublicRole +expectedFinalPreludePublicRoles = + Set.fromList [minBound .. maxBound] + +finalPreludePublicRole + :: FinalPreludeCandidate + -> PreludePublicRole + -> Maybe FinalPreludeRoleTarget +finalPreludePublicRole + (FinalPreludeCandidate _parsed _syntax _semantic _prefix _objects + roles) role = + Map.lookup role roles + +data FinalPreludeValidationError + = FinalPreludePackagedInputMismatch + | FinalPreludeSemanticEnvironmentMismatch + | FinalPreludeDeclarationAssociationMismatch + | FinalPreludeUnexpectedObject !ObjectId + | FinalPreludeDeclarationMissing !Text + | FinalPreludeDeclarationDuplicate !Text + | FinalPreludeDeclarationShapeMismatch !Text + | FinalPreludeDefinitionContentMismatch !Text + | FinalPreludeFactContentMismatch !Text + | FinalPreludeValidationInventoryMismatch !DeclarationSlot + | FinalPreludeAuthorityMismatch !DeclarationSlot + | FinalPreludeBaseStructureMismatch + | FinalPreludePublicRoleMismatch !PreludePublicRole + deriving stock (Show, Eq) + +data FinalPreludeFailure + = FinalPreludeWrongOwner !ModuleName + | FinalPreludeHasImports ![ImportRef] + | FinalPreludeHasSyntaxImports ![SyntaxInterfaceId] + | FinalPreludeUnsupportedBlock !Location + | FinalPreludeUnmatchedProof !Location + | FinalPreludeExactDeclarationFailed !Exact.ExactCompileError + | FinalPreludeExactProofFailed !ExactProof.ExactProofError + | FinalPreludeOmittedProof !Location + | FinalPreludeDeclarationFailed !Declaration.DeclarationError + | FinalPreludeSealFailed !SemanticInterfaceError + | FinalPreludeValidationFailed !FinalPreludeValidationError + deriving stock (Show, Eq) + +data FinalPreludeBuildResult + = FinalPreludeSourceLoadFailed !Prelude.PreludeLoadError + | FinalPreludeSourceParseFailed !Prelude.PreludeParseError + | FinalPreludeBuilt !FinalPreludeCandidate + | FinalPreludeBuildFailed + !FinalPreludeFailure + !Declaration.PendingModulePrefix + | FinalPreludeBuildOpenFailed !Declaration.DriverOpenError + +data PlannedPreludeDeclaration + = PlannedPreludeBinding + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) + | PlannedPreludeFoundation + !(Declaration.PlannedDeclaration + ExactProof.CheckedFinalPreludeFoundationAuthorization) + | PlannedPreludeProof + !(Declaration.PlannedDeclaration + ExactProof.CheckedExactProofAuthorization) + | PlannedPreludeBase + !(Declaration.PlannedDeclaration ()) + +data PreludePlanningFailure + = PreludePlanningAction !FinalPreludeFailure + | PreludePlanningDeclaration !Declaration.DeclarationError + +data PreludeModulePlan = PreludeModulePlan + ![PlannedPreludeDeclaration] + !(Maybe PreludePlanningFailure) + +buildFinalPreludeCandidate + :: CheckedFoundation + -> Declaration.VampireResolver + -> IO FinalPreludeBuildResult +buildFinalPreludeCandidate foundation resolver = + Prelude.loadReservedPreludeSourceInput >>= \case + Left failure -> + pure (FinalPreludeSourceLoadFailed failure) + Right source -> + Prelude.parseReservedPreludeSource source >>= \case + Left failure -> + pure (FinalPreludeSourceParseFailed failure) + Right parsed -> + buildParsedFinalPreludeCandidate + foundation parsed resolver + +-- The production acquisition path establishes packaged provenance before +-- passing its already parsed source here. The explicit parsed seam avoids a +-- second load and parse on a cache miss. +buildParsedFinalPreludeCandidate + :: CheckedFoundation + -> Prelude.ReservedParsedPrelude + -> Declaration.VampireResolver + -> IO FinalPreludeBuildResult +buildParsedFinalPreludeCandidate foundation parsed resolver = + case validatePackagedPreludeInput parsed syntax of + Left failure -> do + case emptyPrefix of + Left prefixFailure -> + pure + (FinalPreludeBuildOpenFailed + (Declaration.DriverInitialPrefixError + prefixFailure)) + Right prefix -> + pure (FinalPreludeBuildFailed failure prefix) + Right () -> do + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + resolver + -- The confined builder never consults stored validation. + Declaration.FreshValidation + do + PreludeModulePlan declarations terminal <- + Declaration.runProspectiveLoweringDriver + (planBlocks [] 0 blocks) + traverse_ admitPreludeDeclaration declarations + traverse_ failPreludePlanning terminal + pure case outcome of + Left failure -> + FinalPreludeBuildOpenFailed failure + Right (Declaration.DriverFailed failure prefix) -> + FinalPreludeBuildFailed + (case failure of + Declaration.DriverDeclarationFailed err -> + FinalPreludeDeclarationFailed err + Declaration.DriverActionFailed err -> + err) + prefix + Right (Declaration.DriverSealFailed failure prefix) -> + FinalPreludeBuildFailed + (FinalPreludeSealFailed failure) + prefix + Right (Declaration.DriverSucceeded + () semantic prefix objects) -> + case validateFinalPrelude + foundation parsed semantic prefix objects of + Left failure -> + FinalPreludeBuildFailed + (FinalPreludeValidationFailed failure) + prefix + Right roles -> + FinalPreludeBuilt + (FinalPreludeCandidate + parsed syntax semantic prefix objects roles) + where + identified = Prelude.reservedParsedPreludeModule parsed + blocks = identifiedParsedModuleBlocks identified + occurrences = identifiedParsedModuleSyntaxOccurrences identified + syntax = identifiedParsedModuleSyntaxInterface identified + + emptyPrefix = + Declaration.emptyPendingModulePrefix + <$> initialPrefixContextId + (theoryId foundation) + preludeModuleName + [] + + planBlocks completed _blockIndex [] = do + planBaseStructure >>= \case + Left failure -> + pure + (PreludeModulePlan + (reverse completed) + (Just failure)) + Right base -> + pure + (PreludeModulePlan + (reverse (base : completed)) + Nothing) + planBlocks completed blockIndex (block : remaining) = + case block of + Raw.BlockClaim{} -> + case remaining of + Raw.BlockProof _location proof _end : rest -> do + continue completed (blockIndex + 2) rest + =<< planOrdinaryProof block (Just proof) + _ -> do + continue completed (blockIndex + 1) remaining + =<< planImplicitClaim block + Raw.BlockProof location _proof _end -> + pure + (PreludeModulePlan + (reverse completed) + (Just + (PreludePlanningAction + (FinalPreludeUnmatchedProof location)))) + Raw.BlockAbbr{} -> do + continue completed (blockIndex + 1) remaining + =<< planBinding blockIndex block + Raw.BlockDefn{} -> do + continue completed (blockIndex + 1) remaining + =<< planBinding blockIndex block + _ -> + pure + (PreludeModulePlan + (reverse completed) + (Just + (PreludePlanningAction + (FinalPreludeUnsupportedBlock + (locate block))))) + where + continue accumulated nextIndex rest = \case + Left failure -> + pure + (PreludeModulePlan + (reverse accumulated) + (Just failure)) + Right declaration -> + planBlocks (declaration : accumulated) nextIndex rest + + planBaseStructure = do + slot <- Declaration.nextDeclarationSlotLowering + theory <- Declaration.currentTheoryLowering + let seed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot 0) + coreType = TyArrow TySet TySet + content = OpaqueObjectContent theory seed coreType + identity = opaqueObjectId theory seed coreType + asserted = assertedObject identity content + structurePhrase = + semanticStructurePhrase Lexicon._Onesorted + operation = + semanticStructureOperation Raw.CarrierSymbol identity + descriptor <- + either + (pure + . Left + . PreludePlanningDeclaration + . Declaration.DeclarationEnvironmentFailed) + (pure . Right) + (semanticStructureDescriptor + structurePhrase Nothing [] [operation]) + case descriptor of + Left failure -> pure (Left failure) + Right checkedDescriptor -> + planPreludeChecked PlannedPreludeBase + (Declaration.checkedCompiledDeclaration + (declarationSyntaxId + "felix-final-prelude-base-structure-v1") + [asserted] [] [] [checkedDescriptor] [] ()) + + planBinding blockIndex block = do + prepared <- + Exact.prepareExactDeclaration + block + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactDeclarationFailed failure))) + Right declaration -> do + Exact.lowerPreparedExactBinding declaration >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeBinding checked + + planImplicitClaim block = do + foundationClaim <- + ExactProof.prepareFinalPreludeFoundationClaim + foundation block Nothing + case foundationClaim of + Right claim -> do + ExactProof.lowerPreparedFinalPreludeFoundationClaim claim + >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeFoundation checked + Left ExactProof.ExactProofFoundationLeafTargetMismatch{} -> + planOrdinaryProof block Nothing + Left ExactProof.ExactProofFoundationLeafRequiresImplicitAuto{} -> + planOrdinaryProof block Nothing + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactProofFailed failure))) + + planOrdinaryProof block explicitProof = do + prepared <- + ExactProof.prepareExactProof block explicitProof + case prepared of + Left failure -> + pure + (Left + (PreludePlanningAction + (FinalPreludeExactProofFailed failure))) + Right proof + | Just location <- + ExactProof.preparedExactProofFirstOmission proof -> + pure + (Left + (PreludePlanningAction + (FinalPreludeOmittedProof location))) + | otherwise -> + ExactProof.lowerPreparedExactProof proof >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planPreludeChecked PlannedPreludeProof checked + + planPreludeChecked + :: forall body. + (Declaration.PlannedDeclaration body + -> PlannedPreludeDeclaration) + -> Declaration.CheckedDeclaration body + -> Declaration.LoweringDriver + (Either PreludePlanningFailure PlannedPreludeDeclaration) + planPreludeChecked constructor checked = + Declaration.planCheckedDeclaration checked >>= \case + Left failure -> planningDeclarationFailure failure + Right planned -> pure (Right (constructor planned)) + + planningDeclarationFailure = + pure . Left . PreludePlanningDeclaration + + admitPreludeDeclaration = \case + PlannedPreludeBinding planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactBinding) + PlannedPreludeFoundation planned -> + void + (Declaration.admitPlannedCheckedDeclaration planned + ExactProof.authorizeCheckedFinalPreludeFoundationClaim) + PlannedPreludeProof planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactProof.authorizeCheckedExactProof) + PlannedPreludeBase planned -> + void + (Declaration.admitPlannedCheckedDeclaration planned + (\() stages -> + unless + (null stages) + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 0 (length stages))))) + + failPreludePlanning = \case + PreludePlanningAction failure -> + Declaration.failModuleDriver failure + PreludePlanningDeclaration failure -> + Declaration.failDeclarationDriver failure + +data PreludeDeclaration = PreludeDeclaration + !Raw.Block + !Declaration.CommittedDeclarationBatch + +data PreludeDefinitionKind + = PreludeDefinition + | PreludeAbbreviation + +data PreludeDefinitionView = PreludeDefinitionView + !ObjectId + !SemanticGlobalTarget + +validateFinalPrelude + :: CheckedFoundation + -> Prelude.ReservedParsedPrelude + -> SemanticInterface + -> Declaration.PendingModulePrefix + -> CheckedObjectClosure + -> Either + FinalPreludeValidationError + (Map.Map PreludePublicRole FinalPreludeRoleTarget) +validateFinalPrelude foundation parsed semantic prefix objects = do + (declarations, baseStructure) <- + associatePreludeDeclarations parsed prefix + validateConfinedAuthority + foundation semantic objects declarations baseStructure + resolveAndValidatePublicRoles foundation objects declarations + +resolveAndValidatePublicRoles + :: CheckedFoundation + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Either + FinalPreludeValidationError + (Map.Map PreludePublicRole FinalPreludeRoleTarget) +resolveAndValidatePublicRoles foundation objects declarations = do + successor <- + expectDefinition + foundation objects declarations + "prelude_successor" + PreludeDefinition + (TyArrow TySet TySet) + expectedSuccessorBody + let successorId = definitionViewObject successor + + inductive <- + expectDefinition + foundation objects declarations + "prelude_inductive" + PreludeDefinition + (TyArrow TySet TyProp) + (expectedInductiveBody successorId) + let inductiveId = definitionViewObject inductive + + u0 <- + expectDefinition + foundation objects declarations + "prelude_u0" + PreludeDefinition + TySet + (applyIntrinsic UnivOf (CIntrinsic Empty)) + let u0Id = definitionViewObject u0 + + let omegaBody = expectedOmegaBody u0Id inductiveId + omega <- + expectDefinition + foundation objects declarations + "prelude_omega" + PreludeDefinition + TySet + omegaBody + let omegaId = definitionViewObject omega + + omegaConstruction <- + expectedOmegaConstruction objects omegaBody + omegaDerived <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + omegaId + omegaConstruction) + + naturals <- + expectDefinition + foundation objects declarations + "prelude_naturals" + PreludeAbbreviation + TySet + (CGlobal omegaId) + case definitionViewTarget naturals of + TransparentExpansion{} -> pure () + _ -> + Left + (FinalPreludeDefinitionContentMismatch + "prelude_naturals") + + (infinity, infinityTarget) <- + expectClaim declarations "prelude_infinity" + validateInfinityTarget objects inductiveId infinityTarget + omegaDeclaration <- findDeclaration "prelude_omega" declarations + omegaEquation <- + validateOmegaDeclaration + objects + omegaId + omegaBody + omegaDerived + omegaDeclaration + let inductiveOmega = + CApp (CGlobal inductiveId) (CGlobal omegaId) + minimalOmega = expectedMinimality inductiveId omegaId + naturalsInductive <- + fst + <$> expectClaimTarget + declarations + "prelude_naturals_inductive" + inductiveOmega + naturalsMinimal <- + fst + <$> expectClaimTarget + declarations + "prelude_naturals_minimal" + minimalOmega + + let roles = Map.fromList + [ ( PreludeInfinityTheorem + , FinalPreludeTheoremRole infinity + ) + , ( PreludeOmegaObject + , FinalPreludeObjectRole omegaId + ) + , ( PreludeOmegaDefiningEquation + , FinalPreludeTheoremRole omegaEquation + ) + , ( PreludeNaturalsAlias + , FinalPreludeObjectRole omegaId + ) + , ( PreludeNaturalsInductiveTheorem + , FinalPreludeTheoremRole naturalsInductive + ) + , ( PreludeNaturalsMinimalTheorem + , FinalPreludeTheoremRole naturalsMinimal + ) + ] + unless + (Map.keysSet roles == expectedFinalPreludePublicRoles) + (Left + (FinalPreludePublicRoleMismatch + PreludeInfinityTheorem)) + pure roles + +expectedOmegaConstruction + :: CheckedObjectClosure + -> CanonicalTerm ObjectId + -> Either + FinalPreludeValidationError + (NamedSetConstruction ObjectId) +expectedOmegaConstruction objects = \case + CApp (CApp (CIntrinsic Sep) bound) (CLam TySet predicate) -> do + checkedBound <- checked [] bound + checkedPredicate <- checked [TySet] predicate + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (checkedSeparationConstruction + (`lookupCheckedObjectType` objects) + checkedBound + checkedPredicate) + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + where + checked context term = + first + (const + (FinalPreludeFactContentMismatch + "prelude_omega")) + (checkScopedCanonicalCore + (`lookupCheckedObjectType` objects) + context + term) + +validateOmegaDeclaration + :: CheckedObjectClosure + -> ObjectId + -> CanonicalTerm ObjectId + -> NamedSetConstructionFact + -> PreludeDeclaration + -> Either FinalPreludeValidationError TheoremRef +validateOmegaDeclaration objects omegaId omegaBody derived declaration = do + let batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + omegaContent <- case lookupCheckedObjectContent omegaId objects of + Just content@TransparentObjectContent{} -> pure content + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + unless + ( declarationDeltaObjects delta == [omegaId] + && case Declaration.committedBatchObjects batch of + [asserted] -> + assertedObjectId asserted == omegaId + && assertedObjectContent asserted == omegaContent + _ -> False + && null (Declaration.committedBatchProofValidations batch) + ) + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + certificates <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + (Right . declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + validateOmegaFactInventory + omegaId + omegaBody + (namedSetConstructionFactProposition derived) + (namedSetConstructionFactDescriptor derived) + (declarationDeltaFacts delta) + (declarationDeltaAliases delta) + (Declaration.committedBatchPropositions batch) + certificates + +-- | Purpose-specific audit of the distinguished Omega definition. It is +-- deliberately not a general declaration manifest: the confined prelude has +-- exactly one declaration whose public role requires this two-fact shape. +-- The explicit arguments also provide a narrow pure seam for corruption +-- regression tests. +validateOmegaFactInventory + :: ObjectId + -> CanonicalTerm ObjectId + -> FrozenCheckedCore ObjectId + -> CacheDigest + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [CheckedPropositionContent] + -> [Authority.ValidationCertificate] + -> Either FinalPreludeValidationError TheoremRef +validateOmegaFactInventory + omegaId omegaBody expectedExtensional expectedDescriptor + facts aliases propositions certificates = do + (equationOccurrence, extensionalOccurrence) <- + case facts of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + (equationCertificate, extensionalCertificate) <- + case certificates of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + case aliases of + [alias] + | semanticAliasName alias == semanticName "prelude_omega" + , semanticAliasTarget alias + == semanticFactFingerprint equationOccurrence -> + pure () + _ -> mismatch + equation <- propositionFor equationOccurrence + extensional <- propositionFor extensionalOccurrence + unless + ( length propositions == 2 + && semanticFactSearchEligibility equationOccurrence + == SearchIneligible + && frozenCoreTerm (checkedPropositionTerm equation) + == CEq TySet (CGlobal omegaId) omegaBody + && Authority.validationTarget equationCertificate + == semanticFactAuthority equationOccurrence + && Authority.validationDirectAuthorization equationCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation omegaId) + && semanticFactSearchEligibility extensionalOccurrence + == SearchEligible + && checkedPropositionTerm extensional == expectedExtensional + && Authority.validationTarget extensionalCertificate + == semanticFactAuthority extensionalOccurrence + && Authority.validationDirectAuthorization extensionalCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + omegaId expectedDescriptor) + ) + mismatch + pure + (Authority.factAuthorityTheorem + (semanticFactAuthority equationOccurrence)) + where + mismatch = + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + + propositionFor occurrence = + case List.filter + ((== semanticFactProposition occurrence) + . checkedPropositionId) + propositions of + [proposition] -> Right proposition + _ -> mismatch + +validatePackagedPreludeInput + :: Prelude.ReservedParsedPrelude + -> ModuleSyntaxInterface + -> Either FinalPreludeFailure () +validatePackagedPreludeInput parsed syntax + | freshModuleInputOwner input /= preludeModuleName = + Left (FinalPreludeWrongOwner (freshModuleInputOwner input)) + | not (null (freshModuleInputImports input)) = + Left (FinalPreludeHasImports (freshModuleInputImports input)) + | not (null (moduleSyntaxDirectInputs syntax)) = + Left + (FinalPreludeHasSyntaxImports + (moduleSyntaxDirectInputs syntax)) + | otherwise = do + unless + ( freshModuleInputBinding input == FreshReservedSource + && freshModuleInputLocationPath input + == Prelude.preludeDiagnosticLabel + && freshModuleInputSyntaxInterface input == syntax + && identifiedParsedModuleSyntaxInterface identified == syntax + ) + (Left + (FinalPreludeValidationFailed + FinalPreludePackagedInputMismatch)) + where + input = Prelude.reservedParsedPreludeInput parsed + identified = Prelude.reservedParsedPreludeModule parsed + +associatePreludeDeclarations + :: Prelude.ReservedParsedPrelude + -> Declaration.PendingModulePrefix + -> Either + FinalPreludeValidationError + ([PreludeDeclaration], Declaration.CommittedDeclarationBatch) +associatePreludeDeclarations parsed prefix = do + case List.splitAt (length sourceDeclarations) batches of + (sourceBatches, [baseStructure]) + | length sourceBatches == length sourceDeclarations -> + pure + ( zipWith PreludeDeclaration + sourceDeclarations sourceBatches + , baseStructure + ) + _ -> Left FinalPreludeDeclarationAssociationMismatch + where + sourceDeclarations = + [ block + | block <- + identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed) + , case block of + Raw.BlockProof{} -> False + _ -> True + ] + batches = Declaration.pendingModulePrefixBatches prefix + +validateConfinedAuthority + :: CheckedFoundation + -> SemanticInterface + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Declaration.CommittedDeclarationBatch + -> Either FinalPreludeValidationError () +validateConfinedAuthority + foundation semantic objects declarations baseStructure = do + unless + ( semanticInterfaceOwner semantic == preludeModuleName + && null (semanticInterfaceDirectInputs semantic) + ) + (Left FinalPreludeSemanticEnvironmentMismatch) + traverse_ requireTransparent + [ identity + | declaration <- declarations + , identity <- + declarationDeltaObjects + (Declaration.committedBatchDelta + (declarationBatch declaration)) + ] + traverse_ (validateDeclarationAuthority foundation objects) declarations + validateBaseStructure foundation objects baseStructure + where + requireTransparent identity = + case lookupCheckedObjectContent identity objects of + Just TransparentObjectContent{} -> pure () + _ -> Left (FinalPreludeUnexpectedObject identity) + +validateBaseStructure + :: CheckedFoundation + -> CheckedObjectClosure + -> Declaration.CommittedDeclarationBatch + -> Either FinalPreludeValidationError () +validateBaseStructure foundation objects batch = do + let slot = Declaration.committedBatchSlot batch + delta = Declaration.committedBatchDelta batch + environment = declarationDeltaEnvironment delta + structurePhrase = semanticStructurePhrase Lexicon._Onesorted + expectedSeed = + opaqueDeclarationSeed + (declarationSlotModule slot) + (declarationSlotOrdinal slot) + StructureDeclaration + (generatedObjectSlot 0) + expectedType = TyArrow TySet TySet + expectedObject = opaqueObjectId (theoryId foundation) expectedSeed expectedType + expectedContent = + OpaqueObjectContent + (theoryId foundation) + expectedSeed + expectedType + descriptor <- + case semanticEnvironmentStructures environment of + [single] -> Right single + _ -> Left FinalPreludeBaseStructureMismatch + expectedDescriptor <- + first (const FinalPreludeBaseStructureMismatch) + (semanticStructureDescriptor + structurePhrase + Nothing + [] + [semanticStructureOperation Raw.CarrierSymbol expectedObject]) + unless + ( declarationSlotModule slot == preludeModuleName + && descriptor == expectedDescriptor + && null (semanticEnvironmentBindings environment) + && declarationDeltaObjects delta == [expectedObject] + && null (declarationDeltaFacts delta) + && null (declarationDeltaAliases delta) + && null (declarationDeltaPropositions delta) + && Declaration.committedBatchObjects batch + == [assertedObject expectedObject expectedContent] + && null (Declaration.committedBatchPropositions batch) + && null (Declaration.committedBatchProofValidations batch) + && maybe + False + (null . declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + && lookupCheckedObjectContent expectedObject objects + == Just expectedContent + ) + (Left FinalPreludeBaseStructureMismatch) + +validateDeclarationAuthority + :: CheckedFoundation + -> CheckedObjectClosure + -> PreludeDeclaration + -> Either FinalPreludeValidationError () +validateDeclarationAuthority foundation objects declaration = do + unless + (fmap Authority.validationTarget certificates + == fmap semanticFactAuthority facts) + (Left (FinalPreludeValidationInventoryMismatch slot)) + traverse_ validateOne (zip facts certificates) + where + batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + slot = Declaration.committedBatchSlot batch + facts = declarationDeltaFacts delta + certificates = + ( Semantic.proofValidationRecordCertificate + <$> Declaration.committedBatchProofValidations batch + ) + <> maybe + [] + Semantic.declarationValidationRecordCertificates + (Declaration.committedBatchDeclarationValidation batch) + + validateOne (occurrence, certificate) = do + unless + (Authority.factAuthoritySafety + (semanticFactAuthority occurrence) + == Authority.cleanAuthoritySafety) + (Left (FinalPreludeAuthorityMismatch slot)) + proposition <- + maybe + (Left (FinalPreludeValidationInventoryMismatch slot)) + Right + (List.find + ((== semanticFactProposition occurrence) + . checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + let target = frozenCoreTerm (checkedPropositionTerm proposition) + case Authority.validationDirectAuthorization certificate of + Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) -> do + let expected = + frozenCoreTerm + (mapFrozenGlobals absurd + (foundationAxiomFrozen foundation tag)) + unless (target == expected) + (Left (FinalPreludeAuthorityMismatch slot)) + Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation identity) -> + case lookupCheckedObjectContent identity objects of + Just (TransparentObjectContent _theory coreType body) -> + unless + (target == CEq coreType (CGlobal identity) body) + (Left (FinalPreludeAuthorityMismatch slot)) + _ -> + Left (FinalPreludeAuthorityMismatch slot) + Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + identity _descriptor) -> + case lookupCheckedObjectContent identity objects of + Just TransparentObjectContent{} + | semanticFactSearchEligibility occurrence + == SearchEligible -> + pure () + _ -> + Left (FinalPreludeAuthorityMismatch slot) + Authority.CheckedSourceProof requests -> + unless + ( not (null requests) + && case declarationBlock declaration of + Raw.BlockClaim{} -> True + _ -> False + ) + (Left (FinalPreludeAuthorityMismatch slot)) + _ -> + Left (FinalPreludeAuthorityMismatch slot) + +expectDefinition + :: CheckedFoundation + -> CheckedObjectClosure + -> [PreludeDeclaration] + -> Text + -> PreludeDefinitionKind + -> CoreType + -> CanonicalTerm ObjectId + -> Either FinalPreludeValidationError PreludeDefinitionView +expectDefinition foundation objects declarations marker kind coreType body = do + declaration <- findDeclaration marker declarations + let delta = + Declaration.committedBatchDelta + (declarationBatch declaration) + unless + (case (kind, declarationBlock declaration) of + (PreludeDefinition, Raw.BlockDefn{}) -> True + (PreludeAbbreviation, Raw.BlockAbbr{}) -> True + _ -> False) + (Left (FinalPreludeDeclarationShapeMismatch marker)) + binding <- + case semanticEnvironmentBindings + (declarationDeltaEnvironment delta) of + [single] -> Right single + _ -> Left (FinalPreludeDeclarationShapeMismatch marker) + let target = semanticGlobalBindingTarget binding + identity = semanticGlobalTargetObject target + unless + (case (kind, target) of + (PreludeDefinition, GlobalReference{}) -> True + (PreludeAbbreviation, TransparentExpansion{}) -> True + _ -> False) + (Left (FinalPreludeDefinitionContentMismatch marker)) + content <- + maybe + (Left (FinalPreludeDefinitionContentMismatch marker)) + Right + (lookupCheckedObjectContent identity objects) + let expected = + TransparentObjectContent + (theoryId foundation) + coreType + body + unless (content == expected) + (Left (FinalPreludeDefinitionContentMismatch marker)) + pure (PreludeDefinitionView identity target) + +expectClaim + :: [PreludeDeclaration] + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectClaim declarations marker = do + declaration <- findDeclaration marker declarations + unless + (case declarationBlock declaration of + Raw.BlockClaim{} -> True + _ -> False) + (Left (FinalPreludeDeclarationShapeMismatch marker)) + expectFact declarations marker + +expectClaimTarget + :: [PreludeDeclaration] + -> Text + -> CanonicalTerm ObjectId + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectClaimTarget declarations marker expected = do + result@(_theorem, actual) <- expectClaim declarations marker + unless + (actual == expected) + (Left (FinalPreludeFactContentMismatch marker)) + pure result + +expectFact + :: [PreludeDeclaration] + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectFact declarations marker = do + declaration <- findDeclaration marker declarations + unless + (length + (declarationDeltaFacts + (Declaration.committedBatchDelta + (declarationBatch declaration))) == 1) + (Left (FinalPreludeFactContentMismatch marker)) + expectAliasedFact declaration marker + +expectAliasedFact + :: PreludeDeclaration + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectAliasedFact declaration marker = do + let batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + expectedAlias = semanticName marker + fingerprint <- case declarationDeltaAliases delta of + [alias] + | semanticAliasName alias == expectedAlias -> + Right (semanticAliasTarget alias) + _ -> Left (FinalPreludeFactContentMismatch marker) + occurrence <- case List.filter + ((== fingerprint) . semanticFactFingerprint) + (declarationDeltaFacts delta) of + [single] -> Right single + _ -> Left (FinalPreludeFactContentMismatch marker) + proposition <- + maybe + (Left (FinalPreludeFactContentMismatch marker)) + Right + (List.find + ((== semanticFactProposition occurrence) + . checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + pure + ( Authority.factAuthorityTheorem + (semanticFactAuthority occurrence) + , frozenCoreTerm (checkedPropositionTerm proposition) + ) + +validateInfinityTarget + :: CheckedObjectClosure + -> ObjectId + -> CanonicalTerm ObjectId + -> Either FinalPreludeValidationError () +validateInfinityTarget objects inductive = \case + CApp (CGlobal predicate) (CGlobal witness) + | predicate == inductive -> + case lookupCheckedObjectContent witness objects of + Just TransparentObjectContent{} -> pure () + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_infinity") + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_infinity") + +findDeclaration + :: Text + -> [PreludeDeclaration] + -> Either FinalPreludeValidationError PreludeDeclaration +findDeclaration marker declarations = + case List.filter ((== marker) . declarationMarker) declarations of + [] -> Left (FinalPreludeDeclarationMissing marker) + [single] -> Right single + _ -> Left (FinalPreludeDeclarationDuplicate marker) + +declarationBlock :: PreludeDeclaration -> Raw.Block +declarationBlock (PreludeDeclaration block _batch) = + block + +declarationBatch + :: PreludeDeclaration + -> Declaration.CommittedDeclarationBatch +declarationBatch (PreludeDeclaration _block batch) = + batch + +declarationMarker :: PreludeDeclaration -> Text +declarationMarker = + fromMaybe "<unmarked>" . blockMarkerText . declarationBlock + +definitionViewObject :: PreludeDefinitionView -> ObjectId +definitionViewObject (PreludeDefinitionView identity _target) = + identity + +definitionViewTarget + :: PreludeDefinitionView + -> SemanticGlobalTarget +definitionViewTarget (PreludeDefinitionView _identity target) = + target + +blockMarkerText :: Raw.Block -> Maybe Text +blockMarkerText = fmap (\(Raw.Marker marker) -> marker) . \case + Raw.BlockAxiom _location _title marker _axiom -> Just marker + Raw.BlockClaim _kind _location _title marker _claim -> Just marker + Raw.BlockDefn _location _title marker _definition -> Just marker + Raw.BlockAbbr _location _title marker _abbreviation -> Just marker + Raw.BlockData _location _title marker _datatype -> Just marker + Raw.BlockInductive _location _title marker _inductive -> Just marker + Raw.BlockSig _location _title marker _assumptions _signature -> Just marker + Raw.BlockStruct _location _title marker _structure -> Just marker + Raw.BlockProof{} -> Nothing + +expectedSuccessorBody :: CanonicalTerm ObjectId +expectedSuccessorBody = + CLam TySet + (canonicalSetInsert (CBound 0) (CBound 0)) + +expectedInductiveBody :: ObjectId -> CanonicalTerm ObjectId +expectedInductiveBody successor = + CLam TySet + (logicalAnd + (memberTerm (CIntrinsic Empty) (CBound 0)) + (CForall TySet + (CImp + (memberTerm (CBound 0) (CBound 1)) + (memberTerm + (CApp (CGlobal successor) (CBound 0)) + (CBound 1))))) + +expectedOmegaBody + :: ObjectId + -> ObjectId + -> CanonicalTerm ObjectId +expectedOmegaBody u0 inductive = + CApp + (CApp (CIntrinsic Sep) (CGlobal u0)) + (CLam TySet + (CForall TySet + (CImp + (CApp (CGlobal inductive) (CBound 0)) + (memberTerm (CBound 1) (CBound 0))))) + +expectedMinimality + :: ObjectId + -> ObjectId + -> CanonicalTerm ObjectId +expectedMinimality inductive omega = + CForall TySet + (CImp + (CApp (CGlobal inductive) (CBound 0)) + (CForall TySet + (CImp + (memberTerm (CBound 0) (CGlobal omega)) + (memberTerm (CBound 0) (CBound 1))))) + +applyIntrinsic + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic intrinsic argument = + CApp (CIntrinsic intrinsic) argument + +applyIntrinsic2 + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic2 intrinsic firstArgument secondArgument = + CApp + (CApp (CIntrinsic intrinsic) firstArgument) + secondArgument + +memberTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +memberTerm = + applyIntrinsic2 Member + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + CImp + (CImp left (CImp right CFalsum)) + CFalsum diff --git a/source/Felix/Checking/Foundation.hs b/source/Felix/Checking/Foundation.hs new file mode 100644 index 0000000..5852901 --- /dev/null +++ b/source/Felix/Checking/Foundation.hs @@ -0,0 +1,1037 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The one compiled monomorphic HOL/HOTG foundation. +-- +-- Constructing 'CheckedFoundation' requires exact manifest coverage, closed +-- well-typed schemas, and structural backend classification. This gate +-- certifies manifest conformance only; it is not a consistency proof. +module Felix.Checking.Foundation + ( FoundationAxiomTag(..) + , KernelRuleTag(..) + , KernelRuleSignature(..) + , FoundationRuleInput(..) + , FoundationBackendClass(..) + , FofExclusion(..) + , FoundationAxiomInput(..) + , FoundationManifestError(..) + , FoundationManifestAudit + , auditFoundationManifest + , compiledFoundationIntrinsicRows + , compiledFoundationRuleRows + , compiledFoundationAxiomRows + , CheckedFoundation + , checkedFoundation + , foundationAxiomProposition + , foundationAxiomFrozen + , foundationAxiomBackendClass + , foundationRuleSignature + , foundationAxiomDependencies + , classifyCanonicalFofStructure + , classifyFrozenCore + ) where + +import Base hiding (Empty) +import Felix.Checking.Core + +import Control.Monad (unless) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The complete axiom inventory. Ordinary implication, quantifier, equality, +-- and falsum rules are dedicated kernel operations rather than manifest rows. +data FoundationAxiomTag + = EmptyCharacteristic + | PairSetCharacteristic + | FamilyUnionCharacteristic + | PowerSetCharacteristic + | SeparationCharacteristic + | ReplacementCharacteristic + | SetChooseWitness + | SetExtensionality + | SetInduction + | PropositionalExtensionality + | DoubleNegationElim + | UnivOfContains + | UnivOfTransitive + | UnivOfFamilyUnionClosed + | UnivOfPowerSetClosed + | UnivOfReplacementClosed + | UnivOfMinimal + deriving stock (Show, Eq, Ord, Enum, Bounded) + +-- | The complete guarded-rule inventory. +data KernelRuleTag + = SetLfpBound + | SetLfpLeast + | SetLfpFixed + | SetLfpInduct + deriving stock (Show, Eq, Ord, Enum, Bounded) + +data KernelRuleSignature = KernelRuleSignature + ![CoreType] + !Natural + deriving stock (Show, Eq) + +data FoundationRuleInput = FoundationRuleInput + !KernelRuleTag + !KernelRuleSignature + deriving stock (Show, Eq) + +data FofExclusion + = HigherOrderBinder !CoreType + | HigherOrderEquality !CoreType + | HigherOrderLambda + | HigherOrderIntrinsic !CoreIntrinsicTag + deriving stock (Show, Eq, Ord) + +data FoundationBackendClass + = FoundationFofProjectable + | FoundationRequiresTh0 !(NonEmpty FofExclusion) + deriving stock (Show, Eq) + +-- | One proposed manifest row. This is deliberately not an authority-bearing +-- fact; only the fixed compiled rows can produce 'CheckedFoundation'. +data FoundationAxiomInput = FoundationAxiomInput + !FoundationAxiomTag + !(CoreSyntax Void Natural) + !FoundationBackendClass + +data FoundationManifestError + = MissingFoundationIntrinsic !CoreIntrinsicTag + | DuplicateFoundationIntrinsic !CoreIntrinsicTag + | FoundationIntrinsicTypeMismatch + !CoreIntrinsicTag + !CoreType + !CoreType + | MissingFoundationRule !KernelRuleTag + | DuplicateFoundationRule !KernelRuleTag + | FoundationRuleSignatureMismatch + !KernelRuleTag + !KernelRuleSignature + !KernelRuleSignature + | MissingFoundationAxiom !FoundationAxiomTag + | DuplicateFoundationAxiom !FoundationAxiomTag + | FoundationAxiomIllTyped + !FoundationAxiomTag + !CoreCheckError + | FoundationAxiomFreezeFailed + !FoundationAxiomTag + !FreezeError + | FoundationAxiomStatementMismatch + !FoundationAxiomTag + | FoundationAxiomBackendClassMismatch + !FoundationAxiomTag + !FoundationBackendClass + !FoundationBackendClass + deriving stock (Show, Eq) + +data CheckedFoundationAxiom = CheckedFoundationAxiom + !(ClosedCheckedProposition Void) + !(FrozenCheckedCore Void) + !FoundationBackendClass + +newtype FoundationManifestAudit = FoundationManifestAudit + ( Map FoundationAxiomTag CheckedFoundationAxiom + , Map KernelRuleTag KernelRuleSignature + ) + +data CheckedFoundation = CheckedFoundation + !(Map FoundationAxiomTag CheckedFoundationAxiom) + !(Map KernelRuleTag KernelRuleSignature) + + +compiledFoundationIntrinsicRows + :: [(CoreIntrinsicTag, CoreType)] +compiledFoundationIntrinsicRows = + [ (Member, TySet `TyArrow` (TySet `TyArrow` TyProp)) + , (Empty, TySet) + , (PairSet, TySet `TyArrow` (TySet `TyArrow` TySet)) + , (FamilyUnion, TySet `TyArrow` TySet) + , (PowerSet, TySet `TyArrow` TySet) + , ( Sep + , TySet + `TyArrow` + ((TySet `TyArrow` TyProp) `TyArrow` TySet) + ) + , ( Repl + , TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + ) + , (SetChoose, (TySet `TyArrow` TyProp) `TyArrow` TySet) + , (UnivOf, TySet `TyArrow` TySet) + , ( ISetLfp + , TySet + `TyArrow` + ((TySet `TyArrow` TySet) `TyArrow` TySet) + ) + ] + +compiledFoundationRuleRows :: [FoundationRuleInput] +compiledFoundationRuleRows = + [ FoundationRuleInput + tag + (expectedKernelRuleSignature tag) + | tag <- allKernelRuleTags + ] + +compiledFoundationAxiomRows :: [FoundationAxiomInput] +compiledFoundationAxiomRows = + [ FoundationAxiomInput + tag + (foundationAxiomSyntax tag) + (expectedFoundationBackendClass tag) + | tag <- allFoundationAxiomTags + ] + +checkedFoundation + :: Either + (NonEmpty FoundationManifestError) + CheckedFoundation +checkedFoundation = do + FoundationManifestAudit (axioms, rules) <- + auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + compiledFoundationAxiomRows + pure (CheckedFoundation axioms rules) + +-- | Audit arbitrary proposed rows without granting foundation authority. +-- This is also the pure mutation boundary used by conformance tests. +auditFoundationManifest + :: [(CoreIntrinsicTag, CoreType)] + -> [FoundationRuleInput] + -> [FoundationAxiomInput] + -> Either + (NonEmpty FoundationManifestError) + FoundationManifestAudit +auditFoundationManifest intrinsicRows ruleRows axiomRows = + case + intrinsicErrors + <> ruleErrors + <> axiomCoverageErrors + <> axiomErrors of + [] -> + case checkedRows of + Left errors -> + Left errors + Right rows -> + Right + (FoundationManifestAudit + ( Map.fromList rows + , Map.fromList + [ (tag, signature) + | FoundationRuleInput + tag + signature <- + ruleRows + ] + )) + firstError : remainingErrors -> + Left (firstError :| remainingErrors) + where + intrinsicErrors = + coverageErrors + MissingFoundationIntrinsic + DuplicateFoundationIntrinsic + allCoreIntrinsicTags + (fst <$> intrinsicRows) + <> [ FoundationIntrinsicTypeMismatch + tag + (coreIntrinsicType tag) + actual + | (tag, actual) <- intrinsicRows + , actual /= coreIntrinsicType tag + ] + axiomCoverageErrors = + coverageErrors + MissingFoundationAxiom + DuplicateFoundationAxiom + allFoundationAxiomTags + [ tag + | FoundationAxiomInput tag _syntax _backendClass <- + axiomRows + ] + ruleErrors = + coverageErrors + MissingFoundationRule + DuplicateFoundationRule + allKernelRuleTags + [ tag + | FoundationRuleInput tag _signature <- + ruleRows + ] + <> [ FoundationRuleSignatureMismatch + tag + (expectedKernelRuleSignature tag) + actual + | FoundationRuleInput tag actual <- + ruleRows + , actual /= expectedKernelRuleSignature tag + ] + checkedRows = + traverse checkAxiomRow axiomRows + axiomErrors = + case checkedRows of + Left errors -> + toList errors + Right _rows -> + [] + +checkAxiomRow + :: FoundationAxiomInput + -> Either + (NonEmpty FoundationManifestError) + (FoundationAxiomTag, CheckedFoundationAxiom) +checkAxiomRow + (FoundationAxiomInput + tag + syntax + declaredBackendClass) = do + proposition <- + firstOne (FoundationAxiomIllTyped tag) + (checkClosedProposition absurd syntax) + frozen <- + firstOne (FoundationAxiomFreezeFailed tag) + (freezeClosed + (checkedPropositionCore proposition)) + expectedFrozen <- + expectedFoundationAxiom tag + unless + (frozen == expectedFrozen) + (Left + (FoundationAxiomStatementMismatch tag :| [])) + let actualBackendClass = + classifyFrozenCore frozen + unless + (declaredBackendClass == actualBackendClass) + (Left + (FoundationAxiomBackendClassMismatch + tag + declaredBackendClass + actualBackendClass + :| [])) + pure + ( tag + , CheckedFoundationAxiom + proposition + frozen + actualBackendClass + ) + +expectedFoundationAxiom + :: FoundationAxiomTag + -> Either + (NonEmpty FoundationManifestError) + (FrozenCheckedCore Void) +expectedFoundationAxiom tag = do + proposition <- + firstOne (FoundationAxiomIllTyped tag) + (checkClosedProposition + absurd + (foundationAxiomSyntax tag)) + firstOne (FoundationAxiomFreezeFailed tag) + (freezeClosed + (checkedPropositionCore proposition)) + +foundationAxiomProposition + :: CheckedFoundation + -> FoundationAxiomTag + -> ClosedCheckedProposition Void +foundationAxiomProposition foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom proposition _frozen _backendClass -> + proposition + +foundationAxiomFrozen + :: CheckedFoundation + -> FoundationAxiomTag + -> FrozenCheckedCore Void +foundationAxiomFrozen foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom _proposition frozen _backendClass -> + frozen + +foundationAxiomBackendClass + :: CheckedFoundation + -> FoundationAxiomTag + -> FoundationBackendClass +foundationAxiomBackendClass foundation tag = + case lookupFoundationAxiom foundation tag of + CheckedFoundationAxiom _proposition _frozen backendClass -> + backendClass + +lookupFoundationAxiom + :: CheckedFoundation + -> FoundationAxiomTag + -> CheckedFoundationAxiom +lookupFoundationAxiom + (CheckedFoundation axioms _rules) + tag = + case Map.lookup tag axioms of + Just axiom -> + axiom + Nothing -> + impossible + "checked foundation omitted a validated axiom tag" + +foundationRuleSignature + :: CheckedFoundation + -> KernelRuleTag + -> KernelRuleSignature +foundationRuleSignature + (CheckedFoundation _axioms rules) + tag = + case Map.lookup tag rules of + Just signature -> + signature + Nothing -> + impossible + "checked foundation omitted a validated kernel rule" + + +classifyFrozenCore + :: FrozenCheckedCore global + -> FoundationBackendClass +classifyFrozenCore = + classifyCanonicalFofStructure + . frozenCoreTerm + +classifyCanonicalFofStructure + :: CanonicalTerm global + -> FoundationBackendClass +classifyCanonicalFofStructure term = + case Set.toAscList + (termFofExclusions + term) of + [] -> + FoundationFofProjectable + firstExclusion : remainingExclusions -> + FoundationRequiresTh0 + (firstExclusion :| remainingExclusions) + +foundationAxiomDependencies + :: CanonicalTerm global + -> Set FoundationAxiomTag +foundationAxiomDependencies = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic -> + intrinsicFoundationAxioms intrinsic + COpaqueInteger{} -> + mempty + CApp function argument -> + foundationAxiomDependencies function + <> foundationAxiomDependencies argument + CLam _binderType body -> + foundationAxiomDependencies body + CFalsum -> + mempty + CImp premise conclusion -> + foundationAxiomDependencies premise + <> foundationAxiomDependencies conclusion + CEq _operandType left right -> + foundationAxiomDependencies left + <> foundationAxiomDependencies right + CForall _binderType body -> + foundationAxiomDependencies body + +intrinsicFoundationAxioms + :: CoreIntrinsicTag + -> Set FoundationAxiomTag +intrinsicFoundationAxioms = Set.fromList . \case + Member -> + [] + Empty -> + [EmptyCharacteristic] + PairSet -> + [PairSetCharacteristic] + FamilyUnion -> + [FamilyUnionCharacteristic] + PowerSet -> + [PowerSetCharacteristic] + Sep -> + [SeparationCharacteristic] + Repl -> + [ReplacementCharacteristic] + SetChoose -> + [SetChooseWitness] + UnivOf -> + [] + ISetLfp -> + [] + +termFofExclusions + :: CanonicalTerm global + -> Set FofExclusion +termFofExclusions = \case + CBound{} -> + mempty + CGlobal{} -> + mempty + CIntrinsic intrinsic + | intrinsic `elem` + [Sep, Repl, SetChoose, ISetLfp] -> + Set.singleton + (HigherOrderIntrinsic intrinsic) + | otherwise -> + mempty + COpaqueInteger{} -> + mempty + CApp function argument -> + termFofExclusions function + <> termFofExclusions argument + CLam _binderType body -> + Set.insert HigherOrderLambda + (termFofExclusions body) + CFalsum -> + mempty + CImp premise conclusion -> + termFofExclusions premise + <> termFofExclusions conclusion + CEq operandType left right -> + (case operandType of + TyArrow{} -> + Set.singleton + (HigherOrderEquality operandType) + _ -> + mempty) + <> termFofExclusions left + <> termFofExclusions right + CForall binderType body -> + (case binderType of + TySet -> + mempty + _ -> + Set.singleton + (HigherOrderBinder binderType)) + <> termFofExclusions body + + +allCoreIntrinsicTags :: [CoreIntrinsicTag] +allCoreIntrinsicTags = + [minBound .. maxBound] + +allFoundationAxiomTags :: [FoundationAxiomTag] +allFoundationAxiomTags = + [minBound .. maxBound] + +allKernelRuleTags :: [KernelRuleTag] +allKernelRuleTags = + [minBound .. maxBound] + +expectedKernelRuleSignature + :: KernelRuleTag + -> KernelRuleSignature +expectedKernelRuleSignature = \case + SetLfpBound -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 0 + SetLfpLeast -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet, TySet] + 2 + SetLfpFixed -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 1 + SetLfpInduct -> + KernelRuleSignature + [ TySet + , TySet `TyArrow` TySet + , TySet `TyArrow` TyProp + , TySet + ] + 3 + +coverageErrors + :: Ord tag + => (tag -> error) + -> (tag -> error) + -> [tag] + -> [tag] + -> [error] +coverageErrors missing duplicate expected actual = + [ missing tag + | tag <- expected + , occurrenceCount tag == 0 + ] + <> [ duplicate tag + | tag <- expected + , occurrenceCount tag > 1 + ] + where + occurrenceCount tag = + length (List.filter (== tag) actual) + +firstOne + :: (error -> FoundationManifestError) + -> Either error value + -> Either (NonEmpty FoundationManifestError) value +firstOne wrap = + either + (Left . (:| []) . wrap) + Right + + +type FoundationSyntax = CoreSyntax Void Natural + +foundationAxiomSyntax + :: FoundationAxiomTag + -> FoundationSyntax +foundationAxiomSyntax = \case + EmptyCharacteristic -> + foralls + [(x, TySet)] + (iff + (member (var x) emptySet) + coreFalsum) + PairSetCharacteristic -> + foralls + [(a, TySet), (b, TySet), (x, TySet)] + (iff + (member + (var x) + (pairSet (var a) (var b))) + (orP + (eqSet (var x) (var a)) + (eqSet (var x) (var b)))) + FamilyUnionCharacteristic -> + foralls + [(a, TySet), (x, TySet)] + (iff + (member + (var x) + (familyUnion (var a))) + (exists + b + TySet + (andP + (member (var b) (var a)) + (member (var x) (var b))))) + PowerSetCharacteristic -> + foralls + [(a, TySet), (b, TySet)] + (iff + (member + (var b) + (powerSet (var a))) + (subset (var b) (var a))) + SeparationCharacteristic -> + foralls + [ (a, TySet) + , (p, TySet `TyArrow` TyProp) + , (x, TySet) + ] + (iff + (member + (var x) + (separation (var a) (var p))) + (andP + (member (var x) (var a)) + (apply (var p) (var x)))) + ReplacementCharacteristic -> + foralls + [ (a, TySet) + , (f, TySet `TyArrow` TySet) + , (y, TySet) + ] + (iff + (member + (var y) + (replacement (var a) (var f))) + (exists + x + TySet + (andP + (member (var x) (var a)) + (eqSet + (var y) + (apply (var f) (var x)))))) + SetChooseWitness -> + foralls + [ (p, TySet `TyArrow` TyProp) + , (x, TySet) + ] + (implies + (apply (var p) (var x)) + (apply + (var p) + (setChoose (var p)))) + SetExtensionality -> + foralls + [(a, TySet), (b, TySet)] + (implies + (subset (var a) (var b)) + (implies + (subset (var b) (var a)) + (eqSet (var a) (var b)))) + SetInduction -> + forallOne + p + (TySet `TyArrow` TyProp) + (implies + (forallOne + a + TySet + (implies + (forallOne + x + TySet + (implies + (member (var x) (var a)) + (apply (var p) (var x)))) + (apply (var p) (var a)))) + (forallOne + a + TySet + (apply (var p) (var a)))) + PropositionalExtensionality -> + foralls + [(p, TyProp), (q, TyProp)] + (implies + (implies (var p) (var q)) + (implies + (implies (var q) (var p)) + (coreEquality + TyProp + (var p) + (var q)))) + DoubleNegationElim -> + forallOne + p + TyProp + (implies + (notP (notP (var p))) + (var p)) + UnivOfContains -> + forallOne + n + TySet + (member + (var n) + (univOf (var n))) + UnivOfTransitive -> + forallOne + n + TySet + (transitive (univOf (var n))) + UnivOfFamilyUnionClosed -> + forallOne + n + TySet + (familyUnionClosed + (univOf (var n))) + UnivOfPowerSetClosed -> + forallOne + n + TySet + (powerSetClosed + (univOf (var n))) + UnivOfReplacementClosed -> + forallOne + n + TySet + (replacementClosed + (univOf (var n))) + UnivOfMinimal -> + foralls + [(n, TySet), (u, TySet)] + (implies + (member (var n) (var u)) + (implies + (transitive (var u)) + (implies + (familyUnionClosed (var u)) + (implies + (powerSetClosed (var u)) + (implies + (replacementClosed (var u)) + (subset + (univOf (var n)) + (var u))))))) + +expectedFoundationBackendClass + :: FoundationAxiomTag + -> FoundationBackendClass +expectedFoundationBackendClass = \case + EmptyCharacteristic -> + FoundationFofProjectable + PairSetCharacteristic -> + FoundationFofProjectable + FamilyUnionCharacteristic -> + FoundationFofProjectable + PowerSetCharacteristic -> + FoundationFofProjectable + SeparationCharacteristic -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [HigherOrderIntrinsic Sep] + ReplacementCharacteristic -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + SetChooseWitness -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [HigherOrderIntrinsic SetChoose] + SetExtensionality -> + FoundationFofProjectable + SetInduction -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TyProp)) + [] + PropositionalExtensionality -> + requiresTh0 + (HigherOrderBinder TyProp) + [] + DoubleNegationElim -> + requiresTh0 + (HigherOrderBinder TyProp) + [] + UnivOfContains -> + FoundationFofProjectable + UnivOfTransitive -> + FoundationFofProjectable + UnivOfFamilyUnionClosed -> + FoundationFofProjectable + UnivOfPowerSetClosed -> + FoundationFofProjectable + UnivOfReplacementClosed -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + UnivOfMinimal -> + requiresTh0 + (HigherOrderBinder + (TySet `TyArrow` TySet)) + [HigherOrderIntrinsic Repl] + where + requiresTh0 firstExclusion remainingExclusions = + FoundationRequiresTh0 + (firstExclusion :| remainingExclusions) + + +x, y, a, b, p, q, f, n, u :: Natural +x = 0 +y = 1 +a = 2 +b = 3 +p = 4 +q = 5 +f = 6 +n = 7 +u = 8 + +var :: Natural -> FoundationSyntax +var = coreLocal + +apply + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +apply = coreApply + +apply2 + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +apply2 function firstArgument secondArgument = + apply + (apply function firstArgument) + secondArgument + +member + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +member = + apply2 (coreIntrinsic Member) + +emptySet :: FoundationSyntax +emptySet = + coreIntrinsic Empty + +pairSet + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +pairSet = + apply2 (coreIntrinsic PairSet) + +familyUnion :: FoundationSyntax -> FoundationSyntax +familyUnion = + apply (coreIntrinsic FamilyUnion) + +powerSet :: FoundationSyntax -> FoundationSyntax +powerSet = + apply (coreIntrinsic PowerSet) + +separation + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +separation = + apply2 (coreIntrinsic Sep) + +replacement + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +replacement = + apply2 (coreIntrinsic Repl) + +setChoose :: FoundationSyntax -> FoundationSyntax +setChoose = + apply (coreIntrinsic SetChoose) + +univOf :: FoundationSyntax -> FoundationSyntax +univOf = + apply (coreIntrinsic UnivOf) + +implies + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +implies = + coreImplication + +notP :: FoundationSyntax -> FoundationSyntax +notP proposition = + implies proposition coreFalsum + +andP + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +andP left right = + notP + (implies left (notP right)) + +orP + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +orP left right = + implies (notP left) right + +iff + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +iff = + coreEquality TyProp + +eqSet + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +eqSet = + coreEquality TySet + +forallOne + :: Natural + -> CoreType + -> FoundationSyntax + -> FoundationSyntax +forallOne local binderType = + coreForall binderType local + +foralls + :: [(Natural, CoreType)] + -> FoundationSyntax + -> FoundationSyntax +foralls binders body = + foldr + (uncurry forallOne) + body + binders + +exists + :: Natural + -> CoreType + -> FoundationSyntax + -> FoundationSyntax +exists local binderType body = + notP + (forallOne + local + binderType + (notP body)) + +subset + :: FoundationSyntax + -> FoundationSyntax + -> FoundationSyntax +subset left right = + forallOne + x + TySet + (implies + (member (var x) left) + (member (var x) right)) + +transitive :: FoundationSyntax -> FoundationSyntax +transitive universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (subset (var a) universe)) + +familyUnionClosed :: FoundationSyntax -> FoundationSyntax +familyUnionClosed universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (member + (familyUnion (var a)) + universe)) + +powerSetClosed :: FoundationSyntax -> FoundationSyntax +powerSetClosed universe = + forallOne + a + TySet + (implies + (member (var a) universe) + (member + (powerSet (var a)) + universe)) + +replacementClosed :: FoundationSyntax -> FoundationSyntax +replacementClosed universe = + foralls + [ (a, TySet) + , (f, TySet `TyArrow` TySet) + ] + (implies + (member (var a) universe) + (implies + (forallOne + x + TySet + (implies + (member (var x) (var a)) + (member + (apply (var f) (var x)) + universe))) + (member + (replacement (var a) (var f)) + universe))) diff --git a/source/Felix/Checking/Identity.hs b/source/Felix/Checking/Identity.hs new file mode 100644 index 0000000..67347a3 --- /dev/null +++ b/source/Felix/Checking/Identity.hs @@ -0,0 +1,1023 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Content-addressed identities for checked mathematical content. +module Felix.Checking.Identity + ( TheoryId + , theoryId + , theoryIdDigest + , encodeFoundationManifest + , foundationManifestTags + , encodeKernelRuleTag + , ObjectFamily(..) + , ObjectId + , objectId + , objectIdFamily + , objectIdDigest + , encodeObjectId + , OpaqueDeclarationSeed + , opaqueDeclarationSeed + , opaqueDeclarationSeedDigest + , ObjectContent(..) + , objectContentTheory + , objectContentType + , intrinsicObjectId + , transparentObjectId + , opaqueObjectId + , AssertedObject + , assertedObject + , assertedObjectId + , assertedObjectContent + , CheckedObjectClosure + , checkedObjectClosureTheory + , checkedObjectIds + , lookupCheckedObjectType + , lookupCheckedObjectContent + , validateObjectClosure + , extendObjectClosure + , ObjectValidationError(..) + , PropositionId + , propositionIdDigest + , CheckedPropositionContent + , checkedPropositionId + , checkedPropositionTerm + , validatePropositionContent + , validateAssertedPropositionContent + , propositionIdOf + , PropositionValidationError(..) + , TheoremRef + , theoremRef + , theoremRefTheory + , theoremRefProposition + , encodeTheoremRef + , TheoremId + , theoremId + , theoremIdDigest + , putTheoryIdCache + , getTheoryIdCache + , putObjectIdCache + , getObjectIdCache + , putObjectContentCache + , getObjectContentCache + , putPropositionIdCache + , getPropositionIdCache + , putTheoremRefCache + , getTheoremRefCache + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module + +import Control.DeepSeq (NFData) +import Control.Monad.State.Strict +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Word (Word8) + + +newtype TheoryId = + TheoryId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +theoryId :: CheckedFoundation -> TheoryId +theoryId foundation = + TheoryId + (codecInvariant + (hashCanonicalFields + "felix-theory" + [encodeFoundationManifest foundation])) + +theoryIdDigest :: TheoryId -> MathematicalDigest +theoryIdDigest (TheoryId digest) = + digest + +-- | Canonical ordered intrinsic/rule/axiom manifest. Backend classification is +-- intentionally absent. +encodeFoundationManifest :: CheckedFoundation -> ByteString +encodeFoundationManifest foundation = + codecInvariant + (encodeSequence + [ codecInvariant (encodeSequence intrinsicRows) + , codecInvariant (encodeSequence ruleRows) + , codecInvariant (encodeSequence axiomRows) + ]) + where + (intrinsicTags, ruleTags, axiomTags) = + foundationManifestTags + + intrinsicRows = + [ encodeCoreIntrinsicTag tag + <> encodeFrame (encodeCoreType (coreIntrinsicType tag)) + | tag <- intrinsicTags + ] + + ruleRows = + [ encodeKernelRuleTag tag + <> encodeFrame + (codecInvariant + (encodeSequence + (encodeCoreType <$> inputTypes))) + <> encodeFrame (encodeNatural binderCount) + | tag <- ruleTags + , let KernelRuleSignature inputTypes binderCount = + foundationRuleSignature foundation tag + ] + + axiomRows = + [ encodeFoundationAxiomTag tag + <> encodeFrame + (encodeCanonicalTerm + absurd + (frozenCoreTerm + (foundationAxiomFrozen foundation tag))) + | tag <- axiomTags + ] + +-- | Exhaustive foundation inventories in their stable encoded-tag order. +foundationManifestTags + :: ( [CoreIntrinsicTag] + , [KernelRuleTag] + , [FoundationAxiomTag] + ) +foundationManifestTags = + ( stableTagOrder + "core intrinsic" + encodeCoreIntrinsicTag + allCoreIntrinsicTags + , stableTagOrder + "kernel rule" + encodeKernelRuleTag + allKernelRuleTags + , stableTagOrder + "foundation axiom" + encodeFoundationAxiomTag + allFoundationAxiomTags + ) + + +data ObjectFamily + = IntrinsicObject + | TransparentObject + | OpaqueObject + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (NFData) + +data ObjectId = ObjectId + !ObjectFamily + !MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +objectId + :: ObjectFamily + -> MathematicalDigest + -> ObjectId +objectId = + ObjectId + +objectIdFamily :: ObjectId -> ObjectFamily +objectIdFamily (ObjectId family _digest) = + family + +objectIdDigest :: ObjectId -> MathematicalDigest +objectIdDigest (ObjectId _family digest) = + digest + +encodeObjectId :: ObjectId -> ByteString +encodeObjectId (ObjectId family digest) = + ByteString.singleton (objectFamilyTag family) + <> mathematicalDigestBytes digest + + +newtype OpaqueDeclarationSeed = + OpaqueDeclarationSeed MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +opaqueDeclarationSeed + :: ModuleName + -> LocalDeclarationOrdinal + -> DeclarationFamilyTag + -> GeneratedObjectSlot + -> OpaqueDeclarationSeed +opaqueDeclarationSeed + owner + declarationOrdinal + family + generatedSlot = + OpaqueDeclarationSeed + (codecInvariant + (hashCanonicalFields + "felix-opaque-declaration-v1" + [ encodeModuleName owner + , encodeNatural + (localDeclarationOrdinalValue + declarationOrdinal) + , encodeDeclarationFamilyTag family + , encodeNatural + (generatedObjectSlotValue + generatedSlot) + ])) + +opaqueDeclarationSeedDigest + :: OpaqueDeclarationSeed + -> MathematicalDigest +opaqueDeclarationSeedDigest + (OpaqueDeclarationSeed digest) = + digest + + +data ObjectContent + = IntrinsicObjectContent + !TheoryId + !CoreIntrinsicTag + !CoreType + | TransparentObjectContent + !TheoryId + !CoreType + !(CanonicalTerm ObjectId) + | OpaqueObjectContent + !TheoryId + !OpaqueDeclarationSeed + !CoreType + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +objectContentTheory :: ObjectContent -> TheoryId +objectContentTheory = \case + IntrinsicObjectContent identity _tag _coreType -> + identity + TransparentObjectContent identity _coreType _body -> + identity + OpaqueObjectContent identity _seed _coreType -> + identity + +objectContentType :: ObjectContent -> CoreType +objectContentType = \case + IntrinsicObjectContent _identity _tag coreType -> + coreType + TransparentObjectContent _identity coreType _body -> + coreType + OpaqueObjectContent _identity _seed coreType -> + coreType + +intrinsicObjectId + :: TheoryId + -> CoreIntrinsicTag + -> CoreType + -> ObjectId +intrinsicObjectId identity tag coreType = + ObjectId + IntrinsicObject + (codecInvariant + (hashCanonicalFields + "felix-intrinsic-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , encodeCoreIntrinsicTag tag + , encodeCoreType coreType + ])) + +transparentObjectId + :: TheoryId + -> CoreType + -> CanonicalTerm ObjectId + -> ObjectId +transparentObjectId identity coreType body = + ObjectId + TransparentObject + (codecInvariant + (hashCanonicalFields + "felix-transparent-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , encodeCoreType coreType + , encodeCanonicalTerm encodeObjectId body + ])) + +opaqueObjectId + :: TheoryId + -> OpaqueDeclarationSeed + -> CoreType + -> ObjectId +opaqueObjectId identity seed coreType = + ObjectId + OpaqueObject + (codecInvariant + (hashCanonicalFields + "felix-opaque-object-v1" + [ mathematicalDigestBytes + (theoryIdDigest identity) + , mathematicalDigestBytes + (opaqueDeclarationSeedDigest seed) + , encodeCoreType coreType + ])) + + +data AssertedObject = AssertedObject + !ObjectId + !ObjectContent + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +assertedObject :: ObjectId -> ObjectContent -> AssertedObject +assertedObject = + AssertedObject + +assertedObjectId :: AssertedObject -> ObjectId +assertedObjectId (AssertedObject identity _content) = + identity + +assertedObjectContent :: AssertedObject -> ObjectContent +assertedObjectContent (AssertedObject _identity content) = + content + +data CheckedObject = CheckedObject + !ObjectContent + !CoreType + +data CheckedObjectClosure = CheckedObjectClosure + !TheoryId + !(Map ObjectId CheckedObject) + +checkedObjectClosureTheory :: CheckedObjectClosure -> TheoryId +checkedObjectClosureTheory (CheckedObjectClosure identity _objects) = + identity + +checkedObjectIds :: CheckedObjectClosure -> Set ObjectId +checkedObjectIds (CheckedObjectClosure _identity objects) = + Map.keysSet objects + +lookupCheckedObjectType + :: ObjectId + -> CheckedObjectClosure + -> Maybe CoreType +lookupCheckedObjectType identity + (CheckedObjectClosure _theory objects) = + checkedObjectType + <$> Map.lookup identity objects + +lookupCheckedObjectContent + :: ObjectId + -> CheckedObjectClosure + -> Maybe ObjectContent +lookupCheckedObjectContent identity + (CheckedObjectClosure _theory objects) = + checkedObjectContent + <$> Map.lookup identity objects + +checkedObjectType :: CheckedObject -> CoreType +checkedObjectType (CheckedObject _content coreType) = + coreType + +checkedObjectContent :: CheckedObject -> ObjectContent +checkedObjectContent (CheckedObject content _coreType) = + content + + +data ObjectValidationError + = DuplicateAssertedObjectId !ObjectId + | ObjectContentTheoryMismatch + !ObjectId + !TheoryId + !TheoryId + | ObjectContentFamilyMismatch + !ObjectId + !ObjectFamily + !ObjectFamily + | IntrinsicObjectTypeMismatch + !ObjectId + !CoreIntrinsicTag + !CoreType + !CoreType + | TransparentObjectReferenceMissing + !ObjectId + !ObjectId + | TransparentObjectCycle !(NonEmpty ObjectId) + | TransparentObjectCoreCheckError + !ObjectId + !CoreCheckError + | TransparentObjectTypeMismatch + !ObjectId + !CoreType + !CoreType + | ObjectIdPayloadMismatch + !ObjectId + !ObjectId + deriving stock (Show, Eq) + +data ObjectValidationState = ObjectValidationState + { validationStack :: ![ObjectId] + , validatedObjects :: !(Map ObjectId CheckedObject) + } + +validateObjectClosure + :: TheoryId + -> [AssertedObject] + -> Either ObjectValidationError CheckedObjectClosure +validateObjectClosure expectedTheory asserted = do + inventory <- buildObjectInventory asserted + finalState <- + execStateT + (traverse_ (validateOneObject expectedTheory inventory) + (Map.keys inventory)) + (ObjectValidationState [] Map.empty) + pure + (CheckedObjectClosure + expectedTheory + (validatedObjects finalState)) + +-- | Validate one declaration's new objects against an already checked +-- closure. The existing closure is returned unchanged for an empty batch. +extendObjectClosure + :: CheckedObjectClosure + -> [AssertedObject] + -> Either ObjectValidationError CheckedObjectClosure +extendObjectClosure closure [] = + Right closure +extendObjectClosure + (CheckedObjectClosure expectedTheory existing) + asserted = do + additions <- buildObjectInventory asserted + traverse_ + (\identity -> + when + (Map.member identity existing) + (Left (DuplicateAssertedObjectId identity))) + (Map.keys additions) + let existingInventory = + checkedObjectContent <$> existing + inventory = + Map.union additions existingInventory + finalState <- + execStateT + (traverse_ + (validateOneObject expectedTheory inventory) + (Map.keys additions)) + (ObjectValidationState [] existing) + pure + (CheckedObjectClosure + expectedTheory + (validatedObjects finalState)) + +buildObjectInventory + :: [AssertedObject] + -> Either ObjectValidationError (Map ObjectId ObjectContent) +buildObjectInventory = + foldM insertOne Map.empty + where + insertOne inventory (AssertedObject identity content) + | Map.member identity inventory = + Left (DuplicateAssertedObjectId identity) + | otherwise = + Right (Map.insert identity content inventory) + +validateOneObject + :: TheoryId + -> Map ObjectId ObjectContent + -> ObjectId + -> StateT + ObjectValidationState + (Either ObjectValidationError) + () +validateOneObject expectedTheory inventory identity = do + alreadyValidated <- + gets (Map.member identity . validatedObjects) + unless alreadyValidated do + stack <- gets validationStack + when (identity `elem` stack) do + lift + (Left + (TransparentObjectCycle + (cyclePath identity stack))) + content <- + case Map.lookup identity inventory of + Nothing -> + impossible + "object validation root is absent from its inventory" + Just found -> + pure found + unless + (objectContentTheory content == expectedTheory) + (lift + (Left + (ObjectContentTheoryMismatch + identity + expectedTheory + (objectContentTheory content)))) + let expectedFamily = + objectContentFamily content + suppliedFamily = + objectIdFamily identity + unless + (suppliedFamily == expectedFamily) + (lift + (Left + (ObjectContentFamilyMismatch + identity + expectedFamily + suppliedFamily))) + modify' + (\validationState -> + validationState + { validationStack = + identity + : validationStack validationState + }) + checked <- case content of + IntrinsicObjectContent + theory + tag + suppliedType -> do + let expectedType = + coreIntrinsicType tag + unless + (suppliedType == expectedType) + (lift + (Left + (IntrinsicObjectTypeMismatch + identity + tag + expectedType + suppliedType))) + verifyObjectId + identity + (intrinsicObjectId + theory + tag + suppliedType) + pure + (CheckedObject content suppliedType) + TransparentObjectContent + theory + suppliedType + body -> do + traverse_ + (validateDependency expectedTheory inventory identity) + (Set.toAscList (canonicalTermGlobals body)) + resolvedObjects <- + gets validatedObjects + checkedBody <- + lift + (first + (TransparentObjectCoreCheckError + identity) + (checkCanonicalCore + (\reference -> + checkedObjectType + <$> Map.lookup + reference + resolvedObjects) + body)) + let inferredType = + frozenCoreType checkedBody + unless + (inferredType == suppliedType) + (lift + (Left + (TransparentObjectTypeMismatch + identity + suppliedType + inferredType))) + verifyObjectId + identity + (transparentObjectId + theory + suppliedType + body) + pure + (CheckedObject content suppliedType) + OpaqueObjectContent + theory + seed + suppliedType -> do + verifyObjectId + identity + (opaqueObjectId + theory + seed + suppliedType) + pure + (CheckedObject content suppliedType) + modify' + (\validationState -> + validationState + { validationStack = + dropCurrent + identity + (validationStack validationState) + , validatedObjects = + Map.insert + identity + checked + (validatedObjects validationState) + }) + where + verifyObjectId supplied computed = + unless + (supplied == computed) + (lift + (Left + (ObjectIdPayloadMismatch + supplied + computed))) + +validateDependency + :: TheoryId + -> Map ObjectId ObjectContent + -> ObjectId + -> ObjectId + -> StateT + ObjectValidationState + (Either ObjectValidationError) + () +validateDependency expectedTheory inventory parent dependency = + case Map.lookup dependency inventory of + Nothing -> + lift + (Left + (TransparentObjectReferenceMissing + parent + dependency)) + Just _ -> + validateOneObject + expectedTheory + inventory + dependency + +cyclePath :: ObjectId -> [ObjectId] -> NonEmpty ObjectId +cyclePath repeated stack = + case break (== repeated) stack of + (between, _repeated : _outer) -> + repeated :| (reverse between <> [repeated]) + _ -> + impossible "repeated object is absent from validation stack" + +dropCurrent :: ObjectId -> [ObjectId] -> [ObjectId] +dropCurrent expected = \case + current : rest + | current == expected -> + rest + _ -> + impossible "object validation stack is inconsistent" + +objectContentFamily :: ObjectContent -> ObjectFamily +objectContentFamily = \case + IntrinsicObjectContent{} -> + IntrinsicObject + TransparentObjectContent{} -> + TransparentObject + OpaqueObjectContent{} -> + OpaqueObject + +newtype PropositionId = + PropositionId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +propositionIdDigest :: PropositionId -> MathematicalDigest +propositionIdDigest (PropositionId digest) = + digest + +data CheckedPropositionContent = CheckedPropositionContent + !PropositionId + !(FrozenCheckedCore ObjectId) + deriving stock (Generic) + deriving anyclass (NFData) + +checkedPropositionId + :: CheckedPropositionContent + -> PropositionId +checkedPropositionId + (CheckedPropositionContent identity _term) = + identity + +checkedPropositionTerm + :: CheckedPropositionContent + -> FrozenCheckedCore ObjectId +checkedPropositionTerm + (CheckedPropositionContent _identity term) = + term + +data PropositionValidationError + = PropositionObjectMissing !ObjectId + | PropositionCoreCheckError !CoreCheckError + | PropositionIsNotProp !CoreType + | PropositionIdPayloadMismatch + !PropositionId + !PropositionId + deriving stock (Show, Eq) + +validatePropositionContent + :: CheckedObjectClosure + -> CanonicalTerm ObjectId + -> Either + PropositionValidationError + CheckedPropositionContent +validatePropositionContent closure term = do + traverse_ + (\identity -> + unless + (isJust + (lookupCheckedObjectType identity closure)) + (Left (PropositionObjectMissing identity))) + (Set.toAscList (canonicalTermGlobals term)) + checked <- + first PropositionCoreCheckError + (checkCanonicalCore + (\identity -> + lookupCheckedObjectType identity closure) + term) + unless + (frozenCoreType checked == TyProp) + (Left + (PropositionIsNotProp + (frozenCoreType checked))) + let identity = + propositionIdOf term + pure + (CheckedPropositionContent + identity + checked) + +validateAssertedPropositionContent + :: CheckedObjectClosure + -> PropositionId + -> CanonicalTerm ObjectId + -> Either + PropositionValidationError + CheckedPropositionContent +validateAssertedPropositionContent closure supplied term = do + checked <- + validatePropositionContent closure term + let computed = + checkedPropositionId checked + unless + (supplied == computed) + (Left + (PropositionIdPayloadMismatch + supplied + computed)) + pure checked + +propositionIdOf + :: CanonicalTerm ObjectId + -> PropositionId +propositionIdOf term = + PropositionId + (codecInvariant + (hashCanonicalFields + "felix-proposition-v1" + [encodeCanonicalTerm encodeObjectId term])) + + +data TheoremRef = TheoremRef + !TheoryId + !PropositionId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +theoremRef :: TheoryId -> PropositionId -> TheoremRef +theoremRef = + TheoremRef + +theoremRefTheory :: TheoremRef -> TheoryId +theoremRefTheory (TheoremRef identity _proposition) = + identity + +theoremRefProposition :: TheoremRef -> PropositionId +theoremRefProposition (TheoremRef _identity proposition) = + proposition + +encodeTheoremRef :: TheoremRef -> ByteString +encodeTheoremRef (TheoremRef identity proposition) = + encodeFrame + (mathematicalDigestBytes + (theoryIdDigest identity)) + <> encodeFrame + (mathematicalDigestBytes + (propositionIdDigest proposition)) + +newtype TheoremId = + TheoremId MathematicalDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +theoremId :: TheoremRef -> TheoremId +theoremId reference = + TheoremId + (codecInvariant + (hashCanonicalFields + "felix-theorem" + [encodeTheoremRef reference])) + +theoremIdDigest :: TheoremId -> MathematicalDigest +theoremIdDigest (TheoremId digest) = + digest + + +putTheoryIdCache :: TheoryId -> CachePut +putTheoryIdCache = + putMathematicalDigestCache . theoryIdDigest + +getTheoryIdCache :: CacheGet TheoryId +getTheoryIdCache = + TheoryId <$> getMathematicalDigestCache + +putObjectIdCache :: ObjectId -> CachePut +putObjectIdCache (ObjectId family digest) = do + putCacheTag (objectFamilyTag family) + putMathematicalDigestCache digest + +getObjectIdCache :: CacheGet ObjectId +getObjectIdCache = do + family <- getCacheTag >>= \case + 0x00 -> + pure IntrinsicObject + 0x01 -> + pure TransparentObject + 0x02 -> + pure OpaqueObject + tag -> + fail ("unknown cache object-family tag " <> show tag) + ObjectId family <$> getMathematicalDigestCache + +putOpaqueDeclarationSeedCache + :: OpaqueDeclarationSeed + -> CachePut +putOpaqueDeclarationSeedCache = + putMathematicalDigestCache + . opaqueDeclarationSeedDigest + +getOpaqueDeclarationSeedCache + :: CacheGet OpaqueDeclarationSeed +getOpaqueDeclarationSeedCache = + OpaqueDeclarationSeed + <$> getMathematicalDigestCache + +putObjectContentCache :: ObjectContent -> CachePut +putObjectContentCache = \case + IntrinsicObjectContent identity tag coreType -> do + putCacheTag 0x00 + putTheoryIdCache identity + putCoreIntrinsicTagCache tag + putCoreTypeCache coreType + TransparentObjectContent identity coreType body -> do + putCacheTag 0x01 + putTheoryIdCache identity + putCoreTypeCache coreType + putCanonicalTermCache putObjectIdCache body + OpaqueObjectContent identity seed coreType -> do + putCacheTag 0x02 + putTheoryIdCache identity + putOpaqueDeclarationSeedCache seed + putCoreTypeCache coreType + +getObjectContentCache :: CacheGet ObjectContent +getObjectContentCache = + getCacheTag >>= \case + 0x00 -> + IntrinsicObjectContent + <$> getTheoryIdCache + <*> getCoreIntrinsicTagCache + <*> getCoreTypeCache + 0x01 -> + TransparentObjectContent + <$> getTheoryIdCache + <*> getCoreTypeCache + <*> getCanonicalTermCache getObjectIdCache + 0x02 -> + OpaqueObjectContent + <$> getTheoryIdCache + <*> getOpaqueDeclarationSeedCache + <*> getCoreTypeCache + tag -> + fail ("unknown cache object-content tag " <> show tag) + +putPropositionIdCache :: PropositionId -> CachePut +putPropositionIdCache = + putMathematicalDigestCache . propositionIdDigest + +getPropositionIdCache :: CacheGet PropositionId +getPropositionIdCache = + PropositionId <$> getMathematicalDigestCache + +putTheoremRefCache :: TheoremRef -> CachePut +putTheoremRefCache (TheoremRef identity proposition) = do + putTheoryIdCache identity + putPropositionIdCache proposition + +getTheoremRefCache :: CacheGet TheoremRef +getTheoremRefCache = + TheoremRef + <$> getTheoryIdCache + <*> getPropositionIdCache + + +objectFamilyTag :: ObjectFamily -> Word8 +objectFamilyTag = \case + IntrinsicObject -> + 0x00 + TransparentObject -> + 0x01 + OpaqueObject -> + 0x02 + +encodeKernelRuleTag :: KernelRuleTag -> ByteString +encodeKernelRuleTag = + ByteString.singleton . \case + SetLfpBound -> + 0x00 + SetLfpLeast -> + 0x01 + SetLfpFixed -> + 0x02 + SetLfpInduct -> + 0x03 + +encodeFoundationAxiomTag :: FoundationAxiomTag -> ByteString +encodeFoundationAxiomTag = + ByteString.singleton . \case + EmptyCharacteristic -> + 0x00 + PairSetCharacteristic -> + 0x01 + FamilyUnionCharacteristic -> + 0x02 + PowerSetCharacteristic -> + 0x03 + SeparationCharacteristic -> + 0x04 + ReplacementCharacteristic -> + 0x05 + SetChooseWitness -> + 0x06 + SetExtensionality -> + 0x07 + SetInduction -> + 0x08 + PropositionalExtensionality -> + 0x09 + DoubleNegationElim -> + 0x0a + UnivOfContains -> + 0x0b + UnivOfTransitive -> + 0x0c + UnivOfFamilyUnionClosed -> + 0x0d + UnivOfPowerSetClosed -> + 0x0e + UnivOfReplacementClosed -> + 0x0f + UnivOfMinimal -> + 0x10 + +allCoreIntrinsicTags :: [CoreIntrinsicTag] +allCoreIntrinsicTags = + [minBound .. maxBound] + +allKernelRuleTags :: [KernelRuleTag] +allKernelRuleTags = + [minBound .. maxBound] + +allFoundationAxiomTags :: [FoundationAxiomTag] +allFoundationAxiomTags = + [minBound .. maxBound] + +stableTagOrder + :: Show tag + => String + -> (tag -> ByteString) + -> [tag] + -> [tag] +stableTagOrder description encodeTag tags + | Set.size encodedTags == length tags = + List.sortOn encodeTag tags + | otherwise = + impossible + ("duplicate stable " + <> description + <> " tag in " + <> show tags) + where + encodedTags = + Set.fromList (encodeTag <$> tags) + +codecInvariant + :: Either MathematicalCodecError value + -> value +codecInvariant = + either + (impossible . ("canonical codec invariant: " <>) . show) + id diff --git a/source/Felix/Checking/Kernel/Derivation.hs b/source/Felix/Checking/Kernel/Derivation.hs new file mode 100644 index 0000000..e83b376 --- /dev/null +++ b/source/Felix/Checking/Kernel/Derivation.hs @@ -0,0 +1,1264 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Private in-memory proof trees and independent kernel replay. +module Felix.Checking.Kernel.Derivation + ( ImportIx + , importIx + , importIxValue + , HypothesisIx + , hypothesisIx + , DerivationImportJudgment + , derivationImportJudgment + , derivationImportStatement + , KernelDerivation + , mapKernelDerivationGlobals + , importedFactDerivation + , localHypothesisDerivation + , foundationFactDerivation + , implicationEliminationDerivation + , forallEliminationDerivation + , falsumEliminationDerivation + , implicationIntroductionDerivation + , forallIntroductionDerivation + , ConversionPlan + , conversionPlan + , conversionPlanBudget + , ConversionPlanError(..) + , convertJudgmentDerivation + , equalityReflexivityDerivation + , scopedEqualityReflexivityDerivation + , equalityCongruenceApplicationDerivation + , equalityCongruenceLambdaDerivation + , equalityModusPonensDerivation + , setLfpBoundDerivation + , setLfpLeastDerivation + , setLfpFixedDerivation + , setLfpInductDerivation + , weakenDerivationHypotheses + , KernelReplayLimits + , kernelReplayLimits + , defaultKernelReplayLimits + , KernelReplayLimitError(..) + , ReplayedKernelDerivation + , replayKernelDerivation + , replayedKernelTarget + , replayedKernelImportUses + , replayedKernelFoundationUses + , replayedKernelRuleUses + , replayedKernelNodeCount + , replayedKernelMaximumDepth + , DerivationImportError(..) + , KernelReplayError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +newtype ImportIx = ImportIx Natural + deriving stock (Show, Eq, Ord) + +importIx :: Natural -> ImportIx +importIx = ImportIx + +importIxValue :: ImportIx -> Natural +importIxValue (ImportIx index) = + index + +newtype HypothesisIx = HypothesisIx Natural + deriving stock (Show, Eq, Ord) + +hypothesisIx :: Natural -> HypothesisIx +hypothesisIx = HypothesisIx + +newtype DerivationImportJudgment global = + DerivationImportJudgment + (FrozenCheckedCore global) + deriving stock (Eq) + +data DerivationImportError = + DerivationImportIsNotProposition !CoreType + deriving stock (Show, Eq) + +derivationImportJudgment + :: FrozenCheckedCore global + -> Either + DerivationImportError + (DerivationImportJudgment global) +derivationImportJudgment statement + | frozenCoreType statement == TyProp = + Right (DerivationImportJudgment statement) + | otherwise = + Left + (DerivationImportIsNotProposition + (frozenCoreType statement)) + +derivationImportStatement + :: DerivationImportJudgment global + -> FrozenCheckedCore global +derivationImportStatement + (DerivationImportJudgment statement) = + statement + +data KernelDerivation global + = UseImportedFact !ImportIx + | UseLocalHypothesis !HypothesisIx + | UseFoundationFact !FoundationAxiomTag + | ImplicationElimination + !(KernelDerivation global) + !(KernelDerivation global) + | ForallElimination + !(KernelDerivation global) + !(ScopedCheckedCore global) + | FalsumElimination + !(KernelDerivation global) + !(ScopedCheckedCore global) + | ImplicationIntroduction + !(ScopedCheckedCore global) + !(KernelDerivation global) + | ForallIntroduction + !CoreType + !(KernelDerivation global) + | ConvertJudgment + !(KernelDerivation global) + !(ScopedCheckedCore global) + !ConversionPlan + | EqualityReflexivity + !(ScopedCheckedCore global) + | EqualityCongruenceApplication + !(KernelDerivation global) + !(KernelDerivation global) + | EqualityCongruenceLambda + !CoreType + !(KernelDerivation global) + | EqualityModusPonens + !(KernelDerivation global) + !(KernelDerivation global) + | ApplySetLfpBound + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + | ApplySetLfpLeast + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + !(KernelDerivation global) + | ApplySetLfpFixed + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + | ApplySetLfpInduct + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(ScopedCheckedCore global) + !(KernelDerivation global) + !(KernelDerivation global) + !(KernelDerivation global) + deriving stock (Eq) + +mapKernelDerivationGlobals + :: (left -> right) + -> KernelDerivation left + -> KernelDerivation right +mapKernelDerivationGlobals transform = go + where + scoped = mapScopedGlobals transform + go = \case + UseImportedFact index -> + UseImportedFact index + UseLocalHypothesis index -> + UseLocalHypothesis index + UseFoundationFact tag -> + UseFoundationFact tag + ImplicationElimination premise implication -> + ImplicationElimination (go premise) (go implication) + ForallElimination proof argument -> + ForallElimination (go proof) (scoped argument) + FalsumElimination proof target -> + FalsumElimination (go proof) (scoped target) + ImplicationIntroduction premise proof -> + ImplicationIntroduction (scoped premise) (go proof) + ForallIntroduction binderType proof -> + ForallIntroduction binderType (go proof) + ConvertJudgment proof target plan -> + ConvertJudgment (go proof) (scoped target) plan + EqualityReflexivity term -> + EqualityReflexivity (scoped term) + EqualityCongruenceApplication function argument -> + EqualityCongruenceApplication (go function) (go argument) + EqualityCongruenceLambda binderType proof -> + EqualityCongruenceLambda binderType (go proof) + EqualityModusPonens equality proof -> + EqualityModusPonens (go equality) (go proof) + ApplySetLfpBound domain operator -> + ApplySetLfpBound (scoped domain) (scoped operator) + ApplySetLfpLeast domain operator candidate bounded closed -> + ApplySetLfpLeast + (scoped domain) + (scoped operator) + (scoped candidate) + (go bounded) + (go closed) + ApplySetLfpFixed domain operator monotone -> + ApplySetLfpFixed + (scoped domain) + (scoped operator) + (go monotone) + ApplySetLfpInduct domain operator predicate element + monotone member closed -> + ApplySetLfpInduct + (scoped domain) + (scoped operator) + (scoped predicate) + (scoped element) + (go monotone) + (go member) + (go closed) + +importedFactDerivation + :: ImportIx + -> KernelDerivation global +importedFactDerivation = + UseImportedFact + +localHypothesisDerivation + :: HypothesisIx + -> KernelDerivation global +localHypothesisDerivation = + UseLocalHypothesis + +foundationFactDerivation + :: FoundationAxiomTag + -> KernelDerivation global +foundationFactDerivation = + UseFoundationFact + +implicationEliminationDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +implicationEliminationDerivation = + ImplicationElimination + +forallEliminationDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> KernelDerivation global +forallEliminationDerivation = + ForallElimination + +falsumEliminationDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> KernelDerivation global +falsumEliminationDerivation = + FalsumElimination + +implicationIntroductionDerivation + :: ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global +implicationIntroductionDerivation = + ImplicationIntroduction + +forallIntroductionDerivation + :: CoreType + -> KernelDerivation global + -> KernelDerivation global +forallIntroductionDerivation = + ForallIntroduction + +newtype ConversionPlan = ConversionPlan Natural + deriving stock (Show, Eq, Ord) + +data ConversionPlanError = + ConversionPlanExceedsLimit !Natural + deriving stock (Show, Eq) + +conversionPlanLimit :: Natural +conversionPlanLimit = + 100000 + +conversionPlan + :: Natural + -> Either ConversionPlanError ConversionPlan +conversionPlan budget + | budget <= conversionPlanLimit = + Right (ConversionPlan budget) + | otherwise = + Left (ConversionPlanExceedsLimit budget) + +conversionPlanBudget :: ConversionPlan -> Natural +conversionPlanBudget (ConversionPlan budget) = + budget + +convertJudgmentDerivation + :: KernelDerivation global + -> ScopedCheckedCore global + -> ConversionPlan + -> KernelDerivation global +convertJudgmentDerivation = + ConvertJudgment + +equalityReflexivityDerivation + :: FrozenCheckedCore global + -> KernelDerivation global +equalityReflexivityDerivation = + EqualityReflexivity . embedClosedCore [] + +scopedEqualityReflexivityDerivation + :: ScopedCheckedCore global + -> KernelDerivation global +scopedEqualityReflexivityDerivation = + EqualityReflexivity + +equalityCongruenceApplicationDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +equalityCongruenceApplicationDerivation = + EqualityCongruenceApplication + +equalityCongruenceLambdaDerivation + :: CoreType + -> KernelDerivation global + -> KernelDerivation global +equalityCongruenceLambdaDerivation = + EqualityCongruenceLambda + +equalityModusPonensDerivation + :: KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +equalityModusPonensDerivation = + EqualityModusPonens + +setLfpBoundDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global +setLfpBoundDerivation = + ApplySetLfpBound + +setLfpLeastDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +setLfpLeastDerivation = + ApplySetLfpLeast + +setLfpFixedDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global +setLfpFixedDerivation = + ApplySetLfpFixed + +setLfpInductDerivation + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global + -> KernelDerivation global +setLfpInductDerivation = + ApplySetLfpInduct + +-- | Add hypotheses outside a derivation while preserving hypotheses introduced +-- by implication nodes inside it. +weakenDerivationHypotheses + :: Natural + -> KernelDerivation global + -> KernelDerivation global +weakenDerivationHypotheses amount = + shift 0 + where + shift cutoff = \case + UseImportedFact index -> + UseImportedFact index + UseLocalHypothesis (HypothesisIx index) -> + UseLocalHypothesis + (HypothesisIx + (if index >= cutoff + then index + amount + else index)) + UseFoundationFact tag -> + UseFoundationFact tag + ImplicationElimination implication premise -> + ImplicationElimination + (shift cutoff implication) + (shift cutoff premise) + ForallElimination quantified argument -> + ForallElimination + (shift cutoff quantified) + argument + FalsumElimination falsum target -> + FalsumElimination + (shift cutoff falsum) + target + ImplicationIntroduction premise body -> + ImplicationIntroduction + premise + (shift (cutoff + 1) body) + ForallIntroduction binderType body -> + ForallIntroduction + binderType + (shift cutoff body) + ConvertJudgment source target plan -> + ConvertJudgment + (shift cutoff source) + target + plan + EqualityReflexivity operand -> + EqualityReflexivity operand + EqualityCongruenceApplication function argument -> + EqualityCongruenceApplication + (shift cutoff function) + (shift cutoff argument) + EqualityCongruenceLambda binderType body -> + EqualityCongruenceLambda + binderType + (shift cutoff body) + EqualityModusPonens equality premise -> + EqualityModusPonens + (shift cutoff equality) + (shift cutoff premise) + ApplySetLfpBound domain operator -> + ApplySetLfpBound domain operator + ApplySetLfpLeast + domain operator candidate + closed bounded -> + ApplySetLfpLeast + domain + operator + candidate + (shift cutoff closed) + (shift cutoff bounded) + ApplySetLfpFixed domain operator monotone -> + ApplySetLfpFixed + domain + operator + (shift cutoff monotone) + ApplySetLfpInduct + domain operator predicate element + monotone member closure -> + ApplySetLfpInduct + domain + operator + predicate + element + (shift cutoff monotone) + (shift cutoff member) + (shift cutoff closure) + +data KernelReplayLimits = KernelReplayLimits + !Natural + !Natural + deriving stock (Show, Eq) + +data KernelReplayLimitError + = KernelReplayNodeLimitIsZero + | KernelReplayNodeLimitTooLarge !Natural + | KernelReplayDepthLimitTooLarge !Natural + deriving stock (Show, Eq) + +maximumKernelReplayNodes :: Natural +maximumKernelReplayNodes = + 1000000 + +maximumKernelReplayDepth :: Natural +maximumKernelReplayDepth = + 4096 + +kernelReplayLimits + :: Natural + -> Natural + -> Either KernelReplayLimitError KernelReplayLimits +kernelReplayLimits nodeLimit depthLimit + | nodeLimit == 0 = + Left KernelReplayNodeLimitIsZero + | nodeLimit > maximumKernelReplayNodes = + Left (KernelReplayNodeLimitTooLarge nodeLimit) + | depthLimit > maximumKernelReplayDepth = + Left (KernelReplayDepthLimitTooLarge depthLimit) + | otherwise = + Right + (KernelReplayLimits + nodeLimit + depthLimit) + +defaultKernelReplayLimits :: KernelReplayLimits +defaultKernelReplayLimits = + KernelReplayLimits + 200000 + 2048 + +data ReplayedKernelDerivation global = + ReplayedKernelDerivation + !(FrozenCheckedCore global) + !(Set ImportIx) + !(Set FoundationAxiomTag) + !(Set KernelRuleTag) + !Natural + !Natural + deriving stock (Eq) + +replayedKernelTarget + :: ReplayedKernelDerivation global + -> FrozenCheckedCore global +replayedKernelTarget + (ReplayedKernelDerivation + target + _importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + target + +replayedKernelImportUses + :: ReplayedKernelDerivation global + -> Set ImportIx +replayedKernelImportUses + (ReplayedKernelDerivation + _target + importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + importUses + +replayedKernelFoundationUses + :: ReplayedKernelDerivation global + -> Set FoundationAxiomTag +replayedKernelFoundationUses + (ReplayedKernelDerivation + _target + _importUses + foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + foundationUses + +replayedKernelRuleUses + :: ReplayedKernelDerivation global + -> Set KernelRuleTag +replayedKernelRuleUses + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + ruleUses + _nodeCount + _maximumDepth) = + ruleUses + +replayedKernelNodeCount + :: ReplayedKernelDerivation global + -> Natural +replayedKernelNodeCount + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + _ruleUses + nodeCount + _maximumDepth) = + nodeCount + +replayedKernelMaximumDepth + :: ReplayedKernelDerivation global + -> Natural +replayedKernelMaximumDepth + (ReplayedKernelDerivation + _target + _importUses + _foundationUses + _ruleUses + _nodeCount + maximumDepth) = + maximumDepth + +data ReplayStep global = ReplayStep + !(ScopedCheckedCore global) + !(Set ImportIx) + !(Set FoundationAxiomTag) + !(Set KernelRuleTag) + !Natural + !Natural + +data KernelReplayError + = KernelReplaySemanticsError + !Semantics.KernelSemanticsError + | KernelReplaySetLfpRuleError + !SetLfp.SetLfpRuleError + | KernelReplayImportOutOfBounds !ImportIx + | KernelReplayHypothesisOutOfBounds !HypothesisIx + | KernelReplayStoredContextMismatch + ![CoreType] + ![CoreType] + | KernelReplayStoredTermIllTyped !CoreCheckError + | KernelReplayStoredTypeMismatch + !CoreType + !CoreType + | KernelReplayWeakeningError !CoreCheckError + | KernelReplayNodeLimitExceeded !Natural + | KernelReplayDepthLimitExceeded !Natural + | KernelReplayRootRemainedOpen + | KernelReplayTargetMismatch + deriving stock (Show, Eq) + +replayKernelDerivation + :: Eq global + => CheckedFoundation + -> KernelReplayLimits + -> (global -> Maybe CoreType) + -> Vector (DerivationImportJudgment global) + -> FrozenCheckedCore global + -> KernelDerivation global + -> Either + KernelReplayError + (ReplayedKernelDerivation global) +replayKernelDerivation + checkedFoundationValue + limits + globalType + imports + expectedTarget + derivation = + checkedFoundationValue `seq` do + expectedTarget' <- + recheckClosed expectedTarget + ReplayStep + synthesized + importUses + foundationUses + ruleUses + nodeCount + maximumDepth <- + replay [] [] 0 derivation + closed <- + maybe + (Left KernelReplayRootRemainedOpen) + Right + (closeScopedCore synthesized) + unless + (closed == expectedTarget') + (Left KernelReplayTargetMismatch) + pure + (ReplayedKernelDerivation + closed + importUses + foundationUses + ruleUses + nodeCount + maximumDepth) + where + replay context hypotheses depth derivationNode + | depth > replayDepthLimit = + Left + (KernelReplayDepthLimitExceeded + replayDepthLimit) + | otherwise = do + step <- + replayWithin + context + hypotheses + depth + derivationNode + if stepNodeCount step > replayNodeLimit + then + Left + (KernelReplayNodeLimitExceeded + replayNodeLimit) + else + Right step + + replayWithin context hypotheses depth = \case + UseImportedFact index -> do + judgment <- + lookupImport index + statement <- + recheckStored + context + (embedClosedCore context + (derivationImportStatement + judgment)) + pure + (leaf + depth + statement + (Set.singleton index) + mempty) + UseLocalHypothesis index -> do + hypothesis <- + lookupHypothesis index hypotheses + checkedHypothesis <- + recheckStored context hypothesis + pure + (leaf + depth + checkedHypothesis + mempty + mempty) + UseFoundationFact tag -> do + statement <- + recheckStored + context + (embedClosedCore context + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + checkedFoundationValue + tag))) + pure + (leaf + depth + statement + mempty + (Set.singleton tag)) + ImplicationElimination implication premise -> do + implicationStep <- + replay context hypotheses (depth + 1) implication + premiseStep <- + replay context hypotheses (depth + 1) premise + combine2 depth + (Semantics.implicationElimination + globalType + (stepValue implicationStep) + (stepValue premiseStep)) + implicationStep + premiseStep + ForallElimination quantified argument -> do + argument' <- + recheckStored context argument + quantifiedStep <- + replay context hypotheses (depth + 1) quantified + combine1 depth + (Semantics.forallElimination + globalType + (stepValue quantifiedStep) + argument') + quantifiedStep + FalsumElimination falsum target -> do + target' <- + recheckStored context target + falsumStep <- + replay context hypotheses (depth + 1) falsum + combine1 depth + (Semantics.falsumElimination + globalType + (stepValue falsumStep) + target') + falsumStep + ImplicationIntroduction premise body -> do + premise' <- + recheckStored context premise + bodyStep <- + replay + context + (premise' : hypotheses) + (depth + 1) + body + combine1 depth + (Semantics.implicationIntroduction + globalType + premise' + (stepValue bodyStep)) + bodyStep + ForallIntroduction binderType body -> do + weakenedHypotheses <- + traverse + (first KernelReplayWeakeningError + . weakenScopedCore + globalType + binderType) + hypotheses + bodyStep <- + replay + (binderType : context) + weakenedHypotheses + (depth + 1) + body + combine1 depth + (Semantics.forallIntroduction + globalType + binderType + (stepValue bodyStep)) + bodyStep + ConvertJudgment source target plan -> do + target' <- + recheckStored context target + sourceStep <- + replay + context + hypotheses + (depth + 1) + source + combine1 depth + (Semantics.convertJudgment + globalType + (conversionPlanBudget plan) + (stepValue sourceStep) + target') + sourceStep + EqualityReflexivity operand -> do + operand' <- + recheckStored context operand + value <- + first KernelReplaySemanticsError + (Semantics.equalityReflexivity + globalType + operand') + pure (leaf depth value mempty mempty) + EqualityCongruenceApplication + functionEquality + argumentEquality -> do + functionStep <- + replay + context + hypotheses + (depth + 1) + functionEquality + argumentStep <- + replay + context + hypotheses + (depth + 1) + argumentEquality + combine2 depth + (Semantics.equalityCongruenceApplication + globalType + (stepValue functionStep) + (stepValue argumentStep)) + functionStep + argumentStep + EqualityCongruenceLambda binderType bodyEquality -> do + weakenedHypotheses <- + traverse + (first KernelReplayWeakeningError + . weakenScopedCore + globalType + binderType) + hypotheses + bodyStep <- + replay + (binderType : context) + weakenedHypotheses + (depth + 1) + bodyEquality + combine1 depth + (Semantics.equalityCongruenceLambda + globalType + binderType + (stepValue bodyStep)) + bodyStep + EqualityModusPonens equality premise -> do + equalityStep <- + replay context hypotheses (depth + 1) equality + premiseStep <- + replay context hypotheses (depth + 1) premise + combine2 depth + (Semantics.equalityModusPonens + globalType + (stepValue equalityStep) + (stepValue premiseStep)) + equalityStep + premiseStep + ApplySetLfpBound domain operator -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + value <- + first KernelReplaySetLfpRuleError + (SetLfp.setLfpBound + checkedFoundationValue + globalType + domain' + operator') + pure + (ruleLeaf + depth + SetLfpBound + value) + ApplySetLfpLeast + domain + operator + candidate + closedPremise + boundedPremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + candidate' <- + recheckStored context candidate + closedStep <- + replay + context + hypotheses + (depth + 1) + closedPremise + boundedStep <- + replay + context + hypotheses + (depth + 1) + boundedPremise + combineRule depth SetLfpLeast + (SetLfp.setLfpLeast + checkedFoundationValue + globalType + domain' + operator' + candidate' + (stepValue closedStep) + (stepValue boundedStep)) + [closedStep, boundedStep] + ApplySetLfpFixed domain operator monotonePremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + monotoneStep <- + replay + context + hypotheses + (depth + 1) + monotonePremise + combineRule depth SetLfpFixed + (SetLfp.setLfpFixed + checkedFoundationValue + globalType + domain' + operator' + (stepValue monotoneStep)) + [monotoneStep] + ApplySetLfpInduct + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise -> do + domain' <- + recheckStored context domain + operator' <- + recheckStored context operator + predicate' <- + recheckStored context predicate + element' <- + recheckStored context element + monotoneStep <- + replay + context + hypotheses + (depth + 1) + monotonePremise + memberStep <- + replay + context + hypotheses + (depth + 1) + memberPremise + closureStep <- + replay + context + hypotheses + (depth + 1) + closurePremise + combineRule depth SetLfpInduct + (SetLfp.setLfpInduct + checkedFoundationValue + globalType + domain' + operator' + predicate' + element' + (stepValue monotoneStep) + (stepValue memberStep) + (stepValue closureStep)) + [ monotoneStep + , memberStep + , closureStep + ] + + lookupImport index@(ImportIx naturalIndex) + | naturalIndex + > fromIntegral (maxBound :: Int) = + Left + (KernelReplayImportOutOfBounds + index) + | otherwise = + maybe + (Left + (KernelReplayImportOutOfBounds + index)) + Right + (imports + Vector.!? + (fromIntegral naturalIndex)) + + lookupHypothesis + index@(HypothesisIx naturalIndex) + hypotheses = + maybe + (Left + (KernelReplayHypothesisOutOfBounds + index)) + Right + (atNatural naturalIndex hypotheses) + + requireContext expected value + | scopedCoreContext value == expected = + Right () + | otherwise = + Left + (KernelReplayStoredContextMismatch + expected + (scopedCoreContext value)) + + recheckStored expectedContext stored = do + requireContext expectedContext stored + checked <- + first KernelReplayStoredTermIllTyped + (checkScopedCanonicalCore + globalType + expectedContext + (scopedCoreTerm stored)) + unless + (scopedCoreType checked + == scopedCoreType stored) + (Left + (KernelReplayStoredTypeMismatch + (scopedCoreType stored) + (scopedCoreType checked))) + pure checked + + recheckClosed stored = do + checked <- + first KernelReplayStoredTermIllTyped + (checkCanonicalCore + globalType + (frozenCoreTerm stored)) + unless + (frozenCoreType checked + == frozenCoreType stored) + (Left + (KernelReplayStoredTypeMismatch + (frozenCoreType stored) + (frozenCoreType checked))) + pure checked + + replayNodeLimit = + case limits of + KernelReplayLimits nodeLimit _depthLimit -> + nodeLimit + + replayDepthLimit = + case limits of + KernelReplayLimits _nodeLimit depthLimit -> + depthLimit + +leaf + :: Natural + -> ScopedCheckedCore global + -> Set ImportIx + -> Set FoundationAxiomTag + -> ReplayStep global +leaf depth value importUses foundationUses = + ReplayStep + value + importUses + foundationUses + mempty + 1 + depth + +ruleLeaf + :: Natural + -> KernelRuleTag + -> ScopedCheckedCore global + -> ReplayStep global +ruleLeaf depth tag value = + ReplayStep + value + mempty + mempty + (Set.singleton tag) + 1 + depth + +stepValue :: ReplayStep global -> ScopedCheckedCore global +stepValue + (ReplayStep + value + _importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + value + +combine1 + :: Natural + -> Either + Semantics.KernelSemanticsError + (ScopedCheckedCore global) + -> ReplayStep global + -> Either KernelReplayError (ReplayStep global) +combine1 depth synthesized child = do + value <- + first KernelReplaySemanticsError synthesized + pure + (ReplayStep + value + (stepImportUses child) + (stepFoundationUses child) + (stepRuleUses child) + (1 + stepNodeCount child) + (max depth + (stepMaximumDepth child))) + +combine2 + :: Natural + -> Either + Semantics.KernelSemanticsError + (ScopedCheckedCore global) + -> ReplayStep global + -> ReplayStep global + -> Either KernelReplayError (ReplayStep global) +combine2 depth synthesized left right = do + value <- + first KernelReplaySemanticsError synthesized + pure + (ReplayStep + value + (stepImportUses left + <> stepImportUses right) + (stepFoundationUses left + <> stepFoundationUses right) + (stepRuleUses left + <> stepRuleUses right) + (1 + + stepNodeCount left + + stepNodeCount right) + (maximum + [ depth + , stepMaximumDepth left + , stepMaximumDepth right + ])) + +combineRule + :: Natural + -> KernelRuleTag + -> Either + SetLfp.SetLfpRuleError + (ScopedCheckedCore global) + -> [ReplayStep global] + -> Either KernelReplayError (ReplayStep global) +combineRule depth tag synthesized children = do + value <- + first KernelReplaySetLfpRuleError synthesized + pure + (ReplayStep + value + (foldMap stepImportUses children) + (foldMap stepFoundationUses children) + (Set.insert tag + (foldMap stepRuleUses children)) + (1 + sum (stepNodeCount <$> children)) + (maximum + (depth + : (stepMaximumDepth <$> children)))) + +stepImportUses + :: ReplayStep global + -> Set ImportIx +stepImportUses + (ReplayStep + _value + importUses + _foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + importUses + +stepFoundationUses + :: ReplayStep global + -> Set FoundationAxiomTag +stepFoundationUses + (ReplayStep + _value + _importUses + foundationUses + _ruleUses + _nodeCount + _maximumDepth) = + foundationUses + +stepRuleUses + :: ReplayStep global + -> Set KernelRuleTag +stepRuleUses + (ReplayStep + _value + _importUses + _foundationUses + ruleUses + _nodeCount + _maximumDepth) = + ruleUses + +stepNodeCount :: ReplayStep global -> Natural +stepNodeCount + (ReplayStep + _value + _importUses + _foundationUses + _ruleUses + nodeCount + _maximumDepth) = + nodeCount + +stepMaximumDepth :: ReplayStep global -> Natural +stepMaximumDepth + (ReplayStep + _value + _importUses + _foundationUses + _ruleUses + _nodeCount + maximumDepth) = + maximumDepth + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest diff --git a/source/Felix/Checking/Kernel/Proof.hs b/source/Felix/Checking/Kernel/Proof.hs new file mode 100644 index 0000000..d4ccedc --- /dev/null +++ b/source/Felix/Checking/Kernel/Proof.hs @@ -0,0 +1,1443 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Small proof-producing natural-deduction combinators. Every resulting tree +-- is still replayed independently before it can authorize a fact. +module Felix.Checking.Kernel.Proof + ( ProofContext + , rootProofContext + , proofContextTypes + , scopedTerm + , BuiltProof + , builtProofStatement + , builtProofDerivation + , importedProof + , foundationProof + , hypothesisProof + , implicationEliminationProof + , implicationIntroductionProof + , forallEliminationProof + , forallIntroductionProof + , falsumEliminationProof + , equalityReflexivityProof + , equalityReverseProof + , equalityCongruenceApplicationProof + , equalityModusPonensProof + , conversionProof + , doubleNegationEliminationProof + , conjunctionTerm + , conjunctionIntroductionProof + , conjunctionLeftProof + , conjunctionRightProof + , disjunctionTerm + , disjunctionLeftProof + , disjunctionRightProof + , disjunctionEliminationProof + , validateCaseAnalysisComposition + , validateDoubleNegationComposition + , validateFalsumEliminationComposition + , validateSetInductionComposition + , existentialTerm + , existentialIntroductionProof + , existentialEliminationProof + , setLfpBoundProof + , setLfpFixedProof + , setLfpInductProof + , KernelProofBuildError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Numeric.Natural (Natural) + + +data ProofContext global = ProofContext + !CheckedFoundation + !(global -> Maybe CoreType) + ![CoreType] + ![ScopedCheckedCore global] + +rootProofContext + :: CheckedFoundation + -> (global -> Maybe CoreType) + -> ProofContext global +rootProofContext foundation globalType = + ProofContext foundation globalType [] [] + +proofContextTypes + :: ProofContext global + -> [CoreType] +proofContextTypes + (ProofContext + _foundation + _globalType + context + _hypotheses) = + context + +data BuiltProof global = BuiltProof + !(ScopedCheckedCore global) + !(KernelDerivation global) + +builtProofStatement + :: BuiltProof global + -> ScopedCheckedCore global +builtProofStatement + (BuiltProof statement _derivation) = + statement + +builtProofDerivation + :: BuiltProof global + -> KernelDerivation global +builtProofDerivation + (BuiltProof _statement derivation) = + derivation + +data KernelProofBuildError + = ProofTermIllTyped !CoreCheckError + | ProofSemanticsFailed + !Semantics.KernelSemanticsError + | ProofFoundationArgumentMismatch + !FoundationAxiomTag + | ProofHypothesisNotFound + | ProofExpectedEquality + | ProofExpectedUnaryBinder + | ProofSetLfpRuleFailed !Text + | ProofConversionPlanFailed !Text + | ProofStructuralCompositionMismatch !Text + deriving stock (Show, Eq) + +scopedTerm + :: ProofContext global + -> CanonicalTerm global + -> Either + KernelProofBuildError + (ScopedCheckedCore global) +scopedTerm + (ProofContext + _foundation + globalType + context + _hypotheses) = + first ProofTermIllTyped + . checkScopedCanonicalCore + globalType + context + +importedProof + :: ProofContext global + -> ImportIx + -> FrozenCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +importedProof context index statement = + pure + (BuiltProof + (embedClosedCore + (proofContextTypes context) + statement) + (importedFactDerivation index)) + +foundationProof + :: ProofContext global + -> FoundationAxiomTag + -> Either + KernelProofBuildError + (BuiltProof global) +foundationProof + context@(ProofContext + foundation + _globalType + _types + _hypotheses) + tag = + pure + (BuiltProof + (embedClosedCore + (proofContextTypes context) + (mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag))) + (foundationFactDerivation tag)) + +hypothesisProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +hypothesisProof + (ProofContext + _foundation + _globalType + _context + hypotheses) + statement = + case List.findIndex (== statement) hypotheses of + Nothing -> + Left ProofHypothesisNotFound + Just index -> + pure + (BuiltProof + statement + (localHypothesisDerivation + (hypothesisIx + (fromIntegral index)))) + +implicationEliminationProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +implicationEliminationProof + (ProofContext + _foundation + globalType + _context + _hypotheses) + implication + premise = do + conclusion <- + first ProofSemanticsFailed + (Semantics.implicationElimination + globalType + (builtProofStatement implication) + (builtProofStatement premise)) + pure + (BuiltProof + conclusion + (implicationEliminationDerivation + (builtProofDerivation implication) + (builtProofDerivation premise))) + +implicationIntroductionProof + :: ProofContext global + -> ScopedCheckedCore global + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +implicationIntroductionProof + (ProofContext + foundation + globalType + types + hypotheses) + premise + buildBody = do + let extended = + ProofContext + foundation + globalType + types + (premise : hypotheses) + premiseProof = + BuiltProof + premise + (localHypothesisDerivation + (hypothesisIx 0)) + body <- + buildBody extended premiseProof + conclusion <- + first ProofSemanticsFailed + (Semantics.implicationIntroduction + globalType + premise + (builtProofStatement body)) + pure + (BuiltProof + conclusion + (implicationIntroductionDerivation + premise + (builtProofDerivation body))) + +forallEliminationProof + :: ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +forallEliminationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + quantified + argument = do + conclusion <- + first ProofSemanticsFailed + (Semantics.forallElimination + globalType + (builtProofStatement quantified) + argument) + pure + (BuiltProof + conclusion + (forallEliminationDerivation + (builtProofDerivation quantified) + argument)) + +forallIntroductionProof + :: ProofContext global + -> CoreType + -> ( ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +forallIntroductionProof + (ProofContext + foundation + globalType + types + hypotheses) + binderType + buildBody = do + weakenedHypotheses <- + traverse + (first ProofTermIllTyped + . weakenScopedCore + globalType + binderType) + hypotheses + let extended = + ProofContext + foundation + globalType + (binderType : types) + weakenedHypotheses + variable <- + scopedTerm extended (CBound 0) + body <- + buildBody extended variable + conclusion <- + first ProofSemanticsFailed + (Semantics.forallIntroduction + globalType + binderType + (builtProofStatement body)) + pure + (BuiltProof + conclusion + (forallIntroductionDerivation + binderType + (builtProofDerivation body))) + +falsumEliminationProof + :: ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +falsumEliminationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + falsum + target = do + conclusion <- + first ProofSemanticsFailed + (Semantics.falsumElimination + globalType + (builtProofStatement falsum) + target) + pure + (BuiltProof + conclusion + (falsumEliminationDerivation + (builtProofDerivation falsum) + target)) + +equalityReflexivityProof + :: ProofContext global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityReflexivityProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + operand = do + equality <- + first ProofSemanticsFailed + (Semantics.equalityReflexivity + globalType + operand) + pure + (BuiltProof + equality + (scopedEqualityReflexivityDerivation + operand)) + +equalityCongruenceApplicationProof + :: ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityCongruenceApplicationProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + functionEquality + argumentEquality = do + equality <- + first ProofSemanticsFailed + (Semantics.equalityCongruenceApplication + globalType + (builtProofStatement functionEquality) + (builtProofStatement argumentEquality)) + pure + (BuiltProof + equality + (equalityCongruenceApplicationDerivation + (builtProofDerivation + functionEquality) + (builtProofDerivation + argumentEquality))) + +equalityModusPonensProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityModusPonensProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + equality + premise = do + conclusion <- + first ProofSemanticsFailed + (Semantics.equalityModusPonens + globalType + (builtProofStatement equality) + (builtProofStatement premise)) + pure + (BuiltProof + conclusion + (equalityModusPonensDerivation + (builtProofDerivation equality) + (builtProofDerivation premise))) + +conversionProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +conversionProof + (ProofContext + _foundation + globalType + _types + _hypotheses) + source + target = do + plan <- + first (ProofConversionPlanFailed . Text.pack . show) + (conversionPlan 100000) + result <- + first ProofSemanticsFailed + (Semantics.convertJudgment + globalType + (conversionPlanBudget plan) + (builtProofStatement source) + target) + pure + (BuiltProof + result + (convertJudgmentDerivation + (builtProofDerivation source) + target + plan)) + +equalityReverseProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +equalityReverseProof context equality = do + (operandType, left, right) <- + equalityParts + (builtProofStatement equality) + leftOperand <- + scopedTerm context left + weakenedLeft <- + first ProofTermIllTyped + (weakenScopedCore + (contextGlobalType context) + operandType + leftOperand) + function <- + scopedTerm context + (CLam operandType + (CEq + operandType + (CBound 0) + (scopedCoreTerm + weakenedLeft))) + functionReflexivity <- + equalityReflexivityProof + context + function + appliedEquality <- + equalityCongruenceApplicationProof + context + functionReflexivity + equality + leftReflexivity <- + equalityReflexivityProof + context + leftOperand + appliedLeft <- + scopedTerm context + (CApp + (scopedCoreTerm function) + left) + appliedLeftReflexivity <- + conversionProof + context + leftReflexivity + appliedLeft + reversedApplication <- + equalityModusPonensProof + context + appliedEquality + appliedLeftReflexivity + expected <- + scopedTerm context + (CEq operandType right left) + conversionProof + context + reversedApplication + expected + +doubleNegationEliminationProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +doubleNegationEliminationProof + context + target + doubleNegation = do + axiom <- + foundationProof + context + DoubleNegationElim + instanceProof <- + forallEliminationProof + context + axiom + target + implicationEliminationProof + context + instanceProof + doubleNegation + +conjunctionTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +conjunctionTerm left right = + CImp + (CImp left + (CImp right CFalsum)) + CFalsum + +conjunctionIntroductionProof + :: Eq global + => ProofContext global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionIntroductionProof + context + left + right = do + let leftTerm = + scopedCoreTerm + (builtProofStatement left) + rightTerm = + scopedCoreTerm + (builtProofStatement right) + refuter <- + scopedTerm context + (CImp leftTerm + (CImp rightTerm CFalsum)) + implicationIntroductionProof + context + refuter + (\extended refuterProof -> do + firstApplication <- + implicationEliminationProof + extended + refuterProof + (weakenForHypothesis left) + implicationEliminationProof + extended + firstApplication + (weakenForHypothesis right)) + +conjunctionLeftProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionLeftProof context left right conjunction = do + leftProposition <- + scopedTerm context left + notLeft <- + scopedTerm context + (CImp left CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notLeft + (\withNotLeft _notLeftProof -> do + leftAtRefuter <- + scopedTerm withNotLeft left + refuterProof <- + implicationIntroductionProof + withNotLeft + leftAtRefuter + (\withLeft leftProof -> do + rightProposition <- + scopedTerm withLeft right + implicationIntroductionProof + withLeft + rightProposition + (\withBoth _rightProof -> do + notLeftCurrent <- + hypothesisProof + withBoth + notLeft + implicationEliminationProof + withBoth + notLeftCurrent + (weakenForHypothesis + leftProof))) + implicationEliminationProof + withNotLeft + (weakenForHypothesis conjunction) + refuterProof) + doubleNegationEliminationProof + context + leftProposition + doubleNegation + +conjunctionRightProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +conjunctionRightProof context left right conjunction = do + rightProposition <- + scopedTerm context right + notRight <- + scopedTerm context + (CImp right CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notRight + (\withNotRight _notRightProof -> do + leftAtRefuter <- + scopedTerm withNotRight left + refuterProof <- + implicationIntroductionProof + withNotRight + leftAtRefuter + (\withLeft _leftProof -> do + rightAtLeft <- + scopedTerm + withLeft + right + implicationIntroductionProof + withLeft + rightAtLeft + (\withBoth rightProof -> do + notRightCurrent <- + hypothesisProof + withBoth + notRight + implicationEliminationProof + withBoth + notRightCurrent + rightProof)) + implicationEliminationProof + withNotRight + (weakenForHypothesis conjunction) + refuterProof) + doubleNegationEliminationProof + context + rightProposition + doubleNegation + +disjunctionTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +disjunctionTerm left right = + CImp + (CImp left CFalsum) + right + +disjunctionLeftProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionLeftProof context right leftProof = do + notLeft <- + scopedTerm context + (CImp + (scopedCoreTerm + (builtProofStatement leftProof)) + CFalsum) + rightTarget <- + scopedTerm context right + implicationIntroductionProof + context + notLeft + (\extended notLeftProof -> do + falsum <- + implicationEliminationProof + extended + notLeftProof + (weakenForHypothesis + leftProof) + falsumEliminationProof + extended + falsum + rightTarget) + +disjunctionRightProof + :: ProofContext global + -> CanonicalTerm global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionRightProof context left rightProof = do + notLeft <- + scopedTerm context + (CImp left CFalsum) + implicationIntroductionProof + context + notLeft + (\_extended _notLeftProof -> + pure + (weakenForHypothesis + rightProof)) + +disjunctionEliminationProof + :: Eq global + => ProofContext global + -> CanonicalTerm global + -> CanonicalTerm global + -> BuiltProof global + -> ScopedCheckedCore global + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> ( ProofContext global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +disjunctionEliminationProof + context + left + right + disjunction + result + leftCase + rightCase = do + leftProposition <- + scopedTerm context left + rightProposition <- + scopedTerm context right + leftImplication <- + implicationIntroductionProof + context + leftProposition + leftCase + rightImplication <- + implicationIntroductionProof + context + rightProposition + rightCase + notResult <- + scopedTerm context + (CImp + (scopedCoreTerm result) + CFalsum) + doubleNegation <- + implicationIntroductionProof + context + notResult + (\extended notResultProof -> do + leftAtNotResult <- + scopedTerm extended left + notLeftProof <- + implicationIntroductionProof + extended + leftAtNotResult + (\withLeft leftProof -> do + resultProof <- + implicationEliminationProof + withLeft + (weakenForHypothesis + (weakenForHypothesis + leftImplication)) + leftProof + implicationEliminationProof + withLeft + (weakenForHypothesis + notResultProof) + resultProof) + rightProof <- + implicationEliminationProof + extended + (weakenForHypothesis + disjunction) + notLeftProof + resultProof <- + implicationEliminationProof + extended + (weakenForHypothesis + rightImplication) + rightProof + implicationEliminationProof + extended + notResultProof + resultProof) + doubleNegationEliminationProof + context + result + doubleNegation + +-- | Validate the one structural rule used by exact source case analysis. +-- The branch proofs and the exhaustive disjunction are represented here by +-- exact hypotheses; the kernel combinators must derive the owned goal from +-- precisely those propositions. No derived proof escapes this check. +validateCaseAnalysisComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateCaseAnalysisComposition + foundation globalType goal cases exhaustive = do + validatePropositionContext "case goal" lexicalContext goal + traverse_ + (validatePropositionContext "case assumption" lexicalContext) + cases + validatePropositionContext + "case exhaustiveness target" lexicalContext exhaustive + let expectedExhaustive = + foldl1 + (\left right -> + CImp + (CImp left CFalsum) + right) + (scopedCoreTerm <$> cases) + unless (scopedCoreTerm exhaustive == expectedExhaustive) + (Left + (ProofStructuralCompositionMismatch + "case exhaustiveness is not the source-ordered disjunction")) + branchImplications <- + traverse + (checkedImplication lexicalContext goal) + cases + let context = + ProofContext + foundation + globalType + lexicalContext + (exhaustive : toList branchImplications) + exhaustiveProof <- hypothesisProof context exhaustive + result <- + eliminateCases + context goal cases exhaustiveProof + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "case elimination did not derive the owned goal")) + where + lexicalContext = scopedCoreContext goal + + checkedImplication expectedContext conclusion antecedent = + case implyScopedCore antecedent conclusion of + Just implication + | scopedCoreContext implication == expectedContext -> + pure implication + _ -> + Left + (ProofStructuralCompositionMismatch + "case branch implication changed context") + + eliminateCases context result (only :| []) caseProof = do + branchImplication <- + scopedTerm context + (CImp + (scopedCoreTerm only) + (scopedCoreTerm result)) + >>= hypothesisProof context + implicationEliminationProof context branchImplication caseProof + eliminateCases context result (firstCase :| rest) disjunctionProof = do + let allCases = firstCase :| rest + leftCases = NonEmpty.fromList (NonEmpty.init allCases) + rightCase = NonEmpty.last allCases + leftTerm = + foldl1 disjunctionTerm + (scopedCoreTerm <$> leftCases) + disjunctionEliminationProof + context + leftTerm + (scopedCoreTerm rightCase) + disjunctionProof + result + (\extended leftProof -> + eliminateCases extended result leftCases leftProof) + (\extended rightProof -> do + branchImplication <- + scopedTerm extended + (CImp + (scopedCoreTerm rightCase) + (scopedCoreTerm result)) + >>= hypothesisProof extended + implicationEliminationProof + extended branchImplication rightProof) + +-- | Validate the exact classical closing step for a proof by contradiction. +-- The only classical input is the confined 'DoubleNegationElim' foundation +-- row already consumed by 'doubleNegationEliminationProof'. +validateDoubleNegationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateDoubleNegationComposition + foundation globalType goal negation falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext + "contradiction negation" lexicalContext negation + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not target falsum")) + expectedNegation <- + checkedNegation lexicalContext goal + unless (negation == expectedNegation) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not own the exact negated goal")) + doubleNegation <- + checkedNegation lexicalContext negation + let context = + ProofContext + foundation globalType lexicalContext [doubleNegation] + hypothesis <- hypothesisProof context doubleNegation + result <- doubleNegationEliminationProof context goal hypothesis + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "double-negation elimination did not derive the owned goal")) + +-- | Validate the exact ex-falso closing step used after a terminal indirect +-- contradiction discharge. +validateFalsumEliminationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateFalsumEliminationComposition foundation globalType goal falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not receive falsum")) + let context = + ProofContext foundation globalType lexicalContext [falsum] + hypothesis <- hypothesisProof context falsum + result <- falsumEliminationProof context hypothesis goal + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not derive the owned goal")) + +-- | Validate the exact structural instance used by source set induction. +-- The admitted child is represented by its generalized step proposition; +-- the checked foundation row must specialize to that exact premise and the +-- owned binder-level result. No induction principle becomes an ATP premise. +validateSetInductionComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> Natural + -> ScopedCheckedCore global + -> [ScopedCheckedCore global] + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateSetInductionComposition + foundation globalType selected property antecedents childTarget + hypothesis result = do + let lexicalContext = scopedCoreContext property + traverse_ + (validatePropositionContext + "set-induction antecedent" lexicalContext) + antecedents + validatePropositionContext + "set-induction property" lexicalContext property + validatePropositionContext + "set-induction child target" lexicalContext childTarget + validatePropositionContext + "set-induction hypothesis" lexicalContext hypothesis + validatePropositionContext + "set-induction result" lexicalContext result + expectedProperty <- + foldrM implyChecked childTarget antecedents + unless (property == expectedProperty) + (Left + (ProofStructuralCompositionMismatch + "set-induction property does not own the child target and guards")) + (predicate, expectedHypothesis, step, expectedResult) <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction focus is not a set-valued ambient binder")) + pure + (scopedSetInductionInstance selected property) + unless (hypothesis == expectedHypothesis) + (Left + (ProofStructuralCompositionMismatch + "set-induction hypothesis does not match the owned property")) + unless (result == expectedResult) + (Left + (ProofStructuralCompositionMismatch + "set-induction result does not close the owned property")) + let context = + ProofContext foundation globalType lexicalContext [step] + stepProof <- hypothesisProof context step + axiom <- foundationProof context SetInduction + instanceProof <- forallEliminationProof context axiom predicate + expectedInstance <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction instance changed lexical context")) + pure + (implyScopedCore step result) + convertedInstance <- + conversionProof context instanceProof expectedInstance + resultProof <- + implicationEliminationProof context convertedInstance stepProof + unless (builtProofStatement resultProof == result) + (Left + (ProofStructuralCompositionMismatch + "set-induction foundation instance did not derive the owned result")) + where + implyChecked antecedent conclusion = + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction guard changed lexical context")) + pure + (implyScopedCore antecedent conclusion) + +validatePropositionContext + :: Text + -> [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validatePropositionContext label expected proposition = + unless + ( scopedCoreType proposition == TyProp + && scopedCoreContext proposition == expected + ) + (Left + (ProofStructuralCompositionMismatch + (label <> " has the wrong type or lexical context"))) + +checkedNegation + :: [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError (ScopedCheckedCore global) +checkedNegation expectedContext proposition = + case negateScopedCore proposition of + Just negation + | scopedCoreContext negation == expectedContext -> + pure negation + _ -> + Left + (ProofStructuralCompositionMismatch + "classical negation changed context") + +existentialTerm + :: CoreType + -> CanonicalTerm global + -> CanonicalTerm global +existentialTerm binderType body = + CImp + (CForall binderType + (CImp body CFalsum)) + CFalsum + +existentialIntroductionProof + :: Eq global + => ProofContext global + -> CoreType + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +existentialIntroductionProof + context + binderType + bodyUnderBinder + witness + bodyAtWitness = do + unless + (proofContextTypes context + == drop 1 + (scopedCoreContext + bodyUnderBinder)) + (Left ProofExpectedUnaryBinder) + universalNegation <- + scopedTerm context + (CForall binderType + (CImp + (scopedCoreTerm + bodyUnderBinder) + CFalsum)) + implicationIntroductionProof + context + universalNegation + (\extended universalProof -> do + negatedBody <- + forallEliminationProof + extended + universalProof + witness + implicationEliminationProof + extended + negatedBody + (weakenForHypothesis + bodyAtWitness)) + +existentialEliminationProof + :: Eq global + => ProofContext global + -> CoreType + -> ScopedCheckedCore global + -> BuiltProof global + -> ScopedCheckedCore global + -> ( ProofContext global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) + ) + -> Either + KernelProofBuildError + (BuiltProof global) +existentialEliminationProof + context + binderType + bodyUnderBinder + existential + result + bodyCase = do + notResult <- + scopedTerm context + (CImp + (scopedCoreTerm result) + CFalsum) + notResultUnderBinder <- + first ProofTermIllTyped + (weakenScopedCore + (contextGlobalType context) + binderType + notResult) + doubleNegation <- + implicationIntroductionProof + context + notResult + (\withNotResult _notResultProof -> do + universalNegation <- + forallIntroductionProof + withNotResult + binderType + (\withBinder variable -> do + let body = + bodyUnderBinder + implicationIntroductionProof + withBinder + body + (\withBody bodyProof -> do + resultProof <- + bodyCase + withBody + variable + bodyProof + notResultCurrent <- + hypothesisProof + withBody + notResultUnderBinder + implicationEliminationProof + withBody + notResultCurrent + resultProof)) + implicationEliminationProof + withNotResult + (weakenForHypothesis + existential) + universalNegation) + doubleNegationEliminationProof + context + result + doubleNegation + +setLfpBoundProof + :: ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpBoundProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpBound + foundation + globalType + domain + operator) + pure + (BuiltProof + result + (setLfpBoundDerivation + domain + operator)) + +setLfpFixedProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpFixedProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator + monotone = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpFixed + foundation + globalType + domain + operator + (builtProofStatement + monotone)) + pure + (BuiltProof + result + (setLfpFixedDerivation + domain + operator + (builtProofDerivation + monotone))) + +setLfpInductProof + :: Eq global + => ProofContext global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> BuiltProof global + -> BuiltProof global + -> BuiltProof global + -> Either + KernelProofBuildError + (BuiltProof global) +setLfpInductProof + (ProofContext + foundation + globalType + _types + _hypotheses) + domain + operator + predicate + element + monotone + member + closure = do + result <- + first (ProofSetLfpRuleFailed . Text.pack . show) + (SetLfp.setLfpInduct + foundation + globalType + domain + operator + predicate + element + (builtProofStatement + monotone) + (builtProofStatement + member) + (builtProofStatement + closure)) + pure + (BuiltProof + result + (setLfpInductDerivation + domain + operator + predicate + element + (builtProofDerivation + monotone) + (builtProofDerivation + member) + (builtProofDerivation + closure))) + +contextGlobalType + :: ProofContext global + -> (global -> Maybe CoreType) +contextGlobalType + (ProofContext + _foundation + globalType + _types + _hypotheses) = + globalType + +equalityParts + :: ScopedCheckedCore global + -> Either + KernelProofBuildError + ( CoreType + , CanonicalTerm global + , CanonicalTerm global + ) +equalityParts equality = + case scopedCoreTerm equality of + CEq operandType left right -> + Right (operandType, left, right) + _ -> + Left ProofExpectedEquality + +weakenForHypothesis + :: BuiltProof global + -> BuiltProof global +weakenForHypothesis + (BuiltProof statement derivation) = + BuiltProof + statement + (weakenDerivationHypotheses 1 derivation) diff --git a/source/Felix/Checking/Kernel/Semantics.hs b/source/Felix/Checking/Kernel/Semantics.hs new file mode 100644 index 0000000..f9cfcfa --- /dev/null +++ b/source/Felix/Checking/Kernel/Semantics.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked logical inference over scoped canonical HOL terms. +module Felix.Checking.Kernel.Semantics + ( implicationElimination + , implicationIntroduction + , forallElimination + , forallIntroduction + , falsumElimination + , equalityReflexivity + , equalityCongruenceApplication + , equalityCongruenceLambda + , equalityModusPonens + , convertJudgment + , KernelSemanticsError(..) + ) where + +import Base +import Felix.Checking.Core + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Numeric.Natural (Natural) + + +data KernelSemanticsError + = KernelContextMismatch + ![CoreType] + ![CoreType] + | KernelBinderContextMismatch + !CoreType + ![CoreType] + | KernelExpectedProposition !CoreType + | KernelExpectedImplication + | KernelImplicationPremiseMismatch + | KernelExpectedForall + | KernelForallArgumentTypeMismatch + !CoreType + !CoreType + | KernelExpectedFalsum + | KernelExpectedEquality + | KernelEqualityOperandTypeMismatch + !CoreType + !CoreType + | KernelExpectedFunctionEquality !CoreType + | KernelEqualityPremiseMismatch + | KernelConversionBudgetExhausted + | KernelConversionMismatch + | KernelConclusionIllTyped !CoreCheckError + deriving stock (Show, Eq) + +implicationElimination + :: Eq global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +implicationElimination globalType implication premise = do + requireSameContext implication premise + requireProposition implication + requireProposition premise + case scopedCoreTerm implication of + CImp expected conclusion + | scopedCoreTerm premise == expected -> + checkConclusion + globalType + (scopedCoreContext implication) + conclusion + | otherwise -> + Left KernelImplicationPremiseMismatch + _ -> + Left KernelExpectedImplication + +implicationIntroduction + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +implicationIntroduction globalType premise conclusion = do + requireSameContext premise conclusion + requireProposition premise + requireProposition conclusion + checkConclusion + globalType + (scopedCoreContext premise) + (CImp + (scopedCoreTerm premise) + (scopedCoreTerm conclusion)) + +forallElimination + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +forallElimination globalType quantified argument = do + requireSameContext quantified argument + requireProposition quantified + case scopedCoreTerm quantified of + CForall binderType body + | scopedCoreType argument == binderType -> + checkConclusion + globalType + (scopedCoreContext quantified) + (instantiateCanonical + (scopedCoreTerm argument) + body) + | otherwise -> + Left + (KernelForallArgumentTypeMismatch + binderType + (scopedCoreType argument)) + _ -> + Left KernelExpectedForall + +forallIntroduction + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +forallIntroduction globalType binderType body = do + requireProposition body + outerContext <- + case scopedCoreContext body of + actualBinder : context + | actualBinder == binderType -> + Right context + | otherwise -> + Left + (KernelBinderContextMismatch + binderType + (scopedCoreContext body)) + [] -> + Left + (KernelBinderContextMismatch + binderType + []) + checkConclusion + globalType + outerContext + (CForall + binderType + (scopedCoreTerm body)) + +falsumElimination + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +falsumElimination _globalType falsum target = do + requireSameContext falsum target + requireProposition falsum + requireProposition target + case scopedCoreTerm falsum of + CFalsum -> + Right target + _ -> + Left KernelExpectedFalsum + +equalityReflexivity + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityReflexivity globalType operand = + checkConclusion + globalType + (scopedCoreContext operand) + (CEq + (scopedCoreType operand) + (scopedCoreTerm operand) + (scopedCoreTerm operand)) + +equalityCongruenceApplication + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityCongruenceApplication + globalType + functionEquality + argumentEquality = do + requireSameContext functionEquality argumentEquality + (functionType, leftFunction, rightFunction) <- + equalityOperands functionEquality + (argumentType, leftArgument, rightArgument) <- + equalityOperands argumentEquality + case functionType of + TyArrow expectedArgument resultType + | expectedArgument == argumentType -> + checkConclusion + globalType + (scopedCoreContext functionEquality) + (CEq + resultType + (CApp leftFunction leftArgument) + (CApp rightFunction rightArgument)) + | otherwise -> + Left + (KernelEqualityOperandTypeMismatch + expectedArgument + argumentType) + other -> + Left (KernelExpectedFunctionEquality other) + +equalityCongruenceLambda + :: (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityCongruenceLambda + globalType + binderType + bodyEquality = do + (bodyType, leftBody, rightBody) <- + equalityOperands bodyEquality + outerContext <- + case scopedCoreContext bodyEquality of + actualBinder : context + | actualBinder == binderType -> + Right context + | otherwise -> + Left + (KernelBinderContextMismatch + binderType + (scopedCoreContext bodyEquality)) + [] -> + Left + (KernelBinderContextMismatch + binderType + []) + checkConclusion + globalType + outerContext + (CEq + (TyArrow binderType bodyType) + (CLam binderType leftBody) + (CLam binderType rightBody)) + +equalityModusPonens + :: Eq global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +equalityModusPonens globalType propositionEquality premise = do + requireSameContext propositionEquality premise + requireProposition premise + (operandType, left, right) <- + equalityOperands propositionEquality + unless + (operandType == TyProp) + (Left + (KernelEqualityOperandTypeMismatch + TyProp + operandType)) + unless + (left == scopedCoreTerm premise) + (Left KernelEqualityPremiseMismatch) + checkConclusion + globalType + (scopedCoreContext premise) + right + +-- | Recheck a displayed proposition and independently establish beta +-- conversion within the supplied contraction budget. +convertJudgment + :: Eq global + => (global -> Maybe CoreType) + -> Natural + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +convertJudgment globalType budget source target = do + requireSameContext source target + requireProposition source + requireProposition target + sourceNormal <- + normalizeCanonical budget + (scopedCoreTerm source) + targetNormal <- + normalizeCanonical budget + (scopedCoreTerm target) + unless + (sourceNormal == targetNormal) + (Left KernelConversionMismatch) + checkConclusion + globalType + (scopedCoreContext target) + (scopedCoreTerm target) + +requireSameContext + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelSemanticsError () +requireSameContext left right + | scopedCoreContext left + == scopedCoreContext right = + Right () + | otherwise = + Left + (KernelContextMismatch + (scopedCoreContext left) + (scopedCoreContext right)) + +requireProposition + :: ScopedCheckedCore global + -> Either KernelSemanticsError () +requireProposition value + | scopedCoreType value == TyProp = + Right () + | otherwise = + Left + (KernelExpectedProposition + (scopedCoreType value)) + +equalityOperands + :: ScopedCheckedCore global + -> Either + KernelSemanticsError + (CoreType, CanonicalTerm global, CanonicalTerm global) +equalityOperands equality = do + requireProposition equality + case scopedCoreTerm equality of + CEq operandType left right -> + Right (operandType, left, right) + _ -> + Left KernelExpectedEquality + +checkConclusion + :: (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either + KernelSemanticsError + (ScopedCheckedCore global) +checkConclusion globalType context = + first KernelConclusionIllTyped + . checkScopedCanonicalCore globalType context + +normalizeCanonical + :: Natural + -> CanonicalTerm global + -> Either + KernelSemanticsError + (CanonicalTerm global) +normalizeCanonical budget term = + fst <$> normalize budget term + where + normalize remaining = \case + CBound index -> + pure (CBound index, remaining) + CGlobal global -> + pure (CGlobal global, remaining) + CIntrinsic intrinsic -> + pure (CIntrinsic intrinsic, remaining) + COpaqueInteger integer -> + pure (COpaqueInteger integer, remaining) + CApp function argument -> do + (functionNormal, afterFunction) <- + normalize remaining function + case functionNormal of + CLam _binderType body -> do + afterContraction <- + consumeReduction afterFunction + normalize + afterContraction + (instantiateCanonical + argument + body) + _ -> do + (argumentNormal, afterArgument) <- + normalize afterFunction argument + pure + ( CApp + functionNormal + argumentNormal + , afterArgument + ) + CLam binderType body -> do + (bodyNormal, remaining') <- + normalize remaining body + pure + (CLam binderType bodyNormal, remaining') + CFalsum -> + pure (CFalsum, remaining) + CImp premise conclusion -> do + (premiseNormal, afterPremise) <- + normalize remaining premise + (conclusionNormal, afterConclusion) <- + normalize afterPremise conclusion + pure + ( CImp premiseNormal conclusionNormal + , afterConclusion + ) + CEq operandType left right -> do + (leftNormal, afterLeft) <- + normalize remaining left + (rightNormal, afterRight) <- + normalize afterLeft right + pure + ( CEq + operandType + leftNormal + rightNormal + , afterRight + ) + CForall binderType body -> do + (bodyNormal, remaining') <- + normalize remaining body + pure + (CForall binderType bodyNormal, remaining') + + consumeReduction 0 = + Left KernelConversionBudgetExhausted + consumeReduction remaining = + Right (remaining - 1) diff --git a/source/Felix/Checking/Kernel/SetLfp.hs b/source/Felix/Checking/Kernel/SetLfp.hs new file mode 100644 index 0000000..19f6714 --- /dev/null +++ b/source/Felix/Checking/Kernel/SetLfp.hs @@ -0,0 +1,762 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The four checked rules for the bounded set-valued least fixed point. +module Felix.Checking.Kernel.SetLfp + ( setLfpBound + , setLfpLeast + , setLfpFixed + , setLfpInduct + , setLfpTerm + , memberProposition + , subsetProposition + , boundedMonoProposition + , inductionClosureProposition + , SetLfpRuleError(..) + ) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Data.Bifunctor (first) +import Numeric.Natural (Natural) + + +data SetLfpRuleError + = SetLfpRuleSignatureMismatch + !KernelRuleTag + !KernelRuleSignature + !KernelRuleSignature + | SetLfpRuleContextMismatch + !KernelRuleTag + ![CoreType] + ![CoreType] + | SetLfpRuleArgumentTypeMismatch + !KernelRuleTag + !Natural + !CoreType + !CoreType + | SetLfpRulePremiseIsNotProposition + !KernelRuleTag + !Natural + !CoreType + | SetLfpRulePremiseMismatch + !KernelRuleTag + !Natural + | SetLfpRuleConstructionIllTyped + !KernelRuleTag + !CoreCheckError + deriving stock (Show, Eq) + +setLfpBound + :: CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpBound foundation globalType domain operator = do + validateApplication + foundation + SetLfpBound + [domain, operator] + [] + fixedPoint <- + setLfpTermFor + SetLfpBound + globalType + domain + operator + subsetFor + SetLfpBound + globalType + fixedPoint + domain + +setLfpLeast + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpLeast + foundation + globalType + domain + operator + candidate + closedPremise + boundedPremise = do + validateApplication + foundation + SetLfpLeast + [domain, operator, candidate] + [closedPremise, boundedPremise] + operatorCandidate <- + applyFor + SetLfpLeast + globalType + operator + candidate + expectedClosed <- + subsetFor + SetLfpLeast + globalType + operatorCandidate + candidate + expectedBounded <- + subsetFor + SetLfpLeast + globalType + candidate + domain + requirePremise + SetLfpLeast + 0 + expectedClosed + closedPremise + requirePremise + SetLfpLeast + 1 + expectedBounded + boundedPremise + fixedPoint <- + setLfpTermFor + SetLfpLeast + globalType + domain + operator + subsetFor + SetLfpLeast + globalType + fixedPoint + candidate + +setLfpFixed + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpFixed + foundation + globalType + domain + operator + monotonePremise = do + validateApplication + foundation + SetLfpFixed + [domain, operator] + [monotonePremise] + expectedMonotone <- + boundedMonoFor + SetLfpFixed + globalType + domain + operator + requirePremise + SetLfpFixed + 0 + expectedMonotone + monotonePremise + fixedPoint <- + setLfpTermFor + SetLfpFixed + globalType + domain + operator + unfolded <- + applyFor + SetLfpFixed + globalType + operator + fixedPoint + checkedFor + SetLfpFixed + globalType + (scopedCoreContext domain) + (CEq + TySet + (scopedCoreTerm fixedPoint) + (scopedCoreTerm unfolded)) + +setLfpInduct + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpInduct + foundation + globalType + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise = do + validateApplication + foundation + SetLfpInduct + [domain, operator, predicate, element] + [monotonePremise, memberPremise, closurePremise] + expectedMonotone <- + boundedMonoFor + SetLfpInduct + globalType + domain + operator + requirePremise + SetLfpInduct + 0 + expectedMonotone + monotonePremise + fixedPoint <- + setLfpTermFor + SetLfpInduct + globalType + domain + operator + expectedMember <- + memberFor + SetLfpInduct + globalType + element + fixedPoint + requirePremise + SetLfpInduct + 1 + expectedMember + memberPremise + expectedClosure <- + inductionClosureFor + SetLfpInduct + globalType + fixedPoint + operator + predicate + requirePremise + SetLfpInduct + 2 + expectedClosure + closurePremise + applyFor + SetLfpInduct + globalType + predicate + element + +setLfpTerm + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpTerm = + setLfpTermFor SetLfpBound + +memberProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +memberProposition = + memberFor SetLfpInduct + +subsetProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +subsetProposition = + subsetFor SetLfpBound + +boundedMonoProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +boundedMonoProposition = + boundedMonoFor SetLfpFixed + +inductionClosureProposition + :: (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +inductionClosureProposition globalType domain operator predicate = do + fixedPoint <- + setLfpTermFor + SetLfpInduct + globalType + domain + operator + inductionClosureFor + SetLfpInduct + globalType + fixedPoint + operator + predicate + +validateApplication + :: CheckedFoundation + -> KernelRuleTag + -> [ScopedCheckedCore global] + -> [ScopedCheckedCore global] + -> Either SetLfpRuleError () +validateApplication foundation tag arguments premises = do + let expected = + expectedSignature tag + actual = + foundationRuleSignature foundation tag + if actual == expected + then pure () + else + Left + (SetLfpRuleSignatureMismatch + tag + expected + actual) + case arguments of + [] -> + pure () + firstArgument : remainingArguments -> do + traverse_ + (requireContext tag firstArgument) + remainingArguments + traverse_ + (requireContext tag firstArgument) + premises + traverse_ + (uncurry + (requireArgumentType tag)) + (zip [0 ..] arguments) + traverse_ + (uncurry + (requireProposition tag)) + (zip [0 ..] premises) + +expectedSignature :: KernelRuleTag -> KernelRuleSignature +expectedSignature = \case + SetLfpBound -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 0 + SetLfpLeast -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet, TySet] + 2 + SetLfpFixed -> + KernelRuleSignature + [TySet, TySet `TyArrow` TySet] + 1 + SetLfpInduct -> + KernelRuleSignature + [ TySet + , TySet `TyArrow` TySet + , TySet `TyArrow` TyProp + , TySet + ] + 3 + +expectedArgumentTypes + :: KernelRuleTag + -> [CoreType] +expectedArgumentTypes tag = + case expectedSignature tag of + KernelRuleSignature argumentTypes _premiseCount -> + argumentTypes + +requireContext + :: KernelRuleTag + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireContext tag expected actual + | scopedCoreContext expected + == scopedCoreContext actual = + Right () + | otherwise = + Left + (SetLfpRuleContextMismatch + tag + (scopedCoreContext expected) + (scopedCoreContext actual)) + +requireArgumentType + :: KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireArgumentType tag index argument = + case atNatural index (expectedArgumentTypes tag) of + Nothing -> + impossible + "fixed-point rule argument inventory is inconsistent" + Just expected + | scopedCoreType argument == expected -> + Right () + | otherwise -> + Left + (SetLfpRuleArgumentTypeMismatch + tag + index + expected + (scopedCoreType argument)) + +requireProposition + :: KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requireProposition tag index premise + | scopedCoreType premise == TyProp = + Right () + | otherwise = + Left + (SetLfpRulePremiseIsNotProposition + tag + index + (scopedCoreType premise)) + +requirePremise + :: Eq global + => KernelRuleTag + -> Natural + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either SetLfpRuleError () +requirePremise tag index expected actual + | expected == actual = + Right () + | otherwise = + Left + (SetLfpRulePremiseMismatch + tag + index) + +setLfpTermFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +setLfpTermFor tag globalType domain operator = + checkedFor tag globalType + (scopedCoreContext domain) + (CApp + (CApp + (CIntrinsic ISetLfp) + (scopedCoreTerm domain)) + (scopedCoreTerm operator)) + +applyFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +applyFor tag globalType function argument = do + requireContext tag function argument + checkedFor tag globalType + (scopedCoreContext function) + (CApp + (scopedCoreTerm function) + (scopedCoreTerm argument)) + +memberFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +memberFor tag globalType element set = do + requireContext tag element set + checkedFor tag globalType + (scopedCoreContext element) + (CApp + (CApp + (CIntrinsic Member) + (scopedCoreTerm element)) + (scopedCoreTerm set)) + +subsetFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +subsetFor tag globalType left right = do + requireContext tag left right + left' <- weakenFor tag globalType TySet left + right' <- weakenFor tag globalType TySet right + element <- + checkedFor tag globalType + (TySet : scopedCoreContext left) + (CBound 0) + inLeft <- + memberFor tag globalType element left' + inRight <- + memberFor tag globalType element right' + checkedFor tag globalType + (scopedCoreContext left) + (CForall + TySet + (CImp + (scopedCoreTerm inLeft) + (scopedCoreTerm inRight))) + +boundedMonoFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +boundedMonoFor tag globalType domain operator = do + requireContext tag domain operator + operatorDomain <- + applyFor tag globalType operator domain + bounded <- + subsetFor tag globalType operatorDomain domain + + domainX <- + weakenFor tag globalType TySet domain + operatorX <- + weakenFor tag globalType TySet operator + domainXY <- + weakenFor tag globalType TySet domainX + operatorXY <- + weakenFor tag globalType TySet operatorX + let xyContext = + TySet : TySet : scopedCoreContext domain + x <- + checkedFor tag globalType + xyContext + (CBound 1) + y <- + checkedFor tag globalType + xyContext + (CBound 0) + xSubsetY <- + subsetFor tag globalType x y + ySubsetDomain <- + subsetFor tag globalType y domainXY + antecedent <- + conjunctionFor + tag + globalType + xSubsetY + ySubsetDomain + operatorXValue <- + applyFor tag globalType operatorXY x + operatorYValue <- + applyFor tag globalType operatorXY y + imageSubset <- + subsetFor + tag + globalType + operatorXValue + operatorYValue + monotoneBody <- + implicationFor + tag + globalType + antecedent + imageSubset + quantifiedY <- + closeForallFor tag globalType TySet monotoneBody + quantifiedXY <- + closeForallFor tag globalType TySet quantifiedY + conjunctionFor + tag + globalType + bounded + quantifiedXY + +inductionClosureFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +inductionClosureFor + tag + globalType + fixedPoint + operator + predicate = do + fixedPoint' <- + weakenFor tag globalType TySet fixedPoint + operator' <- + weakenFor tag globalType TySet operator + predicate' <- + weakenFor tag globalType TySet predicate + element <- + checkedFor tag globalType + (TySet : scopedCoreContext fixedPoint) + (CBound 0) + separated <- + checkedFor tag globalType + (scopedCoreContext fixedPoint') + (CApp + (CApp + (CIntrinsic Sep) + (scopedCoreTerm fixedPoint')) + (scopedCoreTerm predicate')) + unfolded <- + applyFor tag globalType operator' separated + memberUnfolded <- + memberFor tag globalType element unfolded + predicateElement <- + applyFor tag globalType predicate' element + body <- + implicationFor + tag + globalType + memberUnfolded + predicateElement + closeForallFor tag globalType TySet body + +conjunctionFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +conjunctionFor tag globalType left right = do + requireContext tag left right + checkedFor tag globalType + (scopedCoreContext left) + (CImp + (CImp + (scopedCoreTerm left) + (CImp + (scopedCoreTerm right) + CFalsum)) + CFalsum) + +implicationFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +implicationFor tag globalType premise conclusion = do + requireContext tag premise conclusion + checkedFor tag globalType + (scopedCoreContext premise) + (CImp + (scopedCoreTerm premise) + (scopedCoreTerm conclusion)) + +closeForallFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +closeForallFor tag globalType binderType body = + case scopedCoreContext body of + actualBinder : outerContext + | actualBinder == binderType -> + checkedFor tag globalType + outerContext + (CForall + binderType + (scopedCoreTerm body)) + _ -> + Left + (SetLfpRuleContextMismatch + tag + (binderType : drop 1 + (scopedCoreContext body)) + (scopedCoreContext body)) + +weakenFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> CoreType + -> ScopedCheckedCore global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +weakenFor tag globalType binderType = + first + (SetLfpRuleConstructionIllTyped tag) + . weakenScopedCore + globalType + binderType + +checkedFor + :: KernelRuleTag + -> (global -> Maybe CoreType) + -> [CoreType] + -> CanonicalTerm global + -> Either + SetLfpRuleError + (ScopedCheckedCore global) +checkedFor tag globalType context = + first + (SetLfpRuleConstructionIllTyped tag) + . checkScopedCanonicalCore + globalType + context + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest diff --git a/source/Felix/Checking/Materialization.hs b/source/Felix/Checking/Materialization.hs new file mode 100644 index 0000000..51944a5 --- /dev/null +++ b/source/Felix/Checking/Materialization.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Pure applicability checks for later trusted materialization. +-- +-- Successful checks are inert. Fresh completion and validated loading or +-- sealing own the runtime authority that may publish a fact. +module Felix.Checking.Materialization + ( CandidateValidation + , candidateProofValidation + , candidateDeclarationValidation + , checkDeclarationValidationRecord + , checkCandidateValidation + , checkImportedMembership + , checkImportedOccurrence + , MaterializationError(..) + ) where + +import Base +import Felix.Checking.Authority +import Felix.Checking.Identity +import Felix.Checking.Semantic + +import Control.Monad (unless) +import Numeric.Natural (Natural) + + +data CandidateValidation + = CandidateProofValidation + !ProofValidationRecord + !ProofSyntaxId + | CandidateDeclarationValidation + !DeclarationValidationRecord + !DeclarationSyntaxId + ![ObjectId] + ![TheoremId] + !Natural + deriving stock (Show, Eq) + +candidateProofValidation + :: ProofValidationRecord + -> ProofSyntaxId + -> CandidateValidation +candidateProofValidation = + CandidateProofValidation + +candidateDeclarationValidation + :: DeclarationValidationRecord + -> DeclarationSyntaxId + -> [ObjectId] + -> [TheoremId] + -> Natural + -> CandidateValidation +candidateDeclarationValidation = + CandidateDeclarationValidation + +checkDeclarationValidationRecord + :: PrefixContextId + -> DeclarationSyntaxId + -> [ObjectId] + -> [TheoremId] + -> DeclarationValidationRecord + -> Either MaterializationError () +checkDeclarationValidationRecord prefix syntax objects theorems record = do + let suppliedKey = + declarationValidationRecordKey record + certificates = + declarationValidationRecordCertificates record + expectedKey = + declarationValidationKey + syntax prefix objects theorems + unless + (suppliedKey == expectedKey) + (Left + (DeclarationValidationKeyMismatch + suppliedKey expectedKey)) + let certificateTheorems = + theoremId + . factAuthorityTheorem + . validationTarget + <$> certificates + unless + (certificateTheorems == theorems) + (Left + (DeclarationCertificateTargetsMismatch + theorems certificateTheorems)) + +data MaterializationError + = CandidateValidationIndexMissing !Natural + | ProofValidationKeyMismatch + !ProofValidationKey + !ProofValidationKey + | DeclarationValidationKeyMismatch + !DeclarationValidationKey + !DeclarationValidationKey + | DeclarationCertificateTargetsMismatch + ![TheoremId] + ![TheoremId] + | CandidateCertificateTargetMismatch + !FactAuthority + !FactAuthority + | CandidateDirectAuthorizationMismatch + !DirectAuthorization + !DirectAuthorization + | CandidateTheoryMismatch !TheoryId !TheoryId + | CandidatePropositionMismatch + !PropositionId + !PropositionId + | ImportedOccurrenceMissing + !SemanticFactOccurrenceFingerprint + | ImportedAuthorityMismatch + !FactAuthority + !FactAuthority + | ImportedTheoryMismatch !TheoryId !TheoryId + | ImportedPropositionMismatch + !PropositionId + !PropositionId + deriving stock (Show, Eq) + + +-- | Check whether inert validation data applies to one exact candidate. +-- +-- Success deliberately returns no builder authorization. A fresh trusted +-- completion or compatible validated-store hit must perform this check before +-- its owner mints runtime authority. +checkCandidateValidation + :: TheoryId + -> PrefixContextId + -> CheckedPropositionContent + -> FactAuthority + -> DirectAuthorization + -> CandidateValidation + -> Either MaterializationError () +checkCandidateValidation + theory prefix proposition expectedAuthority + expectedDirect validation = do + certificate <- + candidateCertificate + prefix expectedAuthority validation + validateCertificateTarget + theory proposition expectedAuthority expectedDirect certificate + +candidateCertificate + :: PrefixContextId + -> FactAuthority + -> CandidateValidation + -> Either MaterializationError ValidationCertificate +candidateCertificate prefix authority = \case + CandidateProofValidation record syntax -> do + let suppliedKey = + proofValidationRecordKey record + certificate = + proofValidationRecordCertificate record + expectedKey = + proofValidationKey + (theoremId + (factAuthorityTheorem authority)) + syntax + prefix + unless + (suppliedKey == expectedKey) + (Left + (ProofValidationKeyMismatch + suppliedKey expectedKey)) + pure certificate + CandidateDeclarationValidation + record syntax objects theorems ordinal -> do + checkDeclarationValidationRecord + prefix syntax objects theorems record + maybe + (Left (CandidateValidationIndexMissing ordinal)) + Right + (nthNatural ordinal + (declarationValidationRecordCertificates record)) + +validateCertificateTarget + :: TheoryId + -> CheckedPropositionContent + -> FactAuthority + -> DirectAuthorization + -> ValidationCertificate + -> Either MaterializationError () +validateCertificateTarget + theory proposition expectedAuthority expectedDirect certificate = do + let actualAuthority = + validationTarget certificate + actualDirect = + validationDirectAuthorization certificate + reference = + factAuthorityTheorem actualAuthority + unless + (actualAuthority == expectedAuthority) + (Left + (CandidateCertificateTargetMismatch + expectedAuthority actualAuthority)) + unless + (actualDirect == expectedDirect) + (Left + (CandidateDirectAuthorizationMismatch + expectedDirect actualDirect)) + unless + (theoremRefTheory reference == theory) + (Left + (CandidateTheoryMismatch + theory + (theoremRefTheory reference))) + unless + ( theoremRefProposition reference + == checkedPropositionId proposition + ) + (Left + (CandidatePropositionMismatch + (checkedPropositionId proposition) + (theoremRefProposition reference))) + + +-- | Validate exact membership in inert canonical interface data. +-- +-- Logical sealing or atomic cached installation must additionally supply the +-- opaque runtime evidence before an importer receives builder authority. +checkImportedMembership + :: TheoryId + -> SemanticInterface + -> SemanticFactOccurrenceFingerprint + -> CheckedPropositionContent + -> FactAuthority + -> Either MaterializationError SemanticFactOccurrence +checkImportedMembership + theory interface fingerprint proposition expectedAuthority = do + occurrence <- + maybe + (Left (ImportedOccurrenceMissing fingerprint)) + Right + (find + ((== fingerprint) . semanticFactFingerprint) + (concatMap + declarationDeltaFacts + (semanticInterfaceDeclarations interface))) + checkImportedOccurrence + theory fingerprint occurrence proposition expectedAuthority + +checkImportedOccurrence + :: TheoryId + -> SemanticFactOccurrenceFingerprint + -> SemanticFactOccurrence + -> CheckedPropositionContent + -> FactAuthority + -> Either MaterializationError SemanticFactOccurrence +checkImportedOccurrence + theory fingerprint occurrence proposition expectedAuthority = do + unless + (semanticFactFingerprint occurrence == fingerprint) + (Left (ImportedOccurrenceMissing fingerprint)) + let actualAuthority = + semanticFactAuthority occurrence + reference = + factAuthorityTheorem actualAuthority + unless + (actualAuthority == expectedAuthority) + (Left + (ImportedAuthorityMismatch + expectedAuthority actualAuthority)) + unless + (theoremRefTheory reference == theory) + (Left + (ImportedTheoryMismatch + theory + (theoremRefTheory reference))) + unless + (theoremRefProposition reference + == checkedPropositionId proposition) + (Left + (ImportedPropositionMismatch + (checkedPropositionId proposition) + (theoremRefProposition reference))) + pure occurrence + + +nthNatural :: Natural -> [value] -> Maybe value +nthNatural ordinal = + go ordinal + where + go _ [] = + Nothing + go 0 (value : _) = + Just value + go remaining (_ : rest) = + go (remaining - 1) rest diff --git a/source/Felix/Checking/Module.hs b/source/Felix/Checking/Module.hs new file mode 100644 index 0000000..88c8fef --- /dev/null +++ b/source/Felix/Checking/Module.hs @@ -0,0 +1,986 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +-- | Explicit inputs and sealed outputs for the typed module driver. +module Felix.Checking.Module + ( LiveModuleBinding(..) + , IdentifiedModuleInput + , identifiedPhysicalModule + , identifiedReservedPrelude + , identifiedModuleOwner + , identifiedModuleBinding + , identifiedModuleParsed + , TypedSourceDeclaration + , typedSourceDeclarationBlockIndex + , typedSourceDeclarationHead + , typedSourceDeclarationProof + , typedSourceDeclarations + , SealedTypedModule + , sealedTypedModuleOwner + , sealedTypedModuleSyntax + , sealedTypedModuleSemantic + , sealedTypedModuleEvidence + , CachedTypedModuleError(..) + , renderCachedTypedModuleError + , cachedSealedTypedModule + , sealedTypedModulePrefix + , FinalPreludeSession + , ModuleRootAcquisition(..) + , finalPreludeSource + , finalPreludeInput + , finalPreludeModule + , finalPreludeAcquisition + , FinalPreludeReadiness + , finalPreludeReadiness + , BootstrapPreludeFixture + , bootstrapPreludeInput + , bootstrapPreludeModule + , bootstrapPreludeReadiness + , fixtureFinalPreludeReadinessFromSealed + , BootstrapError(..) + , buildBootstrapPreludeFixture + , FinalPreludeReadinessError(..) + , acquireFinalPreludeSession + , TypedModuleInput + , TypedModuleInputError(..) + , renderTypedModuleInputError + , typedModuleInput + , TypedPathError(..) + , TypedModuleFailure(..) + , typedModuleFailureLocation + , renderTypedModuleFailure + , TypedModuleResult(..) + , runTypedModule + ) where + +import Base +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Module +import Felix.Parse +import Felix.Prelude qualified as Prelude +import Felix.Source +import Felix.Store qualified as Store +import Felix.Report.Location +import Felix.Syntax.Interface +import Felix.Syntax.Abstract qualified as Raw + +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.Text qualified as Text + + +data LiveModuleBinding + = PhysicalModuleBinding !ResolvedSource + | ReservedModuleBinding !FileId !FilePath + deriving stock (Show, Eq) + +data IdentifiedModuleInput = IdentifiedModuleInput + !ModuleName + !LiveModuleBinding + !IdentifiedParsedModule + +identifiedPhysicalModule :: ParsedModule -> IdentifiedModuleInput +identifiedPhysicalModule parsed = + IdentifiedModuleInput + (moduleName (parsedModuleAddress parsed)) + (PhysicalModuleBinding (parsedModuleResolved parsed)) + (parsedModuleIdentified parsed) + +identifiedReservedPrelude + :: Prelude.ReservedParsedPrelude + -> IdentifiedModuleInput +identifiedReservedPrelude reserved = + IdentifiedModuleInput + (freshModuleInputOwner input) + (ReservedModuleBinding + (freshModuleInputFileId input) + (freshModuleInputLocationPath input)) + (Prelude.reservedParsedPreludeModule reserved) + where + input = Prelude.reservedParsedPreludeInput reserved + +identifiedModuleOwner :: IdentifiedModuleInput -> ModuleName +identifiedModuleOwner (IdentifiedModuleInput owner _binding _parsed) = + owner + +identifiedModuleBinding + :: IdentifiedModuleInput + -> LiveModuleBinding +identifiedModuleBinding + (IdentifiedModuleInput _owner binding _parsed) = + binding + +identifiedModuleParsed + :: IdentifiedModuleInput + -> IdentifiedParsedModule +identifiedModuleParsed + (IdentifiedModuleInput _owner _binding parsed) = + parsed + + +-- | One source declaration as consumed by the typed module driver. +-- +-- A claim and its immediately following proof occupy one declaration slot. +-- The head block index remains the syntax-occurrence association index. +data TypedSourceDeclaration = TypedSourceDeclaration + !Int + !Raw.Block + !(Maybe Raw.Proof) + +typedSourceDeclarationBlockIndex :: TypedSourceDeclaration -> Int +typedSourceDeclarationBlockIndex + (TypedSourceDeclaration blockIndex _head _proof) = + blockIndex + +typedSourceDeclarationHead :: TypedSourceDeclaration -> Raw.Block +typedSourceDeclarationHead + (TypedSourceDeclaration _blockIndex headBlock _proof) = + headBlock + +typedSourceDeclarationProof + :: TypedSourceDeclaration + -> Maybe Raw.Proof +typedSourceDeclarationProof + (TypedSourceDeclaration _blockIndex _head proof) = + proof + +typedSourceDeclarations + :: IdentifiedParsedModule + -> [TypedSourceDeclaration] +typedSourceDeclarations parsed = + [ declaration + | item <- typedSourceItems (identifiedParsedModuleBlocks parsed) + , Just declaration <- [sourceItemDeclaration item] + ] + +data TypedSourceItem + = TypedSourceDeclarationItem !TypedSourceDeclaration + | TypedUnmatchedSourceProof !Location + +sourceItemDeclaration + :: TypedSourceItem + -> Maybe TypedSourceDeclaration +sourceItemDeclaration = \case + TypedSourceDeclarationItem declaration -> Just declaration + TypedUnmatchedSourceProof{} -> Nothing + +typedSourceItems :: [Raw.Block] -> [TypedSourceItem] +typedSourceItems = go 0 + where + go _blockIndex [] = [] + go blockIndex (block@Raw.BlockClaim{} : remaining) = + case remaining of + Raw.BlockProof _location proof _end : rest -> + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block (Just proof)) + : go (blockIndex + 2) rest + _ -> + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block Nothing) + : go (blockIndex + 1) remaining + go blockIndex (Raw.BlockProof location _proof _end : remaining) = + TypedUnmatchedSourceProof location + : go (blockIndex + 1) remaining + go blockIndex (block : remaining) = + TypedSourceDeclarationItem + (TypedSourceDeclaration blockIndex block Nothing) + : go (blockIndex + 1) remaining + + +data SealedTypedModule = SealedTypedModule + !ModuleName + !ModuleSyntaxInterface + !SemanticInterface + !Declaration.PendingModulePrefix + !Declaration.ImportedModuleEvidence + +sealedTypedModuleOwner :: SealedTypedModule -> ModuleName +sealedTypedModuleOwner (SealedTypedModule owner _syntax _semantic _prefix _evidence) = + owner + +sealedTypedModuleSyntax + :: SealedTypedModule + -> ModuleSyntaxInterface +sealedTypedModuleSyntax + (SealedTypedModule _owner syntax _semantic _prefix _evidence) = + syntax + +sealedTypedModuleSemantic + :: SealedTypedModule + -> SemanticInterface +sealedTypedModuleSemantic + (SealedTypedModule _owner _syntax semantic _prefix _evidence) = + semantic + +sealedTypedModulePrefix + :: SealedTypedModule + -> Declaration.PendingModulePrefix +sealedTypedModulePrefix + (SealedTypedModule _owner _syntax _semantic prefix _evidence) = + prefix + +sealedTypedModuleEvidence + :: SealedTypedModule + -> Declaration.ImportedModuleEvidence +sealedTypedModuleEvidence + (SealedTypedModule _owner _syntax _semantic _prefix evidence) = + evidence + +data CachedTypedModuleError + = CachedTypedModuleEvidenceError !Declaration.DeclarationError + deriving stock (Show, Eq) + +renderCachedTypedModuleError :: CachedTypedModuleError -> Text +renderCachedTypedModuleError = \case + CachedTypedModuleEvidenceError failure -> + Declaration.renderDeclarationError failure + +cachedSealedTypedModule + :: CheckedFoundation + -> [SealedTypedModule] + -> Store.CachedModuleInstallation + -> Either CachedTypedModuleError SealedTypedModule +cachedSealedTypedModule + foundation parents installation = do + evidence <- + first CachedTypedModuleEvidenceError + (Declaration.validateImportedModuleEvidence + (theoryId foundation) + (sealedTypedModuleEvidence <$> parents) + semantic + objects + propositions) + pure + (SealedTypedModule + owner + syntax + semantic + (Declaration.emptyPendingModulePrefix + (Store.cachedInstallationFinalPrefix installation)) + evidence) + where + syntax = Store.cachedInstallationSyntax installation + semantic = Store.cachedInstallationSemantic installation + owner = semanticInterfaceOwner semantic + objects = Store.cachedInstallationObjects installation + propositions = Store.cachedInstallationPropositions installation + + +data ModuleRootAcquisition + = ModuleRootHit + | ModuleRootMiss + deriving stock (Show, Eq) + +data FinalPreludeSession = FinalPreludeSession + !Prelude.ReservedPreludeSourceInput + !IdentifiedModuleInput + !SealedTypedModule + !ModuleRootAcquisition + +finalPreludeSource + :: FinalPreludeSession + -> Prelude.ReservedPreludeSourceInput +finalPreludeSource + (FinalPreludeSession source _input _module _acquisition) = + source + +finalPreludeInput + :: FinalPreludeSession + -> IdentifiedModuleInput +finalPreludeInput (FinalPreludeSession _source input _module _acquisition) = + input + +finalPreludeModule + :: FinalPreludeSession + -> SealedTypedModule +finalPreludeModule (FinalPreludeSession _source _input sealed _acquisition) = + sealed + +finalPreludeAcquisition + :: FinalPreludeSession + -> ModuleRootAcquisition +finalPreludeAcquisition + (FinalPreludeSession _source _input _sealed acquisition) = + acquisition + +newtype FinalPreludeReadiness = FinalPreludeReadiness + SealedTypedModule + +finalPreludeReadiness + :: FinalPreludeSession + -> FinalPreludeReadiness +finalPreludeReadiness = + FinalPreludeReadiness . finalPreludeModule + +-- | Test-only empty-prelude fixture. +-- +-- It is exported for focused exact-compiler tests. Production acquisition is +-- exclusively 'acquireFinalPreludeSession'. +newtype BootstrapPreludeFixture = BootstrapPreludeFixture + FinalPreludeSession + +bootstrapPreludeInput + :: BootstrapPreludeFixture + -> IdentifiedModuleInput +bootstrapPreludeInput (BootstrapPreludeFixture fixture) = + finalPreludeInput fixture + +bootstrapPreludeModule + :: BootstrapPreludeFixture + -> SealedTypedModule +bootstrapPreludeModule (BootstrapPreludeFixture fixture) = + finalPreludeModule fixture + +-- | Test-only seam for the empty bootstrap compiler input. +bootstrapPreludeReadiness + :: BootstrapPreludeFixture + -> FinalPreludeReadiness +bootstrapPreludeReadiness = + FinalPreludeReadiness . bootstrapPreludeModule + +-- | Test-only seam for exercising a synthetic distinguished prelude. +fixtureFinalPreludeReadinessFromSealed + :: SealedTypedModule + -> FinalPreludeReadiness +fixtureFinalPreludeReadinessFromSealed = + FinalPreludeReadiness + +data BootstrapError + = BootstrapParseFailed !Prelude.PreludeParseError + | BootstrapDriverOpenFailed !Declaration.DriverOpenError + | BootstrapDeclarationFailed !Declaration.DeclarationError + | BootstrapSealFailed !SemanticInterfaceError + deriving stock (Show) + +-- | Construct the empty distinguished prelude used only by compiler fixtures. +buildBootstrapPreludeFixture + :: CheckedFoundation + -> Declaration.VampireResolver + -> IO (Either BootstrapError BootstrapPreludeFixture) +buildBootstrapPreludeFixture foundation resolver = do + parsedResult <- + Prelude.parseReservedPreludeSource + Prelude.emptyBootstrapSourceInput + case parsedResult of + Left err -> + pure (Left (BootstrapParseFailed err)) + Right reserved -> do + let input = identifiedReservedPrelude reserved + syntax = + identifiedParsedModuleSyntaxInterface + (identifiedModuleParsed input) + driver <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + resolver + Declaration.FreshValidation + emptyDriver + pure case driver of + Left err -> + Left (BootstrapDriverOpenFailed err) + Right (Declaration.DriverSucceeded + () semantic prefix _closure) -> + Right + (BootstrapPreludeFixture + (FinalPreludeSession + Prelude.emptyBootstrapSourceInput + input + (SealedTypedModule + preludeModuleName + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + [] + semantic + prefix)) + ModuleRootMiss)) + Right + (Declaration.DriverFailed + (Declaration.DriverDeclarationFailed err) + _prefix) -> + Left (BootstrapDeclarationFailed err) + Right (Declaration.DriverSealFailed err _prefix) -> + Left (BootstrapSealFailed err) + where + emptyDriver :: Declaration.ModuleDriver Void () + emptyDriver = pure () + + +data FinalPreludeReadinessError + = FinalPreludeReadinessSourceLoadFailed !Prelude.PreludeLoadError + | FinalPreludeReadinessSourceParseFailed !Prelude.PreludeParseError + | FinalPreludeReadinessBuildFailed !FinalPrelude.FinalPreludeFailure + | FinalPreludeReadinessBuildOpenFailed !Declaration.DriverOpenError + | FinalPreludeReadinessArtifactKeyFailed !ModuleArtifactKeyError + | FinalPreludeReadinessStoreFailed !Store.StoreFailure + | FinalPreludeReadinessCachedModuleFailed !CachedTypedModuleError + | FinalPreludeReadinessAcknowledgementMismatch + !ModuleArtifactResult + !ModuleArtifactResult + deriving stock (Show) + +-- | Acquire the exact packaged final prelude through its ordinary module root. +-- +-- Loading and parsing happen once before the root lookup. A hit is validated +-- and materialized through the generic cached-module boundary; a miss reuses +-- that parsed input for confined construction and atomic publication. +acquireFinalPreludeSession + :: Store.StoreMemo + -> Store.Store + -> CheckedFoundation + -> Declaration.VampireResolver + -> IO (Either FinalPreludeReadinessError FinalPreludeSession) +acquireFinalPreludeSession memo store foundation resolver = + Prelude.loadReservedPreludeSourceInput >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessSourceLoadFailed failure)) + Right source -> + Prelude.parseReservedPreludeSource source >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessSourceParseFailed failure)) + Right parsed -> + acquire source parsed + where + acquire source parsed = + case moduleArtifactKey + preludeModuleName + parsedId + [] + (theoryId foundation) of + Left failure -> + pure (Left (FinalPreludeReadinessArtifactKeyFailed failure)) + Right key -> do + Store.loadCachedModuleInstallation + memo store key (moduleSyntaxAssertedId syntax) >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessStoreFailed failure)) + Right (Just installation) -> + pure do + sealed <- first FinalPreludeReadinessCachedModuleFailed + (cachedSealedTypedModule + foundation [] installation) + pure + (FinalPreludeSession + source + identified sealed ModuleRootHit) + Right Nothing -> + build source parsed key + where + identified = identifiedReservedPrelude parsed + parsedId = identifiedParsedModuleId (identifiedModuleParsed identified) + syntax = identifiedParsedModuleSyntaxInterface + (identifiedModuleParsed identified) + + build source parsed key = + FinalPrelude.buildParsedFinalPreludeCandidate + foundation parsed resolver >>= \case + FinalPrelude.FinalPreludeBuildFailed failure _prefix -> + pure (Left (FinalPreludeReadinessBuildFailed failure)) + FinalPrelude.FinalPreludeBuildOpenFailed failure -> + pure (Left (FinalPreludeReadinessBuildOpenFailed failure)) + FinalPrelude.FinalPreludeBuilt candidate -> + publish source key candidate + FinalPrelude.FinalPreludeSourceLoadFailed failure -> + pure (Left (FinalPreludeReadinessSourceLoadFailed failure)) + FinalPrelude.FinalPreludeSourceParseFailed failure -> + pure (Left (FinalPreludeReadinessSourceParseFailed failure)) + + publish source key candidate = do + let parsed = FinalPrelude.finalPreludeParsed candidate + identified = identifiedReservedPrelude parsed + syntax = FinalPrelude.finalPreludeSyntax candidate + semantic = FinalPrelude.finalPreludeSemantic candidate + prefix = FinalPrelude.finalPreludePrefix candidate + artifact = + moduleArtifactResult + key + (moduleSyntaxAssertedId syntax) + (semanticInterfaceAssertedId semantic) + Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact >>= \case + Left failure -> + pure (Left (FinalPreludeReadinessStoreFailed failure)) + Right acknowledged + | acknowledged /= artifact -> + pure + (Left + (FinalPreludeReadinessAcknowledgementMismatch + artifact + acknowledged)) + | otherwise -> + pure + (Right + (FinalPreludeSession + source + identified + (SealedTypedModule + preludeModuleName + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + [] + semantic + prefix)) + ModuleRootMiss)) + + +data TypedModuleInput = TypedModuleInput + !ModuleName + !IdentifiedModuleInput + !ModuleSyntaxInterface + !CheckedFoundation + !FinalPreludeReadiness + ![SealedTypedModule] + !Declaration.VampireResolver + !Declaration.ValidationRun + +data TypedModuleInputError + = TypedDirectModuleMismatch ![ModuleName] ![ModuleName] + | TypedSyntaxInputMismatch ![SyntaxInterfaceId] ![SyntaxInterfaceId] + deriving stock (Show, Eq) + +renderTypedModuleInputError :: TypedModuleInputError -> Text +renderTypedModuleInputError = \case + TypedDirectModuleMismatch expected actual -> + "direct module inputs differ: expected " <> shown expected + <> ", found " <> shown actual + TypedSyntaxInputMismatch expected actual -> + "direct syntax inputs differ: expected " <> shown expected + <> ", found " <> shown actual + where + shown :: Show value => value -> Text + shown = Text.pack . show + +typedModuleInput + :: CheckedFoundation + -> FinalPreludeReadiness + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> ParsedModule + -> [SealedTypedModule] + -> Either TypedModuleInputError TypedModuleInput +typedModuleInput + foundation readiness resolver validationRun parsed direct = do + unless (expectedOwners == actualOwners) + (Left + (TypedDirectModuleMismatch + expectedOwners + actualOwners)) + unless (expectedSyntax == actualSyntax) + (Left + (TypedSyntaxInputMismatch + expectedSyntax + actualSyntax)) + pure + (TypedModuleInput + owner + identified + syntax + foundation + readiness + direct + resolver + validationRun) + where + identified = identifiedPhysicalModule parsed + owner = identifiedModuleOwner identified + syntax = identifiedParsedModuleSyntaxInterface (identifiedModuleParsed identified) + expectedOwners = + moduleName + <$> nubOrd + (parsedImportedAddress + <$> parsedModuleImports parsed) + actualOwners = sealedTypedModuleOwner <$> direct + expectedSyntax = + nubOrd + ( moduleSyntaxAssertedId + (sealedTypedModuleSyntax prelude) + : ( moduleSyntaxAssertedId + . sealedTypedModuleSyntax + <$> direct + ) + ) + actualSyntax = moduleSyntaxDirectInputs syntax + FinalPreludeReadiness prelude = readiness + +data TypedPathError + = TypedExactCompileFailed !Exact.ExactCompileError + | TypedExactDatatypeFailed !ExactDatatype.ExactDatatypeError + | TypedExactInductiveFailed !ExactInductive.ExactInductiveError + | TypedExactProofFailed !ExactProof.ExactProofError + | TypedUnmatchedProof !Location + deriving stock (Show, Eq) + +data TypedModuleFailure + = TypedDeclarationFailed !Declaration.DeclarationError + | TypedActionFailed !TypedPathError + | TypedSealFailed !SemanticInterfaceError + deriving stock (Show, Eq) + +typedModuleFailureLocation :: TypedModuleFailure -> Maybe Location +typedModuleFailureLocation = \case + TypedActionFailed (TypedExactCompileFailed failure) -> + Just (Exact.exactCompileErrorLocation failure) + TypedActionFailed (TypedExactDatatypeFailed failure) -> + Just (ExactDatatype.exactDatatypeErrorLocation failure) + TypedActionFailed (TypedExactInductiveFailed failure) -> + Just (ExactInductive.exactInductiveErrorLocation failure) + TypedActionFailed (TypedExactProofFailed failure) -> + Just (ExactProof.exactProofErrorLocation failure) + TypedActionFailed (TypedUnmatchedProof location) -> + Just location + TypedDeclarationFailed failure -> + Declaration.declarationErrorLocation failure + TypedSealFailed{} -> + Nothing + +renderTypedModuleFailure :: TypedModuleFailure -> Text +renderTypedModuleFailure = \case + TypedDeclarationFailed failure -> + Declaration.renderDeclarationError failure + TypedActionFailed (TypedExactCompileFailed failure) -> + Exact.renderExactCompileError failure + TypedActionFailed (TypedExactDatatypeFailed failure) -> + ExactDatatype.renderExactDatatypeError failure + TypedActionFailed (TypedExactInductiveFailed failure) -> + ExactInductive.renderExactInductiveError failure + TypedActionFailed (TypedExactProofFailed failure) -> + ExactProof.renderExactProofError failure + TypedActionFailed (TypedUnmatchedProof location) -> + locationToText location + <> ": this proof does not follow a claim" + TypedSealFailed failure -> + renderSemanticInterfaceError failure + +data TypedModuleResult + = TypedModuleOpenFailed !Declaration.DriverOpenError + | TypedModuleSucceeded !SealedTypedModule + | TypedModuleFailed + !TypedModuleFailure + !Declaration.PendingModulePrefix + +data PlannedTypedDeclaration + = PlannedBinding + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) + | PlannedSourceAxiom + !(Declaration.PlannedDeclaration ()) + | PlannedInductive + !(Declaration.PlannedDeclaration + ExactInductive.CheckedExactInductiveAuthorization) + | PlannedDatatype + !(Declaration.PlannedDeclaration + ExactDatatype.CheckedExactDatatypeAuthorization) + | PlannedStructure + !(Declaration.PlannedDeclaration + Exact.CheckedExactStructureAuthorization) + | PlannedProof + !(Declaration.PlannedDeclaration + ExactProof.CheckedExactProofAuthorization) + +data TypedPlanningFailure + = TypedPlanningPathFailure !TypedPathError + | TypedPlanningDeclarationFailure !Declaration.DeclarationError + +data TypedModulePlan = TypedModulePlan + ![PlannedTypedDeclaration] + !(Maybe TypedPlanningFailure) + +runTypedModule :: TypedModuleInput -> IO TypedModuleResult +runTypedModule + (TypedModuleInput + owner identified syntax foundation readiness direct resolver + validationRun) = do + let FinalPreludeReadiness prelude = readiness + action = do + traverse_ + (Declaration.importSealedModuleDriver + . sealedTypedModuleEvidence) + effectiveDirect + TypedModulePlan planned terminal <- + Declaration.runProspectiveLoweringDriver + (planSourceItems [] + (typedSourceItems + (identifiedParsedModuleBlocks + (identifiedModuleParsed identified)))) + traverse_ admitPlannedDeclaration planned + traverse_ failPlanning terminal + semanticDirect = + semanticInterfaceAssertedId + (sealedTypedModuleSemantic prelude) + : ( semanticInterfaceAssertedId + . sealedTypedModuleSemantic + <$> direct + ) + effectiveDirect = + prelude : direct + occurrences = + identifiedParsedModuleSyntaxOccurrences + (identifiedModuleParsed identified) + planSourceItems completed [] = + pure (TypedModulePlan (reverse completed) Nothing) + planSourceItems completed (item : remaining) = + case item of + TypedUnmatchedSourceProof location -> + pure + (TypedModulePlan + (reverse completed) + (Just + (TypedPlanningPathFailure + (TypedUnmatchedProof location)))) + TypedSourceDeclarationItem declaration -> do + planDeclaration declaration >>= \case + Left failure -> + pure + (TypedModulePlan + (reverse completed) + (Just failure)) + Right planned -> + planSourceItems (planned : completed) remaining + + planDeclaration sourceDeclaration = + case block of + Raw.BlockClaim{} -> + planClaim block explicitProof + Raw.BlockProof{} -> + impossible + "typed declaration association retained a proof head" + Raw.BlockSig{} -> + planSelected block + Raw.BlockAbbr{} -> + planSelected block + Raw.BlockDefn{} -> + planSelected block + Raw.BlockAxiom{} -> + planSourceAxiom block + Raw.BlockInductive{} -> + planInductive block + Raw.BlockData{} -> + planDatatype block + Raw.BlockStruct{} -> + planStructure block + where + blockIndex = + typedSourceDeclarationBlockIndex sourceDeclaration + block = typedSourceDeclarationHead sourceDeclaration + explicitProof = + typedSourceDeclarationProof sourceDeclaration + + planSelected selected = do + prepared <- + Exact.prepareExactDeclaration + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right declaration -> do + Exact.lowerPreparedExactBinding declaration >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedBinding checked + + planSourceAxiom selected = do + prepared <- Exact.prepareExactSourceAxiom selected + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right axiom -> do + Exact.lowerPreparedExactSourceAxiom axiom >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedSourceAxiom checked + + planInductive selected = do + prepared <- + ExactInductive.prepareExactInductive + foundation + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactInductiveFailed failure))) + Right inductive -> do + ExactInductive.lowerPreparedExactInductive inductive + >>= \case + Left failure -> + planningDeclarationFailure failure + Right checked -> + planChecked PlannedInductive checked + + planDatatype selected = do + prepared <- + ExactDatatype.prepareExactDatatype + selected + [ ( parsedSyntaxOccurrenceLocation occurrence + , parsedSyntaxOccurrenceMarker occurrence + , parsedSyntaxOccurrenceEntry occurrence + ) + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactDatatypeFailed failure))) + Right datatype -> do + ExactDatatype.lowerPreparedExactDatatype datatype + >>= \case + Left failure -> + planningDeclarationFailure failure + Right checked -> + planChecked PlannedDatatype checked + + planStructure selected = do + prepared <- + Exact.prepareExactStructure + selected + [ parsedSyntaxOccurrenceEntry occurrence + | occurrence <- occurrences + , parsedSyntaxOccurrenceBlockIndex occurrence + == blockIndex + ] + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactCompileFailed failure))) + Right structure -> do + Exact.lowerPreparedExactStructure structure >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedStructure checked + + planClaim selected selectedProof = do + prepared <- + ExactProof.prepareExactProof selected selectedProof + case prepared of + Left failure -> + pure + (Left + (TypedPlanningPathFailure + (TypedExactProofFailed failure))) + Right proof -> do + ExactProof.lowerPreparedExactProof proof >>= \case + Left failure -> planningDeclarationFailure failure + Right checked -> + planChecked PlannedProof checked + + planChecked + :: forall body. + (Declaration.PlannedDeclaration body + -> PlannedTypedDeclaration) + -> Declaration.CheckedDeclaration body + -> Declaration.LoweringDriver + (Either TypedPlanningFailure PlannedTypedDeclaration) + planChecked constructor checked = + Declaration.planCheckedDeclaration checked >>= \case + Left failure -> planningDeclarationFailure failure + Right planned -> pure (Right (constructor planned)) + + planningDeclarationFailure = + pure . Left . TypedPlanningDeclarationFailure + + admitPlannedDeclaration = \case + PlannedBinding planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactBinding) + PlannedSourceAxiom planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactSourceAxiom) + PlannedInductive planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned + ExactInductive.authorizeCheckedExactInductive) + PlannedDatatype planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactDatatype.authorizeCheckedExactDatatype) + PlannedStructure planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned Exact.authorizeCheckedExactStructure) + PlannedProof planned -> + void + (Declaration.admitPlannedCheckedDeclaration + planned ExactProof.authorizeCheckedExactProof) + + failPlanning = \case + TypedPlanningPathFailure failure -> + Declaration.failModuleDriver failure + TypedPlanningDeclarationFailure failure -> + Declaration.failDeclarationDriver failure + result <- + Declaration.runModuleDriver + foundation + owner + semanticDirect + resolver + validationRun + action + pure case result of + Left err -> + TypedModuleOpenFailed err + Right (Declaration.DriverSucceeded () semantic prefix _closure) -> + TypedModuleSucceeded + (SealedTypedModule + owner + syntax + semantic + prefix + (Declaration.freshImportedModuleEvidence + (sealedTypedModuleEvidence <$> effectiveDirect) + semantic + prefix)) + Right + (Declaration.DriverFailed failure prefix) -> + TypedModuleFailed + (case failure of + Declaration.DriverDeclarationFailed err -> + TypedDeclarationFailed err + Declaration.DriverActionFailed err -> + TypedActionFailed err) + prefix + Right (Declaration.DriverSealFailed err prefix) -> + TypedModuleFailed (TypedSealFailed err) prefix diff --git a/source/Felix/Checking/Semantic.hs b/source/Felix/Checking/Semantic.hs new file mode 100644 index 0000000..c9442f3 --- /dev/null +++ b/source/Felix/Checking/Semantic.hs @@ -0,0 +1,1759 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Canonical semantic declaration, prefix, interface, and validation keys. +module Felix.Checking.Semantic + ( DeclarationSlot + , declarationSlot + , declarationSlotModule + , declarationSlotOrdinal + , FactSlot + , factSlot + , factSlotModule + , factSlotOrdinal + , SemanticName + , semanticName + , semanticNameText + , FactSearchEligibility(..) + , SemanticFactOccurrence + , semanticFactOccurrence + , semanticFactSlot + , semanticFactProposition + , semanticFactAuthority + , semanticFactSearchEligibility + , semanticFactFingerprint + , SemanticFactOccurrenceFingerprint + , semanticFactOccurrenceFingerprint + , semanticFactFingerprintDigest + , SemanticAlias + , semanticAlias + , semanticAliasName + , semanticAliasTarget + , SemanticGlobalKey(..) + , semanticGlobalKeyFromLexicalEntry + , semanticGlobalKeyType + , SemanticGlobalTarget(..) + , semanticGlobalTargetObject + , semanticGlobalTargetRequirements + , SemanticGlobalBinding + , semanticGlobalBinding + , semanticGlobalBindingKey + , semanticGlobalBindingTarget + , SemanticGlobalTargetError(..) + , validateSemanticGlobalBindingTarget + , SemanticEnvironmentDelta + , emptySemanticEnvironmentDelta + , semanticEnvironmentDelta + , semanticEnvironmentWithStructures + , semanticEnvironmentBindings + , semanticEnvironmentStructures + , SemanticStructurePhrase + , semanticStructurePhrase + , semanticStructurePhraseSingular + , semanticStructurePhrasePlural + , semanticStructurePhraseMarker + , SemanticStructureOperation + , semanticStructureOperation + , semanticStructureOperationSymbol + , semanticStructureOperationObject + , SemanticStructureDescriptor + , semanticStructureDescriptor + , semanticStructureDescriptorPhrase + , semanticStructureDescriptorPredicate + , semanticStructureDescriptorParents + , semanticStructureDescriptorOperations + , SemanticEnvironmentError(..) + , DeclarationInterfaceDelta + , declarationInterfaceDelta + , declarationDeltaSlot + , declarationDeltaFacts + , declarationDeltaAliases + , declarationDeltaObjects + , declarationDeltaPropositions + , declarationDeltaEnvironment + , DeclarationInterfaceError(..) + , SemanticInterfaceId + , semanticInterfaceIdDigest + , SemanticInterface + , semanticInterface + , semanticInterfaceOwner + , semanticInterfaceDirectInputs + , semanticInterfaceDeclarations + , semanticInterfaceAssertedId + , SemanticInterfaceError(..) + , validateSemanticInterface + , renderSemanticInterfaceError + , PrefixContextId + , initialPrefixContextId + , PrefixContextError(..) + , nextPrefixContextId + , prefixContextIdDigest + , ProofSyntaxId + , proofSyntaxId + , DeclarationSyntaxId + , declarationSyntaxId + , ProofValidationKey + , proofValidationKey + , proofValidationKeyDigest + , ProofValidationRecord + , proofValidationRecord + , proofValidationRecordKey + , proofValidationRecordCertificate + , DeclarationValidationKey + , declarationValidationKey + , declarationValidationKeyDigest + , DeclarationValidationRecord + , declarationValidationRecord + , declarationValidationRecordKey + , declarationValidationRecordCertificates + , ModuleArtifactKey + , moduleArtifactKey + , moduleArtifactKeyOwner + , moduleArtifactKeyDirectSemanticInputs + , moduleArtifactKeyTheory + , ModuleArtifactKeyError(..) + , ModuleArtifactId + , moduleArtifactId + , moduleArtifactIdDigest + , ModuleArtifactResult + , moduleArtifactResult + , moduleArtifactResultId + , moduleArtifactResultSyntax + , moduleArtifactResultSemantic + , putModuleArtifactKeyCache + , getModuleArtifactKeyCache + , putModuleArtifactIdCache + , getModuleArtifactIdCache + , putModuleArtifactResultCache + , getModuleArtifactResultCache + , putSemanticFactOccurrenceFingerprintCache + , getSemanticFactOccurrenceFingerprintCache + , putSemanticFactOccurrenceCache + , getSemanticFactOccurrenceCache + , putSemanticEnvironmentDeltaCache + , getSemanticEnvironmentDeltaCache + , putSemanticGlobalKeyCache + , getSemanticGlobalKeyCache + , putDeclarationInterfaceDeltaCache + , getDeclarationInterfaceDeltaCache + , putSemanticInterfaceCache + , getSemanticInterfaceCache + , putSemanticInterfaceIdCache + , getSemanticInterfaceIdCache + , putPrefixContextIdCache + , getPrefixContextIdCache + , putProofValidationRecordCache + , getProofValidationRecordCache + , putDeclarationValidationRecordCache + , getDeclarationValidationRecordCache + ) where + +import Base +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Identity +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity +import Felix.Source +import Felix.Syntax.Interface +import Felix.Syntax.Abstract + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Numeric.Natural (Natural) +import Data.Set qualified as Set +import Data.Text qualified as Text + + +data DeclarationSlot = DeclarationSlot + !ModuleName + !LocalDeclarationOrdinal + deriving stock (Show, Eq, Ord) + +declarationSlot + :: ModuleName + -> LocalDeclarationOrdinal + -> DeclarationSlot +declarationSlot = + DeclarationSlot + +declarationSlotModule :: DeclarationSlot -> ModuleName +declarationSlotModule (DeclarationSlot owner _) = + owner + +declarationSlotOrdinal + :: DeclarationSlot + -> LocalDeclarationOrdinal +declarationSlotOrdinal (DeclarationSlot _ ordinal) = + ordinal + +data FactSlot = FactSlot + !ModuleName + !LocalFactOrdinal + deriving stock (Show, Eq, Ord) + +factSlot :: ModuleName -> LocalFactOrdinal -> FactSlot +factSlot = + FactSlot + +factSlotModule :: FactSlot -> ModuleName +factSlotModule (FactSlot owner _) = + owner + +factSlotOrdinal :: FactSlot -> LocalFactOrdinal +factSlotOrdinal (FactSlot _ ordinal) = + ordinal + +newtype SemanticName = + SemanticName Text + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticName :: Text -> SemanticName +semanticName = + SemanticName + +semanticNameText :: SemanticName -> Text +semanticNameText (SemanticName name) = + name + +data FactSearchEligibility + = SearchEligible + | SearchIneligible + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +newtype SemanticFactOccurrenceFingerprint = + SemanticFactOccurrenceFingerprint CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticFactOccurrenceFingerprint + :: FactSlot + -> FactAuthority + -> SemanticFactOccurrenceFingerprint +semanticFactOccurrenceFingerprint slot authority = + SemanticFactOccurrenceFingerprint + (hashCacheFields + "felix-semantic-fact-occurrence-v1" + [ encodeCache (putFactSlotCache slot) + , encodeCache (putFactAuthorityCache authority) + ]) + +semanticFactFingerprintDigest + :: SemanticFactOccurrenceFingerprint + -> CacheDigest +semanticFactFingerprintDigest + (SemanticFactOccurrenceFingerprint digest) = + digest + +data SemanticFactOccurrence = SemanticFactOccurrence + !FactSlot + !FactAuthority + !FactSearchEligibility + deriving stock (Show, Eq, Ord, Generic) + +semanticFactOccurrence + :: FactSlot + -> FactAuthority + -> FactSearchEligibility + -> SemanticFactOccurrence +semanticFactOccurrence = + SemanticFactOccurrence + +semanticFactSlot :: SemanticFactOccurrence -> FactSlot +semanticFactSlot + (SemanticFactOccurrence slot _ _) = + slot + +semanticFactProposition + :: SemanticFactOccurrence + -> PropositionId +semanticFactProposition + (SemanticFactOccurrence _ authority _) = + theoremRefProposition + (factAuthorityTheorem authority) + +semanticFactAuthority + :: SemanticFactOccurrence + -> FactAuthority +semanticFactAuthority + (SemanticFactOccurrence _ authority _) = + authority + +semanticFactSearchEligibility + :: SemanticFactOccurrence + -> FactSearchEligibility +semanticFactSearchEligibility + (SemanticFactOccurrence _ _ eligibility) = + eligibility + +semanticFactFingerprint + :: SemanticFactOccurrence + -> SemanticFactOccurrenceFingerprint +semanticFactFingerprint + (SemanticFactOccurrence slot authority _) = + semanticFactOccurrenceFingerprint slot authority + +data SemanticAlias = SemanticAlias + !SemanticName + !SemanticFactOccurrenceFingerprint + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticAlias + :: SemanticName + -> SemanticFactOccurrenceFingerprint + -> SemanticAlias +semanticAlias = + SemanticAlias + +semanticAliasName :: SemanticAlias -> SemanticName +semanticAliasName (SemanticAlias name _) = + name + +semanticAliasTarget + :: SemanticAlias + -> SemanticFactOccurrenceFingerprint +semanticAliasTarget (SemanticAlias _ target) = + target + + +-- | Exact source-level name used to resolve a declared monomorphic object. +-- Presentation markers and expression fixity are deliberately absent. +data SemanticGlobalKey + = SemanticLeftAdjective !Pattern + | SemanticRightAdjective !Pattern + | SemanticFunctionPhrase !Pattern !Pattern + | SemanticNoun !Pattern !Pattern + | SemanticVerb !Pattern !Pattern + | SemanticRelation !Token !ParameterArity + | SemanticExpressionFunction !Pattern + | SemanticPrefixPredicate !Text !Natural + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalKeyType :: SemanticGlobalKey -> Maybe CoreType +semanticGlobalKeyType = \case + SemanticLeftAdjective pat -> + Just (setArguments (1 + patternArity pat) TyProp) + SemanticRightAdjective pat -> + Just (setArguments (1 + patternArity pat) TyProp) + SemanticFunctionPhrase singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (patternArity singular) TySet) + | otherwise -> Nothing + SemanticNoun singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (1 + patternArity singular) TyProp) + | otherwise -> Nothing + SemanticVerb singular plural + | patternArity singular == patternArity plural -> + Just (setArguments (1 + patternArity singular) TyProp) + | otherwise -> Nothing + SemanticRelation _token arity -> + Just + (setArguments + (2 + parameterArityValue arity) + TyProp) + SemanticExpressionFunction pat -> + Just (setArguments (patternArity pat) TySet) + SemanticPrefixPredicate _command arity -> + Just (setArguments arity TyProp) + where + patternArity :: Pattern -> Natural + patternArity = \case + End -> 0 + HoleCons rest -> 1 + patternArity rest + TokenCons _token rest -> patternArity rest + + setArguments :: Natural -> CoreType -> CoreType + setArguments argumentCount result = + foldr + (const (TyArrow TySet)) + result + [1 .. argumentCount] + +semanticGlobalKeyFromLexicalEntry + :: CanonicalLexicalEntry + -> Maybe SemanticGlobalKey +semanticGlobalKeyFromLexicalEntry = \case + CanonicalLeftAdjective pat _marker -> + Just (SemanticLeftAdjective pat) + CanonicalRightAdjective pat _marker -> + Just (SemanticRightAdjective pat) + CanonicalFunctionPhrase singular plural _marker -> + Just (SemanticFunctionPhrase singular plural) + CanonicalNoun singular plural _marker -> + Just (SemanticNoun singular plural) + CanonicalVerb singular plural _marker -> + Just (SemanticVerb singular plural) + CanonicalRelation token arity _marker -> + Just (SemanticRelation token arity) + CanonicalExpressionFunction pat _marker _fixity -> + Just (SemanticExpressionFunction pat) + CanonicalPrefixPredicate command arity _marker -> + Just (SemanticPrefixPredicate command arity) + CanonicalStructureNoun{} -> + Nothing + CanonicalStructureOperation{} -> + Nothing + +data SemanticGlobalTarget + = GlobalReference !ObjectId + | TransparentExpansion !ObjectId + | ContextualTransparentExpansion + !ObjectId + !(Map.Map StructSymbol ObjectId) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalTargetObject :: SemanticGlobalTarget -> ObjectId +semanticGlobalTargetObject = \case + GlobalReference identity -> identity + TransparentExpansion identity -> identity + ContextualTransparentExpansion identity _requirements -> identity + +semanticGlobalTargetRequirements + :: SemanticGlobalTarget + -> Map.Map StructSymbol ObjectId +semanticGlobalTargetRequirements = \case + GlobalReference{} -> Map.empty + TransparentExpansion{} -> Map.empty + ContextualTransparentExpansion _identity requirements -> requirements + +data SemanticGlobalBinding = SemanticGlobalBinding + !SemanticGlobalKey + !SemanticGlobalTarget + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticGlobalBinding + :: SemanticGlobalKey + -> SemanticGlobalTarget + -> SemanticGlobalBinding +semanticGlobalBinding = + SemanticGlobalBinding + +semanticGlobalBindingKey + :: SemanticGlobalBinding + -> SemanticGlobalKey +semanticGlobalBindingKey (SemanticGlobalBinding key _target) = + key + +semanticGlobalBindingTarget + :: SemanticGlobalBinding + -> SemanticGlobalTarget +semanticGlobalBindingTarget (SemanticGlobalBinding _key target) = + target + +data SemanticGlobalTargetError + = SemanticGlobalKeyHasInconsistentArity !SemanticGlobalKey + | SemanticGlobalTargetMissing !ObjectId + | SemanticGlobalTargetIsIntrinsic !ObjectId + | SemanticGlobalTargetTypeMismatch !ObjectId !CoreType !CoreType + | SemanticGlobalExpansionNotTransparent !ObjectId + | SemanticGlobalContextualRequirementsEmpty !ObjectId + | SemanticGlobalContextualRequirementMissing !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementIsIntrinsic !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementTypeMismatch + !StructSymbol !ObjectId !CoreType !CoreType + | SemanticGlobalContextualRequirementNotProvided + !StructSymbol !ObjectId + | SemanticGlobalContextualRequirementNotReferenced !StructSymbol !ObjectId + deriving stock (Show, Eq) + +validateSemanticGlobalBindingTarget + :: Set.Set (StructSymbol, ObjectId) + -> CheckedObjectClosure + -> SemanticGlobalBinding + -> Either SemanticGlobalTargetError () +validateSemanticGlobalBindingTarget operationBindings closure binding = do + expected <- + maybe + (Left (SemanticGlobalKeyHasInconsistentArity key)) + Right + (semanticGlobalKeyType key) + content <- + maybe + (Left (SemanticGlobalTargetMissing identity)) + Right + (lookupCheckedObjectContent identity closure) + when + (objectIdFamily identity == IntrinsicObject) + (Left (SemanticGlobalTargetIsIntrinsic identity)) + let targetExpected = + case target of + ContextualTransparentExpansion{} -> + TyArrow TySet expected + _ -> expected + actual = objectContentType content + unless + (actual == targetExpected) + (Left + (SemanticGlobalTargetTypeMismatch + identity targetExpected actual)) + case target of + GlobalReference{} -> pure () + TransparentExpansion{} -> + validateTransparent content + ContextualTransparentExpansion _ requirements -> do + validateTransparent content + when + (Map.null requirements) + (Left (SemanticGlobalContextualRequirementsEmpty identity)) + traverse_ (validateRequirement content) (Map.toAscList requirements) + where + key = semanticGlobalBindingKey binding + target = semanticGlobalBindingTarget binding + identity = semanticGlobalTargetObject target + + validateTransparent = \case + TransparentObjectContent{} -> pure () + _ -> Left (SemanticGlobalExpansionNotTransparent identity) + + validateRequirement content (symbol, object) = do + operationContent <- + maybe + (Left + (SemanticGlobalContextualRequirementMissing + symbol object)) + Right + (lookupCheckedObjectContent object closure) + when + (objectIdFamily object == IntrinsicObject) + (Left + (SemanticGlobalContextualRequirementIsIntrinsic + symbol object)) + let expectedOperation = TyArrow TySet TySet + actualOperation = objectContentType operationContent + unless + (actualOperation == expectedOperation) + (Left + (SemanticGlobalContextualRequirementTypeMismatch + symbol object expectedOperation actualOperation)) + unless + ((symbol, object) `Set.member` operationBindings) + (Left + (SemanticGlobalContextualRequirementNotProvided + symbol object)) + case content of + TransparentObjectContent _theory _coreType body -> + unless + (object `Set.member` canonicalTermGlobals body) + (Left + (SemanticGlobalContextualRequirementNotReferenced + symbol object)) + _ -> impossible "a contextual expansion was not transparent" + +data SemanticEnvironmentDelta + = EmptySemanticEnvironmentDelta + | SemanticGlobalBindings ![SemanticGlobalBinding] + | SemanticGlobalBindingsAndStructures + ![SemanticGlobalBinding] + ![SemanticStructureDescriptor] + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +data SemanticStructurePhrase = SemanticStructurePhrase + !Pattern + !Pattern + !Marker + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructurePhrase :: LexicalItemSgPl -> SemanticStructurePhrase +semanticStructurePhrase (LexicalItemSgPl forms marker) = + SemanticStructurePhrase (sg forms) (pl forms) marker + +semanticStructurePhraseSingular :: SemanticStructurePhrase -> Pattern +semanticStructurePhraseSingular (SemanticStructurePhrase singular _ _) = + singular + +semanticStructurePhrasePlural :: SemanticStructurePhrase -> Pattern +semanticStructurePhrasePlural (SemanticStructurePhrase _ plural _) = + plural + +semanticStructurePhraseMarker :: SemanticStructurePhrase -> Marker +semanticStructurePhraseMarker (SemanticStructurePhrase _ _ marker) = + marker + +data SemanticStructureOperation = SemanticStructureOperation + !StructSymbol + !ObjectId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructureOperation + :: StructSymbol + -> ObjectId + -> SemanticStructureOperation +semanticStructureOperation = + SemanticStructureOperation + +semanticStructureOperationSymbol + :: SemanticStructureOperation + -> StructSymbol +semanticStructureOperationSymbol (SemanticStructureOperation symbol _) = + symbol + +semanticStructureOperationObject + :: SemanticStructureOperation + -> ObjectId +semanticStructureOperationObject (SemanticStructureOperation _ object) = + object + +data SemanticStructureDescriptor = SemanticStructureDescriptor + !SemanticStructurePhrase + !(Maybe ObjectId) + ![SemanticStructurePhrase] + ![SemanticStructureOperation] + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +semanticStructureDescriptor + :: SemanticStructurePhrase + -> Maybe ObjectId + -> [SemanticStructurePhrase] + -> [SemanticStructureOperation] + -> Either SemanticEnvironmentError SemanticStructureDescriptor +semanticStructureDescriptor structurePhrase predicate parents operations = do + case firstDuplicate parents of + Just duplicate -> + Left (DuplicateSemanticStructureParent duplicate) + Nothing -> pure () + when + (structurePhrase `elem` parents) + (Left (SelfSemanticStructureParent structurePhrase)) + case firstDuplicate (semanticStructureOperationSymbol <$> operations) of + Just duplicate -> + Left (DuplicateSemanticStructureOperation duplicate) + Nothing -> pure () + pure + (SemanticStructureDescriptor + structurePhrase predicate parents operations) + +semanticStructureDescriptorPhrase + :: SemanticStructureDescriptor + -> SemanticStructurePhrase +semanticStructureDescriptorPhrase + (SemanticStructureDescriptor structurePhrase _ _ _) = + structurePhrase + +semanticStructureDescriptorPredicate + :: SemanticStructureDescriptor + -> Maybe ObjectId +semanticStructureDescriptorPredicate + (SemanticStructureDescriptor _ predicate _ _) = + predicate + +semanticStructureDescriptorParents + :: SemanticStructureDescriptor + -> [SemanticStructurePhrase] +semanticStructureDescriptorParents + (SemanticStructureDescriptor _ _ parents _) = + parents + +semanticStructureDescriptorOperations + :: SemanticStructureDescriptor + -> [SemanticStructureOperation] +semanticStructureDescriptorOperations + (SemanticStructureDescriptor _ _ _ operations) = + operations + +data SemanticEnvironmentError + = DuplicateSemanticGlobalKey !SemanticGlobalKey + | NonCanonicalSemanticGlobalBindingOrder + | DuplicateSemanticStructure !SemanticStructurePhrase + | NonCanonicalSemanticStructureOrder + | DuplicateSemanticStructureParent !SemanticStructurePhrase + | SelfSemanticStructureParent !SemanticStructurePhrase + | DuplicateSemanticStructureOperation !StructSymbol + deriving stock (Show, Eq) + +emptySemanticEnvironmentDelta :: SemanticEnvironmentDelta +emptySemanticEnvironmentDelta = + EmptySemanticEnvironmentDelta + +semanticEnvironmentDelta + :: [SemanticGlobalBinding] + -> Either SemanticEnvironmentError SemanticEnvironmentDelta +semanticEnvironmentDelta bindings = + semanticEnvironmentWithStructures bindings [] + +semanticEnvironmentWithStructures + :: [SemanticGlobalBinding] + -> [SemanticStructureDescriptor] + -> Either SemanticEnvironmentError SemanticEnvironmentDelta +semanticEnvironmentWithStructures [] [] = + Right EmptySemanticEnvironmentDelta +semanticEnvironmentWithStructures bindings structures = do + case firstDuplicate (semanticGlobalBindingKey <$> bindings) of + Just duplicate -> + Left (DuplicateSemanticGlobalKey duplicate) + Nothing -> + pure () + unless + (bindings == List.sortOn semanticGlobalBindingKey bindings) + (Left NonCanonicalSemanticGlobalBindingOrder) + case firstDuplicate (semanticStructureDescriptorPhrase <$> structures) of + Just duplicate -> + Left (DuplicateSemanticStructure duplicate) + Nothing -> pure () + unless + ( structures + == List.sortOn semanticStructureDescriptorPhrase structures + ) + (Left NonCanonicalSemanticStructureOrder) + pure + (case structures of + [] -> SemanticGlobalBindings bindings + _ -> SemanticGlobalBindingsAndStructures bindings structures) + +semanticEnvironmentBindings + :: SemanticEnvironmentDelta + -> [SemanticGlobalBinding] +semanticEnvironmentBindings = \case + EmptySemanticEnvironmentDelta -> [] + SemanticGlobalBindings bindings -> bindings + SemanticGlobalBindingsAndStructures bindings _ -> bindings + +semanticEnvironmentStructures + :: SemanticEnvironmentDelta + -> [SemanticStructureDescriptor] +semanticEnvironmentStructures = \case + EmptySemanticEnvironmentDelta -> [] + SemanticGlobalBindings{} -> [] + SemanticGlobalBindingsAndStructures _ structures -> structures + + +data DeclarationInterfaceDelta = DeclarationInterfaceDelta + !DeclarationSlot + ![SemanticFactOccurrence] + ![SemanticAlias] + ![ObjectId] + ![PropositionId] + !SemanticEnvironmentDelta + deriving stock (Show, Eq, Ord, Generic) + +data DeclarationInterfaceError + = DeclarationFactOwnerMismatch !FactSlot + | DuplicateDeclarationFactSlot !FactSlot + | DuplicateDeclarationFactFingerprint + !SemanticFactOccurrenceFingerprint + | DuplicateDeclarationAlias !SemanticName + | DuplicateDeclarationObject !ObjectId + | DuplicateDeclarationProposition !PropositionId + | DeclarationFactPropositionMissing !PropositionId + deriving stock (Show, Eq) + +declarationInterfaceDelta + :: DeclarationSlot + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [ObjectId] + -> [PropositionId] + -> SemanticEnvironmentDelta + -> Either DeclarationInterfaceError DeclarationInterfaceDelta +declarationInterfaceDelta + slot facts aliases objects propositions environment = do + traverse_ validateFact facts + rejectDuplicate + DuplicateDeclarationFactSlot + (semanticFactSlot <$> facts) + rejectDuplicate + DuplicateDeclarationFactFingerprint + (semanticFactFingerprint <$> facts) + rejectDuplicate + DuplicateDeclarationAlias + (semanticAliasName <$> aliases) + rejectDuplicate DuplicateDeclarationObject objects + rejectDuplicate DuplicateDeclarationProposition propositions + pure + (DeclarationInterfaceDelta + slot facts aliases objects propositions environment) + where + owner = declarationSlotModule slot + propositionSet = Set.fromList propositions + + validateFact occurrence = do + unless + (factSlotModule (semanticFactSlot occurrence) == owner) + (Left + (DeclarationFactOwnerMismatch + (semanticFactSlot occurrence))) + let proposition = + semanticFactProposition occurrence + unless + (proposition `Set.member` propositionSet) + (Left (DeclarationFactPropositionMissing proposition)) + +declarationDeltaSlot + :: DeclarationInterfaceDelta + -> DeclarationSlot +declarationDeltaSlot + (DeclarationInterfaceDelta slot _ _ _ _ _) = + slot + +declarationDeltaFacts + :: DeclarationInterfaceDelta + -> [SemanticFactOccurrence] +declarationDeltaFacts + (DeclarationInterfaceDelta _ facts _ _ _ _) = + facts + +declarationDeltaAliases + :: DeclarationInterfaceDelta + -> [SemanticAlias] +declarationDeltaAliases + (DeclarationInterfaceDelta _ _ aliases _ _ _) = + aliases + +declarationDeltaObjects + :: DeclarationInterfaceDelta + -> [ObjectId] +declarationDeltaObjects + (DeclarationInterfaceDelta _ _ _ objects _ _) = + objects + +declarationDeltaPropositions + :: DeclarationInterfaceDelta + -> [PropositionId] +declarationDeltaPropositions + (DeclarationInterfaceDelta _ _ _ _ propositions _) = + propositions + +declarationDeltaEnvironment + :: DeclarationInterfaceDelta + -> SemanticEnvironmentDelta +declarationDeltaEnvironment + (DeclarationInterfaceDelta _ _ _ _ _ environment) = + environment + + +newtype SemanticInterfaceId = + SemanticInterfaceId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +semanticInterfaceIdDigest + :: SemanticInterfaceId + -> CacheDigest +semanticInterfaceIdDigest (SemanticInterfaceId digest) = + digest + +data SemanticInterface = SemanticInterface + !ModuleName + ![SemanticInterfaceId] + ![DeclarationInterfaceDelta] + !SemanticInterfaceId + deriving stock (Show, Eq, Ord) + +data SemanticInterfaceError + = DuplicateDirectSemanticInterface !SemanticInterfaceId + | SemanticDeclarationOwnerMismatch !DeclarationSlot + | NonIncreasingDeclarationSlots + | NonIncreasingFactSlots + | SemanticInterfaceIdMismatch + !SemanticInterfaceId + !SemanticInterfaceId + deriving stock (Show, Eq) + +renderSemanticInterfaceError :: SemanticInterfaceError -> Text +renderSemanticInterfaceError = \case + DuplicateDirectSemanticInterface interface -> + "direct semantic interface occurs more than once: " + <> Text.pack (show interface) + SemanticDeclarationOwnerMismatch slot -> + "declaration belongs to a different module: " + <> Text.pack (show slot) + NonIncreasingDeclarationSlots -> + "declaration slots are not in increasing order" + NonIncreasingFactSlots -> + "fact slots are not in increasing order" + SemanticInterfaceIdMismatch expected actual -> + "semantic interface identity mismatch: expected " + <> Text.pack (show expected) + <> ", found " <> Text.pack (show actual) + +semanticInterface + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> Either SemanticInterfaceError SemanticInterface +semanticInterface owner direct declarations = do + validateSemanticInterfaceStructure owner direct declarations + let identity = + computeSemanticInterfaceId owner direct declarations + pure (SemanticInterface owner direct declarations identity) + +validateSemanticInterface + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> SemanticInterfaceId + -> Either SemanticInterfaceError SemanticInterface +validateSemanticInterface owner direct declarations asserted = do + validateSemanticInterfaceStructure owner direct declarations + let computed = + computeSemanticInterfaceId + owner direct declarations + unless + (asserted == computed) + (Left + (SemanticInterfaceIdMismatch asserted computed)) + pure + (SemanticInterface + owner direct declarations asserted) + +validateSemanticInterfaceStructure + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> Either SemanticInterfaceError () +validateSemanticInterfaceStructure owner direct declarations = do + rejectDuplicate + DuplicateDirectSemanticInterface + direct + traverse_ + (\delta -> + unless + (declarationSlotModule + (declarationDeltaSlot delta) + == owner) + (Left + (SemanticDeclarationOwnerMismatch + (declarationDeltaSlot delta)))) + declarations + unless + (strictlyIncreasing + ( localDeclarationOrdinalValue + . declarationSlotOrdinal + . declarationDeltaSlot + <$> declarations)) + (Left NonIncreasingDeclarationSlots) + unless + (strictlyIncreasing + ( localFactOrdinalValue + . factSlotOrdinal + . semanticFactSlot + <$> concatMap + declarationDeltaFacts + declarations)) + (Left NonIncreasingFactSlots) + +semanticInterfaceOwner :: SemanticInterface -> ModuleName +semanticInterfaceOwner + (SemanticInterface owner _ _ _) = + owner + +semanticInterfaceDirectInputs + :: SemanticInterface + -> [SemanticInterfaceId] +semanticInterfaceDirectInputs + (SemanticInterface _ direct _ _) = + direct + +semanticInterfaceDeclarations + :: SemanticInterface + -> [DeclarationInterfaceDelta] +semanticInterfaceDeclarations + (SemanticInterface _ _ declarations _) = + declarations + +semanticInterfaceAssertedId + :: SemanticInterface + -> SemanticInterfaceId +semanticInterfaceAssertedId + (SemanticInterface _ _ _ asserted) = + asserted + +computeSemanticInterfaceId + :: ModuleName + -> [SemanticInterfaceId] + -> [DeclarationInterfaceDelta] + -> SemanticInterfaceId +computeSemanticInterfaceId owner direct declarations = + SemanticInterfaceId + (hashCacheFields + "felix-semantic-interface-v1" + [ encodeCache (putModuleNameCache owner) + , encodeCache + (putCacheList + putSemanticInterfaceIdCache + direct) + , encodeCache + (putCacheList + putDeclarationInterfaceDeltaCache + declarations) + ]) + + +newtype PrefixContextId = + PrefixContextId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +data PrefixContextError + = DuplicateInitialPrefixSemanticInput !SemanticInterfaceId + deriving stock (Show, Eq) + +initialPrefixContextId + :: TheoryId + -> ModuleName + -> [SemanticInterfaceId] + -> Either PrefixContextError PrefixContextId +initialPrefixContextId theory owner direct = do + rejectDuplicate + DuplicateInitialPrefixSemanticInput + direct + pure + (PrefixContextId + (hashCacheFields + "felix-prefix-initial-v1" + [ encodeCache (putTheoryIdCache theory) + , encodeCache (putModuleNameCache owner) + , encodeCache + (putCacheList + putSemanticInterfaceIdCache + direct) + ])) + +nextPrefixContextId + :: PrefixContextId + -> DeclarationInterfaceDelta + -> PrefixContextId +nextPrefixContextId previous delta = + PrefixContextId + (hashCacheFields + "felix-prefix-step-v1" + [ encodeCache (putPrefixContextIdCache previous) + , encodeCache + (putDeclarationInterfaceDeltaCache delta) + ]) + +prefixContextIdDigest :: PrefixContextId -> CacheDigest +prefixContextIdDigest (PrefixContextId digest) = + digest + + +newtype ProofSyntaxId = + ProofSyntaxId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +proofSyntaxId :: ByteString -> ProofSyntaxId +proofSyntaxId bytes = + ProofSyntaxId + (hashCacheFields "felix-proof-syntax-v1" [bytes]) + +newtype DeclarationSyntaxId = + DeclarationSyntaxId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +declarationSyntaxId :: ByteString -> DeclarationSyntaxId +declarationSyntaxId bytes = + DeclarationSyntaxId + (hashCacheFields "felix-declaration-syntax-v1" [bytes]) + +newtype ProofValidationKey = + ProofValidationKey CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +proofValidationKey + :: TheoremId + -> ProofSyntaxId + -> PrefixContextId + -> ProofValidationKey +proofValidationKey theorem (ProofSyntaxId syntax) prefix = + ProofValidationKey + (hashCacheFields + "felix-proof-validation" + [ mathematicalDigestBytes + (theoremIdDigest theorem) + , cacheDigestBytes syntax + , encodeCache (putPrefixContextIdCache prefix) + ]) + +proofValidationKeyDigest + :: ProofValidationKey + -> CacheDigest +proofValidationKeyDigest (ProofValidationKey digest) = + digest + +data ProofValidationRecord = ProofValidationRecord + !ProofValidationKey + !ValidationCertificate + deriving stock (Show, Eq, Ord, Generic) + +proofValidationRecord + :: ProofValidationKey + -> ValidationCertificate + -> ProofValidationRecord +proofValidationRecord = + ProofValidationRecord + +proofValidationRecordKey + :: ProofValidationRecord + -> ProofValidationKey +proofValidationRecordKey + (ProofValidationRecord key _) = + key + +proofValidationRecordCertificate + :: ProofValidationRecord + -> ValidationCertificate +proofValidationRecordCertificate + (ProofValidationRecord _ certificate) = + certificate + +newtype DeclarationValidationKey = + DeclarationValidationKey CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +declarationValidationKey + :: DeclarationSyntaxId + -> PrefixContextId + -> [ObjectId] + -> [TheoremId] + -> DeclarationValidationKey +declarationValidationKey + (DeclarationSyntaxId syntax) + prefix objects theorems = + DeclarationValidationKey + (hashCacheFields + "felix-declaration-validation" + [ cacheDigestBytes syntax + , encodeCache (putPrefixContextIdCache prefix) + , encodeCache (putCacheList putObjectIdCache objects) + , encodeCache + (putCacheList + (putMathematicalDigestCache . theoremIdDigest) + theorems) + ]) + +declarationValidationKeyDigest + :: DeclarationValidationKey + -> CacheDigest +declarationValidationKeyDigest + (DeclarationValidationKey digest) = + digest + +data DeclarationValidationRecord = DeclarationValidationRecord + !DeclarationValidationKey + ![ValidationCertificate] + deriving stock (Show, Eq, Ord, Generic) + +declarationValidationRecord + :: DeclarationValidationKey + -> [ValidationCertificate] + -> DeclarationValidationRecord +declarationValidationRecord = + DeclarationValidationRecord + +declarationValidationRecordKey + :: DeclarationValidationRecord + -> DeclarationValidationKey +declarationValidationRecordKey + (DeclarationValidationRecord key _) = + key + +declarationValidationRecordCertificates + :: DeclarationValidationRecord + -> [ValidationCertificate] +declarationValidationRecordCertificates + (DeclarationValidationRecord _ certificates) = + certificates + + +data ModuleArtifactKey = ModuleArtifactKey + !ModuleName + !ParsedModuleId + ![SemanticInterfaceId] + !TheoryId + deriving stock (Show, Eq, Ord) + +data ModuleArtifactKeyError + = DuplicateModuleArtifactSemanticInput + !SemanticInterfaceId + deriving stock (Show, Eq) + +moduleArtifactKey + :: ModuleName + -> ParsedModuleId + -> [SemanticInterfaceId] + -> TheoryId + -> Either ModuleArtifactKeyError ModuleArtifactKey +moduleArtifactKey owner parsed direct theory = do + rejectDuplicate + DuplicateModuleArtifactSemanticInput + direct + pure (ModuleArtifactKey owner parsed direct theory) + +moduleArtifactKeyOwner :: ModuleArtifactKey -> ModuleName +moduleArtifactKeyOwner (ModuleArtifactKey owner _parsed _direct _theory) = + owner + +moduleArtifactKeyDirectSemanticInputs + :: ModuleArtifactKey + -> [SemanticInterfaceId] +moduleArtifactKeyDirectSemanticInputs + (ModuleArtifactKey _owner _parsed direct _theory) = + direct + +moduleArtifactKeyTheory :: ModuleArtifactKey -> TheoryId +moduleArtifactKeyTheory + (ModuleArtifactKey _owner _parsed _direct theory) = + theory + +newtype ModuleArtifactId = + ModuleArtifactId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +moduleArtifactId :: ModuleArtifactKey -> ModuleArtifactId +moduleArtifactId key = + ModuleArtifactId + (hashCacheFields + "felix-module-artifact-v1" + [encodeCache (putModuleArtifactKeyCache key)]) + +moduleArtifactIdDigest :: ModuleArtifactId -> CacheDigest +moduleArtifactIdDigest (ModuleArtifactId digest) = + digest + +data ModuleArtifactResult = ModuleArtifactResult + !ModuleArtifactId + !SyntaxInterfaceId + !SemanticInterfaceId + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +moduleArtifactResult + :: ModuleArtifactKey + -> SyntaxInterfaceId + -> SemanticInterfaceId + -> ModuleArtifactResult +moduleArtifactResult key = + ModuleArtifactResult (moduleArtifactId key) + +moduleArtifactResultId + :: ModuleArtifactResult + -> ModuleArtifactId +moduleArtifactResultId + (ModuleArtifactResult identity _ _) = + identity + +moduleArtifactResultSyntax + :: ModuleArtifactResult + -> SyntaxInterfaceId +moduleArtifactResultSyntax + (ModuleArtifactResult _ syntax _) = + syntax + +moduleArtifactResultSemantic + :: ModuleArtifactResult + -> SemanticInterfaceId +moduleArtifactResultSemantic + (ModuleArtifactResult _ _ semantic) = + semantic + + +putSemanticFactOccurrenceFingerprintCache + :: SemanticFactOccurrenceFingerprint + -> CachePut +putSemanticFactOccurrenceFingerprintCache + (SemanticFactOccurrenceFingerprint digest) = + putCacheDigest digest + +getSemanticFactOccurrenceFingerprintCache + :: CacheGet SemanticFactOccurrenceFingerprint +getSemanticFactOccurrenceFingerprintCache = + SemanticFactOccurrenceFingerprint <$> getCacheDigest + +putSemanticFactOccurrenceCache + :: SemanticFactOccurrence + -> CachePut +putSemanticFactOccurrenceCache + (SemanticFactOccurrence slot authority eligibility) = do + putFactSlotCache slot + putFactAuthorityCache authority + putEligibility eligibility + +getSemanticFactOccurrenceCache + :: CacheGet SemanticFactOccurrence +getSemanticFactOccurrenceCache = + semanticFactOccurrence + <$> getFactSlotCache + <*> getFactAuthorityCache + <*> getEligibility + +putSemanticEnvironmentDeltaCache + :: SemanticEnvironmentDelta + -> CachePut +putSemanticEnvironmentDeltaCache EmptySemanticEnvironmentDelta = + putCacheTag 0x00 +putSemanticEnvironmentDeltaCache (SemanticGlobalBindings bindings) = do + putCacheTag 0x01 + putCacheList putSemanticGlobalBindingCache bindings +putSemanticEnvironmentDeltaCache + (SemanticGlobalBindingsAndStructures bindings structures) = do + putCacheTag 0x02 + putCacheList putSemanticGlobalBindingCache bindings + putCacheList putSemanticStructureDescriptorCache structures + +getSemanticEnvironmentDeltaCache + :: CacheGet SemanticEnvironmentDelta +getSemanticEnvironmentDeltaCache = + getCacheTag >>= \case + 0x00 -> + pure EmptySemanticEnvironmentDelta + 0x01 -> do + bindings <- getCacheList getSemanticGlobalBindingCache + either + (fail . ("invalid semantic environment delta: " <>) . show) + pure + (semanticEnvironmentDelta bindings) + 0x02 -> do + bindings <- getCacheList getSemanticGlobalBindingCache + structures <- getCacheList getSemanticStructureDescriptorCache + either + (fail . ("invalid semantic environment delta: " <>) . show) + pure + (semanticEnvironmentWithStructures bindings structures) + tag -> + fail + ("unknown semantic environment delta tag " + <> show tag) + +putSemanticGlobalKeyCache :: SemanticGlobalKey -> CachePut +putSemanticGlobalKeyCache = \case + SemanticLeftAdjective pat -> do + putCacheTag 0x00 + putPatternCache pat + SemanticRightAdjective pat -> do + putCacheTag 0x01 + putPatternCache pat + SemanticFunctionPhrase singular plural -> do + putCacheTag 0x02 + putPatternCache singular + putPatternCache plural + SemanticNoun singular plural -> do + putCacheTag 0x03 + putPatternCache singular + putPatternCache plural + SemanticVerb singular plural -> do + putCacheTag 0x04 + putPatternCache singular + putPatternCache plural + SemanticRelation token arity -> do + putCacheTag 0x05 + putTokenCache token + putCacheNatural (parameterArityValue arity) + SemanticExpressionFunction pat -> do + putCacheTag 0x06 + putPatternCache pat + SemanticPrefixPredicate command arity -> do + putCacheTag 0x07 + putCacheText command + putCacheNatural arity + +getSemanticGlobalKeyCache :: CacheGet SemanticGlobalKey +getSemanticGlobalKeyCache = + getCacheTag >>= \case + 0x00 -> SemanticLeftAdjective <$> getPatternCache + 0x01 -> SemanticRightAdjective <$> getPatternCache + 0x02 -> + SemanticFunctionPhrase + <$> getPatternCache + <*> getPatternCache + 0x03 -> + SemanticNoun + <$> getPatternCache + <*> getPatternCache + 0x04 -> + SemanticVerb + <$> getPatternCache + <*> getPatternCache + 0x05 -> + SemanticRelation + <$> getTokenCache + <*> (ParameterArity <$> getCacheNatural) + 0x06 -> SemanticExpressionFunction <$> getPatternCache + 0x07 -> + SemanticPrefixPredicate + <$> getCacheText + <*> getCacheNatural + tag -> + fail ("unknown semantic global key tag " <> show tag) + +putSemanticGlobalBindingCache :: SemanticGlobalBinding -> CachePut +putSemanticGlobalBindingCache (SemanticGlobalBinding key target) = do + putSemanticGlobalKeyCache key + case target of + GlobalReference identity -> do + putCacheTag 0x00 + putObjectIdCache identity + TransparentExpansion identity -> do + putCacheTag 0x01 + putObjectIdCache identity + ContextualTransparentExpansion identity requirements -> do + putCacheTag 0x02 + putObjectIdCache identity + putCanonicalCacheMap + (\(StructSymbol symbol) -> putCacheText symbol) + putObjectIdCache + requirements + +getSemanticGlobalBindingCache :: CacheGet SemanticGlobalBinding +getSemanticGlobalBindingCache = + SemanticGlobalBinding + <$> getSemanticGlobalKeyCache + <*> (getCacheTag >>= \case + 0x00 -> GlobalReference <$> getObjectIdCache + 0x01 -> TransparentExpansion <$> getObjectIdCache + 0x02 -> + ContextualTransparentExpansion + <$> getObjectIdCache + <*> getCanonicalCacheMap + (StructSymbol <$> getCacheText) + getObjectIdCache + tag -> + fail + ("unknown semantic global target tag " + <> show tag)) + +putSemanticStructureDescriptorCache + :: SemanticStructureDescriptor + -> CachePut +putSemanticStructureDescriptorCache + (SemanticStructureDescriptor structurePhrase predicate parents operations) = do + putSemanticStructurePhraseCache structurePhrase + putCacheMaybe putObjectIdCache predicate + putCacheList putSemanticStructurePhraseCache parents + putCacheList putSemanticStructureOperationCache operations + +getSemanticStructureDescriptorCache + :: CacheGet SemanticStructureDescriptor +getSemanticStructureDescriptorCache = do + structurePhrase <- getSemanticStructurePhraseCache + predicate <- getCacheMaybe getObjectIdCache + parents <- getCacheList getSemanticStructurePhraseCache + operations <- getCacheList getSemanticStructureOperationCache + either + (fail . ("invalid semantic structure descriptor: " <>) . show) + pure + (semanticStructureDescriptor structurePhrase predicate parents operations) + +putSemanticStructurePhraseCache + :: SemanticStructurePhrase + -> CachePut +putSemanticStructurePhraseCache + (SemanticStructurePhrase singular plural (Marker marker)) = do + putPatternCache singular + putPatternCache plural + putCacheText marker + +getSemanticStructurePhraseCache + :: CacheGet SemanticStructurePhrase +getSemanticStructurePhraseCache = + SemanticStructurePhrase + <$> getPatternCache + <*> getPatternCache + <*> (Marker <$> getCacheText) + +putSemanticStructureOperationCache + :: SemanticStructureOperation + -> CachePut +putSemanticStructureOperationCache + (SemanticStructureOperation (StructSymbol symbol) object) = do + putCacheText symbol + putObjectIdCache object + +getSemanticStructureOperationCache + :: CacheGet SemanticStructureOperation +getSemanticStructureOperationCache = + SemanticStructureOperation + <$> (StructSymbol <$> getCacheText) + <*> getObjectIdCache + +putDeclarationInterfaceDeltaCache + :: DeclarationInterfaceDelta + -> CachePut +putDeclarationInterfaceDeltaCache + (DeclarationInterfaceDelta + slot facts aliases objects propositions environment) = do + putDeclarationSlotCache slot + putCacheList putSemanticFactOccurrenceCache facts + putCacheList putSemanticAliasCache aliases + putCacheList putObjectIdCache objects + putCacheList putPropositionIdCache propositions + putSemanticEnvironmentDeltaCache environment + +getDeclarationInterfaceDeltaCache + :: CacheGet DeclarationInterfaceDelta +getDeclarationInterfaceDeltaCache = do + slot <- getDeclarationSlotCache + facts <- getCacheList getSemanticFactOccurrenceCache + aliases <- getCacheList getSemanticAliasCache + objects <- getCacheList getObjectIdCache + propositions <- getCacheList getPropositionIdCache + environment <- getSemanticEnvironmentDeltaCache + either + (fail . ("invalid declaration interface delta: " <>) . show) + pure + (declarationInterfaceDelta + slot facts aliases objects propositions environment) + +putSemanticInterfaceCache :: SemanticInterface -> CachePut +putSemanticInterfaceCache + (SemanticInterface owner direct declarations asserted) = do + putModuleNameCache owner + putCacheList putSemanticInterfaceIdCache direct + putCacheList putDeclarationInterfaceDeltaCache declarations + putSemanticInterfaceIdCache asserted + +getSemanticInterfaceCache :: CacheGet SemanticInterface +getSemanticInterfaceCache = do + owner <- getModuleNameCache + direct <- getCacheList getSemanticInterfaceIdCache + declarations <- getCacheList getDeclarationInterfaceDeltaCache + asserted <- getSemanticInterfaceIdCache + either + (fail . ("invalid semantic interface: " <>) . show) + pure + (validateSemanticInterface + owner direct declarations asserted) + +putSemanticInterfaceIdCache :: SemanticInterfaceId -> CachePut +putSemanticInterfaceIdCache (SemanticInterfaceId digest) = + putCacheDigest digest + +getSemanticInterfaceIdCache :: CacheGet SemanticInterfaceId +getSemanticInterfaceIdCache = + SemanticInterfaceId <$> getCacheDigest + +putPrefixContextIdCache :: PrefixContextId -> CachePut +putPrefixContextIdCache (PrefixContextId digest) = + putCacheDigest digest + +getPrefixContextIdCache :: CacheGet PrefixContextId +getPrefixContextIdCache = + PrefixContextId <$> getCacheDigest + +putModuleArtifactKeyCache :: ModuleArtifactKey -> CachePut +putModuleArtifactKeyCache = + putModuleArtifactKeyFields + +getModuleArtifactKeyCache :: CacheGet ModuleArtifactKey +getModuleArtifactKeyCache = do + owner <- getModuleNameCache + parsed <- getParsedModuleIdCache + direct <- getCacheList getSemanticInterfaceIdCache + theory <- getTheoryIdCache + either + (fail . ("invalid module artifact key: " <>) . show) + pure + (moduleArtifactKey owner parsed direct theory) + +putModuleArtifactIdCache :: ModuleArtifactId -> CachePut +putModuleArtifactIdCache (ModuleArtifactId digest) = + putCacheDigest digest + +getModuleArtifactIdCache :: CacheGet ModuleArtifactId +getModuleArtifactIdCache = + ModuleArtifactId <$> getCacheDigest + +putModuleArtifactResultCache + :: ModuleArtifactResult + -> CachePut +putModuleArtifactResultCache + (ModuleArtifactResult identity syntax semantic) = do + putModuleArtifactIdCache identity + putSyntaxInterfaceIdCache syntax + putSemanticInterfaceIdCache semantic + +getModuleArtifactResultCache + :: ModuleArtifactId + -> CacheGet ModuleArtifactResult +getModuleArtifactResultCache expected = do + asserted <- getModuleArtifactIdCache + unless + (asserted == expected) + (fail "module artifact result ID mismatch") + ModuleArtifactResult asserted + <$> getSyntaxInterfaceIdCache + <*> getSemanticInterfaceIdCache + +putProofValidationRecordCache + :: ProofValidationRecord + -> CachePut +putProofValidationRecordCache + (ProofValidationRecord key certificate) = do + putProofValidationKeyCache key + putValidationCertificateCache certificate + +getProofValidationRecordCache + :: CacheGet ProofValidationRecord +getProofValidationRecordCache = + ProofValidationRecord + <$> getProofValidationKeyCache + <*> getValidationCertificateCache + +putDeclarationValidationRecordCache + :: DeclarationValidationRecord + -> CachePut +putDeclarationValidationRecordCache + (DeclarationValidationRecord key certificates) = do + putDeclarationValidationKeyCache key + putCacheList putValidationCertificateCache certificates + +getDeclarationValidationRecordCache + :: CacheGet DeclarationValidationRecord +getDeclarationValidationRecordCache = + DeclarationValidationRecord + <$> getDeclarationValidationKeyCache + <*> getCacheList getValidationCertificateCache + + +putDeclarationSlotCache :: DeclarationSlot -> CachePut +putDeclarationSlotCache (DeclarationSlot owner ordinal) = do + putModuleNameCache owner + putCacheNatural (localDeclarationOrdinalValue ordinal) + +getDeclarationSlotCache :: CacheGet DeclarationSlot +getDeclarationSlotCache = + DeclarationSlot + <$> getModuleNameCache + <*> (localDeclarationOrdinal <$> getCacheNatural) + +putFactSlotCache :: FactSlot -> CachePut +putFactSlotCache (FactSlot owner ordinal) = do + putModuleNameCache owner + putCacheNatural (localFactOrdinalValue ordinal) + +getFactSlotCache :: CacheGet FactSlot +getFactSlotCache = + FactSlot + <$> getModuleNameCache + <*> (localFactOrdinal <$> getCacheNatural) + +putModuleNameCache :: ModuleName -> CachePut +putModuleNameCache owner = do + putMathematicalDigestCache + (sourceNamespaceDigest + (moduleNameNamespace owner)) + putCacheText + (Text.pack + (safeRelativePathFilePath + (moduleNameRelativePath owner))) + +getModuleNameCache :: CacheGet ModuleName +getModuleNameCache = do + namespace <- + sourceNamespaceIdFromDigest + <$> getMathematicalDigestCache + rawPath <- Text.unpack <$> getCacheText + relative <- + either + (fail . ("invalid cache module path: " <>) . show) + pure + (safeRelativePath rawPath) + pure (moduleNameFromParts namespace relative) + +putSemanticAliasCache :: SemanticAlias -> CachePut +putSemanticAliasCache (SemanticAlias name target) = do + putSemanticNameCache name + putSemanticFactOccurrenceFingerprintCache target + +getSemanticAliasCache :: CacheGet SemanticAlias +getSemanticAliasCache = + SemanticAlias + <$> getSemanticNameCache + <*> getSemanticFactOccurrenceFingerprintCache + +putSemanticNameCache :: SemanticName -> CachePut +putSemanticNameCache (SemanticName name) = + putCacheText name + +getSemanticNameCache :: CacheGet SemanticName +getSemanticNameCache = + SemanticName <$> getCacheText + +putEligibility :: FactSearchEligibility -> CachePut +putEligibility = \case + SearchEligible -> putCacheTag 0x00 + SearchIneligible -> putCacheTag 0x01 + +getEligibility :: CacheGet FactSearchEligibility +getEligibility = + getCacheTag >>= \case + 0x00 -> pure SearchEligible + 0x01 -> pure SearchIneligible + tag -> + fail ("unknown fact-search eligibility tag " <> show tag) + +putModuleArtifactKeyFields :: ModuleArtifactKey -> CachePut +putModuleArtifactKeyFields + (ModuleArtifactKey owner parsed direct theory) = do + putModuleNameCache owner + putParsedModuleIdCache parsed + putCacheList putSemanticInterfaceIdCache direct + putTheoryIdCache theory + +putProofValidationKeyCache :: ProofValidationKey -> CachePut +putProofValidationKeyCache (ProofValidationKey digest) = + putCacheDigest digest + +getProofValidationKeyCache :: CacheGet ProofValidationKey +getProofValidationKeyCache = + ProofValidationKey <$> getCacheDigest + +putDeclarationValidationKeyCache + :: DeclarationValidationKey + -> CachePut +putDeclarationValidationKeyCache + (DeclarationValidationKey digest) = + putCacheDigest digest + +getDeclarationValidationKeyCache + :: CacheGet DeclarationValidationKey +getDeclarationValidationKeyCache = + DeclarationValidationKey <$> getCacheDigest + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go Set.empty + where + go _ [] = + Nothing + go seen (value : rest) + | value `Set.member` seen = + Just value + | otherwise = + go (Set.insert value seen) rest + +rejectDuplicate + :: Ord value + => (value -> error) + -> [value] + -> Either error () +rejectDuplicate makeError values = + maybe + (Right ()) + (Left . makeError) + (firstDuplicate values) + +strictlyIncreasing :: Ord value => [value] -> Bool +strictlyIncreasing values = + and + (zipWith (<) values (drop 1 values)) diff --git a/source/Felix/Checking/SetConstruction.hs b/source/Felix/Checking/SetConstruction.hs new file mode 100644 index 0000000..a5e1d80 --- /dev/null +++ b/source/Felix/Checking/SetConstruction.hs @@ -0,0 +1,1191 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked source semantics for named separation and functional replacement. +-- +-- A value of 'NamedSetConstruction' is the sole transient owner of the +-- source decomposition. Its smart constructors validate the complete +-- telescope and derive one canonical term. Local views, transparent content, +-- direct extensional facts, and cache-scoped descriptors all consume that +-- same checked value. +module Felix.Checking.SetConstruction + ( NamedSetConstruction + , checkedSeparationConstruction + , checkedFunctionalReplacementConstruction + , namedSetConstructionTerm + , namedSetConstructionLocalViews + , namedSetConstructionClosedBody + , SetConstructionFoundation + , setConstructionFoundation + , checkedFoundationSetConstruction + , NamedSetConstructionFact + , namedSetConstructionFactProposition + , namedSetConstructionFactDescriptor + , namedSetConstructionObjectFact + , CheckedRelationalSetConstruction + , checkedRelationalReplacementConstruction + , relationalSetConstructionTerm + , relationalSetConstructionFunctionality + , relationalSetConstructionClosedFunctionality + , relationalSetConstructionLocalViews + , relationalSetConstructionClosedBody + , RelationalSetConstructionFact + , relationalSetConstructionFactProposition + , relationalSetConstructionFactDescriptor + , relationalSetConstructionObjectFact + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Cache.Codec + ( CacheDigest + , encodeCache + , hashCacheFields + , putCanonicalTermCache + , putCoreTypeCache + ) + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The exact fixed rows used by the narrow derived extensionality schema. +-- Proof-local construction obtains these rows through the confined foundation +-- lookup; declaration authorization obtains them from 'CheckedFoundation'. +data SetConstructionFoundation = SetConstructionFoundation + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + +setConstructionFoundation + :: FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> SetConstructionFoundation +setConstructionFoundation = + SetConstructionFoundation + +checkedFoundationSetConstruction + :: CheckedFoundation + -> SetConstructionFoundation +checkedFoundationSetConstruction foundation = + SetConstructionFoundation + (foundationAxiomFrozen foundation FamilyUnionCharacteristic) + (foundationAxiomFrozen foundation SeparationCharacteristic) + (foundationAxiomFrozen foundation ReplacementCharacteristic) + (foundationAxiomFrozen foundation SetChooseWitness) + +data NamedSetConstruction global = NamedSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(NamedSetConstructionShape global) + !(BuiltSetConstruction global) + deriving stock (Eq) + +data NamedSetConstructionShape global + = SeparationShape + !(CanonicalTerm global) + !(CanonicalTerm global) + | FunctionalReplacementShape + !(NonEmpty (CanonicalTerm global)) + !(CanonicalTerm global) + !(Maybe (CanonicalTerm global)) + deriving stock (Eq) + +-- | The one canonical build result retained by the checked construction. +-- Characteristic applications describe the exact primitive rows used by the +-- derived theorem schema; the flattened body is the deterministic composition +-- of those rows for the source telescope. +data BuiltSetConstruction global = BuiltSetConstruction + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +data CheckedCharacteristicApplication global = + CheckedCharacteristicApplication + !CoreIntrinsicTag + ![CoreType] + !(CanonicalTerm global) + !(NonEmpty (CoreType, CanonicalTerm global)) + !(CanonicalTerm global) + deriving stock (Eq) + +-- | One checked relational replacement. Unlike the unconditional named +-- constructions above, its flattened membership theorem is available only +-- after the separately checked functionality proposition has authority. +-- This value owns the source telescope, the one canonical choice/replacement +-- term, and the exact primitive characteristic applications used by that +-- narrow derived schema. +data CheckedRelationalSetConstruction global = + CheckedRelationalSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +-- | Validate one source relational replacement. The relation is checked in +-- the nearest-first context @[range, domain] <> outer@, matching the source +-- binder order @y x A P@ without retaining source syntax. +checkedRelationalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (CheckedRelationalSetConstruction global) +checkedRelationalReplacementConstruction globalType domain relation = do + guard (scopedCoreType domain == TySet) + guard (scopedCoreType relation == TyProp) + let context = scopedCoreContext domain + guard (scopedCoreContext relation == TySet : TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm domain, scopedCoreTerm relation] + let domainTerm = scopedCoreTerm domain + relationTerm = scopedCoreTerm relation + domainPredicate = CLam TySet (logicalExists relationTerm) + restrictedDomain = applyIntrinsic2 Sep domainTerm domainPredicate + choiceFunction = + CLam TySet + (applyIntrinsic SetChoose (CLam TySet relationTerm)) + replacement = applyIntrinsic2 Repl restrictedDomain choiceFunction + functionality = relationalFunctionality domainTerm relationTerm + membership = relationalMembership domainTerm relationTerm + applications = + [ characteristicApplication + Sep context restrictedDomain + [ (TySet, domainTerm) + , (TyArrow TySet TyProp, domainPredicate) + ] + , characteristicApplication + Repl context replacement + [ (TySet, restrictedDomain) + , (TyArrow TySet TySet, choiceFunction) + ] + ] + construction = + CheckedRelationalSetConstruction + context globals domainTerm relationTerm replacement + functionality membership applications + _ <- checkedRelationalDerived construction context TySet replacement + _ <- checkedRelationalDerived construction context TyProp functionality + _ <- checkedRelationalDerived + construction (TySet : context) TyProp membership + pure construction + +-- | Check one source separation. The callback supplies the exact visible +-- type of every global used by its already checked components. +checkedSeparationConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (NamedSetConstruction global) +checkedSeparationConstruction globalType bound predicate = do + guard (scopedCoreType bound == TySet) + guard (scopedCoreType predicate == TyProp) + let context = scopedCoreContext bound + guard (scopedCoreContext predicate == TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm bound, scopedCoreTerm predicate] + finishConstruction + context + globals + (SeparationShape + (scopedCoreTerm bound) + (scopedCoreTerm predicate)) + +-- | Check source-ordered functional replacement once. Domain @i@ is checked +-- beneath exactly the preceding @i - 1@ source binders; the value and optional +-- condition are checked beneath the complete telescope. +checkedFunctionalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) + -> Maybe (NamedSetConstruction global) +checkedFunctionalReplacementConstruction globalType domains value condition = do + let domainList = NonEmpty.toList domains + firstDomain = NonEmpty.head domains + guard (scopedCoreType firstDomain == TySet) + let context = scopedCoreContext firstDomain + expectedDomainContexts = + [ replicate index TySet <> context + | index <- [0 .. length domainList - 1] + ] + valueContext = replicate (length domainList) TySet <> context + guard + (and + (zipWith + (\domain expected -> + scopedCoreType domain == TySet + && scopedCoreContext domain == expected) + domainList + expectedDomainContexts)) + guard + (scopedCoreType value == TySet + && scopedCoreContext value == valueContext) + traverse_ + (\predicate -> + guard + (scopedCoreType predicate == TyProp + && scopedCoreContext predicate == valueContext)) + condition + globals <- + captureGlobalTypes globalType + ( (scopedCoreTerm <$> domainList) + <> [scopedCoreTerm value] + <> maybeToList (scopedCoreTerm <$> condition) + ) + finishConstruction + context + globals + (FunctionalReplacementShape + (scopedCoreTerm <$> domains) + (scopedCoreTerm value) + (scopedCoreTerm <$> condition)) + +namedSetConstructionTerm + :: Ord global + => NamedSetConstruction global + -> ScopedCheckedCore global +namedSetConstructionTerm construction = + fromMaybe + (impossible "a checked construction lost its canonical term") + (checkedDerived + construction + (constructionContext construction) + TySet + (constructionCanonicalTerm construction)) + +-- | Introduce a fresh named set and return adjacent FOF extensional and exact +-- equation locals. Weakening is internal so construction-local binders and +-- source-domain order cannot drift at a caller. +namedSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +namedSetConstructionLocalViews foundation construction = do + weakened <- weakenConstruction TySet construction + let context = TySet : constructionContext construction + target = CBound 0 + extensional <- extensionalView foundation target weakened + equation <- checkedDerived weakened context TyProp + (CEq TySet target (constructionCanonicalTerm weakened)) + pure (extensional, equation) + +-- | Closed transparent content derived from the sole canonical construction +-- term. This retains the pre-existing object-content identity exactly. +namedSetConstructionClosedBody + :: Ord global + => NamedSetConstruction global + -> FrozenCheckedCore global +namedSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked construction did not close") + (freezeDerived construction closedType closedTerm) + where + context = constructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl (flip CLam) (constructionCanonicalTerm construction) context + +data NamedSetConstructionFact = NamedSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +namedSetConstructionFactProposition + :: NamedSetConstructionFact + -> FrozenCheckedCore ObjectId +namedSetConstructionFactProposition + (NamedSetConstructionFact proposition _descriptor) = + proposition + +namedSetConstructionFactDescriptor + :: NamedSetConstructionFact + -> CacheDigest +namedSetConstructionFactDescriptor + (NamedSetConstructionFact _proposition descriptor) = + descriptor + +-- | Derive the only proposition authorized by +-- @CheckedSetConstructionExtensionality@. This is a deliberately small +-- trusted theorem schema over the fixed foundation: every primitive +-- characteristic specialization is checked against its exact membership +-- formula before the source telescope is composed. The caller cannot supply +-- either the resulting proposition or its cache descriptor. +namedSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> NamedSetConstruction ObjectId + -> Maybe NamedSetConstructionFact +namedSetConstructionObjectFact foundation object construction = do + let context = constructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType object objectType (constructionGlobals construction) + let withObject = replaceConstructionGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + view <- extensionalView foundation target withObject + proposition <- freezeDerived withObject TyProp + (foldl + (flip CForall) + (scopedCoreTerm view) + context) + selfView <- extensionalView + foundation + (constructionCanonicalTerm construction) + construction + closedSelf <- freezeDerived construction TyProp + (foldl + (flip CForall) + (scopedCoreTerm selfView) + context) + let closedBody = namedSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (NamedSetConstructionFact proposition descriptor) + +relationalSetConstructionTerm + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionTerm construction = + fromMaybe + (impossible "a checked relational construction lost its canonical term") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TySet + (relationalConstructionCanonicalTerm construction)) + +-- | The exact source functionality obligation, still scoped by the outer +-- definition parameters. It is discharged independently before the derived +-- extensional theorem can be authorized. +relationalSetConstructionFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionFunctionality construction = + fromMaybe + (impossible "a checked relational construction lost functionality") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TyProp + (relationalConstructionFunctionalityTerm construction)) + +relationalSetConstructionClosedFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedFunctionality = + closeRelationalFunctionality + +-- | Introduce a fresh named set. Assuming the exact checked functionality +-- proposition, derive its two local views; no arbitrary proposition can +-- unlock the extensional view. The enclosing proof transaction owns the +-- corresponding authority. +relationalSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +relationalSetConstructionLocalViews foundation construction functionality = do + guard + (functionality + == relationalSetConstructionFunctionality construction) + validateRelationalSchema foundation construction + let context = TySet : relationalConstructionContext construction + target = CBound 0 + extensional <- checkedRelationalDerived construction context TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (CBound 1)) + (shiftCanonical 1 1 + (relationalConstructionMembershipTerm construction)))) + equation <- checkedRelationalDerived construction context TyProp + (CEq TySet + target + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + pure (extensional, equation) + +relationalSetConstructionClosedBody + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked relational construction did not close") + (freezeRelationalDerived construction closedType closedTerm) + where + context = relationalConstructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl + (flip CLam) + (relationalConstructionCanonicalTerm construction) + context + +data RelationalSetConstructionFact = RelationalSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +relationalSetConstructionFactProposition + :: RelationalSetConstructionFact + -> FrozenCheckedCore ObjectId +relationalSetConstructionFactProposition + (RelationalSetConstructionFact proposition _descriptor) = + proposition + +relationalSetConstructionFactDescriptor + :: RelationalSetConstructionFact + -> CacheDigest +relationalSetConstructionFactDescriptor + (RelationalSetConstructionFact _proposition descriptor) = + descriptor + +-- | The direct relational schema is a deterministic theorem over the fixed +-- separation, choice-witness, and replacement rows. The functionality fact +-- is a real strictly-earlier candidate: its exact proposition is checked here +-- and its authority safety is consumed separately by declaration admission. +relationalSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Maybe RelationalSetConstructionFact +relationalSetConstructionObjectFact + foundation object construction functionality = do + let expectedFunctionality = + closeRelationalFunctionality construction + guard (functionality == expectedFunctionality) + validateRelationalSchema foundation construction + let context = relationalConstructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType + object objectType (relationalConstructionGlobals construction) + let withObject = replaceRelationalGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + membership = relationalConstructionMembershipTerm withObject + proposition <- freezeRelationalDerived withObject TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + membership)) + context) + closedSelf <- freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member + (CBound 0) + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + (relationalConstructionMembershipTerm construction))) + context) + let closedBody = relationalSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-relational-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm expectedFunctionality) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (RelationalSetConstructionFact proposition descriptor) + +finishConstruction + :: Ord global + => [CoreType] + -> Map.Map global CoreType + -> NamedSetConstructionShape global + -> Maybe (NamedSetConstruction global) +finishConstruction context globals shape = do + let built = buildConstruction context shape + construction = NamedSetConstruction context globals shape built + _ <- checkedDerived construction context TySet + (builtConstructionTerm built) + _ <- checkedDerived construction (TySet : context) TyProp + (builtConstructionMembership built) + pure construction + +buildConstruction + :: Eq global + => [CoreType] + -> NamedSetConstructionShape global + -> BuiltSetConstruction global +buildConstruction context = \case + SeparationShape bound predicate -> + let function = CLam TySet predicate + term = applyIntrinsic2 Sep bound function + membership = + logicalAnd + (member (CBound 0) (shiftCanonical 1 0 bound)) + predicate + application = + characteristicApplication + Sep context term + [ (TySet, bound) + , (TyArrow TySet TyProp, function) + ] + in BuiltSetConstruction term membership [application] + FunctionalReplacementShape domains value condition -> + let (term, applications) = + buildFunctionalReplacement + context + domains + value + condition + domainList = NonEmpty.toList domains + binderCount = length domainList + terminal = + logicalConjunction + ( maybeToList + (shiftCanonical 1 (fromIntegral binderCount) + <$> condition) + <> [ CEq TySet + (CBound (fromIntegral binderCount)) + (shiftCanonical 1 + (fromIntegral binderCount) + value) + ] + ) + membership = + foldr + (\(depth, domain) rest -> + logicalExists + (logicalAnd + (member + (CBound 0) + (shiftCanonical 1 0 + (shiftCanonical 1 depth domain))) + rest)) + terminal + (zip [0 :: Natural ..] domainList) + in BuiltSetConstruction term membership applications + +-- The only functional-replacement term builder. Its result is reused by the +-- transparent body, exact-content matching, characteristic validation, local +-- views, and descriptor derivation. +buildFunctionalReplacement + :: [CoreType] + -> NonEmpty (CanonicalTerm global) + -> CanonicalTerm global + -> Maybe (CanonicalTerm global) + -> (CanonicalTerm global, [CheckedCharacteristicApplication global]) +buildFunctionalReplacement context (domain :| remaining) value condition = + case remaining of + [] -> + let predicate = CLam TySet <$> condition + filtered = maybe domain + (applyIntrinsic2 Sep domain) + predicate + function = CLam TySet value + replacement = applyIntrinsic2 Repl filtered function + separationApplications = case predicate of + Nothing -> [] + Just checkedPredicate -> + [ characteristicApplication + Sep context filtered + [ (TySet, domain) + , (TyArrow TySet TyProp, checkedPredicate) + ] + ] + replacementApplication = + characteristicApplication + Repl context replacement + [ (TySet, filtered) + , (TyArrow TySet TySet, function) + ] + in + ( replacement + , separationApplications <> [replacementApplication] + ) + next : rest -> + let (nested, nestedApplications) = + buildFunctionalReplacement + (TySet : context) + (next :| rest) + value + condition + function = CLam TySet nested + replacement = applyIntrinsic2 Repl domain function + union = applyIntrinsic FamilyUnion replacement + in + ( union + , characteristicApplication + Repl context replacement + [ (TySet, domain) + , (TyArrow TySet TySet, function) + ] + : characteristicApplication + FamilyUnion context union + [(TySet, replacement)] + : nestedApplications + ) + +characteristicApplication + :: CoreIntrinsicTag + -> [CoreType] + -> CanonicalTerm global + -> [(CoreType, CanonicalTerm global)] + -> CheckedCharacteristicApplication global +characteristicApplication intrinsic context target arguments = + CheckedCharacteristicApplication + intrinsic + context + target + (NonEmpty.fromList arguments) + (expectedCharacteristicBody intrinsic arguments) + +expectedCharacteristicBody + :: CoreIntrinsicTag + -> [(CoreType, CanonicalTerm global)] + -> CanonicalTerm global +expectedCharacteristicBody intrinsic arguments = + case (intrinsic, arguments) of + (Sep, [(_boundType, bound), (_predicateType, CLam TySet predicate)]) -> + logicalAnd + (member (CBound 0) (shiftCanonical 2 0 bound)) + (shiftCanonical 1 1 predicate) + (Repl, [(_domainType, domain), (_functionType, CLam TySet value)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 domain)) + (CEq TySet + (CBound 1) + (shiftCanonical 2 1 value))) + (FamilyUnion, [(_familyType, family)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 family)) + (member (CBound 1) (CBound 0))) + _ -> + impossible "invalid checked set-construction characteristic" + +extensionalView + :: Ord global + => SetConstructionFoundation + -> CanonicalTerm global + -> NamedSetConstruction global + -> Maybe (ScopedCheckedCore global) +extensionalView foundation target construction = do + traverse_ + (validateCharacteristic foundation construction) + (constructionApplications construction) + checkedDerived construction (constructionContext construction) TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + (constructionMembership construction))) + +-- Each primitive step is specialized from the actual fixed row, and the +-- complete normalized membership body is checked. The final flattened view +-- is then the deterministic composition of these exact primitive schemas. +validateCharacteristic + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet + (CEq TyProp actualMembership actualBody) + | actualMembership + == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +characteristicRow + :: SetConstructionFoundation + -> CoreIntrinsicTag + -> Maybe (FrozenCheckedCore Void) +characteristicRow + (SetConstructionFoundation + familyUnion separation replacement _setChoose) = + \case + FamilyUnion -> Just familyUnion + Sep -> Just separation + Repl -> Just replacement + _ -> Nothing + +validateRelationalSchema + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateRelationalSchema foundation construction = do + traverse_ + (validateRelationalCharacteristic foundation construction) + (relationalConstructionApplications construction) + validateChoiceWitness foundation construction + +validateRelationalCharacteristic + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateRelationalCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedRelationalDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedRelationalDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet (CEq TyProp actualMembership actualBody) + | actualMembership == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +validateChoiceWitness + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateChoiceWitness + (SetConstructionFoundation + _familyUnion _separation _replacement setChoose) + construction = do + let context = relationalConstructionContext construction + relation = relationalConstructionRelation construction + predicate = CLam TySet relation + choice = applyIntrinsic SetChoose predicate + witnessContext = TySet : TySet : context + target <- checkedRelationalDerived construction witnessContext TySet + (shiftCanonical 1 0 choice) + checkedPredicate <- + checkedRelationalDerived construction witnessContext + (TyArrow TySet TyProp) + (shiftCanonical 1 0 predicate) + witness <- checkedRelationalDerived construction witnessContext TySet + (CBound 0) + specialized <- + scopedCharacteristicDefinition + setChoose target (checkedPredicate :| [witness]) + guard + (scopedCoreContext specialized + == TySet : TySet : TySet : context) + guard + (scopedCoreTerm specialized + == CImp + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + +relationalFunctionality + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalFunctionality domain relation = + CForall TySet + (CImp + (member (CBound 0) (shiftCanonical 1 0 domain)) + (CForall TySet + (CForall TySet + (CImp + (logicalAnd + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + (CEq TySet (CBound 1) (CBound 0)))))) + +relationalMembership + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalMembership domain relation = + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 2 0 domain)) + (applyRelation + (shiftCanonical 2 0 + (CLam TySet (CLam TySet relation))) + (CBound 0) + (CBound 1))) + where + applyRelation function domainValue rangeValue = + case function of + CLam TySet domainBody -> + case instantiateCanonical domainValue domainBody of + CLam TySet rangeBody -> + instantiateCanonical rangeValue rangeBody + _ -> impossible "a checked relation lost its range binder" + _ -> impossible "a checked relation lost its domain binder" + +weakenConstruction + :: Ord global + => CoreType + -> NamedSetConstruction global + -> Maybe (NamedSetConstruction global) +weakenConstruction binderType construction = + finishConstruction + (binderType : constructionContext construction) + (constructionGlobals construction) + (case constructionShape construction of + SeparationShape bound predicate -> + SeparationShape + (shiftCanonical 1 0 bound) + (shiftCanonical 1 1 predicate) + FunctionalReplacementShape domains value condition -> + let domainList = NonEmpty.toList domains + weakenedDomains = + zipWith + (\depth domain -> shiftCanonical 1 depth domain) + [0..] + domainList + binderDepth = fromIntegral (length domainList) + in FunctionalReplacementShape + (NonEmpty.fromList weakenedDomains) + (shiftCanonical 1 binderDepth value) + (shiftCanonical 1 binderDepth <$> condition)) + +captureGlobalTypes + :: Ord global + => (global -> Maybe CoreType) + -> [CanonicalTerm global] + -> Maybe (Map.Map global CoreType) +captureGlobalTypes globalType terms = + Map.fromList <$> traverse capture + (Set.toAscList (foldMap canonicalTermGlobals terms)) + where + capture global = do + coreType <- globalType global + pure (global, coreType) + +insertGlobalType + :: Ord global + => global + -> CoreType + -> Map.Map global CoreType + -> Maybe (Map.Map global CoreType) +insertGlobalType global coreType globals = + case Map.lookup global globals of + Nothing -> Just (Map.insert global coreType globals) + Just existing + | existing == coreType -> Just globals + | otherwise -> Nothing + +checkedDerived + :: Ord global + => NamedSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` constructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeDerived + :: Ord global + => NamedSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeDerived construction expected term = do + checked <- checkedDerived construction [] expected term + closeScopedCore checked + +checkedRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedRelationalDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` relationalConstructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeRelationalDerived construction expected term = do + checked <- checkedRelationalDerived construction [] expected term + closeScopedCore checked + +closeRelationalFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +closeRelationalFunctionality construction = + fromMaybe + (impossible "a relational functionality proposition did not close") + (freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (relationalConstructionFunctionalityTerm construction) + (relationalConstructionContext construction))) + +replaceRelationalGlobals + :: Map.Map global CoreType + -> CheckedRelationalSetConstruction global + -> CheckedRelationalSetConstruction global +replaceRelationalGlobals globals + (CheckedRelationalSetConstruction + context _oldGlobals domain relation term functionality + membership applications) = + CheckedRelationalSetConstruction + context globals domain relation term functionality membership applications + +relationalConstructionContext + :: CheckedRelationalSetConstruction global + -> [CoreType] +relationalConstructionContext + (CheckedRelationalSetConstruction + context _globals _domain _relation _term _functionality + _membership _applications) = + context + +relationalConstructionGlobals + :: CheckedRelationalSetConstruction global + -> Map.Map global CoreType +relationalConstructionGlobals + (CheckedRelationalSetConstruction + _context globals _domain _relation _term _functionality + _membership _applications) = + globals + +relationalConstructionRelation + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionRelation + (CheckedRelationalSetConstruction + _context _globals _domain relation _term _functionality + _membership _applications) = + relation + +relationalConstructionCanonicalTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionCanonicalTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation term _functionality + _membership _applications) = + term + +relationalConstructionFunctionalityTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionFunctionalityTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term functionality + _membership _applications) = + functionality + +relationalConstructionMembershipTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionMembershipTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + membership _applications) = + membership + +relationalConstructionApplications + :: CheckedRelationalSetConstruction global + -> [CheckedCharacteristicApplication global] +relationalConstructionApplications + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + _membership applications) = + applications + +replaceConstructionGlobals + :: Map.Map global CoreType + -> NamedSetConstruction global + -> NamedSetConstruction global +replaceConstructionGlobals globals + (NamedSetConstruction context _oldGlobals shape built) = + NamedSetConstruction context globals shape built + +constructionContext :: NamedSetConstruction global -> [CoreType] +constructionContext (NamedSetConstruction context _globals _shape _built) = + context + +constructionGlobals + :: NamedSetConstruction global + -> Map.Map global CoreType +constructionGlobals (NamedSetConstruction _context globals _shape _built) = + globals + +constructionShape + :: NamedSetConstruction global + -> NamedSetConstructionShape global +constructionShape (NamedSetConstruction _context _globals shape _built) = + shape + +constructionCanonicalTerm + :: NamedSetConstruction global + -> CanonicalTerm global +constructionCanonicalTerm + (NamedSetConstruction _context _globals _shape built) = + builtConstructionTerm built + +constructionMembership + :: NamedSetConstruction global + -> CanonicalTerm global +constructionMembership + (NamedSetConstruction _context _globals _shape built) = + builtConstructionMembership built + +constructionApplications + :: NamedSetConstruction global + -> [CheckedCharacteristicApplication global] +constructionApplications + (NamedSetConstruction _context _globals _shape built) = + builtConstructionApplications built + +builtConstructionTerm + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionTerm (BuiltSetConstruction term _membership _applications) = + term + +builtConstructionMembership + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionMembership + (BuiltSetConstruction _term membership _applications) = + membership + +builtConstructionApplications + :: BuiltSetConstruction global + -> [CheckedCharacteristicApplication global] +builtConstructionApplications + (BuiltSetConstruction _term _membership applications) = + applications + +applyIntrinsic + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic intrinsic argument = + CApp (CIntrinsic intrinsic) argument + +applyIntrinsic2 + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic2 intrinsic first second = + CApp (CApp (CIntrinsic intrinsic) first) second + +member + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +member = applyIntrinsic2 Member + +logicalNot :: CanonicalTerm global -> CanonicalTerm global +logicalNot proposition = CImp proposition CFalsum + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + logicalNot (CImp left (logicalNot right)) + +logicalTruth :: CanonicalTerm global +logicalTruth = CImp CFalsum CFalsum + +logicalConjunction + :: Eq global + => [CanonicalTerm global] + -> CanonicalTerm global +logicalConjunction = + foldr combine logicalTruth + where + combine proposition remaining + | proposition == logicalTruth = remaining + | remaining == logicalTruth = proposition + | otherwise = logicalAnd proposition remaining + +logicalExists :: CanonicalTerm global -> CanonicalTerm global +logicalExists body = + logicalNot (CForall TySet (logicalNot body)) diff --git a/source/Felix/Checking/Typed/Inductive.hs b/source/Felix/Checking/Typed/Inductive.hs new file mode 100644 index 0000000..4094083 --- /dev/null +++ b/source/Felix/Checking/Typed/Inductive.hs @@ -0,0 +1,4732 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Direct checked lowering of the current one-carrier set-valued inductive +-- declaration. +module Felix.Checking.Typed.Inductive + ( DirectInductive(..) + , DirectInductiveClause(..) + , DirectInductiveCondition(..) + , RecursiveCarrierContext + , RecursiveCarrierContextError(..) + , prepareRecursiveCarrierContext + , directRecursiveCarrierContext + , recursiveCarrierContextSymbols + , SourceGlobal(..) + , PreparedTypedInductive + , typedInductiveCarrierType + , typedInductiveCarrierBody + , typedInductiveGuardTargets + , PreparedTypedInductiveMonotonicity + , typedInductiveMonotonicities + , typedInductiveMonotonicityLocation + , typedInductiveMonotonicityTarget + , typedInductiveContextInventory + , PreparedTypedInductiveFact + , typedInductiveFacts + , typedInductiveFactMarker + , typedInductiveFactTarget + , typedInductiveFactRules + , typedInductiveFactRequiresMonotonicities + , typedInductiveFactDerivation + , prepareTypedClosedTerm + , prepareTypedClosedFormula + , prepareTypedInductive + , TypedInductiveError(..) + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Proof +import Felix.Report.Location (Location) +import Felix.Syntax.Internal + +import Control.Monad ((<=<), foldM) +import Data.Bifunctor (first) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Bound.Scope (fromScope, instantiate) +import Bound.Var (Var(..)) + + +data DirectInductive = DirectInductive + { directInductiveParams :: ![VarSymbol] + , directInductiveDomain :: !Term + , directInductiveClauses + :: !(NonEmpty DirectInductiveClause) + } + +data DirectInductiveClause = DirectInductiveClause + { directClauseVariables :: ![VarSymbol] + , directClauseConditions + :: ![DirectInductiveCondition] + , directClauseResult :: !Term + } + +data DirectInductiveCondition + = DirectSideCondition !Formula + | DirectRecursiveCondition !Term !RecursiveCarrierContext + +data RecursiveCarrierVariable + = RecursiveCarrierHole + | RecursiveCarrierSourceVariable !VarSymbol + deriving stock (Show, Eq, Ord) + +-- | A validated, capture-free one-hole carrier context in the same +-- first-order set-term fragment lowered by this module. The source carrier +-- application itself has been replaced, so the inductive symbol cannot +-- survive inside this value. +data RecursiveCarrierContext = RecursiveCarrierContext + !Location + !(ExprOf RecursiveCarrierVariable) + deriving stock (Show, Eq, Ord) + +data RecursiveCarrierContextError + = RecursiveCarrierWrongArguments !Location + | RecursiveCarrierUnsupportedContext !Location + deriving stock (Show, Eq) + +prepareRecursiveCarrierContext + :: FunctionSymbol + -> [VarSymbol] + -> Term + -> Either RecursiveCarrierContextError RecursiveCarrierContext +prepareRecursiveCarrierContext carrier parameters source = + RecursiveCarrierContext (exprLocation source) <$> go source + where + carrierSymbol = SymbolMixfix carrier + + go = \case + TermVar variable -> + pure + (TermVar + (RecursiveCarrierSourceVariable variable)) + TermSymbol location symbol arguments + | symbol == carrierSymbol -> + if sameCarrierArguments arguments parameters + then pure (TermVar RecursiveCarrierHole) + else Left (RecursiveCarrierWrongArguments location) + | otherwise -> + TermSymbol location symbol <$> traverse go arguments + unsupported -> + Left + (RecursiveCarrierUnsupportedContext + (exprLocation unsupported)) + + sameCarrierArguments arguments variables = + length arguments == length variables + && and + (zipWith + (\argument variable -> + argument == TermVar variable) + arguments + variables) + +recursiveCarrierContextSymbols + :: RecursiveCarrierContext + -> Set Symbol +recursiveCarrierContextSymbols + (RecursiveCarrierContext _location source) = + mentionedSymbols source + +directRecursiveCarrierContext :: Location -> RecursiveCarrierContext +directRecursiveCarrierContext location = + RecursiveCarrierContext location (TermVar RecursiveCarrierHole) + +data SourceGlobal global = SourceGlobal + !global + !(Maybe (FrozenCheckedCore global)) + +data InductiveGlobal global where + InductiveGlobal + :: Eq global + => !global + -> !CoreType + -> InductiveGlobal global + +instance Eq (InductiveGlobal global) where + InductiveGlobal left _leftType + == InductiveGlobal right _rightType = + left == right + +inductiveGlobalIdentity :: InductiveGlobal global -> global +inductiveGlobalIdentity (InductiveGlobal identity _coreType) = + identity + +inductiveGlobalType :: InductiveGlobal global -> CoreType +inductiveGlobalType (InductiveGlobal _identity coreType) = + coreType + +data PreparedTypedInductive global = PreparedTypedInductive + !CoreType + !(FrozenCheckedCore global) + !(Vector (FrozenCheckedCore global)) + !(Vector (PreparedTypedInductiveMonotonicity global)) + !(Vector (FrozenCheckedCore global)) + !(NonEmpty (PreparedTypedInductiveFact global)) + +data PreparedTypedInductiveMonotonicity global = + PreparedTypedInductiveMonotonicity + !Location + !(FrozenCheckedCore global) + +typedInductiveMonotonicities + :: PreparedTypedInductive global + -> Vector (PreparedTypedInductiveMonotonicity global) +typedInductiveMonotonicities + (PreparedTypedInductive + _carrierType + _body + _guards + monotonicities + _contexts + _facts) = + monotonicities + +typedInductiveMonotonicityLocation + :: PreparedTypedInductiveMonotonicity global + -> Location +typedInductiveMonotonicityLocation + (PreparedTypedInductiveMonotonicity location _target) = + location + +typedInductiveMonotonicityTarget + :: PreparedTypedInductiveMonotonicity global + -> FrozenCheckedCore global +typedInductiveMonotonicityTarget + (PreparedTypedInductiveMonotonicity _location target) = + target + +typedInductiveContextInventory + :: PreparedTypedInductive global + -> Vector (FrozenCheckedCore global) +typedInductiveContextInventory + (PreparedTypedInductive + _carrierType _body _guards _monotonicities contexts _facts) = + contexts + +data CheckedRecursiveCarrierContext global = + CheckedRecursiveCarrierContext + ![VarSymbol] + !(FrozenCheckedCore global) + +data PreparedInductiveSource global = PreparedInductiveSource + { preparedInductiveParams :: ![VarSymbol] + , preparedInductiveDomain :: !Term + , preparedInductiveClauses + :: !(NonEmpty (PreparedInductiveClause global)) + } + +data PreparedInductiveClause global = PreparedInductiveClause + { preparedClauseVariables :: ![VarSymbol] + , preparedClauseConditions + :: ![PreparedInductiveCondition global] + , preparedClauseResult :: !Term + } + +data PreparedInductiveCondition global + = PreparedSideCondition !Formula + | PreparedDirectRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + | PreparedNestedRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + !ImportIx + !(FrozenCheckedCore global) + +data PreparedInductiveGuard global + = PreparedFoundationGuard !FoundationAxiomTag + | PreparedImportedGuard + !ImportIx + !(FrozenCheckedCore global) + +typedInductiveCarrierType + :: PreparedTypedInductive global + -> CoreType +typedInductiveCarrierType + (PreparedTypedInductive + carrierType + _body + _guards + _monotonicities + _contexts + _facts) = + carrierType + +typedInductiveCarrierBody + :: PreparedTypedInductive global + -> FrozenCheckedCore global +typedInductiveCarrierBody + (PreparedTypedInductive + _carrierType + body + _guards + _monotonicities + _contexts + _facts) = + body + +typedInductiveGuardTargets + :: PreparedTypedInductive global + -> Vector (FrozenCheckedCore global) +typedInductiveGuardTargets + (PreparedTypedInductive + _carrierType + _body + guards + _monotonicities + _contexts + _facts) = + guards + +newtype PreparedTypedInductiveFact global = + PreparedTypedInductiveFact + ( Marker + , FrozenCheckedCore global + , NonEmpty KernelRuleTag + , Bool + , KernelDerivation global + ) + +typedInductiveFacts + :: PreparedTypedInductive global + -> NonEmpty (PreparedTypedInductiveFact global) +typedInductiveFacts + (PreparedTypedInductive + _carrierType + _body + _guards + _monotonicities + _contexts + facts) = + facts + +typedInductiveFactMarker + :: PreparedTypedInductiveFact global + -> Marker +typedInductiveFactMarker + (PreparedTypedInductiveFact + (marker, _target, _rule, _monotonicities, _derivation)) = + marker + +typedInductiveFactTarget + :: PreparedTypedInductiveFact global + -> FrozenCheckedCore global +typedInductiveFactTarget + (PreparedTypedInductiveFact + (_marker, target, _rule, _monotonicities, _derivation)) = + target + +typedInductiveFactRules + :: PreparedTypedInductiveFact global + -> NonEmpty KernelRuleTag +typedInductiveFactRules + (PreparedTypedInductiveFact + (_marker, _target, rules, _monotonicities, _derivation)) = + rules + +typedInductiveFactRequiresMonotonicities + :: PreparedTypedInductiveFact global + -> Bool +typedInductiveFactRequiresMonotonicities + (PreparedTypedInductiveFact + (_marker, _target, _rules, required, _derivation)) = + required + +typedInductiveFactDerivation + :: PreparedTypedInductiveFact global + -> KernelDerivation global +typedInductiveFactDerivation + (PreparedTypedInductiveFact + (_marker, _target, _rule, _monotonicities, derivation)) = + derivation + +-- | Lower one closed source formula through the exact primitive/global +-- policy used by the direct-inductive compiler. +prepareTypedClosedFormula + :: Eq global + => (global -> CoreType) + -> (Symbol -> Maybe (SourceGlobal global)) + -> Formula + -> Either TypedInductiveError (FrozenCheckedCore global) +prepareTypedClosedFormula globalType resolveGlobal formula = do + term <- + lowerFormulaWith + True + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + emptyEnvironment + formula + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + term) + pure (mapFrozenGlobals inductiveGlobalIdentity checked) + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +prepareTypedClosedTerm + :: Eq global + => (global -> CoreType) + -> (Symbol -> Maybe (SourceGlobal global)) + -> Term + -> Either TypedInductiveError (FrozenCheckedCore global) +prepareTypedClosedTerm globalType resolveGlobal term = do + canonical <- + lowerTerm + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + emptyEnvironment + term + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + canonical) + pure (mapFrozenGlobals inductiveGlobalIdentity checked) + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +data TypedInductiveError + = TypedInductiveDuplicateBinder !VarSymbol + | TypedInductiveUnknownLocal !VarSymbol + | TypedInductiveUnsupportedExpression !Text + | TypedInductiveCoreError !CoreCheckError + | TypedInductiveProofError !KernelProofBuildError + | TypedInductiveProofRemainedOpen + | TypedInductiveFactPreparationFailed + !Marker + !TypedInductiveError + | TypedInductivePreparationContext + !Text + !TypedInductiveError + deriving stock (Show, Eq) + +data InductiveEnvironment = InductiveEnvironment + !(Map VarSymbol Natural) + +emptyEnvironment :: InductiveEnvironment +emptyEnvironment = + InductiveEnvironment Map.empty + +extendEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +extendEnvironment variable + (InductiveEnvironment variables) + | Map.member variable variables = + Left + (TypedInductiveDuplicateBinder + variable) + | otherwise = + Right + (InductiveEnvironment + (Map.insert variable 0 + (succ <$> variables))) + +lookupEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lookupEnvironment variable + (InductiveEnvironment variables) = + maybe + (Left + (TypedInductiveUnknownLocal + variable)) + (Right . CBound) + (Map.lookup variable variables) + +prepareTypedInductive + :: Eq global + => (global -> CoreType) + -> CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal global)) + -> Marker + -> DirectInductive + -> Either + TypedInductiveError + (PreparedTypedInductive global) +prepareTypedInductive + globalType + foundation + resolveGlobal + marker + inductive = + mapPreparedTypedInductive inductiveGlobalIdentity + <$> prepareTypedInductiveInternal + foundation + (fmap (mapSourceGlobal wrapGlobal) . resolveGlobal) + marker + inductive + where + wrapGlobal identity = + InductiveGlobal identity (globalType identity) + +prepareTypedInductiveInternal + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> DirectInductive + -> Either + TypedInductiveError + (PreparedTypedInductive (InductiveGlobal global)) +prepareTypedInductiveInternal + foundation + resolveGlobal + marker + inductive = do + guards <- + traverse + (prepareDirectGuardTarget + resolveGlobal + inductive) + (directInductiveClauses + inductive) + let preparedGuards = + assignGuardSources foundation + (NonEmpty.toList guards) + nextImport = + fromIntegral + (length + [ () + | PreparedImportedGuard{} <- preparedGuards + ]) + (preparedSource, monotonicities, contexts) <- + prepareInductiveSource + resolveGlobal + nextImport + inductive + carrierBody <- + prepareCarrierBody + resolveGlobal + preparedSource + facts <- + prepareFacts + foundation + resolveGlobal + marker + preparedSource + (case preparedGuards of + firstGuard : remainingGuards -> + firstGuard :| remainingGuards + [] -> + impossible + "a nonempty inductive declaration produced no guards") + pure + (PreparedTypedInductive + carrierType + carrierBody + (Vector.fromList + [ target + | PreparedImportedGuard + _index target <- preparedGuards + ]) + (Vector.fromList monotonicities) + (Vector.fromList contexts) + facts) + where + carrierType = + foldr + TyArrow + TySet + (TySet + <$ directInductiveParams + inductive) + +mapSourceGlobal + :: (left -> right) + -> SourceGlobal left + -> SourceGlobal right +mapSourceGlobal transform (SourceGlobal identity body) = + SourceGlobal + (transform identity) + (mapFrozenGlobals transform <$> body) + +mapPreparedTypedInductive + :: (left -> right) + -> PreparedTypedInductive left + -> PreparedTypedInductive right +mapPreparedTypedInductive transform + (PreparedTypedInductive + carrierType body guards monotonicities contexts facts) = + PreparedTypedInductive + carrierType + (mapFrozenGlobals transform body) + (mapFrozenGlobals transform <$> guards) + (mapMonotonicity transform <$> monotonicities) + (mapFrozenGlobals transform <$> contexts) + (mapPreparedFact transform <$> facts) + where + mapMonotonicity mapGlobal + (PreparedTypedInductiveMonotonicity location target) = + PreparedTypedInductiveMonotonicity + location + (mapFrozenGlobals mapGlobal target) + + mapPreparedFact mapGlobal + (PreparedTypedInductiveFact + (marker, target, rule, requiresMonotonicities, derivation)) = + PreparedTypedInductiveFact + ( marker + , mapFrozenGlobals mapGlobal target + , rule + , requiresMonotonicities + , mapKernelDerivationGlobals mapGlobal derivation + ) + +data MonotonicityInventory global = MonotonicityInventory + ![(FrozenCheckedCore global, ImportIx)] + !Natural + ![PreparedTypedInductiveMonotonicity global] + ![FrozenCheckedCore global] + +prepareInductiveSource + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Natural + -> DirectInductive + -> Either + TypedInductiveError + ( PreparedInductiveSource (InductiveGlobal global) + , [PreparedTypedInductiveMonotonicity (InductiveGlobal global)] + , [FrozenCheckedCore (InductiveGlobal global)] + ) +prepareInductiveSource resolveGlobal firstImport inductive = do + (final, clauses) <- + prepareClauses + (MonotonicityInventory [] firstImport [] []) + (NonEmpty.toList (directInductiveClauses inductive)) + let MonotonicityInventory + _targets _next monotonicities contexts = final + pure + ( PreparedInductiveSource + (directInductiveParams inductive) + (directInductiveDomain inductive) + (NonEmpty.fromList clauses) + , reverse monotonicities + , reverse contexts + ) + where + variablesFor clause = + directInductiveParams inductive + <> directClauseVariables clause + + prepareClauses inventory = \case + [] -> pure (inventory, []) + clause : remaining -> do + (afterClause, preparedClause) <- + prepareClause inventory clause + (final, preparedRemaining) <- + prepareClauses afterClause remaining + pure (final, preparedClause : preparedRemaining) + + prepareClause inventory clause = do + (next, conditions) <- + prepareConditions inventory clause + (directClauseConditions clause) + pure + ( next + , PreparedInductiveClause + (directClauseVariables clause) + conditions + (directClauseResult clause) + ) + + prepareConditions inventory _clause [] = + pure (inventory, []) + prepareConditions inventory clause (condition : remaining) = do + (next, prepared) <- + prepareCondition inventory clause condition + (final, preparedRemaining) <- + prepareConditions next clause remaining + pure (final, prepared : preparedRemaining) + + prepareCondition inventory _clause (DirectSideCondition formula) = + pure (inventory, PreparedSideCondition formula) + prepareCondition + (MonotonicityInventory targets next facts contexts) + clause + (DirectRecursiveCondition recursiveTerm sourceContext) = do + checkedContext <- + prepareRecursiveCarrierTemplate + resolveGlobal + (variablesFor clause) + sourceContext + let template = checkedRecursiveCarrierTemplate checkedContext + withContext currentFacts = + MonotonicityInventory + targets next currentFacts (template : contexts) + if recursiveCarrierContextIsDirect sourceContext + then pure + ( withContext facts + , PreparedDirectRecursiveCondition + recursiveTerm checkedContext + ) + else do + target <- + prepareRecursiveCarrierMonotonicityTarget + checkedContext + let RecursiveCarrierContext location _source = sourceContext + case List.lookup target targets of + Just index -> + pure + ( MonotonicityInventory + targets next facts (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + Nothing -> + let index = importIx next + in pure + ( MonotonicityInventory + ((target, index) : targets) + (next + 1) + (PreparedTypedInductiveMonotonicity + location target : facts) + (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + +checkedRecursiveCarrierTemplate + :: CheckedRecursiveCarrierContext global + -> FrozenCheckedCore global +checkedRecursiveCarrierTemplate + (CheckedRecursiveCarrierContext _variables template) = + template + +recursiveCarrierContextIsDirect :: RecursiveCarrierContext -> Bool +recursiveCarrierContextIsDirect + (RecursiveCarrierContext _location source) = + source == TermVar RecursiveCarrierHole + +prepareRecursiveCarrierTemplate + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> [VarSymbol] + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CheckedRecursiveCarrierContext (InductiveGlobal global)) +prepareRecursiveCarrierTemplate resolveGlobal variables context = do + body <- + buildUnderVariables emptyEnvironment variables \environment -> do + underHole <- shiftEnvironment environment + lowerRecursiveCarrierContext + resolveGlobal underHole (CBound 0) context + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + -- Transparent expansion may leave beta redexes. Freeze one + -- normalized template so routing, generated laws, and kernel + -- transport all see the same first-order shape. + (betaNormalizeCanonical + (closeLambdas (length variables + 1) body))) + pure (CheckedRecursiveCarrierContext variables checked) + +prepareRecursiveCarrierMonotonicityTarget + :: CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareRecursiveCarrierMonotonicityTarget + context@(CheckedRecursiveCarrierContext variables _template) = do + target <- + buildUnderVariables emptyEnvironment variables \environment -> do + underSets <- shiftEnvironment =<< shiftEnvironment environment + left <- + instantiateRecursiveCarrier + underSets (CBound 1) context + right <- + instantiateRecursiveCarrier + underSets (CBound 0) context + pure + (CImp + (subsetTerm (CBound 1) (CBound 0)) + (subsetTerm left right)) + freezeClosedTarget + (closeForalls (length variables + 2) target) + +instantiateRecursiveCarrier + :: InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +instantiateRecursiveCarrier environment replacement + context@(CheckedRecursiveCarrierContext variables _template) = do + arguments <- traverse (`lookupEnvironment` environment) variables + foldM instantiateLambda + (frozenCoreTerm (checkedRecursiveCarrierTemplate context)) + (arguments <> [replacement]) + where + instantiateLambda term argument = + case term of + CLam TySet body -> + pure (instantiateCanonical argument body) + _ -> + Left + (TypedInductiveUnsupportedExpression + "a checked recursive carrier context lost its set telescope") + +lowerRecursiveCarrierContext + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerRecursiveCarrierContext resolveGlobal environment replacement + (RecursiveCarrierContext _location source) = + go source + where + go = \case + TermVar RecursiveCarrierHole -> + pure replacement + TermVar (RecursiveCarrierSourceVariable variable) -> + lookupEnvironment variable environment + TermSymbol _location symbol arguments -> do + lowered <- traverse go arguments + lowerApplicationTerms resolveGlobal symbol lowered + _ -> + Left + (TypedInductiveUnsupportedExpression + "a validated recursive carrier context left the supported set-term fragment") + +prepareCarrierBody + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareCarrierBody resolveGlobal inductive = do + body <- + buildUnderVariables + emptyEnvironment + (preparedInductiveParams + inductive) + (\env -> fixedPointTerm + resolveGlobal + inductive + env) + let closed = + closeLambdas + (length + (preparedInductiveParams + inductive)) + body + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + closed) + pure checked + +prepareDirectGuardTarget + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> DirectInductive + -> DirectInductiveClause + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareDirectGuardTarget + resolveGlobal + inductive + clause = do + target <- + buildUnderVariables + emptyEnvironment + (directInductiveParams inductive + <> directClauseVariables clause) + (\environment -> do + domain <- + lowerTerm + resolveGlobal + environment + (directInductiveDomain + inductive) + conditions <- + traverse + (directConditionTerm + resolveGlobal + environment + domain) + (directClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + environment + (directClauseResult + clause) + pure + (impliesIfNeeded + (conjunctionList + conditions) + (memberTerm + result + domain))) + freezeClosedTarget + (closeForalls + (length + (directInductiveParams inductive + <> directClauseVariables clause)) + target) + +assignGuardSources + :: CheckedFoundation + -> [FrozenCheckedCore (InductiveGlobal global)] + -> [PreparedInductiveGuard (InductiveGlobal global)] +assignGuardSources foundation = + snd . List.mapAccumL assign 0 + where + assign nextImport target = + case matchingFoundationAxiom target of + Just tag -> + (nextImport, PreparedFoundationGuard tag) + Nothing -> + ( nextImport + 1 + , PreparedImportedGuard + (importIx nextImport) + target + ) + + matchingFoundationAxiom target = + List.find + (\tag -> + mapFrozenGlobals + absurd + (foundationAxiomFrozen + foundation + tag) + == target) + [minBound .. maxBound] + +prepareFacts + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> NonEmpty (PreparedInductiveGuard (InductiveGlobal global)) + -> Either + TypedInductiveError + (NonEmpty (PreparedTypedInductiveFact (InductiveGlobal global))) +prepareFacts + foundation + resolveGlobal + marker + inductive + guards = do + introductions <- + sequence + (NonEmpty.zipWith + (\clauseIndex pair -> + first + (TypedInductiveFactPreparationFailed + (introMarker + marker + (clauseIndex + 1))) + (prepareIntroductionFact + foundation + resolveGlobal + marker + inductive + clauseIndex + pair)) + (0 :| [1 ..]) + (NonEmpty.zip + guards + (preparedInductiveClauses + inductive))) + domainSubset <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "dom_subset")) + (prepareDomainSubsetFact + foundation + resolveGlobal + marker + inductive) + cases <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "cases")) + (prepareCasesFact + foundation + resolveGlobal + marker + inductive) + induction <- + first + (TypedInductiveFactPreparationFailed + (derivedMarker marker "induct")) + (prepareInductionFact + foundation + resolveGlobal + marker + inductive) + pure + (introductions + <> (domainSubset + :| [cases, induction])) + +prepareIntroductionFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Natural + -> (PreparedInductiveGuard (InductiveGlobal global), PreparedInductiveClause (InductiveGlobal global)) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareIntroductionFact + foundation + resolveGlobal + marker + inductive + clauseIndex + (guardSource, clause) = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams inductive + <> preparedClauseVariables clause) + (\context environment -> do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + fixedPoint <- + checkedTerm context + =<< fixedPointTerm + resolveGlobal + inductive + environment + predicate <- + checkedTerm context + =<< operatorPredicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + appliedOperatorSet <- + checkedTerm context + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm + fixedPoint)) + conditions <- + traverse + (checkedTerm context <=< + conditionTerm + resolveGlobal + environment + (scopedCoreTerm + fixedPoint)) + (preparedClauseConditions + clause) + result <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedClauseResult + clause) + let conditionTerms = + scopedCoreTerm <$> conditions + first + (TypedInductivePreparationContext + "introduction premises") + (provePremises + context + conditionTerms + (\premiseProofs -> do + guardProof <- + preparedGuardProof + context + guardSource + specializedGuard <- + first + (TypedInductivePreparationContext + "introduction guard specialization") + (eliminateWrittenForalls + context + environment + (preparedInductiveParams + inductive + <> preparedClauseVariables + clause) + guardProof) + guardPremiseProofs <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure premiseProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + bound <- + first + TypedInductiveProofError + (setLfpBoundProof + context + domain + operator) + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + implication <- + first + TypedInductiveProofError + (forallEliminationProof + context + bound + recursiveElement) + first + TypedInductiveProofError + (implicationEliminationProof + context + implication + premiseProof) + nested@PreparedNestedRecursiveCondition{} -> do + bound <- + first TypedInductiveProofError + (setLfpBoundProof + context + domain + operator) + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm + nested) + transportNestedRecursiveMembership + context + environment + nested + fixedPoint + domain + recursiveElement + bound + premiseProof + | (condition, premiseProof) <- + zip + (preparedClauseConditions + clause) + premiseProofs + ] + inDomain <- + case conjunctionList + conditionTerms of + Nothing -> + pure specializedGuard + Just _condition -> do + conjunction <- + conjunctionIntroductionList + context + guardPremiseProofs + first + (TypedInductivePreparationContext + "introduction guard application") + (first TypedInductiveProofError + (implicationEliminationProof + context + specializedGuard + conjunction)) + equality <- + first TypedInductiveProofError + (equalityReflexivityProof + context + result) + clauseProof <- + conjunctionIntroductionList + context + (premiseProofs + <> [equality]) + clauseExists <- + first + (TypedInductivePreparationContext + "introduction witnesses") + (introduceClauseWitnesses + resolveGlobal + inductive + clause + context + environment + (scopedCoreTerm + fixedPoint) + result + clauseProof) + alternatives <- + clauseFormulaTerms + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + (scopedCoreTerm + result) + disjunction <- + first + (TypedInductivePreparationContext + "introduction disjunction") + (injectDisjunction + context + clauseIndex + alternatives + clauseExists) + inOperator <- + first + (TypedInductivePreparationContext + "introduction separation") + (separationBackward + context + domain + predicate + result + inDomain + disjunction) + inAppliedTarget <- + checkedTerm context + (memberTerm + (scopedCoreTerm + result) + (scopedCoreTerm + appliedOperatorSet)) + inAppliedOperator <- + first TypedInductiveProofError + (conversionProof + context + inOperator + inAppliedTarget) + monotone <- + first + (TypedInductivePreparationContext + "introduction bounded monotonicity") + (proveBoundedMonotonicity + foundation + resolveGlobal + inductive + context + environment) + fixed <- + first TypedInductiveProofError + (setLfpFixedProof + context + domain + operator + monotone) + reversedFixed <- + first + (TypedInductivePreparationContext + "introduction fixed-point symmetry") + (first TypedInductiveProofError + (equalityReverseProof + context + fixed)) + first + (TypedInductivePreparationContext + "introduction fixed-point transport") + (transportMembership + context + result + reversedFixed + inAppliedOperator)))) + preparedFact + (introMarker + marker + (clauseIndex + 1)) + (if any isRecursiveCondition + (preparedClauseConditions clause) + then SetLfpBound :| [SetLfpFixed] + else SetLfpFixed :| []) + True + proof + where + isRecursiveCondition = \case + PreparedDirectRecursiveCondition{} -> True + PreparedNestedRecursiveCondition{} -> True + PreparedSideCondition{} -> False + +preparedGuardProof + :: ProofContext (InductiveGlobal global) + -> PreparedInductiveGuard (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +preparedGuardProof context = \case + PreparedFoundationGuard tag -> + first TypedInductiveProofError + (foundationProof context tag) + PreparedImportedGuard index target -> + first TypedInductiveProofError + (importedProof context index target) + +prepareDomainSubsetFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareDomainSubsetFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\context environment -> do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + first TypedInductiveProofError + (setLfpBoundProof + context + domain + operator)) + preparedFact + (derivedMarker marker "dom_subset") + (SetLfpBound :| []) + False + proof + +prepareCasesFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareCasesFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\parameterContext parameterEnvironment -> + forallIntroductionTyped + parameterContext + TySet + (\context result -> do + environment <- + shiftEnvironment + parameterEnvironment + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + fixedPoint <- + checkedTerm context + =<< fixedPointTerm + resolveGlobal + inductive + environment + predicate <- + checkedTerm context + =<< operatorPredicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + explicitOperatorSet <- + checkedTerm context + =<< separationSetAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + member <- + checkedTerm context + (memberTerm + (scopedCoreTerm result) + (scopedCoreTerm + fixedPoint)) + implicationIntroductionTyped + context + member + (\withMember memberProof -> do + monotone <- + proveBoundedMonotonicity + foundation + resolveGlobal + inductive + withMember + environment + fixed <- + first TypedInductiveProofError + (setLfpFixedProof + withMember + domain + operator + monotone) + inOperator <- + transportMembership + withMember + result + fixed + memberProof + explicitMembership <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + result) + (scopedCoreTerm + explicitOperatorSet)) + inSeparation <- + first TypedInductiveProofError + (conversionProof + withMember + inOperator + explicitMembership) + separation <- + separationForward + withMember + domain + predicate + result + inSeparation + predicateResult <- + predicateAt + resolveGlobal + inductive + environment + (scopedCoreTerm + fixedPoint) + (scopedCoreTerm + result) + predicateProof <- + first TypedInductiveProofError + (conjunctionRightProof + withMember + (memberTerm + (scopedCoreTerm result) + (scopedCoreTerm + domain)) + (CApp + (scopedCoreTerm + predicate) + (scopedCoreTerm + result)) + separation) + predicateTarget <- + checkedTerm + withMember + predicateResult + first TypedInductiveProofError + (conversionProof + withMember + predicateProof + predicateTarget)))) + preparedFact + (derivedMarker marker "cases") + (SetLfpFixed :| []) + True + proof + +prepareInductionFact + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Marker + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +prepareInductionFact + foundation + resolveGlobal + marker + inductive = do + proof <- + proveUnderVariables + (rootProofContext + foundation + (Just . inductiveGlobalType)) + emptyEnvironment + (preparedInductiveParams + inductive) + (\parameterContext parameterEnvironment -> + forallIntroductionTyped + parameterContext + TySet + (\subsetContext subset -> do + environment <- + shiftEnvironment + parameterEnvironment + closures <- + closureTerms + resolveGlobal + inductive + environment + (scopedCoreTerm subset) + closureConjunction <- + checkedTerm subsetContext + (fromMaybe + (CImp CFalsum CFalsum) + (conjunctionList + closures)) + implicationIntroductionTyped + subsetContext + closureConjunction + (\withClosures closuresProof -> do + fixedPoint <- + checkedTerm withClosures + =<< fixedPointTerm + resolveGlobal + inductive + environment + proveSubset + withClosures + fixedPoint + subset + (\elementContext element memberProof -> do + elementEnvironment <- + shiftEnvironment environment + domain <- + checkedTerm elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm elementContext + =<< operatorTerm + resolveGlobal + inductive + elementEnvironment + fixedPointAtElement <- + checkedTerm elementContext + =<< fixedPointTerm + resolveGlobal + inductive + elementEnvironment + subsetAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + predicate <- + membershipPredicate + elementContext + subsetAtElement + monotone <- + first + (TypedInductivePreparationContext + "induction bounded monotonicity") + (proveBoundedMonotonicity + foundation + resolveGlobal + inductive + elementContext + elementEnvironment) + closure <- + first + (TypedInductivePreparationContext + "induction closure") + (proveInductionClosure + foundation + resolveGlobal + inductive + elementContext + elementEnvironment + fixedPointAtElement + operator + subsetAtElement + closures + closuresProof) + inducted <- + first + (TypedInductivePreparationContext + "induction fixed-point rule") + (first TypedInductiveProofError + (setLfpInductProof + elementContext + domain + operator + predicate + element + monotone + memberProof + closure)) + expected <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + subsetAtElement)) + first TypedInductiveProofError + (conversionProof + elementContext + inducted + expected))))) + preparedFact + (derivedMarker marker "induct") + (SetLfpInduct :| []) + True + proof + +proveUnderVariables + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> [VarSymbol] + -> ( ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveUnderVariables context environment variables build = + case variables of + [] -> + build context environment + variable : remaining -> do + extendedEnvironment <- + extendEnvironment + variable + environment + forallIntroductionTyped + context + TySet + (\extended _bound -> + proveUnderVariables + extended + extendedEnvironment + remaining + build) + +checkedTerm + :: ProofContext (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (ScopedCheckedCore (InductiveGlobal global)) +checkedTerm context = + first TypedInductiveProofError + . scopedTerm context + +preparedFact + :: Marker + -> NonEmpty KernelRuleTag + -> Bool + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (PreparedTypedInductiveFact (InductiveGlobal global)) +preparedFact marker rules requiresMonotonicities proof = do + target <- + maybe + (Left TypedInductiveProofRemainedOpen) + Right + (closeScopedCore + (builtProofStatement proof)) + pure + (PreparedTypedInductiveFact + ( marker + , target + , canonicalRules rules + , requiresMonotonicities + , builtProofDerivation proof + )) + where + canonicalRules supplied = + case Set.toAscList + (Set.fromList (NonEmpty.toList supplied)) of + firstRule : remainingRules -> + firstRule :| remainingRules + [] -> + impossible "a nonempty guarded-rule set became empty" + +introMarker :: Marker -> Natural -> Marker +introMarker (Marker marker) index = + Marker + (marker + <> "_intro_" + <> Text.pack (show index)) + +derivedMarker :: Marker -> Text -> Marker +derivedMarker (Marker marker) suffix = + Marker + (marker <> "_" <> suffix) + +eliminateWrittenForalls + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> [VarSymbol] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateWrittenForalls + context + environment + variables + initial = + foldM + (\proof variable -> do + argument <- + checkedTerm context + =<< lookupEnvironment + variable + environment + first TypedInductiveProofError + (forallEliminationProof + context + proof + argument)) + initial + variables + +provePremises + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> ( [BuiltProof (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +provePremises context premises build = + case conjunctionList premises of + Nothing -> + build [] + Just conjunction -> do + proposition <- + checkedTerm context conjunction + implicationIntroductionTyped + context + proposition + (\extended conjunctionProof -> do + projections <- + projectConjunctionList + extended + premises + conjunctionProof + build projections) + +conjunctionIntroductionList + :: ProofContext (InductiveGlobal global) + -> [BuiltProof (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +conjunctionIntroductionList _context [] = + Left + (TypedInductiveUnsupportedExpression + "an empty conjunction has no introduction proof") +conjunctionIntroductionList context (firstProof : remaining) = + foldM + (\left right -> + first TypedInductiveProofError + (conjunctionIntroductionProof + context + left + right)) + firstProof + remaining + +projectConjunctionList + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + [BuiltProof (InductiveGlobal global)] +projectConjunctionList _context [] _proof = + pure [] +projectConjunctionList _context [_only] proof = + pure [proof] +projectConjunctionList context terms proof = do + let preceding = + List.init terms + final = + List.last terms + precedingTerm = + fromMaybe + CFalsum + (conjunctionList preceding) + precedingProof <- + first TypedInductiveProofError + (conjunctionLeftProof + context + precedingTerm + final + proof) + finalProof <- + first TypedInductiveProofError + (conjunctionRightProof + context + precedingTerm + final + proof) + (<> [finalProof]) + <$> projectConjunctionList + context + preceding + precedingProof + +introduceClauseWitnesses + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +introduceClauseWitnesses + resolveGlobal + _inductive + clause + context + environment + candidate + result + bodyProof = + introduce + (preparedClauseVariables clause) + where + introduce [] = + pure bodyProof + introduce (variable : remaining) = do + inner <- + introduce remaining + witness <- + checkedTerm context + =<< lookupEnvironment + variable + environment + underBinderEnvironment <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + let candidate' = + shiftCanonicalTerm 1 0 candidate + result' = + shiftCanonicalTerm + 1 + 0 + (scopedCoreTerm result) + bodyUnderBinderTerm <- + clauseFormulaWithBinders + resolveGlobal + clause + underBinderEnvironment + candidate' + result' + remaining + bodyUnderBinder <- + first TypedInductiveCoreError + (checkScopedCanonicalCore + (Just . inductiveGlobalType) + (TySet + : proofContextTypes + context) + bodyUnderBinderTerm) + first TypedInductiveProofError + (existentialIntroductionProof + context + TySet + bodyUnderBinder + witness + inner) + +clauseFormulaWithBinders + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [VarSymbol] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clauseFormulaWithBinders + resolveGlobal + clause + environment + candidate + result = \case + [] -> do + conditions <- + traverse + (conditionTerm + resolveGlobal + environment + candidate) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + pure + (fromMaybe + (CEq TySet result clauseResult) + (conjunctionList + (conditions + <> [CEq + TySet + result + clauseResult]))) + variable : remaining -> do + extended <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + body <- + clauseFormulaWithBinders + resolveGlobal + clause + extended + (shiftCanonicalTerm + 1 + 0 + candidate) + (shiftCanonicalTerm + 1 + 0 + result) + remaining + pure (existentialTerm TySet body) + +rebindEnvironment + :: VarSymbol + -> InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +rebindEnvironment variable + (InductiveEnvironment variables) = + pure + (InductiveEnvironment + (Map.insert variable 0 variables)) + +injectDisjunction + :: ProofContext (InductiveGlobal global) + -> Natural + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +injectDisjunction context index alternatives proof = + case splitAtNatural index alternatives of + Nothing -> + Left + (TypedInductiveUnsupportedExpression + "inductive clause index is outside the source-ordered alternatives") + Just (preceding, _selected, following) -> do + selectedProof <- + case preceding of + [] -> + pure proof + _ -> do + let precedingTerm = + disjunctionList preceding + first TypedInductiveProofError + (disjunctionRightProof + context + precedingTerm + proof) + foldM + (\current followingTerm -> + first TypedInductiveProofError + (disjunctionLeftProof + context + followingTerm + current)) + selectedProof + following + where + splitAtNatural + :: Natural + -> [a] + -> Maybe ([a], a, [a]) + splitAtNatural = + go [] + where + go _preceding _index [] = + Nothing + go preceding 0 (selected : rest) = + Just + ( reverse preceding + , selected + , rest + ) + go preceding current (item : rest) = + go + (item : preceding) + (current - 1) + rest + +closureTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + [CanonicalTerm (InductiveGlobal global)] +closureTerms + resolveGlobal + inductive + environment + subset = + traverse closureFor + (NonEmpty.toList + (preparedInductiveClauses + inductive)) + where + closureFor clause = do + clauseEnvironment <- + extendVariables + environment + (preparedClauseVariables clause) + let binderCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + subset' = + shiftCanonicalTerm + binderCount + 0 + subset + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + subset') + (preparedClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult clause) + pure + (closeForalls + (length + (preparedClauseVariables + clause)) + (impliesIfNeeded + (conjunctionList conditions) + (memberTerm + result + subset'))) + +proveBoundedMonotonicity + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveBoundedMonotonicity + _foundation + resolveGlobal + inductive + context + environment = do + domain <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + checkedTerm context + =<< operatorTerm + resolveGlobal + inductive + environment + operatorDomain <- + checkedTerm context + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm domain)) + bounded <- + first + (TypedInductivePreparationContext + "bounded monotonicity range") + (proveSubset + context + operatorDomain + domain + (\elementContext element membership -> do + elementEnvironment <- + shiftEnvironment environment + domainAtElement <- + checkedTerm elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + predicate <- + checkedTerm elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + domainAtElement) + explicitOperator <- + checkedTerm elementContext + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + domainAtElement) + explicitMembership <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm + explicitOperator)) + separatedMembership <- + first TypedInductiveProofError + (conversionProof + elementContext + membership + explicitMembership) + characteristic <- + separationForward + elementContext + domainAtElement + predicate + element + separatedMembership + first TypedInductiveProofError + (conjunctionLeftProof + elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + characteristic))) + monotone <- + first + (TypedInductivePreparationContext + "bounded monotonicity relation") + (forallIntroductionTyped + context + TySet + (\xContext _x -> + forallIntroductionTyped + xContext + TySet + (\xyContext _y -> do + xyEnvironment <- + shiftEnvironment + =<< shiftEnvironment + environment + x <- + checkedTerm xyContext + (CBound 1) + y <- + checkedTerm xyContext + (CBound 0) + domainXY <- + checkedTerm xyContext + =<< lowerTerm + resolveGlobal + xyEnvironment + (preparedInductiveDomain + inductive) + relation <- + checkedTerm xyContext + (conjunctionTerm + (subsetTerm + (scopedCoreTerm x) + (scopedCoreTerm y)) + (subsetTerm + (scopedCoreTerm y) + (scopedCoreTerm + domainXY))) + implicationIntroductionTyped + xyContext + relation + (\relatedContext _relationProof -> do + operatorXY <- + checkedTerm relatedContext + =<< operatorTerm + resolveGlobal + inductive + xyEnvironment + operatorX <- + checkedTerm relatedContext + (CApp + (scopedCoreTerm + operatorXY) + (scopedCoreTerm x)) + operatorY <- + checkedTerm relatedContext + (CApp + (scopedCoreTerm + operatorXY) + (scopedCoreTerm y)) + proveSubset + relatedContext + operatorX + operatorY + (\elementContext element membership -> do + elementEnvironment <- + shiftEnvironment + xyEnvironment + xAtElement <- + checkedTerm + elementContext + (CBound 2) + yAtElement <- + checkedTerm + elementContext + (CBound 1) + domainAtElement <- + checkedTerm + elementContext + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + predicateX <- + checkedTerm + elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + predicateY <- + checkedTerm + elementContext + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + yAtElement) + explicitX <- + checkedTerm + elementContext + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + memberExplicitX <- + checkedTerm + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + explicitX)) + separatedX <- + first TypedInductiveProofError + (conversionProof + elementContext + membership + memberExplicitX) + characteristicX <- + separationForward + elementContext + domainAtElement + predicateX + element + separatedX + inDomain <- + first + (TypedInductivePreparationContext + "monotonicity domain projection") + (first TypedInductiveProofError + (conjunctionLeftProof + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm + predicateX) + (scopedCoreTerm + element)) + characteristicX)) + satisfiesX <- + first + (TypedInductivePreparationContext + "monotonicity predicate projection") + (first TypedInductiveProofError + (conjunctionRightProof + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domainAtElement)) + (CApp + (scopedCoreTerm + predicateX) + (scopedCoreTerm + element)) + characteristicX)) + alternativesX <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + xAtElement) + (scopedCoreTerm + element) + alternativesY <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + yAtElement) + (scopedCoreTerm + element) + predicateXTarget <- + checkedTerm + elementContext + (disjunctionList + alternativesX) + satisfiesX' <- + first TypedInductiveProofError + (conversionProof + elementContext + satisfiesX + predicateXTarget) + satisfiesY <- + first + (TypedInductivePreparationContext + "monotonicity predicate transport") + (transformPredicateProof + resolveGlobal + inductive + elementContext + elementEnvironment + (scopedCoreTerm + xAtElement) + (scopedCoreTerm + yAtElement) + (scopedCoreTerm + domainAtElement) + (scopedCoreTerm + element) + alternativesX + alternativesY + satisfiesX') + separatedY <- + first + (TypedInductivePreparationContext + "monotonicity separation") + (separationBackward + elementContext + domainAtElement + predicateY + element + inDomain + satisfiesY) + operatorYAtElement <- + first + TypedInductiveCoreError + (weakenScopedCore + (Just + . inductiveGlobalType) + TySet + operatorY) + explicitMembershipY <- + checkedTerm + elementContext + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + operatorYAtElement)) + first TypedInductiveProofError + (conversionProof + elementContext + separatedY + explicitMembershipY)))))) + first + (TypedInductivePreparationContext + "bounded monotonicity conjunction") + (first TypedInductiveProofError + (conjunctionIntroductionProof + context + bounded + monotone)) + +transformPredicateProof + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transformPredicateProof + resolveGlobal + inductive + context + environment + candidateX + candidateY + domain + result + alternativesX + alternativesY + proof = do + target <- + checkedTerm context + (disjunctionList alternativesY) + first + (TypedInductivePreparationContext + "predicate disjunction elimination") + (eliminateDisjunctionAlternatives + context + alternativesX + proof + target + (\caseContext clauseIndex clauseProof -> do + clause <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive clause inventory changed during proof construction")) + Right + (atNatural + clauseIndex + (NonEmpty.toList + (preparedInductiveClauses + inductive))) + first + (TypedInductivePreparationContext + "predicate witness elimination") + (eliminateClauseWitnesses + resolveGlobal + clause + caseContext + environment + candidateX + result + clauseProof + target + (\depth + leafContext + leafEnvironment + candidateXAtLeaf + resultAtLeaf + bodyProof -> do + let candidateYAtLeaf = + shiftCanonicalTerm + depth + 0 + candidateY + domainAtLeaf = + shiftCanonicalTerm + depth + 0 + domain + alternativesYAtLeaf = + shiftCanonicalTerm + depth + 0 + <$> alternativesY + bodyY <- + first + (TypedInductivePreparationContext + "predicate clause body") + (transformClauseBody + resolveGlobal + clause + leafContext + leafEnvironment + candidateXAtLeaf + candidateYAtLeaf + domainAtLeaf + resultAtLeaf + bodyProof) + resultAtLeaf' <- + checkedTerm + leafContext + resultAtLeaf + alternativeY <- + introduceClauseWitnesses + resolveGlobal + inductive + clause + leafContext + leafEnvironment + candidateYAtLeaf + resultAtLeaf' + bodyY + first + (TypedInductivePreparationContext + "predicate disjunction injection") + (injectDisjunction + leafContext + clauseIndex + alternativesYAtLeaf + alternativeY))))) + +transformClauseBody + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transformClauseBody + resolveGlobal + clause + context + environment + candidateX + candidateY + domain + result + proof = do + conditionsX <- + traverse + (conditionTerm + resolveGlobal + environment + candidateX) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + let equality = + CEq TySet result clauseResult + bodyTermsX = + conditionsX <> [equality] + projections <- + projectConjunctionList + context + bodyTermsX + proof + let (conditionProofs, equalityProofs) = + splitAt + (length conditionsX) + projections + transformedConditions <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure conditionProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + subsetProof <- + subsetRelationHypothesis + context + candidateX + candidateY + domain + implication <- + first TypedInductiveProofError + (forallEliminationProof + context + subsetProof + recursiveElement) + first TypedInductiveProofError + (implicationEliminationProof + context + implication + conditionProof) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + subsetProof <- + subsetRelationHypothesis + context + candidateX + candidateY + domain + left <- checkedTerm context candidateX + right <- checkedTerm context candidateY + transportNestedRecursiveMembership + context + environment + nested + left + right + recursiveElement + subsetProof + conditionProof + | (condition, conditionProof) <- + zip + (preparedClauseConditions clause) + conditionProofs + ] + equalityProof <- + case equalityProofs of + [only] -> + pure only + _ -> + Left + (TypedInductiveUnsupportedExpression + "inductive clause equality projection is inconsistent") + conjunctionIntroductionList + context + (transformedConditions + <> [equalityProof]) + +subsetRelationHypothesis + :: ProofContext (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +subsetRelationHypothesis + context + left + right + domain = do + let leftSubsetRight = + subsetTerm left right + rightSubsetDomain = + subsetTerm right domain + relation = + conjunctionTerm + leftSubsetRight + rightSubsetDomain + relationTerm <- + checkedTerm context relation + relationProof <- + first TypedInductiveProofError + (hypothesisProof + context + relationTerm) + first TypedInductiveProofError + (conjunctionLeftProof + context + leftSubsetRight + rightSubsetDomain + relationProof) + +preparedRecursiveTerm + :: PreparedInductiveCondition global + -> Term +preparedRecursiveTerm = \case + PreparedDirectRecursiveCondition term _context -> term + PreparedNestedRecursiveCondition term _context _index _target -> term + PreparedSideCondition{} -> + impossible "a side condition has no recursive element" + +transportNestedRecursiveMembership + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportNestedRecursiveMembership + context + environment + condition + left + right + element + subsetProof + membership = do + monotonicity <- + nestedRecursiveMonotonicityProof + context environment condition left right subsetProof + implication <- + first TypedInductiveProofError + (forallEliminationProof + context monotonicity element) + first TypedInductiveProofError + (implicationEliminationProof + context implication membership) + +nestedRecursiveMonotonicityProof + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +nestedRecursiveMonotonicityProof + context + environment + (PreparedNestedRecursiveCondition + _term + (CheckedRecursiveCarrierContext variables _template) + index + target) + left + right + subsetProof = do + theorem <- + first TypedInductiveProofError + (importedProof context index target) + specialized <- + eliminateWrittenForalls + context environment variables theorem + atLeft <- + first TypedInductiveProofError + (forallEliminationProof context specialized left) + atRight <- + first TypedInductiveProofError + (forallEliminationProof context atLeft right) + first TypedInductiveProofError + (implicationEliminationProof + context atRight subsetProof) +nestedRecursiveMonotonicityProof + _context _environment _condition _left _right _subsetProof = + Left + (TypedInductiveUnsupportedExpression + "nested carrier transport requires a monotonicity import") + +proveInductionCandidateSubset + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionCandidateSubset + context fixedPoint predicate candidate subset = + proveSubset + context candidate subset + (\elementContext element membership -> do + fixedPointAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + fixedPoint) + predicateAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + predicate) + explicitMembership <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (apply2 + (CIntrinsic Sep) + (scopedCoreTerm fixedPointAtElement) + (scopedCoreTerm predicateAtElement))) + membership' <- + first TypedInductiveProofError + (conversionProof + elementContext membership explicitMembership) + characteristic <- + separationForward + elementContext + fixedPointAtElement + predicateAtElement + element + membership' + satisfies <- + first TypedInductiveProofError + (conjunctionRightProof + elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm fixedPointAtElement)) + (CApp + (scopedCoreTerm predicateAtElement) + (scopedCoreTerm element)) + characteristic) + expected <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + target <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm expected)) + first TypedInductiveProofError + (conversionProof + elementContext satisfies target)) + +eliminateClauseWitnesses + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( Natural + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateClauseWitnesses + resolveGlobal + clause + initialContext + initialEnvironment + initialCandidate + initialResult + initialProof + initialTarget + finish = + go + 0 + initialContext + initialEnvironment + initialCandidate + initialResult + initialProof + initialTarget + (preparedClauseVariables clause) + where + go depth context environment candidate result proof target = \case + [] -> + finish + depth + context + environment + candidate + result + proof + variable : remaining -> do + underBinderEnvironment <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + let candidate' = + shiftCanonicalTerm + 1 + 0 + candidate + result' = + shiftCanonicalTerm + 1 + 0 + result + bodyUnderBinderTerm <- + clauseFormulaWithBinders + resolveGlobal + clause + underBinderEnvironment + candidate' + result' + remaining + bodyUnderBinder <- + first TypedInductiveCoreError + (checkScopedCanonicalCore + (Just . inductiveGlobalType) + (TySet + : proofContextTypes + context) + bodyUnderBinderTerm) + targetUnderBinder <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + target) + first TypedInductiveProofError + (existentialEliminationProof + context + TySet + bodyUnderBinder + proof + target + (\underBinderContext _witness bodyProof -> + first typedAsProofError + (go + (depth + 1) + underBinderContext + underBinderEnvironment + candidate' + result' + bodyProof + targetUnderBinder + remaining))) + +eliminateDisjunctionAlternatives + :: ProofContext (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> Natural + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +eliminateDisjunctionAlternatives + initialContext + alternatives + proof + target + handle = + go initialContext 0 alternatives proof + where + go _context _offset [] _proof = + Left + (TypedInductiveUnsupportedExpression + "an inductive predicate has no alternatives") + go context offset [_only] onlyProof = + handle context offset onlyProof + go context offset current currentProof = do + let preceding = + List.init current + final = + List.last current + precedingTerm = + disjunctionList preceding + finalIndex = + offset + + fromIntegral + (length preceding) + first TypedInductiveProofError + (disjunctionEliminationProof + context + precedingTerm + final + currentProof + target + (\leftContext leftProof -> + first typedAsProofError + (go + leftContext + offset + preceding + leftProof)) + (\rightContext rightProof -> + first typedAsProofError + (handle + rightContext + finalIndex + rightProof))) + +proveInductionClosure + :: CheckedFoundation + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionClosure + _foundation + resolveGlobal + inductive + context + environment + fixedPoint + operator + subset + closures + _closuresProof = + forallIntroductionTyped + context + TySet + (\elementContext element -> do + elementEnvironment <- + shiftEnvironment environment + fixedPointAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + fixedPoint) + operatorAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + operator) + subsetAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + inductionPredicate <- + membershipPredicate + elementContext + subsetAtElement + candidate <- + checkedTerm elementContext + (apply2 + (CIntrinsic Sep) + (scopedCoreTerm + fixedPointAtElement) + (scopedCoreTerm + inductionPredicate)) + unfolded <- + checkedTerm elementContext + (CApp + (scopedCoreTerm + operatorAtElement) + (scopedCoreTerm + candidate)) + premise <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm unfolded)) + implicationIntroductionTyped + elementContext + premise + (\withMember memberProof -> do + domain <- + checkedTerm withMember + =<< lowerTerm + resolveGlobal + elementEnvironment + (preparedInductiveDomain + inductive) + operatorPredicate <- + checkedTerm withMember + =<< operatorPredicateAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + explicitOperator <- + checkedTerm withMember + =<< separationSetAt + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + explicitMembership <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + explicitOperator)) + separated <- + first TypedInductiveProofError + (conversionProof + withMember + memberProof + explicitMembership) + characteristic <- + separationForward + withMember + domain + operatorPredicate + element + separated + predicateProof <- + first TypedInductiveProofError + (conjunctionRightProof + withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + domain)) + (CApp + (scopedCoreTerm + operatorPredicate) + (scopedCoreTerm + element)) + characteristic) + alternatives <- + clauseFormulaTerms + resolveGlobal + inductive + elementEnvironment + (scopedCoreTerm + candidate) + (scopedCoreTerm + element) + predicateTarget <- + checkedTerm + withMember + (disjunctionList + alternatives) + predicateProof' <- + first TypedInductiveProofError + (conversionProof + withMember + predicateProof + predicateTarget) + result <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + subsetAtElement)) + subsetMembership <- + first + (TypedInductivePreparationContext + "induction clause alternatives") + (eliminateDisjunctionAlternatives + withMember + alternatives + predicateProof' + result + (\caseContext clauseIndex clauseProof -> do + clause <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive closure clause index is outside the source inventory")) + Right + (atNatural + clauseIndex + (NonEmpty.toList + (preparedInductiveClauses + inductive))) + first + (TypedInductivePreparationContext + "induction clause witnesses") + (eliminateClauseWitnesses + resolveGlobal + clause + caseContext + elementEnvironment + (scopedCoreTerm + candidate) + (scopedCoreTerm + element) + clauseProof + result + (\depth + leafContext + leafEnvironment + _candidateAtLeaf + resultAtLeaf + bodyProof -> + first + (TypedInductivePreparationContext + "induction clause proof") + (proveInductionClause + resolveGlobal + inductive + clauseIndex + clause + leafContext + leafEnvironment + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + fixedPointAtElement)) + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + inductionPredicate)) + (shiftCanonicalTerm + depth + 0 + (scopedCoreTerm + subsetAtElement)) + (shiftCanonicalTerm + (depth + 2) + 0 + <$> closures) + resultAtLeaf + bodyProof))))) + appliedPredicate <- + checkedTerm withMember + (CApp + (scopedCoreTerm + inductionPredicate) + (scopedCoreTerm + element)) + first TypedInductiveProofError + (conversionProof + withMember + subsetMembership + appliedPredicate))) + +proveInductionClause + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> Natural + -> PreparedInductiveClause (InductiveGlobal global) + -> ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> [CanonicalTerm (InductiveGlobal global)] + -> CanonicalTerm (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionClause + resolveGlobal + _inductive + clauseIndex + clause + context + environment + fixedPoint + predicate + subset + closures + result + bodyProof = do + conditions <- + traverse + (conditionTerm + resolveGlobal + environment + (apply2 + (CIntrinsic Sep) + fixedPoint + predicate)) + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + environment + (preparedClauseResult clause) + let equality = + CEq TySet result clauseResult + bodyTerms = + conditions <> [equality] + projections <- + first + (TypedInductivePreparationContext + "induction clause body projections") + (projectConjunctionList + context + bodyTerms + bodyProof) + let (conditionProofs, equalityProofs) = + splitAt + (length conditions) + projections + closureConditionProofs <- + sequence + [ case condition of + PreparedSideCondition _formula -> + pure conditionProof + PreparedDirectRecursiveCondition + recursiveTerm _context -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + recursiveTerm + fixedPoint' <- + checkedTerm context fixedPoint + predicate' <- + checkedTerm context predicate + separated <- + separationForward + context + fixedPoint' + predicate' + recursiveElement + conditionProof + predicateMembership <- + first TypedInductiveProofError + (conjunctionRightProof + context + (memberTerm + (scopedCoreTerm + recursiveElement) + fixedPoint) + (CApp + predicate + (scopedCoreTerm + recursiveElement)) + separated) + expected <- + checkedTerm context + (memberTerm + (scopedCoreTerm + recursiveElement) + subset) + first TypedInductiveProofError + (conversionProof + context + predicateMembership + expected) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + fixedPoint' <- checkedTerm context fixedPoint + predicate' <- checkedTerm context predicate + candidate <- + checkedTerm context + (apply2 + (CIntrinsic Sep) + fixedPoint + predicate) + subset' <- checkedTerm context subset + candidateSubset <- + proveInductionCandidateSubset + context + fixedPoint' + predicate' + candidate + subset' + transportNestedRecursiveMembership + context + environment + nested + candidate + subset' + recursiveElement + candidateSubset + conditionProof + | (condition, conditionProof) <- + zip + (preparedClauseConditions clause) + conditionProofs + ] + closureConjunction <- + case conjunctionList closures of + Nothing -> + Left + (TypedInductiveUnsupportedExpression + "inductive closure inventory is empty") + Just conjunction -> + first + (TypedInductivePreparationContext + "induction closure conjunction") + (checkedTerm context conjunction) + allClosures <- + first + (TypedInductivePreparationContext + "induction closure hypothesis") + (first TypedInductiveProofError + (hypothesisProof + context + closureConjunction)) + closureProofs <- + first + (TypedInductivePreparationContext + "induction closure projections") + (projectConjunctionList + context + closures + allClosures) + selectedClosure <- + maybe + (Left + (TypedInductiveUnsupportedExpression + "inductive closure projection is outside the source inventory")) + Right + (atNatural clauseIndex closureProofs) + specializedClosure <- + first + (TypedInductivePreparationContext + "induction closure specialization") + (eliminateWrittenForalls + context + environment + (preparedClauseVariables clause) + selectedClosure) + resultMembership <- + case closureConditionProofs of + [] -> + pure specializedClosure + _ -> do + conjunction <- + conjunctionIntroductionList + context + closureConditionProofs + first TypedInductiveProofError + (implicationEliminationProof + context + specializedClosure + conjunction) + equalityProof <- + case equalityProofs of + [only] -> + pure only + _ -> + Left + (TypedInductiveUnsupportedExpression + "inductive closure equality projection is inconsistent") + subset' <- + first + (TypedInductivePreparationContext + "induction subset target") + (checkedTerm context subset) + first + (TypedInductivePreparationContext + "induction result transport") + (transportElementMembership + context + subset' + equalityProof + resultMembership) + +transportElementMembership + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportElementMembership + context + set + equality + membership = do + (sourceElement, targetElement) <- + case scopedCoreTerm + (builtProofStatement + equality) of + CEq TySet source target -> + Right (source, target) + _ -> + Left + (TypedInductiveUnsupportedExpression + "element transport requires set equality") + predicate <- + membershipPredicate + context + set + predicateReflexivity <- + first TypedInductiveProofError + (equalityReflexivityProof + context + predicate) + propositionEquality <- + first TypedInductiveProofError + (equalityCongruenceApplicationProof + context + predicateReflexivity + equality) + reversed <- + first TypedInductiveProofError + (equalityReverseProof + context + propositionEquality) + appliedTarget <- + checkedTerm context + (CApp + (scopedCoreTerm predicate) + targetElement) + targetMembership <- + first TypedInductiveProofError + (conversionProof + context + membership + appliedTarget) + transported <- + first TypedInductiveProofError + (equalityModusPonensProof + context + reversed + targetMembership) + sourceMembership <- + checkedTerm context + (memberTerm + sourceElement + (scopedCoreTerm set)) + first TypedInductiveProofError + (conversionProof + context + transported + sourceMembership) + +predicateAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +predicateAt + resolveGlobal + inductive + environment + candidate + result = + disjunctionList + <$> clauseFormulaTerms + resolveGlobal + inductive + environment + candidate + result + +clauseFormulaTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + [CanonicalTerm (InductiveGlobal global)] +clauseFormulaTerms + resolveGlobal + inductive + environment + candidate + result = + traverse + (clauseFormulaAt + resolveGlobal + environment + candidate + result) + (NonEmpty.toList + (preparedInductiveClauses + inductive)) + +clauseFormulaAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CanonicalTerm (InductiveGlobal global) + -> PreparedInductiveClause (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clauseFormulaAt + resolveGlobal + environment + candidate + result + clause = do + clauseEnvironment <- + extendVariables + environment + (preparedClauseVariables clause) + let binderCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + candidate' = + shiftCanonicalTerm binderCount 0 candidate + result' = + shiftCanonicalTerm binderCount 0 result + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + candidate') + (preparedClauseConditions + clause) + clauseResult <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult clause) + pure + (closeExistentials + (length + (preparedClauseVariables + clause)) + (fromMaybe + (CEq TySet result' clauseResult) + (conjunctionList + (conditions + <> [CEq + TySet + result' + clauseResult])))) + +extendVariables + :: InductiveEnvironment + -> [VarSymbol] + -> Either + TypedInductiveError + InductiveEnvironment +extendVariables = + go [] + where + go _seen environment [] = + Right environment + go seen environment (variable : remaining) + | variable `elem` seen = + Left + (TypedInductiveDuplicateBinder + variable) + | otherwise = do + extended <- + rebindEnvironment + variable + =<< shiftEnvironment + environment + go + (variable : seen) + extended + remaining + +membershipPredicate + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (ScopedCheckedCore (InductiveGlobal global)) +membershipPredicate context set = do + weakenedSet <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + set) + checkedTerm context + (CLam TySet + (memberTerm + (CBound 0) + (scopedCoreTerm + weakenedSet))) + +operatorPredicateAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +operatorPredicateAt + resolveGlobal + inductive + environment + candidate = do + extended <- + shiftEnvironment environment + body <- + predicateAt + resolveGlobal + inductive + extended + (shiftCanonicalTerm + 1 + 0 + candidate) + (CBound 0) + pure (CLam TySet body) + +separationSetAt + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +separationSetAt + resolveGlobal + inductive + environment + candidate = do + domain <- + lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + predicate <- + operatorPredicateAt + resolveGlobal + inductive + environment + candidate + pure + (apply2 + (CIntrinsic Sep) + domain + predicate) + +foundationInstance + :: ProofContext (InductiveGlobal global) + -> FoundationAxiomTag + -> [ScopedCheckedCore (InductiveGlobal global)] + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +foundationInstance context tag arguments = do + initial <- + first TypedInductiveProofError + (foundationProof context tag) + foldM + (\proof argument -> + first TypedInductiveProofError + (forallEliminationProof + context + proof + argument)) + initial + arguments + +separationForward + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +separationForward + context + domain + predicate + element + membership = do + characteristic <- + foundationInstance + context + SeparationCharacteristic + [domain, predicate, element] + first TypedInductiveProofError + (equalityModusPonensProof + context + characteristic + membership) + +separationBackward + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +separationBackward + context + domain + predicate + element + inDomain + satisfies = do + characteristic <- + foundationInstance + context + SeparationCharacteristic + [domain, predicate, element] + reversed <- + first TypedInductiveProofError + (equalityReverseProof + context + characteristic) + expectedSatisfies <- + checkedTerm context + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + satisfies' <- + first TypedInductiveProofError + (conversionProof + context + satisfies + expectedSatisfies) + conjunction <- + first TypedInductiveProofError + (conjunctionIntroductionProof + context + inDomain + satisfies') + first TypedInductiveProofError + (equalityModusPonensProof + context + reversed + conjunction) + +transportMembership + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportMembership + context + element + setEquality + membership = do + (sourceSet, targetSet) <- + case scopedCoreTerm + (builtProofStatement + setEquality) of + CEq TySet source target -> + Right (source, target) + _ -> + Left + (TypedInductiveUnsupportedExpression + "membership transport requires set equality") + weakenedElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + element) + function <- + checkedTerm context + (CLam TySet + (memberTerm + (scopedCoreTerm + weakenedElement) + (CBound 0))) + functionReflexivity <- + first TypedInductiveProofError + (equalityReflexivityProof + context + function) + propositionEquality <- + first TypedInductiveProofError + (equalityCongruenceApplicationProof + context + functionReflexivity + setEquality) + appliedSource <- + checkedTerm context + (CApp + (scopedCoreTerm function) + sourceSet) + sourceMembership <- + first TypedInductiveProofError + (conversionProof + context + membership + appliedSource) + transported <- + first TypedInductiveProofError + (equalityModusPonensProof + context + propositionEquality + sourceMembership) + targetMembership <- + checkedTerm context + (memberTerm + (scopedCoreTerm element) + targetSet) + first TypedInductiveProofError + (conversionProof + context + transported + targetMembership) + +proveSubset + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveSubset context left right proveElement = + forallIntroductionTyped + context + TySet + (\extended element -> do + left' <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + left) + right' <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + right) + memberLeft <- + checkedTerm extended + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm left')) + implicationIntroductionTyped + extended + memberLeft + (\withMember memberProof -> + proveElement + withMember + element + memberProof + >>= \result -> do + expected <- + checkedTerm withMember + (memberTerm + (scopedCoreTerm + element) + (scopedCoreTerm + right')) + if builtProofStatement result + == expected + then pure result + else + Left + (TypedInductiveUnsupportedExpression + "subset proof produced the wrong membership target"))) + +typedAsProofError + :: TypedInductiveError + -> KernelProofBuildError +typedAsProofError = \case + TypedInductiveProofError err -> + err + err -> + ProofSetLfpRuleFailed + (Text.pack (show err)) + +implicationIntroductionTyped + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ( ProofContext (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +implicationIntroductionTyped context premise build = + first TypedInductiveProofError + (implicationIntroductionProof + context + premise + (\extended proof -> + first typedAsProofError + (build extended proof))) + +forallIntroductionTyped + :: ProofContext (InductiveGlobal global) + -> CoreType + -> ( ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +forallIntroductionTyped context binderType build = + first TypedInductiveProofError + (forallIntroductionProof + context + binderType + (\extended variable -> + first typedAsProofError + (build extended variable))) + +buildUnderVariables + :: InductiveEnvironment + -> [VarSymbol] + -> ( InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) + ) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +buildUnderVariables + environment + [] + build = + build environment +buildUnderVariables + environment + (variable : remaining) + build = do + extended <- + extendEnvironment + variable + environment + buildUnderVariables + extended + remaining + build + +fixedPointTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +fixedPointTerm resolveGlobal inductive environment = do + domain <- + lowerTerm + resolveGlobal + environment + (preparedInductiveDomain + inductive) + operator <- + operatorTerm + resolveGlobal + inductive + environment + pure + (CApp + (CApp + (CIntrinsic ISetLfp) + domain) + operator) + +operatorTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> InductiveEnvironment + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +operatorTerm resolveGlobal inductive parameterEnvironment = do + candidateEnvironment <- + shiftEnvironment parameterEnvironment + domain <- + lowerTerm + resolveGlobal + candidateEnvironment + (preparedInductiveDomain + inductive) + resultEnvironment <- + shiftEnvironment candidateEnvironment + clauses <- + traverse + (clausePredicateTerm + resolveGlobal + resultEnvironment) + (preparedInductiveClauses + inductive) + pure + (CLam TySet + (CApp + (CApp + (CIntrinsic Sep) + domain) + (CLam TySet + (disjunctionList + (NonEmpty.toList + clauses))))) + +clausePredicateTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> PreparedInductiveClause (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +clausePredicateTerm + resolveGlobal + resultEnvironment + clause = do + clauseEnvironment <- + extendVariables + resultEnvironment + (preparedClauseVariables clause) + let variableCount = + fromIntegral + (length + (preparedClauseVariables + clause)) + resultVariable = + CBound variableCount + candidate = + CBound (variableCount + 1) + conditions <- + traverse + (conditionTerm + resolveGlobal + clauseEnvironment + candidate) + (preparedClauseConditions + clause) + result <- + lowerTerm + resolveGlobal + clauseEnvironment + (preparedClauseResult + clause) + pure + (closeExistentials + (length + (preparedClauseVariables clause)) + (fromMaybe + (CEq + TySet + resultVariable + result) + (conjunctionList + (conditions + <> [CEq + TySet + resultVariable + result])))) + +directConditionTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> DirectInductiveCondition + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +directConditionTerm resolveGlobal environment candidate = \case + DirectSideCondition formula -> + lowerFormula resolveGlobal environment formula + DirectRecursiveCondition term context -> do + carrier <- + betaNormalizeCanonical + <$> lowerRecursiveCarrierContext + resolveGlobal environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier + +conditionTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> PreparedInductiveCondition (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +conditionTerm resolveGlobal environment candidate = \case + PreparedSideCondition formula -> + lowerFormula + resolveGlobal + environment + formula + PreparedDirectRecursiveCondition term context -> do + carrier <- + instantiateRecursiveCarrier environment candidate context + memberTerm + <$> lowerTerm + resolveGlobal + environment + term + <*> pure carrier + PreparedNestedRecursiveCondition term context _index _target -> do + carrier <- + instantiateRecursiveCarrier environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier + +shiftEnvironment + :: InductiveEnvironment + -> Either + TypedInductiveError + InductiveEnvironment +shiftEnvironment + (InductiveEnvironment variables) = + pure + (InductiveEnvironment + (succ <$> variables)) + +lowerFormula + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Formula + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerFormula = + lowerFormulaWith False + +lowerFormulaWith + :: Bool + -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Formula + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerFormulaWith allowQuantified resolveGlobal environment = \case + IsElementOf _location element set -> + memberTerm + <$> lowerTerm + resolveGlobal + environment + element + <*> lowerTerm + resolveGlobal + environment + set + Equals _location left right -> + CEq TySet + <$> lowerTerm resolveGlobal environment left + <*> lowerTerm resolveGlobal environment right + NotEquals _location left right -> + notTerm + <$> (CEq TySet + <$> lowerTerm resolveGlobal environment left + <*> lowerTerm resolveGlobal environment right) + IsSubsetOf _location left right -> do + extended <- + shiftEnvironment environment + left' <- + lowerTerm resolveGlobal extended left + right' <- + lowerTerm resolveGlobal extended right + pure + (CForall TySet + (CImp + (memberTerm + (CBound 0) + left') + (memberTerm + (CBound 0) + right'))) + Bottom -> + pure CFalsum + Top -> + pure (CImp CFalsum CFalsum) + Not _location proposition -> + notTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal + environment + proposition + left `Implies` right -> + CImp + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `And` right -> + conjunctionTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `Or` right -> + disjunctionTerm + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + left `Iff` right -> + CEq TyProp + <$> lowerFormulaWith allowQuantified + resolveGlobal environment left + <*> lowerFormulaWith allowQuantified + resolveGlobal environment right + Atomic _location predicate arguments -> + lowerPredicateApplication + resolveGlobal + environment + (SymbolPredicate predicate) + arguments + Quantified quantifier scope + | allowQuantified -> do + let variables = + nubOrd + [ variable + | B variable <- toList (fromScope scope) + ] + body = instantiate TermVar scope + extended <- extendVariables environment variables + lowered <- + lowerFormulaWith + allowQuantified + resolveGlobal + extended + body + pure + (case quantifier of + Universally -> + closeForalls (length variables) lowered + Existentially -> + closeExistentials (length variables) lowered) + _ -> + Left + (TypedInductiveUnsupportedExpression + "quantified and higher-order side conditions are not supported by the typed inductive slice") + +lowerTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Term + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerTerm resolveGlobal environment = \case + TermVar variable -> + lookupEnvironment + variable + environment + EmptySet _location -> + pure (CIntrinsic Empty) + TermSymbol _location (SymbolInteger integer) [] -> + pure + (COpaqueInteger + (toInteger integer)) + TermSymbol _location symbol arguments -> + lowerApplication + resolveGlobal + environment + symbol + arguments + _ -> + Left + (TypedInductiveUnsupportedExpression + "higher-order source terms are not supported by the typed inductive slice") + +lowerApplication + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Symbol + -> [Expr] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerApplication resolveGlobal environment symbol arguments = do + arguments' <- + traverse + (lowerTerm + resolveGlobal + environment) + arguments + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerPredicateApplication + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Symbol + -> [Expr] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerPredicateApplication resolveGlobal environment symbol arguments = do + arguments' <- + traverse + (lowerTerm + resolveGlobal + environment) + arguments + case classifyExactSymbol symbol of + ExactFixedPrimitive meaning -> + maybe + (lowerApplicationTerms resolveGlobal symbol arguments') + Right + (lowerFixedEqualityPredicate meaning arguments') + _ -> + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerApplicationTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Symbol + -> [CanonicalTerm (InductiveGlobal global)] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerApplicationTerms resolveGlobal symbol arguments' = + case dispatchFixedSetTerm symbol arguments' of + LoweredFixedSetTerm term -> + pure term + RejectedFixedSetTerm -> + Left + (TypedInductiveUnsupportedExpression + ("fixed source symbol is not a supported set term: " + <> symbolText symbol)) + NotFixedSetTerm -> do + SourceGlobal reference body <- + maybe + (Left + (TypedInductiveUnsupportedExpression + ("source symbol is not typed: " + <> symbolText symbol))) + Right + (resolveGlobal symbol) + pure + (foldl' + CApp + (maybe + (CGlobal reference) + frozenCoreTerm + body) + arguments') + +memberTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +memberTerm = + apply2 (CIntrinsic Member) + +subsetTerm + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +subsetTerm left right = + CForall TySet + (CImp + (memberTerm + (CBound 0) + (shiftCanonicalTerm + 1 + 0 + left)) + (memberTerm + (CBound 0) + (shiftCanonicalTerm + 1 + 0 + right))) + +apply2 + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +apply2 function firstArgument secondArgument = + CApp + (CApp function firstArgument) + secondArgument + +notTerm + :: CanonicalTerm global + -> CanonicalTerm global +notTerm proposition = + CImp proposition CFalsum + +conjunctionList + :: [CanonicalTerm global] + -> Maybe (CanonicalTerm global) +conjunctionList = \case + [] -> + Nothing + firstTerm : remaining -> + Just + (foldl' + conjunctionTerm + firstTerm + remaining) + +disjunctionList + :: [CanonicalTerm global] + -> CanonicalTerm global +disjunctionList = \case + [] -> + CFalsum + firstTerm : remaining -> + foldl' + disjunctionTerm + firstTerm + remaining + +impliesIfNeeded + :: Maybe (CanonicalTerm global) + -> CanonicalTerm global + -> CanonicalTerm global +impliesIfNeeded = \case + Nothing -> + id + Just premise -> + CImp premise + +closeLambdas + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeLambdas binderCount body = + foldl' + (\current _ -> + CLam TySet current) + body + [1 .. binderCount] + +closeForalls + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeForalls binderCount body = + foldl' + (\current _ -> + CForall TySet current) + body + [1 .. binderCount] + +closeExistentials + :: Int + -> CanonicalTerm global + -> CanonicalTerm global +closeExistentials binderCount body = + foldl' + (\current _ -> + existentialTerm TySet current) + body + [1 .. binderCount] + +shiftCanonicalTerm + :: Natural + -> Natural + -> CanonicalTerm global + -> CanonicalTerm global +shiftCanonicalTerm amount cutoff = \case + CBound index + | index >= cutoff -> + CBound (index + amount) + | otherwise -> + CBound index + CGlobal global -> + CGlobal global + CIntrinsic intrinsic -> + CIntrinsic intrinsic + COpaqueInteger integer -> + COpaqueInteger integer + CApp function argument -> + CApp + (shiftCanonicalTerm + amount + cutoff + function) + (shiftCanonicalTerm + amount + cutoff + argument) + CLam binderType body -> + CLam binderType + (shiftCanonicalTerm + amount + (cutoff + 1) + body) + CFalsum -> + CFalsum + CImp premise conclusion -> + CImp + (shiftCanonicalTerm + amount + cutoff + premise) + (shiftCanonicalTerm + amount + cutoff + conclusion) + CEq operandType left right -> + CEq operandType + (shiftCanonicalTerm + amount + cutoff + left) + (shiftCanonicalTerm + amount + cutoff + right) + CForall binderType body -> + CForall binderType + (shiftCanonicalTerm + amount + (cutoff + 1) + body) + +atNatural :: Natural -> [a] -> Maybe a +atNatural _index [] = + Nothing +atNatural 0 (value : _rest) = + Just value +atNatural index (_value : rest) = + atNatural (index - 1) rest + +freezeClosedTarget + :: CanonicalTerm (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +freezeClosedTarget = + first TypedInductiveCoreError + . checkCanonicalCore + (Just . inductiveGlobalType) + +symbolText :: Symbol -> Text +symbolText = \case + SymbolMixfix symbol -> + case mixfixMarker symbol of + Marker text -> + text + SymbolFun symbol -> + case lexicalItemSgPlMarker symbol of + Marker text -> + text + SymbolInteger integer -> + Text.pack (show integer) + SymbolPredicate predicate -> + case predicateObjectMarker predicate of + Marker text -> + text diff --git a/source/Felix/CommandLine.hs b/source/Felix/CommandLine.hs index 701020f..448d698 100644 --- a/source/Felix/CommandLine.hs +++ b/source/Felix/CommandLine.hs @@ -26,10 +26,10 @@ import Felix.Store qualified as Store import Felix.Verification qualified as Verification import Felix.Version qualified as Version import Felix.Workspace qualified as Workspace -import Render.Html.Export qualified as HtmlExport -import Render.Html.Layout qualified as HtmlLayout -import Render.Html.Output qualified as HtmlOutput -import Report.Location +import Felix.Render.Html.Export qualified as HtmlExport +import Felix.Render.Html.Layout qualified as HtmlLayout +import Felix.Render.Html.Output qualified as HtmlOutput +import Felix.Report.Location import Control.Monad (unless, when) import Data.Maybe (catMaybes) diff --git a/source/Felix/Math/Codec.hs b/source/Felix/Math/Codec.hs index 4a5c7b1..a551f53 100644 --- a/source/Felix/Math/Codec.hs +++ b/source/Felix/Math/Codec.hs @@ -24,7 +24,7 @@ module Felix.Math.Codec ) where import Base hiding (Empty) -import Checking.Core +import Felix.Checking.Core import Control.DeepSeq (NFData) import Crypto.Hash qualified as Crypto diff --git a/source/Felix/Meaning.hs b/source/Felix/Meaning.hs index 60c4cfc..268a1a6 100644 --- a/source/Felix/Meaning.hs +++ b/source/Felix/Meaning.hs @@ -9,12 +9,12 @@ module Felix.Meaning where import Base -import Syntax.Abstract (Sign(..)) -import Syntax.Abstract qualified as Raw -import Syntax.Internal (VarSymbol(..), pattern FreshVar) -import Syntax.Internal qualified as Sem -import Syntax.LexicalPhrase (unsafeReadPhrase) -import Report.Location +import Felix.Syntax.Abstract (Sign(..)) +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal (VarSymbol(..), pattern FreshVar) +import Felix.Syntax.Internal qualified as Sem +import Felix.Syntax.LexicalPhrase (unsafeReadPhrase) +import Felix.Report.Location import Bound import Control.Monad.Except diff --git a/source/Felix/OutputPlan.hs b/source/Felix/OutputPlan.hs index 58314db..78d7e7a 100644 --- a/source/Felix/OutputPlan.hs +++ b/source/Felix/OutputPlan.hs @@ -18,7 +18,7 @@ module Felix.OutputPlan import Base import Felix.Source import Felix.Store -import Render.Html.Output qualified as Html +import Felix.Render.Html.Output qualified as Html import Control.Exception (displayException) import Data.List qualified as List diff --git a/source/Felix/Parse.hs b/source/Felix/Parse.hs index e03feb9..0a46d82 100644 --- a/source/Felix/Parse.hs +++ b/source/Felix/Parse.hs @@ -90,9 +90,9 @@ import Felix.Source import Felix.Source.Content qualified as Content import Felix.Source.Graph import Felix.Store qualified as Store -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Adapt +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt ( LexicalScanError(..) , ScannedLexicalItem , SyntaxMaterializationError(..) @@ -101,11 +101,11 @@ import Syntax.Adapt , scanChunk , scannedItemMarker ) -import Syntax.Concrete (grammar) -import Syntax.Interface -import Syntax.Lexicon (Lexicon) -import Syntax.Pragma -import Syntax.Token +import Felix.Syntax.Concrete (grammar) +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon (Lexicon) +import Felix.Syntax.Pragma +import Felix.Syntax.Token import Control.DeepSeq (NFData, force) import Control.Exception (Exception, evaluate) diff --git a/source/Felix/Parsed/Identity.hs b/source/Felix/Parsed/Identity.hs index e11b2c7..b76c26e 100644 --- a/source/Felix/Parsed/Identity.hs +++ b/source/Felix/Parsed/Identity.hs @@ -20,7 +20,7 @@ module Felix.Parsed.Identity import Base import Felix.Cache.Codec import Felix.Source.Content -import Syntax.Interface +import Felix.Syntax.Interface import Control.DeepSeq (NFData) import Data.ByteString (ByteString) diff --git a/source/Felix/Parsed/Payload.hs b/source/Felix/Parsed/Payload.hs index 2506973..5e63c70 100644 --- a/source/Felix/Parsed/Payload.hs +++ b/source/Felix/Parsed/Payload.hs @@ -30,11 +30,11 @@ import Base import Felix.Cache.Codec import Felix.Parsed.Identity qualified as Identity import Felix.Source -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import Syntax.LexicalPhrase qualified as Phrase -import Syntax.Token qualified as Token +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.LexicalPhrase qualified as Phrase +import Felix.Syntax.Token qualified as Token import Control.DeepSeq (NFData) import Control.Monad (unless) diff --git a/source/Felix/Prelude.hs b/source/Felix/Prelude.hs index 28ad961..ccd5623 100644 --- a/source/Felix/Prelude.hs +++ b/source/Felix/Prelude.hs @@ -30,10 +30,10 @@ import Felix.Parse import Felix.Parsed.Identity qualified as Parsed import Felix.Source import Felix.Source.Graph -import Report.Location -import Syntax.Adapt (SyntaxMaterializationError) -import Syntax.Interface -import Syntax.Pragma +import Felix.Report.Location +import Felix.Syntax.Adapt (SyntaxMaterializationError) +import Felix.Syntax.Interface +import Felix.Syntax.Pragma import Control.Exception (IOException, displayException, try) import Data.ByteString (ByteString) diff --git a/source/Felix/Provers.hs b/source/Felix/Provers.hs index eb6f62c..16ef655 100644 --- a/source/Felix/Provers.hs +++ b/source/Felix/Provers.hs @@ -79,9 +79,9 @@ module Felix.Provers ) where import Base -import Checking.Authority qualified as Authority -import Checking.Backend.Problem -import Checking.Backend.Tptp +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem +import Felix.Checking.Backend.Tptp import Control.Concurrent.STM ( STM @@ -130,7 +130,7 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding import Data.Text.Encoding.Error qualified as TextEncodingError import Numeric.Natural (Natural) -import Report.Location (Location) +import Felix.Report.Location (Location) import System.Exit (ExitCode(..)) import System.Posix.Signals (sigKILL, signalProcessGroup) import System.Posix.Types (ProcessGroupID) diff --git a/source/Felix/Render/Html.hs b/source/Felix/Render/Html.hs new file mode 100644 index 0000000..7081e52 --- /dev/null +++ b/source/Felix/Render/Html.hs @@ -0,0 +1,3964 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Felix.Render.Html + ( HtmlRenderIndex + , HtmlPagePresentation + , buildRenderIndex + , htmlPagePresentationSource + , renderDocument + , supportScriptAssetContents + ) where + +import Felix.Syntax.Abstract + +import Base +import Felix.Source (ResolvedSource) +import Lucid hiding (Term, for_) +import Lucid.Base (makeAttributes) +import Lucid.Math +import Felix.Render.Html.Context + ( HtmlRenderContext + , HtmlRenderContextError + , htmlCurrentPageLabel + , htmlCurrentSource + , htmlSourceFragmentHref + , htmlSourceLabel + , htmlSourcePageHref + , htmlSupportScriptHref + ) +import Felix.Render.Html.Layout (renderUrlFragment) +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Token (VariableDisplay(..), VariableSuffix(..), displayVariable, tokToText) + +import Control.Monad (unless, when) +import Data.Char (digitToInt, isAlphaNum, isDigit, isSpace, toUpper) +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.Text.Lazy qualified as LazyText + + + +data HintCategory + = OperatorHint + | RelationHint + | PredicateHint + | StructOpHint + deriving (Show, Eq, Ord) + +data TemplatePiece + = Literal Text + | Slot Int + deriving (Show, Eq, Ord) + +data RenderHint = RenderHint + { renderHintArity :: Int + , renderHintTemplate :: [TemplatePiece] + } deriving (Show, Eq, Ord) + +type HintMap = Map (HintCategory, Marker, Int) RenderHint +type AnchorMap = Map Marker Text +type BlockRenderInfo = (Int, Block, Text) +type PreviewMap = Map Marker PreviewEntry + +data HtmlRenderIndex = HtmlRenderIndex + !(Map Marker IndexedReferenceTarget) + +data HtmlPagePresentation = HtmlPagePresentation + { htmlPagePresentationSource :: !ResolvedSource + , pagePresentationBlockInfos :: ![BlockRenderInfo] + , pagePresentationAnchors :: !AnchorMap + , pagePresentationReferencedMarkers :: !(Set Marker) + } + +data IndexedReferenceTarget = IndexedReferenceTarget + !Int + !ResolvedSource + !ReferenceTarget + +data ReferenceContext = ReferenceContext + { referenceAnchors :: AnchorMap + , referencePreviews :: PreviewMap + } + +data PreviewEntry = PreviewEntry + { previewMarker :: Marker + , previewKind :: Text + , previewTitle :: Maybe Text + , previewSourceLabel :: Text + , previewSourceHref :: Text + , previewReferenceHref :: Text + , previewId :: Text + , previewBody :: HintMap -> Html () + } + +data ReferenceTarget = ReferenceTarget + { targetMarker :: Marker + , targetAnchorId :: Text + , targetKind :: Text + , targetTitle :: Maybe Text + , targetBody :: HintMap -> Html () + } + +data StmtMathFragment + = StmtMathProse Text + | StmtMathNode (Html ()) + +type StmtMathFragments = [StmtMathFragment] + +newtype MissingHintMap = MissingHintMap + { unMissingHintMap :: Map HintCategory (Set Marker) + } deriving (Show, Eq) + +instance Semigroup MissingHintMap where + MissingHintMap left <> MissingHintMap right = + MissingHintMap (Map.unionWith (<>) left right) + +instance Monoid MissingHintMap where + mempty = MissingHintMap mempty + +proofCollapseThreshold :: Int +proofCollapseThreshold = 10 + +referenceGroupThreshold :: Int +referenceGroupThreshold = 5 + + +renderDocument + :: HtmlRenderContext + -> Text + -> HtmlRenderIndex + -> HtmlPagePresentation + -> Either HtmlRenderContextError Text +renderDocument + context + hintsSource + renderIndex + HtmlPagePresentation + { pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = anchors + , pagePresentationReferencedMarkers = referencedMarkers + } = do + previews <- + buildPreviewMap + context + referencedMarkers + anchors + renderIndex + let result = + case formatMissingHintWarning missingHints of + Nothing -> rendered + Just warningText -> + trace (Text.unpack warningText) rendered + hints = parseHints hintsSource + missingHints = + collectMissingHints + hints + [ block + | (_index, block, _blockId) <- blockInfos + ] + rendered = LazyText.toStrict (renderText (renderPage hints)) + pageLabel = htmlCurrentPageLabel context + tocBlocks = [(index, blockId, block) | (index, block, blockId) <- blockInfos, includeInToc block] + referenceContext = ReferenceContext anchors previews + + renderPage :: HintMap -> Html () + renderPage hintMap = doctypehtml_ do + head_ do + meta_ [charset_ "utf-8"] + title_ (toHtml pageLabel) + style_ pageStyles + body_ do + div_ [class_ "page-layout"] do + aside_ [class_ "toc-column"] do + nav_ [class_ "toc"] do + h2_ [class_ "toc-heading"] "Contents" + input_ + [ class_ "toc-filter" + , type_ "search" + , placeholder_ "Filter labels" + , makeAttributes "aria-label" "Filter TOC by label" + ] + ol_ [class_ "toc-list"] do + traverse_ renderTocEntry tocBlocks + main_ do + h1_ (toHtml pageLabel) + traverse_ (renderBlock hintMap referenceContext) blockInfos + renderPreviewStore hintMap previews + div_ + [ id_ "reference-preview-popup" + , class_ "reference-preview-popup" + , makeAttributes "role" "tooltip" + , makeAttributes "aria-hidden" "true" + ] + skip + script_ + [src_ (htmlSupportScriptHref context)] + ("" :: Text) + Right result + +-- | Index every block target and every page's referenced markers once in +-- deterministic source order. Rendering a page subsequently performs only +-- marker lookups in the shared index. +buildRenderIndex + :: NonEmpty (ResolvedSource, [Block]) + -> (HtmlRenderIndex, NonEmpty HtmlPagePresentation) +buildRenderIndex sourceBlocks = + ( HtmlRenderIndex + (Map.fromList + [ ( targetMarker target + , IndexedReferenceTarget ordinal source target + ) + | (ordinal, (source, target)) <- + zip [1 :: Int ..] orderedTargets + ]) + , pages + ) + where + analysedPages = + uncurry analysePage <$> sourceBlocks + pages = + fst <$> analysedPages + orderedTargets = + [ (htmlPagePresentationSource page, target) + | (page, targets) <- NonEmpty.toList analysedPages + , target <- targets + ] + + analysePage source blocks = + ( HtmlPagePresentation + { htmlPagePresentationSource = source + , pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = + Map.fromList + [ (targetMarker, targetAnchorId) + | ReferenceTarget + { targetMarker + , targetAnchorId + } <- targets + ] + , pagePresentationReferencedMarkers = + foldMap + (\(_blockInfo, _targets, references) -> references) + analysedBlocks + } + , targets + ) + where + analysedBlocks = + [ ( blockInfo + , referenceTargetsOfBlockRenderInfo blockInfo + , collectReferencedMarkersOfBlock block + ) + | (index, block) <- zip [1 :: Int ..] blocks + , let blockInfo = + (index, block, blockAnchorId index block) + ] + blockInfos = + [ blockInfo + | (blockInfo, _targets, _references) <- analysedBlocks + ] + targets = + concat + [ blockTargets + | (_blockInfo, blockTargets, _references) <- analysedBlocks + ] + + +pageStyles :: Text +pageStyles = Text.unlines + [ ":root {" + , " color-scheme: light dark;" + , " font-family: Georgia, \"Times New Roman\", serif;" + , " --page-bg: #ffffff;" + , " --page-fg: #111111;" + , " --muted-fg: #666666;" + , " --subtle-fg: #444444;" + , " --badge-bg: #f1f1f1;" + , " --badge-border: #dddddd;" + , " --badge-fg: #555555;" + , " --rule-color: #d9d2c2;" + , " --error-fg: #9f1d1d;" + , " --error-bg: #fff1f1;" + , " --toc-active-bg: #f3efe6;" + , " --toc-active-fg: #1b1b1b;" + , " --toc-active-accent: #b9aa7a;" + , " --preview-bg: #fffdf8;" + , " --preview-border: #cfc3a3;" + , " --preview-shadow: rgba(0, 0, 0, 0.18);" + , "}" + , "html {" + , " height: 100%;" + , "}" + , "body {" + , " margin: 0;" + , " height: 100vh;" + , " overflow: hidden;" + , " line-height: 1.5;" + , " background: var(--page-bg);" + , " color: var(--page-fg);" + , "}" + , ".page-layout {" + , " display: grid;" + , " grid-template-columns: minmax(16rem, 24rem) minmax(0, 1fr);" + , " grid-template-rows: minmax(0, 1fr);" + , " gap: 2rem;" + , " align-items: stretch;" + , " box-sizing: border-box;" + , " margin: 0 auto;" + , " max-width: 84rem;" + , " height: 100vh;" + , " padding: 2rem 1.25rem 3rem;" + , "}" + , ".toc-column {" + , " display: block;" + , " min-height: 0;" + , "}" + , ".toc {" + , " display: flex;" + , " flex-direction: column;" + , " height: 100%;" + , " min-height: 0;" + , "}" + , ".toc-heading {" + , " margin: 0 0 0.75rem;" + , " color: var(--muted-fg);" + , " font-size: 0.9rem;" + , " letter-spacing: 0.04em;" + , " text-transform: uppercase;" + , "}" + , ".toc-filter {" + , " box-sizing: border-box;" + , " width: 100%;" + , " margin: 0 0 0.9rem;" + , " padding: 0.45rem 0.55rem;" + , " border: 1px solid var(--badge-border);" + , " border-radius: 0.35rem;" + , " background: var(--page-bg);" + , " color: var(--page-fg);" + , " font: inherit;" + , "}" + , ".toc-filter::placeholder {" + , " color: var(--muted-fg);" + , "}" + , ".toc-list {" + , " flex: 1 1 auto;" + , " min-height: 0;" + , " overflow-y: auto;" + , " list-style: none;" + , " margin: 0;" + , " padding: 0 0.5rem 0 0;" + , "}" + , ".toc-list > li {" + , " margin: 0 0 0.8rem;" + , "}" + , ".toc-list > li > a {" + , " display: block;" + , " margin: -0.15rem -0.35rem;" + , " padding: 0.15rem 0.35rem;" + , " border-radius: 0.35rem;" + , " color: inherit;" + , " text-decoration: none;" + , " transition: background-color 120ms ease, box-shadow 120ms ease, color 120ms ease;" + , "}" + , ".toc-list > li > a:hover," + , ".toc-list > li > a:focus-visible {" + , " text-decoration: underline;" + , "}" + , ".toc-list > li > a.is-active {" + , " background: var(--toc-active-bg);" + , " box-shadow: inset 0.2rem 0 0 var(--toc-active-accent);" + , " color: var(--toc-active-fg);" + , "}" + , ".toc-list > li > a.is-active > code {" + , " color: var(--toc-active-fg);" + , "}" + , ".toc-list > li > a > span:first-child {" + , " display: block;" + , " font-weight: 700;" + , "}" + , ".toc-list > li > a > code {" + , " display: block;" + , " margin-top: 0.15rem;" + , " color: var(--muted-fg);" + , " font-size: 0.9em;" + , " overflow-wrap: anywhere;" + , "}" + , "main {" + , " min-width: 0;" + , " min-height: 0;" + , " overflow-y: auto;" + , "}" + , "main > *[id] {" + , " display: block;" + , " margin: 0 0 1rem;" + , " scroll-margin-top: 1rem;" + , "}" + , "head- {" + , " font-weight: 700;" + , "}" + , "title- {" + , " font-weight: 400;" + , "}" + , "id-," + , "main a[href^=\"#\"]," + , ".ref-badge {" + , " display: inline-block;" + , " padding: 0.02rem 0.35rem;" + , " border: 1px solid var(--badge-border);" + , " border-radius: 0.2rem;" + , " background: var(--badge-bg);" + , " color: var(--badge-fg);" + , " font-family: \"SFMono-Regular\", Menlo, Consolas, \"Liberation Mono\", monospace;" + , " font-size: 0.82em;" + , " text-decoration: none;" + , "}" + , "head- > id- {" + , " margin-left: 0.45rem;" + , "}" + , "main a[href^=\"#\"]:hover," + , "main a[href^=\"#\"]:focus-visible," + , ".ref-badge.has-preview:hover," + , ".ref-badge.has-preview:focus-visible {" + , " text-decoration: underline;" + , "}" + , ".ref-badge.has-preview {" + , " cursor: help;" + , "}" + , ".ref-badge-group {" + , " user-select: none;" + , "}" + , "proof- > p:first-child," + , "proof- > details > summary + p {" + , " display: inline;" + , " margin: 0;" + , "}" + , "proof- proof- {" + , " display: block;" + , " margin: 0.5rem 0 0.5rem 1rem;" + , " padding-left: 0.75rem;" + , " border-left: 1px solid var(--rule-color);" + , "}" + , "proof- > details {" + , " margin: 0;" + , "}" + , "proof- > details > summary {" + , " cursor: pointer;" + , " font-weight: 700;" + , "}" + , "proof- > details > summary title- {" + , " font-weight: 400;" + , "}" + , "proof- > details > :not(summary) {" + , " margin-top: 0.5rem;" + , "}" + , "inductive- > details {" + , " margin-top: 0.75rem;" + , "}" + , "inductive- > details > summary {" + , " cursor: pointer;" + , " font-weight: 700;" + , "}" + , "inductive- > details > :not(summary) {" + , " margin-top: 0.5rem;" + , "}" + , ".inductive-derived-facts > li {" + , " margin: 0.35rem 0;" + , "}" + , ".inductive-derived-facts {" + , " margin: 0;" + , " padding-left: 1.5rem;" + , "}" + , ".reference-preview-store {" + , " display: none;" + , "}" + , ".reference-preview-popup {" + , " position: fixed;" + , " z-index: 1000;" + , " box-sizing: border-box;" + , " width: 44rem;" + , " max-width: calc(100vw - 2rem);" + , " max-height: 34rem;" + , " max-height: min(34rem, calc(100vh - 2rem));" + , " overflow: auto;" + , " overscroll-behavior: contain;" + , " padding: 0.75rem 0.9rem;" + , " border: 1px solid var(--preview-border);" + , " border-radius: 0.45rem;" + , " background: var(--preview-bg);" + , " color: var(--page-fg);" + , " box-shadow: 0 0.75rem 2.25rem var(--preview-shadow);" + , " opacity: 0;" + , " pointer-events: none;" + , " transform: translateY(0.2rem);" + , " transition: opacity 90ms ease, transform 90ms ease;" + , "}" + , ".reference-preview-popup[aria-hidden=\"true\"] {" + , " visibility: hidden;" + , "}" + , ".reference-preview-popup.is-visible {" + , " opacity: 1;" + , " pointer-events: auto;" + , " transform: translateY(0);" + , "}" + , ".reference-preview-popup * {" + , " box-sizing: border-box;" + , "}" + , ".reference-preview-template {" + , " display: flex;" + , " flex-direction: column;" + , " gap: 0.45rem;" + , " width: 100%;" + , "}" + , ".reference-preview-heading {" + , " display: block;" + , " margin: 0;" + , " width: 100%;" + , " color: var(--muted-fg);" + , " font-size: 0.82rem;" + , " letter-spacing: 0.035em;" + , " text-transform: uppercase;" + , "}" + , ".reference-preview-heading code {" + , " color: var(--page-fg);" + , " font-family: \"SFMono-Regular\", Menlo, Consolas, \"Liberation Mono\", monospace;" + , " letter-spacing: 0;" + , " text-transform: none;" + , "}" + , ".reference-preview-heading a {" + , " color: inherit;" + , " text-decoration: none;" + , "}" + , ".reference-preview-heading a:hover," + , ".reference-preview-heading a:focus-visible {" + , " text-decoration: underline;" + , "}" + , ".reference-preview-source {" + , " display: block;" + , " margin: 0;" + , " color: var(--subtle-fg);" + , " font-size: 0.78rem;" + , " letter-spacing: 0;" + , " text-transform: none;" + , "}" + , ".reference-preview-body {" + , " display: block;" + , " clear: both;" + , " margin: 0;" + , " width: 100%;" + , "}" + , ".reference-preview-body p {" + , " margin: 0.35rem 0 0;" + , "}" + , ".reference-preview-body p:first-child {" + , " margin-top: 0;" + , "}" + , ".reference-preview-group-template {" + , " display: flex;" + , " flex-direction: column;" + , " gap: 1rem;" + , " margin: 0;" + , " width: 100%;" + , "}" + , ".reference-preview-group-template > .reference-preview-template + .reference-preview-template {" + , " padding-top: 1rem;" + , " border-top: 1px solid var(--badge-border);" + , "}" + , ".reference-preview-statement {" + , " display: block;" + , " width: 100%;" + , " white-space: normal;" + , " overflow-wrap: break-word;" + , "}" + , ".reference-preview-statement math {" + , " max-width: 100%;" + , " overflow-x: auto;" + , " overflow-y: hidden;" + , " vertical-align: middle;" + , "}" + , "math[display=\"block\"] {" + , " display: block;" + , " margin: 0.5rem 0;" + , "}" + , "merror {" + , " color: var(--error-fg);" + , " background: var(--error-bg);" + , "}" + , "@media (prefers-color-scheme: dark) {" + , " :root {" + , " --page-bg: #161616;" + , " --page-fg: #e9e6df;" + , " --muted-fg: #b7b0a4;" + , " --subtle-fg: #cfc8bc;" + , " --badge-bg: #2a2a2a;" + , " --badge-border: #444444;" + , " --badge-fg: #d8d3ca;" + , " --rule-color: #5b5348;" + , " --error-fg: #ffb0b0;" + , " --error-bg: #3b1f1f;" + , " --toc-active-bg: #2b271f;" + , " --toc-active-fg: #f0ebe1;" + , " --toc-active-accent: #99865a;" + , " --preview-bg: #211f1a;" + , " --preview-border: #776a50;" + , " --preview-shadow: rgba(0, 0, 0, 0.55);" + , " }" + , "}" + , "@media (max-width: 900px) {" + , " body {" + , " height: auto;" + , " overflow: auto;" + , " }" + , " .page-layout {" + , " grid-template-columns: 1fr;" + , " grid-template-rows: auto;" + , " gap: 1.5rem;" + , " height: auto;" + , " }" + , " .toc-column {" + , " display: none;" + , " }" + , " main {" + , " min-height: auto;" + , " overflow: visible;" + , " }" + , "}" + ] + +supportScriptAssetContents :: Text +supportScriptAssetContents = tocScript <> "\n" <> referencePreviewScript + + +tocScript :: Text +tocScript = Text.unlines + [ "(function () {" + , " const toc = document.querySelector('.toc');" + , " const tocList = toc ? toc.querySelector('.toc-list') : null;" + , " const filterInput = toc ? toc.querySelector('.toc-filter') : null;" + , " const content = document.querySelector('main');" + , " if (!toc || !tocList || !content) return;" + , " const links = Array.from(tocList.querySelectorAll(':scope > li > a[href^=\"#\"]'));" + , " const blocks = Array.from(content.querySelectorAll(':scope > *[id]'));" + , " if (!links.length || !blocks.length) return;" + , " const linkByTarget = new Map(links.map((link) => [decodeURIComponent(link.hash.slice(1)), link]));" + , " const tocEntries = links.map((link) => ({" + , " item: link.parentElement," + , " link," + , " label: ((link.querySelector('code') || link.lastElementChild || link).textContent || '').trim().toLowerCase()" + , " }));" + , " let activeTarget = null;" + , " let rafId = 0;" + , " let suspendUntil = 0;" + , "" + , " const keepActiveLinkVisible = (link) => {" + , " if (!link || performance.now() < suspendUntil) return;" + , " const item = link.parentElement;" + , " if (item && item.hidden) return;" + , " const tocRect = tocList.getBoundingClientRect();" + , " const linkRect = link.getBoundingClientRect();" + , " const comfortTop = tocRect.top + tocRect.height * 0.2;" + , " const comfortBottom = tocRect.bottom - tocRect.height * 0.2;" + , " if (linkRect.top < comfortTop || linkRect.bottom > comfortBottom) {" + , " link.scrollIntoView({ block: 'nearest', inline: 'nearest' });" + , " }" + , " };" + , "" + , " const applyFilter = () => {" + , " const query = filterInput ? filterInput.value.trim().toLowerCase() : '';" + , " for (const { item, label } of tocEntries) {" + , " if (!item) continue;" + , " item.hidden = query !== '' && !label.includes(query);" + , " }" + , " if (activeTarget) {" + , " keepActiveLinkVisible(linkByTarget.get(activeTarget));" + , " }" + , " };" + , "" + , " const setActiveTarget = (target) => {" + , " if (!target || target === activeTarget) return;" + , " const previous = activeTarget ? linkByTarget.get(activeTarget) : null;" + , " if (previous) {" + , " previous.classList.remove('is-active');" + , " previous.removeAttribute('aria-current');" + , " }" + , " activeTarget = target;" + , " const next = linkByTarget.get(target);" + , " if (!next) return;" + , " next.classList.add('is-active');" + , " next.setAttribute('aria-current', 'location');" + , " keepActiveLinkVisible(next);" + , " };" + , "" + , " const firstTarget = blocks[0].id;" + , "" + , " const findActiveTarget = () => {" + , " const contentRect = content.getBoundingClientRect();" + , " const topSnapThreshold = 40;" + , " for (const block of blocks) {" + , " const target = block.id;" + , " const rect = block.getBoundingClientRect();" + , " if (rect.top >= contentRect.top - 4 && rect.top <= contentRect.top + topSnapThreshold) {" + , " return target;" + , " }" + , " }" + , " const activationLine = contentRect.top + contentRect.height * 0.22;" + , " let candidate = firstTarget;" + , " for (const block of blocks) {" + , " const target = block.id;" + , " if (block.getBoundingClientRect().top <= activationLine) {" + , " candidate = target;" + , " continue;" + , " }" + , " break;" + , " }" + , " return candidate;" + , " };" + , "" + , " const scheduleUpdate = () => {" + , " if (rafId) return;" + , " rafId = window.requestAnimationFrame(() => {" + , " rafId = 0;" + , " setActiveTarget(findActiveTarget());" + , " });" + , " };" + , "" + , " const suspendAutofollow = () => {" + , " suspendUntil = performance.now() + 1500;" + , " };" + , "" + , " const revealTarget = (target) => {" + , " let parent = target.parentElement;" + , " while (parent) {" + , " if (parent.localName === 'details') {" + , " parent.open = true;" + , " }" + , " parent = parent.parentElement;" + , " }" + , " };" + , "" + , " const scrollToTarget = (targetId) => {" + , " const target = document.getElementById(targetId);" + , " if (!target || !content.contains(target)) return false;" + , " revealTarget(target);" + , " target.scrollIntoView({ block: 'start', inline: 'nearest' });" + , " setActiveTarget(targetId);" + , " return true;" + , " };" + , "" + , " content.addEventListener('scroll', scheduleUpdate, { passive: true });" + , " window.addEventListener('resize', scheduleUpdate);" + , " tocList.addEventListener('wheel', suspendAutofollow, { passive: true });" + , " tocList.addEventListener('touchstart', suspendAutofollow, { passive: true });" + , " toc.addEventListener('pointerdown', suspendAutofollow);" + , " toc.addEventListener('focusin', suspendAutofollow);" + , " if (filterInput) {" + , " filterInput.addEventListener('input', applyFilter);" + , " }" + , " for (const details of content.querySelectorAll('details')) {" + , " details.addEventListener('toggle', scheduleUpdate);" + , " }" + , "" + , " toc.addEventListener('click', (event) => {" + , " const link = event.target.closest('a[href^=\"#\"]');" + , " if (!link || !tocList.contains(link)) return;" + , " const targetId = decodeURIComponent(link.hash.slice(1));" + , " if (!scrollToTarget(targetId)) return;" + , " event.preventDefault();" + , " suspendUntil = 0;" + , " if (location.hash !== '#' + targetId) {" + , " try {" + , " history.pushState(null, '', '#' + targetId);" + , " } catch (_error) {" + , " location.hash = targetId;" + , " }" + , " }" + , " });" + , "" + , " window.addEventListener('hashchange', () => {" + , " if (location.hash.length <= 1) return;" + , " const hashTarget = decodeURIComponent(location.hash.slice(1));" + , " if (!scrollToTarget(hashTarget)) scheduleUpdate();" + , " });" + , "" + , " if (location.hash.length > 1) {" + , " const hashTarget = decodeURIComponent(location.hash.slice(1));" + , " window.requestAnimationFrame(() => {" + , " applyFilter();" + , " if (!scrollToTarget(hashTarget)) scheduleUpdate();" + , " });" + , " return;" + , " }" + , "" + , " applyFilter();" + , " scheduleUpdate();" + , "})();" + ] + +referencePreviewScript :: Text +referencePreviewScript = Text.unlines + [ "(function () {" + , " const content = document.querySelector('main');" + , " const popup = document.getElementById('reference-preview-popup');" + , " if (!content || !popup) return;" + , " let activeTrigger = null;" + , " let lastPointer = null;" + , " let isPinned = false;" + , " let hideTimer = 0;" + , " const offset = 14;" + , " const margin = 12;" + , " const hideDelay = 180;" + , "" + , " const cloneHiddenPreview = (trigger) => {" + , " const previewId = trigger.getAttribute('data-preview-id');" + , " const template = previewId ? document.getElementById(previewId) : null;" + , " if (!template) return null;" + , " const clone = template.cloneNode(true);" + , " clone.removeAttribute('id');" + , " return clone;" + , " };" + , "" + , " const buildCurrentPreview = (trigger) => {" + , " const targetId = trigger.getAttribute('data-preview-target-id');" + , " const target = targetId ? document.getElementById(targetId) : null;" + , " if (!target || !content.contains(target)) return null;" + , " const template = document.createElement('div');" + , " template.className = 'reference-preview-template';" + , " const heading = document.createElement('div');" + , " heading.className = 'reference-preview-heading';" + , " const kind = target.getAttribute('data-preview-kind') || 'Reference';" + , " const label = target.getAttribute('data-preview-label') || targetId;" + , " const title = target.getAttribute('data-preview-title');" + , " heading.append(document.createTextNode(kind + ' '));" + , " const code = document.createElement('code');" + , " code.textContent = label;" + , " heading.append(code);" + , " if (title) {" + , " heading.append(document.createTextNode(' (' + title + ')'));" + , " }" + , " template.append(heading);" + , " const body = document.createElement('div');" + , " body.className = 'reference-preview-body';" + , " const statement = document.createElement('div');" + , " statement.className = 'reference-preview-statement';" + , " const head = Array.from(target.children).find((child) => child.localName === 'head-');" + , " const nodes = Array.from(target.childNodes);" + , " const start = head ? nodes.indexOf(head) + 1 : 0;" + , " for (const node of nodes.slice(start)) {" + , " statement.append(node.cloneNode(true));" + , " }" + , " if (!statement.childNodes.length) return null;" + , " body.append(statement);" + , " template.append(body);" + , " return template;" + , " };" + , "" + , " const buildMissingPreview = (item) => {" + , " const label = item.getAttribute('data-reference-label') || '';" + , " const template = document.createElement('div');" + , " template.className = 'reference-preview-template';" + , " const heading = document.createElement('div');" + , " heading.className = 'reference-preview-heading';" + , " heading.append(document.createTextNode('Reference '));" + , " const code = document.createElement('code');" + , " code.textContent = label;" + , " heading.append(code);" + , " template.append(heading);" + , " const body = document.createElement('div');" + , " body.className = 'reference-preview-body';" + , " const statement = document.createElement('p');" + , " statement.className = 'reference-preview-statement';" + , " statement.textContent = 'Preview unavailable.';" + , " body.append(statement);" + , " template.append(body);" + , " return template;" + , " };" + , "" + , " const linkGroupHeading = (item, template) => {" + , " const href = item.getAttribute('data-preview-link');" + , " if (!href) return template;" + , " const heading = template.querySelector('.reference-preview-heading');" + , " const code = heading ? heading.querySelector('code') : null;" + , " if (!heading || !code || code.closest('a')) return template;" + , " const link = document.createElement('a');" + , " link.href = href;" + , " link.append(code.cloneNode(true));" + , " code.replaceWith(link);" + , " return template;" + , " };" + , "" + , " const buildGroupPreview = (trigger) => {" + , " if (!trigger.hasAttribute('data-preview-group')) return null;" + , " const items = Array.from(trigger.querySelectorAll('.reference-preview-group-items > [data-reference-label]'));" + , " if (!items.length) return null;" + , " const template = document.createElement('div');" + , " template.className = 'reference-preview-group-template';" + , " for (const item of items) {" + , " const preview = cloneHiddenPreview(item) || buildCurrentPreview(item) || buildMissingPreview(item);" + , " template.append(linkGroupHeading(item, preview));" + , " }" + , " return template;" + , " };" + , "" + , " const previewFor = (trigger) => buildGroupPreview(trigger) || cloneHiddenPreview(trigger) || buildCurrentPreview(trigger);" + , "" + , " const clamp = (value, min, max) => Math.min(Math.max(value, min), max);" + , " const findTrigger = (target) => target instanceof Element ? target.closest('[data-preview-group], [data-preview-id], [data-preview-target-id]') : null;" + , " const clearHideTimer = () => {" + , " if (!hideTimer) return;" + , " window.clearTimeout(hideTimer);" + , " hideTimer = 0;" + , " };" + , "" + , " const hidePreview = () => {" + , " clearHideTimer();" + , " activeTrigger = null;" + , " lastPointer = null;" + , " isPinned = false;" + , " popup.classList.remove('is-visible');" + , " popup.setAttribute('aria-hidden', 'true');" + , " popup.replaceChildren();" + , " };" + , "" + , " const scheduleHide = () => {" + , " if (isPinned) return;" + , " clearHideTimer();" + , " hideTimer = window.setTimeout(() => {" + , " hideTimer = 0;" + , " if (!isPinned) hidePreview();" + , " }, hideDelay);" + , " };" + , "" + , " const placePreview = () => {" + , " if (!activeTrigger) return;" + , " const triggerRect = activeTrigger.getBoundingClientRect();" + , " const popupRect = popup.getBoundingClientRect();" + , " const fallbackWidth = Math.min(704, Math.max(0, window.innerWidth - margin * 2));" + , " const popupWidth = popupRect.width || fallbackWidth;" + , " const popupHeight = popupRect.height || 0;" + , " const pointer = lastPointer;" + , " const anchorX = pointer ? pointer.clientX : triggerRect.left;" + , " const anchorY = pointer ? pointer.clientY : triggerRect.bottom;" + , " let left = anchorX + (pointer ? offset : 0);" + , " let top = anchorY + offset;" + , " if (top + popupHeight + margin > window.innerHeight) {" + , " const upperAnchor = pointer ? pointer.clientY : triggerRect.top;" + , " top = Math.max(margin, upperAnchor - popupHeight - offset);" + , " }" + , " left = clamp(left, margin, Math.max(margin, window.innerWidth - popupWidth - margin));" + , " popup.style.left = `${left}px`;" + , " popup.style.top = `${top}px`;" + , " };" + , "" + , " const showPreview = (trigger, pointerEvent, pinned = false) => {" + , " const source = previewFor(trigger);" + , " if (!source) {" + , " hidePreview();" + , " return;" + , " }" + , " const wasPinned = isPinned && trigger === activeTrigger;" + , " clearHideTimer();" + , " activeTrigger = trigger;" + , " lastPointer = pointerEvent ? { clientX: pointerEvent.clientX, clientY: pointerEvent.clientY } : null;" + , " isPinned = pinned || wasPinned;" + , " popup.replaceChildren(source);" + , " popup.scrollTop = 0;" + , " popup.setAttribute('aria-hidden', 'false');" + , " popup.classList.add('is-visible');" + , " placePreview();" + , " };" + , "" + , " content.addEventListener('pointerover', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (!trigger || !content.contains(trigger) || trigger === activeTrigger) return;" + , " showPreview(trigger, event);" + , " });" + , "" + , " content.addEventListener('pointermove', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (!trigger || trigger !== activeTrigger) return;" + , " if (isPinned) return;" + , " lastPointer = { clientX: event.clientX, clientY: event.clientY };" + , " placePreview();" + , " });" + , "" + , " content.addEventListener('pointerout', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (!trigger || trigger !== activeTrigger) return;" + , " if (isPinned) return;" + , " const related = event.relatedTarget;" + , " if (related instanceof Node && trigger.contains(related)) return;" + , " if (related instanceof Node && popup.contains(related)) return;" + , " scheduleHide();" + , " });" + , "" + , " content.addEventListener('focusin', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (!trigger || !content.contains(trigger)) return;" + , " showPreview(trigger, null);" + , " });" + , "" + , " content.addEventListener('focusout', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (trigger && trigger === activeTrigger && !isPinned) scheduleHide();" + , " });" + , "" + , " content.addEventListener('click', (event) => {" + , " const trigger = findTrigger(event.target);" + , " if (!trigger || !trigger.hasAttribute('data-preview-group') || !content.contains(trigger)) return;" + , " event.preventDefault();" + , " showPreview(trigger, event, true);" + , " });" + , "" + , " popup.addEventListener('pointerenter', clearHideTimer);" + , " popup.addEventListener('pointerleave', scheduleHide);" + , "" + , " document.addEventListener('click', (event) => {" + , " if (!isPinned) return;" + , " const target = event.target;" + , " if (target instanceof Node && popup.contains(target)) return;" + , " if (activeTrigger && target instanceof Node && activeTrigger.contains(target)) return;" + , " hidePreview();" + , " });" + , "" + , " content.addEventListener('scroll', hidePreview, { passive: true });" + , " window.addEventListener('resize', hidePreview);" + , " window.addEventListener('hashchange', hidePreview);" + , " document.addEventListener('keydown', (event) => {" + , " if (event.key === 'Escape') {" + , " hidePreview();" + , " return;" + , " }" + , " if (event.key !== 'Enter' && event.key !== ' ') return;" + , " const trigger = findTrigger(document.activeElement);" + , " if (!trigger || !trigger.hasAttribute('data-preview-group')) return;" + , " event.preventDefault();" + , " showPreview(trigger, null, true);" + , " });" + , "})();" + ] + +collectReferencedMarkersOfBlock :: Block -> Set Marker +collectReferencedMarkersOfBlock = + collectBlock + where + collectBlock :: Block -> Set Marker + collectBlock = \case + BlockProof _start proof _end -> + collectProof proof + _ -> + mempty + + collectProof :: Proof -> Set Marker + collectProof = \case + Omitted _loc -> + mempty + Qed _loc justification -> + collectJustification justification + Contradiction _loc justification -> + collectJustification justification + ByCase _loc cases -> + foldMap collectCase cases + ByContradiction _loc proof -> + collectProof proof + BySetInduction _loc _term proof -> + collectProof proof + ByOrdInduction _loc proof -> + collectProof proof + Assume _loc _stmt proof -> + collectProof proof + FixSymbolic _loc _vars _bound proof -> + collectProof proof + FixSuchThat _loc _vars _stmt proof -> + collectProof proof + Calc _loc _maybeQuant calc proof -> + collectCalc calc <> collectProof proof + TakeVar _loc _vars _bound _stmt justification proof -> + collectJustification justification <> collectProof proof + TakeNoun _loc _np justification proof -> + collectJustification justification <> collectProof proof + Have _loc _maybeStmt _stmt justification proof -> + collectJustification justification <> collectProof proof + Suffices _loc _stmt justification proof -> + collectJustification justification <> collectProof proof + Subclaim _loc _stmt subproof proof -> + collectProof subproof <> collectProof proof + Define _loc _var _expr proof -> + collectProof proof + DefineFunction _loc _fun _arg _value _boundVar _boundExpr proof -> + collectProof proof + DefineFunctionLocal _loc _fun _arg _target _domVar _codVar _rules proof -> + collectProof proof + + collectCase :: Case -> Set Marker + collectCase Case{caseProof} = + collectProof caseProof + + collectCalc :: Calc -> Set Marker + collectCalc = \case + Equation _expr steps -> + foldMap (collectJustification . snd) steps + Biconditionals _formula steps -> + foldMap (collectJustification . snd) steps + + collectJustification :: Justification -> Set Marker + collectJustification = \case + JustificationRef markers -> + Set.fromList (toList markers) + JustificationSetExt -> + mempty + JustificationEmpty -> + mempty + JustificationLocal -> + mempty + +collectMissingHints :: HintMap -> [Block] -> MissingHintMap +collectMissingHints hints = foldMap collectBlock + where + noteMissingHint :: HintCategory -> Marker -> Int -> MissingHintMap + noteMissingHint category marker arity = + if Map.member (category, marker, arity) hints + then mempty + else MissingHintMap (Map.singleton category (Set.singleton marker)) + + collectBlock :: Block -> MissingHintMap + collectBlock = \case + BlockAxiom _loc _title _marker axiom -> + collectAxiom axiom + BlockClaim _kind _loc _title _marker claim -> + collectClaim claim + BlockProof _start proof _end -> + collectProof proof + BlockDefn _loc _title _marker defn -> + collectDefn defn + BlockAbbr _loc _title _marker abbr -> + collectAbbreviation abbr + BlockData _loc _title _marker datatype -> + collectDatatype datatype + BlockInductive _loc _title _marker ind -> + collectInductive ind + BlockSig _loc _title _marker asms sig -> + collectAsms asms + <> collectSignature sig + BlockStruct _loc _title _marker structDefn -> + collectStructDefn structDefn + + collectAxiom :: Axiom -> MissingHintMap + collectAxiom (Axiom asms stmt) = + collectAsms asms <> collectStmt stmt + + collectClaim :: Claim -> MissingHintMap + collectClaim (Claim asms stmt) = + collectAsms asms <> collectStmt stmt + + collectDefn :: Defn -> MissingHintMap + collectDefn = \case + Defn asms defnHead stmt -> + collectAsms asms + <> collectDefnHead defnHead + <> collectStmt stmt + DefnFun asms _fun maybeTerm resultTerm -> + collectAsms asms + <> foldMap collectTerm maybeTerm + <> collectTerm resultTerm + DefnOp symb expr -> + collectSymbolPattern symb + <> collectExpr expr + + collectDefnHead :: DefnHead -> MissingHintMap + collectDefnHead = \case + DefnAdj maybeNp _var _adj -> + foldMap collectNounPhraseMaybe maybeNp + DefnVerb maybeNp _var _verb -> + foldMap collectNounPhraseMaybe maybeNp + DefnNoun _var noun -> + collectVarNoun noun + DefnSymbolicPredicate _predi marker vars -> + noteMissingHint PredicateHint marker (length vars) + <> foldMap (collectExpr . ExprVar) vars + DefnRel _x rel params _y -> + noteMissingHint RelationHint (relationSymbolMarker rel) (length params) + + collectAbbreviation :: Abbreviation -> MissingHintMap + collectAbbreviation = \case + AbbreviationAdj _var _adj stmt -> + collectStmt stmt + AbbreviationVerb _var _verb stmt -> + collectStmt stmt + AbbreviationNoun _var _noun stmt -> + collectStmt stmt + AbbreviationRel _x rel params _y stmt -> + noteMissingHint RelationHint (relationSymbolMarker rel) (length params) + <> collectStmt stmt + AbbreviationFun _fun bodyTerm -> + collectTerm bodyTerm + AbbreviationEq symb expr -> + collectSymbolPattern symb + <> collectExpr expr + + collectDatatype :: Datatype -> MissingHintMap + collectDatatype Datatype{..} = + collectExpr datatypeHeadExpr + <> foldMap collectDatatypeClause datatypeClauses + + collectDatatypeClause :: DatatypeClause -> MissingHintMap + collectDatatypeClause DatatypeClause{..} = + collectExpr datatypeClauseConstructorExpr + <> collectExpr datatypeClauseTargetExpr + <> foldMap (collectExpr . snd) datatypeClausePremises + + collectInductive :: Inductive -> MissingHintMap + collectInductive Inductive{..} = + collectSymbolPattern inductiveSymbolPattern + <> collectExpr inductiveDomain + <> foldMap collectIntroRule inductiveIntros + + collectIntroRule :: IntroRule -> MissingHintMap + collectIntroRule IntroRule{..} = + foldMap collectFormula introConditions + <> collectFormula introResult + + collectSignature :: Signature -> MissingHintMap + collectSignature = \case + SignatureAdj _var adj -> + collectVarAdj adj + SignatureVerb _var verb -> + collectVarVerb verb + SignatureNoun _var noun -> + collectVarNoun noun + SignatureSymbolic symb np -> + collectSymbolPattern symb + <> collectNounPhraseMaybe np + + collectStructDefn :: StructDefn -> MissingHintMap + collectStructDefn StructDefn{structAssumes} = + foldMap (collectStmt . snd) structAssumes + + collectProof :: Proof -> MissingHintMap + collectProof = \case + Omitted _loc -> + mempty + Qed{} -> + mempty + Contradiction{} -> + mempty + ByCase _loc cases -> + foldMap collectCase cases + ByContradiction _loc proof -> + collectProof proof + BySetInduction _loc maybeTerm proof -> + foldMap collectTerm maybeTerm + <> collectProof proof + ByOrdInduction _loc proof -> + collectProof proof + Assume _loc stmt proof -> + collectStmt stmt + <> collectProof proof + FixSymbolic _loc _vars bound proof -> + collectBound bound + <> collectProof proof + FixSuchThat _loc _vars stmt proof -> + collectStmt stmt + <> collectProof proof + Calc _loc maybeQuant calc proof -> + foldMap collectCalcQuantifier maybeQuant + <> collectCalc calc + <> collectProof proof + TakeVar _loc _vars bound stmt _justification proof -> + collectBound bound + <> collectStmt stmt + <> collectProof proof + TakeNoun _loc np _justification proof -> + collectNounPhraseList np + <> collectProof proof + Have _loc maybeStmt stmt _justification proof -> + foldMap collectStmt maybeStmt + <> collectStmt stmt + <> collectProof proof + Suffices _loc stmt _justification proof -> + collectStmt stmt + <> collectProof proof + Subclaim _loc stmt subproof proof -> + collectStmt stmt + <> collectProof subproof + <> collectProof proof + Define _loc _var expr proof -> + collectExpr expr + <> collectProof proof + DefineFunction _loc _fun _arg value _boundVar boundExpr proof -> + collectExpr value + <> collectExpr boundExpr + <> collectProof proof + DefineFunctionLocal _loc _fun _arg _target _domVar _codVar rules proof -> + foldMap collectLocalFunctionRule rules + <> collectProof proof + + collectLocalFunctionRule :: (Expr, Formula) -> MissingHintMap + collectLocalFunctionRule (ruleTerm, formula) = + collectExpr ruleTerm + <> collectFormula formula + + collectCase :: Case -> MissingHintMap + collectCase Case{caseOf, caseProof} = + collectStmt caseOf + <> collectProof caseProof + + collectCalcQuantifier :: CalcQuantifier -> MissingHintMap + collectCalcQuantifier (CalcQuantifier _vars bound maybeStmt) = + collectBound bound + <> foldMap collectStmt maybeStmt + + collectCalc :: Calc -> MissingHintMap + collectCalc = \case + Equation expr steps -> + collectExpr expr + <> foldMap (collectExpr . fst) steps + Biconditionals phi steps -> + collectFormula phi + <> foldMap (collectFormula . fst) steps + + collectStmt :: Stmt -> MissingHintMap + collectStmt = \case + StmtFormula phi -> + collectFormula phi + StmtVerbPhrase terms verbPhrase -> + collectTerms terms + <> collectVerbPhrase verbPhrase + StmtNoun terms np -> + collectTerms terms + <> collectNounPhraseMaybe np + StmtStruct stmtTerm _structPhrase -> + collectTerm stmtTerm + StmtNeg _loc stmt -> + collectStmt stmt + StmtExists _loc np -> + collectNounPhraseList np + StmtConnected _conn _loc stmt1 stmt2 -> + collectStmt stmt1 + <> collectStmt stmt2 + StmtQuantPhrase _loc qp stmt -> + collectQuantPhrase qp + <> collectStmt stmt + SymbolicQuantified _loc _quant _vars bound suchThat stmt -> + collectBound bound + <> foldMap collectStmt suchThat + <> collectStmt stmt + + collectQuantPhrase :: QuantPhrase -> MissingHintMap + collectQuantPhrase (QuantPhrase _quant np) = + collectNounPhraseList np + + collectAsm :: Asm -> MissingHintMap + collectAsm = \case + AsmSuppose stmt -> + collectStmt stmt + AsmLetNoun _vars np -> + collectNounPhraseMaybe np + AsmLetIn _vars expr -> + collectExpr expr + AsmLetThe _var fun -> + collectFun fun + AsmLetEq _var expr -> + collectExpr expr + AsmLetStruct{} -> + mempty + + collectTerm :: Term -> MissingHintMap + collectTerm = \case + TermExpr expr -> + collectExpr expr + TermFun fun -> + collectFun fun + TermIota _loc _var stmt -> + collectStmt stmt + TermQuantified _quant _loc np -> + collectNounPhraseMaybe np + + collectNounPhraseMaybe :: NounPhrase Maybe -> MissingHintMap + collectNounPhraseMaybe (NounPhrase ls noun _maybeName rs maybeSuchThat) = + collectAdjLs ls + <> collectNoun noun + <> collectAdjRs rs + <> foldMap collectStmt maybeSuchThat + + collectNounPhraseList :: NounPhrase [] -> MissingHintMap + collectNounPhraseList (NounPhrase ls noun _names rs maybeSuchThat) = + collectAdjLs ls + <> collectNoun noun + <> collectAdjRs rs + <> foldMap collectStmt maybeSuchThat + + collectAdjL :: AdjLOf Term -> MissingHintMap + collectAdjL (AdjL _loc _item args) = + collectTerms args + + collectAdjR :: AdjROf Term -> MissingHintMap + collectAdjR = \case + AdjR _loc _item args -> + collectTerms args + AttrRThat verbPhrase -> + collectVerbPhrase verbPhrase + + collectAdj :: AdjOf Term -> MissingHintMap + collectAdj (Adj _loc _item args) = + collectTerms args + + collectVarAdj :: AdjOf VarSymbol -> MissingHintMap + collectVarAdj _adj = + mempty + + collectVerb :: VerbOf Term -> MissingHintMap + collectVerb (Verb _loc _item args) = + collectTerms args + + collectVarVerb :: VerbOf VarSymbol -> MissingHintMap + collectVarVerb _verb = + mempty + + collectVerbPhrase :: VerbPhrase -> MissingHintMap + collectVerbPhrase = \case + VPVerb verb -> + collectVerb verb + VPAdj adjs -> + foldMap collectAdj adjs + VPVerbNot verb -> + collectVerb verb + VPAdjNot adjs -> + foldMap collectAdj adjs + + collectNoun :: NounOf Term -> MissingHintMap + collectNoun (Noun _loc _item args) = + collectTerms args + + collectVarNoun :: NounOf VarSymbol -> MissingHintMap + collectVarNoun _noun = + mempty + + collectFun :: FunOf Term -> MissingHintMap + collectFun Fun{funArgs} = + collectTerms funArgs + + collectBound :: Bound -> MissingHintMap + collectBound = \case + Unbounded -> + mempty + Bounded _loc _sign rel expr -> + collectRelation rel + <> collectExpr expr + + collectFormula :: Formula -> MissingHintMap + collectFormula = \case + FormulaChain chain -> + collectChain chain + FormulaPredicate _loc _predi marker exprs -> + noteMissingHint PredicateHint marker (length exprs) + <> collectExprs exprs + Connected _loc _conn phi psi -> + collectFormula phi + <> collectFormula psi + FormulaNeg _loc phi -> + collectFormula phi + FormulaQuantified _loc _quant _vars bound phi -> + collectBound bound + <> collectFormula phi + PropositionalConstant{} -> + mempty + + collectChain :: Chain -> MissingHintMap + collectChain = \case + ChainBase lhs _sign rel rhs -> + collectExprs lhs + <> collectRelation rel + <> collectExprs rhs + ChainCons lhs _sign rel chain -> + collectExprs lhs + <> collectRelation rel + <> collectChain chain + + collectRelation :: Relation -> MissingHintMap + collectRelation = \case + Relation _loc symbol relParams -> + noteMissingHint RelationHint (relationSymbolMarker symbol) (length relParams) + <> collectExprs relParams + RelationExpr _loc expr -> + collectExpr expr + + collectExpr :: Expr -> MissingHintMap + collectExpr = \case + ExprVar{} -> + mempty + ExprInteger{} -> + mempty + ExprOp _loc item args -> + noteMissingHint OperatorHint (mixfixMarker item) (length args) + <> collectExprs args + ExprStructOp _loc symb maybeExpr -> + noteMissingHint StructOpHint (structMarker symb) (length (maybeToList maybeExpr)) + <> foldMap collectExpr maybeExpr + ExprFiniteSet _loc exprs -> + collectExprs exprs + ExprSep _loc _var boundExpr stmt -> + collectExpr boundExpr + <> collectStmt stmt + ExprReplace _loc expr bounds maybeStmt -> + collectExpr expr + <> foldMap (collectExpr . snd) bounds + <> foldMap collectStmt maybeStmt + ExprReplacePred _loc _rangeVar _domVar domExpr stmt -> + collectExpr domExpr + <> collectStmt stmt + + collectSymbolPattern :: SymbolPattern -> MissingHintMap + collectSymbolPattern (SymbolPattern symbol vars) = + noteMissingHint OperatorHint (mixfixMarker symbol) (length vars) + + collectAsms :: [Asm] -> MissingHintMap + collectAsms = + foldMap collectAsm + + collectTerms :: Foldable t => t Term -> MissingHintMap + collectTerms = + foldMap collectTerm + + collectAdjLs :: [AdjLOf Term] -> MissingHintMap + collectAdjLs = + foldMap collectAdjL + + collectAdjRs :: [AdjROf Term] -> MissingHintMap + collectAdjRs = + foldMap collectAdjR + + collectExprs :: Foldable t => t Expr -> MissingHintMap + collectExprs = + foldMap collectExpr + +formatMissingHintWarning :: MissingHintMap -> Maybe Text +formatMissingHintWarning missingHints + | null parts = Nothing + | otherwise = Just ("WARNING: missing render hints: " <> Text.intercalate "; " parts) + where + missingHintMap = unMissingHintMap missingHints + + parts = + [ label <> "(" <> Text.intercalate ", " (markerText <$> Set.toAscList markers) <> ")" + | (category, label) <- categoryLabels + , Just markers <- [Map.lookup category missingHintMap] + , not (Set.null markers) + ] + + categoryLabels :: [(HintCategory, Text)] + categoryLabels = + [ (OperatorHint, "operators") + , (RelationHint, "relations") + , (PredicateHint, "predicates") + , (StructOpHint, "structops") + ] + + +parseHints :: Text -> HintMap +parseHints source = Map.fromList (parseLine <$> zip [1 :: Int ..] relevantLines) + where + relevantLines = [line | line <- Text.lines source, not (Text.all isSpace line)] + + parseLine :: (Int, Text) -> ((HintCategory, Marker, Int), RenderHint) + parseLine (lineNo, line) = case Text.splitOn "\t" line of + [categoryText, markerName, arityText, templateText] -> + let category = parseCategory lineNo categoryText + marker = Marker markerName + arity = parseArity lineNo arityText + template = parseTemplate lineNo templateText + in ((category, marker, arity), RenderHint arity template) + _ -> + error ("Malformed render hint at line " <> show lineNo <> ": expected exactly 4 tab-separated columns") + +parseCategory :: Int -> Text -> HintCategory +parseCategory lineNo = \case + "operator" -> OperatorHint + "relation" -> RelationHint + "predicate" -> PredicateHint + "structop" -> StructOpHint + other -> error ("Unknown render hint category at line " <> show lineNo <> ": " <> Text.unpack other) + +parseArity :: Int -> Text -> Int +parseArity lineNo text = case reads (Text.unpack text) of + [(n, "")] -> n + _ -> error ("Malformed render-hint arity at line " <> show lineNo <> ": " <> Text.unpack text) + +parseTemplate :: Int -> Text -> [TemplatePiece] +parseTemplate lineNo template = reverse (flush mempty (go mempty [] template)) + where + go :: Text -> [TemplatePiece] -> Text -> [TemplatePiece] + go literal acc rest = case parseSlot rest of + Just (slot, rest') -> + go mempty (Slot slot : flush literal acc) rest' + Nothing -> case Text.uncons rest of + Nothing -> flush literal acc + Just (c, rest') -> go (Text.snoc literal c) acc rest' + + flush :: Text -> [TemplatePiece] -> [TemplatePiece] + flush literal acc + | Text.null literal = acc + | otherwise = Literal literal : acc + + parseSlot :: Text -> Maybe (Int, Text) + parseSlot text = do + text' <- Text.stripPrefix "<x" text + (digit, rest) <- Text.uncons text' + guard (isDigit digit) + rest' <- Text.stripPrefix "/>" rest + let slot = digitToInt digit + guard (slot > 0 && slot <= 9) + pure (slot, rest') + + _unusedLineNo = lineNo + + +renderBlock :: HintMap -> ReferenceContext -> BlockRenderInfo -> Html () +renderBlock hints references (_index, block, blockId) = case block of + BlockAxiom _loc title marker axiom -> + renderCustomBlock blockId "axiom-" "Axiom" (Just marker) title (renderAxiom hints axiom) + BlockClaim kind _loc title marker claim -> + renderCustomBlock blockId (claimKindElement kind) (claimKindPrefix kind) (Just marker) title (renderClaim hints claim) + BlockProof _start proof _end -> + renderProofBlock hints references proof + BlockDefn _loc title marker defn -> + renderCustomBlock blockId "definition-" "Definition" (Just marker) title (renderDefn hints defn) + BlockAbbr _loc title marker abbr -> + renderCustomBlock blockId "abbreviation-" "Abbreviation" (Just marker) title (renderAbbreviation hints abbr) + BlockData _loc title marker datatype -> + renderCustomBlock blockId "datatype-" "Datatype" (Just marker) title (renderDatatype hints datatype) + BlockInductive _loc title marker ind -> + renderCustomBlock blockId "inductive-" "Inductive" (Just marker) title (renderInductive hints marker ind) + BlockSig _loc title marker asms sig -> + renderCustomBlock blockId "signature-" "Signature" (Just marker) title (renderSignatureBlock hints asms sig) + BlockStruct _loc title marker structDefn -> + renderCustomBlock blockId "struct-" "Structure" (Just marker) title (renderStructDefn hints structDefn) + +renderTocEntry :: (Int, Text, Block) -> Html () +renderTocEntry (index, blockId, block) = + li_ do + a_ [href_ (renderUrlFragment blockId)] do + span_ (toHtml (blockPrefixText block)) + case formatMarker (blockMarkerOf block) of + Nothing -> + when (blockNeedsIndexLabel block) do + code_ (toHtml (Text.pack (show index))) + Just marker -> + code_ (toHtml marker) + +includeInToc :: Block -> Bool +includeInToc = \case + BlockProof{} -> False + _ -> True + +renderCustomBlock :: Text -> Text -> Text -> Maybe Marker -> Maybe BlockTitle -> Html () -> Html () +renderCustomBlock blockId name prefix mmarker mtitle body = + term name (id_ blockId : previewTargetAttributes prefix mmarker mtitle) do + renderBlockLead prefix mmarker mtitle True + body + +previewTargetAttributes :: Text -> Maybe Marker -> Maybe BlockTitle -> [Attributes] +previewTargetAttributes prefix mmarker mtitle = + case formatMarker mmarker of + Nothing -> + [] + Just marker -> + [ makeAttributes "data-preview-kind" prefix + , makeAttributes "data-preview-label" marker + ] + <> case formatBlockTitle mtitle of + Nothing -> + [] + Just title -> + [makeAttributes "data-preview-title" title] + +renderProofBlock :: HintMap -> ReferenceContext -> Proof -> Html () +renderProofBlock hints references proof + | proofStepCount proof >= proofCollapseThreshold = + term "proof-" do + details_ do + summary_ (renderBlockLead "Proof" Nothing Nothing False) + renderProof hints references proof + | otherwise = + term "proof-" do + renderBlockLead "Proof" Nothing Nothing True + renderProof hints references proof + +blockAnchorId :: Int -> Block -> Text +blockAnchorId index block = + case formatMarker (blockMarkerOf block) of + Just marker -> marker + Nothing -> sanitizeIdFragment (Text.toLower (blockPrefixText block) <> "-" <> Text.pack (show index)) + +sanitizeIdFragment :: Text -> Text +sanitizeIdFragment = + Text.dropWhile (== '-') . Text.map sanitize . Text.toLower + where + sanitize c + | isAlphaNum c = c + | c == '-' || c == '_' = c + | otherwise = '-' + +blockPrefixText :: Block -> Text +blockPrefixText = \case + BlockAxiom{} -> "Axiom" + BlockClaim kind _ _ _ _ -> claimKindPrefix kind + BlockProof{} -> "Proof" + BlockDefn{} -> "Definition" + BlockAbbr{} -> "Abbreviation" + BlockData{} -> "Datatype" + BlockInductive{} -> "Inductive" + BlockSig{} -> "Signature" + BlockStruct{} -> "Structure" + +blockMarkerOf :: Block -> Maybe Marker +blockMarkerOf = \case + BlockAxiom _ _ marker _ -> Just marker + BlockClaim _ _ _ marker _ -> Just marker + BlockProof{} -> Nothing + BlockDefn _ _ marker _ -> Just marker + BlockAbbr _ _ marker _ -> Just marker + BlockData _ _ marker _ -> Just marker + BlockInductive _ _ marker _ -> Just marker + BlockSig _ _ marker _ _ -> Just marker + BlockStruct _ _ marker _ -> Just marker + +blockTitleOf :: Block -> Maybe BlockTitle +blockTitleOf = \case + BlockAxiom _ title _ _ -> title + BlockClaim _ _ title _ _ -> title + BlockProof{} -> Nothing + BlockDefn _ title _ _ -> title + BlockAbbr _ title _ _ -> title + BlockData _ title _ _ -> title + BlockInductive _ title _ _ -> title + BlockSig _ title _ _ _ -> title + BlockStruct _ title _ _ -> title + +blockNeedsIndexLabel :: Block -> Bool +blockNeedsIndexLabel block = case (formatMarker (blockMarkerOf block), formatBlockTitle (blockTitleOf block)) of + (Nothing, Nothing) -> True + _ -> False + +renderBlockLead :: Text -> Maybe Marker -> Maybe BlockTitle -> Bool -> Html () +renderBlockLead prefix mmarker mtitle withTrailingSpace = + term "head-" do + toHtml prefix + case formatMarker mmarker of + Nothing -> skip + Just marker -> + term "id-" (toHtml marker) + case formatBlockTitle mtitle of + Nothing -> + toHtml ("." <> suffix) + Just title -> do + toHtml (" (" :: Text) + term "title-" (toHtml title) + toHtml (")." <> suffix) + where + suffix :: Text + suffix + | withTrailingSpace = " " + | otherwise = "" + +formatMarker :: Maybe Marker -> Maybe Text +formatMarker = \case + Nothing -> Nothing + Just marker -> + let text = Text.strip (markerText marker) + in if Text.null text then Nothing else Just text + +formatBlockTitle :: Maybe BlockTitle -> Maybe Text +formatBlockTitle = + fmap capitalizeTitle . nonEmptyTitle + where + nonEmptyTitle = \case + Nothing -> Nothing + Just toks -> + let text = Text.strip (Text.unwords (tokToText <$> toks)) + in if Text.null text then Nothing else Just text + +capitalizeTitle :: Text -> Text +capitalizeTitle text = case Text.uncons text of + Nothing -> text + Just (c, rest) -> Text.cons (toUpper c) rest + +claimKindElement :: ClaimKind -> Text +claimKindElement = \case + Proposition -> "proposition-" + Theorem -> "theorem-" + Lemma -> "lemma-" + Corollary -> "corollary-" + PlainClaim -> "claim-" + +claimKindPrefix :: ClaimKind -> Text +claimKindPrefix = \case + Proposition -> "Proposition" + Theorem -> "Theorem" + Lemma -> "Lemma" + Corollary -> "Corollary" + PlainClaim -> "Claim" + + +renderAxiom :: HintMap -> Axiom -> Html () +renderAxiom hints (Axiom asms stmt) = + renderWithAssumptions hints asms stmt + +renderClaim :: HintMap -> Claim -> Html () +renderClaim hints (Claim asms stmt) = + renderWithAssumptions hints asms stmt + +renderWithAssumptions :: HintMap -> [Asm] -> Stmt -> Html () +renderWithAssumptions hints asms stmt = do + case asms of + [] -> renderStmtInline hints stmt + _ -> do + toHtml ("Suppose " :: Text) + renderAsmList hints asms + toHtml (". Then " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + +renderDefn :: HintMap -> Defn -> Html () +renderDefn hints = \case + Defn asms headStmt stmt -> + do + when (not (null asms)) do + toHtml ("If " :: Text) + renderAsmList hints asms + toHtml (", then " :: Text) + renderDefnHead hints headStmt + toHtml (" iff " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + DefnFun asms fun maybeSymbol resultTerm -> + do + when (not (null asms)) do + toHtml ("If " :: Text) + renderAsmList hints asms + toHtml (", then " :: Text) + renderFunInline renderVarInline fun + case maybeSymbol of + Nothing -> skip + Just symbolicTerm -> do + toHtml (", " :: Text) + renderTermInline hints symbolicTerm + toHtml (" is " :: Text) + renderTermInline hints resultTerm + toHtml ("." :: Text) + DefnOp symb expr -> + do + inlineMath do + renderSymbolPatternMath hints symb + moText "=" + renderExprMathRow hints expr + toHtml ("." :: Text) + +renderDefnHead :: HintMap -> DefnHead -> Html () +renderDefnHead hints = \case + DefnAdj maybeNp var adj -> do + renderTypedVar hints maybeNp var + toHtml (" is " :: Text) + renderAdjInline renderVarInline adj + DefnVerb maybeNp var verb -> do + renderTypedVar hints maybeNp var + toHtml (" " :: Text) + renderVerbInline False renderVarInline verb + DefnNoun var noun -> do + renderVarInline var + toHtml (" is a " :: Text) + renderNounInline False renderVarInline noun + DefnSymbolicPredicate predi marker vars -> + inlineMath + ( renderHintedMathRow + hints + PredicateHint + marker + (ExprVar <$> toList vars) + (renderPrefixPredicateFallback predi (renderVarMath <$> toList vars)) + ) + DefnRel x rel params y -> + inlineMath (renderRelationApplication hints Positive [ExprVar x] (Relation Nowhere rel [ExprVar p | p <- params]) [ExprVar y]) + +renderTypedVar :: HintMap -> Maybe (NounPhrase Maybe) -> VarSymbol -> Html () +renderTypedVar hints = \case + Nothing -> renderVarInline + Just np -> \var -> do + renderNounPhraseMaybe hints np + toHtml (" " :: Text) + renderVarInline var + + +renderAbbreviation :: HintMap -> Abbreviation -> Html () +renderAbbreviation hints = \case + AbbreviationAdj var adj stmt -> + do + renderVarInline var + toHtml (" is " :: Text) + renderAdjInline renderVarInline adj + toHtml (" stands for " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + AbbreviationVerb var verb stmt -> + do + renderVarInline var + toHtml (" " :: Text) + renderVerbInline False renderVarInline verb + toHtml (" stands for " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + AbbreviationNoun var noun stmt -> + do + renderVarInline var + toHtml (" is a " :: Text) + renderNounInline False renderVarInline noun + toHtml (" stands for " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + AbbreviationRel x rel params y stmt -> + do + inlineMath (renderRelationApplication hints Positive [ExprVar x] (Relation Nowhere rel [ExprVar p | p <- params]) [ExprVar y]) + toHtml (" stands for " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + AbbreviationFun fun bodyTerm -> + do + renderFunInline renderVarInline fun + toHtml (" stands for " :: Text) + renderTermInline hints bodyTerm + toHtml ("." :: Text) + AbbreviationEq symb expr -> + do + renderSymbolPatternInline hints symb + toHtml (" stands for " :: Text) + inlineMath (renderExprMathRow hints expr) + toHtml ("." :: Text) + +renderDatatype :: HintMap -> Datatype -> Html () +renderDatatype hints Datatype{..} = do + toHtml ("Datatype of " :: Text) + inlineMath (renderExprMathRow hints datatypeHeadExpr) + toHtml ("." :: Text) + ul_ do + traverse_ renderDatatypeClause (toList datatypeClauses) + -- Derived facts require checked semantic context. + where + renderDatatypeClause :: DatatypeClause -> Html () + renderDatatypeClause DatatypeClause{..} = li_ do + inlineMath do + renderRelationApplication hints Positive [datatypeClauseConstructorExpr] (Relation Nowhere ElementSymbol []) [datatypeClauseTargetExpr] + case datatypeClausePremises of + [] -> + toHtml ("." :: Text) + premises -> do + toHtml (" for " :: Text) + joinHtml (toHtml (" and " :: Text)) (renderDatatypePremise <$> premises) + toHtml ("." :: Text) + + renderDatatypePremise :: (VarSymbol, Expr) -> Html () + renderDatatypePremise (x, domain) = + inlineMath (renderRelationApplication hints Positive [ExprVar x] (Relation Nowhere ElementSymbol []) [domain]) + +exprVar :: Expr -> Maybe VarSymbol +exprVar = \case + ExprVar x -> + Just x + _ -> + Nothing + +substituteExpr :: Map.Map VarSymbol Expr -> Expr -> Expr +substituteExpr env = \case + ExprVar x -> + fromMaybe (ExprVar x) (Map.lookup x env) + ExprInteger loc n -> + ExprInteger loc n + ExprOp loc symbol args -> + ExprOp loc symbol (substituteExpr env <$> args) + ExprStructOp loc symbol expr -> + ExprStructOp loc symbol (substituteExpr env <$> expr) + ExprFiniteSet loc exprs -> + ExprFiniteSet loc (substituteExpr env <$> exprs) + ExprSep loc x bound stmt -> + ExprSep loc x (substituteExpr env bound) stmt + ExprReplace loc expr bounds maybeStmt -> + ExprReplace loc (substituteExpr env expr) ((\(x, bound) -> (x, substituteExpr env bound)) <$> bounds) maybeStmt + ExprReplacePred loc x y expr stmt -> + ExprReplacePred loc x y (substituteExpr env expr) stmt + +elementOfFormula :: Expr -> Expr -> Formula +elementOfFormula left right = + FormulaChain (ChainBase (left :| []) Positive (Relation Nowhere ElementSymbol []) (right :| [])) + +semanticSubsetFormula :: Set VarSymbol -> Expr -> Expr -> Formula +semanticSubsetFormula reserved left right = + forallIfNeeded [witnessVar] + (impliesFormula + (elementOfFormula (ExprVar witnessVar) left) + (elementOfFormula (ExprVar witnessVar) right)) + where + witnessVar = freshDatatypeVar (reserved <> Set.fromList (exprVars left <> exprVars right)) "x" + +equalsFormula :: Expr -> Expr -> Formula +equalsFormula left right = + FormulaChain (ChainBase (left :| []) Positive (Relation Nowhere EqSymbol []) (right :| [])) + +impliesFormula :: Formula -> Formula -> Formula +impliesFormula left right = + Connected Nowhere Implication left right + +formulaConjunction :: [Formula] -> Formula +formulaConjunction = \case + [] -> + PropositionalConstant Nowhere IsTop + phi : rest -> + foldl' (\left right -> Connected Nowhere Conjunction left right) phi rest + +formulaDisjunction :: [Formula] -> Formula +formulaDisjunction = \case + [] -> + PropositionalConstant Nowhere IsBottom + phi : rest -> + foldl' (\left right -> Connected Nowhere Disjunction left right) phi rest + +forallIfNeeded :: [VarSymbol] -> Formula -> Formula +forallIfNeeded [] phi = phi +forallIfNeeded vars phi = + FormulaQuantified Nowhere Universally (NonEmpty.fromList vars) Unbounded phi + +existsIfNeeded :: [VarSymbol] -> Formula -> Formula +existsIfNeeded [] phi = phi +existsIfNeeded vars phi = + FormulaQuantified Nowhere Existentially (NonEmpty.fromList vars) Unbounded phi + +impliesFrom :: [Formula] -> Formula -> Formula +impliesFrom [] conclusion = conclusion +impliesFrom premises conclusion = impliesFormula (formulaConjunction premises) conclusion + +freshDatatypeVar :: Set VarSymbol -> Text -> VarSymbol +freshDatatypeVar used base = + List.head + [ NamedVar candidate + | candidate <- base : [base <> Text.pack (show n) | n <- [(1 :: Int) ..]] + , NamedVar candidate `Set.notMember` used + ] + +renderInductive :: HintMap -> Marker -> Inductive -> Html () +renderInductive hints marker Inductive{..} = do + toHtml ("Inductive definition of " :: Text) + renderSymbolPatternInline hints inductiveSymbolPattern + toHtml (" over " :: Text) + inlineMath (renderExprMathRow hints inductiveDomain) + toHtml ("." :: Text) + ul_ do + traverse_ renderIntro (toList inductiveIntros) + case inductiveDerivedFacts marker Inductive{..} of + [] -> + skip + derivedFacts -> + details_ do + summary_ (toHtml ("Derived facts" :: Text)) + ul_ [class_ "inductive-derived-facts"] do + traverse_ (renderInductiveDerivedFact hints) derivedFacts + where + renderIntro :: IntroRule -> Html () + renderIntro IntroRule{..} = li_ do + case introConditions of + [] -> skip + _ -> do + toHtml ("If " :: Text) + joinHtml (toHtml (" and " :: Text)) (inlineMath . renderFormulaMath hints <$> introConditions) + toHtml (", then " :: Text) + inlineMath (renderFormulaMath hints introResult) + toHtml ("." :: Text) + +renderInductiveDerivedFact :: HintMap -> InductiveDerivedFact -> Html () +renderInductiveDerivedFact hints InductiveDerivedFact{inductiveDerivedFactMarker, inductiveDerivedFactFormula} = + li_ (id_ (markerText inductiveDerivedFactMarker) : previewTargetAttributes "Inductive Fact" (Just inductiveDerivedFactMarker) Nothing) do + term "head-" do + code_ (toHtml (markerText inductiveDerivedFactMarker)) + toHtml (": " :: Text) + inlineMath (renderFormulaMath hints inductiveDerivedFactFormula) + toHtml ("." :: Text) + +data InductiveDerivedFact = InductiveDerivedFact + { inductiveDerivedFactMarker :: Marker + , inductiveDerivedFactFormula :: Formula + } + +data InductiveRenderInfo = InductiveRenderInfo + { inductiveFactBaseMarker :: Marker + , inductiveRenderParams :: [VarSymbol] + , inductiveRenderCarrierExpr :: Expr + , inductiveRenderDomainExpr :: Expr + , inductiveRenderClauses :: NonEmpty InductiveRenderClause + } + +data InductiveRenderClause = InductiveRenderClause + { inductiveRenderClauseVars :: [VarSymbol] + , inductiveRenderClauseConditions :: [InductiveRenderCondition] + , inductiveRenderClauseResultExpr :: Expr + } + +data InductiveRenderCondition + = InductiveRenderSideCondition Formula + | InductiveRenderRecursiveCondition Expr Expr + +inductiveDerivedFacts :: Marker -> Inductive -> [InductiveDerivedFact] +inductiveDerivedFacts marker inductive = case inductiveRenderInfo marker inductive of + Nothing -> + [] + Just info -> + inductiveIntroFacts info + <> [ InductiveDerivedFact (inductiveDomSubsetMarker info) (inductiveDomSubsetFormula info) + , InductiveDerivedFact (inductiveCasesMarker info) (inductiveCasesFormula info) + , InductiveDerivedFact (inductiveInductMarker info) (inductiveInductFormula info) + ] + +inductiveRenderInfo :: Marker -> Inductive -> Maybe InductiveRenderInfo +inductiveRenderInfo marker Inductive{inductiveSymbolPattern = SymbolPattern inductiveSymbol inductiveParams, inductiveDomain, inductiveIntros} = do + inductiveRenderClauses <- traverse (inductiveRenderClause inductiveSymbol inductiveParams) inductiveIntros + pure InductiveRenderInfo + { inductiveFactBaseMarker = marker + , inductiveRenderParams = inductiveParams + , inductiveRenderCarrierExpr = ExprOp Nowhere inductiveSymbol (ExprVar <$> inductiveParams) + , inductiveRenderDomainExpr = inductiveDomain + , inductiveRenderClauses + } + where + inductiveRenderClause :: MixfixItem -> [VarSymbol] -> IntroRule -> Maybe InductiveRenderClause + inductiveRenderClause symbol params IntroRule{introConditions, introResult} = do + inductiveRenderClauseResultExpr <- inductiveRenderResultExpr symbol params introResult + inductiveRenderClauseConditions <- traverse (inductiveRenderCondition symbol params) introConditions + let paramSet = Set.fromList params + inductiveRenderClauseVars = + List.filter (`Set.notMember` paramSet) + (orderedRenderVars (concatMap formulaVars introConditions <> exprVars inductiveRenderClauseResultExpr)) + pure InductiveRenderClause + { inductiveRenderClauseVars + , inductiveRenderClauseConditions + , inductiveRenderClauseResultExpr + } + +inductiveRenderResultExpr :: MixfixItem -> [VarSymbol] -> Formula -> Maybe Expr +inductiveRenderResultExpr symbol params = \case + FormulaChain (ChainBase (resultExpr :| []) Positive (Relation _ ElementSymbol []) (carrierExpr :| [])) + | sameInductiveCarrierExpr symbol params carrierExpr -> + Just resultExpr + _ -> + Nothing + +inductiveRenderCondition :: MixfixItem -> [VarSymbol] -> Formula -> Maybe InductiveRenderCondition +inductiveRenderCondition symbol params phi + | not (formulaMentionsFunction symbol phi) = + Just (InductiveRenderSideCondition phi) + | otherwise = case phi of + FormulaChain (ChainBase (recursiveTerm :| []) Positive (Relation _ ElementSymbol []) (recursiveCarrier :| [])) + | not (exprMentionsFunction symbol recursiveTerm) -> + InductiveRenderRecursiveCondition recursiveTerm <$> replaceCarrierExpr symbol params recursiveCarrier + _ -> + Nothing + where + replaceCarrierExpr :: MixfixItem -> [VarSymbol] -> Expr -> Maybe Expr + replaceCarrierExpr target targetParams = + replaceInductiveCarrierExpr target targetParams (ExprVar "__inductive") + +inductiveIntroFacts :: InductiveRenderInfo -> [InductiveDerivedFact] +inductiveIntroFacts info = + [ InductiveDerivedFact (inductiveIntroMarker info index) (inductiveIntroFormula info clause) + | (index, clause) <- zip [(1 :: Int) ..] (NonEmpty.toList (inductiveRenderClauses info)) + ] + +inductiveIntroMarker :: InductiveRenderInfo -> Int -> Marker +inductiveIntroMarker info index = + Marker (markerText (inductiveFactBaseMarker info) <> "_intro_" <> Text.pack (show index)) + +inductiveDomSubsetMarker :: InductiveRenderInfo -> Marker +inductiveDomSubsetMarker info = + Marker (markerText (inductiveFactBaseMarker info) <> "_dom_subset") + +inductiveCasesMarker :: InductiveRenderInfo -> Marker +inductiveCasesMarker info = + Marker (markerText (inductiveFactBaseMarker info) <> "_cases") + +inductiveInductMarker :: InductiveRenderInfo -> Marker +inductiveInductMarker info = + Marker (markerText (inductiveFactBaseMarker info) <> "_induct") + +inductiveIntroFormula :: InductiveRenderInfo -> InductiveRenderClause -> Formula +inductiveIntroFormula info clause = + forallIfNeeded (orderedRenderVars (inductiveRenderParams info <> inductiveRenderClauseVars clause)) + (impliesFrom premises conclusion) + where + premises = inductiveRenderConditionFormula info <$> inductiveRenderClauseConditions clause + conclusion = elementOfFormula (inductiveRenderClauseResultExpr clause) (inductiveRenderCarrierExpr info) + +inductiveDomSubsetFormula :: InductiveRenderInfo -> Formula +inductiveDomSubsetFormula info = + forallIfNeeded (inductiveRenderParams info) + (semanticSubsetFormula (inductiveUsedVars info) (inductiveRenderCarrierExpr info) (inductiveRenderDomainExpr info)) + +inductiveCasesFormula :: InductiveRenderInfo -> Formula +inductiveCasesFormula info = + forallIfNeeded (orderedRenderVars (inductiveRenderParams info <> [witnessVar])) + (impliesFormula (elementOfFormula (ExprVar witnessVar) (inductiveRenderCarrierExpr info)) (formulaDisjunction disjuncts)) + where + witnessVar = freshDatatypeVar (inductiveUsedVars info) "x" + disjuncts = inductiveCaseDisjunct witnessVar <$> NonEmpty.toList (inductiveRenderClauses info) + inductiveCaseDisjunct x clause = + existsIfNeeded (inductiveRenderClauseVars clause) + (formulaConjunction (premises <> [equalsFormula (ExprVar x) (inductiveRenderClauseResultExpr clause)])) + where + premises = inductiveRenderConditionFormula info <$> inductiveRenderClauseConditions clause + +inductiveInductFormula :: InductiveRenderInfo -> Formula +inductiveInductFormula info = + forallIfNeeded (orderedRenderVars (inductiveRenderParams info <> [subsetVar])) + (impliesFrom closures conclusion) + where + subsetVar = freshDatatypeVar (inductiveUsedVars info) "S" + closures = inductiveInductionClosure subsetVar <$> NonEmpty.toList (inductiveRenderClauses info) + conclusion = + semanticSubsetFormula + (Set.insert subsetVar (inductiveUsedVars info)) + (inductiveRenderCarrierExpr info) + (ExprVar subsetVar) + +inductiveInductionClosure :: VarSymbol -> InductiveRenderClause -> Formula +inductiveInductionClosure subsetVar clause = + forallIfNeeded (inductiveRenderClauseVars clause) (impliesFrom premises conclusion) + where + premises = inductiveRenderConditionFormulaAt (ExprVar subsetVar) <$> inductiveRenderClauseConditions clause + conclusion = elementOfFormula (inductiveRenderClauseResultExpr clause) (ExprVar subsetVar) + +inductiveRenderConditionFormula :: InductiveRenderInfo -> InductiveRenderCondition -> Formula +inductiveRenderConditionFormula info = + inductiveRenderConditionFormulaAt (inductiveRenderCarrierExpr info) + +inductiveRenderConditionFormulaAt :: Expr -> InductiveRenderCondition -> Formula +inductiveRenderConditionFormulaAt replacement = \case + InductiveRenderSideCondition phi -> + phi + InductiveRenderRecursiveCondition recursiveTerm recursiveCarrierTemplate -> + elementOfFormula recursiveTerm (substituteExpr (Map.singleton "__inductive" replacement) recursiveCarrierTemplate) + +inductiveUsedVars :: InductiveRenderInfo -> Set VarSymbol +inductiveUsedVars info = + Set.fromList + ( inductiveRenderParams info + <> [ var + | clause <- NonEmpty.toList (inductiveRenderClauses info) + , var <- inductiveRenderClauseVars clause + ] + ) + +sameInductiveCarrierExpr :: MixfixItem -> [VarSymbol] -> Expr -> Bool +sameInductiveCarrierExpr symbol params = \case + ExprOp _ symbol' args -> + symbol == symbol' + && length params == length args + && and (zipWith (\param arg -> exprVar arg == Just param) params args) + _ -> + False + +replaceInductiveCarrierExpr :: MixfixItem -> [VarSymbol] -> Expr -> Expr -> Maybe Expr +replaceInductiveCarrierExpr symbol params replacement = go + where + go = \case + ExprVar x -> + Just (ExprVar x) + ExprInteger loc n -> + Just (ExprInteger loc n) + ExprOp loc symbol' args + | sameInductiveCarrierExpr symbol params (ExprOp loc symbol' args) -> + Just replacement + | symbol == symbol' -> + Nothing + | otherwise -> + ExprOp loc symbol' <$> traverse go args + ExprStructOp loc structSymbol expr -> + ExprStructOp loc structSymbol <$> traverse go expr + ExprFiniteSet loc exprs -> + ExprFiniteSet loc <$> traverse go exprs + ExprSep{} -> + Nothing + ExprReplace{} -> + Nothing + ExprReplacePred{} -> + Nothing + +formulaMentionsFunction :: MixfixItem -> Formula -> Bool +formulaMentionsFunction symbol = \case + FormulaChain chain -> + chainMentionsFunction symbol chain + FormulaPredicate _loc _predicate _marker exprs -> + any (exprMentionsFunction symbol) exprs + Connected _loc _conn left right -> + formulaMentionsFunction symbol left || formulaMentionsFunction symbol right + FormulaNeg _loc phi -> + formulaMentionsFunction symbol phi + FormulaQuantified _loc _quant _vars _bound phi -> + formulaMentionsFunction symbol phi + PropositionalConstant{} -> + False + +chainMentionsFunction :: MixfixItem -> Chain -> Bool +chainMentionsFunction symbol = \case + ChainBase left _sign relation right -> + any (exprMentionsFunction symbol) left || relationMentionsFunction symbol relation || any (exprMentionsFunction symbol) right + ChainCons left _sign relation rest -> + any (exprMentionsFunction symbol) left || relationMentionsFunction symbol relation || chainMentionsFunction symbol rest + +relationMentionsFunction :: MixfixItem -> Relation -> Bool +relationMentionsFunction symbol = \case + Relation _loc _relationSymbol exprs -> + any (exprMentionsFunction symbol) exprs + RelationExpr _loc expr -> + exprMentionsFunction symbol expr + +exprMentionsFunction :: MixfixItem -> Expr -> Bool +exprMentionsFunction symbol = \case + ExprVar{} -> + False + ExprInteger{} -> + False + ExprOp _loc symbol' args -> + symbol == symbol' || any (exprMentionsFunction symbol) args + ExprStructOp _loc _structSymbol expr -> + maybe False (exprMentionsFunction symbol) expr + ExprFiniteSet _loc exprs -> + any (exprMentionsFunction symbol) exprs + ExprSep _loc _var bound _stmt -> + exprMentionsFunction symbol bound + ExprReplace _loc expr bounds _maybeStmt -> + exprMentionsFunction symbol expr || any (exprMentionsFunction symbol . snd) bounds + ExprReplacePred _loc _x _y expr _stmt -> + exprMentionsFunction symbol expr + +formulaVars :: Formula -> [VarSymbol] +formulaVars = \case + FormulaChain chain -> + chainVars chain + FormulaPredicate _loc _predicate _marker exprs -> + concatMap exprVars exprs + Connected _loc _conn left right -> + formulaVars left <> formulaVars right + FormulaNeg _loc phi -> + formulaVars phi + FormulaQuantified _loc _quant vars _bound phi -> + List.filter (`notElem` toList vars) (formulaVars phi) + PropositionalConstant{} -> + [] + +chainVars :: Chain -> [VarSymbol] +chainVars = \case + ChainBase left _sign relation right -> + concatMap exprVars (toList left) <> relationVars relation <> concatMap exprVars (toList right) + ChainCons left _sign relation rest -> + concatMap exprVars (toList left) <> relationVars relation <> chainVars rest + +relationVars :: Relation -> [VarSymbol] +relationVars = \case + Relation _loc _relationSymbol exprs -> + concatMap exprVars exprs + RelationExpr _loc expr -> + exprVars expr + +exprVars :: Expr -> [VarSymbol] +exprVars = \case + ExprVar x -> + [x] + ExprInteger{} -> + [] + ExprOp _loc _symbol args -> + concatMap exprVars args + ExprStructOp _loc _structSymbol expr -> + maybe [] exprVars expr + ExprFiniteSet _loc exprs -> + concatMap exprVars exprs + ExprSep _loc x bound _stmt -> + List.filter (/= x) (exprVars bound) + ExprReplace _loc expr bounds _maybeStmt -> + let boundVars = fst <$> toList bounds + free = exprVars expr <> concatMap (exprVars . snd) (toList bounds) + in List.filter (`notElem` boundVars) free + ExprReplacePred _loc x y expr _stmt -> + List.filter (\var -> var /= x && var /= y) (exprVars expr) + +orderedRenderVars :: [VarSymbol] -> [VarSymbol] +orderedRenderVars = + reverse . snd . foldl' step (Set.empty, []) + where + step (seen, acc) x + | x `Set.member` seen = (seen, acc) + | otherwise = (Set.insert x seen, x : acc) + +renderSignatureBlock :: HintMap -> [Asm] -> Signature -> Html () +renderSignatureBlock hints asms sig = do + case asms of + [] -> skip + _ -> do + toHtml ("Assumptions: " :: Text) + renderAsmList hints asms + toHtml ("." :: Text) + when (not (null asms)) do + p_ do + renderSignature hints sig + toHtml ("." :: Text) + when (null asms) do + renderSignature hints sig + toHtml ("." :: Text) + +renderSignature :: HintMap -> Signature -> Html () +renderSignature hints = \case + SignatureAdj var adj -> do + renderVarInline var + toHtml (" can be " :: Text) + renderAdjInline renderVarInline adj + SignatureVerb var verb -> do + renderVarInline var + toHtml (" can " :: Text) + renderVerbInline False renderVarInline verb + SignatureNoun var noun -> do + renderVarInline var + toHtml (" is a " :: Text) + renderNounInline False renderVarInline noun + SignatureSymbolic symb np -> do + renderSymbolPatternInline hints symb + toHtml (" is a " :: Text) + renderNounPhraseMaybe hints np + +renderStructDefn :: HintMap -> StructDefn -> Html () +renderStructDefn hints StructDefn{..} = do + toHtml ("Structure phrase: " :: Text) + renderStructPhraseInline structPhrase + toHtml ("." :: Text) + p_ do + toHtml ("Label: " :: Text) + renderVarInline structLabel + toHtml ("." :: Text) + when (not (null structParents)) do + p_ do + toHtml ("Parents: " :: Text) + joinHtml (toHtml (", " :: Text)) (renderStructPhraseInline <$> structParents) + toHtml ("." :: Text) + when (not (null structFixes)) do + p_ do + toHtml ("Fixes: " :: Text) + inlineMath (joinHtml (moText ",") (renderStructSymbolName <$> structFixes)) + toHtml ("." :: Text) + when (not (null structAssumes)) do + ul_ do + for_ structAssumes \(marker, stmt) -> li_ do + toHtml (markerText marker) + toHtml (": " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + + +buildPreviewMap + :: HtmlRenderContext + -> Set Marker + -> AnchorMap + -> HtmlRenderIndex + -> Either HtmlRenderContextError PreviewMap +buildPreviewMap + context + referencedMarkers + anchors + (HtmlRenderIndex targetIndex) = + Map.fromList <$> traverse makePreviewEntry indexedTargets + where + targets = + List.sortOn targetOrdinal + [ indexed + | marker <- Set.toList referencedMarkers + , marker `Map.notMember` anchors + , Just indexed@(IndexedReferenceTarget _ source _target) <- + [Map.lookup marker targetIndex] + , source /= htmlCurrentSource context + ] + targetOrdinal (IndexedReferenceTarget ordinal _source _target) = + ordinal + sourceTarget (IndexedReferenceTarget _ordinal source target) = + (source, target) + indexedTargets = + zip [1 :: Int ..] (sourceTarget <$> targets) + + makePreviewEntry (index, (source, target)) = do + previewSourceLabel <- + htmlSourceLabel context source + previewSourceHref <- + htmlSourcePageHref context source + previewReferenceHref <- + htmlSourceFragmentHref + context + source + (targetAnchorId target) + let marker = targetMarker target + previewMarker = marker + previewKind = targetKind target + previewTitle = targetTitle target + previewId = + "reference-preview-" <> Text.pack (show index) + previewBody = targetBody target + Right (marker, PreviewEntry{..}) + +renderPreviewStore :: HintMap -> PreviewMap -> Html () +renderPreviewStore hints previews = + div_ [class_ "reference-preview-store", makeAttributes "aria-hidden" "true"] do + traverse_ (renderPreviewEntry hints) (Map.elems previews) + +renderPreviewEntry :: HintMap -> PreviewEntry -> Html () +renderPreviewEntry hints PreviewEntry{..} = + div_ [id_ previewId, class_ "reference-preview-template"] do + div_ [class_ "reference-preview-heading"] do + toHtml previewKind + toHtml (" " :: Text) + code_ (toHtml (markerText previewMarker)) + case previewTitle of + Nothing -> + skip + Just title -> do + toHtml (" (" :: Text) + toHtml title + toHtml (")" :: Text) + div_ [class_ "reference-preview-source"] do + toHtml ("from " :: Text) + a_ [href_ previewSourceHref] do + code_ (toHtml previewSourceLabel) + div_ [class_ "reference-preview-body"] do + previewBody hints + +renderPreviewBlockBody :: HintMap -> Block -> Html () +renderPreviewBlockBody hints = \case + BlockAxiom _loc _title _marker axiom -> + previewStatement (renderAxiom hints axiom) + BlockClaim _kind _loc _title _marker claim -> + previewStatement (renderClaim hints claim) + BlockDefn _loc _title _marker defn -> + previewStatement (renderDefn hints defn) + BlockAbbr _loc _title _marker abbr -> + previewStatement (renderAbbreviation hints abbr) + BlockData _loc _title _marker datatype -> + renderDatatype hints datatype + BlockInductive _loc _title marker ind -> + renderInductive hints marker ind + BlockSig _loc _title _marker asms sig -> + renderSignatureBlock hints asms sig + BlockStruct _loc _title _marker structDefn -> + renderStructDefn hints structDefn + BlockProof{} -> + skip + +previewStatement :: Html () -> Html () +previewStatement = + p_ [class_ "reference-preview-statement"] + +referenceTargetsOfBlockRenderInfo :: BlockRenderInfo -> [ReferenceTarget] +referenceTargetsOfBlockRenderInfo (_index, block, blockId) = + maybeToList blockTarget <> inductiveTargets + where + blockTarget = do + marker <- blockMarkerOf block + pure ReferenceTarget + { targetMarker = marker + , targetAnchorId = blockId + , targetKind = blockPrefixText block + , targetTitle = formatBlockTitle (blockTitleOf block) + , targetBody = \hints -> renderPreviewBlockBody hints block + } + + inductiveTargets = case block of + BlockInductive _loc _title marker inductive -> + [ ReferenceTarget + { targetMarker = inductiveDerivedFactMarker + , targetAnchorId = markerText inductiveDerivedFactMarker + , targetKind = "Inductive Fact" + , targetTitle = Nothing + , targetBody = \hints -> previewStatement (inlineMath (renderFormulaMath hints inductiveDerivedFactFormula)) + } + | InductiveDerivedFact{inductiveDerivedFactMarker, inductiveDerivedFactFormula} <- inductiveDerivedFacts marker inductive + ] + _ -> + [] + + +renderProof :: HintMap -> ReferenceContext -> Proof -> Html () +renderProof hints references = \case + Omitted _loc -> + p_ "Omitted." + Qed mloc justification -> + renderProofTerminal mloc justification + Contradiction _loc justification -> + p_ do + toHtml ("Contradiction" :: Text) + renderJustificationSuffix references justification + toHtml ("." :: Text) + ByCase _loc cases -> do + p_ "Proof by cases." + term "proof-" (traverse_ (renderCase hints references) cases) + ByContradiction _loc proof -> do + p_ "Proof by contradiction." + term "proof-" (renderProof hints references proof) + BySetInduction _loc maybeTerm proof -> do + p_ do + toHtml ("Proof by set induction" :: Text) + case maybeTerm of + Nothing -> skip + Just targetTerm -> do + toHtml (" on " :: Text) + renderTermInline hints targetTerm + toHtml ("." :: Text) + term "proof-" (renderProof hints references proof) + ByOrdInduction _loc proof -> do + p_ "Proof by ordinal induction." + term "proof-" (renderProof hints references proof) + Assume _loc stmt proof -> do + p_ do + toHtml ("Assume " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + renderProofContinuation hints references proof + FixSymbolic _loc vars bound proof -> do + p_ do + toHtml ("Fix " :: Text) + renderVarListInline vars + renderBoundInline hints vars bound + toHtml ("." :: Text) + renderProofContinuation hints references proof + FixSuchThat _loc vars stmt proof -> do + p_ do + toHtml ("Fix " :: Text) + renderVarListInline vars + toHtml (" such that " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + renderProofContinuation hints references proof + Calc _loc maybeQuant calc proof -> do + renderCalc hints references maybeQuant calc + renderProofContinuation hints references proof + TakeVar _loc vars bound stmt justification proof -> do + p_ do + toHtml ("Take " :: Text) + renderVarListInline vars + renderBoundInline hints vars bound + toHtml (" such that " :: Text) + renderStmtInline hints stmt + renderJustificationSuffix references justification + toHtml ("." :: Text) + renderProofContinuation hints references proof + TakeNoun _loc np justification proof -> do + p_ do + toHtml ("Take " :: Text) + renderNounPhraseList hints np + renderJustificationSuffix references justification + toHtml ("." :: Text) + renderProofContinuation hints references proof + Have _loc maybeStmt stmt justification proof -> do + p_ do + case maybeStmt of + Nothing + | isImplicitProofEnd proof -> + skip + | otherwise -> + toHtml ("We have " :: Text) + Just premise -> do + toHtml ("Since " :: Text) + renderStmtInline hints premise + toHtml (", we have " :: Text) + renderStmtInline hints stmt + renderJustificationSuffix references justification + toHtml ("." :: Text) + renderProofContinuation hints references proof + Suffices _loc stmt justification proof -> do + p_ do + toHtml ("It suffices to show that " :: Text) + renderStmtInline hints stmt + renderJustificationSuffix references justification + toHtml ("." :: Text) + renderProofContinuation hints references proof + Subclaim _loc stmt subproof proof -> do + p_ do + toHtml ("Show " :: Text) + renderStmtInline hints stmt + toHtml ("." :: Text) + term "proof-" (renderProof hints references subproof) + renderProofContinuation hints references proof + Define _loc var expr proof -> do + p_ do + toHtml ("Let " :: Text) + renderVarEqInline hints var expr + toHtml ("." :: Text) + renderProofContinuation hints references proof + DefineFunction _loc fun arg value boundVar boundExpr proof -> do + p_ do + toHtml ("Let " :: Text) + renderFunctionEqInline hints fun arg value + toHtml (" for " :: Text) + renderVarInline boundVar + toHtml (" in " :: Text) + inlineMath (renderExprMathRow hints boundExpr) + toHtml ("." :: Text) + renderProofContinuation hints references proof + DefineFunctionLocal _loc fun arg _target domVar codVar rules proof -> do + p_ do + toHtml ("Let " :: Text) + renderFunctionCallInline fun arg + toHtml (" be locally defined from " :: Text) + renderVarInline domVar + toHtml (" to " :: Text) + renderVarInline codVar + toHtml ("." :: Text) + ul_ do + for_ (toList rules) \(ruleTerm, formula) -> li_ do + inlineMath (renderExprMathRow hints ruleTerm) + toHtml (" if " :: Text) + inlineMath (renderFormulaMath hints formula) + toHtml ("." :: Text) + renderProofContinuation hints references proof + + where + renderProofTerminal :: Maybe Location -> Justification -> Html () + renderProofTerminal mloc justification = case (mloc, justification) of + (Nothing, JustificationEmpty) -> + skip + (Just _, JustificationEmpty) -> + p_ "Trivial." + _ -> + p_ do + toHtml ("Follows" :: Text) + renderJustificationSuffix references justification + toHtml ("." :: Text) + +renderProofContinuation :: HintMap -> ReferenceContext -> Proof -> Html () +renderProofContinuation hints references proof = + unless (isImplicitProofEnd proof) (renderProof hints references proof) + +isImplicitProofEnd :: Proof -> Bool +isImplicitProofEnd = \case + Qed Nothing JustificationEmpty -> True + _ -> False + +proofStepCount :: Proof -> Int +proofStepCount = \case + Omitted _loc -> 1 + Qed{} -> 1 + Contradiction{} -> 1 + ByCase _loc cases -> 1 + sum (caseStepCount <$> cases) + ByContradiction _loc proof -> 1 + proofStepCount proof + BySetInduction _loc _maybeTerm proof -> 1 + proofStepCount proof + ByOrdInduction _loc proof -> 1 + proofStepCount proof + Assume _loc _stmt proof -> 1 + proofStepCount proof + FixSymbolic _loc _vars _bound proof -> 1 + proofStepCount proof + FixSuchThat _loc _vars _stmt proof -> 1 + proofStepCount proof + Calc _loc _maybeQuant calc proof -> 1 + calcStepCount calc + proofStepCount proof + TakeVar _loc _vars _bound _stmt _justification proof -> 1 + proofStepCount proof + TakeNoun _loc _np _justification proof -> 1 + proofStepCount proof + Have _loc _maybeStmt _stmt _justification proof -> 1 + proofStepCount proof + Suffices _loc _stmt _justification proof -> 1 + proofStepCount proof + Subclaim _loc _stmt subproof proof -> 1 + proofStepCount subproof + proofStepCount proof + Define _loc _var _expr proof -> 1 + proofStepCount proof + DefineFunction _loc _fun _arg _value _boundVar _boundExpr proof -> 1 + proofStepCount proof + DefineFunctionLocal _loc _fun _arg _target _domVar _codVar rules proof -> + 1 + length rules + proofStepCount proof + +caseStepCount :: Case -> Int +caseStepCount Case{caseProof} = 1 + proofStepCount caseProof + +calcStepCount :: Calc -> Int +calcStepCount = \case + Equation _ steps -> length steps + Biconditionals _ steps -> length steps + +renderCase :: HintMap -> ReferenceContext -> Case -> Html () +renderCase hints references Case{..} = + term "proof-" do + p_ do + toHtml ("Case " :: Text) + renderStmtInline hints caseOf + toHtml ("." :: Text) + renderProof hints references caseProof + +renderCalc :: HintMap -> ReferenceContext -> Maybe CalcQuantifier -> Calc -> Html () +renderCalc hints references maybeQuant calc = do + p_ do + toHtml ("Calculation" :: Text) + case maybeQuant of + Nothing -> skip + Just quant -> do + toHtml (" for " :: Text) + renderCalcQuantifierInline hints quant + toHtml ("." :: Text) + blockMath (renderCalcMath hints calc) + let justifications = calcJustifications calc + when (not (null justifications)) do + ul_ do + traverse_ renderStepJustification justifications + where + renderStepJustification :: (Int, Justification) -> Html () + renderStepJustification (_idx, JustificationEmpty) = skip + renderStepJustification (idx, jst) = li_ do + toHtml ("Step " <> Text.pack (show idx) <> ": " :: Text) + renderJustification references jst + toHtml ("." :: Text) + +renderCalcQuantifierInline :: HintMap -> CalcQuantifier -> Html () +renderCalcQuantifierInline hints (CalcQuantifier vars bound maybeStmt) = do + renderVarListInline vars + renderBoundInline hints vars bound + case maybeStmt of + Nothing -> skip + Just stmt -> do + toHtml (" such that " :: Text) + renderStmtInline hints stmt + +renderCalcMath :: HintMap -> Calc -> Html () +renderCalcMath hints = \case + Equation expr steps -> do + renderExprMathRow hints expr + for_ (toList steps) \(nextExpr, _jst) -> do + moText "=" + renderExprMathRow hints nextExpr + Biconditionals phi steps -> do + renderFormulaMath hints phi + for_ (toList steps) \(nextPhi, _jst) -> do + moText "⇔" + renderFormulaMath hints nextPhi + +calcJustifications :: Calc -> [(Int, Justification)] +calcJustifications = \case + Equation _ steps -> + zip [1..] (snd <$> toList steps) + Biconditionals _ steps -> + zip [1..] (snd <$> toList steps) + + +renderStmtInline :: HintMap -> Stmt -> Html () +renderStmtInline hints = \case + StmtFormula phi -> + inlineMath (renderFormulaMath hints phi) + StmtVerbPhrase ts vp -> do + renderTermList hints ts + toHtml (" " :: Text) + renderVerbPhraseInline hints (length ts > 1) vp + StmtNoun ts np -> do + renderTermList hints ts + toHtml (if length ts > 1 then " are a " else " is a " :: Text) + renderNounPhraseMaybe hints np + StmtStruct t structPhrase -> do + renderTermInline hints t + toHtml (" is a " :: Text) + renderStructPhraseInline structPhrase + StmtNeg _loc stmt -> do + toHtml ("it is not the case that " :: Text) + renderStmtInline hints stmt + StmtExists _loc np -> do + toHtml ("there exists " :: Text) + renderNounPhraseList hints np + StmtConnected conn _loc stmt1 stmt2 -> do + renderConnectedStmtInline hints conn stmt1 stmt2 + StmtQuantPhrase _loc qp stmt -> do + renderQuantPhraseInline hints qp + toHtml (" " :: Text) + renderStmtInline hints stmt + SymbolicQuantified _loc quant vars bound suchThat stmt -> do + toHtml (quantifierWord quant) + toHtml (" " :: Text) + renderBoundSubjectInline hints vars bound + renderQuantifiedTailInline hints quant suchThat stmt + +renderQuantPhraseInline :: HintMap -> QuantPhrase -> Html () +renderQuantPhraseInline hints (QuantPhrase quant np) = do + toHtml (quantifierWord quant) + toHtml (" " :: Text) + renderNounPhraseList hints np + +quantifierWord :: Quantifier -> Text +quantifierWord = \case + Universally -> "for every" + Existentially -> "there exists" + Nonexistentially -> "there exists no" + +connectiveWord :: Connective -> Text +connectiveWord = \case + Conjunction -> "and" + Disjunction -> "or" + Implication -> "implies" + Equivalence -> "iff" + ExclusiveOr -> "xor" + NegatedDisjunction -> "nor" + +renderConnectedStmtInline :: HintMap -> Connective -> Stmt -> Stmt -> Html () +renderConnectedStmtInline hints conn stmt1 stmt2 = case conn of + ExclusiveOr -> do + toHtml ("either " :: Text) + renderStmtInline hints stmt1 + toHtml (" or " :: Text) + renderStmtInline hints stmt2 + NegatedDisjunction -> do + toHtml ("neither " :: Text) + renderStmtInline hints stmt1 + toHtml (" nor " :: Text) + renderStmtInline hints stmt2 + _ -> do + renderStmtInline hints stmt1 + toHtml (" " :: Text) + toHtml (connectiveWord conn) + toHtml (" " :: Text) + renderStmtInline hints stmt2 + +renderQuantifiedTailInline :: HintMap -> Quantifier -> Maybe Stmt -> Stmt -> Html () +renderQuantifiedTailInline hints quant suchThat stmt = + case quant of + Universally -> do + for_ suchThat \suchStmt -> do + toHtml (" such that " :: Text) + renderStmtInline hints suchStmt + toHtml (" we have " :: Text) + renderStmtInline hints stmt + Existentially -> + renderExistentialTailInline hints suchThat stmt + Nonexistentially -> + renderExistentialTailInline hints suchThat stmt + +renderExistentialTailInline :: HintMap -> Maybe Stmt -> Stmt -> Html () +renderExistentialTailInline hints suchThat stmt = do + toHtml (" such that " :: Text) + case suchThat of + Nothing -> + renderStmtInline hints stmt + Just suchStmt -> do + renderStmtInline hints suchStmt + toHtml (" and " :: Text) + renderStmtInline hints stmt + + +renderAsmList :: HintMap -> [Asm] -> Html () +renderAsmList hints asms = + joinHtml (toHtml ("; " :: Text)) (renderAsm hints <$> asms) + +renderAsm :: HintMap -> Asm -> Html () +renderAsm hints = \case + AsmSuppose stmt -> + renderStmtInline hints stmt + AsmLetNoun vars np -> do + renderVarListInline vars + toHtml (" be " :: Text) + renderNounPhraseMaybe hints np + AsmLetIn vars expr -> do + renderVarListInline vars + toHtml (" be in " :: Text) + inlineMath (renderExprMathRow hints expr) + AsmLetThe var fun -> do + renderVarInline var + toHtml (" be " :: Text) + renderFunInline renderTermInline' fun + where renderTermInline' = renderTermInline hints + AsmLetEq var expr -> do + renderVarEqInline hints var expr + AsmLetStruct var structPhrase -> do + renderVarInline var + toHtml (" be a " :: Text) + renderStructPhraseInline structPhrase + + +renderTermInline :: HintMap -> Term -> Html () +renderTermInline hints = \case + TermExpr expr -> + inlineMath (renderExprMathRow hints expr) + TermFun fun -> do + toHtml ("the " :: Text) + renderFunInline (renderTermInline hints) fun + TermIota _loc var stmt -> do + toHtml ("the " :: Text) + renderVarInline var + toHtml (" such that " :: Text) + renderStmtInline hints stmt + TermQuantified quant _loc np -> do + toHtml (termQuantifierWord quant) + toHtml (" " :: Text) + renderNounPhraseMaybe hints np + +termQuantifierWord :: Quantifier -> Text +termQuantifierWord = \case + Universally -> "every" + Existentially -> "some" + Nonexistentially -> "no" + +renderTermList :: HintMap -> NonEmpty Term -> Html () +renderTermList hints = + joinHtml (toHtml (" and " :: Text)) . fmap (renderTermInline hints) . toList + +renderNounPhraseMaybe :: HintMap -> NounPhrase Maybe -> Html () +renderNounPhraseMaybe hints (NounPhrase ls noun maybeName rs maybeSuchThat) = do + renderAdjListInline renderTermInline' ls + renderNounInline False renderTermInline' noun + case maybeName of + Nothing -> skip + Just name -> do + toHtml (" " :: Text) + renderVarInline name + renderAdjRListInline hints rs + case maybeSuchThat of + Nothing -> skip + Just stmt -> do + toHtml (" such that " :: Text) + renderStmtInline hints stmt + where + renderTermInline' = renderTermInline hints + +renderNounPhraseList :: HintMap -> NounPhrase [] -> Html () +renderNounPhraseList hints (NounPhrase ls noun names rs maybeSuchThat) = do + renderAdjListInline renderTermInline' ls + renderNounInline (length names > 1) renderTermInline' noun + when (not (null names)) do + toHtml (" " :: Text) + renderVarListInline (NonEmpty.fromList names) + renderAdjRListInline hints rs + case maybeSuchThat of + Nothing -> skip + Just stmt -> do + toHtml (" such that " :: Text) + renderStmtInline hints stmt + where + renderTermInline' = renderTermInline hints + +renderAdjListInline :: (a -> Html ()) -> [AdjLOf a] -> Html () +renderAdjListInline renderArg adjs = + unless (null adjs) do + joinHtml (toHtml (" " :: Text)) (renderAdjLInline renderArg <$> adjs) + toHtml (" " :: Text) + +renderAdjRListInline :: HintMap -> [AdjROf Term] -> Html () +renderAdjRListInline hints adjs = + unless (null adjs) do + toHtml (" " :: Text) + joinHtml (toHtml (" and " :: Text)) (renderAdjRInline hints <$> adjs) + +renderAdjLInline :: (a -> Html ()) -> AdjLOf a -> Html () +renderAdjLInline renderArg (AdjL _loc item args) = + renderLexicalItemInline renderArg item args + +renderAdjRInline :: HintMap -> AdjROf Term -> Html () +renderAdjRInline hints = \case + AdjR _loc item args -> + renderLexicalItemInline (renderTermInline hints) item args + AttrRThat verbPhrase -> do + toHtml ("that " :: Text) + renderVerbPhraseInline hints False verbPhrase + +renderAdjInline :: (a -> Html ()) -> AdjOf a -> Html () +renderAdjInline renderArg (Adj _loc item args) = + renderLexicalItemInline renderArg item args + +renderVerbInline :: Bool -> (a -> Html ()) -> VerbOf a -> Html () +renderVerbInline isPlural renderArg (Verb _loc item args) = + renderLexicalItemSgPlInline isPlural renderArg item args + +renderVerbPhraseInline :: HintMap -> Bool -> VerbPhrase -> Html () +renderVerbPhraseInline hints isPlural = \case + VPVerb verb -> + renderVerbInline isPlural (renderTermInline hints) verb + VPAdj adjs -> do + toHtml (if isPlural then "are " else "is " :: Text) + joinHtml (toHtml (" and " :: Text)) (renderAdjInline (renderTermInline hints) <$> toList adjs) + VPVerbNot verb -> do + toHtml (if isPlural then "do not " else "does not " :: Text) + renderVerbInline True (renderTermInline hints) verb + VPAdjNot adjs -> do + toHtml (if isPlural then "are not " else "is not " :: Text) + joinHtml (toHtml (" and " :: Text)) (renderAdjInline (renderTermInline hints) <$> toList adjs) + +renderNounInline :: Bool -> (a -> Html ()) -> NounOf a -> Html () +renderNounInline isPlural renderArg (Noun _loc item args) = + renderLexicalItemSgPlInline isPlural renderArg item args + +renderFunInline :: (a -> Html ()) -> FunOf a -> Html () +renderFunInline renderArg Fun{phrase, funArgs} = + renderLexicalItemSgPlInline False renderArg phrase funArgs + +renderStructPhraseInline :: StructPhrase -> Html () +renderStructPhraseInline item = + renderLexicalItemSgPlInline False renderTermInlinePlaceholder item [] + +renderTermInlinePlaceholder :: a -> Html () +renderTermInlinePlaceholder _ = toHtml ("?" :: Text) + +renderLexicalItemInline :: (a -> Html ()) -> LexicalItem -> [a] -> Html () +renderLexicalItemInline renderArg item args = + renderPatternInline renderArg (lexicalItemPhrase item) args + +renderLexicalItemSgPlInline :: Bool -> (a -> Html ()) -> LexicalItemSgPl -> [a] -> Html () +renderLexicalItemSgPlInline isPlural renderArg item args = + renderPatternInline renderArg phrase args + where + phrase = if isPlural then pl (lexicalItemSgPlPhrase item) else sg (lexicalItemSgPlPhrase item) + +renderPatternInline :: (a -> Html ()) -> [Maybe Token] -> [a] -> Html () +renderPatternInline renderArg patternParts args = + joinHtml (toHtml (" " :: Text)) (go patternParts args) + where + go [] [] = [] + go [] (_ : _) = error "renderPatternInline: too many arguments" + go (Nothing : rest) (arg : restArgs) = renderArg arg : go rest restArgs + go (Nothing : _) [] = error "renderPatternInline: not enough arguments" + go (Just tok : rest) restArgs = tokenTextHtml tok : go rest restArgs + +renderStmtMath :: HintMap -> Stmt -> Html () +renderStmtMath hints = + renderStmtMathFragments . stmtMathFragments hints + +renderStmtMathFragments :: StmtMathFragments -> Html () +renderStmtMathFragments = + go "" + where + go :: Text -> StmtMathFragments -> Html () + go pending = \case + [] -> + flush pending + StmtMathProse text : rest -> + go (pending <> text) rest + StmtMathNode node : rest -> do + flush pending + node + go "" rest + + flush :: Text -> Html () + flush text = + let renderedText = preserveBoundarySpaces text + in unless (Text.null renderedText) (mtextText renderedText) + + preserveBoundarySpaces :: Text -> Text + preserveBoundarySpaces text = + Text.replicate leadingCount nbsp + <> middleText + <> Text.replicate trailingCount nbsp + where + leadingCount = Text.length (Text.takeWhile (== ' ') text) + textAfterLeading = Text.drop leadingCount text + trailingCount = Text.length (Text.takeWhileEnd (== ' ') textAfterLeading) + middleText = Text.dropEnd trailingCount textAfterLeading + nbsp = Text.singleton '\160' + +stmtMathProse :: Text -> StmtMathFragments +stmtMathProse text + | Text.null text = [] + | otherwise = [StmtMathProse text] + +stmtMathNode :: Html () -> StmtMathFragments +stmtMathNode html = + [StmtMathNode html] + +joinStmtMathFragments :: StmtMathFragments -> [StmtMathFragments] -> StmtMathFragments +joinStmtMathFragments _ [] = [] +joinStmtMathFragments separator (first : rest) = + first <> foldMap (separator <>) rest + +stmtMathFragments :: HintMap -> Stmt -> StmtMathFragments +stmtMathFragments hints = \case + StmtFormula phi -> + stmtMathNode (renderFormulaMath hints phi) + StmtVerbPhrase ts vp -> do + termListMathFragments hints ts + <> stmtMathProse " " + <> verbPhraseMathFragments hints (length ts > 1) vp + StmtNoun ts np -> do + termListMathFragments hints ts + <> stmtMathProse (if length ts > 1 then " are a " else " is a ") + <> nounPhraseMaybeMathFragments hints np + StmtStruct t structPhrase -> do + termMathFragments hints t + <> stmtMathProse " is a " + <> structPhraseMathFragments structPhrase + StmtNeg _loc stmt -> do + stmtMathProse "it is not the case that " + <> stmtMathFragments hints stmt + StmtExists _loc np -> do + stmtMathProse "there exists " + <> nounPhraseListMathFragments hints np + StmtConnected conn _loc stmt1 stmt2 -> do + connectedStmtMathFragments hints conn stmt1 stmt2 + StmtQuantPhrase _loc qp stmt -> do + quantPhraseMathFragments hints qp + <> stmtMathProse " " + <> stmtMathFragments hints stmt + SymbolicQuantified _loc quant vars bound suchThat stmt -> do + stmtMathProse (quantifierWord quant <> " ") + <> boundSubjectMathFragments hints vars bound + <> quantifiedTailMathFragments hints quant suchThat stmt + +quantPhraseMathFragments :: HintMap -> QuantPhrase -> StmtMathFragments +quantPhraseMathFragments hints (QuantPhrase quant np) = + stmtMathProse (quantifierWord quant <> " ") + <> nounPhraseListMathFragments hints np + +connectedStmtMathFragments :: HintMap -> Connective -> Stmt -> Stmt -> StmtMathFragments +connectedStmtMathFragments hints conn stmt1 stmt2 = case conn of + ExclusiveOr -> + stmtMathProse "either " + <> stmtMathFragments hints stmt1 + <> stmtMathProse " or " + <> stmtMathFragments hints stmt2 + NegatedDisjunction -> + stmtMathProse "neither " + <> stmtMathFragments hints stmt1 + <> stmtMathProse " nor " + <> stmtMathFragments hints stmt2 + _ -> + stmtMathFragments hints stmt1 + <> stmtMathProse (" " <> connectiveWord conn <> " ") + <> stmtMathFragments hints stmt2 + +quantifiedTailMathFragments :: HintMap -> Quantifier -> Maybe Stmt -> Stmt -> StmtMathFragments +quantifiedTailMathFragments hints quant suchThat stmt = + case quant of + Universally -> + foldMap + (\suchStmt -> stmtMathProse " such that " <> stmtMathFragments hints suchStmt) + suchThat + <> stmtMathProse " we have " + <> stmtMathFragments hints stmt + Existentially -> + existentialTailMathFragments hints suchThat stmt + Nonexistentially -> + existentialTailMathFragments hints suchThat stmt + +existentialTailMathFragments :: HintMap -> Maybe Stmt -> Stmt -> StmtMathFragments +existentialTailMathFragments hints suchThat stmt = + stmtMathProse " such that " + <> case suchThat of + Nothing -> + stmtMathFragments hints stmt + Just suchStmt -> + stmtMathFragments hints suchStmt + <> stmtMathProse " and " + <> stmtMathFragments hints stmt + +termMathFragments :: HintMap -> Term -> StmtMathFragments +termMathFragments hints = \case + TermExpr expr -> + stmtMathNode (renderExprMathRow hints expr) + TermFun fun -> do + stmtMathProse "the " + <> funMathFragments (termMathFragments hints) fun + TermIota _loc var stmt -> do + stmtMathProse "the " + <> stmtMathNode (renderVarMath var) + <> stmtMathProse " such that " + <> stmtMathFragments hints stmt + TermQuantified quant _loc np -> do + stmtMathProse (termQuantifierWord quant <> " ") + <> nounPhraseMaybeMathFragments hints np + +termListMathFragments :: HintMap -> NonEmpty Term -> StmtMathFragments +termListMathFragments hints = + joinStmtMathFragments (stmtMathProse " and ") . fmap (termMathFragments hints) . toList + +nounPhraseMaybeMathFragments :: HintMap -> NounPhrase Maybe -> StmtMathFragments +nounPhraseMaybeMathFragments hints (NounPhrase ls noun maybeName rs maybeSuchThat) = + adjListMathFragments renderTermMath' ls + <> nounMathFragments False renderTermMath' noun + <> foldMap (\name -> stmtMathProse " " <> stmtMathNode (renderVarMath name)) maybeName + <> adjRListMathFragments hints rs + <> foldMap (\stmt -> stmtMathProse " such that " <> stmtMathFragments hints stmt) maybeSuchThat + where + renderTermMath' = termMathFragments hints + +nounPhraseListMathFragments :: HintMap -> NounPhrase [] -> StmtMathFragments +nounPhraseListMathFragments hints (NounPhrase ls noun names rs maybeSuchThat) = + adjListMathFragments renderTermMath' ls + <> nounMathFragments (length names > 1) renderTermMath' noun + <> if null names + then [] + else stmtMathProse " " <> stmtMathNode (renderVarListMath (NonEmpty.fromList names)) + <> adjRListMathFragments hints rs + <> foldMap (\stmt -> stmtMathProse " such that " <> stmtMathFragments hints stmt) maybeSuchThat + where + renderTermMath' = termMathFragments hints + +adjListMathFragments :: (a -> StmtMathFragments) -> [AdjLOf a] -> StmtMathFragments +adjListMathFragments renderArg adjs = + if null adjs + then [] + else joinStmtMathFragments (stmtMathProse " ") (renderAdjLMathFragments renderArg <$> adjs) + <> stmtMathProse " " + +adjRListMathFragments :: HintMap -> [AdjROf Term] -> StmtMathFragments +adjRListMathFragments hints adjs = + if null adjs + then [] + else stmtMathProse " " + <> joinStmtMathFragments (stmtMathProse " and ") (renderAdjRMathFragments hints <$> adjs) + +renderAdjLMathFragments :: (a -> StmtMathFragments) -> AdjLOf a -> StmtMathFragments +renderAdjLMathFragments renderArg (AdjL _loc item args) = + lexicalItemStmtMathFragments renderArg item args + +renderAdjRMathFragments :: HintMap -> AdjROf Term -> StmtMathFragments +renderAdjRMathFragments hints = \case + AdjR _loc item args -> + lexicalItemStmtMathFragments (termMathFragments hints) item args + AttrRThat verbPhrase -> + stmtMathProse "that " + <> verbPhraseMathFragments hints False verbPhrase + +adjMathFragments :: (a -> StmtMathFragments) -> AdjOf a -> StmtMathFragments +adjMathFragments renderArg (Adj _loc item args) = + lexicalItemStmtMathFragments renderArg item args + +verbMathFragments :: Bool -> (a -> StmtMathFragments) -> VerbOf a -> StmtMathFragments +verbMathFragments isPlural renderArg (Verb _loc item args) = + lexicalItemSgPlStmtMathFragments isPlural renderArg item args + +verbPhraseMathFragments :: HintMap -> Bool -> VerbPhrase -> StmtMathFragments +verbPhraseMathFragments hints isPlural = \case + VPVerb verb -> + verbMathFragments isPlural (termMathFragments hints) verb + VPAdj adjs -> + stmtMathProse (if isPlural then "are " else "is ") + <> joinStmtMathFragments (stmtMathProse " and ") (adjMathFragments (termMathFragments hints) <$> toList adjs) + VPVerbNot verb -> + stmtMathProse (if isPlural then "do not " else "does not ") + <> verbMathFragments True (termMathFragments hints) verb + VPAdjNot adjs -> + stmtMathProse (if isPlural then "are not " else "is not ") + <> joinStmtMathFragments (stmtMathProse " and ") (adjMathFragments (termMathFragments hints) <$> toList adjs) + +nounMathFragments :: Bool -> (a -> StmtMathFragments) -> NounOf a -> StmtMathFragments +nounMathFragments isPlural renderArg (Noun _loc item args) = + lexicalItemSgPlStmtMathFragments isPlural renderArg item args + +funMathFragments :: (a -> StmtMathFragments) -> FunOf a -> StmtMathFragments +funMathFragments renderArg Fun{phrase, funArgs} = + lexicalItemSgPlStmtMathFragments False renderArg phrase funArgs + +structPhraseMathFragments :: StructPhrase -> StmtMathFragments +structPhraseMathFragments item = + lexicalItemSgPlStmtMathFragments False termMathPlaceholderFragments item [] + +termMathPlaceholderFragments :: a -> StmtMathFragments +termMathPlaceholderFragments _ = + stmtMathProse "?" + +lexicalItemStmtMathFragments :: (a -> StmtMathFragments) -> LexicalItem -> [a] -> StmtMathFragments +lexicalItemStmtMathFragments renderArg item args = + patternStmtMathFragments renderArg (lexicalItemPhrase item) args + +lexicalItemSgPlStmtMathFragments :: Bool -> (a -> StmtMathFragments) -> LexicalItemSgPl -> [a] -> StmtMathFragments +lexicalItemSgPlStmtMathFragments isPlural renderArg item args = + patternStmtMathFragments renderArg phrase args + where + phrase = if isPlural then pl (lexicalItemSgPlPhrase item) else sg (lexicalItemSgPlPhrase item) + +patternStmtMathFragments :: (a -> StmtMathFragments) -> [Maybe Token] -> [a] -> StmtMathFragments +patternStmtMathFragments renderArg patternParts args = + joinStmtMathFragments (stmtMathProse " ") (go patternParts args) + where + go [] [] = [] + go [] (_ : _) = error "renderPatternStmtMath: too many arguments" + go (Nothing : rest) (arg : restArgs) = renderArg arg : go rest restArgs + go (Nothing : _) [] = error "renderPatternStmtMath: not enough arguments" + go (Just tok : rest) restArgs = renderStmtToken tok : go rest restArgs + + renderStmtToken :: Token -> StmtMathFragments + renderStmtToken = \case + Word w -> stmtMathProse w + tok -> stmtMathNode (renderMathToken tok) + + +renderFormulaMath :: HintMap -> Formula -> Html () +renderFormulaMath hints = \case + FormulaChain chain -> + renderChainMathRow hints chain + FormulaPredicate _loc predi marker exprs -> + renderHintedMathRow hints PredicateHint marker (toList exprs) (renderPrefixPredicateFallback predi (renderExprMath hints <$> toList exprs)) + Connected _loc conn phi psi -> do + renderFormulaMath hints phi + moText (connectiveSymbol conn) + renderFormulaMath hints psi + FormulaNeg _loc phi -> do + moText "¬" + renderFormulaMath hints phi + FormulaQuantified _loc quant vars bound phi -> do + moText (quantifierSymbol quant) + renderVarListMath vars + renderBoundMath hints vars bound + moText "." + renderFormulaMath hints phi + PropositionalConstant _loc pc -> + moText (propositionalConstantSymbol pc) + +connectiveSymbol :: Connective -> Text +connectiveSymbol = \case + Conjunction -> "∧" + Disjunction -> "∨" + Implication -> "⇒" + Equivalence -> "⇔" + ExclusiveOr -> "⊕" + NegatedDisjunction -> "↓" + +quantifierSymbol :: Quantifier -> Text +quantifierSymbol = \case + Universally -> "∀" + Existentially -> "∃" + Nonexistentially -> "∄" + +propositionalConstantSymbol :: PropositionalConstant -> Text +propositionalConstantSymbol = \case + IsBottom -> "⊥" + IsTop -> "⊤" + +renderChainMathRow :: HintMap -> Chain -> Html () +renderChainMathRow hints chain = + joinHtml (moText "∧") (renderLink <$> splatChain chain) + where + renderLink (lhs, sign, rel, rhs) = + renderRelationApplication hints sign (toList lhs) rel (toList rhs) + + splatChain :: Chain -> [(NonEmpty Expr, Sign, Relation, NonEmpty Expr)] + splatChain = \case + ChainBase es sign rel es' -> + [(es, sign, rel, es')] + ChainCons es sign rel ch'@(ChainBase es' _ _ _) -> + (es, sign, rel, es') : splatChain ch' + ChainCons es sign rel ch'@(ChainCons es' _ _ _) -> + (es, sign, rel, es') : splatChain ch' + +renderBoundMath :: HintMap -> NonEmpty VarSymbol -> Bound -> Html () +renderBoundMath hints vars = \case + Unbounded -> skip + Bounded _loc sign rel expr -> do + moText "," + renderRelationApplication hints sign (ExprVar <$> toList vars) rel [expr] + +renderRelationApplication :: HintMap -> Sign -> [Expr] -> Relation -> [Expr] -> Html () +renderRelationApplication hints sign lhs rel rhs = case (sign, rel) of + (Negative, Relation _loc symbol []) + | Just negated <- negatedRelationSymbol (relationSymbolToken symbol) -> do + renderExprListMath hints lhs + moText negated + renderExprListMath hints rhs + _ -> + applySign sign (renderRelationCore hints lhs rel rhs) + +applySign :: Sign -> Html () -> Html () +applySign sign html = case sign of + Positive -> html + Negative -> do + mo_ "¬" + html + +renderRelationCore :: HintMap -> [Expr] -> Relation -> [Expr] -> Html () +renderRelationCore hints lhs rel rhs = case rel of + Relation _loc symbol relParams -> do + renderExprListMath hints lhs + renderRelationSymbolCore hints symbol relParams + renderExprListMath hints rhs + RelationExpr _loc expr -> do + renderExprListMath hints lhs + renderExprMath hints expr + renderExprListMath hints rhs + +renderRelationSymbolCore :: HintMap -> RelationSymbol -> [Expr] -> Html () +renderRelationSymbolCore hints symbol relParams = + renderHintedMathRow + hints + RelationHint + (relationSymbolMarker symbol) + relParams + (renderRelationFallback hints symbol relParams) + +renderRelationFallback :: HintMap -> RelationSymbol -> [Expr] -> Html () +renderRelationFallback hints symbol relParams = + merror_ (renderRelationFallbackCore hints symbol relParams) + +renderRelationFallbackCore :: HintMap -> RelationSymbol -> [Expr] -> Html () +renderRelationFallbackCore hints symbol relParams + | null relParams = renderRelationToken (relationSymbolToken symbol) + | otherwise = msub_ do + renderRelationToken (relationSymbolToken symbol) + mrow_ (renderExprListMath hints relParams) + +renderRelationToken :: Token -> Html () +renderRelationToken = \case + Command "in" -> moText "∈" + Command "ni" -> moText "∋" + Command "notin" -> moText "∉" + Command "meets" -> moText "⋈" + Command "notmeets" -> moText "⋈̸" + Command "subset" -> moText "⊂" + Command "subseteq" -> moText "⊆" + Command "supset" -> moText "⊃" + Command "supseteq" -> moText "⊇" + Command "neq" -> moText "≠" + tok -> renderMathToken tok + +negatedRelationSymbol :: Token -> Maybe Text +negatedRelationSymbol = \case + Command "in" -> Just "∉" + Command "ni" -> Just "∌" + Command "subset" -> Just "⊄" + Command "subseteq" -> Just "⊈" + Command "supset" -> Just "⊅" + Command "supseteq" -> Just "⊉" + Command "meets" -> Just "⋈̸" + Symbol "=" -> Just "≠" + Symbol "<" -> Just "≮" + Symbol ">" -> Just "≯" + Symbol "≤" -> Just "≰" + Symbol "≥" -> Just "≱" + _ -> Nothing + + +renderExprMath :: HintMap -> Expr -> Html () +renderExprMath hints expr = case expr of + ExprVar var -> + renderVarMath var + ExprInteger _loc n -> + mnText (Text.pack (show n)) + ExprOp _loc item args -> + renderHintedMath hints OperatorHint (mixfixMarker item) args (renderPatternFallback (mixfixPattern item) (renderExprMath hints <$> args)) + ExprStructOp _loc symb maybeExpr -> + let marker = structMarker symb + args = maybeToList maybeExpr + in renderHintedMath hints StructOpHint marker args (renderStructFallback symb (renderExprMath hints <$> args)) + ExprFiniteSet{} -> + mrow_ (renderExprMathRow hints expr) + ExprSep{} -> + mrow_ (renderExprMathRow hints expr) + ExprReplace{} -> + mrow_ (renderExprMathRow hints expr) + ExprReplacePred{} -> + mrow_ (renderExprMathRow hints expr) + +renderExprMathRow :: HintMap -> Expr -> Html () +renderExprMathRow hints = \case + ExprVar var -> + renderVarMath var + ExprInteger _loc n -> + mnText (Text.pack (show n)) + ExprOp _loc item args -> + renderHintedMathRow hints OperatorHint (mixfixMarker item) args (renderPatternFallback (mixfixPattern item) (renderExprMath hints <$> args)) + ExprStructOp _loc symb maybeExpr -> + let marker = structMarker symb + args = maybeToList maybeExpr + in renderHintedMathRow hints StructOpHint marker args (renderStructFallback symb (renderExprMath hints <$> args)) + ExprFiniteSet _loc exprs -> + renderFiniteSetMath hints (toList exprs) + ExprSep _loc var bound stmt -> do + moText "{" + renderVarMath var + moText "∈" + renderExprMathRow hints bound + moText "|" + renderStmtMath hints stmt + moText "}" + ExprReplace _loc expr bounds maybeStmt -> do + moText "{" + renderExprMathRow hints expr + moText "|" + renderReplaceBoundsMath hints (toList bounds) + for_ maybeStmt \stmt -> do + moText "|" + renderStmtMath hints stmt + moText "}" + ExprReplacePred _loc rangeVar domVar domExpr stmt -> do + moText "{" + renderVarMath rangeVar + moText "|" + moText "∃" + renderVarMath domVar + moText "∈" + renderExprMathRow hints domExpr + moText "." + renderStmtMath hints stmt + moText "}" + +renderReplaceBoundsMath :: HintMap -> [(VarSymbol, Expr)] -> Html () +renderReplaceBoundsMath hints = + joinHtml (moText ",") . fmap renderBound + where + renderBound (var, expr) = do + renderVarMath var + moText "∈" + renderExprMathRow hints expr + +renderExprListMath :: HintMap -> [Expr] -> Html () +renderExprListMath hints = + joinHtml (moText ",") . fmap (renderExprMath hints) + +renderFiniteSetMath :: HintMap -> [Expr] -> Html () +renderFiniteSetMath hints exprs = + do + moText "{" + renderExprListMath hints exprs + moText "}" + +renderHintedMath :: HintMap -> HintCategory -> Marker -> [Expr] -> Html () -> Html () +renderHintedMath hints category marker args fallback = + case Map.lookup (category, marker, length args) hints of + Nothing -> + fallback + Just RenderHint{..} + | renderHintArity /= length args -> + error ("Render hint arity mismatch for " <> show category <> " " <> show marker <> ": expected " <> show renderHintArity <> ", got " <> show (length args)) + | otherwise -> + renderTemplateAsNode renderHintTemplate + where + renderedArgs = renderExprMath hints <$> args + + renderTemplateAsNode :: [TemplatePiece] -> Html () + renderTemplateAsNode = \case + [piece] -> + renderPiece piece + pieces -> + mrow_ (traverse_ renderPiece pieces) + + renderPiece :: TemplatePiece -> Html () + renderPiece = \case + Literal text -> toHtmlRaw text + Slot ix -> case nth (ix - 1) renderedArgs of + Just html -> html + Nothing -> error ("Render hint slot out of bounds for " <> show marker <> ": <x" <> show ix <> "/>") + +renderHintedMathRow :: HintMap -> HintCategory -> Marker -> [Expr] -> Html () -> Html () +renderHintedMathRow hints category marker args fallback = + case Map.lookup (category, marker, length args) hints of + Nothing -> + fallback + Just RenderHint{..} + | renderHintArity /= length args -> + error ("Render hint arity mismatch for " <> show category <> " " <> show marker <> ": expected " <> show renderHintArity <> ", got " <> show (length args)) + | otherwise -> + traverse_ renderPiece renderHintTemplate + where + renderedArgs = renderExprMath hints <$> args + + renderPiece :: TemplatePiece -> Html () + renderPiece = \case + Literal text -> toHtmlRaw text + Slot ix -> case nth (ix - 1) renderedArgs of + Just html -> html + Nothing -> error ("Render hint slot out of bounds for " <> show marker <> ": <x" <> show ix <> "/>") + +renderPatternFallback :: Pattern -> [Html ()] -> Html () +renderPatternFallback patternParts renderedArgs = + merror_ (renderPatternMath patternParts renderedArgs) + +renderPatternMath :: Pattern -> [Html ()] -> Html () +renderPatternMath patternParts renderedArgs = + traverse_ id (go patternParts renderedArgs) + where + go End [] = [] + go End (_ : _) = error "renderPatternMath: too many arguments" + go (HoleCons rest) (arg : args) = arg : go rest args + go (HoleCons _) [] = error "renderPatternMath: not enough arguments" + go (TokenCons tok rest) args = renderMathToken tok : go rest args + +renderPrefixPredicateFallback :: PrefixPredicate -> [Html ()] -> Html () +renderPrefixPredicateFallback (PrefixPredicate command _arity) renderedArgs = + merror_ do + miText command + when (not (null renderedArgs)) do + moText "(" + joinHtml (moText ",") renderedArgs + moText ")" + +renderStructFallback :: StructSymbol -> [Html ()] -> Html () +renderStructFallback symb renderedArgs = + merror_ do + renderStructSymbolName symb + when (not (null renderedArgs)) do + moText "(" + joinHtml (moText ",") renderedArgs + moText ")" + +renderStructSymbolName :: StructSymbol -> Html () +renderStructSymbolName (StructSymbol name) = miText name + +structMarker :: StructSymbol -> Marker +structMarker (StructSymbol name) = Marker name + +renderMathToken :: Token -> Html () +renderMathToken = \case + Word w -> miText w + Variable v -> renderNamedVariableMath v + Symbol s -> moText s + Integer n -> mnText (Text.pack (show n)) + Command cmd -> miText cmd + Label m -> mtextText ("label:" <> m) + Ref ms -> mtextText ("ref:" <> Text.intercalate "," (toList ms)) + BeginEnv env -> mtextText ("begin:" <> env) + EndEnv env -> mtextText ("end:" <> env) + ParenL -> moText "(" + ParenR -> moText ")" + BracketL -> moText "[" + BracketR -> moText "]" + VisibleBraceL -> moText "{" + VisibleBraceR -> moText "}" + InvisibleBraceL -> moText "(" + InvisibleBraceR -> moText ")" + + +inlineMath :: Html () -> Html () +inlineMath inner = math_ inner + +blockMath :: Html () -> Html () +blockMath inner = math_ [displayblock_] inner + +renderVarInline :: VarSymbol -> Html () +renderVarInline = inlineMath . renderVarMath + +renderVarMath :: VarSymbol -> Html () +renderVarMath = \case + NamedVarAt _loc name -> + renderNamedVariableMath name + FreshVarAt _loc n -> + miText ("_" <> Text.pack (show n)) + +renderNamedVariableMath :: Text -> Html () +renderNamedVariableMath rawName = + case displayVariable rawName of + VariableDisplay baseText Nothing -> + miText baseText + VariableDisplay baseText (Just (VariableTicks tickCount)) -> + msup_ do + miText baseText + renderPrimeSuperscript tickCount + VariableDisplay baseText (Just (VariableSubscript subscriptText)) -> + msub_ do + miText baseText + renderVariableSubscriptMath subscriptText + +renderPrimeSuperscript :: Int -> Html () +renderPrimeSuperscript tickCount + | tickCount <= 1 = + moText "′" + | otherwise = + mrow_ (foldMap (const (moText "′")) [1 .. tickCount]) + +renderVariableSubscriptMath :: Text -> Html () +renderVariableSubscriptMath subscriptText + | Text.all isDigit subscriptText = + mnText subscriptText + | otherwise = + miText subscriptText + +renderVarEqInline :: HintMap -> VarSymbol -> Expr -> Html () +renderVarEqInline hints var expr = + inlineMath do + renderVarMath var + moText "=" + renderExprMathRow hints expr + +renderFunctionCallInline :: VarSymbol -> VarSymbol -> Html () +renderFunctionCallInline fun arg = + inlineMath (renderFunctionCallMath fun arg) + +renderFunctionEqInline :: HintMap -> VarSymbol -> VarSymbol -> Expr -> Html () +renderFunctionEqInline hints fun arg expr = + inlineMath do + renderFunctionCallMath fun arg + moText "=" + renderExprMathRow hints expr + +renderFunctionCallMath :: VarSymbol -> VarSymbol -> Html () +renderFunctionCallMath fun arg = do + renderVarMath fun + moText "(" + renderVarMath arg + moText ")" + +renderVarListInline :: NonEmpty VarSymbol -> Html () +renderVarListInline vars = + inlineMath (renderVarListMath vars) + +renderVarListMath :: NonEmpty VarSymbol -> Html () +renderVarListMath vars = + joinHtml (moText ",") (renderVarMath <$> toList vars) + +renderBoundInline :: HintMap -> NonEmpty VarSymbol -> Bound -> Html () +renderBoundInline hints vars = \case + Unbounded -> skip + bound -> do + toHtml (" with " :: Text) + inlineMath (renderBoundPhraseMath hints vars bound) + +renderBoundSubjectInline :: HintMap -> NonEmpty VarSymbol -> Bound -> Html () +renderBoundSubjectInline hints vars = \case + Unbounded -> + renderVarListInline vars + bound -> + inlineMath (renderBoundSubjectMath hints vars bound) + +renderBoundPhraseMath :: HintMap -> NonEmpty VarSymbol -> Bound -> Html () +renderBoundPhraseMath hints vars = \case + Unbounded -> mrow_ skip + Bounded _loc sign rel expr -> + renderRelationApplication hints sign (ExprVar <$> toList vars) rel [expr] + +renderBoundSubjectMath :: HintMap -> NonEmpty VarSymbol -> Bound -> Html () +renderBoundSubjectMath hints vars = \case + Unbounded -> + renderVarListMath vars + Bounded _loc sign rel expr -> + renderRelationApplication hints sign (ExprVar <$> toList vars) rel [expr] + +boundSubjectMathFragments :: HintMap -> NonEmpty VarSymbol -> Bound -> StmtMathFragments +boundSubjectMathFragments hints vars = \case + Unbounded -> + stmtMathNode (renderVarListMath vars) + bound -> + stmtMathNode (renderBoundSubjectMath hints vars bound) + +renderSymbolPatternInline :: HintMap -> SymbolPattern -> Html () +renderSymbolPatternInline hints = + inlineMath . renderSymbolPatternMath hints + +renderSymbolPatternMath :: HintMap -> SymbolPattern -> Html () +renderSymbolPatternMath hints (SymbolPattern symbol vars) = + renderHintedMathRow hints OperatorHint (mixfixMarker symbol) (ExprVar <$> vars) (renderPatternFallback (mixfixPattern symbol) (renderVarMath <$> vars)) + +renderJustification :: ReferenceContext -> Justification -> Html () +renderJustification references = \case + JustificationRef markers -> do + toHtml ("by " :: Text) + renderMarkerReferences references (toList markers) + JustificationSetExt -> + toHtml ("by set extensionality" :: Text) + JustificationEmpty -> + skip + JustificationLocal -> + toHtml ("by local assumptions" :: Text) + +renderJustificationSuffix :: ReferenceContext -> Justification -> Html () +renderJustificationSuffix _ JustificationEmpty = skip +renderJustificationSuffix references justification = do + toHtml (" " :: Text) + renderJustification references justification + +renderMarkerReferences :: ReferenceContext -> [Marker] -> Html () +renderMarkerReferences references markers + | length markers >= referenceGroupThreshold = + renderMarkerReferenceGroup references markers + | otherwise = + joinHtml (toHtml (", " :: Text)) (renderMarkerReference references <$> markers) + +renderMarkerReferenceGroup :: ReferenceContext -> [Marker] -> Html () +renderMarkerReferenceGroup references markers = + span_ groupAttributes do + toHtml ("[...]" :: Text) + span_ [class_ "reference-preview-group-items", makeAttributes "hidden" "hidden"] do + traverse_ (renderMarkerReferenceGroupItem references) markers + where + referenceCountLabel = Text.pack (show (length markers)) <> " references" + + groupAttributes = + [ class_ "ref-badge has-preview ref-badge-group" + , makeAttributes "data-preview-group" "true" + , makeAttributes "data-reference-label" referenceCountLabel + , makeAttributes "aria-describedby" "reference-preview-popup" + , makeAttributes "tabindex" "0" + , makeAttributes "role" "button" + , makeAttributes "aria-label" ("Show " <> referenceCountLabel) + ] + +renderMarkerReferenceGroupItem :: ReferenceContext -> Marker -> Html () +renderMarkerReferenceGroupItem ReferenceContext{..} marker = + span_ itemAttributes skip + where + label = markerText marker + baseAttributes = + [ class_ "reference-preview-group-item" + , makeAttributes "data-reference-label" label + ] + + itemAttributes = + baseAttributes <> case Map.lookup marker referenceAnchors of + Just anchor -> + [ makeAttributes + "data-preview-link" + (renderUrlFragment anchor) + , makeAttributes "data-preview-target-id" anchor + ] + Nothing -> + case Map.lookup marker referencePreviews of + Nothing -> + [] + Just preview -> + [ makeAttributes + "data-preview-link" + (previewReferenceHref preview) + , makeAttributes "data-preview-id" (previewId preview) + ] + +renderMarkerReference :: ReferenceContext -> Marker -> Html () +renderMarkerReference ReferenceContext{..} marker = + case Map.lookup marker referenceAnchors of + Just anchor -> + a_ + ( href_ (renderUrlFragment anchor) + : referenceAttributes + (Just (currentPreviewAttributes anchor)) + ) + (toHtml label) + Nothing -> + case Map.lookup marker referencePreviews of + Nothing -> + span_ (referenceAttributes Nothing) (toHtml label) + Just preview -> + a_ + ( href_ (previewReferenceHref preview) + : referenceAttributes (Just (importedPreviewAttributes preview)) + ) + (toHtml label) + where + label = markerText marker + + referenceAttributes preview = + [ class_ (if hasPreview preview then "ref-badge has-preview" else "ref-badge") + , makeAttributes "data-reference-label" label + ] + <> foldMap id preview + + hasPreview = + \case + Nothing -> False + Just _ -> True + + currentPreviewAttributes anchor = + [ makeAttributes "data-preview-target-id" anchor + , makeAttributes "aria-describedby" "reference-preview-popup" + ] + + importedPreviewAttributes entry = + [ makeAttributes "data-preview-id" (previewId entry) + , makeAttributes "aria-describedby" "reference-preview-popup" + ] + + +markerText :: Marker -> Text +markerText (Marker text) = text + +tokenTextHtml :: Token -> Html () +tokenTextHtml = toHtml . tokToText + +joinHtml :: Html () -> [Html ()] -> Html () +joinHtml _ [] = mempty +joinHtml separator (x : xs) = x <> foldMap (separator <>) xs + +miText :: Text -> Html () +miText = mi_ . toHtml + +moText :: Text -> Html () +moText = mo_ . toHtml + +mnText :: Text -> Html () +mnText = mn_ . toHtml + +mtextText :: Text -> Html () +mtextText = mtext_ . toHtml diff --git a/source/Felix/Render/Html/Context.hs b/source/Felix/Render/Html/Context.hs new file mode 100644 index 0000000..469d986 --- /dev/null +++ b/source/Felix/Render/Html/Context.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Browser-facing routing authority for one rendered HTML page. +module Felix.Render.Html.Context + ( HtmlRenderEnvironment + , htmlRenderEnvironment + , HtmlRenderContext + , HtmlRenderContextError(..) + , htmlRenderContext + , htmlRenderContextFromEnvironment + , htmlCurrentSource + , htmlCurrentPageUrl + , htmlCurrentPageLabel + , htmlRouteNamespaces + , htmlSourceUrl + , htmlSourceLabel + , htmlSourcePageHref + , htmlSourceFragmentHref + , htmlSupportScriptHref + ) where + +import Base +import Felix.Source +import Felix.Render.Html.Layout + +import Control.Exception (Exception) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text + + +data HtmlRenderContextError + = HtmlCurrentSourceNotRouted !ResolvedSource + | HtmlReferencedSourceNotRouted !ResolvedSource + deriving stock (Show, Eq) + +instance Exception HtmlRenderContextError + +data HtmlRenderContext = HtmlRenderContext + { contextCurrentSource :: !ResolvedSource + , contextCurrentPageUrl :: !UrlPath + , contextEnvironment :: !HtmlRenderEnvironment + } + deriving stock (Show, Eq) + +data HtmlRenderEnvironment = HtmlRenderEnvironment + { environmentSourceUrls :: !(Map ResolvedSource UrlPath) + , environmentRouteNamespaces :: !(Map SourceMountId UrlPath) + , environmentSupportScriptUrl :: !UrlPath + } + deriving stock (Show, Eq) + +htmlRenderEnvironment :: HtmlLayout -> HtmlRenderEnvironment +htmlRenderEnvironment layout = + HtmlRenderEnvironment + { environmentSourceUrls = + Map.fromList + [ (source, routeUrlPath route) + | (source, route) <- htmlPageRoutes layout + ] + , environmentRouteNamespaces = + htmlMountUrlPrefixes layout + , environmentSupportScriptUrl = + routeUrlPath (htmlSupportScriptRoute layout) + } + +htmlRenderContext + :: HtmlLayout + -> ResolvedSource + -> Either HtmlRenderContextError HtmlRenderContext +htmlRenderContext layout = + htmlRenderContextFromEnvironment + (htmlRenderEnvironment layout) + +htmlRenderContextFromEnvironment + :: HtmlRenderEnvironment + -> ResolvedSource + -> Either HtmlRenderContextError HtmlRenderContext +htmlRenderContextFromEnvironment environment currentSource = do + currentPageUrl <- + maybe + (Left (HtmlCurrentSourceNotRouted currentSource)) + Right + (Map.lookup + currentSource + (environmentSourceUrls environment)) + Right + HtmlRenderContext + { contextCurrentSource = currentSource + , contextCurrentPageUrl = currentPageUrl + , contextEnvironment = environment + } + +htmlCurrentSource :: HtmlRenderContext -> ResolvedSource +htmlCurrentSource = + contextCurrentSource + +htmlCurrentPageUrl :: HtmlRenderContext -> UrlPath +htmlCurrentPageUrl = + contextCurrentPageUrl + +htmlCurrentPageLabel :: HtmlRenderContext -> Text +htmlCurrentPageLabel context = + resolvedSourceLabel (contextCurrentSource context) + +htmlRouteNamespaces + :: HtmlRenderContext + -> Map SourceMountId UrlPath +htmlRouteNamespaces = + environmentRouteNamespaces . contextEnvironment + +htmlSourceUrl + :: HtmlRenderContext + -> ResolvedSource + -> Either HtmlRenderContextError UrlPath +htmlSourceUrl HtmlRenderContext{contextEnvironment} source = + maybe + (Left (HtmlReferencedSourceNotRouted source)) + Right + (Map.lookup source (environmentSourceUrls contextEnvironment)) + +htmlSourceLabel + :: HtmlRenderContext + -> ResolvedSource + -> Either HtmlRenderContextError Text +htmlSourceLabel context source = do + _url <- htmlSourceUrl context source + Right (resolvedSourceLabel source) + +htmlSourcePageHref + :: HtmlRenderContext + -> ResolvedSource + -> Either HtmlRenderContextError Text +htmlSourcePageHref context source = + renderRelativeUrlPath + (contextCurrentPageUrl context) + <$> htmlSourceUrl context source + +htmlSourceFragmentHref + :: HtmlRenderContext + -> ResolvedSource + -> Text + -> Either HtmlRenderContextError Text +htmlSourceFragmentHref context source fragment = do + target <- htmlSourceUrl context source + let encodedFragment = + renderUrlFragment fragment + Right + (if target == contextCurrentPageUrl context + then encodedFragment + else + renderRelativeUrlPath + (contextCurrentPageUrl context) + target + <> encodedFragment) + +htmlSupportScriptHref :: HtmlRenderContext -> Text +htmlSupportScriptHref context = + renderRelativeUrlPath + (contextCurrentPageUrl context) + (environmentSupportScriptUrl + (contextEnvironment context)) + +resolvedSourceLabel :: ResolvedSource -> Text +resolvedSourceLabel source = + sourceMountIdText (resolvedSourceMount source) + <> ":" + <> Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) diff --git a/source/Felix/Render/Html/Export.hs b/source/Felix/Render/Html/Export.hs new file mode 100644 index 0000000..a3f0e39 --- /dev/null +++ b/source/Felix/Render/Html/Export.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Prepare a complete HTML export from retained parsed presentation. +module Felix.Render.Html.Export + ( HtmlPresentation + , htmlPresentationFromParsedWorkspace + , HtmlExportError(..) + , renderHtmlExportError + , prepareHtmlExport + , prepareHtmlExportWithLayout + , prepareHtmlExportWithLayoutFromRendererRoots + ) where + +import Base +import Felix.Parse +import Felix.Source +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Render.Html.Output +import Felix.Syntax.Abstract (Block) + +import Control.Exception (Exception, IOException, displayException) +import Control.Exception qualified as Exception +import Data.Bifunctor (first) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Text.Encoding.Error (UnicodeException) +import Data.Text.IO qualified as TextIO +import System.Directory (doesFileExist) +import System.FilePath.Posix ((</>)) + + +-- | The strict, invocation-local subset of parsed presentation needed by the +-- renderer. Construction forces the complete module sequence and every page +-- shell, severing references to parser payloads, syntax interfaces, and +-- canonical cache payloads. +data HtmlPresentation = HtmlPresentation + !(NonEmpty HtmlSourcePresentation) + +data HtmlSourcePresentation = HtmlSourcePresentation + !ResolvedSource + ![Block] + +htmlPresentationFromParsedWorkspace + :: ParsedSourceWorkspace + -> HtmlPresentation +htmlPresentationFromParsedWorkspace workspace = + HtmlPresentation + (strictMapNonEmpty project parsedModules) + where + parsedModules = + parsedWorkspaceImportedBeforeImporter workspace + project parsedModule = + HtmlSourcePresentation + (parsedModuleResolved parsedModule) + (parsedModuleBlocks parsedModule) + +strictMapNonEmpty :: (a -> b) -> NonEmpty a -> NonEmpty b +strictMapNonEmpty f (value :| values) = + let !firstPage = f value + !rest = strictMapList f values + in firstPage :| rest + +strictMapList :: (a -> b) -> [a] -> [b] +strictMapList _ [] = + [] +strictMapList f (value : values) = + let !next = f value + !rest = strictMapList f values + in next : rest + +data HtmlExportError + = HtmlRendererDataNotFound !FilePath ![FilePath] + | HtmlRendererDataLookupFailed !FilePath !Text + | HtmlRendererDataReadFailed !FilePath !Text + | HtmlExportLayoutError !HtmlLayoutError + | HtmlExportContextError !HtmlRenderContextError + deriving stock (Show) + +instance Exception HtmlExportError + +renderHtmlExportError :: HtmlExportError -> Text +renderHtmlExportError = \case + HtmlRendererDataNotFound requested searched -> + "renderer data " <> quotePath requested <> " was not found; searched " + <> Text.intercalate ", " (quotePath <$> searched) + HtmlRendererDataLookupFailed path reason -> + "could not locate renderer data " <> quotePath path <> ": " <> reason + HtmlRendererDataReadFailed path reason -> + "could not read renderer data " <> quotePath path <> ": " <> reason + HtmlExportLayoutError failure -> + renderHtmlLayoutError failure + HtmlExportContextError failure -> + case failure of + HtmlCurrentSourceNotRouted source -> + "current source has no HTML route: " <> sourceLabel source + HtmlReferencedSourceNotRouted source -> + "referenced source has no HTML route: " <> sourceLabel source + where + sourceLabel source = + sourceMountIdText (resolvedSourceMount source) + <> ":" + <> Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + + quotePath = Text.pack . show + +prepareHtmlExport + :: [(SourceMountId, [Text])] + -> HtmlPresentation + -> Text + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareHtmlExport + mountPrefixes + (HtmlPresentation presentation) + hints = do + let sources = + sourceOf <$> NonEmpty.toList presentation + layout <- + first + HtmlExportLayoutError + (layoutHtmlSources mountPrefixes sources) + prepareRenderedExport hints layout presentation + where + sourceOf (HtmlSourcePresentation source _blocks) = + source + +prepareHtmlExportWithLayout + :: HtmlLayout + -> HtmlPresentation + -> Text + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareHtmlExportWithLayout + layout + (HtmlPresentation presentation) + hints = + prepareRenderedExport hints layout presentation + +prepareHtmlExportWithLayoutFromRendererRoots + :: [FilePath] + -> HtmlLayout + -> HtmlPresentation + -> IO (Either HtmlExportError [PreparedHtmlArtifact]) +prepareHtmlExportWithLayoutFromRendererRoots roots layout presentation = do + hintsResult <- findAndReadRendererFile roots "lexicon.tsv" + pure do + hints <- hintsResult + prepareHtmlExportWithLayout layout presentation hints + +-- Renderer data follows the established current-directory, +-- configured-library, and debug-directory lookup policy. +findAndReadRendererFile + :: [FilePath] + -> FilePath + -> IO (Either HtmlExportError Text) +findAndReadRendererFile roots path = + selectRendererData path ((</> path) <$> roots) >>= \case + Left failure -> pure (Left failure) + Right selectedPath -> do + readResult <- tryRendererRead (TextIO.readFile selectedPath) + pure case readResult of + Left reason -> + Left (HtmlRendererDataReadFailed selectedPath reason) + Right contents -> Right contents + +selectRendererData + :: FilePath + -> [FilePath] + -> IO (Either HtmlExportError FilePath) +selectRendererData requested candidates = go candidates + where + go = \case + [] -> pure (Left (HtmlRendererDataNotFound requested candidates)) + candidate : remaining -> + tryRendererIO (doesFileExist candidate) >>= \case + Left failure -> + pure + (Left + (HtmlRendererDataLookupFailed + candidate + (Text.pack (displayException failure)))) + Right True -> pure (Right candidate) + Right False -> go remaining + +tryRendererIO :: IO value -> IO (Either IOException value) +tryRendererIO = Exception.try + +tryRendererRead :: IO value -> IO (Either Text value) +tryRendererRead action = + Exception.catch + (Exception.catch (Right <$> action) renderIOException) + renderUnicodeException + where + renderIOException :: IOException -> IO (Either Text value) + renderIOException = pure . Left . Text.pack . displayException + + renderUnicodeException + :: UnicodeException + -> IO (Either Text value) + renderUnicodeException = pure . Left . Text.pack . displayException + +prepareRenderedExport + :: Text + -> HtmlLayout + -> NonEmpty HtmlSourcePresentation + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareRenderedExport hints layout presentation = do + let sourceBlocks = + (\(HtmlSourcePresentation source blocks) -> + (source, blocks)) + <$> presentation + (unforcedRenderIndex, pages) = + Html.buildRenderIndex sourceBlocks + !renderIndex = unforcedRenderIndex + renderEnvironment = + htmlRenderEnvironment layout + pageArtifacts <- + traverse + (prepareSourceArtifact + renderEnvironment + layout + hints + renderIndex) + pages + let supportRoute = + htmlSupportScriptRoute layout + supportArtifact = + preparedHtmlArtifact + (routeDestination supportRoute) + (Right + (TextEncoding.encodeUtf8 + Html.supportScriptAssetContents)) + -- Page artifacts retain imported-before-importer source order. The + -- singleton support asset is published deterministically afterward. + Right (NonEmpty.toList pageArtifacts <> [supportArtifact]) + +prepareSourceArtifact + :: HtmlRenderEnvironment + -> HtmlLayout + -> Text + -> Html.HtmlRenderIndex + -> Html.HtmlPagePresentation + -> Either + HtmlExportError + PreparedHtmlArtifact +prepareSourceArtifact renderEnvironment layout hints renderIndex page = do + let source = Html.htmlPagePresentationSource page + context <- + first + HtmlExportContextError + (htmlRenderContextFromEnvironment + renderEnvironment + source) + route <- + maybe + (Left + (HtmlExportContextError + (HtmlCurrentSourceNotRouted source))) + Right + (htmlPageRoute layout source) + Right + (preparedHtmlArtifact + (routeDestination route) + (first renderHtmlExportError + (TextEncoding.encodeUtf8 + <$> first + HtmlExportContextError + (Html.renderDocument + context + hints + renderIndex + page)))) diff --git a/source/Felix/Render/Html/Layout.hs b/source/Felix/Render/Html/Layout.hs new file mode 100644 index 0000000..7e5bfcf --- /dev/null +++ b/source/Felix/Render/Html/Layout.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Pure browser and destination routing for a resolved source graph. +module Felix.Render.Html.Layout + ( UrlSegment + , UrlSegmentError(..) + , urlSegment + , renderUrlSegment + , UrlPath + , urlPath + , renderUrlPath + , renderRelativeUrlPath + , renderUrlFragment + , HtmlRoute + , routeDestination + , routeUrlPath + , HtmlRouteOwner(..) + , HtmlUrlRouteCollision(..) + , HtmlDestinationRouteCollision(..) + , HtmlLayoutError(..) + , renderHtmlLayoutError + , HtmlLayout + , htmlPageRoutes + , htmlPageRoute + , htmlSupportScriptRoute + , htmlMountUrlPrefixes + , layoutHtmlSources + , layoutHtmlSourceGraph + ) where + +import Base +import Felix.Source +import Felix.Source.Graph + +import Control.Exception (Exception) +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.Char (chr) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Word (Word8) +import System.FilePath.Posix qualified as Posix + + +-- | One canonical percent-encoded URL path segment. +newtype UrlSegment = UrlSegment Text + deriving stock (Show, Eq, Ord) + +data UrlSegmentError + = EmptyUrlSegment + | DotUrlSegment !Text + | UrlSegmentContainsSeparator !Text + | UrlSegmentContainsNull !Text + deriving stock (Show, Eq) + +urlSegment :: Text -> Either UrlSegmentError UrlSegment +urlSegment decoded + | Text.null decoded = + Left EmptyUrlSegment + | decoded == "." || decoded == ".." = + Left (DotUrlSegment decoded) + | "/" `Text.isInfixOf` decoded = + Left (UrlSegmentContainsSeparator decoded) + | "\0" `Text.isInfixOf` decoded = + Left (UrlSegmentContainsNull decoded) + | otherwise = + Right (UrlSegment (percentEncodeUtf8 decoded)) + +renderUrlSegment :: UrlSegment -> Text +renderUrlSegment (UrlSegment encoded) = + encoded + + +-- | A root-relative URL path. Its segments are already encoded. +newtype UrlPath = UrlPath [UrlSegment] + deriving stock (Show, Eq, Ord) + +urlPath :: [Text] -> Either UrlSegmentError UrlPath +urlPath = + fmap UrlPath . traverse urlSegment + +renderUrlPath :: UrlPath -> Text +renderUrlPath (UrlPath segments) = + "/" <> Text.intercalate "/" (renderUrlSegment <$> segments) + +-- | Render a target path relative to the directory of a current page. +renderRelativeUrlPath :: UrlPath -> UrlPath -> Text +renderRelativeUrlPath + (UrlPath currentPageSegments) + (UrlPath targetSegments) = + case relativeSegments of + [] -> + "." + _ -> + Text.intercalate "/" relativeSegments + where + currentDirectorySegments = + case reverse currentPageSegments of + [] -> + [] + _page : directoryReversed -> + reverse directoryReversed + (remainingCurrent, remainingTarget) = + dropCommonPrefix currentDirectorySegments targetSegments + relativeSegments = + replicate (length remainingCurrent) ".." + <> (renderUrlSegment <$> remainingTarget) + +-- | Render an exact source marker as an encoded URL fragment. +renderUrlFragment :: Text -> Text +renderUrlFragment marker = + "#" <> percentEncodeUtf8 marker + + +data HtmlRoute = HtmlRoute + { routeDestination :: !SafeRelativePath + , routeUrlPath :: !UrlPath + } + deriving stock (Show, Eq) + +data HtmlRouteOwner + = HtmlPage !ResolvedSource + | HtmlSupportScript + deriving stock (Show, Eq, Ord) + +data HtmlUrlRouteCollision = HtmlUrlRouteCollision + !UrlPath + !(NonEmpty HtmlRouteOwner) + deriving stock (Show, Eq) + +data HtmlDestinationRouteCollision = HtmlDestinationRouteCollision + !SafeRelativePath + !(NonEmpty HtmlRouteOwner) + | NestedHtmlDestinationRouteCollision + !SafeRelativePath + !HtmlRouteOwner + !SafeRelativePath + !HtmlRouteOwner + deriving stock (Show, Eq) + +data HtmlLayoutError + = DuplicateHtmlMountId !SourceMountId + | InvalidHtmlMountPrefixSegment + !SourceMountId + !Text + !UrlSegmentError + | DuplicateHtmlMountPrefix + ![Text] + !(NonEmpty SourceMountId) + | MissingHtmlMountPrefix !SourceMountId + | InvalidHtmlRouteSegment + !HtmlRouteOwner + !Text + !UrlSegmentError + | InvalidHtmlRouteDestination + !HtmlRouteOwner + !FilePath + !RelativePathError + | CollidingHtmlRoutes + ![HtmlUrlRouteCollision] + ![HtmlDestinationRouteCollision] + deriving stock (Show, Eq) + +instance Exception HtmlLayoutError + +renderHtmlLayoutError :: HtmlLayoutError -> Text +renderHtmlLayoutError = \case + DuplicateHtmlMountId mount -> + "HTML mount is configured more than once: " + <> quoteText (sourceMountIdText mount) + InvalidHtmlMountPrefixSegment mount segment _problem -> + "HTML mount " <> quoteText (sourceMountIdText mount) + <> " has invalid route segment " <> quoteText segment + DuplicateHtmlMountPrefix prefix mounts -> + "HTML route prefix " <> quoteText (Text.intercalate "/" prefix) + <> " is shared by mounts " + <> Text.intercalate ", " + (quoteText . sourceMountIdText <$> toList mounts) + MissingHtmlMountPrefix mount -> + "no HTML route prefix is configured for mount " + <> quoteText (sourceMountIdText mount) + InvalidHtmlRouteSegment owner segment _problem -> + renderOwner owner <> " has invalid route segment " <> quoteText segment + InvalidHtmlRouteDestination owner path _problem -> + renderOwner owner <> " has invalid HTML destination " <> quotePath path + CollidingHtmlRoutes urlCollisions destinationCollisions -> + "HTML routes collide: " + <> Text.intercalate "; " + ( (renderUrlCollision <$> urlCollisions) + <> (renderDestinationCollision <$> destinationCollisions) + ) + where + renderUrlCollision (HtmlUrlRouteCollision path owners) = + "URL " <> quoteText (renderUrlPath path) + <> " is owned by " + <> Text.intercalate ", " (renderOwner <$> toList owners) + + renderDestinationCollision + (HtmlDestinationRouteCollision path owners) = + "destination " + <> quotePath (safeRelativePathFilePath path) + <> " is owned by " + <> Text.intercalate ", " (renderOwner <$> toList owners) + renderDestinationCollision + (NestedHtmlDestinationRouteCollision + ancestor ancestorOwner descendant descendantOwner) = + "destination " <> quotePath (safeRelativePathFilePath ancestor) + <> " for " <> renderOwner ancestorOwner + <> " is an ancestor of " + <> quotePath (safeRelativePathFilePath descendant) + <> " for " <> renderOwner descendantOwner + +renderOwner :: HtmlRouteOwner -> Text +renderOwner = \case + HtmlPage source -> + "page " + <> quoteText + (sourceMountIdText (resolvedSourceMount source) + <> ":" + <> Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source))) + HtmlSupportScript -> + "support script" + +quotePath :: FilePath -> Text +quotePath = Text.pack . show + +quoteText :: Text -> Text +quoteText = Text.pack . show + +data HtmlLayout = HtmlLayout + !(Map ResolvedSource HtmlRoute) + !HtmlRoute + !(Map SourceMountId UrlPath) + deriving stock (Show, Eq) + +htmlPageRoutes :: HtmlLayout -> [(ResolvedSource, HtmlRoute)] +htmlPageRoutes (HtmlLayout routes _supportScript _mountPrefixes) = + Map.toAscList routes + +htmlPageRoute :: HtmlLayout -> ResolvedSource -> Maybe HtmlRoute +htmlPageRoute (HtmlLayout routes _supportScript _mountPrefixes) source = + Map.lookup source routes + +htmlSupportScriptRoute :: HtmlLayout -> HtmlRoute +htmlSupportScriptRoute (HtmlLayout _routes supportScript _mountPrefixes) = + supportScript + +htmlMountUrlPrefixes :: HtmlLayout -> Map SourceMountId UrlPath +htmlMountUrlPrefixes (HtmlLayout _routes _supportScript mountPrefixes) = + mountPrefixes + + +data ValidatedMountPrefix = ValidatedMountPrefix + ![Text] + ![UrlSegment] + +layoutHtmlSourceGraph + :: [(SourceMountId, [Text])] + -> ResolvedSourceGraph + -> Either HtmlLayoutError HtmlLayout +layoutHtmlSourceGraph specifications graph = + layoutHtmlSources + specifications + (sourceNodeResolved <$> sourceGraphNodes graph) + +layoutHtmlSources + :: [(SourceMountId, [Text])] + -> [ResolvedSource] + -> Either HtmlLayoutError HtmlLayout +layoutHtmlSources specifications inputSources = do + prefixes <- validateMountPrefixes specifications + let sources = + List.sort + inputSources + usedMounts = + Set.fromList (resolvedSourceMount <$> sources) + missingMounts = + usedMounts `Set.difference` Map.keysSet prefixes + case Set.lookupMin missingMounts of + Just missing -> + Left (MissingHtmlMountPrefix missing) + Nothing -> do + pageEntries <- + traverse + (makePageRoute prefixes) + sources + encodedSupportScript <- + encodeRouteSegments + HtmlSupportScript + supportScriptAssetComponents + supportScript <- + makeRoute + HtmlSupportScript + supportScriptAssetComponents + encodedSupportScript + let ownedRoutes = + (HtmlSupportScript, supportScript) + : [ (HtmlPage source, route) + | (source, route) <- pageEntries + ] + urlCollisions = + collectUrlCollisions ownedRoutes + destinationCollisions = + collectDestinationCollisions ownedRoutes + <> collectNestedDestinationCollisions ownedRoutes + if null urlCollisions && null destinationCollisions + then + Right + (HtmlLayout + (Map.fromList pageEntries) + supportScript + (Map.map + (\(ValidatedMountPrefix _decoded encoded) -> + UrlPath encoded) + prefixes)) + else + Left + (CollidingHtmlRoutes + urlCollisions + destinationCollisions) + +validateMountPrefixes + :: [(SourceMountId, [Text])] + -> Either HtmlLayoutError (Map SourceMountId ValidatedMountPrefix) +validateMountPrefixes specifications = + case duplicateValues (fst <$> specifications) of + duplicate : _ -> + Left (DuplicateHtmlMountId duplicate) + [] -> do + validated <- traverse validatePrefix (List.sort specifications) + case duplicatePrefixGroups validated of + duplicate : _ -> + Left duplicate + [] -> + Right + (Map.fromList + [ (mount, prefix) + | (mount, _decoded, prefix) <- validated + ]) + where + validatePrefix (mount, decoded) = do + encoded <- traverse + (\segment -> + first + (InvalidHtmlMountPrefixSegment mount segment) + (urlSegment segment)) + decoded + Right + ( mount + , decoded + , ValidatedMountPrefix decoded encoded + ) + +duplicatePrefixGroups + :: [(SourceMountId, [Text], ValidatedMountPrefix)] + -> [HtmlLayoutError] +duplicatePrefixGroups validated = + [ DuplicateHtmlMountPrefix prefix (firstMount :| otherMounts) + | (prefix, mounts) <- + Map.toAscList + (Map.fromListWith (<>) + [ (decoded, [mount]) + | (mount, decoded, _prefix) <- validated + ]) + , firstMount : secondMount : remainingMounts <- + [List.sort mounts] + , let otherMounts = secondMount : remainingMounts + ] + +duplicateValues :: Ord a => [a] -> [a] +duplicateValues values = + [ value + | (value, multiplicity) <- + Map.toAscList + (Map.fromListWith (+) + [(value, 1 :: Int) | value <- values]) + , multiplicity > 1 + ] + +makePageRoute + :: Map SourceMountId ValidatedMountPrefix + -> ResolvedSource + -> Either HtmlLayoutError (ResolvedSource, HtmlRoute) +makePageRoute prefixes source = do + prefix <- case Map.lookup (resolvedSourceMount source) prefixes of + Nothing -> + Left + (MissingHtmlMountPrefix + (resolvedSourceMount source)) + Just found -> + Right found + let sourceComponents = + Text.splitOn + "/" + (Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source))) + destinationComponents = + replaceFinalComponent + (\component -> + dropFinalExtension component <> ".html") + sourceComponents + urlComponents = + replaceFinalComponent + dropFinalExtension + sourceComponents + ValidatedMountPrefix decodedPrefix encodedPrefix = + prefix + owner = HtmlPage source + encodedPageComponents <- + encodeRouteSegments owner urlComponents + route <- + makeRoute + owner + (decodedPrefix <> destinationComponents) + (encodedPrefix <> encodedPageComponents) + Right (source, route) + +replaceFinalComponent :: (a -> a) -> [a] -> [a] +replaceFinalComponent transform components = + case reverse components of + [] -> + [] + final : precedingReversed -> + reverse precedingReversed <> [transform final] + +dropFinalExtension :: Text -> Text +dropFinalExtension component = + case Text.breakOnEnd "." component of + ("", _suffix) -> + component + (".", _suffix) -> + component + (prefix, _suffix) -> + Text.dropEnd 1 prefix + +makeRoute + :: HtmlRouteOwner + -> [Text] + -> [UrlSegment] + -> Either HtmlLayoutError HtmlRoute +makeRoute owner destinationComponents encodedUrlComponents = do + let destinationSpelling = + List.intercalate + "/" + (Text.unpack <$> destinationComponents) + destination <- + first + (InvalidHtmlRouteDestination + owner + destinationSpelling) + (safeRelativePath destinationSpelling) + Right + HtmlRoute + { routeDestination = destination + , routeUrlPath = UrlPath encodedUrlComponents + } + +encodeRouteSegments + :: HtmlRouteOwner + -> [Text] + -> Either HtmlLayoutError [UrlSegment] +encodeRouteSegments owner = + traverse + (\decoded -> + first + (InvalidHtmlRouteSegment owner decoded) + (urlSegment decoded)) + +collectUrlCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlUrlRouteCollision] +collectUrlCollisions ownedRoutes = + [ HtmlUrlRouteCollision path owners + | (path, collidingOwners) <- + Map.toAscList + (Map.fromListWith (<>) + [ (routeUrlPath route, [owner]) + | (owner, route) <- ownedRoutes + ]) + , owners <- + collisionOwners collidingOwners + ] + +collectDestinationCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlDestinationRouteCollision] +collectDestinationCollisions ownedRoutes = + [ HtmlDestinationRouteCollision destination owners + | (destination, collidingOwners) <- + Map.toAscList + (Map.fromListWith (<>) + [ (routeDestination route, [owner]) + | (owner, route) <- ownedRoutes + ]) + , owners <- + collisionOwners collidingOwners + ] + +collectNestedDestinationCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlDestinationRouteCollision] +collectNestedDestinationCollisions ownedRoutes = + take 1 + [ NestedHtmlDestinationRouteCollision + ancestor + ancestorOwner + descendant + descendantOwner + | ( (ancestorComponents, ancestor, ancestorOwner) + , (descendantComponents, descendant, descendantOwner) + ) <- zip destinations (drop 1 destinations) + , strictComponentPrefix ancestorComponents descendantComponents + ] + where + destinations = + List.sort + [ ( relativePathComponents destination + , destination + , owner + ) + | (owner, route) <- ownedRoutes + , let destination = routeDestination route + ] + +relativePathComponents :: SafeRelativePath -> [FilePath] +relativePathComponents = + Posix.splitDirectories . safeRelativePathFilePath + +strictComponentPrefix :: [FilePath] -> [FilePath] -> Bool +strictComponentPrefix possibleAncestor possibleDescendant = + length possibleAncestor < length possibleDescendant + && possibleAncestor `List.isPrefixOf` possibleDescendant + +collisionOwners :: [HtmlRouteOwner] -> [NonEmpty HtmlRouteOwner] +collisionOwners owners = + case List.sort owners of + firstOwner : secondOwner : rest -> + [firstOwner :| (secondOwner : rest)] + _ -> + [] + +dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) +dropCommonPrefix (left : lefts) (right : rights) + | left == right = + dropCommonPrefix lefts rights +dropCommonPrefix left right = + (left, right) + + +supportScriptAssetComponents :: [Text] +supportScriptAssetComponents = + ["_static", "naproche-html.js"] + +percentEncodeUtf8 :: Text -> Text +percentEncodeUtf8 = + Text.pack + . concatMap encodeByte + . ByteString.unpack + . TextEncoding.encodeUtf8 + +encodeByte :: Word8 -> String +encodeByte byte + | isUnreservedAscii byte = + [chr (fromIntegral byte)] + | otherwise = + [ '%' + , hexadecimalDigit (byte `div` 16) + , hexadecimalDigit (byte `mod` 16) + ] + +isUnreservedAscii :: Word8 -> Bool +isUnreservedAscii byte = + isAsciiUpper byte + || isAsciiLower byte + || isAsciiDigit byte + || byte `elem` fmap (fromIntegral . fromEnum) ("-._~" :: String) + +isAsciiUpper :: Word8 -> Bool +isAsciiUpper byte = + byte >= 65 && byte <= 90 + +isAsciiLower :: Word8 -> Bool +isAsciiLower byte = + byte >= 97 && byte <= 122 + +isAsciiDigit :: Word8 -> Bool +isAsciiDigit byte = + byte >= 48 && byte <= 57 + +hexadecimalDigit :: Word8 -> Char +hexadecimalDigit value + | value < 10 = + chr (fromIntegral value + fromEnum '0') + | otherwise = + chr (fromIntegral value - 10 + fromEnum 'A') diff --git a/source/Felix/Render/Html/Output.hs b/source/Felix/Render/Html/Output.hs new file mode 100644 index 0000000..8e36f97 --- /dev/null +++ b/source/Felix/Render/Html/Output.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Confined filesystem authority for HTML output. +-- +-- The output root is assumed to be user-owned and not concurrently changed by +-- a hostile actor between planning and writing. Existing parent symlinks are +-- accepted only when they resolve inside the canonical root. Final-target +-- symlinks are rejected without following them; regular generated files may be +-- replaced. This policy prevents stable-tree escapes, not TOCTOU attacks. +module Felix.Render.Html.Output + ( PreparedHtmlArtifact + , preparedHtmlArtifact + , preparedHtmlArtifactDestination + , HtmlRoutePlan + , htmlRoutePlanDestinations + , planHtmlRoutes + , HtmlOutputPlan + , HtmlOutputError(..) + , renderHtmlOutputError + , planHtmlOutput + , planHtmlOutputAgainst + , HtmlPublicationError(..) + , renderHtmlPublicationError + , writeHtmlOutput + ) where + +import Base +import Felix.Output.Atomic (writeBytesAtomically) +import Felix.Source + ( SafeRelativePath + , safeRelativePathFilePath + ) + +import Control.Exception (Exception, IOException, displayException) +import Control.Exception qualified as Exception +import Control.Monad (unless, when) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import System.Posix.Files qualified as PosixFiles + + +-- | One lazily rendered artifact. The destination is available for complete +-- preflight without demanding the strict bytes or a renderer failure. +data PreparedHtmlArtifact = PreparedHtmlArtifact + !SafeRelativePath + (Either Text ByteString) + +preparedHtmlArtifact + :: SafeRelativePath + -> Either Text ByteString + -> PreparedHtmlArtifact +preparedHtmlArtifact = + PreparedHtmlArtifact + +preparedHtmlArtifactDestination + :: PreparedHtmlArtifact + -> SafeRelativePath +preparedHtmlArtifactDestination + (PreparedHtmlArtifact destination _rendered) = + destination + + +-- Constructors and absolute paths stay private to this module. +newtype HtmlRoutePlan = HtmlRoutePlan + [(SafeRelativePath, FilePath)] + +htmlRoutePlanDestinations + :: HtmlRoutePlan + -> [(SafeRelativePath, FilePath)] +htmlRoutePlanDestinations (HtmlRoutePlan routes) = + routes + +newtype HtmlOutputPlan = HtmlOutputPlan + [PlannedHtmlArtifact] + +data PlannedHtmlArtifact = PlannedHtmlArtifact + !SafeRelativePath + !FilePath + (Either Text ByteString) + +data HtmlOutputError + = EmptyPreparedHtmlOutput + | DuplicatePreparedHtmlDestination !SafeRelativePath + | HtmlOutputRouteMismatch + ![SafeRelativePath] + ![SafeRelativePath] + | EmptyHtmlOutputRoot + | HtmlOutputPathInspectionFailed !FilePath !Text + | HtmlOutputRootNotDirectory !FilePath + | HtmlOutputParentNotDirectory !FilePath + | HtmlOutputParentEscapesRoot !FilePath !FilePath + | HtmlOutputTargetIsSymbolicLink !FilePath + | HtmlOutputTargetNotRegularFile !FilePath + deriving stock (Show, Eq) + +renderHtmlOutputError :: HtmlOutputError -> Text +renderHtmlOutputError = \case + EmptyPreparedHtmlOutput -> + "HTML output contains no artifacts" + DuplicatePreparedHtmlDestination relative -> + "HTML output contains destination more than once: " + <> quoteRelative relative + HtmlOutputRouteMismatch planned prepared -> + "prepared HTML destinations do not match the reserved routes; planned " + <> renderRelatives planned <> ", prepared " <> renderRelatives prepared + EmptyHtmlOutputRoot -> + "HTML output root is empty" + HtmlOutputPathInspectionFailed path reason -> + "could not inspect HTML output path " <> quotePath path <> ": " <> reason + HtmlOutputRootNotDirectory path -> + "HTML output root is not a directory: " <> quotePath path + HtmlOutputParentNotDirectory path -> + "HTML output parent is not a directory: " <> quotePath path + HtmlOutputParentEscapesRoot root parent -> + "HTML output parent " <> quotePath parent + <> " resolves outside root " <> quotePath root + HtmlOutputTargetIsSymbolicLink path -> + "HTML output target is a symbolic link: " <> quotePath path + HtmlOutputTargetNotRegularFile path -> + "HTML output target is not a regular file: " <> quotePath path + where + renderRelatives = Text.intercalate ", " . fmap quoteRelative + +quoteRelative :: SafeRelativePath -> Text +quoteRelative = quotePath . safeRelativePathFilePath + +quotePath :: FilePath -> Text +quotePath = Text.pack . show + +instance Exception HtmlOutputError + +-- | Validate every destination without changing the filesystem. +planHtmlOutput + :: FilePath + -> [PreparedHtmlArtifact] + -> IO (Either HtmlOutputError HtmlOutputPlan) +planHtmlOutput outputRoot artifacts = do + routes <- planHtmlRoutes + outputRoot + (preparedHtmlArtifactDestination <$> artifacts) + pure (routes >>= (`planHtmlOutputAgainst` artifacts)) + +planHtmlRoutes + :: FilePath + -> [SafeRelativePath] + -> IO (Either HtmlOutputError HtmlRoutePlan) +planHtmlRoutes outputRoot destinations = + runExceptT do + when (null destinations) + (throwE EmptyPreparedHtmlOutput) + case duplicateDestinations destinations of + duplicate : _ -> + throwE + (DuplicatePreparedHtmlDestination duplicate) + [] -> + pure () + when (null outputRoot) (throwE EmptyHtmlOutputRoot) + absoluteRoot <- + inspectPath + outputRoot + (Directory.makeAbsolute outputRoot) + rootIsLink <- inspectSymbolicLink absoluteRoot + rootExists <- + inspectPath + absoluteRoot + (Directory.doesPathExist absoluteRoot) + rootIsDirectory <- + inspectPath + absoluteRoot + (Directory.doesDirectoryExist absoluteRoot) + when + ((rootIsLink || rootExists) && not rootIsDirectory) + (throwE (HtmlOutputRootNotDirectory absoluteRoot)) + canonicalRoot <- + inspectPath + absoluteRoot + (Directory.canonicalizePath absoluteRoot) + planned <- for (List.sort destinations) + \relative -> do + let components = + Posix.splitDirectories + (safeRelativePathFilePath relative) + destination = + confinedDestination + absoluteRoot + components + preflightDestination + canonicalRoot + absoluteRoot + components + destination + pure + ( relative + , destination + ) + pure (HtmlRoutePlan planned) + +planHtmlOutputAgainst + :: HtmlRoutePlan + -> [PreparedHtmlArtifact] + -> Either HtmlOutputError HtmlOutputPlan +planHtmlOutputAgainst + (HtmlRoutePlan routes) + artifacts + | null artifacts = + Left EmptyPreparedHtmlOutput + | duplicate : _ <- duplicateDestinations preparedDestinations = + Left (DuplicatePreparedHtmlDestination duplicate) + | Set.fromList plannedDestinations + /= Set.fromList preparedDestinations = + Left + (HtmlOutputRouteMismatch + plannedDestinations + preparedDestinations) + | otherwise = HtmlOutputPlan <$> traverse attach artifacts + where + plannedDestinations = fst <$> routes + preparedDestinations = + preparedHtmlArtifactDestination <$> artifacts + routeDestinations = Map.fromList routes + + attach (PreparedHtmlArtifact relative rendered) = + case Map.lookup relative routeDestinations of + Nothing -> + Left + (HtmlOutputRouteMismatch + plannedDestinations + preparedDestinations) + Just destination -> + Right + (PlannedHtmlArtifact + relative + destination + rendered) + +duplicateDestinations + :: [SafeRelativePath] + -> [SafeRelativePath] +duplicateDestinations destinations = + [ destination + | (destination, multiplicity) <- + Map.toAscList + (Map.fromListWith (+) + [ (destination, 1 :: Int) + | destination <- destinations + ]) + , multiplicity > 1 + ] + + +data HtmlPublicationError = IncompleteHtmlPublication + { committedHtmlDestinations :: ![SafeRelativePath] + , failedHtmlDestination :: !SafeRelativePath + , htmlPublicationFailure :: !Text + } + deriving stock (Show, Eq) + +instance Exception HtmlPublicationError + +renderHtmlPublicationError :: HtmlPublicationError -> [Text] +renderHtmlPublicationError failure = + [ "HTML publication failed at " + <> quoteRelative (failedHtmlDestination failure) + <> ": " <> htmlPublicationFailure failure + ] + <> case committedHtmlDestinations failure of + [] -> [] + committed -> + [ "HTML files published before the failure: " + <> Text.intercalate ", " + (quoteRelative <$> committed) + ] + +-- | Render, stage, and atomically replace each completely preflighted artifact +-- in the supplied source order. No later artifact is rendered or staged +-- before the preceding destination has been replaced. +writeHtmlOutput + :: HtmlOutputPlan + -> IO (Either HtmlPublicationError ()) +writeHtmlOutput (HtmlOutputPlan planned) = + publishAll [] planned + +publishAll + :: [SafeRelativePath] + -> [PlannedHtmlArtifact] + -> IO (Either HtmlPublicationError ()) +publishAll _committed [] = + pure (Right ()) +publishAll + committedReversed + (PlannedHtmlArtifact relative destination rendered : remaining) = + case rendered of + Left failure -> + pure + (Left + (IncompleteHtmlPublication + { committedHtmlDestinations = + reverse committedReversed + , failedHtmlDestination = relative + , htmlPublicationFailure = failure + })) + Right bytes -> do + result <- + tryIOException + (stageAndReplace destination bytes) + case result of + Left err -> + pure + (Left + (publicationError + (reverse committedReversed) + relative + err)) + Right () -> + publishAll + (relative : committedReversed) + remaining + +stageAndReplace + :: FilePath + -> ByteString + -> IO () +stageAndReplace destination bytes = do + let directory = Posix.takeDirectory destination + Directory.createDirectoryIfMissing True directory + writeBytesAtomically destination bytes + +publicationError + :: [SafeRelativePath] + -> SafeRelativePath + -> IOException + -> HtmlPublicationError +publicationError committed failed err = + IncompleteHtmlPublication + { committedHtmlDestinations = committed + , failedHtmlDestination = failed + , htmlPublicationFailure = + Text.pack (displayException err) + } + +tryIOException :: IO a -> IO (Either IOException a) +tryIOException = + Exception.try + + +preflightDestination + :: FilePath + -> FilePath + -> [FilePath] + -> FilePath + -> ExceptT HtmlOutputError IO () +preflightDestination canonicalRoot outputRoot components destination = do + traverse_ + (preflightParent canonicalRoot) + (destinationParents outputRoot components) + preflightTarget destination + +destinationParents :: FilePath -> [FilePath] -> [FilePath] +destinationParents root components = + take + (length components) + (scanl (Posix.</>) root components) + +confinedDestination :: FilePath -> [FilePath] -> FilePath +confinedDestination = + foldl' (Posix.</>) + +preflightParent + :: FilePath + -> FilePath + -> ExceptT HtmlOutputError IO () +preflightParent canonicalRoot parent = do + parentIsLink <- inspectSymbolicLink parent + parentExists <- + inspectPath parent (Directory.doesPathExist parent) + parentIsDirectory <- + inspectPath parent (Directory.doesDirectoryExist parent) + when (parentIsLink || parentExists) do + unless + parentIsDirectory + (throwE (HtmlOutputParentNotDirectory parent)) + canonicalParent <- + inspectPath + parent + (Directory.canonicalizePath parent) + unless + (isComponentwiseChild canonicalRoot canonicalParent) + (throwE + (HtmlOutputParentEscapesRoot + parent + canonicalParent)) + +preflightTarget + :: FilePath + -> ExceptT HtmlOutputError IO () +preflightTarget target = do + statusResult <- + liftIO + (tryIOError + (PosixFiles.getSymbolicLinkStatus target)) + case statusResult of + Left err + | isDoesNotExistError err -> + pure () + | otherwise -> + throwE + (HtmlOutputPathInspectionFailed + target + (Text.pack (displayException err))) + Right status + | PosixFiles.isSymbolicLink status -> + throwE + (HtmlOutputTargetIsSymbolicLink target) + | PosixFiles.isRegularFile status -> + pure () + | otherwise -> + throwE + (HtmlOutputTargetNotRegularFile target) + +isComponentwiseChild :: FilePath -> FilePath -> Bool +isComponentwiseChild root child = + canonicalComponents root + `List.isPrefixOf` + canonicalComponents child + +canonicalComponents :: FilePath -> [FilePath] +canonicalComponents = + Posix.splitDirectories + . Posix.dropTrailingPathSeparator + +inspectSymbolicLink + :: FilePath + -> ExceptT HtmlOutputError IO Bool +inspectSymbolicLink path = do + result <- + liftIO + (tryIOError + (Directory.pathIsSymbolicLink path)) + case result of + Right isLink -> + pure isLink + Left err + | isDoesNotExistError err -> + pure False + | otherwise -> + throwE + (HtmlOutputPathInspectionFailed + path + (Text.pack (displayException err))) + +inspectPath + :: FilePath + -> IO a + -> ExceptT HtmlOutputError IO a +inspectPath path action = do + result <- liftIO (tryIOError action) + case result of + Right value -> + pure value + Left err -> + throwE + (HtmlOutputPathInspectionFailed + path + (Text.pack (displayException err))) diff --git a/source/Felix/Report/Location.hs b/source/Felix/Report/Location.hs new file mode 100644 index 0000000..36b8997 --- /dev/null +++ b/source/Felix/Report/Location.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module Felix.Report.Location where + +import Base +import Text.Megaparsec.Pos (SourcePos (sourceColumn, sourceLine), unPos) +import Data.Bits +import Control.DeepSeq (NFData) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.IntMap.Strict qualified as IntMap +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Word (Word16, Word32) +import System.IO.Unsafe (unsafePerformIO) + +-- | File identifier used in packed source locations. +newtype FileId = FileId + { unFileId :: Word16 + } deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +-- | Packed source location. +-- Bit layout (high to low): +-- 16 bits file id | 24 bits line | 24 bits column. +newtype Location = Location + { unLocation :: Word64 + } deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +data RegisteredFile = RegisteredFile + { registeredFileIdentity :: FilePath + , registeredFileDisplayPath :: FilePath + } + +data FileRegistry = FileRegistry + { registrationToFileId :: Map (FilePath, FilePath) FileId + , fileIdToFile :: IntMap RegisteredFile + , fileIdAllocator :: !FileIdAllocator + } + +data LocationRegistrationError + = FileIdSpaceExhausted + deriving stock (Show, Eq) + +data LocationConstructionError + = LocationCoordinateOutOfRange !Int !Int + deriving stock (Show, Eq) + +newtype FileIdAllocator = FileIdAllocator Word32 + deriving stock (Show, Eq) + +initialFileIdAllocator :: FileIdAllocator +initialFileIdAllocator = FileIdAllocator 0 + +allocateFileId + :: FileIdAllocator + -> Either LocationRegistrationError (FileId, FileIdAllocator) +allocateFileId (FileIdAllocator next) + | next >= fromIntegral (maxBound :: Word16) = + Left FileIdSpaceExhausted + | otherwise = + Right + ( FileId (fromIntegral next) + , FileIdAllocator (next + 1) + ) + +initialFileRegistry :: FileRegistry +initialFileRegistry = FileRegistry + { registrationToFileId = mempty + , fileIdToFile = mempty + , fileIdAllocator = initialFileIdAllocator + } + +fileRegistryRef :: IORef FileRegistry +fileRegistryRef = unsafePerformIO (newIORef initialFileRegistry) +{-# NOINLINE fileRegistryRef #-} + +registerFilePath + :: MonadIO io + => FilePath + -> io (Either LocationRegistrationError FileId) +registerFilePath path = + registerFilePathWithDisplay path path + +-- | Register a file by physical identity while retaining a separate path for +-- diagnostics. The identity must be stable and unique for the selected +-- physical source. Distinct display paths receive distinct file identifiers so +-- one workspace cannot inherit another workspace's presentation. Callers with +-- only one path should use 'registerFilePath'. +registerFilePathWithDisplay + :: MonadIO io + => FilePath + -> FilePath + -> io (Either LocationRegistrationError FileId) +registerFilePathWithDisplay identity displayPath = liftIO $ + atomicModifyIORef' fileRegistryRef \registry -> + case Map.lookup registration (registrationToFileId registry) of + Just fileId -> + (registry, Right fileId) + Nothing -> + case allocateFileId (fileIdAllocator registry) of + Left err -> + (registry, Left err) + Right (fileId, nextAllocator) -> + let fileIdInt = fromIntegral (unFileId fileId) + registeredFile = + RegisteredFile identity displayPath + registry' = FileRegistry + { registrationToFileId = + Map.insert + registration + fileId + (registrationToFileId registry) + , fileIdToFile = + IntMap.insert + fileIdInt + registeredFile + (fileIdToFile registry) + , fileIdAllocator = nextAllocator + } + in + (registry', Right fileId) + where + registration = (identity, displayPath) + +lookupFilePath :: FileId -> Maybe FilePath +lookupFilePath fileId = unsafePerformIO do + registry <- readIORef fileRegistryRef + pure + (registeredFileDisplayPath <$> + IntMap.lookup + (fromIntegral (unFileId fileId)) + (fileIdToFile registry)) + +lookupFileIdentityPath :: FileId -> Maybe FilePath +lookupFileIdentityPath fileId = unsafePerformIO do + registry <- readIORef fileRegistryRef + pure + (registeredFileIdentity <$> + IntMap.lookup + (fromIntegral (unFileId fileId)) + (fileIdToFile registry)) + +fileShift, lineShift :: Int +fileShift = 48 +lineShift = 24 + +fileMask, coordMask :: Word64 +fileMask = 0xFFFF +coordMask = 0xFFFFFF + +nowhereWord :: Word64 +nowhereWord = maxBound + +mkLocationChecked + :: FileId + -> Int + -> Int + -> Either LocationConstructionError Location +mkLocationChecked fileId line column + | line < 0 + || column < 0 + || lineWord > coordMask + || columnWord > coordMask = + Left (LocationCoordinateOutOfRange line column) + | otherwise = + Right + (Location + ( (fromIntegral (unFileId fileId) `shiftL` fileShift) + .|. (lineWord `shiftL` lineShift) + .|. columnWord + )) + where + lineWord = fromIntegral line :: Word64 + columnWord = fromIntegral column :: Word64 + +mkLocation :: FileId -> Int -> Int -> Location +mkLocation fileId line column = + either + (impossible . ("mkLocation: " <>) . show) + id + (mkLocationChecked fileId line column) + +locFileId :: Location -> Maybe FileId +locFileId (Location w) + | w == nowhereWord = Nothing + | otherwise = Just (FileId (fromIntegral ((w `shiftR` fileShift) .&. fileMask))) + +locFile :: Location -> FilePath +locFile loc = case locFileId loc of + Nothing -> "<nowhere>" + Just fileId -> + fromMaybe ("<file#" <> show (unFileId fileId) <> ">") (lookupFilePath fileId) + +locLine :: Location -> Int +locLine (Location w) + | w == nowhereWord = -1 + | otherwise = fromIntegral ((w `shiftR` lineShift) .&. coordMask) + +locColumn :: Location -> Int +locColumn (Location w) + | w == nowhereWord = -1 + | otherwise = fromIntegral (w .&. coordMask) + +instance Show Location where + showsPrec p loc = + showParen (p > appPrec) $ + showString "Location {locFile = " + . shows (locFile loc) + . showString ", locLine = " + . shows (locLine loc) + . showString ", locColumn = " + . shows (locColumn loc) + . showString "}" + where + appPrec = 10 + +fromSourcePosChecked + :: FileId + -> SourcePos + -> Either LocationConstructionError Location +fromSourcePosChecked fileId pos = + mkLocationChecked + fileId + (unPos (sourceLine pos)) + (unPos (sourceColumn pos)) + +prettyLocation :: Location -> String +prettyLocation loc = + locFile loc <> " " <> show (locLine loc) <> ":" <> show (locColumn loc) + +-- | Render two locations together, qualifying equal display paths when they +-- refer to different physical files. +prettyLocationPair :: Location -> Location -> (String, String) +prettyLocationPair firstLocation secondLocation = + if locFile firstLocation == locFile secondLocation + && firstIdentity /= secondIdentity + && isJust firstIdentity + && isJust secondIdentity + then + ( qualify firstIdentity firstLocation + , qualify secondIdentity secondLocation + ) + else + (prettyLocation firstLocation, prettyLocation secondLocation) + where + firstIdentity = + locFileId firstLocation >>= lookupFileIdentityPath + secondIdentity = + locFileId secondLocation >>= lookupFileIdentityPath + + qualify identity location = + locFile location + <> " (canonical " + <> maybe "<unknown>" show identity + <> ") " + <> show (locLine location) + <> ":" + <> show (locColumn location) + +locationToText :: Location -> Text +locationToText loc = Text.pack (prettyLocation loc) + +-- | Things that have a location. +class Locatable a where + locate :: a -> Location + +pattern Nowhere :: Location +pattern Nowhere = Location 0xFFFFFFFFFFFFFFFF + +instance Locatable Location where + locate = id + +instance Locatable a => Locatable [a] where + locate [] = Nowhere + locate (x:_) = locate x + +instance Locatable a => Locatable (Maybe a) where + locate Nothing = Nowhere + locate (Just x) = locate x + +instance Locatable a => Locatable (NonEmpty a) where + locate (x :| _) = locate x diff --git a/source/Felix/Source.hs b/source/Felix/Source.hs index 350bb50..68d596c 100644 --- a/source/Felix/Source.hs +++ b/source/Felix/Source.hs @@ -80,7 +80,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Encoding -import Report.Location +import Felix.Report.Location ( Location , LocationRegistrationError(..) , locationToText diff --git a/source/Felix/Source/Graph.hs b/source/Felix/Source/Graph.hs index cb8990e..9c8753d 100644 --- a/source/Felix/Source/Graph.hs +++ b/source/Felix/Source/Graph.hs @@ -25,11 +25,11 @@ module Felix.Source.Graph import Base import Felix.Source -import Report.Location +import Felix.Report.Location ( FileId , registerFilePathWithDisplay ) -import Syntax.Token (Located(..), gatherImports) +import Felix.Syntax.Token (Located(..), gatherImports) import Control.Monad (unless) import Control.Monad.State.Strict diff --git a/source/Felix/Store.hs b/source/Felix/Store.hs index 038b4dc..fb12670 100644 --- a/source/Felix/Store.hs +++ b/source/Felix/Store.hs @@ -54,16 +54,16 @@ module Felix.Store ) where import Base -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Identity -import Checking.Materialization qualified as Materialization -import Checking.Semantic +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Identity +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic import Felix.Cache.Codec import Felix.Module (ModuleName) import Felix.Parsed.Identity qualified as Parsed import Felix.Parsed.Payload qualified as ParsedPayload -import Syntax.Interface qualified as Syntax +import Felix.Syntax.Interface qualified as Syntax import Control.Concurrent.MVar ( MVar diff --git a/source/Felix/Syntax/Abstract.hs b/source/Felix/Syntax/Abstract.hs new file mode 100644 index 0000000..b18612a --- /dev/null +++ b/source/Felix/Syntax/Abstract.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- | Data types for the abstract syntax tree and helper functions +-- for constructing the lexicon. +-- +module Felix.Syntax.Abstract + ( module Felix.Syntax.Abstract + , module Felix.Syntax.LexicalPhrase + , module Felix.Syntax.Token + ) where + + +import Base +import Felix.Syntax.LexicalPhrase (LexicalPhrase, SgPl(..), unsafeReadPhraseSgPl, unsafeReadPhrase) +import Felix.Syntax.Token (Token(..), Located(..)) +import Felix.Report.Location + +import Control.DeepSeq (NFData) +import Text.Earley.Mixfix (Holey) +import Data.Text qualified as Text +import Numeric.Natural (Natural) + +-- | Local "variable-like" symbols that can be captured by binders. +data VarSymbol + = NamedVarAt Location Text -- ^ A named variable. + | FreshVarAt Location Int -- ^ A nameless (implicit) variable. Should only come from desugaring. + deriving (Generic, NFData) + +pattern NamedVar :: Text -> VarSymbol +pattern NamedVar x <- NamedVarAt _ x where + NamedVar x = NamedVarAt Nowhere x + +pattern FreshVar :: Int -> VarSymbol +pattern FreshVar n <- FreshVarAt _ n where + FreshVar n = FreshVarAt Nowhere n + +{-# COMPLETE NamedVarAt, FreshVarAt #-} +{-# COMPLETE NamedVar, FreshVar #-} + +instance Show VarSymbol where + showsPrec d = \case + NamedVarAt _ x -> + showParen (d > 10) (showString "NamedVar " . showsPrec 11 x) + FreshVarAt _ n -> + showParen (d > 10) (showString "FreshVar " . showsPrec 11 n) + +instance Eq VarSymbol where + NamedVarAt _ x == NamedVarAt _ y = x == y + FreshVarAt _ n == FreshVarAt _ m = n == m + _ == _ = False + +instance Ord VarSymbol where + compare (NamedVarAt _ x) (NamedVarAt _ y) = compare x y + compare NamedVarAt{} FreshVarAt{} = LT + compare FreshVarAt{} NamedVarAt{} = GT + compare (FreshVarAt _ n) (FreshVarAt _ m) = compare n m + +instance Hashable VarSymbol where + hashWithSalt s = \case + NamedVarAt _ x -> hashWithSalt s (0 :: Int, x) + FreshVarAt _ n -> hashWithSalt s (1 :: Int, n) + +instance IsString VarSymbol where + fromString v = NamedVar $ Text.pack v + +instance Locatable VarSymbol where + locate = \case + NamedVarAt l _ -> l + FreshVarAt l _ -> l + +data Expr + = ExprVar VarSymbol + | ExprInteger Location Int + | ExprOp Location MixfixItem [Expr] + | ExprStructOp Location StructSymbol (Maybe Expr) + | ExprFiniteSet Location (NonEmpty Expr) + | ExprSep Location VarSymbol Expr Stmt + -- ^ Of the form /@{x ∈ X | P(x)}@/. + | ExprReplace Location Expr (NonEmpty (VarSymbol,Expr)) (Maybe Stmt) + -- ^ E.g.: /@{ f(x, y) | x ∈ X, y ∈ Y | P(x, y) }@/. + | ExprReplacePred Location VarSymbol VarSymbol Expr Stmt + -- ^ E.g.: /@{ y | \\exists x\\in X. P(x, y) }@/. + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Expr where + locate = \case + ExprVar x -> locate x + ExprInteger l _ -> l + ExprOp l _ _ -> l + ExprStructOp l _ _ -> l + ExprFiniteSet l _ -> l + ExprSep l _ _ _ -> l + ExprReplace l _ _ _ -> l + ExprReplacePred l _ _ _ _ -> l + + +data LexicalItem = LexicalItem Pattern Marker deriving (Show, Generic, NFData) + +instance Eq LexicalItem where + LexicalItem p _ == LexicalItem p' _ = p == p' + +instance Ord LexicalItem where + compare (LexicalItem p _) (LexicalItem p' _) = compare p p' + +instance Hashable LexicalItem where + hashWithSalt s (LexicalItem p _) = hashWithSalt s p + +data LexicalItemSgPl = LexicalItemSgPl (SgPl Pattern) Marker deriving (Show, Generic, NFData) + +instance Eq LexicalItemSgPl where + LexicalItemSgPl p _ == LexicalItemSgPl p' _ = sg p == sg p' + +instance Ord LexicalItemSgPl where + compare (LexicalItemSgPl p _) (LexicalItemSgPl p' _) = compare (sg p) (sg p') + +instance Hashable LexicalItemSgPl where + hashWithSalt s (LexicalItemSgPl p _) = hashWithSalt s (sg p) + +data Associativity + = LeftAssoc + | NonAssoc + | RightAssoc + deriving (Eq, Show, Ord, Generic, Hashable, NFData) + +data MixfixItem = MixfixItem Pattern Marker Associativity deriving (Eq, Show, Ord, Generic, Hashable, NFData) + +data Pattern = End | HoleCons Pattern | TokenCons Token Pattern deriving (Eq, Show, Ord, Generic, Hashable, NFData) + +type FunctionSymbol = MixfixItem + +newtype ParameterArity = ParameterArity Natural + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +zeroParameterArity :: ParameterArity +zeroParameterArity = ParameterArity 0 + +parameterArityOf :: Foldable f => f a -> ParameterArity +parameterArityOf = ParameterArity . fromIntegral . length + +parameterArityValue :: ParameterArity -> Natural +parameterArityValue (ParameterArity arity) = arity + +data RelationSymbol + = RelationSymbol Token ParameterArity Marker + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +newtype StructSymbol = StructSymbol { unStructSymbol :: Text } + deriving newtype (Show, Eq, Ord, Hashable, NFData) + +pattern ElementSymbol, NotElementSymbol :: RelationSymbol +pattern ElementSymbol = + RelationSymbol (Command "in") (ParameterArity 0) "elem" +pattern NotElementSymbol = + RelationSymbol (Command "notin") (ParameterArity 0) "notelem" + +pattern EqSymbol, NeqSymbol, SubseteqSymbol :: RelationSymbol +pattern EqSymbol = + RelationSymbol (Symbol "=") (ParameterArity 0) "eq" +pattern NeqSymbol = + RelationSymbol (Command "neq") (ParameterArity 0) "neq" +pattern SubseteqSymbol = + RelationSymbol (Command "subseteq") (ParameterArity 0) "subseteq" + +-- | The ordinary source-level @cons@ function symbol. +-- +-- Finite-set notation is intrinsic and does not desugar through this symbol. +pattern ConsSymbol :: FunctionSymbol +pattern ConsSymbol = + MixfixItem + (TokenCons (Command "cons") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End))))))) + "cons" + NonAssoc + +-- | The predefined @pair@ function symbol used for desugaring tuple notation.. +pattern PairSymbol :: FunctionSymbol +pattern PairSymbol = + MixfixItem + (TokenCons (Command "pair") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End))))))) + "pair" + NonAssoc + +-- | The concrete binary-tuple surface recognized by the dedicated tuple +-- grammar. It lowers to 'PairSymbol'. +tupleSurfacePattern :: Pattern +tupleSurfacePattern = + TokenCons ParenL + (HoleCons + (TokenCons (Symbol ",") + (HoleCons + (TokenCons ParenR End)))) + +-- | The predefined unordered-pair function symbol. +pattern UpairSymbol :: FunctionSymbol +pattern UpairSymbol = + MixfixItem + (TokenCons (Command "upair") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End))))))) + "upair" + NonAssoc + +-- | The fixed family-union function symbol. +pattern UnionsSymbol :: FunctionSymbol +pattern UnionsSymbol = + MixfixItem + (TokenCons (Command "unions") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End)))) + "unions" + NonAssoc + +-- | Function application /@f(x)@/ desugars to /@\apply{f}{x}@/. +pattern ApplySymbol :: FunctionSymbol +pattern ApplySymbol = + MixfixItem + (TokenCons (Command "apply") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End))))))) + "apply" + NonAssoc + +pattern DomSymbol :: FunctionSymbol +pattern DomSymbol = + MixfixItem + (TokenCons (Command "dom") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End)))) + "dom" + NonAssoc + +pattern CarrierSymbol :: StructSymbol +pattern CarrierSymbol = StructSymbol "carrier" + +patternFromHoley :: Holey Token -> Pattern +patternFromHoley = foldr step End + where + step = \case + Nothing -> HoleCons + Just tok -> TokenCons tok + +patternToHoley :: Pattern -> Holey Token +patternToHoley = \case + End -> [] + HoleCons pat -> Nothing : patternToHoley pat + TokenCons tok pat -> Just tok : patternToHoley pat + +mixfixPattern :: MixfixItem -> Pattern +mixfixPattern (MixfixItem pat _ _) = pat + +mixfixMarker :: MixfixItem -> Marker +mixfixMarker (MixfixItem _ m _) = m + +mixfixAssoc :: MixfixItem -> Associativity +mixfixAssoc (MixfixItem _ _ assoc) = assoc + +mkMixfixItem :: Holey Token -> Marker -> Associativity -> MixfixItem +mkMixfixItem pat m assoc = MixfixItem (patternFromHoley pat) m assoc + +lexicalItemPattern :: LexicalItem -> Pattern +lexicalItemPattern (LexicalItem pat _) = pat + +lexicalItemMarker :: LexicalItem -> Marker +lexicalItemMarker (LexicalItem _ m) = m + +lexicalItemPhrase :: LexicalItem -> LexicalPhrase +lexicalItemPhrase = patternToHoley . lexicalItemPattern + +lexicalItemSgPlPattern :: LexicalItemSgPl -> SgPl Pattern +lexicalItemSgPlPattern (LexicalItemSgPl pat _) = pat + +lexicalItemSgPlMarker :: LexicalItemSgPl -> Marker +lexicalItemSgPlMarker (LexicalItemSgPl _ m) = m + +lexicalItemSgPlPhrase :: LexicalItemSgPl -> SgPl LexicalPhrase +lexicalItemSgPlPhrase = fmap patternToHoley . lexicalItemSgPlPattern + +mkLexicalItem :: LexicalPhrase -> Marker -> LexicalItem +mkLexicalItem pat m = LexicalItem (patternFromHoley pat) m + +mkLexicalItemSgPl :: SgPl LexicalPhrase -> Marker -> LexicalItemSgPl +mkLexicalItemSgPl pat m = LexicalItemSgPl (patternFromHoley <$> pat) m + +relationSymbolToken :: RelationSymbol -> Token +relationSymbolToken (RelationSymbol tok _ _) = tok + +relationSymbolParameterArity :: RelationSymbol -> ParameterArity +relationSymbolParameterArity (RelationSymbol _ arity _) = arity + +relationSymbolMarker :: RelationSymbol -> Marker +relationSymbolMarker (RelationSymbol _ _ m) = m + +relationSymbolPattern :: RelationSymbol -> Pattern +relationSymbolPattern rel = + HoleCons (TokenCons (relationSymbolToken rel) (HoleCons End)) + +structSymbolPattern :: StructSymbol -> Pattern +structSymbolPattern (StructSymbol c) = TokenCons (Command c) End + +patternToken :: Pattern -> Maybe Token +patternToken = \case + TokenCons tok End -> Just tok + _ -> Nothing + +markerFromToken :: Token -> Marker +markerFromToken = \case + Word w -> Marker w + Symbol s -> Marker s + Command c -> Marker c + Integer n -> Marker (Text.pack (show n)) + tok -> error ("markerFromToken: unsupported token " <> show tok) + +pattern ExprConst :: Location -> Token -> Expr +pattern ExprConst l c <- ExprOp l (MixfixItem (TokenCons c End) _ NonAssoc) [] + where + ExprConst l c = ExprOp l (MixfixItem (TokenCons c End) (markerFromToken c) NonAssoc) [] + +pattern ExprApp :: Location -> Expr -> Expr -> Expr +pattern ExprApp loc e1 e2 = ExprOp loc ApplySymbol [e1, e2] + +pattern ExprPair :: Location -> Expr -> Expr -> Expr +pattern ExprPair loc e1 e2 = ExprOp loc PairSymbol [e1, e2] + +-- | Tuples are interpreted as nested pairs: +-- the triple /@(a, b, c)@/ is interpreted as +-- /@(a, (b, c))@/. +-- This means that the product operation should also +-- be right associative, so that /@(a, b, c)@/ can +-- form elements of /@A\times B\times C@/. +makeTuple :: Location -> NonEmpty Expr -> Expr +makeTuple l = \case + e :| [] -> e + e :| (e' : es) -> ExprPair l e (makeTuple l (e' :| es)) + + +data Chain + = ChainBase (NonEmpty Expr) Sign Relation (NonEmpty Expr) -- left arguments, possibly empty list of parameters, right arguments + | ChainCons (NonEmpty Expr) Sign Relation Chain + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Chain where + locate (ChainBase lhs _ _ _) = locate lhs + locate (ChainCons lhs _ _ _) = locate lhs + +data Relation + = Relation Location RelationSymbol [Expr] -- ^ E.g.: /@x \in X@/, potentially with parameters in braces + | RelationExpr Location Expr -- ^ E.g.: /@x \mathrel{R} y@/ + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Relation where + locate = \case + Relation l _ _ -> l + RelationExpr l _ -> l + +data Sign = Positive | Negative deriving (Show, Eq, Ord, Generic, NFData) + +data Formula + = FormulaChain Chain + | FormulaPredicate Location PrefixPredicate Marker (NonEmpty Expr) + | Connected Location Connective Formula Formula + | FormulaNeg Location Formula + | FormulaQuantified Location Quantifier (NonEmpty VarSymbol) Bound Formula + | PropositionalConstant Location PropositionalConstant + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Formula where + locate = \case + FormulaChain chain -> locate chain + FormulaPredicate l _ _ _ -> l + Connected l _ _ _ -> l + FormulaNeg l _ -> l + FormulaQuantified l _ _ _ _ -> l + PropositionalConstant l _ -> l + +data PropositionalConstant = IsBottom | IsTop + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +data PrefixPredicate + = PrefixPredicate Text Int + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + + +data Connective + = Conjunction + | Disjunction + | Implication + | Equivalence + | ExclusiveOr + | NegatedDisjunction + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + + + +mixfixLoc :: Locatable a => Holey (Located Token) -> [a] -> Location +mixfixLoc parts args0 = go parts args0 + where + go [] _ = Nowhere + go (Just ltok : _parts') _args' = startPos ltok + go (Nothing : parts') (a : args') + | locate a == Nowhere = go parts' args' + | otherwise = locate a + go (Nothing : parts') [] = go parts' [] + +makeConnective :: Holey (Located Token) -> [Formula] -> Formula +makeConnective parts@[Nothing, Just Located{unLocated = Command "implies"}, Nothing] [f1, f2] = Connected (mixfixLoc parts [f1, f2]) Implication f1 f2 +makeConnective parts@[Nothing, Just Located{unLocated = Command "land"}, Nothing] [f1, f2] = Connected (mixfixLoc parts [f1, f2]) Conjunction f1 f2 +makeConnective parts@[Nothing, Just Located{unLocated = Command "lor"}, Nothing] [f1, f2] = Connected (mixfixLoc parts [f1, f2]) Disjunction f1 f2 +makeConnective parts@[Nothing, Just Located{unLocated = Command "iff"}, Nothing] [f1, f2] = Connected (mixfixLoc parts [f1, f2]) Equivalence f1 f2 +makeConnective parts@[Just Located{unLocated = Command "lnot"}, Nothing] [f1] = FormulaNeg (mixfixLoc parts [f1]) f1 +makeConnective pat _ = error ("makeConnective does not handle the following connective correctly: " <> show pat) + + + +type StructPhrase = LexicalItemSgPl + +-- | For example 'an integer' would be +-- > Noun (unsafeReadPhrase "integer[/s]") [] +type Noun = NounOf Term +data NounOf a + = Noun Location LexicalItemSgPl [a] + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (NounOf a) where + locate (Noun l _ _) = l + + + + +type NounPhrase t = NounPhraseOf t Term +-- NOTE: 'NounPhraseOf' is only used with arguments of type 'Term', +-- but keeping the argument parameter @a@ allows the 'Show' and 'Eq' +-- instances to remain decidable. +data NounPhraseOf t a + = NounPhrase [AdjLOf a] (NounOf a) (t VarSymbol) [AdjROf a] (Maybe Stmt) + deriving (Generic) + +instance (Show a, Show (t VarSymbol)) => Show (NounPhraseOf t a) where + show (NounPhrase ls n vs rs ms) = + "NounPhrase (" + <> show ls <> ") (" + <> show n <> ") (" + <> show vs <> ") (" + <> show rs <> ") (" + <> show ms <> ")" + +instance (Eq a, Eq (t VarSymbol)) => Eq (NounPhraseOf t a) where + NounPhrase ls n vs rs ms == NounPhrase ls' n' vs' rs' ms' = + ls == ls' && n == n' && vs == vs' && rs == rs' && ms == ms' + +-- Raw syntax uses this lexicographic order for deterministic deduplication. +instance (Ord a, Ord (t VarSymbol)) => Ord (NounPhraseOf t a) where + NounPhrase ls n vs rs ms `compare` NounPhrase ls' n' vs' rs' ms' = + compare + (ls, n, vs, rs, ms) + (ls', n', vs', rs', ms') + +instance + (NFData a, NFData (t VarSymbol)) + => NFData (NounPhraseOf t a) + +-- | @Nameless a@ is quivalent to @Const () a@ (from "Data.Functor.Const"). +-- It describes a container that is unwilling to actually contain something. +-- @Nameless@ lets us treat nouns with no names, one name, or many names uniformly. +-- Thus @NounPhraseOf Nameless a@ is a noun phrase without a name and with arguments +-- of type @a@. +data Nameless a = Nameless deriving (Show, Eq, Ord, Generic, NFData) + + +-- | Left adjectives modify nouns from the left side, +-- e.g. /@even@/, /@continuous@/, and /@σ-finite@/. +type AdjL = AdjLOf Term +data AdjLOf a + = AdjL Location LexicalItem [a] + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (AdjLOf a) where + locate (AdjL l _ _) = l + + +-- | Right attributes consist of basic right adjectives, e.g. +-- /@divisible by ?@/, or /@of finite type@/ and verb phrases +-- marked with /@that@/, such as /@integer that divides n@/. +-- In some cases these right attributes may be followed +-- by an additional such-that phrase. +type AdjR = AdjROf Term +data AdjROf a + = AdjR Location LexicalItem [a] + | AttrRThat VerbPhrase + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (AdjROf a) where + locate (AdjR l _ _) = l + locate (AttrRThat vp) = locate vp + +-- | Adjectives for parts of the AST where adjectives are not used +-- to modify nouns and the L/R distinction does not matter, such as +-- when then are used together with a copula (like /@n is even@/). +type Adj = AdjOf Term +data AdjOf a + = Adj Location LexicalItem [a] + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (AdjOf a) where + locate (Adj l _ _) = l + + +type Verb = VerbOf Term +data VerbOf a + = Verb Location LexicalItemSgPl [a] + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (VerbOf a) where + locate (Verb l _ _) = l + + +type Fun = FunOf Term +data FunOf a + = Fun {loc :: Location, phrase :: LexicalItemSgPl, funArgs :: [a]} + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (FunOf a) where + locate = (.loc) + + +type VerbPhrase = VerbPhraseOf Term +data VerbPhraseOf a + = VPVerb (VerbOf a) + | VPAdj (NonEmpty (AdjOf a)) -- ^ @x is foo@ / @x is foo and bar@ + | VPVerbNot (VerbOf a) + | VPAdjNot (NonEmpty (AdjOf a)) -- ^ @x is not foo@ / @x is neither foo nor bar@ + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable (VerbPhraseOf a) where + locate = \case + VPVerb v -> locate v + VPAdj adjs -> locate adjs + VPVerbNot v -> locate v + VPAdjNot adjs -> locate adjs + + +data Quantifier + = Universally + | Existentially + | Nonexistentially + deriving (Show, Eq, Ord, Generic, NFData) + +data QuantPhrase = QuantPhrase Quantifier (NounPhrase []) deriving (Show, Eq, Ord, Generic, NFData) + + +data Term + = TermExpr Expr + -- ^ A symbolic expression. + | TermFun Fun + -- ^ Definite noun phrase, e.g. /@the derivative of $f$@/. + | TermIota Location VarSymbol Stmt + -- ^ Definite descriptor, e.g. /@an $x$ such that ...@// + | TermQuantified Quantifier Location (NounPhrase Maybe) + -- ^ Indefinite quantified notion, e.g. /@every even integer that divides $k$ ...@/. + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Term where + locate :: Term -> Location + locate (TermExpr e) = locate e + locate (TermFun f) = f.loc + locate (TermIota l _ _) = l + locate (TermQuantified _ l _) = l + + +data Stmt + = StmtFormula {formula :: Formula} -- ^ E.g.: /@We have \<Formula\>@/. + | StmtVerbPhrase {args :: NonEmpty Term, verb :: VerbPhrase} -- ^ E.g.: /@\<Term\> and \<Term\> \<verb\>@/. + | StmtNoun {args :: NonEmpty Term, noun :: (NounPhrase Maybe)} -- ^ E.g.: /@\<Term\> is a(n) \<NP\>@/. + | StmtStruct {arg :: Term, struct :: StructPhrase} + | StmtNeg {loc :: Location, stmt :: Stmt} -- ^ E.g.: /@It is not the case that \<Stmt\>@/. + | StmtExists {loc :: Location, np :: NounPhrase []} -- ^ E.g.: /@There exists a(n) \<NP\>@/. + | StmtConnected {conn :: Connective, mloc :: Maybe Location, stmt1 :: Stmt, stmt2 :: Stmt} + | StmtQuantPhrase {loc :: Location, qp :: QuantPhrase, stmt :: Stmt} + | SymbolicQuantified {loc :: Location, quant :: Quantifier, vars :: NonEmpty VarSymbol, b :: Bound, suchThat :: Maybe Stmt, stmt :: Stmt} + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Stmt where + locate :: Stmt -> Location + locate StmtFormula{formula = phi} = locate phi + locate StmtConnected{mloc = Just p} = p + locate StmtConnected{mloc = Nothing, stmt1 = s} = locate s + locate StmtVerbPhrase{args = a :| _} = locate a + locate StmtNoun{args = a :| _} = locate a + locate StmtStruct{arg = a} = locate a + locate StmtNeg{loc = p} = p + locate StmtExists{loc = p} = p + locate StmtQuantPhrase{loc = p} = p + locate SymbolicQuantified{loc = p} = p + +data Bound = Unbounded | Bounded Location Sign Relation Expr deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Bound where + locate = \case + Unbounded -> Nowhere + Bounded l _ _ _ -> l + +pattern SymbolicForall :: Location -> NonEmpty VarSymbol -> Bound -> Maybe Stmt -> Stmt -> Stmt +pattern SymbolicForall loc vs bound suchThat have = SymbolicQuantified loc Universally vs bound suchThat have + +pattern SymbolicExists :: Location -> NonEmpty VarSymbol -> Bound -> Stmt -> Stmt +pattern SymbolicExists loc vs bound suchThat = SymbolicQuantified loc Existentially vs bound Nothing suchThat + +makeSymbolicNotExists :: Location -> NonEmpty VarSymbol -> Bound -> Stmt -> Stmt +makeSymbolicNotExists p vs bound st = StmtNeg p (SymbolicExists p vs bound st) + +data Asm + = AsmSuppose Stmt + | AsmLetNoun (NonEmpty VarSymbol) (NounPhrase Maybe) -- ^ E.g.: /@let k be an integer@/ + | AsmLetIn (NonEmpty VarSymbol) Expr -- ^ E.g.: /@let $k\in\integers$@/ + | AsmLetThe VarSymbol Fun -- ^ E.g.: /@let $g$ be the derivative of $f$@/ + | AsmLetEq VarSymbol Expr -- ^ E.g.: /@let $m = n + k$@/ + | AsmLetStruct VarSymbol StructPhrase -- ^ E.g.: /@let $A$ be a monoid@/ + deriving (Show, Eq, Ord, Generic, NFData) + +data Axiom = Axiom [Asm] Stmt + deriving (Show, Eq, Ord, Generic, NFData) + +data Claim = Claim [Asm] Stmt + deriving (Show, Eq, Ord, Generic, NFData) + +-- | The head of the definition describes the part before the /@iff@/, +-- i.e. the definiendum. An optional noun-phrase corresponds to an optional +-- type annotation for the 'Term' of the head. The last part of the head +-- is the lexical phrase that is defined. +-- +-- > "A natural number $n$ divides $m$ iff ..." +-- > ^^^^^^^^^^^^^^^^ ^^^ ^^^^^^^^^^^ ^^^ +-- > type annotation variable verb definiens +-- > (a noun phrase) (all args are vars) (a statement) +-- +data DefnHead + = DefnAdj (Maybe (NounPhrase Maybe)) VarSymbol (AdjOf VarSymbol) + | DefnVerb (Maybe (NounPhrase Maybe)) VarSymbol (VerbOf VarSymbol) + | DefnNoun VarSymbol (NounOf VarSymbol) + | DefnSymbolicPredicate PrefixPredicate Marker (NonEmpty VarSymbol) + | DefnRel VarSymbol RelationSymbol [VarSymbol] VarSymbol + -- ^ E.g.: /@$x \subseteq y$ iff [...@/ + deriving (Show, Eq, Ord, Generic, NFData) + +data Defn + = Defn [Asm] DefnHead Stmt + | DefnFun [Asm] (FunOf VarSymbol) (Maybe Term) Term + -- ^ A 'DefnFun' consists of the functional noun (which must start with /@the@/) + -- and an optional specification of a symbolic equivalent. The symbolic equivalent + -- does not need to have the same variables as the full functional noun pattern. + -- + -- > "The tensor product of $U$ and $V$ over $K$, $U\tensor V$, is ..." + -- > ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^ ^^^ + -- > definiendum symbolic eqv. definiens + -- > (a functional noun) (an exression) (a term) + -- + | DefnOp SymbolPattern Expr + deriving (Show, Eq, Ord, Generic, NFData) + +data CalcQuantifier + = CalcQuantifier (NonEmpty VarSymbol) Bound (Maybe Stmt) + deriving (Show, Eq, Ord, Generic, NFData) + +data Proof + = Omitted Location + | Qed (Maybe Location) Justification + -- ^ Ends of a proof, leaving automation to discharge the current goal using the given justification. + | Contradiction Location Justification + -- ^ Ends a proof by deriving absurdity using the given justification. + | ByCase Location [Case] + | ByContradiction Location Proof + | BySetInduction Location (Maybe Term) Proof + -- ^ ∈-induction. + | ByOrdInduction Location Proof + -- ^ Transfinite induction for ordinals. + | Assume Location Stmt Proof + | FixSymbolic Location (NonEmpty VarSymbol) Bound Proof + | FixSuchThat Location (NonEmpty VarSymbol) Stmt Proof + | Calc Location (Maybe CalcQuantifier) Calc Proof + -- ^ Simplify goals that are implications or disjunctions. + | TakeVar Location (NonEmpty VarSymbol) Bound Stmt Justification Proof + | TakeNoun Location (NounPhrase []) Justification Proof + | Have Location (Maybe Stmt) Stmt Justification Proof + -- ^ /@Since \<stmt\>, we have \<stmt\> by \<ref\>.@/ + | Suffices Location Stmt Justification Proof + -- ^ /@It suffices to show that [...]. [...]@/ + | Subclaim Location Stmt Proof Proof + -- ^ A claim is a sublemma with its own proof: + -- /@Show \<goal stmt\>. \<steps\>. \<continue other proof\>.@/ + | Define Location VarSymbol Expr Proof + -- ^ Local definition. + -- + | DefineFunction Location VarSymbol VarSymbol Expr VarSymbol Expr Proof + -- ^ Local function definition, e.g. /@Let $f(x) = e$ for $x\\in d$@/. + -- The first 'VarSymbol' is the newly defined symbol, the second one is the argument. + -- The first 'Expr' is the value, the final variable and expr specify a bound (the domain of the function). + + + + + | DefineFunctionLocal Location VarSymbol VarSymbol Expr VarSymbol VarSymbol (NonEmpty (Expr, Formula)) Proof + -- ^ Local function definition, but in this case we give the domain and target an the rules for $xs$ in some sub domains. + -- + deriving (Show, Eq, Ord, Generic, NFData) + +-- | An inline justification. +data Justification + = JustificationRef (NonEmpty Marker) + | JustificationSetExt + | JustificationEmpty + | JustificationLocal -- ^ Use only local assumptions + deriving (Show, Eq, Ord, Generic, NFData) + + +-- | A case of a case split. +data Case = Case + { caseOf :: Stmt + , caseProof :: Proof + } deriving (Show, Eq, Ord, Generic, NFData) + +data Calc + = Equation Expr (NonEmpty (Expr, Justification)) + -- ^ A chain of equalities. Each claimed equality has a (potentially empty) justification. + -- For example: @a &= b \\explanation{by \\cref{a_eq_b}} &= c@ + -- would be (modulo expr constructors) + -- @Equation "a" [("b", JustificationRef "a_eq_b"), ("c", JustificationEmpty)]@. + | Biconditionals Formula (NonEmpty (Formula, Justification)) + deriving (Show, Eq, Ord, Generic, NFData) + + +data Abbreviation + = AbbreviationAdj VarSymbol (AdjOf VarSymbol) Stmt + | AbbreviationVerb VarSymbol (VerbOf VarSymbol) Stmt + | AbbreviationNoun VarSymbol (NounOf VarSymbol) Stmt + | AbbreviationRel VarSymbol RelationSymbol [VarSymbol] VarSymbol Stmt + | AbbreviationFun (FunOf VarSymbol) Term + | AbbreviationEq SymbolPattern Expr + deriving (Show, Eq, Ord, Generic, NFData) + +data Datatype + = Datatype + { datatypeHeadExpr :: Expr + , datatypeClauses :: NonEmpty DatatypeClause + } + deriving (Show, Eq, Ord, Generic, NFData) + +data DatatypeClause = DatatypeClause + { datatypeClauseConstructorExpr :: Expr + , datatypeClauseTargetExpr :: Expr + , datatypeClausePremises :: [(VarSymbol, Expr)] + } + deriving (Show, Eq, Ord, Generic, NFData) + +data Inductive = Inductive + { inductiveSymbolPattern :: SymbolPattern + , inductiveDomain :: Expr + , inductiveIntros :: NonEmpty IntroRule + } + deriving (Show, Eq, Ord, Generic, NFData) + +data IntroRule = IntroRule + { introConditions :: [Formula] -- The inductively defined set may only appear as an argument of monotone operations on the rhs. + , introResult :: Formula -- TODO Refine. + } + deriving (Show, Eq, Ord, Generic, NFData) + + +data SymbolPattern = SymbolPattern FunctionSymbol [VarSymbol] + deriving (Show, Eq, Ord, Generic, NFData) + +data Signature + = SignatureAdj VarSymbol (AdjOf VarSymbol) + -- The verb and noun forms are available to programmatic AST consumers but + -- have no concrete source syntax. + | SignatureVerb VarSymbol (VerbOf VarSymbol) + | SignatureNoun VarSymbol (NounOf VarSymbol) + | SignatureSymbolic SymbolPattern (NounPhrase Maybe) + -- ^ /@$\<symbol\>(\<vars\>)$ is a \<noun\>@/ + deriving (Show, Eq, Ord, Generic, NFData) + + +data StructDefn = StructDefn + { structPhrase :: StructPhrase + -- ^ E.g.: @partial order@ or @abelian group@.\ + , structParents :: [StructPhrase] + -- ^ Structural parents + , structLabel :: VarSymbol + , structFixes :: [StructSymbol] + -- ^ List of text for commands representing constants not inherited from its parents, + -- e.g.: @\sqsubseteq@ or @\inv@. + , structAssumes :: [(Marker, Stmt)] + } + deriving (Show, Eq, Ord, Generic, NFData) + +newtype Marker = Marker Text + deriving stock (Show, Eq, Ord, Generic) + +deriving newtype instance Hashable Marker +deriving newtype instance NFData Marker + +instance IsString Marker where + fromString str = Marker (Text.pack str) + +type BlockTitle = [Token] + +data ClaimKind + = Proposition + | Theorem + | Lemma + | Corollary + | PlainClaim + deriving (Show, Eq, Ord, Generic, NFData) + +data Block + = BlockAxiom Location (Maybe BlockTitle) Marker Axiom + | BlockClaim ClaimKind Location (Maybe BlockTitle) Marker Claim + | BlockProof Location Proof Location -- ^ Proof start and ending location. + | BlockDefn Location (Maybe BlockTitle) Marker Defn + | BlockAbbr Location (Maybe BlockTitle) Marker Abbreviation + | BlockData Location (Maybe BlockTitle) Marker Datatype + | BlockInductive Location (Maybe BlockTitle) Marker Inductive + | BlockSig Location (Maybe BlockTitle) Marker [Asm] Signature + | BlockStruct Location (Maybe BlockTitle) Marker StructDefn + deriving (Show, Eq, Ord, Generic, NFData) + +instance Locatable Block where + locate = \case + BlockAxiom location _title _marker _axiom -> location + BlockClaim _kind location _title _marker _claim -> location + BlockProof location _proof _end -> location + BlockDefn location _title _marker _definition -> location + BlockAbbr location _title _marker _abbreviation -> location + BlockData location _title _marker _datatype -> location + BlockInductive location _title _marker _inductive -> location + BlockSig location _title _marker _assumptions _signature -> location + BlockStruct location _title _marker _structure -> location diff --git a/source/Felix/Syntax/Adapt.hs b/source/Felix/Syntax/Adapt.hs new file mode 100644 index 0000000..eb0cb6c --- /dev/null +++ b/source/Felix/Syntax/Adapt.hs @@ -0,0 +1,928 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module Felix.Syntax.Adapt + ( FunctionPatternError(..) + , LexicalScanError(..) + , ScannedLexicalItem(..) + , scannedItemMarker + , canonicalScannedItem + , SyntaxMaterializationError(..) + , materializeSyntaxDelta + , scanChunk + ) where + +import Base +import Felix.Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon +import Felix.Report.Location + +import Control.Monad (foldM) +import Data.Bifunctor qualified as Bifunctor +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Numeric.Natural (Natural) +import Text.Regex.Applicative qualified as RE +import Text.Regex.Applicative (RE) + +data FunctionPatternError + = FunctionPatternEmpty + | FunctionPatternBareVariable + | FunctionPatternReservedApplication + deriving (Show, Eq) + +data LexicalScanError + = MalformedLexicalEnvironment !Location !Text + | InvalidFunctionPattern !Location !FunctionPatternError + | MalformedDatatype !Location !Text + deriving (Eq) + +instance Show LexicalScanError where + show = \case + MalformedLexicalEnvironment location environment -> + "could not find a lexical pattern in " + <> Text.unpack environment + <> " at " + <> prettyLocation location + InvalidFunctionPattern location problem -> + functionPatternErrorMessage problem + <> " at " + <> prettyLocation location + MalformedDatatype location problem -> + "malformed datatype declaration at " + <> prettyLocation location + <> ": " + <> Text.unpack problem + +scanChunk + :: [Located Token] + -> Either LexicalScanError [Located ScannedLexicalItem] +scanChunk ltoks = + case ltoks of + first@Located{startPos = pos, unLocated = BeginEnv "definition"} : _ -> + locateAt first + <$> (matchOrErr (definition pos) "definition" pos >>= id) + first@Located{startPos = pos, unLocated = BeginEnv "signature"} : _ -> + locateAt first + <$> (matchOrErr (signatureExtension pos) "signature" pos >>= id) + first@Located{startPos = pos, unLocated = BeginEnv "abbreviation"} : _ -> + locateAt first + <$> (matchOrErr (abbreviation pos) "abbreviation" pos >>= id) + first@Located{startPos = pos, unLocated = BeginEnv "struct"} : _ -> + locateStructItems first ltoks + <$> matchOrErr structRE "struct definition" pos + first@Located{startPos = pos, unLocated = BeginEnv "inductive"} : _ -> + locateAt first + <$> (matchOrErr (inductive pos) "inductive definition" pos >>= id) + Located{startPos = pos, unLocated = BeginEnv "datatype"} : _ -> + scanDatatypeChunk pos ltoks + _ -> + Right [] + where + toks = unLocated <$> ltoks + + matchOrErr + :: RE Token a + -> Text + -> Location + -> Either LexicalScanError a + matchOrErr re environment location = + case RE.match re toks of + Nothing -> + Left + (MalformedLexicalEnvironment + location + environment) + Just result -> + Right result + + locateAt first items = + [item <$ first | item <- items] + +data ScannedLexicalItem + = ScanAdj LexicalPhrase Marker + | ScanFun LexicalPhrase Marker + | ScanNoun LexicalPhrase Marker + | ScanStructNoun LexicalPhrase Marker + | ScanVerb LexicalPhrase Marker + | ScanRelationSymbol Token ParameterArity Marker + | ScanFunctionSymbol Pattern Marker + | ScanPrefixPredicate PrefixPredicate Marker + | ScanStructOp Text -- we an use the command text as export name. + deriving (Show, Eq, Ord) + +scannedItemMarker :: ScannedLexicalItem -> Marker +scannedItemMarker = \case + ScanAdj _item marker -> + marker + ScanFun _item marker -> + marker + ScanNoun _item marker -> + marker + ScanStructNoun _item marker -> + marker + ScanVerb _item marker -> + marker + ScanRelationSymbol _token _arity marker -> + marker + ScanFunctionSymbol _pattern marker -> + marker + ScanPrefixPredicate _predicate marker -> + marker + ScanStructOp commandText -> + Marker commandText + +canonicalScannedItem + :: Fixity + -> ScannedLexicalItem + -> CanonicalLexicalEntry +canonicalScannedItem fixity = \case + ScanAdj phrase marker + | isAdjR phrase -> + CanonicalRightAdjective + (patternFromHoley phrase) + marker + | otherwise -> + CanonicalLeftAdjective + (patternFromHoley phrase) + marker + ScanFun phrase marker -> + canonicalSgPl + CanonicalFunctionPhrase + (guessNounPlural phrase) + marker + ScanNoun phrase marker -> + canonicalSgPl + CanonicalNoun + (guessNounPlural phrase) + marker + ScanStructNoun phrase marker -> + canonicalSgPl + CanonicalStructureNoun + (guessNounPlural phrase) + marker + ScanVerb phrase marker -> + canonicalSgPl + CanonicalVerb + (guessVerbPlural phrase) + marker + ScanRelationSymbol token arity marker -> + CanonicalRelation token arity marker + ScanFunctionSymbol pat marker -> + CanonicalExpressionFunction + (if pat == tupleSurfacePattern + then mixfixPattern PairSymbol + else pat) + marker + fixity + ScanPrefixPredicate + (PrefixPredicate commandText arity) + marker -> + CanonicalPrefixPredicate + commandText + (fromIntegral arity) + marker + ScanStructOp commandText -> + CanonicalStructureOperation commandText + where + canonicalSgPl constructor phrases marker = + constructor + (patternFromHoley (sg phrases)) + (patternFromHoley (pl phrases)) + marker + +data SyntaxMaterializationError + = MaterializedSyntaxCollision !CanonicalSyntaxCollision + | PrefixPredicateArityOutOfRange !Natural + deriving (Show, Eq) + +materializeSyntaxDelta + :: CanonicalSyntaxDelta + -> Either SyntaxMaterializationError Lexicon +materializeSyntaxDelta delta = do + combined <- + Bifunctor.first MaterializedSyntaxCollision + (canonicalSyntaxDelta + (fixedBaseSyntaxEntries + <> canonicalSyntaxDeltaEntries delta)) + foldM + insertCanonicalEntry + builtins + [ entry + | entry <- canonicalSyntaxDeltaEntries combined + , entry `Set.notMember` fixedEntries + ] + where + fixedEntries = + Set.fromList fixedBaseSyntaxEntries + +insertCanonicalEntry + :: Lexicon + -> CanonicalLexicalEntry + -> Either SyntaxMaterializationError Lexicon +insertCanonicalEntry lexicon@Lexicon{..} entry = do + extended <- case entry of + CanonicalLeftAdjective pat marker -> + pure + lexicon + { lexiconAdjLs = + lexicalItem pat marker : lexiconAdjLs + } + CanonicalRightAdjective pat marker -> + pure + lexicon + { lexiconAdjRs = + lexicalItem pat marker : lexiconAdjRs + } + CanonicalFunctionPhrase singular plural marker -> + pure + lexicon + { lexiconFuns = + lexicalItemSgPl singular plural marker + : lexiconFuns + } + CanonicalNoun singular plural marker -> + pure + lexicon + { lexiconNouns = + lexicalItemSgPl singular plural marker + : lexiconNouns + } + CanonicalStructureNoun singular plural marker -> + pure + lexicon + { lexiconStructNouns = + lexicalItemSgPl singular plural marker + : lexiconStructNouns + } + CanonicalVerb singular plural marker -> + pure + lexicon + { lexiconVerbs = + lexicalItemSgPl singular plural marker + : lexiconVerbs + } + CanonicalRelation token arity marker -> + pure + lexicon + { lexiconRelationSymbols = + RelationSymbol token arity marker + : lexiconRelationSymbols + } + CanonicalExpressionFunction + pat + marker + (Fixity associativity level) -> + pure + lexicon + { lexiconMixfixTable = + Seq.adjust + (Map.insert + pat + (MixfixItem + pat + marker + associativity)) + (fromIntegral + (mixfixLevelValue level)) + lexiconMixfixTable + } + CanonicalPrefixPredicate commandText arity marker -> do + runtimeArity <- + if arity <= fromIntegral (maxBound :: Int) + then pure (fromIntegral arity) + else + Left + (PrefixPredicateArityOutOfRange arity) + pure + lexicon + { lexiconPrefixPredicates = + (PrefixPredicate commandText runtimeArity, marker) + : lexiconPrefixPredicates + } + CanonicalStructureOperation commandText -> + pure + lexicon + { lexiconStructFun = + StructSymbol commandText : lexiconStructFun + } + pure extended + where + lexicalItem pat marker = + mkLexicalItem (patternToHoley pat) marker + + lexicalItemSgPl singular plural marker = + mkLexicalItemSgPl + (SgPl + (patternToHoley singular) + (patternToHoley plural)) + marker + +skipUntilNextLexicalEnv :: RE Token [Token] +skipUntilNextLexicalEnv = many (RE.psym otherToken) + where + otherToken tok = tok /= BeginEnv "definition" && tok /= BeginEnv "struct" && tok /= BeginEnv "abbreviation" + +notEndOfLexicalEnvToken :: RE Token Token +notEndOfLexicalEnvToken = RE.psym innerToken + where + innerToken tok = tok /= EndEnv "definition" && tok /= EndEnv "struct" && tok /= EndEnv "abbreviation" + +notEndOfSignatureSentenceToken :: RE Token Token +notEndOfSignatureSentenceToken = RE.psym \case + Symbol "." -> False + EndEnv "signature" -> False + _ -> True + +definition + :: Location + -> RE Token (Either LexicalScanError [ScannedLexicalItem]) +definition location = do + RE.sym (BeginEnv "definition") + RE.few notEndOfLexicalEnvToken + m <- labelRE + RE.few RE.anySym + lexicalItem <- headRE location + RE.few RE.anySym + RE.sym (EndEnv "definition") + skipUntilNextLexicalEnv + pure ((: []) <$> lexicalItem m) + +abbreviation + :: Location + -> RE Token (Either LexicalScanError [ScannedLexicalItem]) +abbreviation location = do + RE.sym (BeginEnv "abbreviation") + RE.few RE.anySym + m <- labelRE + RE.few RE.anySym + lexicalItem <- headRE location + RE.few RE.anySym + RE.sym (EndEnv "abbreviation") + skipUntilNextLexicalEnv + pure ((: []) <$> lexicalItem m) + +signatureExtension + :: Location + -> RE Token (Either LexicalScanError [ScannedLexicalItem]) +signatureExtension location = do + RE.sym (BeginEnv "signature") + RE.few notEndOfLexicalEnvToken + m <- labelRE + RE.few RE.anySym + lexicalItem <- sigHeadRE location + RE.few notEndOfSignatureSentenceToken + RE.sym (Symbol ".") + RE.sym (EndEnv "signature") + skipUntilNextLexicalEnv + pure ((: []) <$> lexicalItem m) + +labelRE :: RE Token Marker +labelRE = RE.msym \case + Label m -> Just (Marker m) + _ -> Nothing + +-- | 'RE' that matches the head of a definition. +headRE + :: Location + -> RE Token (Marker -> Either LexicalScanError ScannedLexicalItem) +-- Note that @<|>@ is left biased for 'RE', so we can just +-- place 'adj' before 'verb' and do not have to worry about +-- overlapping patterns. +headRE location = + pureScan ScanNoun <$> nounRE + <|> pureScan ScanAdj <$> adjRE + <|> pureScan ScanVerb <$> verbRE + <|> pureScan ScanFun <$> funRE + <|> relationScan <$> relationSymbolRE + <|> functionScan <$> functionSymbolRE location + <|> pureScan ScanPrefixPredicate <$> prefixPredicate + where + pureScan constructor value marker = + Right (constructor value marker) + + relationScan (token, arity) marker = + Right (ScanRelationSymbol token arity marker) + + functionScan patternResult marker = + (`ScanFunctionSymbol` marker) <$> patternResult + +sigHeadRE + :: Location + -> RE Token (Marker -> Either LexicalScanError ScannedLexicalItem) +sigHeadRE location = + asum + [ signatureHeadRE form + | form <- concreteSignatureHeadForms + ] + where + signatureHeadRE = \case + AdjectiveSignatureHead -> + pureScan ScanAdj <$> sigAdjectiveRE + SymbolicSignatureHead -> + functionScan <$> sigFunctionSymbolRE location + + pureScan constructor value marker = + Right (constructor value marker) + + functionScan patternResult marker = + (`ScanFunctionSymbol` marker) <$> patternResult + +sigAdjectiveRE :: RE Token LexicalPhrase +sigAdjectiveRE = + toLexicalPhrase + <$> ( math var + *> RE.sym (Word "can") + *> RE.sym (Word "be") + *> RE.some + (RE.psym isLexicalPhraseToken <|> math var) + ) + +sigFunctionSymbolRE :: Location -> RE Token (Either LexicalScanError Pattern) +sigFunctionSymbolRE location = do + RE.sym (BeginEnv "math") + toks <- RE.few nonDefinitionKeyword + RE.sym (EndEnv "math") + pure (makeFunctionSymbol location toks) + +inductive + :: Location + -> RE Token (Either LexicalScanError [ScannedLexicalItem]) +inductive location = do + RE.sym (BeginEnv "inductive") + RE.few notEndOfLexicalEnvToken + m <- labelRE + RE.few RE.anySym + lexicalItem <- functionSymbolInductive location + RE.few RE.anySym + RE.sym (EndEnv "inductive") + skipUntilNextLexicalEnv + pure (((: []) . (`ScanFunctionSymbol` m)) <$> lexicalItem) + +scanDatatypeChunk + :: Location + -> [Located Token] + -> Either LexicalScanError [Located ScannedLexicalItem] +scanDatatypeChunk = datatypeLexicalItems + +datatypeLexicalItems + :: Location + -> [Located Token] + -> Either LexicalScanError [Located ScannedLexicalItem] +datatypeLexicalItems environmentLocation toks = do + marker <- requireDatatype + environmentLocation + "missing declaration label" + (findDatatypeLabel toks) + datatypeHeadToks <- requireDatatype + environmentLocation + "missing datatype head" + (findDatatypeHead toks) + constructorToks <- requireDatatype + environmentLocation + "missing constructor enumeration" + (findDatatypeConstructors toks) + let datatypeLocation = + maybe environmentLocation startPos (listToMaybe datatypeHeadToks) + datatypePattern <- makeFunctionSymbol + datatypeLocation + (unLocated <$> datatypeHeadToks) + constructorItems <- traverse makeConstructor constructorToks + pure + ((ScanFunctionSymbol datatypePattern marker + <$ locationTemplate datatypeLocation toks) + : constructorItems) + where + makeConstructor (itemLocation, raw) = do + constructorToks <- requireDatatype + itemLocation + "constructor item has no symbolic declaration" + (itemConstructorToks raw) + let stripped = stripOuterParens constructorToks + markerToken <- constructorMarker itemLocation stripped + constructorPattern <- makeFunctionSymbol + (startPos markerToken) + (unLocated <$> stripped) + pure + (ScanFunctionSymbol + constructorPattern + (markerFromToken (unLocated markerToken)) + <$ markerToken) + +requireDatatype + :: Location + -> Text + -> Maybe a + -> Either LexicalScanError a +requireDatatype location problem = + maybe (Left (MalformedDatatype location problem)) Right + +locationTemplate :: Location -> [Located Token] -> Located Token +locationTemplate location = \case + token : _ -> + token{startPos = location} + [] -> + impossible "datatype scanner has no environment token" + +findDatatypeLabel :: [Located Token] -> Maybe Marker +findDatatypeLabel = \case + [] -> Nothing + Located{unLocated = Label m} : _ -> Just (Marker m) + _ : toks -> findDatatypeLabel toks + +findDatatypeHead :: [Located Token] -> Maybe [Located Token] +findDatatypeHead toks = do + afterLabel <- tailMay =<< dropUntil (isLabel . unLocated) toks + defineToks <- dropUntil ((== Word "define") . unLocated) afterLabel + case defineToks of + _define : Located{unLocated = BeginEnv "math"} : rest -> + takeUntilToken (EndEnv "math") rest + _ -> Nothing + +findDatatypeConstructors + :: [Located Token] + -> Maybe [(Location, [Located Token])] +findDatatypeConstructors toks = do + afterEnumerate <- tailMay + =<< dropUntil ((== BeginEnv "enumerate") . unLocated) toks + enumerateBody <- takeUntilToken (EndEnv "enumerate") afterEnumerate + let items = splitDatatypeItems enumerateBody + guard (not (null items)) + pure items + +splitDatatypeItems + :: [Located Token] + -> [(Location, [Located Token])] +splitDatatypeItems = \case + [] -> + [] + Located{startPos = itemLocation, unLocated = Command "item"} : rest -> + let (item, remaining) = + break ((== Command "item") . unLocated) rest + in (itemLocation, item) : splitDatatypeItems remaining + _ : rest -> + splitDatatypeItems rest + +itemConstructorToks :: [Located Token] -> Maybe [Located Token] +itemConstructorToks toks = do + afterMath <- tailMay =<< dropUntil ((== BeginEnv "math") . unLocated) toks + mathBody <- takeUntilToken (EndEnv "math") afterMath + takeUntilToken (Command "in") mathBody + +constructorMarker + :: Location + -> [Located Token] + -> Either LexicalScanError (Located Token) +constructorMarker fallback = + maybe + (Left + (MalformedDatatype + fallback + "constructor has no marker-bearing head token")) + Right + . find (isConstructorMarkerToken . unLocated) + +isConstructorMarkerToken :: Token -> Bool +isConstructorMarkerToken = \case + Word _ -> True + Symbol _ -> True + Command _ -> True + Integer _ -> True + _ -> False + +stripOuterParens :: [Located Token] -> [Located Token] +stripOuterParens toks + | hasOuterParens toks = case toks of + Located{unLocated = ParenL} : rest -> case reverse rest of + Located{unLocated = ParenR} : innerRev -> reverse innerRev + _ -> toks + _ -> toks + | otherwise = toks + +hasOuterParens :: [Located Token] -> Bool +hasOuterParens = \case + Located{unLocated = ParenL} : rest -> go (1 :: Int) rest + _ -> False + where + go _ [] = False + go depth [Located{unLocated = ParenR}] = depth == 1 + go depth (Located{unLocated = ParenL} : rest) = + go (depth + 1) rest + go depth (Located{unLocated = ParenR} : rest) + | depth <= 0 = False + | otherwise = go (depth - 1) rest + go depth (_ : rest) = go depth rest + +isLabel :: Token -> Bool +isLabel = \case + Label _ -> True + _ -> False + +dropUntil :: (a -> Bool) -> [a] -> Maybe [a] +dropUntil predicate = \case + [] -> Nothing + xs@(x : rest) + | predicate x -> Just xs + | otherwise -> dropUntil predicate rest + +takeUntilToken :: Token -> [Located Token] -> Maybe [Located Token] +takeUntilToken stop = \case + [] -> Nothing + x : xs + | unLocated x == stop -> Just [] + | otherwise -> (x :) <$> takeUntilToken stop xs + +tailMay :: [a] -> Maybe [a] +tailMay = \case + [] -> Nothing + _ : xs -> Just xs + +structRE :: RE Token [ScannedLexicalItem] +structRE = do + RE.sym (BeginEnv "struct") + RE.few RE.anySym + m <- labelRE + RE.few RE.anySym + lexicalItem <- ScanStructNoun . toLexicalPhrase <$> (an *> structPat <* math var) + RE.few RE.anySym + lexicalItems <- structOps <|> pure [] + RE.sym (EndEnv "struct") + skipUntilNextLexicalEnv + pure (lexicalItem m : lexicalItems) + +structOps :: RE Token [ScannedLexicalItem] +structOps = do + RE.sym (BeginEnv "enumerate") + lexicalItems <- many structOp + RE.sym (EndEnv "enumerate") + RE.few RE.anySym + pure lexicalItems + +structOp :: RE Token ScannedLexicalItem +structOp = do + RE.sym (Command "item") + op <- math command + pure (ScanStructOp op) + +locateStructItems + :: Located Token + -> [Located Token] + -> [ScannedLexicalItem] + -> [Located ScannedLexicalItem] +locateStructItems environmentToken toks = \case + [] -> + [] + structureNoun : operations -> + (structureNoun <$ environmentToken) + : zipWith locateOperation operations operationTokens + where + operationTokens = + structOperationTokens toks + <> repeat environmentToken + + locateOperation operation token = + operation <$ token + +structOperationTokens :: [Located Token] -> [Located Token] +structOperationTokens = \case + Located{unLocated = Command "item"} + : Located{unLocated = BeginEnv "math"} + : commandToken@Located{unLocated = Command _} + : Located{unLocated = EndEnv "math"} + : rest -> + commandToken : structOperationTokens rest + _ : rest -> + structOperationTokens rest + [] -> + [] + +nounRE :: RE Token LexicalPhrase +nounRE = toLexicalPhrase <$> (math var *> is *> an *> patRE <* iff) + +adjRE :: RE Token LexicalPhrase +adjRE = toLexicalPhrase <$> (math var *> is *> patRE <* iff) + +verbRE :: RE Token LexicalPhrase +verbRE = toLexicalPhrase <$> (math var *> patRE <* iff) + +funRE :: RE Token LexicalPhrase +funRE = toLexicalPhrase <$> (the *> patRE <* (is <|> comma)) + +relationSymbolRE :: RE Token (Token, ParameterArity) +relationSymbolRE = do + beginMath + var + rel <- symbol + k <- params + var + endMath + iff + pure (rel, k) + where + params :: RE Token ParameterArity + params = do + vars <- many (RE.sym InvisibleBraceL *> var <* RE.sym InvisibleBraceR) + pure (parameterArityOf vars) + +functionSymbolRE + :: Location + -> RE Token (Either LexicalScanError Pattern) +functionSymbolRE location = do + RE.sym (BeginEnv "math") + toks <- RE.few nonDefinitionKeyword + RE.sym (Symbol "=") + pure (makeFunctionSymbol location toks) + +makeFunctionSymbol + :: Location + -> [Token] + -> Either LexicalScanError Pattern +makeFunctionSymbol location = \case + [] -> + Left (InvalidFunctionPattern location FunctionPatternEmpty) + [Variable _] -> + Left (InvalidFunctionPattern location FunctionPatternBareVariable) + [Variable _, ParenL, Variable _, ParenR] -> + Left + (InvalidFunctionPattern + location + FunctionPatternReservedApplication) + toks -> + Right (patternFromHoley (fromToken <$> toks)) + where + fromToken = \case + Variable _ -> Nothing -- Variables become slots. + tok -> Just tok -- Everything else is part of the pattern. + +functionPatternErrorMessage :: FunctionPatternError -> String +functionPatternErrorMessage = \case + FunctionPatternEmpty -> + "malformed function pattern: no pattern" + FunctionPatternBareVariable -> + "malformed function pattern: a bare variable would cause infinite left recursion" + FunctionPatternReservedApplication -> + "malformed function pattern: _(_) is reserved for set-theoretic function application" + +functionSymbolInductive + :: Location + -> RE Token (Either LexicalScanError Pattern) +functionSymbolInductive location = do + RE.sym (BeginEnv "math") + toks <- RE.few nonDefinitionKeyword + RE.sym (Command "subseteq") + pure (makeFunctionSymbol location toks) + +prefixPredicate :: RE Token PrefixPredicate +prefixPredicate = math prfx <* iff + where + prfx = do + r <- command + args <- many (RE.sym InvisibleBraceL *> var <* RE.sym InvisibleBraceR) + pure (PrefixPredicate r (length args)) + + +command :: RE Token Text +command = RE.msym \case + Command cmd -> Just cmd + _ -> Nothing + +var :: RE Token Token +var = RE.psym isVar + + +nonDefinitionKeyword :: RE Token Token +nonDefinitionKeyword = RE.psym (`notElem` keywords) + where + keywords = + [ Word "if" + , Word "iff" + , Symbol "=" + , Command "iff" + , BeginEnv "math" + , EndEnv "math" + ] + + +patRE :: RE Token [Token] +patRE = many (RE.psym isLexicalPhraseToken <|> math var) + +structPat :: RE Token [Token] +structPat = many (RE.psym isLexicalPhraseToken) + +beginMath, endMath :: RE Token () +beginMath = void (RE.sym (BeginEnv "math")) +endMath = void (RE.sym (EndEnv "math")) + +math :: RE Token a -> RE Token a +math re = beginMath *> re <* endMath + +-- | We allow /conditional perfection/: the first /@if@/ in a definition is interpreted as /@iff@/. +iff :: RE Token () +iff = void (RE.sym (Word "if")) -- Using @void@ is faster (only requires recognition). + <|> void (RE.sym (Word "iff")) + <|> void (RE.string [Word "if", Word "and", Word "only", Word "if"]) + <|> void (RE.sym (Word "denote")) + <|> void (RE.sym (Word "stand") *> RE.sym (Word "for")) +{-# INLINE iff #-} + +an :: RE Token () +an = void (RE.sym (Word "a")) + <|> void (RE.sym (Word "an")) +{-# INLINE an #-} + +is :: RE Token () +is = void (RE.sym (Word "is") <|> RE.sym (Word "denotes")) +{-# INLINE is #-} + +the :: RE Token () +the = void (RE.sym (Word "the")) +{-# INLINE the #-} + +comma :: RE Token () +comma = void (RE.sym (Symbol ",")) +{-# INLINE comma #-} + + +isVar :: Token -> Bool +isVar = \case + Variable _ -> True + _token -> False + +isLexicalPhraseToken :: Token -> Bool +isLexicalPhraseToken = \case + Word w -> w `Set.notMember` keywords + -- + -- Simple commands (outside of math-mode) are allowed. This is useful + -- for defining lexical phrases containing symbolic expressions such as + -- `X is \Ttwo{}`, where `\Ttwo` is a macro that expands to `T_2`. + -- We also allow these macros to take arguments, hence the need to + -- allow grouping delimiters. They can also be used to escape the end + -- of the command for correct spacing, as in the above example. + -- + Command _cmd -> True + InvisibleBraceL -> True + InvisibleBraceR -> True + -- + -- No other tokens may occur in lexical phrases. In particular, no `_dot` + -- token may occur, limiting the lexical phrase to a single sentence. + -- Commas occurring in variable lists should be placed + -- within the math environment. Thus `$a,b$ are coprime iff`, + -- not `$a$,`$b$` are coprime iff`. + -- + _token -> False + where + keywords = Set.fromList ["a", "an", "is", "are", "if", "iff", "denote", "stand", "let"] + + +toLexicalPhrase :: [Token] -> LexicalPhrase +toLexicalPhrase toks = component <$> toks + where + component = \case + Variable _ -> Nothing + tok -> Just tok + + +symbol :: RE Token Token +symbol = RE.msym $ \tok -> case tok of + Command _ -> Just tok + Symbol _ -> Just tok + _tok -> Nothing + + +-- | Basic paradigms for pluralizations of nominals. +guessNounPlural :: LexicalPhrase -> SgPl LexicalPhrase +guessNounPlural item = SgPl item (pluralize item) + where + pluralize :: LexicalPhrase -> LexicalPhrase + pluralize = \case + Just (Word w) : pat'@(Just w' : _) | isPreposition w' -> Just (Word (Text.snoc w 's')) : pat' + tok : Just (Word w) : pat'@(Just w' : _) | isPreposition w' -> tok : Just (Word (Text.snoc w 's')) : pat' + tok1 : tok2 : Just (Word w) : pat'@(Just w' : _) | isPreposition w' -> tok1 : tok2 : Just (Word (Text.snoc w 's')) : pat' + [Just (Word w)] -> [Just (Word (Text.snoc w 's'))] + [tok, Just (Word w)] -> [tok, Just (Word (Text.snoc w 's'))] + [tok, tok', Just (Word w)] -> [tok, tok', Just (Word (Text.snoc w 's'))] + pat' -> pat' + +guessVerbPlural :: LexicalPhrase -> SgPl LexicalPhrase +guessVerbPlural item = SgPl item itemPl + where + itemPl = case item of + Just (Word v) : rest -> case Text.unsnoc v of + Just (v', 's') -> Just (Word v') : rest + _ -> item + _ -> item + +isAdjR :: LexicalPhrase -> Bool +isAdjR item = containsPreposition item || containsSlot item + where + containsPreposition, containsSlot :: LexicalPhrase -> Bool + containsPreposition = any isPreposition . catMaybes + containsSlot = (Nothing `elem`) + +isPreposition :: Token -> Bool +isPreposition w = Set.member w (Set.map Word prepositions) diff --git a/source/Felix/Syntax/Concrete.hs b/source/Felix/Syntax/Concrete.hs new file mode 100644 index 0000000..8be8ab6 --- /dev/null +++ b/source/Felix/Syntax/Concrete.hs @@ -0,0 +1,1032 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +-- | Concrete syntax of the surface language. +module Felix.Syntax.Concrete where + +import Base +import Felix.Syntax.Abstract +import Felix.Syntax.Concrete.Keywords +import Felix.Syntax.Lexicon + ( Lexicon(..) + , SignatureHeadForm(..) + , concreteSignatureHeadForms + , lexiconAdjs + , splitOnVariableSlot + ) +import Felix.Syntax.Token +import Felix.Report.Location + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Text.Earley (Grammar, Prod, (<?>), rule, satisfy, terminal) +import Felix.Syntax.Mixfix + + +grammar :: Lexicon -> Grammar r (Prod r Text (Located Token) Block) +grammar lexicon@Lexicon{..} = mdo + let patternToProd :: Pattern -> Holey (Prod r Text (Located Token) (Located Token)) + patternToProd pat = map (fmap tokenLocated) (patternToHoley pat) + makeMixfixOp item = (patternToProd (mixfixPattern item), mixfixAssoc item, \parts args -> ExprOp (mixfixLoc parts args) item args) + mixfixItems = toList (Map.elems <$> lexiconMixfixTable) + mixfixOps = map (map makeMixfixOp) mixfixItems + makeConn (pat, assoc) = (map (fmap tokenLocated) pat, assoc) + conns = map (map makeConn) lexiconConnectives + + integerWithLoc <- rule (terminal maybeIntTokenWithLoc <?> "integer") + relatorWithLoc <- rule $ asum + [ (,) <$> tokenPos (relationSymbolToken item) <*> pure item + | item <- lexiconRelationSymbols + ] <?> "relator" + relator <- rule (snd <$> relatorWithLoc) + varSymbol <- rule (terminal maybeVarToken <?> "variable") + varSymbols <- rule (commaList varSymbol) + cmd <- rule (terminal maybeCmdToken <?> "TEX command") +-- +-- Formulas have three levels: +-- +-- + Expressions: atoms or operators applied to atoms. +-- + Chains: comma-lists of expressions, separated by relators. +-- + Formulas: chains or connectives applied to chains. +-- +-- For example, the formula @x, y < z \implies x, y < z + 1@ consist of the +-- connective @\implies@ applied to two chains @x, y < z@ and @x, y < z + 1@. +-- In turn, the chain @x, y < z + 1@ consist of three expressions, +-- @x@, @y@, and @z + 1@. Finally, @z + 1@ consist the operator @+@ +-- applied to two atoms, the variable @z@ and the number literal @1@. +-- +-- This split is due to the different behaviour of relators compared to +-- operators and connectives. Relators can chain (@x < y < z@) and allow +-- lists as arguments, as in the above example. Operators and connectives +-- instead have precedence and fixity. The only syntactic difference between +-- an operator and a connective is the relative precedence compared to relators. +-- + replaceBound <- rule $ (,) <$> varSymbol <* _in <*> expr + replaceBounds <- rule $ commaList replaceBound + comprStmt <- rule $ (StmtFormula <$> formula) <|> text stmt + + let replaceFun = (\e bounds mstmt loc -> ExprReplace loc e bounds mstmt) <$> expr <* _pipe <*> replaceBounds <*> optional (_pipe *> comprStmt) + replacePredSymbolic = (\y x xBound st loc -> ExprReplacePred loc y x xBound st) <$> varSymbol <* _pipe <*> (command "exists" *> varSymbol) <* _in <*> expr <* _dot <*> (StmtFormula <$> formula) + replacePredText = (\y x xBound st loc -> ExprReplacePred loc y x xBound st) <$> varSymbol <* _pipe <*> (begin "text" *> _exists *> beginMath *> varSymbol <* _in) <*> expr <* endMath <* _suchThat <*> stmt <* end "text" + replacePred = replacePredSymbolic <|> replacePredText + + let exprStructOpOf ann = foldr alg empty lexiconStructFun + where + alg s prod = prod <|> (uncurry ExprStructOp <$> structSymbolPos s <*> ann) + + exprStructOp <- rule (exprStructOpOf (optional (bracket expr))) + + let bracedArgs1 ar arg = count1 ar $ group arg + let prefixPredicateOf f arg symb@(PrefixPredicate c ar) = f <$> pure symb <* command c <*> bracedArgs1 ar arg + + + exprParen <- rule $ paren expr + exprInteger <- rule $ uncurry ExprInteger <$> integerWithLoc + exprVar <- rule $ ExprVar <$> varSymbol + exprTuple <- rule do + loc <- tokenPos ParenL + es <- commaList2 expr <* token ParenR + pure (makeTuple loc es) + exprSep <- rule do + loc <- tokenPos VisibleBraceL + x <- varSymbol <* _in + bound <- expr <* _pipe + phi <- comprStmt <* token VisibleBraceR + pure (ExprSep loc x bound phi) + exprReplace <- rule do + (\loc mk -> mk loc) <$> tokenPos VisibleBraceL <*> (replaceFun <|> replacePred) <* token VisibleBraceR + exprFinSet <- rule do + loc <- tokenPos VisibleBraceL + es <- exprs <* token VisibleBraceR + pure (ExprFiniteSet loc es) + exprBase <- rule $ asum [exprVar, exprInteger, exprStructOp, exprParen, exprTuple, exprSep, exprReplace, exprFinSet] + exprApp <- rule $ (\e1 e2 -> ExprApp (locate e1) e1 e2) <$> exprBase <*> (paren expr <|> exprTuple) + expr <- mixfixExpressionSeparate mixfixOps (exprBase <|> exprApp) + exprs <- rule $ commaList expr + + relationSign <- rule $ pure Positive <|> (Negative <$ command "not") + relationExpr <- rule $ RelationExpr <$> command "mathrel" <*> group expr + relation <- rule $ (uncurry Relation <$> relatorWithLoc <*> many (group expr)) <|> relationExpr + chainBase <- rule $ (\es sign rel es' -> ChainBase es sign rel es') <$> exprs <*> relationSign <*> relation <*> exprs + chainCons <- rule $ (\es sign rel ch -> ChainCons es sign rel ch) <$> exprs <*> relationSign <*> relation <*> chain + chain <- rule $ chainCons <|> chainBase + + formulaPredicate <- rule $ asum + [ (\loc es -> FormulaPredicate loc symb marker es) <$> command c <*> bracedArgs1 ar expr + | (symb@(PrefixPredicate c ar), marker) <- lexiconPrefixPredicates + ] + formulaChain <- rule $ FormulaChain <$> chain + formulaBottom <- rule $ PropositionalConstant <$> command "bot" <*> pure IsBottom <?> "\"\\bot\"" + formulaTop <- rule $ PropositionalConstant <$> command "top" <*> pure IsTop <?> "\"\\top\"" + formulaExists <- rule $ FormulaQuantified <$> command "exists" <*> pure Existentially <*> varSymbols <*> maybeBounded <* _dot <*> formula + formulaAll <- rule $ FormulaQuantified <$> command "forall" <*> pure Universally <*> varSymbols <*> maybeBounded <* _dot <*> formula + formulaQuantified <- rule $ formulaExists <|> formulaAll + formulaBase <- rule $ asum [formulaChain, formulaPredicate, formulaBottom, formulaTop, paren formula] + formulaConn <- mixfixExpression conns formulaBase makeConnective + formula <- rule $ formulaQuantified <|> formulaConn + +-- These are asymmetric formulas (only variables are allowed on one side). +-- They express judgements. +-- + assignment <- rule $ (,) <$> varSymbol <* (_eq <|> _defeq) <*> expr + typing <- rule $ (,) <$> varSymbols <* (_in <|> _colon) <*> expr + + adjL <- rule $ adjLOf lexicon term + adjR <- rule $ adjROf lexicon term + adj <- rule $ adjOf lexicon term + adjVar <- rule $ adjOf lexicon var + + var <- rule $ math varSymbol + vars <- rule $ math varSymbols + + verb <- rule $ verbOf lexicon sg term + verbPl <- rule $ verbOf lexicon pl term + verbVar <- rule $ verbOf lexicon sg var + + let nounTrieSg = nounTrieOf sg lexiconNouns + nounTriePl = nounTrieOf pl lexiconNouns + structNounTrieSg = nounTrieOf sg lexiconStructNouns + + noun <- rule $ nounOfTrie nounTrieSg term nounName -- Noun with optional variable name. + nounList <- rule $ nounOfTrie nounTrieSg term nounNames -- Noun with a list of names. + nounVar <- rule $ fst <$> nounOfTrie nounTrieSg var (pure Nameless) -- No names in defined nouns. + nounPl <- rule $ nounOfTrie nounTriePl term nounNames + nounPlMay <- rule $ nounOfTrie nounTriePl term nounName + + + structNoun <- rule $ structNounOfTrie structNounTrieSg var var + structNounNameless <- rule $ fst <$> structNounOfTrie structNounTrieSg var (pure Nameless) + + + fun <- rule $ funOf lexicon sg term + funVar <- rule $ funOf lexicon sg var + + attrRThat <- rule $ AttrRThat <$> thatVerbPhrase + attrRThats <- rule $ ((:[]) <$> attrRThat) <|> ((\a a' -> [a,a']) <$> attrRThat <* _and <*> attrRThat) <|> pure [] + attrRs <- rule $ ((:[]) <$> adjR) <|> ((\a a' -> [a,a']) <$> adjR <* _and <*> adjR) <|> pure [] + attrRight <- rule $ (<>) <$> attrRs <*> attrRThats + + verbPhraseVerbSg <- rule $ VPVerb <$> verb + verbPhraseVerbNotSg <- rule $ VPVerbNot <$> (_does *> _not *> verbPl) + verbPhraseAdjSg <- rule $ VPAdj . (:|[]) <$> (_is *> adj) + verbPhraseAdjAnd <- rule do {_is; a1 <- adj; _and; a2 <- adj; pure (VPAdj (a1 :| [a2]))} + verbPhraseAdjNotSg <- rule $ VPAdjNot . (:|[]) <$> (_is *> _not *> adj) + verbPhraseNotSg <- rule $ verbPhraseVerbNotSg <|> verbPhraseAdjNotSg + verbPhraseSg <- rule $ verbPhraseVerbSg <|> verbPhraseAdjSg <|> verbPhraseAdjAnd <|> verbPhraseNotSg + + -- LATER can cause technical ambiguities? verbPhraseVerbPl <- rule $ VPVerb <$> verbPl + verbPhraseVerbNotPl <- rule $ VPVerbNot <$> (_do *> _not *> verbPl) + verbPhraseAdjPl <- rule $ VPAdj . (:|[]) <$> (_are *> adj) + verbPhraseAdjNotPl <- rule $ VPAdjNot . (:|[]) <$> (_are *> _not *> adj) + verbPhraseNotPl <- rule $ verbPhraseVerbNotPl <|> verbPhraseAdjNotPl + verbPhrasePl <- rule $ verbPhraseAdjPl <|> verbPhraseNotPl -- LATER <|> verbPhraseVerbPl + + + + thatVerbPhrase <- rule $ _that *> verbPhraseSg + + nounName <- rule $ optional (math varSymbol) + nounNames <- rule $ math (commaList_ varSymbol) <|> pure [] + nounPhrase <- rule $ makeNounPhrase <$> many adjL <*> noun <*> attrRight <*> optional suchStmt + nounPhrase' <- rule $ makeNounPhrase <$> many adjL <*> nounList <*> attrRight <*> optional suchStmt + nounPhrasePl <- rule $ makeNounPhrase <$> many adjL <*> nounPl <*> attrRight <*> optional suchStmt + nounPhrasePlMay <- rule $ makeNounPhrase <$> many adjL <*> nounPlMay <*> attrRight <*> optional suchStmt + nounPhraseMay <- rule $ makeNounPhrase <$> many adjL <*> noun <*> attrRight <*> optional suchStmt + + -- Quantification phrases for quantification and indfinite terms. + quantAll <- rule $ QuantPhrase Universally <$> (_forEvery *> nounPhrase' <|> _forAll *> nounPhrasePl) + quantSome <- rule $ QuantPhrase Existentially <$> (_some *> (nounPhrase' <|> nounPhrasePl)) + quantNone <- rule $ QuantPhrase Nonexistentially <$> (_no *> (nounPhrase' <|> nounPhrasePl)) + quant <- rule $ quantAll <|> quantSome <|> quantNone -- <|> quantUniq + + + termExpr <- rule $ math do + e <- expr + pure (TermExpr e) + termFun <- rule $ TermFun <$> (optional _the *> fun) + termIota <- rule $ TermIota <$> _the <*> var <* _suchThat <*> stmt + termAll <- rule $ TermQuantified Universally <$> _every <*> nounPhraseMay + termSome <- rule $ TermQuantified Existentially <$> _some <*> nounPhraseMay + termNo <- rule $ TermQuantified Nonexistentially <$> _no <*> nounPhraseMay + termQuantified <- rule $ termAll <|> termSome <|> termNo + term <- rule $ termExpr <|> termFun <|> termQuantified <|> termIota + +-- Basic statements @stmt'@ are statements without any conjunctions or quantifiers. +-- + let singletonTerm = (:| []) <$> term + nonemptyTerms = andList1 term + stmtVerbSg <- rule $ StmtVerbPhrase <$> singletonTerm <*> verbPhraseSg + stmtVerbPl <-rule $ StmtVerbPhrase <$> andList1 term <*> verbPhrasePl + stmtVerb <- rule $ stmtVerbSg <|> stmtVerbPl + stmtNounIs <- rule do + ts <- singletonTerm + np <- _is *> _an *> nounPhrase + pure (StmtNoun ts np) + stmtNounAre <- rule do + ts <- nonemptyTerms <* _are + np <- nounPhrasePlMay + pure (StmtNoun ts np) + stmtNounIsNot <- rule do + ts <- singletonTerm + np <- _is *> _not *> _an *> nounPhrase + pure let t :| _ = ts in (StmtNeg (locate t) (StmtNoun ts np)) + stmtNounAreNot <- rule do + ts <- nonemptyTerms + np <- _are *> _not *> nounPhrasePlMay + pure let t :| _ = ts in (StmtNeg (locate t) (StmtNoun ts np)) + stmtNoun <- rule $ stmtNounIs <|> stmtNounIsNot <|> stmtNounAre <|> stmtNounAreNot + stmtStruct <- rule do + t <- term + s <- _is *> _an *> structNounNameless + pure (StmtStruct t s) + stmtExists <- rule $ StmtExists <$> _exists <*> (_an *> nounPhrase') + stmtExist <- rule $ StmtExists <$> _exist <*> nounPhrasePl + stmtExistsNot <- rule do + p <- _exists *> _no + np <- nounPhrase' + pure (StmtNeg p (StmtExists p np)) + stmtFormula <- rule $ math do + phi <- formula + pure (StmtFormula phi) + stmtFormualNeg <- rule do + loc <- _not + phi <- math formula + pure (StmtNeg loc (StmtFormula phi)) + stmtAtom <- rule $ + stmtVerb + <|> stmtNoun + <|> stmtStruct + <|> stmtFormula + <|> stmtFormualNeg + <|> paren stmt + + -- Textual connectives use the same precedence and associativity as + -- symbolic connectives. Prefix negation and quantifiers scope over the + -- complete statement that follows them. + let connect conn lhs rhs = + StmtConnected conn Nothing lhs rhs + appendScoped conn lhs rhs scoped = + let connected = foldl' (connect conn) lhs rhs + in maybe connected (connect conn connected) scoped + stmtAnd <- rule do + lhs <- stmtAtom + rhs <- many (_and *> stmtAtom) + scoped <- optional (_and *> stmtScoped) + pure (appendScoped Conjunction lhs rhs scoped) + stmtXor <- rule $ + StmtConnected ExclusiveOr + <$> (Just <$> _either) + <*> stmtAnd + <* _or + <*> stmtAnd + stmtNor <- rule $ + StmtConnected NegatedDisjunction + <$> (Just <$> _neither) + <*> stmtAnd + <* _nor + <*> stmtAnd + stmtOrBase <- rule $ stmtXor <|> stmtNor <|> stmtAnd + stmtOr <- rule do + lhs <- stmtOrBase + rhs <- many (_or *> stmtOrBase) + scoped <- optional (_or *> stmtScoped) + pure (appendScoped Disjunction lhs rhs scoped) + stmtIf <- rule $ + StmtConnected Implication + <$> (Just <$> _if) + <*> stmtIfAntecedent + <* optional _comma + <* _then + <*> stmtImpRhs + stmtImp <- rule $ stmtIf <|> stmtOr + stmtIff <- rule do + lhs <- stmtImp + rhs <- optional (_iff *> stmtImpRhs) + pure case rhs of + Nothing -> lhs + Just rhs' -> connect Equivalence lhs rhs' + stmtNeg <- rule $ StmtNeg <$> _itIsWrong <*> stmt + + stmtQuantPhrase <- rule $ StmtQuantPhrase <$> _for <*> quant <* optional _comma <* optional _have <*> stmt + + suchStmt <- rule $ _suchThat *> stmt <* optional _comma + + -- Symbolic quantifications with or without generalized bounds. + symbolicForall <- rule do + p <- _forAll <|> _forEvery + xs <- beginMath *> varSymbols + b <- maybeBounded <* endMath + ms <- optional suchStmt + s <- optional _have *> stmt + pure (SymbolicForall p xs b ms s) + symbolicExists <- rule do + loc1 <- _exists <|> _exist + xs <- beginMath *> varSymbols + b <- maybeBounded + loc2 <- endMath + ms <- optional (_suchThat *> stmt) + pure (SymbolicExists loc1 xs b (ms ?? StmtFormula (PropositionalConstant loc2 IsTop))) + symbolicNotExists <- rule do + p <- _exists *> _no + xs <- beginMath *> varSymbols + b <- maybeBounded <* endMath + s <- _suchThat *> stmt + pure (makeSymbolicNotExists p xs b s) + symbolicBound <- rule $ (\sign rel e -> Bounded (locate rel) sign rel e) <$> relationSign <*> relation <*> expr + maybeBounded <- rule (pure Unbounded <|> symbolicBound) + + symbolicQuantified <- rule $ symbolicForall <|> symbolicExists <|> symbolicNotExists + + stmtScoped <- rule $ + asum + [ stmtNeg + , stmtExists + , stmtExist + , stmtExistsNot + , stmtQuantPhrase + , symbolicQuantified + ] + stmtIfAntecedent <- rule $ stmtScoped <|> stmtOr + stmtImpRhs <- rule $ stmtScoped <|> stmtImp + stmt :: Prod r Text (Located Token) Stmt <- rule $ + (stmtScoped <|> stmtIff) <?> "a statement" + + + asmLetIn <- rule $ uncurry AsmLetIn <$> (_let *> math typing) + asmLetNoun <- rule $ AsmLetNoun <$> (_let *> fmap pure var <* (_be <|> _denote) <* _an) <*> nounPhrase + asmLetNouns <- rule $ AsmLetNoun <$> (_let *> vars <* (_be <|> _denote)) <*> nounPhrasePlMay + asmLetEq <- rule $ uncurry AsmLetEq <$> (_let *> math assignment) + asmLetThe <- rule $ AsmLetThe <$> (_let *> var <* _be <* _the) <*> fun + asmLetStruct <- rule $ AsmLetStruct <$> (_let *> var <* _be <* _an) <*> structNounNameless + asmLet <- rule $ asmLetNoun <|> asmLetNouns <|> asmLetIn <|> asmLetEq <|> asmLetThe <|> asmLetStruct + asmSuppose <- rule $ AsmSuppose <$> (_suppose *> stmt) + asm <- rule $ andList1_ (asmLet <|> asmSuppose) <* _dot + asms <- rule $ concat <$> many asm + + axiom <- rule $ Axiom <$> asms <* optional _then <*> stmt <* _dot + + claim <- rule $ (,) <$> asms <* optional _then <*> stmt <* _dot + + defnAdj <- rule $ DefnAdj <$> optional (_an *> nounPhrase) <*> var <* _is <*> adjVar + defnVerb <- rule $ DefnVerb <$> optional (_an *> nounPhrase) <*> var <*> verbVar + defnNoun <- rule $ DefnNoun <$> var <* _is <* _an <*> nounVar + defnRel <- rule $ DefnRel <$> (beginMath *> varSymbol) <*> relator <*> many (group varSymbol) <*> varSymbol <* endMath + defnSymbolicPredicate <- rule $ math $ asum $ do + (predi, marker) <- lexiconPrefixPredicates + pure (prefixPredicateOf (\predi' args -> DefnSymbolicPredicate predi' marker args) varSymbol predi) + defnHead <- rule $ optional _write *> asum [defnAdj, defnVerb, defnNoun, defnRel, defnSymbolicPredicate] + + defnIf <- rule $ Defn <$> asms <*> defnHead <* (_iff <|> _if) <*> stmt <* _dot + defnFunSymb <- rule $ _comma *> termExpr <* _comma -- Optional symbolic equivalent. + defnFun <- rule $ DefnFun <$> asms <*> (optional _the *> funVar) <*> optional defnFunSymb <* _is <*> term <* _dot + + symbolicPatternEqTerm <- rule do + pat <- beginMath *> symbolicPattern <* _eq + e <- expr <* endMath <* _dot + pure (pat, e) + defnOp <- rule $ uncurry DefnOp <$> symbolicPatternEqTerm + + defn <- rule $ defnIf <|> defnFun <|> defnOp + + abbreviationVerb <- rule $ AbbreviationVerb <$> var <*> verbVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationAdj <- rule $ AbbreviationAdj <$> var <* _is <*> adjVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationNoun <- rule $ AbbreviationNoun <$> var <* _is <* _an <*> nounVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationRel <- rule $ AbbreviationRel <$> (beginMath *> varSymbol) <*> relator <*> many (group varSymbol) <*> varSymbol <* endMath <* (_iff <|> _if) <*> stmt <* _dot + abbreviationFun <- rule $ AbbreviationFun <$> (_the *> funVar) <* (_is <|> _denotes) <*> term <* _dot + abbreviationEq <- rule $ uncurry AbbreviationEq <$> symbolicPatternEqTerm + abbreviation <- rule $ (abbreviationVerb <|> abbreviationAdj <|> abbreviationNoun <|> abbreviationRel <|> abbreviationFun <|> abbreviationEq) + + datatypePremise <- rule $ math $ (,) <$> varSymbol <* _in <*> expr + datatypeClause <- rule $ + (\(constructorExpr, targetExpr) premises -> DatatypeClause + { datatypeClauseConstructorExpr = constructorExpr + , datatypeClauseTargetExpr = targetExpr + , datatypeClausePremises = premises ?? [] + }) <$> math ((,) <$> expr <* _in <*> expr) + <*> optional (_for *> andList1_ datatypePremise) + <* _dot + datatypeHead <- rule $ _define *> math expr <* optional _inductively <* optional _asFollows <* _dot + datatype <- rule $ Datatype <$> datatypeHead <*> enumerated1 datatypeClause + + unconditionalIntro <- rule $ IntroRule [] <$> math formula + conditionalIntro <- rule $ IntroRule <$> (_if *> andList1_ (math formula)) <* _comma <* _then <*> math formula + inductiveIntro <- rule $ (unconditionalIntro <|> conditionalIntro) <* _dot + inductiveDomain <- rule $ math $ (,) <$> symbolicPattern <* _subseteq <*> expr + inductiveHead <- rule $ _define *> inductiveDomain <* optional _inductively <* optional _asFollows <* _dot + inductive <- rule $ uncurry Inductive <$> inductiveHead <*> enumerated1 inductiveIntro + + signatureAdj <- rule $ SignatureAdj <$> var <* _can <* _be <*> adjOf lexicon var + symbolicPattern <- symbolicPatternOf mixfixItems varSymbol + signatureSymbolic <- rule $ SignatureSymbolic <$> math symbolicPattern <* _is <* _an <*> nounPhrase + signatureHead <- rule $ asum + [ case form of + AdjectiveSignatureHead -> signatureAdj + SymbolicSignatureHead -> signatureSymbolic + | form <- concreteSignatureHeadForms + ] + signature <- rule $ + (,) <$> asms <* optional _then <*> signatureHead <* _dot + + structFix <- rule do + beginMath + rawCmd <- cmd + endMath + pure (StructSymbol rawCmd) + structDefn <- rule $ do + _an + ~(structPhrase, structLabel) <- structNoun + _extends + structParents <- andList1_ (_an *> structNounNameless) + maybeFixes <- optional (_equipped *> enumerated structFix) + structAssumes <- (_suchThat *> enumeratedMarked (stmt <* _dot)) <|> ([] <$ _dot) + pure StructDefn + { structPhrase = structPhrase + , structLabel = structLabel + , structParents = structParents + , structFixes = maybeFixes ?? [] + , structAssumes = structAssumes + } + + justificationSet <- rule $ JustificationSetExt <$ _bySetExt + justificationRef <- rule $ JustificationRef <$> (_by *> ref) + justificationLocal <- rule $ JustificationLocal <$ (_by *> (_assumption <|> _definition)) + justification <- rule (justificationSet <|> justificationRef <|> justificationLocal <|> pure JustificationEmpty) + + trivial <- rule $ Qed . Just <$> _trivial <* _dot <*> pure JustificationEmpty + omitted <- rule $ Omitted <$> _omitted <* _dot + qedJustified <- rule $ Qed . Just <$> _follows <*> (justification <* _dot) + qed <- rule $ qedJustified <|> trivial <|> omitted <|> pure (Qed Nothing JustificationEmpty) + contradiction <- rule $ Contradiction <$> _contradiction <*> justification <* _dot + + let alignedEq = symbol "&=" <?> "\"&=\"" + explanation <- rule $ (text justification) <|> pure JustificationEmpty + equationItem <- rule $ (,) <$> (alignedEq *> expr) <*> explanation + equations <- rule $ Equation <$> expr <*> (many1 equationItem) + + let alignedIff = symbol "&" *> command "iff" <?> "\"&\\iff\"" + biconditionalItem <- rule $ (,) <$> (alignedIff *> formula) <*> explanation + biconditionals <- rule $ Biconditionals <$> formula <*> (many1 biconditionalItem) <* optional _dot + + + calcQuantifier <- rule do + loc <- _forAll <|> _forEvery + xs <- beginMath *> varSymbols + mb <- maybeBounded <* endMath + st <- optional suchStmt + optional _have + pure (loc, CalcQuantifier xs mb st) + + calc <- rule do + mquant <- optional calcQuantifier + psteps <- align (equations <|> biconditionals) + pf <- proof + pure let (loc2, steps) = psteps in case mquant of + Nothing -> Calc loc2 Nothing steps pf + Just (loc, q) -> Calc loc (Just q) steps pf + + caseOf <- rule $ command "caseOf" *> token InvisibleBraceL *> stmt <* _dot <* token InvisibleBraceR + byCases <- rule $ uncurry ByCase <$> envPos_ "byCase" (many1_ (Case <$> caseOf <*> proof)) + byContradiction <- rule $ ByContradiction <$> _suppose <* _not <* _dot <*> proof + bySetInduction <- rule $ uncurry BySetInduction <$> proofBy (_in *> word "-induction" *> optional (word "on" *> term)) <*> proof + byOrdInduction <- rule $ ByOrdInduction . fst <$> proofBy (word "transfinite" *> word "induction") <*> proof + assume <- rule $ Assume <$> _suppose <*> (stmt <* _dot) <*> proof + + fixSymbolic <- rule $ FixSymbolic <$> _fix <*> (beginMath *> varSymbols) <*> maybeBounded <* endMath <* _dot <*> proof + fixSuchThat <- rule $ FixSuchThat <$> _fix <*> math varSymbols <* _suchThat <*> stmt <* _dot <*> proof + fix <- rule $ fixSymbolic <|> fixSuchThat + + takeVar <- rule $ TakeVar <$> _take <*> (beginMath *> varSymbols) <*> maybeBounded <* endMath <* _suchThat <*> stmt <*> justification <* _dot <*> proof + takeNoun <- rule $ TakeNoun <$> _take <*> (_an *> (nounPhrase' <|> nounPhrasePl)) <*> justification <* _dot <*> proof + take <- rule $ takeVar <|> takeNoun + suffices <- rule $ Suffices <$> _sufficesThat <*> stmt <*> (justification <* _dot) <*> proof + subclaim <- rule $ Subclaim <$> _show <*> (stmt <* _dot) <*> env_ "subproof" proof <*> proof + have <- rule do + msince <- optional ((,) <$> _since <*> stmt <* _comma <* _have) + mpos <- optional _haveIntro + s <- stmt + j <- justification <* _dot + pf <- proof + pure + let pos = case (msince, mpos) of + (Just (p, _), _) -> p + (_, Just p) -> p + _ -> locate s + in (Have pos (snd <$> msince) s j pf) + + + define <- rule $ Define <$> _let <*> (beginMath *> varSymbol <* _eq) <*> expr <* endMath <* _dot <*> proof + defineFunction <- rule $ DefineFunction <$> _let <*> (beginMath *> varSymbol) <*> paren varSymbol <* _eq <*> expr <* endMath <* _for <* beginMath <*> varSymbol <* _in <*> expr <* endMath <* _dot <*> proof + + proof <- rule $ asum [byContradiction, byCases, bySetInduction, byOrdInduction, calc, subclaim, assume, fix, take, have, suffices, define, defineFunction, contradiction, qed] + + + blockAxiom <- rule $ (\(p, title, m, a) -> BlockAxiom p title m a) <$> envPos "axiom" axiom + blockClaim <- rule $ claimEnv claim + blockProof <- rule $ uncurry3 BlockProof <$> envStartEndLocation "proof" proof + blockDefn <- rule $ (\(p, title, m, d) -> BlockDefn p title m d) <$> envPos "definition" defn + blockAbbr <- rule $ (\(p, title, m, a) -> BlockAbbr p title m a) <$> envPos "abbreviation" abbreviation + blockData <- rule $ (\(p, title, m, d) -> BlockData p title m d) <$> envPos "datatype" datatype + blockInd <- rule $ (\(p, title, m, i) -> BlockInductive p title m i) <$> envPos "inductive" inductive + blockSig <- rule $ (\(p, title, m, (a, s)) -> BlockSig p title m a s) <$> envPos "signature" signature + blockStruct <- rule $ (\(p, title, m, s) -> BlockStruct p title m s) <$> envPos "struct" structDefn + block <- rule $ asum [blockAxiom, blockClaim, blockDefn, blockAbbr, blockData, blockInd, blockSig, blockStruct, blockProof] + + -- Starting category. + pure block + + +proofBy :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, a) +proofBy method = bracket do + pos <- word "proof" *> word "by" + a <- method + pure (pos, a) + +claimEnv :: Prod r Text (Located Token) (([Asm], Stmt)) -> Prod r Text (Located Token) Block +claimEnv content = asum + [ make Theorem <$> envPos "theorem" content + , make Lemma <$> envPos "lemma" content + , make Corollary <$> envPos "corollary" content + , make PlainClaim <$> envPos "claim" content + , make Proposition <$> envPos "proposition" content + ] + where + make kind = (\ (loc, title, m, (asms, stmt)) -> BlockClaim kind loc title m (Claim asms stmt)) + +-- | A disjunctive list with at least two items: +-- * 'a or b' +-- * 'a, b, or c' +-- * 'a, b, c, or d' +-- +orList2 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +orList2 item = ((:|) <$> item <*> many (_commaOr *> item)) + <|> ((\i j -> i:|[j]) <$> item <* _or <*> item) + + +-- | Nonempty textual lists of the form "a, b, c, and d". +-- The final comma is mandatory, 'and' is not. +-- Also allows "a and b". Should therefore be avoided in contexts where +-- a logical conjunction would also be possible. +-- Currently also allows additional 'and's after each comma... +-- +andList1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +andList1 item = ((:|) <$> item <*> many (_commaAnd *> item)) + <|> ((\i j -> i:|[j]) <$> item <* _and <*> item) + +-- | Like 'andList1', but drops the information about nonemptiness. +andList1_ :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +andList1_ item = NonEmpty.toList <$> andList1 item + + +commaList :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +commaList item = (:|) <$> item <*> many (_comma *> item) + +-- | Like 'commaList', but drops the information about nonemptiness. +commaList_ :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +commaList_ item = NonEmpty.toList <$> commaList item + +-- | Like 'commaList', but requires at least two items (and hence at least one comma). +commaList2 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +commaList2 item = (:|) <$> item <* _comma <*> commaList_ item + + +enumerated :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +enumerated p = NonEmpty.toList <$> enumerated1 p + +enumerated1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +enumerated1 p = begin "enumerate" *> many1 (command "item" *> p) <* end "enumerate" <?> "\"\\begin{enumerate} ...\"" + + +enumeratedMarked :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [(Marker, a)] +enumeratedMarked p = NonEmpty.toList <$> enumeratedMarked1 p + +enumeratedMarked1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty (Marker, a)) +enumeratedMarked1 p = begin "enumerate" *> many1 ((,) <$> (command "item" *> label) <*> p) <* end "enumerate" <?> "\"\\begin{enumerate}\\item\\label{...}...\"" + + + +-- This function could be rewritten, so that it can be used directly in the grammar, +-- instead of with specialized variants. +-- +phraseOf + :: forall pat a b r. Locatable a + => (Location -> pat -> [a] -> b) + -> Lexicon + -> (Lexicon -> [pat]) + -> (pat -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) b +phraseOf constr lexicon selector proj arg = + uncurry3 constr <$> buildPhraseTrie arg trie + where + pats :: [pat] + pats = selector lexicon + + trie :: Trie PhraseStep pat + trie = trieFromList + [ (phraseSteps (proj pat), pat) + | pat <- pats + ] + +adjLOf :: Locatable arg => Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjLOf arg) +adjLOf lexicon arg = phraseOf AdjL lexicon lexiconAdjLs lexicalItemPhrase arg <?> "a left adjective" + +adjROf :: Locatable arg =>Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjROf arg) +adjROf lexicon arg = phraseOf AdjR lexicon lexiconAdjRs lexicalItemPhrase arg <?> "a right adjective" + +adjOf :: Locatable arg =>Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjOf arg) +adjOf lexicon arg = phraseOf Adj lexicon lexiconAdjs lexicalItemPhrase arg <?> "an adjective" + +verbOf + :: Locatable a => Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) (VerbOf a) +verbOf lexicon proj arg = phraseOf Verb lexicon lexiconVerbs (proj . lexicalItemSgPlPhrase) arg + +funOf + :: Locatable a => Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) (FunOf a) +funOf lexicon proj arg = phraseOf Fun lexicon lexiconFuns (proj . lexicalItemSgPlPhrase) arg <?> "functional phrase" + + +-- | A noun with a @t VarSymbol@ as name(s). +nounOf + :: Locatable arg => Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) (t VarSymbol) + -> Prod r Text (Located Token) (NounOf arg, t VarSymbol) +nounOf lexicon proj arg vars = + nounOfTrie (nounTrieOf proj (lexiconNouns lexicon)) arg vars + +nounOfTrie + :: Locatable arg => Trie NounStep LexicalItemSgPl + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) (t VarSymbol) + -> Prod r Text (Located Token) (NounOf arg, t VarSymbol) +nounOfTrie trie arg vars = + (\(loc, pat, args, xs) -> (Noun loc pat args, xs)) + <$> buildNounTrie arg vars trie + <?> "a noun" + +nounTrieOf + :: (SgPl LexicalPhrase -> LexicalPhrase) + -> [LexicalItemSgPl] + -> Trie NounStep LexicalItemSgPl +nounTrieOf proj pats = trieFromList + [ (nounStepsWithSlot (proj (lexicalItemSgPlPhrase pat)), pat) + | pat <- pats + ] + +structNounOfTrie + :: Locatable arg => Trie NounStep LexicalItemSgPl + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) name + -> Prod r Text (Located Token) (StructPhrase, name) +structNounOfTrie trie arg name = + (\(_loc, pat, _args, xs) -> (pat, xs)) + <$> buildNounTrie arg name trie + <?> "a structure noun" + +structNounOf + :: Locatable arg => Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) name + -> Prod r Text (Located Token) (StructPhrase, name) +structNounOf lexicon proj arg name = + structNounOfTrie (nounTrieOf proj (lexiconStructNouns lexicon)) arg name + +-- Trie helpers for lexically-defined phrases. + +data PhraseStep + = PhraseTok Token + | PhraseHole + deriving (Eq, Ord) + +data NounStep + = NounTok Token + | NounHole + | NounVar + deriving (Eq, Ord) + +data Trie k v = Trie + { trieValues :: [v] + , trieEdges :: [(k, Trie k v)] + } + +emptyTrie :: Trie k v +emptyTrie = Trie [] [] + +insertTrie :: Eq k => [k] -> v -> Trie k v -> Trie k v +insertTrie [] v Trie{trieValues = vs, trieEdges = es} = + Trie (vs <> [v]) es +insertTrie (k:ks) v Trie{trieValues = vs, trieEdges = es} = + Trie vs (go es) + where + go = \case + [] -> [(k, insertTrie ks v emptyTrie)] + (k', child) : rest + | k == k' -> (k', insertTrie ks v child) : rest + | otherwise -> (k', child) : go rest + +trieFromList :: Eq k => [([k], v)] -> Trie k v +trieFromList = foldl' (\tr (k, v) -> insertTrie k v tr) emptyTrie + +phraseSteps :: LexicalPhrase -> [PhraseStep] +phraseSteps = map \case + Just tok -> PhraseTok tok + Nothing -> PhraseHole + +nounSteps :: LexicalPhrase -> [NounStep] +nounSteps = map \case + Just tok -> NounTok tok + Nothing -> NounHole + +nounStepsWithSlot :: LexicalPhrase -> [NounStep] +nounStepsWithSlot pat = + let (pat1, pat2) = splitOnVariableSlot pat + in nounSteps pat1 <> [NounVar] <> nounSteps pat2 + +data PhraseAcc a = PhraseAcc + { phraseLoc :: Maybe Location + , phraseArgs :: [a] -> [a] + } + +emptyPhraseAcc :: PhraseAcc a +emptyPhraseAcc = PhraseAcc Nothing id + +setPhraseLoc :: Location -> PhraseAcc a -> PhraseAcc a +setPhraseLoc Nowhere acc = acc +setPhraseLoc _loc acc@PhraseAcc{phraseLoc = Just _} = acc +setPhraseLoc loc PhraseAcc{phraseLoc = Nothing, phraseArgs = args} = + PhraseAcc (Just loc) args + +addPhraseArg :: Locatable a => a -> PhraseAcc a -> PhraseAcc a +addPhraseArg a acc@PhraseAcc{phraseLoc = loc, phraseArgs = args} + | locate a == Nowhere = acc{phraseArgs = args . (a :)} + | otherwise = PhraseAcc (loc <|> Just (locate a)) (args . (a :)) + +finalizePhraseAcc :: PhraseAcc a -> (Location, [a]) +finalizePhraseAcc PhraseAcc{phraseLoc = Just loc, phraseArgs = args} = + (loc, args []) +finalizePhraseAcc PhraseAcc{phraseLoc = Nothing} = + impossible "phraseOf: empty phrase" + +data NounAcc a name = NounAcc + { nounLoc :: Maybe Location + , nounArgs :: [a] -> [a] + , nounName :: Maybe name + } + +emptyNounAcc :: NounAcc a name +emptyNounAcc = NounAcc Nothing id Nothing + +setNounLoc :: Location -> NounAcc a name -> NounAcc a name +setNounLoc Nowhere acc = acc +setNounLoc _loc acc@NounAcc{nounLoc = Just _} = acc +setNounLoc loc NounAcc{nounLoc = Nothing, nounArgs = args, nounName = name} = + NounAcc (Just loc) args name + +addNounArg :: Locatable a => a -> NounAcc a name -> NounAcc a name +addNounArg a acc@NounAcc{nounLoc = loc, nounArgs = args, nounName = name} + | locate a == Nowhere = acc{nounArgs = args . (a :)} + | otherwise = NounAcc (loc <|> Just (locate a)) (args . (a :)) name + +setNounName :: name -> NounAcc a name -> NounAcc a name +setNounName name NounAcc{nounLoc = loc, nounArgs = args, nounName = Nothing} = + NounAcc loc args (Just name) +setNounName _ acc@NounAcc{nounName = Just _} = acc + +finalizeNounAcc :: NounAcc a name -> (Location, [a], name) +finalizeNounAcc NounAcc{nounLoc = Just loc, nounArgs = args, nounName = Just name} = + (loc, args [], name) +finalizeNounAcc NounAcc{nounName = Nothing} = + impossible "nounOf: missing variable slot" +finalizeNounAcc NounAcc{nounLoc = Nothing} = + impossible "nounOf: empty noun phrase" + +buildPhraseTrie + :: Locatable a + => Prod r Text (Located Token) a + -> Trie PhraseStep pat + -> Prod r Text (Located Token) (Location, pat, [a]) +buildPhraseTrie arg trie = + let stepParser = \case + PhraseTok tok -> setPhraseLoc <$> tokenPos tok + PhraseHole -> addPhraseArg <$> arg + finish f = + let (acc, pat) = f emptyPhraseAcc + (loc, args) = finalizePhraseAcc acc + in (loc, pat, args) + in finish <$> buildTrieProd stepParser trie + +buildTrieProd + :: (step -> Prod r Text (Located Token) (acc -> acc)) + -> Trie step pat + -> Prod r Text (Located Token) (acc -> (acc, pat)) +buildTrieProd stepParser = go + where + go Trie{trieValues = pats, trieEdges = edges} = + let leafs = asum [pure (\acc -> (acc, pat)) | pat <- pats] + edgesProds = asum + [ liftA2 (\f g -> g . f) (stepParser step) (go sub) + | (step, sub) <- edges + ] + in leafs <|> edgesProds + +buildNounTrie + :: Locatable a + => Prod r Text (Located Token) a + -> Prod r Text (Located Token) name + -> Trie NounStep pat + -> Prod r Text (Located Token) (Location, pat, [a], name) +buildNounTrie arg vars trie = + let stepParser = \case + NounTok tok -> setNounLoc <$> tokenPos tok + NounHole -> addNounArg <$> arg + NounVar -> setNounName <$> vars + finish f = + let (acc, pat) = f emptyNounAcc + (loc, args, name) = finalizeNounAcc acc + in (loc, pat, args, name) + in finish <$> buildTrieProd stepParser trie + + +symbolicPatternOf + :: forall r. [[MixfixItem]] + -> Prod r Text (Located Token) VarSymbol + -> Grammar r (Prod r Text (Located Token) SymbolPattern) +symbolicPatternOf ops varSymbol = rule $ + (tuplePattern <|> asum + [ go item + | ops' <- ops + , item <- ops' + ]) <?> "a symbolic pattern" + where + tuplePattern = do + token ParenL + first <- varSymbol <* token (Symbol ",") + second <- varSymbol <* token ParenR + pure (SymbolPattern PairSymbol [first, second]) + + go :: MixfixItem -> Prod r Text (Located Token) SymbolPattern + go item = SymbolPattern item <$> parseVars (mixfixPattern item) + + parseVars :: Pattern -> Prod r Text (Located Token) [VarSymbol] + parseVars = \case + End -> pure [] + TokenCons tok pat -> token tok *> parseVars pat + HoleCons pat -> (:) <$> varSymbol <*> parseVars pat + + +makeNounPhrase + :: [AdjL] + -> (Noun, t VarSymbol) + -> [AdjR] + -> Maybe Stmt + -> NounPhrase t +makeNounPhrase ls (n, vs) rs ms = NounPhrase ls n vs rs ms + + + + +begin, end :: Text -> Prod r Text (Located Token) Location +begin kind = tokenPos (BeginEnv kind) <?> ("\"\\begin{" <> kind <> "}\"") +end kind = tokenPos (EndEnv kind) <?> ("\"\\end{" <> kind <> "}\"") + +-- | Surround a production rule @body@ with an environment of a certain @kind@ requiring a marker specified in a @\\label@. +envPos :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, Maybe [Token], Marker, a) +envPos kind body = do + p <- begin kind <?> ("start of a \"" <> kind <> "\" environment") + mt <- optional title + m <- label + a <- body <* end kind + pure (p, mt, m, a) + where + title :: Prod r Text (Located Token) [Token] + title = bracket (many (unLocated <$> satisfy (\ltok -> unLocated ltok /= BracketR))) + +-- 'env_' is like 'env', but without allowing titles. +-- +envPos_ :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, a) +envPos_ kind body = (,) <$> begin kind <*> (optional label *> body) <* end kind + +envStartEndLocation :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, a, Location) +envStartEndLocation kind body = (,,) <$> begin kind <*> (optional label *> body) <*> end kind + +env_ :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) a +env_ kind body = begin kind *> optional label *> body <* end kind + +-- | A label specifying a marker for referencing via /@\\label{...}@/. Returns the marker text. +label :: Prod r Text (Located Token) Marker +label = label_ <?> "\"\\label{...}\"" + where + label_ = terminal \ltok -> case unLocated ltok of + Label m -> Just (Marker m) + _tok -> Nothing + +-- | A reference via /@\\ref{...}@/. Returns the markers as text. +ref :: Prod r Text (Located Token) (NonEmpty Marker) +ref = terminal \ltok -> case unLocated ltok of + Ref ms -> Just (Marker <$> ms) + _tok -> Nothing + +math :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +math body = beginMath *> body <* endMath + +mathPos :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, a) +mathPos body = (,) <$> beginMath <*> body <* endMath + +text :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +text body = begin "text" *> body <* end "text" <?> "\"\\text{...}\"" + +beginMath, endMath :: Prod r Text (Located Token) Location +beginMath = begin "math" <?> "start of a formula, e.g. \"$\"" +endMath = end "math" <?> "end of a formula, e.g. \"$\"" + +paren :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +paren body = token ParenL *> body <* token ParenR <?> "\"(...)\"" + +bracket :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +bracket body = token BracketL *> body <* token BracketR <?> "\"[...]\"" + +brace :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +brace body = token VisibleBraceL *> body <* token VisibleBraceR <?> "\"\\{...\\}\"" + +group :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +group body = token InvisibleBraceL *> body <* token InvisibleBraceR <?> "\"{...}\"" + +align :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (Location, a) +align body = (,) <$> begin "align*" <*> body <* end "align*" + +cases :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +cases body = begin "cases" *> body <* end "cases" + + +maybeVarToken :: Located Token -> Maybe VarSymbol +maybeVarToken ltok = case unLocated ltok of + Variable x -> Just (NamedVarAt (startPos ltok) x) + _tok -> Nothing + +maybeWordToken :: Located Token -> Maybe Text +maybeWordToken ltok = case unLocated ltok of + Word n -> Just n + _tok -> Nothing + +maybeIntToken :: Located Token -> Maybe Int +maybeIntToken ltok = case unLocated ltok of + Integer n -> Just n + _tok -> Nothing + +maybeIntTokenWithLoc :: Located Token -> Maybe (Location, Int) +maybeIntTokenWithLoc ltok = case unLocated ltok of + Integer n -> Just (startPos ltok, n) + _tok -> Nothing + +maybeCmdToken :: Located Token -> Maybe Text +maybeCmdToken ltok = case unLocated ltok of + Command n -> Just n + _tok -> Nothing + +structSymbol :: StructSymbol -> Prod r Text (Located Token) StructSymbol +structSymbol s@(StructSymbol c) = terminal \ltok -> case unLocated ltok of + Command c' | c == c' -> Just s + _ -> Nothing + +structSymbolPos :: StructSymbol -> Prod r Text (Located Token) (Location, StructSymbol) +structSymbolPos s@(StructSymbol c) = terminal \ltok -> case unLocated ltok of + Command c' | c == c' -> Just (startPos ltok, s) + _ -> Nothing + +-- | Tokens that are allowed to appear in labels of environments. +maybeTagToken :: Located Token -> Maybe Text +maybeTagToken ltok = case unLocated ltok of + Symbol "'" ->Just "'" + Symbol "-" -> Just "" + _ -> maybeWordToken ltok + + +token :: Token -> Prod r Text (Located Token) Token +token tok = terminal maybeToken <?> tokToText tok + where + maybeToken ltok = case unLocated ltok of + tok' | tok == tok' -> Just tok + _ -> Nothing + +tokenLocated :: Token -> Prod r Text (Located Token) (Located Token) +tokenLocated tok = terminal maybeToken <?> tokToText tok + where + maybeToken ltok = case unLocated ltok of + tok' | tok == tok' -> Just ltok + _ -> Nothing + +tokenPos :: Token -> Prod r Text (Located Token) Location +tokenPos tok = terminal maybeToken <?> tokToText tok + where + maybeToken ltok = case unLocated ltok of + tok' | tok == tok' -> Just (startPos ltok) + _ -> Nothing diff --git a/source/Felix/Syntax/Concrete/Keywords.hs b/source/Felix/Syntax/Concrete/Keywords.hs new file mode 100644 index 0000000..eb6d09c --- /dev/null +++ b/source/Felix/Syntax/Concrete/Keywords.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-| +This module defines lots of keywords and various filler +phrases. The prefix underscore indicates that we do not +care about the parse result (analogous to discarding +like @...; _ <- action; ...@ in do-notation). Moreover, +this convention allows the use of short names that would +otherwise be Haskell keywords or clash with other definitions. +Care should be taken with introducing too many variants of +a keyword, lest the grammar becomes needlessly ambiguous! + +The names are chosen using the following criteria: + + * As short as possible (e.g.: @_since@ over @_because@). + + * Sound like a keyword (e.g.: @_show@). + +This module also defines symbols that have special uses +(such as @_colon@ for its use in type signatures). +-} +module Felix.Syntax.Concrete.Keywords where + + +import Base +import Felix.Syntax.Token +import Felix.Report.Location + +import Text.Earley (Prod, (<?>), terminal) + +infixr 0 ? +-- | Variant of '<?>' for annotating literal tokens. +(?) :: Prod r Text t a -> Text -> Prod r Text t a +p ? e = p <?> ("\"" <> e <> "\"") + +word :: Text -> Prod r Text (Located Token) Location +word w = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Word w' | w == w' -> Just (startPos ltok) + _ -> Nothing + +symbol :: Text -> Prod r Text (Located Token) Location +symbol s = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Symbol s' | s == s' -> Just (startPos ltok) + _ -> Nothing + +command :: Text -> Prod r Text (Located Token) Location +command cmd = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Command cmd' | cmd == cmd' -> Just (startPos ltok) + _ -> Nothing + +_arity :: Prod r Text (Located Token) Int +_arity = asum + [ 1 <$ word "unary" + , 2 <$ word "binary" + , 3 <$ word "ternary" + , 4 <$ word "quaternary" + , 5 <$ word "quinary" + , 6 <$ word "senary" + , 7 <$ word "septenary" + , 8 <$ word "octonary" + , 9 <$ word "nonary" + , 10 <$ word "denary" + ] <?> "\"unary\", \"binary\', ..." + +-- * Keywords + +_an :: Prod r Text (Located Token) Location +_an = word "a" <|> word "an" <?> "indefinite article" +_and :: Prod r Text (Located Token) Location +_and = word "and" ? "and" +_are :: Prod r Text (Located Token) Location +_are = word "are" ? "are" +_asFollows :: Prod r Text (Located Token) Location +_asFollows = word "as" <* word "follows" ? "as follows" +_assumption :: Prod r Text (Located Token) Location +_assumption = word "assumption" ? "assumption" +_be :: Prod r Text (Located Token) Location +_be = word "be" ? "be" +_by :: Prod r Text (Located Token) Location +_by = word "by" ? "by" +_bySetExt :: Prod r Text (Located Token) Location +_bySetExt = word "by" <* ((word "set" ? "set") <* word "extensionality") ? "by set extensionality" +_can :: Prod r Text (Located Token) Location +_can = word "can" ? "can" +_consistsOf :: Prod r Text (Located Token) Location +_consistsOf = word "consists" <* word "of" ? "consists of" +_contradiction :: Prod r Text (Located Token) Location +_contradiction = optional (word "a") *> word "contradiction" ? "a contradiction" +_define :: Prod r Text (Located Token) Location +_define = word "define" ? "define" +_definition :: Prod r Text (Located Token) Location +_definition = word "definition" ? "definition" +_denote :: Prod r Text (Located Token) Location +_denote = word "denote" <|> (word "stand" <* word "for") ? "denote" +_denotes :: Prod r Text (Located Token) Location +_denotes = word "denotes" ? "denotes" +_do :: Prod r Text (Located Token) Location +_do = word "do" ? "do" +_does :: Prod r Text (Located Token) Location +_does = word "does" ? "does" +_either :: Prod r Text (Located Token) Location +_either = word "either" ? "either" +_equipped :: Prod r Text (Located Token) Location +_equipped = (word "equipped" <|> word "together") <* word "with" ? "equipped with" +_every :: Prod r Text (Located Token) Location +_every = word "every" ? "every" +_exist :: Prod r Text (Located Token) Location +_exist = word "there" <* word "exist" ? "there exist" +_exists :: Prod r Text (Located Token) Location +_exists = word "there" <* word "exists" ? "there exists" +_extends :: Prod r Text (Located Token) Location +_extends = (_is) <|> (word "consists" <* word "of") ? "consists of" +_fix :: Prod r Text (Located Token) Location +_fix = word "fix" ? "fix" +_follows :: Prod r Text (Located Token) Location +_follows = word "follows" ? "follows" +_for :: Prod r Text (Located Token) Location +_for = word "for" ? "for" +_forAll :: Prod r Text (Located Token) Location +_forAll = (word "for" <* word "all") <|> word "all" ? "all" +_forEvery :: Prod r Text (Located Token) Location +_forEvery = (word "for" <* word "every") <|> word "every" ? "for every" +_have :: Prod r Text (Located Token) Location +_have = word "we" <* word "have" <* optional (word "that") ? "we have" +_if :: Prod r Text (Located Token) Location +_if = word "if" ? "if" +_iff :: Prod r Text (Located Token) Location +_iff = word "iff" <|> (word "if" <* word "and" <* word "only" <* word "if") ? "iff" +_inductively :: Prod r Text (Located Token) Location +_inductively = word "inductively" ? "inductively" +_is :: Prod r Text (Located Token) Location +_is = word "is" ? "is" +_itIsWrong :: Prod r Text (Located Token) Location +_itIsWrong = word "it" <* word "is" <* (word "not" <* word "the" <* word "case" <|> word "wrong") <* word "that" ? "it is wrong that" +_let :: Prod r Text (Located Token) Location +_let = word "let" ? "let" +_neither :: Prod r Text (Located Token) Location +_neither = word "neither" ? "neither" +_no :: Prod r Text (Located Token) Location +_no = word "no" ? "no" +_nor :: Prod r Text (Located Token) Location +_nor = word "nor" ? "nor" +_not :: Prod r Text (Located Token) Location +_not = word "not" ? "not" +_omitted :: Prod r Text (Located Token) Location +_omitted = word "omitted" ? "omitted" +_on :: Prod r Text (Located Token) Location +_on = word "on" ? "on" +_oneOf :: Prod r Text (Located Token) Location +_oneOf = word "one" <* word "of" ? "one of" +_or :: Prod r Text (Located Token) Location +_or = word "or" ? "or" +_particularly :: Prod r Text (Located Token) Location +_particularly = (word "particularly" <|> (word "in" *> word "particular")) <* _comma ? "particularly" +_relation :: Prod r Text (Located Token) Location +_relation = word "relation" ? "relation" +_satisfying :: Prod r Text (Located Token) Location +_satisfying = _suchThat <|> word "satisfying" ? "satisfying" +_setOf :: Prod r Text (Located Token) Location +_setOf = word "set" <* word "of" ? "set of" +_now :: Prod r Text (Located Token) Location +_now = (word "then" <|> word "next" <|> word "now" <|> word "first" <|> word "finally" <|> word "subsequently" <|> word "ultimately") +_show :: Prod r Text (Located Token) Location +_show = optional _now *> optional (word "we") *> word "show" <* optional (word "that") +_since :: Prod r Text (Located Token) Location +_since = word "since" <|> word "because" ? "since" +_some :: Prod r Text (Located Token) Location +_some = word "some" ? "some" +_suchThat :: Prod r Text (Located Token) Location +_suchThat = ((word "such" <* word "that") <|> (word "s" <* _dot <* word "t" <* _dot)) ? "such that" +_sufficesThat :: Prod r Text (Located Token) Location +_sufficesThat = word "it" <* word "suffices" <* word "to" <* word "show" <* word "that" ? "it suffices to show" +_suppose :: Prod r Text (Located Token) Location +_suppose = (word "suppose" <|> word "assume") <* optional (word "that") ? "assume" +_take :: Prod r Text (Located Token) Location +_take = optional _now *> (word "take" <|> word "consider") ? "take" +_that :: Prod r Text (Located Token) Location +_that = word "that" ? "that" +_the :: Prod r Text (Located Token) Location +_the = word "the" ? "the" +_then :: Prod r Text (Located Token) Location +_then = word "then" ? "then" +_thus :: Prod r Text (Located Token) Location +_thus = word "thus" <|> word "hence" <|> _now <|> word "therefore" ? "thus" +_trivial :: Prod r Text (Located Token) Location +_trivial = word "straightforward" <|> word "trivial" ? "trivial" +_unique :: Prod r Text (Located Token) Location +_unique = word "unique" ? "unique" +_write :: Prod r Text (Located Token) Location +_write = (optional (word "we") *> word "say" <* optional (word "that")) <|> (optional (word "we") *> word "write") ? "write" + +-- | Introducing plain claims in proofs. +_haveIntro :: Prod r Text (Located Token) Location +_haveIntro = _thus <|> _particularly <|> _have + +-- * Symbols + +_colon :: Prod r Text (Located Token) Location +_colon = symbol ":" ? ":" +_pipe :: Prod r Text (Located Token) Location +_pipe = (optional (command "middle") *> symbol "|") <|> command "mid" ? "\\mid" +_comma :: Prod r Text (Located Token) Location +_comma = symbol "," ? "," +_commaAnd :: Prod r Text (Located Token) Location +_commaAnd = symbol "," <* optional (word "and") ? ", and" +_commaOr :: Prod r Text (Located Token) Location +_commaOr = symbol "," <* optional (word "or") ? ", or" +_defeq :: Prod r Text (Located Token) Location +_defeq = symbol ":=" ? ":=" -- Should use `\coloneq` from unicode-math as display. +_dot :: Prod r Text (Located Token) Location +_dot = symbol "." ? "." +_eq :: Prod r Text (Located Token) Location +_eq = symbol "=" ? "=" +_in :: Prod r Text (Located Token) Location +_in = command "in" ? "\\in" +_subseteq :: Prod r Text (Located Token) Location +_subseteq = command "subseteq" ? "\\subseteq" +_to :: Prod r Text (Located Token) Location +_to = command "to" ? "\\to" +_mapsto :: Prod r Text (Located Token) Location +_mapsto = command "mapsto" ? "\\mapsto" +_ampersand :: Prod r Text (Located Token) Location +_ampersand = symbol "&" ? "&" diff --git a/source/Felix/Syntax/Interface.hs b/source/Felix/Syntax/Interface.hs new file mode 100644 index 0000000..1820705 --- /dev/null +++ b/source/Felix/Syntax/Interface.hs @@ -0,0 +1,887 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Syntax.Interface + ( MixfixLevel + , mixfixLevel + , mixfixLevelValue + , MixfixLevelError(..) + , Fixity(..) + , sourcePragmaFixity + , CanonicalLexicalEntry(..) + , canonicalLexicalSurfacePatterns + , eligibleExpressionPattern + , CanonicalSyntaxDelta + , canonicalSyntaxDelta + , canonicalSyntaxDeltaEntries + , canonicalSyntaxDeltaSize + , CanonicalSyntaxCollision + , canonicalCollisionPattern + , canonicalCollisionEntries + , CanonicalSyntaxDeltaId + , canonicalSyntaxDeltaId + , canonicalSyntaxDeltaIdDigest + , BaseSyntaxInterfaceId + , baseSyntaxInterfaceId + , baseSyntaxInterfaceIdDigest + , baseSyntaxManifest + , fixedBaseSyntaxEntries + , SyntaxInterfaceId + , syntaxInterfaceIdDigest + , ModuleSyntaxInterface + , moduleSyntaxInterface + , moduleSyntaxBase + , moduleSyntaxDirectInputs + , moduleSyntaxLocalDelta + , moduleSyntaxAssertedId + , SyntaxInterfaceError(..) + , validateModuleSyntaxInterface + , putCanonicalLexicalEntryCache + , getCanonicalLexicalEntryCache + , putPatternCache + , getPatternCache + , putTokenCache + , getTokenCache + , putCanonicalSyntaxDeltaCache + , getCanonicalSyntaxDeltaCache + , putModuleSyntaxInterfaceCache + , getModuleSyntaxInterfaceCache + , putBaseSyntaxInterfaceIdCache + , getBaseSyntaxInterfaceIdCache + , putSyntaxInterfaceIdCache + , getSyntaxInterfaceIdCache + ) where + +import Base + +import Felix.Cache.Codec +import Felix.Syntax.Abstract +import Felix.Syntax.Lexicon +import Felix.Syntax.Pragma + +import Control.DeepSeq (NFData) +import Control.Monad (unless) +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.Word (Word8) +import Numeric.Natural (Natural) + + +newtype MixfixLevel = MixfixLevel Word8 + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +data MixfixLevelError + = MixfixLevelOutOfRange !Word8 + deriving stock (Show, Eq) + +mixfixLevel :: Word8 -> Either MixfixLevelError MixfixLevel +mixfixLevel supplied + | supplied <= 9 = + Right (MixfixLevel supplied) + | otherwise = + Left (MixfixLevelOutOfRange supplied) + +mixfixLevelValue :: MixfixLevel -> Word8 +mixfixLevelValue (MixfixLevel level) = + level + +data Fixity = Fixity + { fixityAssociativity :: !Associativity + , fixityLevel :: !MixfixLevel + } deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +sourcePragmaFixity :: SyntaxPragma -> Fixity +sourcePragmaFixity pragma = + Fixity + (syntaxPragmaAssociativity pragma) + (MixfixLevel + (sourceMixfixLevelValue + (syntaxPragmaLevel pragma))) + +-- | Complete origin-free lexical semantics produced by scanning. +data CanonicalLexicalEntry + = CanonicalLeftAdjective !Pattern !Marker + | CanonicalRightAdjective !Pattern !Marker + | CanonicalFunctionPhrase !Pattern !Pattern !Marker + | CanonicalNoun !Pattern !Pattern !Marker + | CanonicalStructureNoun !Pattern !Pattern !Marker + | CanonicalVerb !Pattern !Pattern !Marker + | CanonicalRelation !Token !ParameterArity !Marker + | CanonicalExpressionFunction !Pattern !Marker !Fixity + | CanonicalPrefixPredicate !Text !Natural !Marker + | CanonicalStructureOperation !Text + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | Every surface pattern through which the concrete parser can select an +-- entry. Equal singular and plural surfaces are returned only once. +canonicalLexicalSurfacePatterns + :: CanonicalLexicalEntry + -> NonEmpty Pattern +canonicalLexicalSurfacePatterns = + deduplicatePatterns . \case + CanonicalLeftAdjective pat _marker -> + [pat] + CanonicalRightAdjective pat _marker -> + [pat] + CanonicalFunctionPhrase singular _plural _marker -> + [singular] + CanonicalNoun singular plural _marker -> + [singular, plural] + CanonicalStructureNoun singular _plural _marker -> + [singular] + CanonicalVerb singular plural _marker -> + [singular, plural] + CanonicalRelation token arity marker -> + [ relationSymbolPattern + (RelationSymbol token arity marker) + ] + CanonicalExpressionFunction pat _marker _fixity -> + [pat] + CanonicalPrefixPredicate command _arity _marker -> + [ prefixPredicatePattern + (PrefixPredicate command 0) + ] + CanonicalStructureOperation command -> + [structSymbolPattern (StructSymbol command)] + where + deduplicatePatterns patterns = + case NonEmpty.nonEmpty + (Set.toList (Set.fromList patterns)) of + Just nonempty -> + nonempty + Nothing -> + impossible + "canonical lexical entry has no parser surface" + +eligibleExpressionPattern :: Pattern -> Bool +eligibleExpressionPattern pat = + case patternToHoley pat of + Nothing : rest -> + case reverse rest of + Nothing : middleReversed -> + let middle = + reverse middleReversed + in + countHoles middle == 0 + && any isJust middle + _ -> + False + _ -> + False + where + countHoles = + length . List.filter isNothing + +newtype CanonicalSyntaxDelta = + CanonicalSyntaxDelta + [CanonicalLexicalEntry] + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +data CanonicalSyntaxCollision = CanonicalSyntaxCollision + { canonicalCollisionPattern :: !Pattern + , canonicalCollisionEntries + :: !(NonEmpty CanonicalLexicalEntry) + } deriving stock (Show, Eq) + +canonicalSyntaxDelta + :: [CanonicalLexicalEntry] + -> Either CanonicalSyntaxCollision CanonicalSyntaxDelta +canonicalSyntaxDelta supplied = + case orderedCollisions of + [] -> + Right (CanonicalSyntaxDelta orderedEntries) + (_encodedPattern, pat, entries) : _ -> + Left + (CanonicalSyntaxCollision + pat + (case NonEmpty.nonEmpty + (canonicalEntryOrder + (Set.toList entries)) of + Just collisionEntries -> + collisionEntries + Nothing -> + impossible + "canonical syntax collision has no entries")) + where + orderedEntries = + canonicalEntryOrder + (Set.toList (Set.fromList supplied)) + + grouped = + foldl' + (\entries entry -> + foldl' + (\indexed pat -> + Map.insertWith + Set.union + pat + (Set.singleton entry) + indexed) + entries + (canonicalLexicalSurfacePatterns entry)) + mempty + orderedEntries + + orderedCollisions = + List.sortOn + (\(encodedPattern, _pattern, _entries) -> + encodedPattern) + [ ( encodeCache (putPatternCache pat) + , pat + , entries + ) + | (pat, entries) <- Map.toList grouped + , Set.size entries > 1 + ] + +canonicalSyntaxDeltaEntries + :: CanonicalSyntaxDelta + -> [CanonicalLexicalEntry] +canonicalSyntaxDeltaEntries + (CanonicalSyntaxDelta entries) = + entries + +canonicalSyntaxDeltaSize :: CanonicalSyntaxDelta -> Int +canonicalSyntaxDeltaSize + (CanonicalSyntaxDelta entries) = + length entries + +canonicalEntryOrder + :: [CanonicalLexicalEntry] + -> [CanonicalLexicalEntry] +canonicalEntryOrder = + List.sortOn + (encodeCache . putCanonicalLexicalEntryCache) + +newtype CanonicalSyntaxDeltaId = + CanonicalSyntaxDeltaId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +canonicalSyntaxDeltaId + :: CanonicalSyntaxDelta + -> CanonicalSyntaxDeltaId +canonicalSyntaxDeltaId delta = + CanonicalSyntaxDeltaId + (hashCacheFields + "felix-syntax-delta-v1" + [encodeCache + (putCanonicalSyntaxDeltaCache delta)]) + +canonicalSyntaxDeltaIdDigest + :: CanonicalSyntaxDeltaId + -> CacheDigest +canonicalSyntaxDeltaIdDigest + (CanonicalSyntaxDeltaId digest) = + digest + +newtype BaseSyntaxInterfaceId = + BaseSyntaxInterfaceId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +baseSyntaxInterfaceId :: BaseSyntaxInterfaceId +baseSyntaxInterfaceId = + BaseSyntaxInterfaceId + (hashCacheFields + "felix-base-syntax-interface-v1" + [encodeCache + (putCacheList + putManifestRow + baseSyntaxManifest)]) + where + putManifestRow = + putCacheList putCanonicalLexicalEntryCache + . canonicalEntryOrder + +baseSyntaxInterfaceIdDigest + :: BaseSyntaxInterfaceId + -> CacheDigest +baseSyntaxInterfaceIdDigest + (BaseSyntaxInterfaceId digest) = + digest + +baseSyntaxManifest :: [[CanonicalLexicalEntry]] +baseSyntaxManifest = + case traverse makeRow + (zip [0 :: Word8 ..] builtinMixfixLevels) of + Right rows + | length rows == 10 -> + rows + _ -> + impossible + "the fixed mixfix manifest does not have ten valid rows" + where + makeRow (row, entries) = do + level <- mixfixLevel row + pure + [ CanonicalExpressionFunction + pat + marker + (Fixity associativity level) + | MixfixItem pat marker associativity <- + entries + ] + +-- | Every fixed lexical entry consulted by the concrete parser. The base +-- syntax identity above commits to the ten expression rows; the remaining +-- fixed categories are compiler input covered by the cache epoch. +fixedBaseSyntaxEntries :: [CanonicalLexicalEntry] +fixedBaseSyntaxEntries = + case canonicalSyntaxDelta rawEntries of + Right delta -> + canonicalSyntaxDeltaEntries delta + Left collision -> + impossible + ("fixed base syntax contains a collision: " + <> show collision) + where + rawEntries = + concat baseSyntaxManifest + <> (canonicalAdjective CanonicalLeftAdjective + <$> lexiconAdjLs builtins) + <> (canonicalAdjective CanonicalRightAdjective + <$> lexiconAdjRs builtins) + <> (canonicalSgPl CanonicalFunctionPhrase + <$> lexiconFuns builtins) + <> (canonicalSgPl CanonicalNoun + <$> lexiconNouns builtins) + <> (canonicalSgPl CanonicalStructureNoun + <$> lexiconStructNouns builtins) + <> (canonicalSgPl CanonicalVerb + <$> lexiconVerbs builtins) + <> (canonicalRelation + <$> lexiconRelationSymbols builtins) + <> (canonicalPrefix + <$> lexiconPrefixPredicates builtins) + <> (canonicalStructure + <$> lexiconStructFun builtins) + + canonicalAdjective constructor item = + constructor + (lexicalItemPattern item) + (lexicalItemMarker item) + + canonicalSgPl constructor item = + let patterns = + lexicalItemSgPlPattern item + in + constructor + (sg patterns) + (pl patterns) + (lexicalItemSgPlMarker item) + + canonicalRelation relation = + CanonicalRelation + (relationSymbolToken relation) + (relationSymbolParameterArity relation) + (relationSymbolMarker relation) + + canonicalPrefix + (PrefixPredicate command arity, marker) = + CanonicalPrefixPredicate + command + (fromIntegral arity) + marker + + canonicalStructure (StructSymbol command) = + CanonicalStructureOperation command + +newtype SyntaxInterfaceId = + SyntaxInterfaceId CacheDigest + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +syntaxInterfaceIdDigest :: SyntaxInterfaceId -> CacheDigest +syntaxInterfaceIdDigest (SyntaxInterfaceId digest) = + digest + +data ModuleSyntaxInterface = ModuleSyntaxInterface + !BaseSyntaxInterfaceId + ![SyntaxInterfaceId] + !CanonicalSyntaxDelta + !SyntaxInterfaceId + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +moduleSyntaxBase + :: ModuleSyntaxInterface + -> BaseSyntaxInterfaceId +moduleSyntaxBase + (ModuleSyntaxInterface base _direct _delta _asserted) = + base + +moduleSyntaxDirectInputs + :: ModuleSyntaxInterface + -> [SyntaxInterfaceId] +moduleSyntaxDirectInputs + (ModuleSyntaxInterface _base direct _delta _asserted) = + direct + +moduleSyntaxLocalDelta + :: ModuleSyntaxInterface + -> CanonicalSyntaxDelta +moduleSyntaxLocalDelta + (ModuleSyntaxInterface _base _direct delta _asserted) = + delta + +moduleSyntaxAssertedId + :: ModuleSyntaxInterface + -> SyntaxInterfaceId +moduleSyntaxAssertedId + (ModuleSyntaxInterface _base _direct _delta asserted) = + asserted + +data SyntaxInterfaceError + = DuplicateDirectSyntaxInterface !SyntaxInterfaceId + | UnexpectedBaseSyntaxInterface + !BaseSyntaxInterfaceId + !BaseSyntaxInterfaceId + | SyntaxInterfaceIdMismatch + !SyntaxInterfaceId + !SyntaxInterfaceId + deriving stock (Show, Eq) + +moduleSyntaxInterface + :: [SyntaxInterfaceId] + -> CanonicalSyntaxDelta + -> Either SyntaxInterfaceError ModuleSyntaxInterface +moduleSyntaxInterface direct delta = + validateModuleSyntaxInterface + baseSyntaxInterfaceId + direct + delta + (computeSyntaxInterfaceId + baseSyntaxInterfaceId + direct + delta) + +validateModuleSyntaxInterface + :: BaseSyntaxInterfaceId + -> [SyntaxInterfaceId] + -> CanonicalSyntaxDelta + -> SyntaxInterfaceId + -> Either SyntaxInterfaceError ModuleSyntaxInterface +validateModuleSyntaxInterface base direct delta asserted = do + unless + (base == baseSyntaxInterfaceId) + (Left + (UnexpectedBaseSyntaxInterface + base + baseSyntaxInterfaceId)) + case firstDuplicate direct of + Just duplicate -> + Left + (DuplicateDirectSyntaxInterface duplicate) + Nothing -> + pure () + let computed = + computeSyntaxInterfaceId base direct delta + unless + (asserted == computed) + (Left + (SyntaxInterfaceIdMismatch + asserted + computed)) + Right + (ModuleSyntaxInterface + base + direct + delta + asserted) + +computeSyntaxInterfaceId + :: BaseSyntaxInterfaceId + -> [SyntaxInterfaceId] + -> CanonicalSyntaxDelta + -> SyntaxInterfaceId +computeSyntaxInterfaceId base direct delta = + SyntaxInterfaceId + (hashCacheFields + "felix-syntax-interface-v1" + [ cacheDigestBytes + (baseSyntaxInterfaceIdDigest base) + , encodeCache + (putCacheList + putSyntaxInterfaceIdCache + direct) + , cacheDigestBytes + (canonicalSyntaxDeltaIdDigest + (canonicalSyntaxDeltaId delta)) + ]) + +firstDuplicate :: Ord value => [value] -> Maybe value +firstDuplicate = + go mempty + where + go _seen [] = + Nothing + go seen (value : rest) + | value `Set.member` seen = + Just value + | otherwise = + go (Set.insert value seen) rest + +putCanonicalLexicalEntryCache + :: CanonicalLexicalEntry + -> CachePut +putCanonicalLexicalEntryCache = \case + CanonicalLeftAdjective pat marker -> do + putCacheTag 0x00 + putPatternCache pat + putMarkerCache marker + CanonicalRightAdjective pat marker -> do + putCacheTag 0x01 + putPatternCache pat + putMarkerCache marker + CanonicalFunctionPhrase singular plural marker -> do + putCacheTag 0x02 + putPatternCache singular + putPatternCache plural + putMarkerCache marker + CanonicalNoun singular plural marker -> do + putCacheTag 0x03 + putPatternCache singular + putPatternCache plural + putMarkerCache marker + CanonicalStructureNoun singular plural marker -> do + putCacheTag 0x04 + putPatternCache singular + putPatternCache plural + putMarkerCache marker + CanonicalVerb singular plural marker -> do + putCacheTag 0x05 + putPatternCache singular + putPatternCache plural + putMarkerCache marker + CanonicalRelation token arity marker -> do + putCacheTag 0x06 + putTokenCache token + putCacheNatural (parameterArityValue arity) + putMarkerCache marker + CanonicalExpressionFunction pat marker fixity -> do + putCacheTag 0x07 + putPatternCache pat + putMarkerCache marker + putFixityCache fixity + CanonicalPrefixPredicate command arity marker -> do + putCacheTag 0x08 + putCacheText command + putCacheNatural arity + putMarkerCache marker + CanonicalStructureOperation command -> do + putCacheTag 0x09 + putCacheText command + +getCanonicalLexicalEntryCache + :: CacheGet CanonicalLexicalEntry +getCanonicalLexicalEntryCache = + getCacheTag >>= \case + 0x00 -> + CanonicalLeftAdjective + <$> getPatternCache + <*> getMarkerCache + 0x01 -> + CanonicalRightAdjective + <$> getPatternCache + <*> getMarkerCache + 0x02 -> + CanonicalFunctionPhrase + <$> getPatternCache + <*> getPatternCache + <*> getMarkerCache + 0x03 -> + CanonicalNoun + <$> getPatternCache + <*> getPatternCache + <*> getMarkerCache + 0x04 -> + CanonicalStructureNoun + <$> getPatternCache + <*> getPatternCache + <*> getMarkerCache + 0x05 -> + CanonicalVerb + <$> getPatternCache + <*> getPatternCache + <*> getMarkerCache + 0x06 -> + CanonicalRelation + <$> getTokenCache + <*> (ParameterArity <$> getCacheNatural) + <*> getMarkerCache + 0x07 -> + CanonicalExpressionFunction + <$> getPatternCache + <*> getMarkerCache + <*> getFixityCache + 0x08 -> + CanonicalPrefixPredicate + <$> getCacheText + <*> getCacheNatural + <*> getMarkerCache + 0x09 -> + CanonicalStructureOperation + <$> getCacheText + tag -> + fail + ("unknown canonical lexical entry tag " + <> show tag) + +putCanonicalSyntaxDeltaCache + :: CanonicalSyntaxDelta + -> CachePut +putCanonicalSyntaxDeltaCache + (CanonicalSyntaxDelta entries) = + putCacheList putCanonicalLexicalEntryCache entries + +getCanonicalSyntaxDeltaCache + :: CacheGet CanonicalSyntaxDelta +getCanonicalSyntaxDeltaCache = do + supplied <- getCacheList getCanonicalLexicalEntryCache + case canonicalSyntaxDelta supplied of + Left collision -> + fail + ("colliding cached canonical syntax entries: " + <> show collision) + Right delta + | canonicalSyntaxDeltaEntries delta == supplied -> + pure delta + | otherwise -> + fail + "cached canonical syntax entries are not in canonical order" + +putModuleSyntaxInterfaceCache + :: ModuleSyntaxInterface + -> CachePut +putModuleSyntaxInterfaceCache + (ModuleSyntaxInterface base direct delta asserted) = do + putBaseSyntaxInterfaceIdCache base + putCacheList putSyntaxInterfaceIdCache direct + putCanonicalSyntaxDeltaCache delta + putSyntaxInterfaceIdCache asserted + +getModuleSyntaxInterfaceCache + :: CacheGet ModuleSyntaxInterface +getModuleSyntaxInterfaceCache = do + base <- getBaseSyntaxInterfaceIdCache + direct <- getCacheList getSyntaxInterfaceIdCache + delta <- getCanonicalSyntaxDeltaCache + asserted <- getSyntaxInterfaceIdCache + case + validateModuleSyntaxInterface + base + direct + delta + asserted of + Left err -> + fail + ("invalid module syntax interface: " + <> show err) + Right interface -> + pure interface + +putBaseSyntaxInterfaceIdCache + :: BaseSyntaxInterfaceId + -> CachePut +putBaseSyntaxInterfaceIdCache + (BaseSyntaxInterfaceId digest) = + putCacheDigest digest + +getBaseSyntaxInterfaceIdCache + :: CacheGet BaseSyntaxInterfaceId +getBaseSyntaxInterfaceIdCache = + BaseSyntaxInterfaceId <$> getCacheDigest + +putSyntaxInterfaceIdCache + :: SyntaxInterfaceId + -> CachePut +putSyntaxInterfaceIdCache + (SyntaxInterfaceId digest) = + putCacheDigest digest + +getSyntaxInterfaceIdCache + :: CacheGet SyntaxInterfaceId +getSyntaxInterfaceIdCache = + SyntaxInterfaceId <$> getCacheDigest + +putFixityCache :: Fixity -> CachePut +putFixityCache (Fixity associativity level) = do + putAssociativityCache associativity + putCacheTag (mixfixLevelValue level) + +getFixityCache :: CacheGet Fixity +getFixityCache = do + associativity <- getAssociativityCache + suppliedLevel <- getCacheTag + case mixfixLevel suppliedLevel of + Left err -> + fail ("invalid cached mixfix level: " <> show err) + Right level -> + pure (Fixity associativity level) + +putAssociativityCache :: Associativity -> CachePut +putAssociativityCache = + putCacheTag . \case + LeftAssoc -> + 0x00 + RightAssoc -> + 0x01 + NonAssoc -> + 0x02 + +getAssociativityCache :: CacheGet Associativity +getAssociativityCache = + getCacheTag >>= \case + 0x00 -> + pure LeftAssoc + 0x01 -> + pure RightAssoc + 0x02 -> + pure NonAssoc + tag -> + fail + ("unknown associativity tag " <> show tag) + +putMarkerCache :: Marker -> CachePut +putMarkerCache (Marker marker) = + putCacheText marker + +getMarkerCache :: CacheGet Marker +getMarkerCache = + Marker <$> getCacheText + +putPatternCache :: Pattern -> CachePut +putPatternCache = \case + End -> + putCacheTag 0x00 + HoleCons rest -> do + putCacheTag 0x01 + putPatternCache rest + TokenCons token rest -> do + putCacheTag 0x02 + putTokenCache token + putPatternCache rest + +getPatternCache :: CacheGet Pattern +getPatternCache = + getCacheTag >>= \case + 0x00 -> + pure End + 0x01 -> + HoleCons <$> getPatternCache + 0x02 -> + TokenCons + <$> getTokenCache + <*> getPatternCache + tag -> + fail + ("unknown lexical pattern tag " <> show tag) + +putTokenCache :: Token -> CachePut +putTokenCache = \case + Word text -> do + putCacheTag 0x00 + putCacheText text + Variable text -> do + putCacheTag 0x01 + putCacheText text + Symbol text -> do + putCacheTag 0x02 + putCacheText text + Integer integer -> do + putCacheTag 0x03 + putCacheInteger (toInteger integer) + Command text -> do + putCacheTag 0x04 + putCacheText text + Label text -> do + putCacheTag 0x05 + putCacheText text + Ref references -> do + putCacheTag 0x06 + putCacheList putCacheText (toList references) + BeginEnv text -> do + putCacheTag 0x07 + putCacheText text + EndEnv text -> do + putCacheTag 0x08 + putCacheText text + ParenL -> + putCacheTag 0x09 + ParenR -> + putCacheTag 0x0a + BracketL -> + putCacheTag 0x0b + BracketR -> + putCacheTag 0x0c + VisibleBraceL -> + putCacheTag 0x0d + VisibleBraceR -> + putCacheTag 0x0e + InvisibleBraceL -> + putCacheTag 0x0f + InvisibleBraceR -> + putCacheTag 0x10 + +getTokenCache :: CacheGet Token +getTokenCache = + getCacheTag >>= \case + 0x00 -> + Word <$> getCacheText + 0x01 -> + Variable <$> getCacheText + 0x02 -> + Symbol <$> getCacheText + 0x03 -> + Integer <$> getCacheInt + 0x04 -> + Command <$> getCacheText + 0x05 -> + Label <$> getCacheText + 0x06 -> do + references <- getCacheList getCacheText + case NonEmpty.nonEmpty references of + Nothing -> + fail "cached reference token has no marker" + Just nonempty -> + pure (Ref nonempty) + 0x07 -> + BeginEnv <$> getCacheText + 0x08 -> + EndEnv <$> getCacheText + 0x09 -> + pure ParenL + 0x0a -> + pure ParenR + 0x0b -> + pure BracketL + 0x0c -> + pure BracketR + 0x0d -> + pure VisibleBraceL + 0x0e -> + pure VisibleBraceR + 0x0f -> + pure InvisibleBraceL + 0x10 -> + pure InvisibleBraceR + tag -> + fail ("unknown lexical token tag " <> show tag) + +getCacheInt :: CacheGet Int +getCacheInt = do + integer <- getCacheInteger + if integer < toInteger (minBound :: Int) + || integer > toInteger (maxBound :: Int) + then + fail "cached integer token exceeds Int" + else + pure (fromInteger integer) diff --git a/source/Felix/Syntax/Internal.hs b/source/Felix/Syntax/Internal.hs new file mode 100644 index 0000000..d129947 --- /dev/null +++ b/source/Felix/Syntax/Internal.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Data types for the internal (semantic) syntax tree. +module Felix.Syntax.Internal + ( module Felix.Syntax.Internal + , module Felix.Syntax.Abstract + , module Felix.Syntax.LexicalPhrase + , module Felix.Syntax.Token + ) where + + +import Base +import Felix.Syntax.Lexicon + ( pattern PairSymbol + , pattern UnionsSymbol + , pattern UpairSymbol + ) +import Felix.Syntax.LexicalPhrase (unsafeReadPhrase, unsafeReadPhraseSgPl) +import Felix.Syntax.Token (Token(..)) +import Felix.Report.Location + +import Felix.Syntax.Abstract + ( Chain(..) + , Associativity(..) + , Connective(..) + , VarSymbol(..) + , pattern NamedVar + , pattern FreshVar + , FunctionSymbol + , SymbolPattern(..) + , MixfixItem(..) + , Pattern(..) + , LexicalItem + , LexicalItemSgPl + , RelationSymbol(..) + , ParameterArity(..) + , PrefixPredicate(..) + , StructSymbol (..) + , Relation + , PropositionalConstant(..) + , StructPhrase + , Justification(..) + , Marker(..) + , markerFromToken + , lexicalItemMarker + , lexicalItemSgPlMarker + , mkLexicalItem + , mkLexicalItemSgPl + , relationSymbolMarker + , relationSymbolParameterArity + , relationSymbolToken + , parameterArityOf + , parameterArityValue + , zeroParameterArity + , mixfixMarker + , mkMixfixItem + , pattern CarrierSymbol, pattern ConsSymbol, pattern ElementSymbol + , pattern NotElementSymbol, pattern EqSymbol, pattern NeqSymbol, pattern SubseteqSymbol + ) + +import Bound +import Bound.Scope +import Data.Deriving (deriveShow1, deriveEq1, deriveOrd1) +import Data.Hashable.Lifted +import Data.HashMap.Strict qualified as HM +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set + +-- | 'Symbol's can be used as function and relation symbols. +data Symbol + = SymbolMixfix FunctionSymbol + | SymbolFun LexicalItemSgPl + | SymbolInteger Int + | SymbolPredicate Predicate + deriving (Show, Eq, Ord, Generic, Hashable) + + +data Predicate + = PredicateAdj LexicalItem + | PredicateVerb LexicalItemSgPl + | PredicateNoun LexicalItemSgPl -- ^ /@\<...\> is a \<...\>@/. + | PredicateRelation RelationSymbol + | PredicateSymbol Text + | PredicateNounStruct LexicalItemSgPl -- ^ /@\<...\> is a \<...\>@/. + deriving (Show, Eq, Ord, Generic, Hashable) + + +-- | The object-language marker of an ownable symbol. +objectSymbolMarker :: Symbol -> Maybe Marker +objectSymbolMarker = \case + SymbolMixfix symbol -> + Just (mixfixMarker symbol) + SymbolFun symbol -> + Just (lexicalItemSgPlMarker symbol) + SymbolInteger{} -> + Nothing + SymbolPredicate predicate -> + Just (predicateObjectMarker predicate) + +-- | The object-language marker of a predicate. +predicateObjectMarker :: Predicate -> Marker +predicateObjectMarker = \case + PredicateAdj item -> + lexicalItemMarker item + PredicateVerb item -> + lexicalItemSgPlMarker item + PredicateNoun item -> + lexicalItemSgPlMarker item + PredicateRelation relation -> + relationSymbolMarker relation + PredicateSymbol text -> + Marker text + PredicateNounStruct item -> + lexicalItemSgPlMarker item + + +data Quantifier + = Universally + | Existentially + deriving (Show, Eq, Ord, Generic, Hashable) + +type Formula = Term +type Term = Expr +type Expr = ExprOf VarSymbol + + +-- | Internal higher-order expressions. +data ExprOf a + = TermVar a + -- ^ Fresh constants disjoint from all user-named identifiers. + -- These can be used to eliminate higher-order constructs. + -- + | TermSymbol Location Symbol [ExprOf a] + -- ^ Application of a symbol (including function and predicate symbols). + | TermSymbolStruct StructSymbol (Maybe (ExprOf a)) + -- + | Apply (ExprOf a) (NonEmpty (ExprOf a)) + -- ^ Higher-order application. + -- + | TermSep VarSymbol (ExprOf a) (Scope () ExprOf a) + -- ^ Set comprehension using seperation, e.g.: /@{ x ∈ X | P(x) }@/. + -- + | ReplacePred VarSymbol VarSymbol (ExprOf a) (Scope ReplacementVar ExprOf a) + -- ^ Replacement for single-valued predicates. The concrete syntax for these + -- syntactically requires a bounded existential quantifier in the condition: + -- + -- /@$\\{ y | \\exists x\\in A. P(x,y) \\}$@/ + -- + -- In definitions the single-valuedness of @P@ becomes a proof obligation. + -- In other cases we could instead add it as constraint + -- + -- /@$b\\in \\{ y | \\exists x\\in A. P(x,y) \\}$@/ + -- /@iff@/ + -- /@$\\exists x\\in A. P(x,y)$ and $P$ is single valued@/ + -- + -- + | ReplaceFun (NonEmpty (VarSymbol, ExprOf a)) (Scope VarSymbol ExprOf a) (Scope VarSymbol ExprOf a) + -- ^ Set comprehension using functional replacement, + -- e.g.: /@{ f(x, y) | x ∈ X; y ∈ Y; P(x, y) }@/. + -- The list of pairs gives the domains, the integers in the scope point to list indices. + -- The first scope is the lhs, the optional scope can be used for additional constraints + -- on the variables (i.e. implicit separation over the product of the domains). + -- An out-of-bound index is an error, since otherwise replacement becomes unsound. + -- + | Connected Connective (ExprOf a) (ExprOf a) + | Lambda (Scope VarSymbol ExprOf a) + | Quantified Quantifier (Scope VarSymbol ExprOf a) + | PropositionalConstant PropositionalConstant + | Not Location (ExprOf a) + deriving (Functor, Foldable, Traversable) + +-- | Best source location carried by an elaborated expression. +exprLocation :: Expr -> Location +exprLocation = \case + TermVar variable -> locate variable + TermSymbol location _symbol _arguments -> location + TermSymbolStruct _symbol expression -> + maybe Nowhere exprLocation expression + Apply function _arguments -> exprLocation function + TermSep variable _bound _predicate -> locate variable + ReplacePred value _domain _bound _predicate -> locate value + ReplaceFun ((variable, _domain) :| _remaining) _value _condition -> + locate variable + Connected _connective left _right -> exprLocation left + Lambda{} -> Nowhere + Quantified{} -> Nowhere + PropositionalConstant{} -> Nowhere + Not location _term -> location + +data ReplacementVar = ReplacementDomVar | ReplacementRangeVar deriving (Show, Eq, Ord, Generic, Hashable) + +makeBound ''ExprOf + +deriveShow1 ''ExprOf +deriveEq1 ''ExprOf +deriveOrd1 ''ExprOf + +deriving instance Show a => Show (ExprOf a) +deriving instance Eq a => Eq (ExprOf a) +deriving instance Ord a => Ord (ExprOf a) + +deriving instance Generic (ExprOf a) +deriving instance Generic1 ExprOf + +deriving instance Hashable1 ExprOf + +deriving instance Hashable a => Hashable (ExprOf a) + +mentionedSymbols :: ExprOf a -> Set Symbol +mentionedSymbols = \case + TermVar{} -> + mempty + TermSymbol _loc symbol args -> + Set.insert symbol (Set.unions (mentionedSymbols <$> args)) + TermSymbolStruct _symbol expr -> + maybe mempty mentionedSymbols expr + Apply expr args -> + mentionedSymbols expr <> Set.unions (mentionedSymbols <$> toList args) + TermSep _x bound scope -> + mentionedSymbols bound <> mentionedSymbols (fromScope scope) + ReplacePred _y _x bound scope -> + mentionedSymbols bound <> mentionedSymbols (fromScope scope) + ReplaceFun bounds lhs cond -> + Set.unions (mentionedSymbols . snd <$> toList bounds) + <> mentionedSymbols (fromScope lhs) + <> mentionedSymbols (fromScope cond) + Connected _conn left right -> + mentionedSymbols left <> mentionedSymbols right + Lambda scope -> + mentionedSymbols (fromScope scope) + Quantified _quant scope -> + mentionedSymbols (fromScope scope) + PropositionalConstant{} -> + mempty + Not _loc expr -> + mentionedSymbols expr + +abstractVarSymbol :: VarSymbol -> ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +abstractVarSymbol x = abstract (\y -> if x == y then Just x else Nothing) + +abstractVarSymbols :: Foldable t => t VarSymbol -> ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +abstractVarSymbols xs = abstract (\y -> if y `elem` xs then Just y else Nothing) + + +forgetLocation :: forall a. ExprOf a -> ExprOf a +forgetLocation = \case + TermVar a -> + TermVar a + + TermSymbol _loc symb args -> + TermSymbol Nowhere symb (map forgetLocation args) + + TermSymbolStruct ss me -> + TermSymbolStruct ss (forgetLocation <$> me) + + Apply f args -> + Apply (forgetLocation f) (forgetLocation <$> args) + + TermSep v dom sc -> + TermSep v (forgetLocation dom) (hoistScope forgetLocation sc) + + ReplacePred v1 v2 dom sc -> + ReplacePred v1 v2 (forgetLocation dom) (hoistScope forgetLocation sc) + + ReplaceFun doms lhs rhs -> + ReplaceFun + (fmap (fmap forgetLocation) doms) + (hoistScope forgetLocation lhs) + (hoistScope forgetLocation rhs) + + Connected c e1 e2 -> + Connected c (forgetLocation e1) (forgetLocation e2) + + Lambda sc -> + Lambda (hoistScope forgetLocation sc) + + Quantified q sc -> + Quantified q (hoistScope forgetLocation sc) + + PropositionalConstant pc -> + PropositionalConstant pc + + Not _loc e -> + Not Nowhere (forgetLocation e) + + +equivalent :: Eq a => ExprOf a -> ExprOf a -> Bool +equivalent e1 e2 = forgetLocation e1 == forgetLocation e2 + +-- | Use the given set of in scope structures to cast them to their carriers +-- when occurring on the rhs of the element relation. +-- Use the given 'Map' to annotate (unannotated) structure operations +-- with the most recent inscope appropriate label. +annotateWith :: Set VarSymbol -> HashMap StructSymbol VarSymbol -> Formula -> Formula +annotateWith = go + where + go :: (Ord a) => Set a -> HashMap StructSymbol a -> ExprOf a -> ExprOf a + go labels ops = \case + TermSymbolStruct symb Nothing -> + -- TODO error if symbol is not instantiated, but only in theorems? + TermSymbolStruct symb (TermVar <$> HM.lookup symb ops) + TermSymbolStruct symb (Just e) -> + TermSymbolStruct symb (Just (go labels ops e)) + IsElementOf loc1 a (TermVar x) | x `Set.member` labels -> + IsElementOf loc1 (go labels ops a) (TermSymbolStruct CarrierSymbol (Just (TermVar x))) + Not loc a -> + Not loc (go labels ops a) + Connected conn a b -> + Connected conn (go labels ops a) (go labels ops b) + Quantified quant body -> + Quantified quant (toScope (go (Set.map F labels) (F <$> ops) (fromScope body))) + e@TermVar{} -> e + TermSymbol loc symb args -> + TermSymbol loc symb (go labels ops <$> args) + Apply e1 args -> + Apply (go labels ops e1) (go labels ops <$> args) + TermSep vs e scope -> + TermSep vs (go labels ops e) (toScope (go (Set.map F labels) (F <$> ops) (fromScope scope))) + ReplacePred y x xB scope -> + ReplacePred y x (go labels ops xB) (toScope (go (Set.map F labels) (F <$> ops) (fromScope scope))) + ReplaceFun bounds ap cond -> + ReplaceFun + (fmap (\(x, e) -> (x, go labels ops e)) bounds) + (toScope (go (Set.map F labels) (F <$> ops) (fromScope ap))) + (toScope (go (Set.map F labels) (F <$> ops) (fromScope cond))) + Lambda body -> + Lambda (toScope (go (Set.map F labels) (F <$> ops) (fromScope body))) + e@PropositionalConstant{} -> e + +containsHigherOrderConstructs :: ExprOf a -> Bool +containsHigherOrderConstructs = \case + TermSep {} -> True + ReplacePred{}-> True + ReplaceFun{}-> True + Lambda{} -> True + Apply{} -> False -- FIXME: this is a lie in general; we need to add sortchecking to determine this. + TermVar{} -> False + PropositionalConstant{} -> False + TermSymbol _loc _s es -> any containsHigherOrderConstructs es + Not _loc e -> containsHigherOrderConstructs e + Connected _ e1 e2 -> containsHigherOrderConstructs e1 || containsHigherOrderConstructs e2 + Quantified _ scope -> containsHigherOrderConstructs (fromScope scope) + TermSymbolStruct _ _ -> False + +pattern TermOp :: Location -> FunctionSymbol -> [ExprOf a] -> ExprOf a +pattern TermOp loc op es = TermSymbol loc (SymbolMixfix op) es + +pattern TermConst :: Location -> Token -> ExprOf a +pattern TermConst loc c <- TermOp loc (MixfixItem (TokenCons c End) _ NonAssoc) [] + where + TermConst loc c = + TermOp loc (MixfixItem (TokenCons c End) (markerFromToken c) NonAssoc) [] + +pattern TermPair :: Location -> ExprOf a -> ExprOf a -> ExprOf a +pattern TermPair loc e1 e2 = TermOp loc PairSymbol [e1, e2] + +pattern Atomic :: Location -> Predicate -> [ExprOf a] -> ExprOf a +pattern Atomic loc symbol args = TermSymbol loc (SymbolPredicate symbol) args + + +pattern FormulaAdj :: Location -> ExprOf a -> LexicalItem -> [ExprOf a] -> ExprOf a +pattern FormulaAdj loc e adj es = Atomic loc (PredicateAdj adj) (e:es) + +pattern FormulaVerb :: Location -> ExprOf a -> LexicalItemSgPl -> [ExprOf a] -> ExprOf a +pattern FormulaVerb loc e verb es = Atomic loc (PredicateVerb verb) (e:es) + +pattern FormulaNoun :: Location -> ExprOf a -> LexicalItemSgPl -> [ExprOf a] -> ExprOf a +pattern FormulaNoun loc e noun es = Atomic loc (PredicateNoun noun) (e:es) + +relationNoun :: Location -> Expr -> Formula +relationNoun loc arg = FormulaNoun loc arg (mkLexicalItemSgPl (unsafeReadPhraseSgPl "relation[/s]") "relation") [] + +rightUniqueAdj :: Location -> Expr -> Formula +rightUniqueAdj loc arg = FormulaAdj loc arg (mkLexicalItem (unsafeReadPhrase "right-unique") "rightunique") [] + +-- | Untyped quantification. +pattern Forall, Exists :: Scope VarSymbol ExprOf a -> ExprOf a +pattern Forall scope = Quantified Universally scope +pattern Exists scope = Quantified Existentially scope + +makeForall, makeExists :: Foldable t => t VarSymbol -> Formula -> Formula +makeForall xs e = Quantified Universally (abstractVarSymbols xs e) +makeExists xs e = Quantified Existentially (abstractVarSymbols xs e) + +instantiateSome :: NonEmpty VarSymbol -> Scope VarSymbol ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +instantiateSome xs scope = toScope (instantiateEither inst scope) + where + inst (Left x) | x `elem` xs = TermVar (F x) + inst (Left b) = TermVar (B b) + inst (Right fv) = TermVar (F fv) + +-- | Bind all free variables not occuring in the given set universally +forallClosure :: Set VarSymbol -> Formula -> Formula +forallClosure xs phi = if isClosed phi + then phi + else Quantified Universally (abstract isNamedVar phi) + where + isNamedVar :: VarSymbol -> Maybe VarSymbol + isNamedVar x = if x `Set.member` xs then Nothing else Just x + +freeVars :: ExprOf VarSymbol -> Set VarSymbol +freeVars = Set.fromList . toList + +pattern And :: ExprOf a -> ExprOf a -> ExprOf a +pattern And e1 e2 = Connected Conjunction e1 e2 + +pattern Or :: ExprOf a -> ExprOf a -> ExprOf a +pattern Or e1 e2 = Connected Disjunction e1 e2 + +pattern Implies :: ExprOf a -> ExprOf a -> ExprOf a +pattern Implies e1 e2 = Connected Implication e1 e2 + +pattern Iff :: ExprOf a -> ExprOf a -> ExprOf a +pattern Iff e1 e2 = Connected Equivalence e1 e2 + +pattern Xor :: ExprOf a -> ExprOf a -> ExprOf a +pattern Xor e1 e2 = Connected ExclusiveOr e1 e2 + + +pattern Bottom :: ExprOf a +pattern Bottom = PropositionalConstant IsBottom + +pattern Top :: ExprOf a +pattern Top = PropositionalConstant IsTop + + +data RelationApplicationError + = RelationParameterArityMismatch + { relationApplicationLocation :: Location + , relationApplicationSymbol :: RelationSymbol + , relationApplicationExpectedParameters :: ParameterArity + , relationApplicationActualParameters :: ParameterArity + } + deriving (Show, Eq, Ord) + +checkRelationParameterArity + :: Foldable f + => Location + -> RelationSymbol + -> f a + -> Either RelationApplicationError () +checkRelationParameterArity loc relation parameters + | expected == actual = + Right () + | otherwise = + Left RelationParameterArityMismatch + { relationApplicationLocation = loc + , relationApplicationSymbol = relation + , relationApplicationExpectedParameters = expected + , relationApplicationActualParameters = actual + } + where + expected = relationSymbolParameterArity relation + actual = parameterArityOf parameters + +makeRelationApplication + :: Location + -> RelationSymbol + -> [ExprOf a] + -> Either + RelationApplicationError + (ExprOf a -> ExprOf a -> ExprOf a) +makeRelationApplication loc relation parameters = do + checkRelationParameterArity loc relation parameters + pure \left right -> + Atomic loc (PredicateRelation relation) (parameters <> [left, right]) + +pattern Relation :: Location -> RelationSymbol -> [ExprOf a] -> ExprOf a +pattern Relation loc rel es <- Atomic loc (PredicateRelation rel) es + +-- | Membership. +pattern IsElementOf :: Location -> ExprOf a -> ExprOf a -> ExprOf a +pattern IsElementOf loc e1 e2 = + Atomic loc (PredicateRelation ElementSymbol) [e1, e2] + +isElementOf :: ExprOf a -> ExprOf a -> ExprOf a +isElementOf e1 e2 = + Atomic Nowhere (PredicateRelation ElementSymbol) [e1, e2] + +-- | Membership. +isNotElementOf :: Location -> ExprOf a -> ExprOf a -> ExprOf a +isNotElementOf loc e1 e2 = Not loc (IsElementOf loc e1 e2) + +-- | Subset relation (non-strict). +pattern IsSubsetOf :: Location -> ExprOf a -> ExprOf a -> ExprOf a +pattern IsSubsetOf loc e1 e2 = Atomic loc (PredicateRelation SubseteqSymbol) (e1 : [e2]) + +ordinalNoun :: LexicalItemSgPl +ordinalNoun = mkLexicalItemSgPl (unsafeReadPhraseSgPl "ordinal[/s]") "ordinal" + +isOrdinalNoun :: LexicalItemSgPl -> Bool +isOrdinalNoun noun = noun == ordinalNoun + +-- | Ordinal predicate. +pattern IsOrd :: Location -> ExprOf a -> ExprOf a +pattern IsOrd loc e1 <- Atomic loc (PredicateNoun (isOrdinalNoun -> True)) [e1] + where + IsOrd loc e1 = Atomic loc (PredicateNoun ordinalNoun) [e1] + +-- | Equality. +pattern Equals :: Location -> ExprOf a -> ExprOf a -> ExprOf a +pattern Equals loc e1 e2 = Atomic loc (PredicateRelation EqSymbol) (e1 : [e2]) + +equals :: ExprOf a -> ExprOf a -> ExprOf a +equals e1 e2 = Atomic Nowhere (PredicateRelation EqSymbol) (e1 : [e2]) + +-- | Disequality. +pattern NotEquals :: Location -> ExprOf a -> ExprOf a -> ExprOf a +pattern NotEquals loc e1 e2 = Atomic loc (PredicateRelation NeqSymbol) (e1 : [e2]) + +pattern EmptySet :: Location -> ExprOf a +pattern EmptySet loc = + TermSymbol loc + (SymbolMixfix (MixfixItem (TokenCons (Command "emptyset") End) "emptyset" NonAssoc)) + [] + +makeConjunction :: [ExprOf a] -> ExprOf a +makeConjunction = \case + [] -> Top + es -> List.foldl1' And es + +makeDisjunction :: [ExprOf a] -> ExprOf a +makeDisjunction = \case + [] -> Bottom + es -> List.foldl1' Or es + +makeIff :: [ExprOf a] -> ExprOf a +makeIff = \case + [] -> Bottom + es -> List.foldl1' Iff es + +makeXor :: [ExprOf a] -> ExprOf a +makeXor = \case + [] -> Bottom + es -> List.foldl1' Xor es + +-- | Source-ordered HOTG finite-set adjunction. +-- +-- This deliberately uses only fixed operations. In particular, finite-set +-- notation is independent of the ordinary source-owned 'ConsSymbol'. +finiteSet :: Location -> NonEmpty (ExprOf a) -> ExprOf a +finiteSet location = foldr insert (EmptySet location) + where + insert element set = + TermSymbol location (SymbolMixfix UnionsSymbol) + [ TermSymbol location (SymbolMixfix UpairSymbol) + [ TermSymbol location (SymbolMixfix UpairSymbol) + [element, element] + , set + ] + ] + +isPositive :: ExprOf a -> Bool +isPositive = \case + Not _ _ -> False + _ -> True + +dual :: ExprOf a -> ExprOf a +dual = \case + Not _loc f -> f + f -> Not Nowhere f + + + +-- | Local assumptions. +data Asm + = Asm Formula + | AsmStruct VarSymbol StructPhrase + + +deriving instance Show Asm +deriving instance Eq Asm +deriving instance Ord Asm + +data StructAsm + = StructAsm VarSymbol StructPhrase + + + +data Axiom = Axiom [Asm] Formula + +deriving instance Show Axiom +deriving instance Eq Axiom +deriving instance Ord Axiom + + +data Lemma = Lemma [Asm] Formula + +deriving instance Show Lemma +deriving instance Eq Lemma +deriving instance Ord Lemma + + +data Defn + = DefnPredicate [Asm] Predicate (NonEmpty VarSymbol) Formula + | DefnFun [Asm] LexicalItemSgPl [VarSymbol] Term + | DefnOp FunctionSymbol [VarSymbol] Term + +deriving instance Show Defn +deriving instance Eq Defn +deriving instance Ord Defn + +data Inductive = Inductive + { inductiveSymbol :: FunctionSymbol + , inductiveParams :: [VarSymbol] + , inductiveDomain :: Expr + , inductiveIntros :: NonEmpty IntroRule + } + deriving (Show, Eq, Ord) + +data IntroRule = IntroRule + { introConditions :: [Formula] -- The inductively defined set may only appear as an argument of monotone operations on the rhs. + , introResult :: Formula -- TODO Refine. + } + deriving (Show, Eq, Ord) + +data CalcQuantifier + = CalcForall (NonEmpty VarSymbol) (Maybe Formula) + | CalcUnquantified + deriving (Show, Eq, Ord) + +data Proof + = Omitted Location + -- ^ Ends a proof without further verification. + -- This results in a “gap” in the formalization. + | Qed {mloc :: Maybe Location, by :: Justification} + -- ^ Ends of a proof, leaving automation to discharge the current goal using the given justification. + | Contradiction Location Justification + -- ^ Ends a proof by deriving absurdity using the given justification. + | ByContradiction Location Proof + -- ^ Take the dual of the current goal as an assumption and + -- set the goal to absurdity. + | BySetInduction Location (Maybe Term) Proof + -- ^ ∈-induction. + | ByOrdInduction Location Proof + -- ^ Transfinite induction for ordinals. + | Assume Location Formula Proof + -- ^ Simplify goals that are implications or disjunctions. + | Fix Location (NonEmpty VarSymbol) Formula Proof + -- ^ Simplify universal goals (with an optional bound or such that statement) + | Take Location (NonEmpty VarSymbol) Formula Justification Proof + -- ^ Use existential assumptions. + | Suffices Location Formula Justification Proof + | ByCase Location [Case] + -- ^ Proof by case. Disjunction of the case hypotheses 'Case' + -- must hold for this step to succeed. Each case starts a subproof, + -- keeping the same goal but adding the case hypothesis as an assumption. + -- Often this will be a classical split between /@P@/ and /@not P@/, in + -- which case the proof that /@P or not P@/ holds is easy. + -- + | Have Location Formula Justification Proof + -- ^ An affirmation, e.g.: /@We have \<stmt\> by \<ref\>@/. + -- + | Calc Location CalcQuantifier Calc Proof + | Subclaim Location Formula Proof Proof + -- ^ A claim is a sublemma with its own proof: + -- + -- /@Show \<goal stmt\>. \<steps\>. \<continue other proof\>.@/ + -- + -- A successful first proof adds the claimed formula as an assumption + -- for the remaining proof. + -- + | Define Location VarSymbol Term Proof + | DefineFunction Location VarSymbol VarSymbol Term Term Proof + + | DefineFunctionLocal Location VarSymbol VarSymbol VarSymbol Term (NonEmpty (Term, Formula)) Proof + +deriving instance Show Proof +deriving instance Eq Proof +deriving instance Ord Proof + + + +-- | A case of a case split. +data Case = Case + { caseOf :: Formula + , caseProof :: Proof + } + +deriving instance Show Case +deriving instance Eq Case +deriving instance Ord Case + +-- | See 'Syntax.Abstract.Calc'. +data Calc + = Equation Term (NonEmpty (Term, Justification)) + | Biconditionals Term (NonEmpty (Term, Justification)) + +deriving instance Show Calc +deriving instance Eq Calc +deriving instance Ord Calc + +calcQuant :: CalcQuantifier -> (Formula -> Formula) +calcQuant = \case + CalcUnquantified -> id + CalcForall xs maySuchThat -> case maySuchThat of + Nothing -> makeForall xs + Just suchThat -> \phi -> makeForall xs (suchThat `Implies` phi) + +calcResult :: CalcQuantifier -> Calc -> ExprOf VarSymbol +calcResult quant = \case + Equation e eqns -> calcQuant quant (Equals Nowhere e (fst (NonEmpty.last eqns))) + Biconditionals phi phis -> calcQuant quant (phi `Iff` fst (NonEmpty.last phis)) + +calculation :: CalcQuantifier -> Calc -> [(ExprOf VarSymbol, Justification)] +calculation quant = \case + Equation e1 eqns@((e2, jst) :| _) -> (calcQuant quant (Equals Nowhere e1 e2), jst) : collectEquations quant (toList eqns) + Biconditionals p1 ps@((p2, jst) :| _) -> (calcQuant quant (p1 `Iff` p2), jst) : collectBiconditionals quant (toList ps) + + +collectEquations :: CalcQuantifier -> [(Formula, j)] -> [(Formula, j)] +collectEquations quant = \case + (e1, _) : eqns'@((e2, jst) : _) -> (calcQuant quant (Equals Nowhere e1 e2), jst) : collectEquations quant eqns' + _ -> [] + +collectBiconditionals :: CalcQuantifier -> [(Formula, j)] -> [(Formula, j)] +collectBiconditionals quant = \case + (p1, _) : ps@((p2, jst) : _) -> (calcQuant quant (p1 `Iff` p2), jst) : collectBiconditionals quant ps + _ -> [] + + +data Datatype + = Datatype + { datatypeHead :: SymbolPattern + , datatypeClauses :: NonEmpty DatatypeClause + } + deriving (Show, Eq, Ord) + +data DatatypeClause = DatatypeClause + { datatypeClauseConstructor :: SymbolPattern + , datatypeClausePremises :: [(VarSymbol, Expr)] + } + deriving (Show, Eq, Ord) + + +data Signature + = SignaturePredicate Predicate (NonEmpty VarSymbol) + | SignatureFormula Formula + -- TODO: This is a lossy encoding of a symbolic signature declaration. + -- The checker currently recovers the declared mixfix symbol heuristically + -- from the generated formula in order to assign ownership. Replace this + -- with a precise signature representation that carries the declared symbol + -- directly. + +deriving instance Show Signature +deriving instance Eq Signature +deriving instance Ord Signature + +data StructDefn = StructDefn + { structPhrase :: StructPhrase + -- ^ The noun phrase naming the structure, e.g.: @partial order@ or @abelian group@. + , structParents :: Set StructPhrase + , structDefnLabel :: VarSymbol + , structDefnFixes :: Set StructSymbol + -- ^ List of commands representing operations, + -- e.g.: @\\contained@ or @\\inv@. These are used as default operation names + -- in instantiations such as @Let $G$ be a group@. + -- The commands should be set up to handle an optional struct label + -- which would typically be rendered as a sub- or superscript, e.g.: + -- @\\contained[A]@ could render as ”⊑ᴬ“. + -- -- + , structDefnAssumes :: [(Marker, Formula)] + -- ^ The assumption or axioms of the structure. + -- To be instantiate with the @structFixes@ of a given structure. + } + +deriving instance Show StructDefn +deriving instance Eq StructDefn +deriving instance Ord StructDefn + + +data Abbreviation + = Abbreviation Symbol (Scope Int ExprOf Void) + deriving (Show, Eq, Ord) + +data Block + = BlockAxiom Location Marker Axiom + | BlockLemma Location Marker Lemma + | BlockProof Location Location Proof + | BlockDefn Location Marker Defn + | BlockAbbr Location Marker Abbreviation + | BlockStruct Location Marker StructDefn + | BlockInductive Location Marker Inductive + | BlockSig Location Marker [Asm] Signature + | BlockData Location Marker Datatype + deriving (Show, Eq, Ord) + + +-- | Full boolean contraction. +contraction :: ExprOf a -> ExprOf a +contraction = \case + Connected conn f1 f2 -> atomicContraction (Connected conn (contraction f1) (contraction f2)) + Quantified quant scope -> atomicContraction (Quantified quant (hoistScope contraction scope)) + Not loc f -> Not loc (contraction f) + f -> f + + +-- | Atomic boolean contraction. +atomicContraction :: ExprOf a -> ExprOf a +atomicContraction = \case + Top `Iff` f -> f + Bottom `Iff` f -> Not Nowhere f + f `Iff` Top -> f + f `Iff` Bottom -> Not Nowhere f + + Top `Implies` f -> f + Bottom `Implies` _ -> Top + _ `Implies` Top -> Top + f `Implies` Bottom -> Not Nowhere f + + Top `And` f -> f + Bottom `And` _ -> Bottom + f `And` Top -> f + _ `And` Bottom -> Bottom + + phi@(Quantified _quant scope) -> case unscope scope of + Top -> Top + Bottom -> Bottom + _ -> phi + + Not _ Top -> Bottom + Not _ Bottom -> Top + + f -> f diff --git a/source/Felix/Syntax/LexicalPhrase.hs b/source/Felix/Syntax/LexicalPhrase.hs new file mode 100644 index 0000000..5eb5b18 --- /dev/null +++ b/source/Felix/Syntax/LexicalPhrase.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Syntax.LexicalPhrase where + + +import Base +import Felix.Syntax.Token (Token(..)) + +import Control.DeepSeq (NFData) +import Data.Char (isAlpha) +import Data.Text qualified as Text +import Text.Earley.Mixfix (Holey) +import Text.Earley (Grammar, Prod, (<?>), fullParses, parser, rule, token, satisfy) + + + +-- | 'LexicalPhrase's should be nonempty lists with at least one proper word token. +-- Hyphens and quotes in words are treated as letters. +-- Thus /@manifold-with-boundary@/ is a singleton lexical phrase (one word). +-- +type LexicalPhrase = Holey Token + +-- MAYBE Add this instance by making LexicalPhrase a proper Type? +-- Until then we can use the default instance for lists of prettyprintable things. +-- +-- instance Pretty LexicalPhrase where +-- pretty components = hsep (prettyComponent <$> components) +-- where +-- prettyComponent = \case +-- Nothing -> "_" +-- Just tok -> pretty tok + + + +-- | Split data by grammatical number (singular/plural). +-- The 'Eq' and 'Ord' instances only consider the singular +-- form so that we can prefer known irregular plurals over +-- guessed irregular plurals when inserting items into +-- the 'Lexicon'. +data SgPl a + = SgPl {sg :: a, pl :: a} + deriving (Show, Functor, Generic, Hashable, NFData) + +instance Eq a => Eq (SgPl a) where (==) = (==) `on` sg +instance Ord a => Ord (SgPl a) where compare = compare `on` sg + + +-- These readers parse only Felix-owned lexical literals. +unsafeReadPhrase :: String -> LexicalPhrase +unsafeReadPhrase spec = case fst (fullParses (parser lexicalPhraseSpec) spec) of + pat : _ -> pat + _ -> error "unsafeReadPhrase failed" + +unsafeReadPhraseSgPl :: String -> SgPl LexicalPhrase +unsafeReadPhraseSgPl spec = case fst (fullParses (parser lexicalPhraseSpecSgPl) spec) of + pat : _ -> pat + _ -> error "unsafeReadPhraseSgPl failed" + + +lexicalPhraseSpec :: Grammar r (Prod r String Char LexicalPhrase) +lexicalPhraseSpec = do + hole <- rule $ Nothing <$ token '?' <?> "hole" + word <- rule $ Just <$> many (satisfy (\c -> isAlpha c || c == '-')) + space <- rule $ Just . (:[]) <$> token ' ' + segment <- rule $ hole <|> word + rule $ (\s ss -> makePhrase (s:ss)) <$> segment <*> many (space *> segment) + where + makePhrase :: [Maybe String] -> LexicalPhrase + makePhrase pat = fmap makeWord pat + + +lexicalPhraseSpecSgPl :: Grammar r (Prod r String Char (SgPl LexicalPhrase)) +lexicalPhraseSpecSgPl = do + space <- rule $ Just . (:[]) <$> token ' ' + hole <- rule $ (Nothing, Nothing) <$ token '?'<?> "hole" + + word <- rule (many (satisfy isAlpha) <?> "word") + wordSgPl <- rule $ (,) <$> (token '[' *> word) <* token '/' <*> word <* token ']' + complexWord <- rule $ (\(a,b) -> (Just a, Just b)) . fuse <$> + many ((<>) <$> (dup <$> word) <*> wordSgPl) <?> "word" + segment <- rule (hole <|> (dup . Just <$> word) <|> complexWord ) + rule $ (\s ss -> makePhrase (s:ss)) <$> segment <*> many (space *> segment) + where + dup x = (x,x) + fuse = \case + (a, b) : (c, d) : rest -> fuse ((a <> c, b <> d) : rest) + [(a, b)] -> (a, b) + _ -> error "Syntax.Abstract.fuse" + + makePhrase :: [(Maybe String, Maybe String)] -> SgPl LexicalPhrase + makePhrase = (\(patSg, patPl) -> SgPl (fmap makeWord patSg) (fmap makeWord patPl)) . unzip + +makeWord :: Maybe String -> Maybe Token +makeWord = fmap (Word . Text.pack) diff --git a/source/Felix/Syntax/Lexicon.hs b/source/Felix/Syntax/Lexicon.hs new file mode 100644 index 0000000..c3332c7 --- /dev/null +++ b/source/Felix/Syntax/Lexicon.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The 'Lexicon' describes the part of the grammar that extensible/dynamic. +-- +-- The items of the 'Lexicon' are organized by their meaning and their +-- syntactic behaviour. They are typically represented as some kind of +-- pattern data which is then used to generate various production rules +-- for the concrete grammar. This representation makes inspection and +-- extension easier. +-- + +module Felix.Syntax.Lexicon + ( module Felix.Syntax.Lexicon + , pattern ConsSymbol + , pattern PairSymbol + , pattern UpairSymbol + , pattern UnionsSymbol + , pattern CarrierSymbol + , pattern ApplySymbol + , pattern DomSymbol + ) where + + +import Base +import Felix.Syntax.Abstract + +import Data.List qualified as List +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Felix.Syntax.Mixfix (Holey) + + +data SignatureHeadForm + = AdjectiveSignatureHead + | SymbolicSignatureHead + deriving (Show, Eq, Ord) + +-- Adjective heads must precede symbolic heads because both start with a math +-- variable. +concreteSignatureHeadForms :: [SignatureHeadForm] +concreteSignatureHeadForms = + [ AdjectiveSignatureHead + , SymbolicSignatureHead + ] + +data Lexicon = Lexicon + { lexiconMixfixTable :: Seq (Map Pattern MixfixItem) + , lexiconConnectives :: [[(Holey Token, Associativity)]] + , lexiconPrefixPredicates :: [(PrefixPredicate, Marker)] + , lexiconStructFun :: [StructSymbol] + , lexiconRelationSymbols :: [RelationSymbol] + , lexiconVerbs :: [LexicalItemSgPl] + , lexiconAdjLs :: [LexicalItem] + , lexiconAdjRs :: [LexicalItem] + , lexiconNouns :: [LexicalItemSgPl] + , lexiconStructNouns :: [LexicalItemSgPl] + , lexiconFuns :: [LexicalItemSgPl] + } deriving (Show, Eq) + +-- Projection returning the union of both left and right attributes. +-- +lexiconAdjs :: Lexicon -> [LexicalItem] +lexiconAdjs lexicon = lexiconAdjLs lexicon <> lexiconAdjRs lexicon + + +builtins :: Lexicon +builtins = + Lexicon + { lexiconMixfixTable = builtinMixfixTable + , lexiconPrefixPredicates = builtinPrefixPredicates + , lexiconStructFun = builtinStructOps + , lexiconConnectives = builtinConnectives + , lexiconRelationSymbols = builtinRelationSymbols + , lexiconAdjLs = [] + , lexiconAdjRs = builtinAdjRs + , lexiconVerbs = builtinVerbs + , lexiconNouns = builtinNouns + , lexiconStructNouns = builtinStructNouns + , lexiconFuns = [] + } + +prefixPredicatePattern :: PrefixPredicate -> Pattern +prefixPredicatePattern (PrefixPredicate command _arity) = + TokenCons (Command command) End + +builtinMixfixTable :: Seq (Map Pattern MixfixItem) +builtinMixfixTable = Seq.fromList $ Map.fromList . fmap toEntry <$> builtinMixfixLevels + where + toEntry item@(MixfixItem pat _ _) = (pat, item) + +-- INVARIANT: 10 precedence levels for now. +builtinMixfixLevels :: [[MixfixItem]] +builtinMixfixLevels = + [ [] + , [binOp (Symbol "+") LeftAssoc "add", binOp (Command "union") LeftAssoc "union", binOp (Symbol "-") LeftAssoc "minus", binOp (Command "rminus") LeftAssoc "rminus", binOp (Command "monus") LeftAssoc "monus"] + , [binOp (Command "relcomp") LeftAssoc "relcomp"] + , [binOp (Command "circ") LeftAssoc "circ"] + , [binOp (Command "mul") LeftAssoc "mul", binOp (Command "inter") LeftAssoc "inter", binOp (Command "rmul") LeftAssoc "rmul"] + , [binOp (Command "setminus") LeftAssoc "setminus"] + , [binOp (Command "times") RightAssoc "times"] + , [] + , prefixOps + , builtinIdentifiers + ] + where + builtinIdentifiers :: [MixfixItem] + builtinIdentifiers = identifier <$> + [ "emptyset" + , "naturals" + , "naturalsPlus" + , "integers" + , "rationals" + , "reals" + , "unit" + , "zero" + ] + + +prefixOps :: [MixfixItem] +prefixOps = + [ mkMixfixItem [Just (Command "rfrac"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "rfrac" NonAssoc + , mkMixfixItem [Just (Command "exp"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "exp" NonAssoc + , UnionsSymbol + , mkMixfixItem [Just (Command "cumul"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "cumul" NonAssoc + , mkMixfixItem [Just (Command "fst"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "fst" NonAssoc + , mkMixfixItem [Just (Command "snd"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "snd" NonAssoc + , mkMixfixItem [Just (Command "pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "pow" NonAssoc + , mkMixfixItem [Just (Command "neg"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "neg" NonAssoc + , mkMixfixItem [Just (Command "inv"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "inv" NonAssoc + , mkMixfixItem [Just (Command "abs"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "abs" NonAssoc + , ConsSymbol + , PairSymbol + , UpairSymbol + -- NOTE Is now defined and hence no longer necessary , ApplySymbol + ] + + +builtinStructOps :: [StructSymbol] +builtinStructOps = + [ CarrierSymbol + ] + +identifier :: Text -> MixfixItem +identifier cmd = mkMixfixItem [Just (Command cmd)] (Marker cmd) NonAssoc + + +builtinRelationSymbols :: [RelationSymbol] +builtinRelationSymbols = + [ RelationSymbol (Symbol "=") zeroParameterArity "eq" + , RelationSymbol (Command "rless") zeroParameterArity "rless" + , RelationSymbol (Command "neq") zeroParameterArity "neq" + , ElementSymbol + , NotElementSymbol -- Alternative to @\not\in@. + ] + +builtinPrefixPredicates :: [(PrefixPredicate, Marker)] +builtinPrefixPredicates = + [ (PrefixPredicate "Cong" 4, "cong") + , (PrefixPredicate "Betw" 3, "betw") + ] + + +builtinConnectives :: [[(Holey Token, Associativity)]] +builtinConnectives = + [ [binOp' (Command "iff") NonAssoc] + , [binOp' (Command "implies") RightAssoc] + , [binOp' (Command "lor") LeftAssoc] + , [binOp' (Command "land") LeftAssoc] + , [([Just (Command "lnot"), Nothing], NonAssoc)] + ] + + +binOp :: Token -> Associativity -> Marker -> MixfixItem +binOp tok assoc m = mkMixfixItem [Nothing, Just tok, Nothing] m assoc + +binOp' :: Token -> Associativity -> (Holey Token, Associativity) +binOp' tok assoc = ([Nothing, Just tok, Nothing], assoc) + +builtinAdjRs :: [LexicalItem] +builtinAdjRs = + [ builtinEqualityRightAdjective + ] + +builtinEqualityRightAdjective :: LexicalItem +builtinEqualityRightAdjective = + mkLexicalItem (unsafeReadPhrase "equal to ?") "eq" + +builtinVerbs :: [LexicalItemSgPl] +builtinVerbs = + [ builtinEqualityVerb + ] + +builtinEqualityVerb :: LexicalItemSgPl +builtinEqualityVerb = + mkLexicalItemSgPl (unsafeReadPhraseSgPl "equal[s/] ?") "eq" + + +-- Some of these do/should correspond to mathlib structures, +-- e.g.: lattice, complete lattice, ring, etc. +-- +builtinNouns :: [LexicalItemSgPl] +builtinNouns = + [ builtinSetNoun + , mkLexicalItemSgPl (unsafeReadPhraseSgPl "point[/s]") "point" + , builtinElementNoun + ] + +builtinSetNoun :: LexicalItemSgPl +builtinSetNoun = + mkLexicalItemSgPl + (unsafeReadPhraseSgPl "set[/s]") + "set" + +builtinElementNoun :: LexicalItemSgPl +builtinElementNoun = + mkLexicalItemSgPl + (unsafeReadPhraseSgPl "element[/s] of ?") + "elem" + +-- | Match the complete fixed-base identity, including the plural surface and +-- authoritative marker. The ordinary 'Eq' instance intentionally compares +-- only singular patterns. +isBuiltinSetNoun :: LexicalItemSgPl -> Bool +isBuiltinSetNoun item = + let actual = lexicalItemSgPlPattern item + expected = lexicalItemSgPlPattern builtinSetNoun + in sg actual == sg expected + && pl actual == pl expected + && lexicalItemSgPlMarker item + == lexicalItemSgPlMarker builtinSetNoun + +_Onesorted :: LexicalItemSgPl +_Onesorted = mkLexicalItemSgPl (unsafeReadPhraseSgPl "onesorted structure[/s]") "onesorted_structure" + +builtinStructNouns :: [LexicalItemSgPl] +builtinStructNouns = [_Onesorted] + + +-- | Naïve splitting of lexical phrases to insert a variable slot for names in noun phrases, +-- as in /@there exists a linear form $h$ on $E$@/, where the underlying pattern is +-- /@linear form on ?@/. In this case we would get: +-- +-- > splitOnVariableSlot (sg (unsafeReadPhraseSgPl "linear form[/s] on ?")) +-- > == +-- > (unsafeReadPhrase "linear form", unsafeReadPhrase "on ?") +-- +splitOnVariableSlot :: LexicalPhrase -> (LexicalPhrase, LexicalPhrase) +splitOnVariableSlot pat = case prepositionIndices <> nonhyphenatedSlotIndices of + [] -> (pat, []) -- Place variable slot at the end. + is -> List.splitAt (minimum is) pat + where + prepositionIndices, slotIndices, nonhyphenatedSlotIndices :: [Int] -- Ascending. + prepositionIndices = List.findIndices isPreposition pat + slotIndices = List.findIndices isNothing pat + nonhyphenatedSlotIndices = [i | i <- slotIndices, noHyphen (nth (i + 1) pat)] + + isPreposition :: Maybe Token -> Bool + isPreposition = \case + Just (Word w) -> w `Set.member` prepositions + _ -> False + + noHyphen :: Maybe (Maybe Token) -> Bool + noHyphen = \case + Just (Just (Word w)) -> Text.head w /= '-' + -- If we arrive here, either the pattern is over (`Nothing`) or the next + -- part of the pattern is not a word that starts with a hyphen. + _ -> True + + +-- Preposition are a closed class, but this list is not yet exhaustive. +-- It can and should be extended when needed. The following list is a +-- selection of the prepositions found at +-- https://en.wikipedia.org/wiki/List_of_English_prepositions. +-- +prepositions :: Set Text +prepositions = Set.fromList + [ "about" + , "above" + , "across" + , "after" + , "against" + , "along", "alongside" + , "amid", "amidst" + , "among" + , "around" + , "as" + , "at" + , "atop" + , "before" + , "behind" + , "below" + , "beneath" + , "beside", "besides" + , "between" + , "beyond" + , "but" + , "by" + , "except" + , "for" + , "from" + , "in", "inside", "into" + , "like" + , "modulo", "mod" + , "near" + , "next" + , "of" + , "off" + , "on" + , "onto" + , "opposite" + , "out" + , "over" + , "past" + , "per" + , "sans" + , "till" + , "to" + , "under" + , "underneath" + , "unlike" + , "unto" + , "up", "upon" + , "versus" + , "via" + , "with" + , "within" + , "without" + ] diff --git a/source/Felix/Syntax/Mixfix.hs b/source/Felix/Syntax/Mixfix.hs new file mode 100644 index 0000000..a3ce4bb --- /dev/null +++ b/source/Felix/Syntax/Mixfix.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RecursiveDo #-} + +module Felix.Syntax.Mixfix where + +{- +Original code Copyright (c) 2014-2019, Olle Fredriksson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Olle Fredriksson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + + +import Base +import Text.Earley +import Data.Either +import Felix.Syntax.Abstract + + +replicateA :: Applicative f => Int -> f a -> f [a] +replicateA n = sequenceA . replicate n + +consA :: Applicative f => f a -> f [a] -> f [a] +consA p q = (:) <$> p <*> q + + +-- | An identifier with identifier parts ('Just's), and holes ('Nothing's) +-- representing the positions of its arguments. +-- +-- Example (commonly written "if_then_else_"): +-- @['Just' "if", 'Nothing', 'Just' "then", 'Nothing', 'Just' "else", 'Nothing'] :: 'Holey' 'String'@ +type Holey a = [Maybe a] + + +-- | Create a grammar for parsing mixfix expressions. +mixfixExpression + :: [[(Holey (Prod r e t ident), Associativity)]] + -- ^ A table of holey identifier parsers, with associativity information. + -- The identifiers should be in groups of precedence levels listed from + -- binding the least to the most tightly. + -- + -- The associativity is taken into account when an identifier starts or ends + -- with holes, or both. Internal holes (e.g. after "if" in "if_then_else_") + -- start from the beginning of the table. + -- + -- Note that this rule also applies to identifiers with multiple consecutive + -- holes, e.g. "if__" --- the associativity then applies to both holes. + -> Prod r e t expr + -- ^ An atom, i.e. what is parsed at the lowest level. This will + -- commonly be a (non-mixfix) identifier or a parenthesised expression. + -> (Holey ident -> [expr] -> expr) + -- ^ How to combine the successful application of a holey identifier to its + -- arguments into an expression. + -> Grammar r (Prod r e t expr) +mixfixExpression table atom app = mixfixExpressionSeparate table' atom + where + table' = [[(holey, assoc, app) | (holey, assoc) <- row] | row <- table] + +-- | A version of 'mixfixExpression' with a separate semantic action for each +-- individual 'Holey' identifier. +mixfixExpressionSeparate + :: [[(Holey (Prod r e t ident), Associativity, Holey ident -> [expr] -> expr)]] + -- ^ A table of holey identifier parsers, with associativity information and + -- semantic actions. The identifiers should be in groups of precedence + -- levels listed from binding the least to the most tightly. + -- + -- The associativity is taken into account when an identifier starts or ends + -- with holes, or both. Internal holes (e.g. after "if" in "if_then_else_") + -- start from the beginning of the table. + -- + -- Note that this rule also applies to identifiers with multiple consecutive + -- holes, e.g. "if__" --- the associativity then applies to both holes. + -> Prod r e t expr + -- ^ An atom, i.e. what is parsed at the lowest level. This will + -- commonly be a (non-mixfix) identifier or a parenthesised expression. + -> Grammar r (Prod r e t expr) +mixfixExpressionSeparate table atom = mdo + expr <- foldrM ($) atom $ map (level expr) table + return expr + where + level expr idents next = mdo + same <- rule $ asum $ next : map (mixfixIdent same) idents + return same + where + -- Group consecutive holes and ident parts. + grp [] = [] + grp (Nothing:ps) = case grp ps of + Left n:rest -> (Left $! (n + 1)) : rest + rest -> Left 1 : rest + grp (Just p:ps) = case grp ps of + Right ps':rest -> Right (consA p ps') : rest + rest -> Right (consA p $ pure []) : rest + + mixfixIdent same (ps, a, f) = f' <$> go (grp ps) + where + f' xs = f (concatMap (either (map $ const Nothing) $ map Just) xs) + $ concat $ lefts xs + go ps' = case ps' of + [] -> pure [] + [Right p] -> pure . Right <$> p + Left n:rest -> consA + (Left <$> replicateA n (if a == RightAssoc then next + else same)) + $ go rest + [Right p, Left n] -> consA + (Right <$> p) + $ pure . Left <$> replicateA n (if a == LeftAssoc then next + else same) + Right p:Left n:rest -> consA (Right <$> p) + $ consA (Left <$> replicateA n expr) + $ go rest + Right _:Right _:_ -> error + $ "Earley.mixfixExpression: The impossible happened. " + ++ "Please report this as a bug." diff --git a/source/Felix/Syntax/Pragma.hs b/source/Felix/Syntax/Pragma.hs new file mode 100644 index 0000000..97d1482 --- /dev/null +++ b/source/Felix/Syntax/Pragma.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Syntax.Pragma + ( SourceMixfixLevel + , sourceMixfixLevelValue + , SyntaxPragma(..) + , SyntaxPragmaProblem(..) + , SyntaxPragmaError(..) + , renderSyntaxPragmaError + , extractSyntaxPragmas + ) where + +import Base + +import Felix.Report.Location +import Felix.Syntax.Abstract (Associativity(..)) + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Bifunctor (first) +import Data.Char (ord) +import Data.Text qualified as Text +import Data.Word (Word8) + + +newtype SourceMixfixLevel = SourceMixfixLevel Word8 + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +sourceMixfixLevelValue :: SourceMixfixLevel -> Word8 +sourceMixfixLevelValue (SourceMixfixLevel level) = + level + +data SyntaxPragma = LocatedFixityPragma + { syntaxPragmaLocation :: !Location + , syntaxPragmaAssociativity :: !Associativity + , syntaxPragmaLevel :: !SourceMixfixLevel + } deriving stock (Show, Eq) + +instance Locatable SyntaxPragma where + locate = syntaxPragmaLocation + +data SyntaxPragmaProblem + = SyntaxPragmaMissingSpaceAfterPrefix + | SyntaxPragmaMissingKeyword + | SyntaxPragmaUnknownKeyword !Text + | SyntaxPragmaMissingLevel + | SyntaxPragmaInvalidLevel + | SyntaxPragmaLevelOutOfRange + | SyntaxPragmaTrailingContent + | SyntaxPragmaLoneCarriageReturn + deriving stock (Show, Eq) + +data SyntaxPragmaError + = InvalidSyntaxPragma !Location !SyntaxPragmaProblem + | SyntaxPragmaLocationOutOfRange !FilePath !Int !Int + deriving stock (Show, Eq) + +renderSyntaxPragmaError :: SyntaxPragmaError -> Text +renderSyntaxPragmaError = \case + InvalidSyntaxPragma location problem -> + locationToText location + <> ": " + <> renderSyntaxPragmaProblem problem + SyntaxPragmaLocationOutOfRange file line column -> + Text.pack file + <> ": syntax pragma location is out of range at " + <> Text.pack (show line) + <> ":" + <> Text.pack (show column) + +renderSyntaxPragmaProblem :: SyntaxPragmaProblem -> Text +renderSyntaxPragmaProblem = \case + SyntaxPragmaMissingSpaceAfterPrefix -> + "expected horizontal space after %!" + SyntaxPragmaMissingKeyword -> + "missing syntax pragma keyword" + SyntaxPragmaUnknownKeyword keyword -> + "unknown syntax pragma keyword " <> Text.pack (show keyword) + SyntaxPragmaMissingLevel -> + "missing syntax pragma level" + SyntaxPragmaInvalidLevel -> + "syntax pragma level must use ASCII decimal digits" + SyntaxPragmaLevelOutOfRange -> + "syntax pragma level must be between 0 and 7" + SyntaxPragmaTrailingContent -> + "unexpected trailing syntax pragma content" + SyntaxPragmaLoneCarriageReturn -> + "a syntax pragma line must end with LF, CRLF, or end of file" + +extractSyntaxPragmas + :: FileId + -> FilePath + -> Text + -> Either SyntaxPragmaError [SyntaxPragma] +extractSyntaxPragmas fileId file = + go 1 + where + go lineNumber source + | Text.null source = + Right [] + | otherwise = do + let (rawLine, suffix) = + Text.break (== '\n') source + hasLineFeed = + not (Text.null suffix) + (line, lineEnding) = + if hasLineFeed && Text.isSuffixOf "\r" rawLine + then + (Text.dropEnd 1 rawLine, CrLf) + else if hasLineFeed + then + (rawLine, LineFeed) + else + (rawLine, EndOfFile) + remaining = + if hasLineFeed + then Text.drop 1 suffix + else "" + reserved = + Text.isPrefixOf "%!" + (Text.dropWhile isHorizontalSpace line) + pragma <- + if reserved + then Just <$> parsePragmaLine + fileId + file + lineNumber + lineEnding + line + else + Right Nothing + rest <- go (lineNumber + 1) remaining + pure (maybe rest (: rest) pragma) + +data LineEnding + = LineFeed + | CrLf + | EndOfFile + deriving stock (Show, Eq) + +parsePragmaLine + :: FileId + -> FilePath + -> Int + -> LineEnding + -> Text + -> Either SyntaxPragmaError SyntaxPragma +parsePragmaLine fileId file lineNumber lineEnding rawLine = do + let horizontalPrefix = + Text.takeWhile isHorizontalSpace rawLine + column = + Text.length horizontalPrefix + 1 + location <- + first + (const + (SyntaxPragmaLocationOutOfRange + file + lineNumber + column)) + (mkLocationChecked fileId lineNumber column) + let invalid + :: SyntaxPragmaProblem + -> Either SyntaxPragmaError a + invalid = + Left . InvalidSyntaxPragma location + afterPrefix = + Text.drop 2 + (Text.dropWhile isHorizontalSpace rawLine) + when + (lineEnding == EndOfFile + && Text.isSuffixOf "\r" rawLine) + (invalid SyntaxPragmaLoneCarriageReturn) + afterPrefixSpace <- + case Text.uncons afterPrefix of + Nothing -> + invalid SyntaxPragmaMissingKeyword + Just (char, _) + | not (isHorizontalSpace char) -> + invalid SyntaxPragmaMissingSpaceAfterPrefix + Just{} -> + Right (Text.dropWhile isHorizontalSpace afterPrefix) + when + (Text.null afterPrefixSpace) + (invalid SyntaxPragmaMissingKeyword) + let (keyword, afterKeyword) = + Text.break isHorizontalSpace afterPrefixSpace + associativity <- + case keyword of + "infixl" -> + Right LeftAssoc + "infixr" -> + Right RightAssoc + "infix" -> + Right NonAssoc + _ -> + invalid (SyntaxPragmaUnknownKeyword keyword) + afterKeywordSpace <- + case Text.uncons afterKeyword of + Nothing -> + invalid SyntaxPragmaMissingLevel + Just{} -> + Right (Text.dropWhile isHorizontalSpace afterKeyword) + when + (Text.null afterKeywordSpace) + (invalid SyntaxPragmaMissingLevel) + let (digits, trailing) = + Text.span isAsciiDigit afterKeywordSpace + when + (Text.null digits) + (invalid SyntaxPragmaInvalidLevel) + level <- + maybe + (invalid SyntaxPragmaLevelOutOfRange) + (Right . SourceMixfixLevel) + (sourceLevel digits) + unless + (Text.null (Text.dropWhile isHorizontalSpace trailing)) + (invalid SyntaxPragmaTrailingContent) + pure + LocatedFixityPragma + { syntaxPragmaLocation = location + , syntaxPragmaAssociativity = associativity + , syntaxPragmaLevel = level + } + +isHorizontalSpace :: Char -> Bool +isHorizontalSpace char = + char == ' ' || char == '\t' + +isAsciiDigit :: Char -> Bool +isAsciiDigit char = + '0' <= char && char <= '9' + +sourceLevel :: Text -> Maybe Word8 +sourceLevel = + Text.foldl' step (Just 0) + where + step Nothing _ = + Nothing + step (Just current) char = + let next = + current * 10 + + fromIntegral (ord char - ord '0') + in + if next <= 7 + then Just next + else Nothing diff --git a/source/Felix/Syntax/Token.hs b/source/Felix/Syntax/Token.hs new file mode 100644 index 0000000..31d1d19 --- /dev/null +++ b/source/Felix/Syntax/Token.hs @@ -0,0 +1,633 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- This module defines the lexer and its associated data types. +-- The lexer takes `Text` as input and produces a stream of tokens +-- annotated with positional information. This information is bundled +-- together with the original raw input for producing error messages. +-- +-- The lexer perfoms some normalizations to make describing the grammar easier. +-- Words outside of math environments are case-folded. Some commands are analysed +-- as variable tokens and are equivalent to their respective unicode variants +-- (α, β, γ, ..., 𝔸, 𝔹, ℂ, ...). Similarly, @\\begin{...}@ and @\\end{...}@ commands +-- are each parsed as single tokens. +-- +module Felix.Syntax.Token + ( Token(..) + , VariableDisplay(..) + , VariableSuffix(..) + , displayVariable + , renderVariableText + , tokToString + , tokToText + , TokStream(..) + , Located(..) + , runLexer + , gatherImports + ) where + + +import Base hiding (many) + +import Felix.Report.Location + +import Control.DeepSeq (NFData) +import Control.Monad.Combinators +import Control.Monad.State.Strict +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Prettyprinter (Pretty(..)) +import Text.Megaparsec hiding (Token, Label, label) +import Text.Megaparsec.Char qualified as Char +import Text.Megaparsec.Char.Lexer qualified as Lexer +import Tptp.UnsortedFirstOrder (isAsciiLetter, isAsciiAlphaNumOrUnderscore) + + +runLexer :: FileId -> String -> Text -> Either (ParseErrorBundle Text Void) ([FilePath], [[Located Token]]) +runLexer fileId file raw = runParser (evalStateT document (initLexerState fileId)) file raw + + +type Lexer = StateT LexerState (Parsec Void Text) + + +data LexerState = LexerState + { frames :: !(NonEmpty Frame) + , currentFileId :: !FileId + } deriving (Show, Eq) + +data Frame + = TopText + | MathFrame !Text + | TextFrame !Int + deriving (Show, Eq) + +initLexerState :: FileId -> LexerState +initLexerState fileId = LexerState (TopText :| []) fileId + +topFrameOf :: LexerState -> Frame +topFrameOf LexerState{frames = frame :| _} = frame + +topFrame :: Lexer Frame +topFrame = gets topFrameOf + +pushFrame :: Frame -> LexerState -> LexerState +pushFrame frame st@LexerState{frames = top :| rest} = + st{frames = frame :| (top : rest)} + +popFrame :: LexerState -> LexerState +popFrame st@LexerState{frames = _ :| []} = st +popFrame st@LexerState{frames = _ :| (top : rest)} = + st{frames = top :| rest} + +modifyTopFrame :: (Frame -> Frame) -> LexerState -> LexerState +modifyTopFrame f st@LexerState{frames = top :| rest} = + st{frames = f top :| rest} + +-- Token recognizers only emit tokens; this is the single place that changes +-- lexical context. +advance :: Token -> LexerState -> LexerState +advance tok st = + case (topFrameOf st, tok) of + (TopText, BeginEnv "math") -> + pushFrame (MathFrame "math") st + (TextFrame{}, BeginEnv "math") -> + pushFrame (MathFrame "math") st + (TopText, BeginEnv "align*") -> + pushFrame (MathFrame "align*") st + (TextFrame{}, BeginEnv "align*") -> + pushFrame (MathFrame "align*") st + (MathFrame env, EndEnv env') + | env == env' -> + popFrame st + (MathFrame{}, BeginEnv "text") -> + pushFrame (TextFrame 1) st + (TextFrame n, InvisibleBraceL) -> + modifyTopFrame (const (TextFrame (n + 1))) st + (TextFrame n, InvisibleBraceR) + | n > 1 -> + modifyTopFrame (const (TextFrame (n - 1))) st + (TextFrame 1, EndEnv "text") -> + popFrame st + _ -> + st + +-- | +-- A token stream as input stream for a parser. Contains the raw input +-- before tokenization as 'Text' for showing error messages. +-- +data TokStream = TokStream + { rawInput :: !Text + , unTokStream :: ![[Located Token]] + } deriving (Show, Eq) + +instance Semigroup TokStream where + TokStream raw1 toks1 <> TokStream raw2 toks2 = TokStream (raw1 <> raw2) (toks1 <> toks2) + +instance Monoid TokStream where + mempty = TokStream mempty mempty + +-- | A LaTeX token. +-- Invisible delimiters 'InvisibleBraceL' and 'InvisibleBraceR' are +-- unescaped braces used for grouping in TEX (@{@), +-- visibles braces are escaped braces (@\\{@). +data Token + = Word !Text + | Variable !Text + | Symbol !Text + | Integer !Int + | Command !Text + | Label Text -- ^ A /@\\label{...}@/ command (case-sensitive). + | Ref (NonEmpty Text) -- ^ A /@\\ref{...}@/ command (case-sensitive). + | BeginEnv !Text + | EndEnv !Text + | ParenL | ParenR + | BracketL | BracketR + | VisibleBraceL | VisibleBraceR + | InvisibleBraceL | InvisibleBraceR + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance IsString Token where + fromString w = Word (Text.pack w) + +data VariableDisplay = VariableDisplay + { variableBaseText :: !Text + , variableSuffix :: !(Maybe VariableSuffix) + } deriving (Show, Eq, Ord) + +data VariableSuffix + = VariableSubscript !Text + | VariableTicks !Int + deriving (Show, Eq, Ord) + +displayVariable :: Text -> VariableDisplay +displayVariable rawName = + case splitVariableBase rawName of + Nothing -> + VariableDisplay rawName Nothing + Just (baseText, suffixText) -> + VariableDisplay baseText (displayVariableSuffix suffixText) + +renderVariableText :: Text -> Text +renderVariableText rawName = + case displayVariable rawName of + VariableDisplay baseText Nothing -> + baseText + VariableDisplay baseText (Just (VariableTicks n)) -> + baseText <> Text.replicate n "'" + VariableDisplay baseText (Just (VariableSubscript subscriptText)) -> + baseText <> renderSubscriptText subscriptText + +splitVariableBase :: Text -> Maybe (Text, Text) +splitVariableBase rawName = + matchBlackboardBase rawName <|> matchGreekBase rawName <|> matchSingleLetterBase rawName + +matchBlackboardBase :: Text -> Maybe (Text, Text) +matchBlackboardBase rawName = do + suffixText <- Text.stripPrefix "bb" rawName + case Text.uncons suffixText of + Just (upper, rest) + | 'A' <= upper && upper <= 'Z' -> + Just ("bb" <> Text.singleton upper, rest) + _ -> + Nothing + +matchGreekBase :: Text -> Maybe (Text, Text) +matchGreekBase rawName = + asum + [ (\suffixText -> (rendered, suffixText)) <$> Text.stripPrefix prefix rawName + | (prefix, rendered) <- greekVariables + ] + +matchSingleLetterBase :: Text -> Maybe (Text, Text) +matchSingleLetterBase rawName = do + (baseChar, suffixText) <- Text.uncons rawName + pure (Text.singleton baseChar, suffixText) + +displayVariableSuffix :: Text -> Maybe VariableSuffix +displayVariableSuffix suffixText + | Text.null suffixText = + Nothing + | Text.all (== '_') suffixText = + Just (VariableTicks (Text.length suffixText)) + | otherwise = + Just (VariableSubscript (Text.replace "_" "'" suffixText)) + +renderSubscriptText :: Text -> Text +renderSubscriptText subscriptText + | Text.length subscriptText == 1 = + "_" <> subscriptText + | otherwise = + "_{" <> subscriptText <> "}" + +greekVariables :: [(Text, Text)] +greekVariables = + [ ("alpha", "α"), ("beta", "β"), ("gamma", "γ"), ("delta", "δ") + , ("epsilon", "ε"), ("zeta", "ζ"), ("eta", "η"), ("theta", "θ") + , ("iota", "ι"), ("kappa", "κ"), ("lambda", "λ"), ("mu", "μ") + , ("nu", "ν"), ("xi", "ξ"), ("pi", "π"), ("rho", "ρ"), ("sigma", "σ") + , ("tau", "τ"), ("upsilon", "υ"), ("phi", "φ"), ("chi", "χ") + , ("psi", "ψ"), ("omega", "ω") + , ("Gamma", "Γ"), ("Delta", "Δ"), ("Theta", "Θ"), ("Lambda", "Λ") + , ("Xi", "Ξ"), ("Pi", "Π"), ("Sigma", "Σ"), ("Upsilon", "Υ") + , ("Phi", "Φ"), ("Psi", "Ψ"), ("Omega", "Ω") + ] + +tokToText :: Token -> Text +tokToText = \case + Word w -> w + Variable v -> renderVariableText v + Symbol s -> s + Integer n -> Text.pack (show n) + Command cmd -> Text.cons '\\' cmd + Label m -> "\\label{" <> m <> "}" + Ref ms -> "\\ref{" <> Text.intercalate ", " (toList ms) <> "}" + BeginEnv "math" -> "$" + EndEnv "math" -> "$" + BeginEnv env -> "\\begin{" <> env <> "}" + EndEnv env -> "\\end{" <> env <> "}" + ParenL -> "(" + ParenR -> ")" + BracketL -> "[" + BracketR -> "]" + VisibleBraceL -> "\\{" + VisibleBraceR -> "\\}" + InvisibleBraceL -> "{" + InvisibleBraceR -> "}" + +tokToString :: Token -> String +tokToString = Text.unpack . tokToText + +instance Pretty Token where + pretty = \case + Word w -> pretty w + Variable v -> pretty (renderVariableText v) + Symbol s -> pretty s + Integer n -> pretty n + Command cmd -> "\\" <> pretty cmd + Label m -> "\\label{" <> pretty m <> "}" + Ref m -> "\\ref{" <> pretty m <> "}" + BeginEnv env -> "\\begin{" <> pretty env <> "}" + EndEnv env -> "\\end{" <> pretty env <> "}" + ParenL -> "(" + ParenR -> ")" + BracketL -> "[" + BracketR -> "]" + VisibleBraceL -> "\\{" + VisibleBraceR -> "\\}" + InvisibleBraceL -> "{" + InvisibleBraceR -> "}" + + +data Located a = Located + { startPos :: !Location + , unLocated :: !a + , postWhitespace :: Whitespace + } deriving (Show, Functor) + +data Whitespace = NoSpace | Space deriving (Show) + +collapseWhitespace :: [Whitespace] -> Whitespace +collapseWhitespace = \case + Space : _ -> Space + NoSpace : ws -> collapseWhitespace ws + [] -> NoSpace + +instance Eq a => Eq (Located a) where (==) = (==) `on` unLocated +instance Ord a => Ord (Located a) where compare = compare `on` unLocated + + +document :: Lexer ([FilePath], [[Located Token]]) +document = do + is <- importBlock + es <- many environment + eof + return (unLocated <$> is, es) + + +importBlock :: Lexer [Located FilePath] +importBlock = do + void (skipManyTill skipChar importLineOrBeginEnvOrEof) + many importLine + where + -- When skipping to the import block, we first need to try parsing whitespace to properly handle comments and avoid picking up a commented import line at the start of the import block. + skipChar, importLineOrBeginEnvOrEof :: Lexer () + skipChar = comment <|> void anySingle + importLineOrBeginEnvOrEof = + lookAhead + (void (Char.string "\\import{") + <|> void beginToplevelEnvironment) + <|> eof + + importLine :: Lexer (Located FilePath) = lexeme do + Char.string "\\import{" + path <- some (satisfy isTheoryNameChar) + Char.char '}' + pure path + + isTheoryNameChar :: Char -> Bool + isTheoryNameChar c = + c /= '}' && c /= '\n' && c /= '\r' && c /= '\0' + +-- | Scan only the leading import block. Source-graph construction uses this +-- authority-free pass before parsing modules under their composed syntax. +gatherImports + :: FileId + -> String + -> Text + -> Either (ParseErrorBundle Text Void) [Located FilePath] +gatherImports fileId file = + runParser (evalStateT importBlock (initLexerState fileId)) file + + +beginToplevelEnvironment :: Lexer (Located Text) +beginToplevelEnvironment = lexeme do + Char.string "\\begin{" + env :: Text <- asum (Char.string <$> ["definition", "theorem", "lemma", "axiom", "proof", "corollary", "proposition", "claim", "abbreviation", "datatype", "inductive", "signature", "struct"]) + Char.char '}' + pure env + +-- | Parses tokens, switching tokenizing frames when encountering math and text environments. +environment :: Lexer [Located Token] +environment = do + env <- skipManyTill (comment <|> void anySingle) beginToplevelEnvironment + lts <- go (unLocated env) id + pure ((BeginEnv <$> env) : lts) + where + go env f = do + frame <- topFrame + r <- optional (nextTokenFor frame) + case r of + Nothing -> + pure (f []) + Just t@Located{unLocated = EndEnv env'} + | frame == TopText && env == env' -> + pure (f [t]) + Just t -> do + modify' (advance (unLocated t)) + go env (f . (t:)) +{-# INLINE environment #-} + +nextTokenFor :: Frame -> Lexer (Located Token) +nextTokenFor = \case + TopText -> normalToken + MathFrame{} -> mathToken + TextFrame n -> textToken n + +-- | Parses a single normal-mode token. +normalToken :: Lexer (Located Token) +normalToken = + word <|> symbol <|> beginMath <|> beginAlign <|> subEnvironment <|> opening <|> closing <|> label <|> ref <|> end <|> command + +-- | Parses a single math mode token. +mathToken :: Lexer (Located Token) +mathToken = + var <|> symbol <|> number <|> beginCases <|> endAlign <|> endCases <|> opening <|> closing <|> beginText <|> beginExplanation <|> endMath <|> command + +beginText :: Lexer (Located Token) +beginText = lexeme do + Char.string "\\text{" <|> Char.string "\\textbox{" + pure (BeginEnv "text") + +-- | Same as text modulo spacing, so we treat it synonymously +beginExplanation :: Lexer (Located Token) +beginExplanation = lexeme do + Char.string "\\explanation{" + pure (BeginEnv "text") + +subEnvironment :: Lexer (Located Token) +subEnvironment = beginOrEnd ["enumerate", "subproof", "byCase"] + where + beginOrEnd envs = asum [beginEnv env <|> endEnv env | env <- envs] + beginEnv env = lexeme do + Char.string ("\\begin{" <> env <> "}") + pure (BeginEnv env) + endEnv env = lexeme do + Char.string ("\\end{" <> env <> "}") + pure (EndEnv env) + +-- | Normal mode embedded into math mode via @\text{...}@. +textToken :: Int -> Lexer (Located Token) +textToken n = word <|> symbol <|> textEnd <|> beginMath <|> beginAlign <|> opening' <|> closing' <|> ref <|> command + where + textEnd = lexeme do + guard (n == 1) + Char.char '}' + pure (EndEnv "text") + + opening' = lexeme (group <|> optional (Char.string "\\left") *> (brace <|> paren <|> bracket)) + where + brace = VisibleBraceL <$ lexeme (Char.string "\\{") + group = InvisibleBraceL <$ lexeme (Char.char '{') + paren = ParenL <$ lexeme (Char.char '(') + bracket = BracketL <$ lexeme (Char.char '[') + + closing' = lexeme (group <|> optional (Char.string "\\right") *> (brace <|> paren <|> bracket)) + where + brace = VisibleBraceR <$ lexeme (Char.string "\\}") + group = InvisibleBraceR <$ lexeme (Char.char '}') + paren = ParenR <$ lexeme (Char.char ')') + bracket = BracketR <$ lexeme (Char.char ']') + + +-- | Parses a single begin math token. +beginMath :: Lexer (Located Token) +beginMath = lexeme do + Char.string "\\(" <|> Char.string "\\[" <|> Char.string "$" + pure (BeginEnv "math") + +beginAlign :: Lexer (Located Token) +beginAlign = lexeme do + Char.string "\\begin{align*}" + pure (BeginEnv "align*") + +beginCases :: Lexer (Located Token) +beginCases = lexeme do + Char.string "\\begin{cases}" + pure (BeginEnv "cases") + +-- | Parses a single end math token. +endMath :: Lexer (Located Token) +endMath = lexeme do + Char.string "\\)" <|> Char.string "\\]" <|> Char.string "$" + pure (EndEnv "math") + +endAlign :: Lexer (Located Token) +endAlign = lexeme do + Char.string "\\end{align*}" + pure (EndEnv "align*") + +endCases :: Lexer (Located Token) +endCases = lexeme do + Char.string "\\end{cases}" + pure (EndEnv "cases") + + +-- | Parses the end of an environment. +-- Commits only after having seen "\end{". +end :: Lexer (Located Token) +end = lexeme do + notFollowedBy (Char.string "\\end{cases}") + Char.string "\\end{" + env <- some (Char.letterChar <|> Char.char '*') + Char.char '}' + pure (EndEnv (Text.pack env)) + + + +-- | Parses a word. Words are returned casefolded, since we want to ignore their case later on. +word :: Lexer (Located Token) +word = lexeme do + w <- some (Char.letterChar <|> Char.char '\'' <|> Char.char '-') + let t = Word (Text.toCaseFold (Text.pack w)) + pure t + +number :: Lexer (Located Token) +number = lexeme $ Integer <$> Lexer.decimal + + +var :: Lexer (Located Token) +var = lexeme (fmap Variable var') + where + var' = do + alphabeticPart <- letter <|> bb <|> greek + variationPart <- subscript <|> ticked <|> pure "" + pure (alphabeticPart <> variationPart) + + subscript :: Lexer Text + subscript = do + Char.char '_' + unbraced <|> braced <|> text + where + unbraced = Text.singleton <$> Char.alphaNumChar + braced = Text.pack <$> (Char.char '{' *> some (Char.alphaNumChar <|> tick) <* Char.char '}') + text = Char.string "\\text" *> braced -- for rendering the subscript in roman type + + -- A bit of a hack to fit the TPTP format. + tick :: Lexer Char + tick = '_' <$ Char.char '\'' + + ticked :: Lexer Text + ticked = do + ticks <- some tick + pure (Text.pack ticks) + + letter :: Lexer Text + letter = fmap Text.singleton Char.letterChar + + greek :: Lexer Text + greek = try do + Char.char '\\' + l <- symbolParser greeks + notFollowedBy Char.letterChar + pure l + + greeks :: [Text] + greeks = + [ "alpha", "beta", "gamma", "delta", "epsilon", "zeta", "eta", "theta" + , "iota", "kappa", "lambda", "mu", "nu", "xi", "pi", "rho", "sigma" + , "tau", "upsilon", "phi", "chi", "psi", "omega" + , "Gamma", "Delta", "Theta", "Lambda", "Xi", "Pi", "Sigma", "Upsilon" + , "Phi", "Psi", "Omega" + ] + + bb :: Lexer Text + bb = do + Char.string "\\mathbb{" + l <- symbolParser bbs + Char.char '}' + pure $ "bb" <> l + + bbs :: [Text] + bbs = Text.singleton <$> ['A'..'Z'] + + + symbolParser :: [Text] -> Lexer Text + symbolParser symbols = asum (fmap Char.string symbols) + + +symbol :: Lexer (Located Token) +symbol = lexeme do + symb <- some (satisfy (`elem` symbols)) + pure (Symbol (Text.pack symb)) + where + symbols :: [Char] + symbols = ".,:;!?@=≠+-/|^><≤≥*&≈⊂⊃⊆⊇∈“”‘’" + +-- | Parses a TEX-style command. +command :: Lexer (Located Token) +command = lexeme do + Char.char '\\' + cmd <- some Char.letterChar + pure (Command (Text.pack cmd)) + +-- | Parses a label command and extracts its marker. +label :: Lexer (Located Token) +label = lexeme do + Char.string "\\label{" + m <- marker + Char.char '}' + pure (Label m) + +-- | Parses a label command and extracts its marker. +ref :: Lexer (Located Token) +ref = lexeme do + -- @\\cref@ is from @cleveref@ and @\\hyperref@ is from @hyperref@ + cmd <- Char.string "\\ref{" <|> Char.string "\\cref{" <|> Char.string "\\hyperref[" + ms <- NonEmpty.fromList <$> marker `sepBy1` Char.char ',' + case cmd of + "\\hyperref[" -> Char.string "]{" *> some (satisfy (/= '}')) *> Char.char '}' *> pure (Ref ms) + _ -> Char.char '}' *> pure (Ref ms) + +marker :: Lexer Text +marker = do + c <- satisfy isAsciiLetter + cs <- takeWhileP Nothing isAsciiAlphaNumOrUnderscore + pure (Text.cons c cs) + +-- | Parses an opening delimiter. +opening :: Lexer (Located Token) +opening = lexeme (group <|> optional (Char.string "\\left") *> (paren <|> brace <|> bracket)) + where + brace = VisibleBraceL <$ lexeme (Char.string "\\{") + group = InvisibleBraceL <$ lexeme (Char.char '{') + paren = ParenL <$ lexeme (Char.char '(') + bracket = BracketL <$ lexeme (Char.char '[') + +-- | Parses a closing delimiter. +closing :: Lexer (Located Token) +closing = lexeme (group <|> optional (Char.string "\\right") *> (paren <|> brace <|> bracket)) + where + brace = VisibleBraceR <$ lexeme (Char.string "\\}") + group = InvisibleBraceR <$ lexeme (Char.char '}') + paren = ParenR <$ lexeme (Char.char ')') + bracket = BracketR <$ lexeme (Char.char ']') + +-- | Turns a Lexer into one that tracks the source position of the token +-- and consumes trailing whitespace. +lexeme :: Lexer a -> Lexer (Located a) +lexeme p = do + fileId <- gets currentFileId + start <- getSourcePos + location <- + either + (fail . show) + pure + (fromSourcePosChecked fileId start) + t <- p + w <- whitespace + pure (Located location t w) + +space :: Lexer Whitespace +space = Space <$ (Char.char ' ' <|> Char.char '\n' <|> Char.char '\r') + <|> Space <$ (Char.string "\\ " <|> Char.string "\\\\" <|> Char.string "\\!" <|> Char.string "\\," <|> Char.string "\\:" <|> Char.string "\\;" <|> Char.string "\\;") + +whitespace :: Lexer Whitespace +whitespace = do + ws <- many (spaces <|> NoSpace <$ comment) + pure (collapseWhitespace ws) + where + spaces = collapseWhitespace <$> some space + +comment :: Lexer () +comment = Lexer.skipLineComment "%" diff --git a/source/Felix/Test/All.hs b/source/Felix/Test/All.hs new file mode 100644 index 0000000..7cdc49c --- /dev/null +++ b/source/Felix/Test/All.hs @@ -0,0 +1,14 @@ +module Felix.Test.All where + + +import Base +import Felix.Test.Golden +import Felix.Test.Unit +import Test.Tasty + + +runTests :: IO () +runTests = defaultMain =<< tests + +tests :: IO TestTree +tests = testGroup "all tests" <$> sequence [goldenTests, return unitTests] diff --git a/source/Felix/Test/Golden.hs b/source/Felix/Test/Golden.hs new file mode 100644 index 0000000..905ff73 --- /dev/null +++ b/source/Felix/Test/Golden.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +module Felix.Test.Golden where + + +import Base +import Felix.Workspace qualified as Workspace + +import Data.Text.Lazy.IO qualified as LazyTextIO +import System.Directory +import System.FilePath +import Test.Tasty +import Test.Tasty.Golden (goldenVsFile, findByExtension) +import Text.Pretty.Simple (pShowNoColor) +import UnliftIO +goldenTests :: IO TestTree +goldenTests = goldenTestGroup + +goldenTestGroup :: MonadUnliftIO io => io TestTree +goldenTestGroup = testGroup "golden tests" <$> sequence + [ tokenizing + , scanning + , parsing + ] + + +-- | A testing triple consists of a an 'input' file, which is proccesed, resulting +-- in 'output' file, which is then compared to a 'golden' file. +data Triple = Triple + { input :: FilePath + , output :: FilePath + , golden :: FilePath + } + deriving (Show, Eq) + + +-- | Gathers all the files for the test. We test all examples and everything in @test/pass/@. +-- The golden files for all tests are stored in @test/pass/@, so we need to adjust the filepath +-- of the files from @examples/@. +gatherTriples :: MonadIO io => String -> io [Triple] +gatherTriples stage = do + inputs <- liftIO (findByExtension [".tex"] "test/examples") + pure $ + [ Triple{..} + | input <- inputs + , let input' = "test" </> "golden" </> takeBaseName input </> stage + , let golden = input' <.> "golden" + , let output = input' <.> "out" + ] + +createTripleDirectoriesIfMissing :: MonadIO io => Triple -> io () +createTripleDirectoriesIfMissing Triple{..} = liftIO $ + createDirectoryIfMissing True (takeDirectory output) + +makeGoldenTest :: MonadUnliftIO io => String -> (Triple -> io ()) -> io TestTree +makeGoldenTest stage action = do + triples <- gatherTriples stage + for triples createTripleDirectoriesIfMissing + runInIO <- askRunInIO + pure $ testGroup stage + [ goldenVsFile + (takeBaseName input) -- test name + golden + output + (runInIO (action triple)) + | triple@Triple{..} <- triples + ] + +tokenizing :: MonadUnliftIO io => io TestTree +tokenizing = makeGoldenTest "tokenizing" $ \Triple{..} -> do + tokenStream <- liftIO (Workspace.tokenize input) + liftIO + (LazyTextIO.writeFile output + (pShowNoColor (Workspace.simpleStream tokenStream))) + + +scanning :: MonadUnliftIO io => io TestTree +scanning = makeGoldenTest "scanning" $ \Triple{..} -> do + lexicalItems <- liftIO (Workspace.scan input) + liftIO (LazyTextIO.writeFile output (pShowNoColor lexicalItems)) + +parsing :: MonadUnliftIO io => io TestTree +parsing = makeGoldenTest "parsing" $ \Triple{..} -> do + parseResult <- liftIO (Workspace.parse input) + liftIO (LazyTextIO.writeFile output (pShowNoColor parseResult)) diff --git a/source/Felix/Test/Unit.hs b/source/Felix/Test/Unit.hs new file mode 100644 index 0000000..f11d21f --- /dev/null +++ b/source/Felix/Test/Unit.hs @@ -0,0 +1,52 @@ +module Felix.Test.Unit where + + +import Felix.Test.Unit.Abstract qualified as Abstract +import Felix.Test.Unit.Backend qualified as Backend +import Felix.Test.Unit.CommandLine qualified as CommandLine +import Felix.Test.Unit.Concrete qualified as Concrete +import Felix.Test.Unit.Core qualified as Core +import Felix.Test.Unit.Declaration qualified as Declaration +import Felix.Test.Unit.Foundation qualified as Foundation +import Felix.Test.Unit.Html qualified as Html +import Felix.Test.Unit.HtmlLayout qualified as HtmlLayout +import Felix.Test.Unit.HtmlOutput qualified as HtmlOutput +import Felix.Test.Unit.Identity qualified as Identity +import Felix.Test.Unit.Kernel qualified as Kernel +import Felix.Test.Unit.Lexicon qualified as Lexicon +import Felix.Test.Unit.Materialization qualified as Materialization +import Felix.Test.Unit.Meaning qualified as Meaning +import Felix.Test.Unit.Module qualified as Module +import Felix.Test.Unit.OutputPlan qualified as OutputPlan +import Felix.Test.Unit.Provers qualified as Provers +import Felix.Test.Unit.Semantic qualified as Semantic +import Felix.Test.Unit.Source qualified as Source +import Felix.Test.Unit.Store qualified as Store +import Felix.Test.Unit.Token qualified as Token +import Test.Tasty + +unitTests :: TestTree +unitTests = testGroup "unit tests" + [ Abstract.unitTests + , Backend.unitTests + , CommandLine.unitTests + , Concrete.unitTests + , Core.unitTests + , Declaration.unitTests + , Foundation.unitTests + , Identity.unitTests + , Html.unitTests + , HtmlLayout.unitTests + , HtmlOutput.unitTests + , Kernel.unitTests + , Lexicon.unitTests + , Meaning.unitTests + , Materialization.unitTests + , Module.unitTests + , OutputPlan.unitTests + , Provers.unitTests + , Semantic.unitTests + , Source.unitTests + , Store.unitTests + , Token.unitTests + ] diff --git a/source/Felix/Test/Unit/Abstract.hs b/source/Felix/Test/Unit/Abstract.hs new file mode 100644 index 0000000..c487c2a --- /dev/null +++ b/source/Felix/Test/Unit/Abstract.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Abstract (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Abstract + +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.Hedgehog (testPropertyNamed) + +unitTests :: TestTree +unitTests = + testGroup "Abstract syntax" + [ testPropertyNamed + "noun phrase ordering obeys the Ord laws" + "prop_nounPhraseOrd" + prop_nounPhraseOrd + , testCase + "noun phrase fields survive ordered deduplication" + nounPhraseFieldsRemainDistinct + ] + +prop_nounPhraseOrd :: Property +prop_nounPhraseOrd = withTests 100 . property $ do + x <- forAll nounPhrase + y <- forAll nounPhrase + z <- forAll nounPhrase + + (compare x y == EQ) === (x == y) + compare x y === oppositeOrdering (compare y x) + assert (not (x <= y && y <= z) || x <= z) + +nounPhraseFieldsRemainDistinct :: Assertion +nounPhraseFieldsRemainDistinct = + assertEqual + "one value per base and changed field" + 6 + (length + (nubOrd + [ sampleNounPhrase False False False False False + , sampleNounPhrase True False False False False + , sampleNounPhrase False True False False False + , sampleNounPhrase False False True False False + , sampleNounPhrase False False False True False + , sampleNounPhrase False False False False True + ])) + +nounPhrase :: Gen (NounPhraseOf Maybe Int) +nounPhrase = + sampleNounPhrase + <$> Gen.bool + <*> Gen.bool + <*> Gen.bool + <*> Gen.bool + <*> Gen.bool + +sampleNounPhrase + :: Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> NounPhraseOf Maybe Int +sampleNounPhrase hasLeft otherNoun hasName hasRight hasSuchThat = + NounPhrase + [AdjL Nowhere leftAdjective [1] | hasLeft] + (Noun + Nowhere + (if otherNoun then secondNoun else firstNoun) + [2]) + (NamedVar "x" <$ guardMaybe hasName) + [AdjR Nowhere rightAdjective [3] | hasRight] + (truthStatement <$ guardMaybe hasSuchThat) + where + guardMaybe condition = + if condition then Just () else Nothing + +leftAdjective :: LexicalItem +leftAdjective = + mkLexicalItem [Just (Word "left")] "left" + +rightAdjective :: LexicalItem +rightAdjective = + mkLexicalItem [Just (Word "right")] "right" + +firstNoun :: LexicalItemSgPl +firstNoun = + mkLexicalItemSgPl + (SgPl + [Just (Word "first")] + [Just (Word "firsts")]) + "first" + +secondNoun :: LexicalItemSgPl +secondNoun = + mkLexicalItemSgPl + (SgPl + [Just (Word "second")] + [Just (Word "seconds")]) + "second" + +truthStatement :: Stmt +truthStatement = + StmtFormula (PropositionalConstant Nowhere IsTop) + +oppositeOrdering :: Ordering -> Ordering +oppositeOrdering = \case + LT -> GT + EQ -> EQ + GT -> LT diff --git a/source/Felix/Test/Unit/Backend.hs b/source/Felix/Test/Unit/Backend.hs new file mode 100644 index 0000000..384d21b --- /dev/null +++ b/source/Felix/Test/Unit/Backend.hs @@ -0,0 +1,752 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Backend (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Backend.Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Provers +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Test.Tasty +import Test.Tasty.HUnit + + +data TestGlobal + = FirstOrderPredicate + | HigherOrderPredicate + deriving (Show, Eq, Ord) + +testGlobalType :: TestGlobal -> Maybe CoreType +testGlobalType = \case + FirstOrderPredicate -> + Just (TySet `TyArrow` TyProp) + HigherOrderPredicate -> + Just + ((TySet `TyArrow` TyProp) + `TyArrow` TyProp) + +data TestLocal + = ObjectLocal + | PredicateLocal + deriving (Show, Eq, Ord) + +unitTests :: TestTree +unitTests = + testGroup "Typed backend problem" + [ testCase + "projects proposition equality as equivalence" + classifiesPropositionEquality + , testCase + "projects exact ambient support" + projectsExactAmbientSupport + , testCase + "routes implicit, explicit, and local-only problems" + routesCompleteProblems + , testCase + "admits only checked implicit set constructions" + admitsImplicitSetConstructions + , testCase + "renders checked FOF and TH0 problems" + rendersCheckedProblems + ] + +classifiesPropositionEquality :: Assertion +classifiesPropositionEquality = do + proposition <- + checkedProposition + Vector.empty + (CEq TyProp CFalsum CFalsum) + capability <- + either + (assertFailure . show) + pure + (classifySupportedProposition + testGlobalType + proposition) + case capability of + FofProjectable{} -> + pure () + RequiresTh0 exclusions -> + assertFailure + ("proposition equality was not projected: " + <> show exclusions) + +projectsExactAmbientSupport :: Assertion +projectsExactAmbientSupport = do + let term :: CanonicalTerm Void + term = + CForall TySet + (CEq TySet + (CBound 1) + (CBound 3)) + scoped <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + (const Nothing) + [TySet, TySet, TySet] + term) + projected <- + either + (assertFailure . show) + pure + (projectSupportedProposition + (const Nothing) + (Vector.fromList + [ (0 :: Int, TySet) + , (1, TySet) + , (2, TySet) + ]) + scoped) + assertEqual + "unused middle support is removed" + (Vector.fromList + [ (0 :: Int, TySet) + , (2, TySet) + ]) + (supportedPropositionSupport projected) + assertEqual + "indices are remapped below nested binders" + (CForall TySet + (CEq TySet + (CBound 1) + (CBound 2))) + (supportedPropositionTerm projected) + +routesCompleteProblems :: Assertion +routesCompleteProblems = do + fofFact <- + checkedBackendFact + (0 :: Int) + firstOrderClaim + th0Fact <- + checkedBackendFact + (1 :: Int) + higherOrderClaim + let fofFacts = + Vector.singleton fofFact + th0Facts = + Vector.singleton th0Fact + claim <- + checkedProposition + (Vector.singleton + (ObjectLocal, TySet)) + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0)) + firstOrderLocal <- + checkedLocalPremise + 0 + "first-order local" + claim + higherOrderLocalProposition <- + checkedProposition + (Vector.singleton + (PredicateLocal, + TySet `TyArrow` TyProp)) + (CApp + (CGlobal HigherOrderPredicate) + (CBound 0)) + higherOrderLocal <- + checkedLocalPremise + 1 + "higher-order local" + higherOrderLocalProposition + + implicit <- + planned + fofFacts + claim + [higherOrderLocal, firstOrderLocal] + [] + FirstOrderLocals + ImplicitConstructionJustification + assertEqual "implicit route" RouteFof + (typedProblemRoute implicit) + assertEqual "implicit FOF globals" [0] + (typedBackendFactReference + <$> toList + (typedProblemGlobalPremises + implicit)) + assertEqual "first-order local only" [0] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises + implicit)) + + explicitFof <- + planned + fofFacts + claim + [higherOrderLocal, firstOrderLocal] + [] + FirstOrderLocals + ExplicitHigherOrderJustification + assertEqual "explicit FOF route" RouteFof + (typedProblemRoute explicitFof) + assertEqual "explicit FOF references retain only FOF locals" [0] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises explicitFof)) + + explicitTh0 <- + planned + th0Facts + claim + [higherOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification + assertEqual "explicit TH0 route" RouteTh0 + (typedProblemRoute explicitTh0) + assertEqual "explicit TH0 references retain complete locals" [0, 1] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises explicitTh0)) + + localOnly <- + planned + Vector.empty + claim + [higherOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification + assertEqual "local-only TH0 route" RouteTh0 + (typedProblemRoute localOnly) + assertEqual "local order restored" [0, 1] + (localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList + (typedProblemLocalPremises + localOnly)) + assertEqual + "complete ambient local inventory" + (Map.fromList + [ (ObjectLocal, TySet) + , (PredicateLocal, + TySet `TyArrow` TyProp) + ]) + (typedProblemLocalTypes localOnly) + + case planTypedProblem + testGlobalType + Vector.empty + claim + [firstOrderLocal, firstOrderLocal] + [] + CompleteLocals + ExplicitHigherOrderJustification of + Left + (TypedProblemDuplicateLocalPremiseOrdinal + duplicateOrdinal) -> + assertEqual + "duplicate local ordinal" + 0 + (localPremiseOrdinalValue + duplicateOrdinal) + result -> + assertFailure + ("expected duplicate local ordinal error, got " + <> showProblemResult result) + + higherOrderClaimProposition <- + checkedProposition + Vector.empty + higherOrderClaim + case planTypedProblem + testGlobalType + fofFacts + higherOrderClaimProposition + [] + [] + FirstOrderLocals + ImplicitConstructionJustification of + Left + TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + result -> + assertFailure + ("expected explicit higher-order error, got " + <> showProblemResult result) + checkedFoundationValue <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + case planTypedProblem + testGlobalType + fofFacts + claim + [] + [typedFoundationAuxiliaryInput + checkedFoundationValue + Foundation.SeparationCharacteristic] + FirstOrderLocals + ImplicitConstructionJustification of + Left + TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + result -> + assertFailure + ("expected implicit higher-order auxiliary error, got " + <> showProblemResult result) + unusedContext <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet `TyArrow` TyProp] + firstOrderClaim) + case supportedProposition + (Vector.singleton + (PredicateLocal, + TySet `TyArrow` TyProp)) + unusedContext of + Left (UnusedSupportedLocal PredicateLocal) -> + pure () + Left err -> + assertFailure + ("unexpected exact-support error: " + <> show err) + Right _ -> + assertFailure + "unused ambient local entered exact support" + where + planned selectedFacts claim locals auxiliaries localPolicy higherOrderPolicy = + either + (assertFailure . show) + pure + (planTypedProblem + testGlobalType + selectedFacts + claim + locals + auxiliaries + localPolicy + higherOrderPolicy) + + showProblemResult = \case + Left err -> + show err + Right problem -> + show (typedProblemRoute problem) + +admitsImplicitSetConstructions :: Assertion +admitsImplicitSetConstructions = do + checkedFoundationValue <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + let separation = + CApp + (CApp + (CIntrinsic Sep) + (CIntrinsic Empty)) + (CLam TySet + (CApp + (CGlobal HigherOrderPredicate) + (CLam TySet CFalsum))) + separationClaim = + CEq TySet separation separation + filteredDomain = + CApp + (CApp + (CIntrinsic Sep) + (CBound 0)) + (CLam TySet + (CEq TySet (CBound 0) (CBound 0))) + innerReplacement = + CApp + (CApp (CIntrinsic Repl) filteredDomain) + (CLam TySet (CBound 0)) + functionalReplacement = + CApp + (CIntrinsic FamilyUnion) + (CApp + (CApp + (CIntrinsic Repl) + (CIntrinsic Empty)) + (CLam TySet innerReplacement)) + replacementClaim = + CEq TySet functionalReplacement functionalReplacement + replacementTags = + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ] + auxiliary tag = + typedFoundationAuxiliaryInput + checkedFoundationValue tag + plan selected claim locals tags = + planTypedProblem + testGlobalType + selected + claim + locals + (auxiliary <$> tags) + FirstOrderLocals + ImplicitConstructionJustification + + separationProposition <- + checkedProposition Vector.empty separationClaim + separationProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + separationProposition + [] + [Foundation.SeparationCharacteristic]) + assertEqual "separation implicit route" RouteTh0 + (typedProblemRoute separationProblem) + assertEqual "separation characteristic only" + [Foundation.SeparationCharacteristic] + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries separationProblem)) + assertEqual "separation selects no global premise" + 0 + (Vector.length (typedProblemGlobalPremises separationProblem)) + + replacementProposition <- + checkedProposition Vector.empty replacementClaim + replacementProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + replacementProposition + [] + replacementTags) + assertEqual "functional replacement implicit route" RouteTh0 + (typedProblemRoute replacementProblem) + assertEqual "functional replacement exact helper set" + replacementTags + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries replacementProblem)) + + firstOrderProposition <- + checkedProposition Vector.empty firstOrderClaim + firstOrderLocal <- + checkedLocalPremise 0 "first-order" firstOrderProposition + separationLocal <- + checkedLocalPremise 2 "separation" separationProposition + unrelatedLocalProposition <- + checkedProposition + (Vector.singleton + (PredicateLocal, TySet `TyArrow` TyProp)) + (CApp + (CGlobal HigherOrderPredicate) + (CBound 0)) + unrelatedLocal <- + checkedLocalPremise 1 "unrelated higher-order" unrelatedLocalProposition + separationWithLocals <- + either + (assertFailure . show) + pure + (plan + Vector.empty + separationProposition + [unrelatedLocal, firstOrderLocal] + [Foundation.SeparationCharacteristic]) + assertEqual "inline separation keeps unrelated HO local out" RouteTh0 + (typedProblemRoute separationWithLocals) + assertEqual "inline separation retains only FOF local" [0] + ( localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList (typedProblemLocalPremises separationWithLocals) + ) + assertEqual "excluded HO local adds no auxiliary" + [Foundation.SeparationCharacteristic] + (typedProblemAuxiliaryTag + <$> toList (typedProblemAuxiliaries separationWithLocals)) + localProblem <- + either + (assertFailure . show) + pure + (plan + Vector.empty + firstOrderProposition + [unrelatedLocal, separationLocal, firstOrderLocal] + []) + assertEqual "implicit construction local remains excluded" RouteFof + (typedProblemRoute localProblem) + assertEqual "unrelated higher-order local remains unselected" + [0] + ( localPremiseOrdinalValue + . typedLocalPremiseOrdinal + <$> toList (typedProblemLocalPremises localProblem) + ) + + higherOrderFact <- checkedBackendFact (1 :: Int) higherOrderClaim + expectImplicitHigherOrderRejection + "implicit higher-order global remains forbidden" + (plan + (Vector.singleton higherOrderFact) + separationProposition + [] + [Foundation.SeparationCharacteristic]) + + ordinaryHigherOrder <- + checkedProposition Vector.empty + (CEq TySet + (CApp + (CIntrinsic SetChoose) + (CLam TySet CFalsum)) + (CIntrinsic Empty)) + expectImplicitHigherOrderRejection + "ordinary implicit higher-order target remains forbidden" + (plan Vector.empty ordinaryHigherOrder [] []) + mixedHigherOrder <- + checkedProposition Vector.empty + (CImp + separationClaim + (supportedPropositionTerm ordinaryHigherOrder)) + expectImplicitHigherOrderRejection + "construction does not admit another higher-order intrinsic" + (plan + Vector.empty + mixedHigherOrder + [] + [Foundation.SeparationCharacteristic]) + + expectImplicitHigherOrderRejection + "auxiliary tag alone grants no construction permission" + (plan + Vector.empty + firstOrderProposition + [] + [Foundation.SeparationCharacteristic]) + where + expectImplicitHigherOrderRejection label = \case + Left TypedProblemExplicitHigherOrderJustificationRequired{} -> + pure () + Left err -> + assertFailure (label <> ": unexpected error " <> show err) + Right problem -> + assertFailure + (label <> ": unexpectedly routed " + <> show (typedProblemRoute problem)) + +rendersCheckedProblems :: Assertion +rendersCheckedProblems = do + fofFact <- + checkedBackendFact + (0 :: Int) + firstOrderClaim + th0Fact <- + checkedBackendFact + (1 :: Int) + higherOrderClaim + claim <- + checkedProposition + (Vector.singleton + (ObjectLocal, TySet)) + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0)) + fofProblem <- + planned + (Vector.singleton fofFact) + claim + FirstOrderLocals + ImplicitConstructionJustification + th0Problem <- + planned + (Vector.singleton th0Fact) + claim + CompleteLocals + ExplicitHigherOrderJustification + preparedFof <- + either + (assertFailure . show) + pure + (prepareTypedTptpProblem + fofProblem) + preparedTh0 <- + either + (assertFailure . show) + pure + (prepareTypedTptpProblem + th0Problem) + proverTask <- + either + (assertFailure . show) + pure + (prepareTypedProverTask + DirectTask + th0Problem) + assertEqual "FOF route" RouteFof + (preparedTypedTptpRoute preparedFof) + assertBool "FOF formulas" + ("fof(tg_h0,axiom," + `Text.isInfixOf` + preparedTypedTptpText + preparedFof) + assertBool "FOF has no TH0 declarations" + (not + ("thf(" + `Text.isInfixOf` + preparedTypedTptpText + preparedFof)) + assertEqual "TH0 route" RouteTh0 + (preparedTypedTptpRoute preparedTh0) + assertEqual "TH0 request dialect" + VerificationTh0 + (preparedVerificationDialect + (preparedTypedProverRequest + proverTask)) + assertEqual "request preserves exact prepared text" + (preparedTypedTptpText preparedTh0) + (preparedVerificationText + (preparedTypedProverRequest + proverTask)) + for_ + [ "thf(tg_h0,axiom," + , "^ [V0:$i]" + , "thf(tg_q0,conjecture," + ] + \fragment -> + assertBool + ("TH0 contains " <> Text.unpack fragment) + (fragment + `Text.isInfixOf` + preparedTypedTptpText + preparedTh0) + for_ + (Map.keys + (preparedTypedTptpNameOrigins + preparedTh0)) + \target -> + assertBool + ("valid generated name " <> Text.unpack target) + (if "V" `Text.isPrefixOf` target + then Tptp.isProperVariable target + else Tptp.isProperAtomicWord target) + where + planned selectedFacts claim localPolicy higherOrderPolicy = + either + (assertFailure . show) + pure + (planTypedProblem + testGlobalType + selectedFacts + claim + [] + [] + localPolicy + higherOrderPolicy) + +firstOrderClaim :: CanonicalTerm TestGlobal +firstOrderClaim = + CApp + (CGlobal FirstOrderPredicate) + (CIntrinsic Empty) + +higherOrderClaim :: CanonicalTerm TestGlobal +higherOrderClaim = + CApp + (CGlobal HigherOrderPredicate) + (CLam TySet + (CApp + (CGlobal FirstOrderPredicate) + (CBound 0))) + +checkedProposition + :: Vector (TestLocal, CoreType) + -> CanonicalTerm TestGlobal + -> IO + (SupportedProposition + TestLocal + TestGlobal) +checkedProposition support term = do + checked <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + (snd <$> Vector.toList support) + term) + either + (assertFailure . show) + pure + (supportedProposition support checked) + +checkedClosedProposition + :: CanonicalTerm TestGlobal + -> IO + (SupportedProposition + Void + TestGlobal) +checkedClosedProposition term = do + checked <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + term) + either + (assertFailure . show) + pure + (supportedProposition + Vector.empty + checked) + +checkedBackendFact + :: ref + -> CanonicalTerm TestGlobal + -> IO (TypedBackendFact ref TestGlobal) +checkedBackendFact reference term = do + proposition <- + checkedClosedProposition term + capability <- + either + (assertFailure . show) + pure + (classifySupportedProposition + testGlobalType + proposition) + pure + (typedBackendFact + reference + proposition + capability) + +checkedLocalPremise + :: Natural + -> Text + -> SupportedProposition TestLocal TestGlobal + -> IO + (TypedLocalPremise + TestLocal + Text + TestGlobal) +checkedLocalPremise ordinal premiseOrigin proposition = + either + (assertFailure . show) + pure + (typedLocalPremise + testGlobalType + (localPremiseOrdinal ordinal) + premiseOrigin + proposition) diff --git a/source/Felix/Test/Unit/CommandLine.hs b/source/Felix/Test/Unit/CommandLine.hs new file mode 100644 index 0000000..f2a4a10 --- /dev/null +++ b/source/Felix/Test/Unit/CommandLine.hs @@ -0,0 +1,799 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.CommandLine (unitTests) where + +import Base +import Felix.CommandLine +import Felix.Output.Atomic qualified as Atomic +import Felix.Source (safeRelativePath) +import Felix.Store qualified as Store +import Felix.Verification qualified as Verification +import Felix.Provers qualified as Provers +import Felix.Render.Html.Output qualified as HtmlOutput +import Felix.Report.Location (pattern Nowhere) + +import Control.Exception (IOException, bracket) +import Control.Exception qualified as Exception +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Options.Applicative (ParserResult(..)) +import Options.Applicative qualified as Options +import System.Directory qualified as Directory +import System.Environment (getEnvironment) +import System.Exit (ExitCode(..)) +import System.FilePath.Posix ((</>)) +import System.Process + ( CreateProcess(..) + , proc + , readCreateProcessWithExitCode + ) +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = + testGroup "Command line" + [ testCase "parses the closed command model" + parsesClosedCommands + , testCase "rejects conflicting command options" + rejectsConflictingOptions + , testCase "maps structured outcomes to process status" do + for_ outcomeCases \(outcome, expectedExitCode) -> + commandOutcomeExitCode outcome + `shouldBe` expectedExitCode + , testCase "reports the committed HTML prefix" + reportsCommittedHtmlPrefix + , testCase "removes an unpublished dump temporary" + removesFailedDumpTemporary + , testGroup "process boundary" + [ testCase "version needs no input or store" + versionNeedsNoInputOrStore + , testCase "parse-only uses no store or Vampire" + parseOnlyUsesNoAuthority + , testCase "malformed source has a stable failure class" + malformedSourceHasStableFailure + , testCase "invalid output needs no source pass or store startup" + invalidOutputPrecedesStoreStartup + , testCase "nested HTML routes fail before store startup" + nestedHtmlRoutesPrecedeStoreStartup + , testCase "verified theorem exits successfully" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for cli'" + , "exit 0" + ] + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` "Verification successful." + , testCase "omitted proof reports a located explicit gap" do + (exitCode, stdout, stderr) <- + runCliWithSourceAndConfiguredVampire + cliGapSource + writeNonExecutableFile + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` + "Verification completed with explicit proof gaps." + stderr `shouldContain` "1 explicit proof gap" + stderr `shouldContain` "input.tex 5:5" + , testCase "countermodel exits as verification rejection" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + , "exit 0" + ] + exitCode `shouldBe` ExitFailure 1 + stdout `shouldBe` "" + stderr `shouldContain` + "Verification failed: prover found countermodel" + , testCase "failed prover exits as infrastructure failure" do + (exitCode, stdout, stderr) <- runCliWithFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for cli'" + , "exit 7" + ] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` + "UnsuccessfulVampireExit (ExitFailure 7)" + , testCase "prover launch failure exits as infrastructure failure" do + (exitCode, stdout, stderr) <- + runCliWithConfiguredVampire writeNonExecutableFile + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "ProverLaunchFailed" + , testCase "dumps the exact executed request once" + dumpsExactExecutedRequest + , testCase "launch failure dumps no request" + launchFailureDumpsNoRequest + , testCase "failed verification retains its executed dump subset" + dumpsOnlyExecutedPrefix + , testCase "dump and HTML share one verification" + dumpAndHtmlVerifyOnce + , testCase "semantic failure publishes no HTML" + semanticFailurePublishesNoHtml + , testCase "fresh and cached presentation publish equal HTML" + freshAndCachedPresentationAgree + , testCase "missing renderer data is a typed failure" + missingRendererDataIsTyped + , testCase + "post-verification HTML failure retains authorization report" + htmlFailureRetainsAuthorizationReport + ] + ] + +parsesClosedCommands :: Assertion +parsesClosedCommands = do + case parseCommandArguments ["--version"] of + Success Version -> + pure () + other -> + assertFailure + ("unexpected version parse: " <> showParserResult other) + case parseCommandArguments ["input.tex", "--parseonly"] of + Success (ParseOnly (Input "input.tex")) -> + pure () + other -> + assertFailure + ("unexpected parse-only parse: " <> showParserResult other) + case parseCommandArguments ["input.tex"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationStoreSelection = + Store.DefaultStore + }) -> + pure () + other -> + assertFailure + ("unexpected default verify parse: " + <> showParserResult other) + case parseCommandArguments ["input.tex", "--jobs", "3"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationJobsOverride = Just jobs + }) -> + Provers.effectiveJobsValue jobs `shouldBe` 3 + other -> + assertFailure + ("unexpected jobs parse: " <> showParserResult other) + case parseCommandArguments ["input.tex", "--fresh"] of + Success + (Verify + (Input "input.tex") + VerificationOptions + { verificationStoreSelection = + Store.FreshTemporaryStore + }) -> + pure () + other -> + assertFailure + ("unexpected verify parse: " <> showParserResult other) + +rejectsConflictingOptions :: Assertion +rejectsConflictingOptions = do + for_ + [ ["input.tex", "--parseonly", "--fresh"] + , ["input.tex", "--parseonly", "--jobs", "2"] + , ["input.tex", "--parseonly", "--dump", "dump"] + , ["input.tex", "--parseonly", "--html"] + , ["input.tex", "--store", "store.sqlite", "--fresh"] + ] + \arguments -> + case parseCommandArguments arguments of + Failure _failure -> + pure () + other -> + assertFailure + ("conflicting options were accepted: " + <> show arguments + <> " as " + <> showParserResult other) + case parseCommandArguments ["input.tex", "--jobs", "0"] of + Failure _failure -> pure () + other -> + assertFailure + ("non-positive jobs were accepted as " + <> showParserResult other) + +showParserResult :: ParserResult Command -> String +showParserResult = \case + Success selected -> + show selected + Failure failure -> + fst (Options.renderFailure failure "felix") + CompletionInvoked _completion -> + "completion invoked" + +versionNeedsNoInputOrStore :: Assertion +versionNeedsNoInputOrStore = + withCliFixture cliSource \fixture -> do + (exitCode, stdout, stderr) <- + runCliFixture fixture ["--version"] + exitCode `shouldBe` ExitSuccess + stdout `shouldContain` "Version 0.3.0.0" + stderr `shouldBe` "" + assertNoDefaultStore fixture + +parseOnlyUsesNoAuthority :: Assertion +parseOnlyUsesNoAuthority = + withCliFixture cliPreludeSyntaxSource \fixture -> do + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, stdout, stderr) <- + runCliFixture + fixture + ["input.tex", "--parseonly"] + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldBe` "" + assertNoDefaultStore fixture + +malformedSourceHasStableFailure :: Assertion +malformedSourceHasStableFailure = + withCliFixture malformedCliSource \fixture -> do + (exitCode, stdout, stderr) <- + runCliFixture + fixture + ["input.tex", "--parseonly"] + exitCode `shouldBe` ExitFailure 1 + stdout `shouldBe` "" + stderr `shouldContain` "Parsing failed: project:input.tex" + stderr `shouldContain` "input.tex 2:5" + stderr `shouldContain` "unconsumed word" + assertBool "does not print an internal error constructor" + (not ("SourceParseError" `List.isInfixOf` stderr)) + assertNoDefaultStore fixture + +invalidOutputPrecedesStoreStartup :: Assertion +invalidOutputPrecedesStoreStartup = + withCliFixture cliSource \fixture -> do + let dump = cliFixtureRoot fixture </> "dump" + Directory.removeFile + (cliFixtureRoot fixture </> "input.tex") + Directory.createDirectory dump + writeFile (dump </> "stale.p") "stale" + (exitCode, stdout, stderr) <- + runCliFixture fixture + ["input.tex", "--dump", "dump"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "Verification output preflight failed:" + stderr `shouldContain` (Text.pack (show dump)) + stderr `shouldContain` "choose an absent or empty directory" + stderr `shouldContain` "stale.p" + assertNoDefaultStore fixture + +reportsCommittedHtmlPrefix :: Assertion +reportsCommittedHtmlPrefix = do + first <- checkedRelative "a.html" + second <- checkedRelative "nested/b.html" + failed <- checkedRelative "nested/c.html" + assertEqual + "deterministic committed prefix" + [ "HTML publication failed at \"nested/c.html\": disk full" + , "HTML files published before the failure: \"a.html\", \"nested/b.html\"" + ] + (HtmlOutput.renderHtmlPublicationError + (HtmlOutput.IncompleteHtmlPublication + [first, second] + failed + "disk full")) + where + checkedRelative path = + case safeRelativePath path of + Left problem -> + assertFailure + ("invalid test route " <> show path <> ": " <> show problem) + >> fail "unreachable" + Right relative -> + pure relative + +nestedHtmlRoutesPrecedeStoreStartup :: Assertion +nestedHtmlRoutesPrecedeStoreStartup = + withCliFixture nestedHtmlRootSource \fixture -> do + let root = cliFixtureRoot fixture + nested = root </> "a.html" + Directory.createDirectory nested + writeFile (root </> "a.tex") cliSource + writeFile (nested </> "b.tex") cliSource + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "HTML route planning failed:" + stderr `shouldContain` "\"a.html\"" + stderr `shouldContain` "\"a.html/b.html\"" + assertNoDefaultStore fixture + +removesFailedDumpTemporary :: Assertion +removesFailedDumpTemporary = + withTemporaryDirectory "felix-dump-atomic" \root -> do + let destination = root </> "1.p" + Directory.createDirectory destination + result <- Exception.try + (Atomic.writeBytesAtomically + destination + (TextEncoding.encodeUtf8 "complete request")) + :: IO (Either IOException ()) + case result of + Left _failure -> + pure () + Right () -> + assertFailure "dump publication unexpectedly succeeded" + contents <- List.sort <$> Directory.listDirectory root + assertEqual + "only the pre-existing final target remains" + ["1.p"] + contents + +dumpsExactExecutedRequest :: Assertion +dumpsExactExecutedRequest = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + let captured = cliFixtureRoot fixture </> "captured.p" + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat > " <> show captured + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitSuccess + stderr `shouldContain` "Verification successful." + dumped <- ByteString.readFile + (cliFixtureRoot fixture </> "dump" </> "1-1.p") + sent <- ByteString.readFile captured + assertEqual "dump is the exact process input" sent dumped + assertBool "request is dumped only once" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture </> "dump" </> "1-2.p") + +launchFailureDumpsNoRequest :: Assertion +launchFailureDumpsNoRequest = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitFailure 2 + stderr `shouldContain` "ProverLaunchFailed" + assertBool "no request was dumped before process launch" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture </> "dump" </> "1-1.p") + +dumpsOnlyExecutedPrefix :: Assertion +dumpsOnlyExecutedPrefix = + withCliFixture cliTwoSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + ] + exitCode `shouldBe` ExitFailure 1 + stderr `shouldContain` "prover found countermodel" + assertBool "executed request was dumped" + =<< Directory.doesFileExist + (cliFixtureRoot fixture </> "dump" </> "1-1.p") + -- Prospective execution may start a source-later request before the + -- admission cursor observes this first rejection. Dump ownership is + -- therefore the actual executed subset, not a semantic prefix. + +dumpAndHtmlVerifyOnce :: Assertion +dumpAndHtmlVerifyOnce = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + let countPath = cliFixtureRoot fixture </> "vampire-runs" + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' run >> " <> show countPath + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + , "--html" + ] + exitCode `shouldBe` ExitSuccess + stderr `shouldContain` "Verification successful." + runs <- List.lines <$> readFile countPath + assertEqual "one semantic verification" ["run"] runs + assertBool "request dump was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture </> "dump" </> "1-1.p") + assertBool "root HTML page was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture </> "html" </> "input.html") + assertBool "HTML support asset was published" + =<< Directory.doesFileExist + (cliFixtureRoot fixture + </> "html" + </> "_static" + </> "naproche-html.js") + +semanticFailurePublishesNoHtml :: Assertion +semanticFailurePublishesNoHtml = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for cli'" + ] + (exitCode, _stdout, stderr) <- + runCliFixture fixture + [ "input.tex" + , "--dump" + , "dump" + , "--html" + ] + exitCode `shouldBe` ExitFailure 1 + stderr `shouldContain` "prover found countermodel" + assertBool "semantic failure retains the executed request dump" + =<< Directory.doesFileExist + (cliFixtureRoot fixture </> "dump" </> "1-1.p") + assertBool "semantic failure publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture </> "html") + +freshAndCachedPresentationAgree :: Assertion +freshAndCachedPresentationAgree = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (freshExit, _freshStdout, freshStderr) <- + runCliFixture fixture ["input.tex", "--html"] + freshExit `shouldBe` ExitSuccess + freshStderr `shouldContain` "Verification successful." + let htmlRoot = cliFixtureRoot fixture </> "html" + page = htmlRoot </> "input.html" + support = + htmlRoot </> "_static" </> "naproche-html.js" + freshPage <- ByteString.readFile page + freshSupport <- ByteString.readFile support + Directory.removePathForcibly htmlRoot + writeNonExecutableFile (cliFixtureVampire fixture) + (warmExit, _warmStdout, warmStderr) <- + runCliFixture fixture ["input.tex", "--html"] + warmExit `shouldBe` ExitSuccess + warmStderr `shouldContain` "Verification successful." + warmPage <- ByteString.readFile page + warmSupport <- ByteString.readFile support + assertEqual "fresh/cache-hit page bytes" freshPage warmPage + assertEqual "fresh/cache-hit support bytes" + freshSupport warmSupport + +missingRendererDataIsTyped :: Assertion +missingRendererDataIsTyped = + withCliFixture cliSource \fixture -> do + seedPackagedPreludeCache fixture + Directory.removeFile + (cliFixtureRoot fixture </> "library" </> "lexicon.tsv") + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for cli'" + ] + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` "HTML preparation failed:" + stderr `shouldContain` "renderer data \"lexicon.tsv\" was not found" + assertBool "does not expose an ErrorCall" + (not ("ErrorCall" `List.isInfixOf` stderr)) + assertBool "failed preparation publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture </> "html") + +htmlFailureRetainsAuthorizationReport :: Assertion +htmlFailureRetainsAuthorizationReport = + withCliFixture cliGapSource \fixture -> do + seedPackagedPreludeCache fixture + Directory.removeFile + (cliFixtureRoot fixture </> "library" </> "lexicon.tsv") + writeNonExecutableFile (cliFixtureVampire fixture) + (exitCode, stdout, stderr) <- + runCliFixture fixture ["input.tex", "--html"] + exitCode `shouldBe` ExitFailure 2 + stdout `shouldBe` "" + stderr `shouldContain` + "Verification succeeded, but HTML preparation failed:" + stderr `shouldContain` + "Direct source authorization summary: 0 source axioms, 1 explicit proof gap." + stderr `shouldContain` "Explicit proof gap at input.tex 5:5" + assertBool "failed output publishes no HTML" + . not + =<< Directory.doesPathExist + (cliFixtureRoot fixture </> "html") + +outcomeCases :: [(CommandOutcome, ExitCode)] +outcomeCases = + [ (CommandCompleted, ExitSuccess) + , (VerificationSucceeded emptyReport emptySlowReport, ExitSuccess) + , (VerificationCompletedWithGaps emptyReport emptySlowReport, ExitSuccess) + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.CountermodelFailure "")) + emptySlowReport + , ExitFailure 1 + ) + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.IndeterminateFailure "")) + emptySlowReport + , ExitFailure 2 + ) + , ( VerificationCheckingRejected + emptyReport + (Verification.VerificationModuleSchedulerInvariant "test") + emptySlowReport + , ExitFailure 2 + ) + ] + +emptyReport :: Verification.VerificationReport +emptyReport = + Verification.VerificationReport + { Verification.verificationDirectEscapes = [] + } + +emptySlowReport :: Provers.SlowAtpReport +emptySlowReport = Provers.SlowAtpReport 0 [] + +runCliWithFakeVampire + :: [String] + -> IO (ExitCode, String, String) +runCliWithFakeVampire scriptLines = + runCliWithConfiguredVampire \vampirePath -> do + writeExecutableScript vampirePath + (["cat >/dev/null"] <> scriptLines) + +runCliWithConfiguredVampire + :: (FilePath -> IO ()) + -> IO (ExitCode, String, String) +runCliWithConfiguredVampire = + runCliWithSourceAndConfiguredVampire cliSource + +runCliWithSourceAndConfiguredVampire + :: String + -> (FilePath -> IO ()) + -> IO (ExitCode, String, String) +runCliWithSourceAndConfiguredVampire source prepareVampire = + withCliFixture source \fixture -> do + seedPackagedPreludeCache fixture + prepareVampire (cliFixtureVampire fixture) + runCliFixture fixture ["input.tex"] + +data CliFixture = CliFixture + { cliFixtureRoot :: !FilePath + , cliFixtureExecutable :: !FilePath + , cliFixtureVampire :: !FilePath + , cliFixtureCacheRoot :: !FilePath + , cliFixtureEnvironment :: ![(String, String)] + } + +withCliFixture + :: String + -> (CliFixture -> IO value) + -> IO value +withCliFixture source action = + withTemporaryDirectory "felix-cli" \temp -> do + felixExecutable <- requireFelixExecutable + repositoryRoot <- Directory.getCurrentDirectory + let sourcePath = temp </> "input.tex" + vampirePath = temp </> "vampire" + libraryPath = temp </> "library" + debugPath = temp </> "debug" + cacheRoot = temp </> "cache" + Directory.createDirectory libraryPath + Directory.createDirectory debugPath + Directory.createDirectory cacheRoot + writeFile sourcePath source + ByteString.readFile + (repositoryRoot </> "library" </> "lexicon.tsv") + >>= ByteString.writeFile + (libraryPath </> "lexicon.tsv") + inheritedEnvironment <- getEnvironment + let processEnvironment = + setEnvironmentVariable + "XDG_CACHE_HOME" + cacheRoot + (setEnvironmentVariable + "FELIX_VAMPIRE" + vampirePath + (setEnvironmentVariable + "NAPROCHE_LIB" + libraryPath + inheritedEnvironment)) + action + CliFixture + { cliFixtureRoot = temp + , cliFixtureExecutable = felixExecutable + , cliFixtureVampire = vampirePath + , cliFixtureCacheRoot = cacheRoot + , cliFixtureEnvironment = processEnvironment + } + +runCliFixture + :: CliFixture + -> [String] + -> IO (ExitCode, String, String) +runCliFixture fixture arguments = + readCreateProcessWithExitCode + ((proc + (cliFixtureExecutable fixture) + arguments) + { cwd = Just (cliFixtureRoot fixture) + , env = Just (cliFixtureEnvironment fixture) + }) + "" + +-- | Populate only the packaged final-prelude root. Process-boundary tests +-- can then exercise the requested ordinary module outcome without making +-- their fake prover depend on the prelude's private obligation count. +seedPackagedPreludeCache :: CliFixture -> Assertion +seedPackagedPreludeCache fixture = do + let sourcePath = cliFixtureRoot fixture </> "input.tex" + original <- ByteString.readFile sourcePath + writeExecutableScript + (cliFixtureVampire fixture) + [ "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for prelude seed'" + ] + (exitCode, stdout, stderr) <- + (do + writeFile sourcePath "% cache the packaged final prelude\n" + runCliFixture fixture ["input.tex"]) + `Exception.finally` ByteString.writeFile sourcePath original + exitCode `shouldBe` ExitSuccess + stdout `shouldBe` "" + stderr `shouldContain` "Verification successful." + +assertNoDefaultStore :: CliFixture -> Assertion +assertNoDefaultStore fixture = + assertBool "default store was not created" + . not + =<< Directory.doesPathExist + (cliFixtureCacheRoot fixture </> "felix") + +writeExecutableScript :: FilePath -> [String] -> IO () +writeExecutableScript path scriptLines = do + writeFile path + (unlines (["#!/bin/sh"] <> scriptLines)) + permissions <- Directory.getPermissions path + Directory.setPermissions path + (Directory.setOwnerExecutable True permissions) + +writeNonExecutableFile :: FilePath -> IO () +writeNonExecutableFile path = do + exists <- Directory.doesPathExist path + if exists + then Directory.removeFile path + else pure () + writeFile path "not executable" + +requireFelixExecutable :: IO FilePath +requireFelixExecutable :: IO FilePath + = do + executable <- Directory.findExecutable "felix" + case executable of + Just path -> + pure path + Nothing -> do + assertFailure "felix build tool is not available on PATH" + pure "felix" + +setEnvironmentVariable + :: String + -> String + -> [(String, String)] + -> [(String, String)] +setEnvironmentVariable name value environment = + (name, value) : List.filter ((/= name) . fst) environment + +cliSource :: String +cliSource = + unlines + [ "\\begin{proposition}\\label{cli_test}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + ] + +cliPreludeSyntaxSource :: String +cliPreludeSyntaxSource = + unlines + [ "\\begin{proposition}\\label{parse_prelude_syntax}" + , " For all $x$ we have $\\preludeSuccessor{x} = \\preludeSuccessor{x}$." + , "\\end{proposition}" + ] + +cliGapSource :: String +cliGapSource = + unlines + [ "\\begin{proposition}\\label{cli_gap}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Omitted." + , "\\end{proof}" + ] + +cliTwoSource :: String +cliTwoSource = + unlines + [ "\\begin{proposition}\\label{cli_first}" + , " $\\forall x. x = x$." + , "\\end{proposition}" + , "\\begin{proposition}\\label{cli_second}" + , " $\\forall y. y = y$." + , "\\end{proposition}" + ] + +malformedCliSource :: String +malformedCliSource = + unlines + [ "\\begin{proposition}\\label{malformed}" + , " This is not a proposition." + , "\\end{proposition}" + ] + +nestedHtmlRootSource :: String +nestedHtmlRootSource = + unlines + [ "\\import{a.tex}" + , "\\import{a.html/b.tex}" + ] + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +shouldContain :: String -> Text -> Assertion +shouldContain actual expected = + assertBool + ("expected " <> show actual <> " to contain " <> show expected) + (expected `Text.isInfixOf` Text.pack actual) + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = + flip (assertEqual "") diff --git a/source/Felix/Test/Unit/Concrete.hs b/source/Felix/Test/Unit/Concrete.hs new file mode 100644 index 0000000..7eac7df --- /dev/null +++ b/source/Felix/Test/Unit/Concrete.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Concrete (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Concrete (grammar) +import Felix.Syntax.Lexicon (builtins) +import Felix.Syntax.Token (runLexer) + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.Earley (fullParses, parser) +import Text.Megaparsec (errorBundlePretty) + +unitTests :: TestTree +unitTests = + testGroup "Parser" + [ testCase + "textual connectives follow symbolic precedence" + textualConnectivePrecedence + , testCase + "transfinite induction precedes its continuation" + transfiniteInductionContinuation + ] + +data StatementShape + = Truth + | Falsity + | Connected Raw.Connective StatementShape StatementShape + | Scoped StatementShape + deriving (Show, Eq) + +textualConnectivePrecedence :: Assertion +textualConnectivePrecedence = do + for_ cases \(label, statement, expected) -> + assertEqual label (Right expected) (statementShape =<< parseStatement statement) + + assertBool + "chained iff is rejected" + (case parseStatement "$\\top$ iff $\\bot$ iff $\\top$" of + Left _ -> True + Right _ -> False) + + assertEqual + "textual and symbolic connective trees agree" + (statementShape + =<< parseStatement + "$\\top \\land \\bot \\lor \\top$") + (statementShape + =<< parseStatement + "$\\top$ and $\\bot$ or $\\top$") + where + cases = + [ ( "and binds tighter than following or" + , "$\\top$ and $\\bot$ or $\\top$" + , Connected Raw.Disjunction + (Connected Raw.Conjunction Truth Falsity) + Truth + ) + , ( "and binds tighter than preceding or" + , "$\\top$ or $\\bot$ and $\\top$" + , Connected Raw.Disjunction + Truth + (Connected Raw.Conjunction Falsity Truth) + ) + , ( "and associates left" + , "$\\top$ and $\\bot$ and $\\top$" + , Connected Raw.Conjunction + (Connected Raw.Conjunction Truth Falsity) + Truth + ) + , ( "or associates left" + , "$\\top$ or $\\bot$ or $\\top$" + , Connected Raw.Disjunction + (Connected Raw.Disjunction Truth Falsity) + Truth + ) + , ( "either is accepted after ordinary or" + , "$\\top$ or either $\\bot$ or $\\top$" + , Connected Raw.Disjunction + Truth + (Connected Raw.ExclusiveOr Falsity Truth) + ) + , ( "implication associates right" + , "if $\\top$ then if $\\bot$ then $\\top$" + , Connected Raw.Implication + Truth + (Connected Raw.Implication Falsity Truth) + ) + , ( "a quantified implication antecedent ends at then" + , "if for all $x$ we have $\\top$ then $\\bot$" + , Connected Raw.Implication + (Scoped Truth) + Falsity + ) + , ( "parentheses override precedence" + , "($\\top$ or $\\bot$) and $\\top$" + , Connected Raw.Conjunction + (Connected Raw.Disjunction Truth Falsity) + Truth + ) + , ( "a quantified right operand scopes over its continuation" + , "$\\top$ iff there exists $x$ such that $\\bot$ and $\\top$" + , Connected Raw.Equivalence + Truth + (Scoped + (Connected Raw.Conjunction Falsity Truth)) + ) + ] + +parseStatement :: Text -> Either String Raw.Stmt +parseStatement statement = do + chunks <- case runLexer + (FileId 46) + "textual-connectives.tex" + (Text.unlines + [ "\\begin{axiom}\\label{textual_connectives}" + , statement <> "." + , "\\end{axiom}" + ]) of + Left err -> + Left (errorBundlePretty err) + Right (_imports, chunks') -> + Right chunks' + tokens <- case chunks of + [tokens'] -> + Right tokens' + _ -> + Left ("expected one source chunk, got " <> show (length chunks)) + case fullParses (parser (grammar builtins)) tokens of + ( [Raw.BlockAxiom + _location + _title + _marker + (Raw.Axiom [] statement')] + , _report + ) -> + Right statement' + (blocks, report) -> + Left + ( "expected one axiom, got " + <> show blocks + <> " with " + <> show report + ) + +statementShape :: Raw.Stmt -> Either String StatementShape +statementShape = \case + Raw.StmtConnected conn _ left right -> + Connected conn + <$> statementShape left + <*> statementShape right + Raw.StmtFormula formula -> + formulaShape formula + Raw.SymbolicQuantified _ _ _ _ _ statement -> + Scoped <$> statementShape statement + statement -> + Left ("unsupported statement in precedence test: " <> show statement) + +formulaShape :: Raw.Formula -> Either String StatementShape +formulaShape = \case + Raw.PropositionalConstant _ Raw.IsTop -> + Right Truth + Raw.PropositionalConstant _ Raw.IsBottom -> + Right Falsity + Raw.Connected _ conn left right -> + Connected conn + <$> formulaShape left + <*> formulaShape right + formula -> + Left ("unsupported formula in precedence test: " <> show formula) + +transfiniteInductionContinuation :: Assertion +transfiniteInductionContinuation = + case runLexer + (FileId 45) + "transfinite-induction.tex" + sourceText of + Left err -> + assertFailure (errorBundlePretty err) + Right (_imports, [tokens]) -> + case fullParses (parser (grammar builtins)) tokens of + ( [ Raw.BlockProof + _start + (Raw.ByOrdInduction methodLocation + (Raw.Qed + (Just continuationLocation) + Raw.JustificationEmpty)) + _end + ] + , _report + ) -> do + assertEqual + "method header line" + 2 + (locLine methodLocation) + assertEqual + "continuation line" + 3 + (locLine continuationLocation) + (blocks, report) -> + assertFailure + ( "expected one transfinite-induction proof, got " + <> show blocks + <> " with " + <> show report + ) + Right (_imports, chunks) -> + assertFailure + ("expected one proof chunk, got " <> show (length chunks)) + where + sourceText = + Text.unlines + [ "\\begin{proof}" + , "[proof by transfinite induction]" + , "Trivial." + , "\\end{proof}" + ] diff --git a/source/Felix/Test/Unit/Core.hs b/source/Felix/Test/Unit/Core.hs new file mode 100644 index 0000000..0388c7f --- /dev/null +++ b/source/Felix/Test/Unit/Core.hs @@ -0,0 +1,670 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Core (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.SetConstruction + +import Control.DeepSeq (NFData(..), force) +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.Hedgehog (testPropertyNamed) + + +data TestGlobal + = TestGlobal + | TestPairGlobal + deriving (Show, Eq, Ord) + +instance NFData TestGlobal where + rnf _global = + () + +testGlobalType :: TestGlobal -> Maybe CoreType +testGlobalType TestGlobal = + Just TySet +testGlobalType TestPairGlobal = + Just (TySet `TyArrow` (TySet `TyArrow` TySet)) + +unitTests :: TestTree +unitTests = + testGroup "Checked core" + [ testCase + "freezes explicit binder positions" + freezesExplicitBinderPositions + , testCase + "freezes generalized substitution without capture" + freezesGeneralizedSubstitution + , testCase + "rejects ill-typed and open terms" + rejectsInvalidTerms + , testCase + "rechecks canonical terms without unchecked construction" + rechecksCanonicalTerms + , testCase + "checks scoped canonical weakening and substitution" + checksScopedCanonicalOperations + , testCase + "builds set-induction hypotheses from the complete property" + buildsSetInductionHypotheses + , testCase + "specializes the checked separation characteristic" + specializesCheckedSeparationCharacteristic + , testCase + "specializes the checked replacement characteristic" + specializesCheckedReplacementCharacteristic + , testCase + "derives named construction views from checked components" + derivesNamedConstructionViews + , testCase + "thaws checked closed terms without changing them" + thawsCheckedClosedTerms + , testPropertyNamed + "optimized freeze agrees with bounded reference" + "prop_freezeAgreesWithReference" + prop_freezeAgreesWithReference + ] + +freezesExplicitBinderPositions :: Assertion +freezesExplicitBinderPositions = do + let x = 0 :: Int + y = 1 :: Int + freeze body = do + checked <- + either + (assertFailure . show) + pure + (checkClosedCore + testGlobalType + (coreLambda TySet x + (coreLambda TyProp y body))) + either + (assertFailure . show) + (pure . frozenCoreTerm) + (freezeClosed checked) + nearest <- + freeze (coreLocal y) + outer <- + freeze (coreLocal x) + global <- + freeze (coreGlobal TestGlobal) + assertEqual + "nearest binder" + (CLam TySet (CLam TyProp (CBound 0))) + nearest + assertEqual + "outer binder" + (CLam TySet (CLam TyProp (CBound 1))) + outer + assertEqual + "global with both vacuous binders" + (CLam TySet (CLam TyProp (CGlobal TestGlobal))) + global + +freezesGeneralizedSubstitution :: Assertion +freezesGeneralizedSubstitution = do + let outer = 0 :: Int + inner = 1 :: Int + placeholder = 2 :: Int + innerTerm = + coreLambda TySet inner (coreLocal placeholder) + substituted = + innerTerm >>= \local -> + if local == placeholder + then coreLocal outer + else coreLocal local + term = + coreLambda TyProp outer substituted + checked <- + either + (assertFailure . show) + pure + (checkClosedCore testGlobalType term) + optimized <- + either + (assertFailure . show) + pure + (freezeClosed checked) + reference <- + either + (assertFailure . show) + pure + (referenceFreezeClosed checked) + assertEqual "reference result" reference optimized + assertEqual + "outer variable remains outside the inner binder" + (CLam TyProp (CLam TySet (CBound 1))) + (frozenCoreTerm optimized) + +rejectsInvalidTerms :: Assertion +rejectsInvalidTerms = do + assertEqual + "free local" + (Left UnboundCoreLocal) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreLocal (0 :: Int))) + assertEqual + "application argument" + (Left + (ApplicationArgumentTypeMismatch + TySet + TyProp)) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreApply + (coreIntrinsic FamilyUnion) + coreFalsum)) + assertEqual + "equality operand" + (Left + (EqualityOperandTypeMismatch + TySet + TyProp)) + (checkedCoreType + <$> checkClosedCore + testGlobalType + (coreEquality + TySet + coreFalsum + (coreGlobal TestGlobal))) + +rechecksCanonicalTerms :: Assertion +rechecksCanonicalTerms = do + let term = + CForall TySet + (CEq TySet + (CBound 0) + (CBound 0)) + assertEqual + "well-typed canonical proposition" + (Right (TyProp, term)) + ( (\checked -> + ( frozenCoreType checked + , frozenCoreTerm checked + )) + <$> checkCanonicalCore testGlobalType term + ) + assertEqual + "out-of-scope de Bruijn index" + (Left (UnboundCoreIndex 1)) + (frozenCoreType + <$> checkCanonicalCore + testGlobalType + (CForall TySet (CBound 1))) + assertEqual + "canonical application still checks argument types" + (Left + (ApplicationArgumentTypeMismatch + TySet + TyProp)) + (frozenCoreType + <$> checkCanonicalCore + testGlobalType + (CApp + (CIntrinsic FamilyUnion) + CFalsum)) + +checksScopedCanonicalOperations :: Assertion +checksScopedCanonicalOperations = do + scoped <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet] + (CBound 0)) + weakened <- + either + (assertFailure . show) + pure + (weakenScopedCore + testGlobalType + TyProp + scoped) + assertEqual + "nearest binder insertion shifts the prior local" + ( [TyProp, TySet] + , TySet + , CBound 1 + ) + ( scopedCoreContext weakened + , scopedCoreType weakened + , scopedCoreTerm weakened + ) + assertEqual + "top-level binder substitution removes its index" + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + (instantiateCanonical + (CIntrinsic Empty + :: CanonicalTerm TestGlobal) + (CEq TySet + (CBound 0) + (CBound 0))) + root <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + (CGlobal TestGlobal)) + assertEqual + "empty scoped context closes" + (Just + (TySet, CGlobal TestGlobal)) + ( (\closed -> + ( frozenCoreType closed + , frozenCoreTerm closed + )) + <$> closeScopedCore root + ) + +buildsSetInductionHypotheses :: Assertion +buildsSetInductionHypotheses = do + let propertyTerm = + CImp + (CEq TySet + (CBound 0) + (CIntrinsic Empty)) + (CEq TySet + (CBound 0) + (CBound 0)) + claimProperty <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [TySet] + propertyTerm) + (predicate, hypothesis, step, result) <- + maybe + (assertFailure "set-induction instance was not constructed") + pure + (scopedSetInductionInstance 0 claimProperty) + let abstractedProperty = + CImp + (CEq TySet + (CBound 0) + (CIntrinsic Empty)) + (CEq TySet + (CBound 0) + (CBound 0)) + memberHypothesis = + CForall TySet + (CImp + (CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + (CBound 1)) + abstractedProperty) + assertEqual + "set induction abstracts the selected property once" + (CLam TySet abstractedProperty) + (scopedCoreTerm predicate) + assertEqual + "antecedent and goal are both generalized over the member" + memberHypothesis + (scopedCoreTerm hypothesis) + assertEqual + "set-induction step owns its member-wise hypothesis" + (CForall TySet + (CImp memberHypothesis abstractedProperty)) + (scopedCoreTerm step) + assertEqual + "set-induction result closes the complete property" + (CForall TySet abstractedProperty) + (scopedCoreTerm result) + +specializesCheckedSeparationCharacteristic :: Assertion +specializesCheckedSeparationCharacteristic = do + foundation <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + let bound = CIntrinsic Empty + predicate = + CLam TySet + (CEq TySet (CBound 0) (CBound 0)) + separation = + CApp + (CApp (CIntrinsic Sep) bound) + predicate + body <- + either + (assertFailure . show) + pure + (checkScopedCanonicalCore + testGlobalType + [] + separation) + definition <- + maybe + (assertFailure "separation did not form a set definition") + pure + (scopedSetDefinition + (Foundation.foundationAxiomFrozen + foundation + Foundation.SeparationCharacteristic) + body) + let generated = + instantiateCanonical + separation + (scopedCoreTerm definition) + expected = + betaNormalize + (specializeForall predicate + (specializeForall bound + (mapCanonicalGlobals absurd + (frozenCoreTerm + (Foundation.foundationAxiomFrozen + foundation + Foundation.SeparationCharacteristic))))) + assertEqual + "local characteristic is the checked rule specialization" + expected + generated + +specializesCheckedReplacementCharacteristic :: Assertion +specializesCheckedReplacementCharacteristic = do + foundation <- + either + (assertFailure . show) + pure + Foundation.checkedFoundation + pair <- checked [] (CGlobal TestPairGlobal) + domain <- checked [] (CIntrinsic Empty) + value <- checked [TySet] (CBound 0) + (graph, checkedDomain, function) <- + maybe + (assertFailure "checked values did not form a replacement graph") + pure + (scopedReplacementGraph pair domain value) + definition <- + maybe + (assertFailure "replacement graph did not form a definition") + pure + (scopedCharacteristicDefinition + (Foundation.foundationAxiomFrozen + foundation + Foundation.ReplacementCharacteristic) + graph + (checkedDomain :| [function])) + let generated = + instantiateCanonical + (scopedCoreTerm graph) + (scopedCoreTerm definition) + expected = + betaNormalize + (specializeForall (scopedCoreTerm function) + (specializeForall (scopedCoreTerm checkedDomain) + (mapCanonicalGlobals absurd + (frozenCoreTerm + (Foundation.foundationAxiomFrozen + foundation + Foundation.ReplacementCharacteristic))))) + assertEqual + "local graph characteristic is the checked rule specialization" + expected + generated + where + checked context term = + either + (assertFailure . show) + pure + (checkScopedCanonicalCore testGlobalType context term) + +derivesNamedConstructionViews :: Assertion +derivesNamedConstructionViews = do + foundation <- + either (assertFailure . show) pure Foundation.checkedFoundation + bound <- checked [] (CIntrinsic Empty) + predicate <- checked [TySet] (CEq TySet (CBound 0) (CBound 0)) + separation <- + maybe + (assertFailure "checked separation descriptor failed") + pure + (checkedSeparationConstruction testGlobalType bound predicate) + (separationView, separationEquation) <- + maybe + (assertFailure "checked separation views failed") + pure + (namedSetConstructionLocalViews + (checkedFoundationSetConstruction foundation) + separation) + expectedSeparationView <- + maybe + (assertFailure "checked separation characteristic failed") + pure + (scopedSetDefinition + (Foundation.foundationAxiomFrozen foundation + Foundation.SeparationCharacteristic) + (namedSetConstructionTerm separation)) + assertEqual "separation view is the checked specialization" + expectedSeparationView separationView + assertEqual "separation view is first-order" + (Set.singleton Foundation.EmptyCharacteristic) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm separationView)) + assertEqual "separation equation retains exact construction" + (Set.fromList + [ Foundation.EmptyCharacteristic + , Foundation.SeparationCharacteristic + ]) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm separationEquation)) + + firstDomain <- checked [] (CIntrinsic Empty) + singleValue <- checked [TySet] (CBound 0) + singleCondition <- checked [TySet] + (CEq TySet (CBound 0) (CBound 0)) + singleReplacement <- + maybe + (assertFailure "checked one-domain replacement failed") + pure + (checkedFunctionalReplacementConstruction + testGlobalType + (firstDomain :| []) + singleValue + (Just singleCondition)) + assertEqual "one-domain replacement has one canonical term" + (CApp + (CApp + (CIntrinsic Repl) + (CApp + (CApp (CIntrinsic Sep) (CIntrinsic Empty)) + (CLam TySet + (CEq TySet (CBound 0) (CBound 0))))) + (CLam TySet (CBound 0))) + (scopedCoreTerm + (namedSetConstructionTerm singleReplacement)) + + secondDomain <- checked [TySet] (CBound 0) + value <- checked [TySet, TySet] (CBound 0) + condition <- checked [TySet, TySet] + (CEq TySet (CBound 0) (CBound 0)) + replacement <- + maybe + (assertFailure "checked replacement descriptor failed") + pure + (checkedFunctionalReplacementConstruction + testGlobalType + (firstDomain :| [secondDomain]) + value + (Just condition)) + (replacementView, replacementEquation) <- + maybe + (assertFailure "checked replacement views failed") + pure + (namedSetConstructionLocalViews + (checkedFoundationSetConstruction foundation) + replacement) + let terminal = + andP + (CEq TySet (CBound 0) (CBound 0)) + (CEq TySet (CBound 2) (CBound 0)) + secondWitness = + existsP + (andP + (memberP (CBound 0) (CBound 1)) + terminal) + firstWitness = + existsP + (andP + (memberP (CBound 0) (CIntrinsic Empty)) + secondWitness) + expectedReplacementTerm = + CForall TySet + (CEq TyProp + (memberP (CBound 0) (CBound 1)) + firstWitness) + expectedReplacementView <- checked [TySet] expectedReplacementTerm + assertEqual "replacement view preserves bounds and condition" + expectedReplacementView replacementView + assertEqual "flattened replacement view is first-order" + (Set.singleton Foundation.EmptyCharacteristic) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm replacementView)) + assertEqual "replacement equation retains every helper" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.EmptyCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies + (scopedCoreTerm replacementEquation)) + where + checked context term = + either + (assertFailure . show) + pure + (checkScopedCanonicalCore testGlobalType context term) + + memberP element set = + CApp (CApp (CIntrinsic Member) element) set + + notP proposition = CImp proposition CFalsum + + andP left right = + notP (CImp left (notP right)) + + existsP proposition = + notP (CForall TySet (notP proposition)) + +specializeForall + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +specializeForall argument = \case + CForall _binderType body -> + instantiateCanonical argument body + _ -> + error "the checked characteristic lost a binder" + +betaNormalize :: CanonicalTerm global -> CanonicalTerm global +betaNormalize = \case + CApp function argument -> + case betaNormalize function of + CLam _binderType body -> + betaNormalize + (instantiateCanonical + (betaNormalize argument) + body) + normalizedFunction -> + CApp normalizedFunction (betaNormalize argument) + CLam binderType body -> + CLam binderType (betaNormalize body) + CImp premise conclusion -> + CImp + (betaNormalize premise) + (betaNormalize conclusion) + CEq operandType left right -> + CEq operandType + (betaNormalize left) + (betaNormalize right) + CForall binderType body -> + CForall binderType (betaNormalize body) + term -> term + +thawsCheckedClosedTerms :: Assertion +thawsCheckedClosedTerms = do + let source = + coreLambda TySet (0 :: Int) + (coreForall TySet 1 + (coreEquality + TySet + (coreLocal 0) + (coreLocal 1))) + freeze syntax = do + checked <- + either + (assertFailure . show) + pure + (checkClosedCore testGlobalType syntax) + either + (assertFailure . show) + pure + (freezeClosed checked) + original <- + freeze source + roundTrip <- + freeze (thawFrozenCore original) + assertEqual "frozen term" original roundTrip + assertEqual + "global inventory" + mempty + (frozenCoreGlobals original) + +prop_freezeAgreesWithReference :: Property +prop_freezeAgreesWithReference = property do + depth <- + forAll (Gen.int (Range.linear 1 10)) + binderTypes <- + forAll + (Gen.list + (Range.singleton depth) + (Gen.element + [ TyProp + , TySet + , TySet `TyArrow` TySet + ])) + selected <- + forAll + (Gen.maybe + (Gen.int (Range.linear 0 (depth - 1)))) + let binders = + zip [0 :: Int ..] binderTypes + body = + maybe + (coreGlobal TestGlobal) + coreLocal + selected + term = + foldr + (\(local, binderType) -> + coreLambda binderType local) + body + binders + checked <- + evalEither + (checkClosedCore testGlobalType term) + optimized <- + evalEither (force <$> freezeClosed checked) + reference <- + evalEither (force <$> referenceFreezeClosed checked) + optimized === reference diff --git a/source/Felix/Test/Unit/Declaration.hs b/source/Felix/Test/Unit/Declaration.hs new file mode 100644 index 0000000..f3d9be7 --- /dev/null +++ b/source/Felix/Test/Unit/Declaration.hs @@ -0,0 +1,3596 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Declaration (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Vocabulary qualified as Vocabulary +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Kernel.Derivation qualified as Kernel +import Felix.Checking.SetConstruction qualified as SetConstruction +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Math.Codec +import Felix.Module +import Felix.Source +import Felix.Store qualified as Store +import Felix.Meaning qualified as Meaning +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon + +import Data.List.NonEmpty qualified as NonEmpty +import Data.IORef qualified as IORef +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad.Except (runExceptT) +import Control.Monad.State (evalState) +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Typed declaration seam" + [ testCase "enforces staged candidate order" + enforcesStagedCandidateOrder + , testCase "retains only appended declaration prefixes" + retainsOnlyAppendedPrefixes + , testCase "makes declaration failures terminal" + makesDeclarationFailuresTerminal + , testCase "propagates unsafe authority through local claims" + propagatesUnsafeAuthorityThroughLocalClaims + , testCase "aggregates exact Vampire obligations" + aggregatesExactVampireObligations + , testCase "validates complete resolver batches before rejection" + validatesCompleteResolverBatchesBeforeRejection + , testCase "rejects retained-plan admission drift fatally" + rejectsRetainedPlanAdmissionDrift + , testCase "preserves source-axiom safety through Vampire validation" + preservesSourceAxiomSafetyThroughVampireValidation + , testCase "materializes a sealed import with fresh authority" + materializesSealedImport + , testCase "reconstructs exact imported global bindings" + reconstructsImportedGlobalBindings + , testCase "elaborates scoped exact propositions" + elaboratesScopedExactPropositions + , testCase "lowers fixed equality aliases without global support" + lowersFixedEqualityAliases + , testCase "scopes quantified proposition terms" + scopesQuantifiedPropositionTerms + , testCase "prepares exact claim envelopes" + preparesExactClaimEnvelopes + , testCase "lowers exact separation comprehensions" + lowersExactSeparationComprehensions + , testCase "lowers exact replacement telescopes" + lowersExactReplacementTelescopes + , testCase "lowers exact finite sets" + lowersExactFiniteSets + , testCase "lowers exact ordinary declarations" + lowersExactOrdinaryDeclarations + , testCase "folds transitive and diamond import evidence" + foldsTransitiveAndDiamondEvidence + , testCase "validates exact kernel construction descriptors" + validatesExactKernelConstructionDescriptors + , testCase "authorizes exact datatype compilation families" + authorizesExactDatatypeCompilationFamilies + , testCase "reuses exact compiled declaration validation" + reusesExactCompiledDeclarationValidation + , testCase "keeps fatal validation lookup failures out of declarations" + keepsFatalValidationLookupFailuresOutOfDeclarations + ] + +data FatalValidationLookup = FatalValidationLookup + deriving (Show) + +instance Exception.Exception FatalValidationLookup + +keepsFatalValidationLookupFailuresOutOfDeclarations :: Assertion +keepsFatalValidationLookupFailuresOutOfDeclarations = do + fixture <- makeFixture + prepared <- makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let lookup = proofOnlyValidationLookup + (const (Exception.throwIO FatalValidationLookup)) + action = Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "fatal-validation-lookup") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "fatal-validation-lookup") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + result <- Exception.try + (runDriverWithValidation fixture lookup action) + :: IO + (Either + FatalValidationLookup + (Declaration.DriverResult + Void + ((), Declaration.CommittedDeclarationBatch))) + case result of + Left FatalValidationLookup -> pure () + Right _ -> + assertFailure "fatal validation lookup became a driver result" + +enforcesStagedCandidateOrder :: Assertion +enforcesStagedCandidateOrder = do + fixture <- makeFixture + accepted <- runSuccessful fixture do + result <- Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "staged-success") do + first <- Declaration.reserveCandidate + (factSpec fixture "first") + later <- Declaration.reserveCandidateBatch + ( factSpec fixture "later-a" + :| [factSpec fixture "later-b"] + ) + Declaration.authorizeCompiledDeclaration do + Declaration.authorizeSourceAxiomCandidate first + traverse_ + (\candidate -> + Declaration.authorizeKernelProofCandidate + candidate do + premise <- + Declaration.useStagedCandidate first + pure + (Kernel.importedFactDerivation premise)) + later + pure result + let (_value, batch) = accepted + assertEqual + "all source-ordered candidates appended" + 3 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch))) + + provenance <- runDriver fixture (priorDeclarationUse fixture) + case provenance of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.CandidateOutsideDeclaration slot)) + prefix -> do + assertEqual + "cross-declaration staged premise" + (localFact fixture 0) + slot + assertSingleCompletedPrefix prefix + _other -> + assertFailure + "cross-declaration staged provenance was not rejected" + + traverse_ + (\(label, action, expectedPremise, expectedCandidate) -> do + result <- runDriver fixture action + case result of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.StagedPremiseNotEarlier + premiseSlot premiseStage + candidateSlot candidateStage)) + _prefix -> do + assertEqual (label <> " premise slot") + expectedPremise premiseSlot + assertEqual (label <> " candidate slot") + expectedCandidate candidateSlot + assertBool (label <> " rejected non-earlier stage") + (premiseStage >= candidateStage) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) + _prefix -> + assertFailure + (label <> ": unexpected error " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) + _prefix -> + assertFailure + (label <> ": unexpected ordinary driver failure") + Declaration.DriverSucceeded{} -> + assertFailure (label <> ": invalid staged use succeeded") + Declaration.DriverSealFailed{} -> + assertFailure (label <> ": invalid staged use reached sealing")) + [ ( "self" + , selfUse fixture + , localFact fixture 0 + , localFact fixture 0 + ) + , ( "same stage" + , sameStageUse fixture + , localFact fixture 1 + , localFact fixture 0 + ) + , ( "forward" + , forwardUse fixture + , localFact fixture 1 + , localFact fixture 0 + ) + ] + where + localFact fixture ordinal = + Semantic.factSlot + (fixtureOwner fixture) + (localFactOrdinal ordinal) + + selfUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "self") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "self") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate candidate do + premise <- Declaration.useStagedCandidate candidate + pure (Kernel.importedFactDerivation premise)) + + sameStageUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "same-stage") do + candidates <- Declaration.reserveCandidateBatch + ( factSpec fixture "same-a" + :| [factSpec fixture "same-b"] + ) + let first = NonEmpty.head candidates + second = NonEmpty.last candidates + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate first do + premise <- Declaration.useStagedCandidate second + pure (Kernel.importedFactDerivation premise)) + + forwardUse fixture = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "forward") do + first <- Declaration.reserveCandidate + (factSpec fixture "forward-a") + second <- Declaration.reserveCandidate + (factSpec fixture "forward-b") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate first do + premise <- Declaration.useStagedCandidate second + pure (Kernel.importedFactDerivation premise)) + + priorDeclarationUse fixture = do + (premise, _batch) <- Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "prior-stage") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "prior-stage") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeSourceAxiomCandidate candidate) + pure candidate + void + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "later-stage") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "later-stage") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelProofCandidate candidate do + imported <- + Declaration.useStagedCandidate premise + pure (Kernel.importedFactDerivation imported))) + +retainsOnlyAppendedPrefixes :: Assertion +retainsOnlyAppendedPrefixes = do + fixture <- makeFixture + outcome <- runDriver fixture do + (_value, _firstBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "accepted") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "accepted") + Declaration.authorizeSourceAxiomCandidate candidate + Declaration.failModuleDriver + ("later checker failure" :: Text) + case outcome of + Declaration.DriverFailed + (Declaration.DriverActionFailed reason) prefix -> do + assertEqual + "driver reports the later ordinary failure" + "later checker failure" + reason + assertSingleCompletedPrefix prefix + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed err) _prefix -> + assertFailure + ("unexpected declaration failure: " <> show err) + Declaration.DriverSucceeded{} -> + assertFailure "ordinary driver failure was lost" + Declaration.DriverSealFailed{} -> + assertFailure "ordinary driver failure became a seal failure" + +makesDeclarationFailuresTerminal :: Assertion +makesDeclarationFailuresTerminal = do + fixture <- makeFixture + outcome <- runDriver fixture do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "accepted-before-failure") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "accepted-before-failure") + Declaration.authorizeSourceAxiomCandidate candidate) + void + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "rolled-back") do + void + (Declaration.reserveCandidate + (factSpec fixture "uncommitted"))) + -- This declaration must be unreachable after the terminal failure. + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "must-not-publish") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "must-not-publish") + Declaration.authorizeSourceAxiomCandidate candidate) + case outcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DeclarationHasUnauthorizedCandidates) + prefix -> + assertSingleCompletedPrefix prefix + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected declaration failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "failed declaration was skipped" + Declaration.DriverSealFailed{} -> + assertFailure "failed declaration reached sealing" + +assertSingleCompletedPrefix + :: Declaration.PendingModulePrefix + -> Assertion +assertSingleCompletedPrefix prefix = do + let batches = + Declaration.pendingModulePrefixBatches prefix + assertEqual "one completed envelope survives" 1 (length batches) + case batches of + [batch] -> do + let expected = + Declaration.committedBatchNextPrefix batch + assertEqual + "failed declaration did not advance the prefix" + expected + (Declaration.pendingModulePrefixCurrent prefix) + assertEqual + "retained envelope ends at the exposed prefix" + expected + (Declaration.committedBatchNextPrefix batch) + _ -> pure () + +propagatesUnsafeAuthorityThroughLocalClaims :: Assertion +propagatesUnsafeAuthorityThroughLocalClaims = do + fixture <- makeFixture + result <- runSuccessful fixture do + (_sourceValue, sourceBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source") + Declaration.authorizeSourceAxiomCandidate candidate + sourceOccurrence <- requireSingleOccurrence sourceBatch + let + sourceFingerprint = + Semantic.semanticFactFingerprint sourceOccurrence + (_derivedValue, derivedBatch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "local-claim") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "derived") + Declaration.authorizeKernelProofCandidate candidate do + sourcePremise <- + Declaration.useAuthorizedFact sourceFingerprint + claim <- Declaration.proveLocalKernelClaim + (fixtureProposition fixture) + (Kernel.importedFactDerivation sourcePremise) + claimPremise <- Declaration.useLocalClaim claim + pure (Kernel.importedFactDerivation claimPremise) + pure derivedBatch + occurrence <- + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta result) of + [single] -> pure single + facts -> + assertFailure + ("unexpected fact count: " <> show (length facts)) + >> fail "unreachable" + let authority = Semantic.semanticFactAuthority occurrence + assertEqual + "local claim cannot erase source-axiom safety" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom)) + (Authority.factAuthoritySafety authority) + case Declaration.committedBatchProofValidations result of + [record] -> + assertEqual + "local support is absent from the compact direct authorization" + (Authority.CheckedSourceProof []) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected proof validation count: " + <> show (length records)) + +aggregatesExactVampireObligations :: Assertion +aggregatesExactVampireObligations = + withTemporaryDirectory "felix-declaration-vampire" \root -> do + fixture <- makeFixture + let executable = root Posix.</> "vampire" + writeAcceptedVampire executable + first <- makePreparedObligation + fixture + Foundation.EmptyCharacteristic + second <- makePreparedObligation + fixture + Foundation.PairSetCharacteristic + let exactResolver = acceptedResolver executable + freshOutcome <- + (runDriverWithResolver fixture exactResolver do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + :: IO + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch)) + (batch, freshPrefix) <- + case freshOutcome of + Declaration.DriverSucceeded value _ prefix _closure -> + pure (value, prefix) + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh Vampire fixture failed: " <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh Vampire fixture did not seal: " + <> show failure) + >> fail "unreachable" + let expectedRequests = + Provers.preparedVerificationRequestId + (Provers.preparedTypedProverRequest first) + : [Provers.preparedVerificationRequestId + (Provers.preparedTypedProverRequest second)] + case Declaration.committedBatchProofValidations batch of + [record] -> + assertEqual + "accepted requests retain source order" + (Authority.CheckedSourceProof expectedRequests) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected proof validation count: " + <> show (length records)) + + cachedRecord <- + case Declaration.committedBatchProofValidations batch of + [record] -> pure record + records -> + assertFailure + ("unexpected cached proof records: " + <> show (length records)) + >> fail "unreachable" + cachedLookupKey <- IORef.newIORef Nothing + cached <- runSuccessfulWithValidation fixture + (proofOnlyValidationLookup + (\key -> do + IORef.writeIORef cachedLookupKey (Just key) + pure (Just cachedRecord))) do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + publishedRecord <- + case Declaration.committedBatchProofValidations cached of + [record] -> pure record + records -> + assertFailure + ("unexpected cached validation records: " + <> show (length records)) + >> fail "unreachable" + assertEqual + "cached authorization preserves the exact direct proof" + (Authority.CheckedSourceProof expectedRequests) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate publishedRecord)) + assertEqual + "lookup and publication retain the same validation key" + (Semantic.proofValidationRecordKey cachedRecord) + (Semantic.proofValidationRecordKey publishedRecord) + assertEqual + "one proof syntax key governs lookup and publication" + (Just + (Semantic.proofValidationRecordKey cachedRecord)) + =<< IORef.readIORef cachedLookupKey + + missLookups <- IORef.newIORef (0 :: Int) + missRuns <- IORef.newIORef (0 :: Int) + let missLookup = proofOnlyValidationLookup \_key -> do + IORef.modifyIORef' missLookups (+ 1) + pure Nothing + missResolver = Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' missRuns (+ 1) + resolveAccepted executable prepared + miss <- runDriverWithValidationAndResolver + fixture + missLookup + missResolver + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + case miss of + Declaration.DriverSucceeded{} -> pure () + _ -> + assertFailure "warm miss failed" + assertEqual "warm miss performs one exact lookup" + 1 + =<< IORef.readIORef missLookups + assertEqual "warm miss runs every reached Vampire request" + 2 + =<< IORef.readIORef missRuns + + mismatchRuns <- IORef.newIORef (0 :: Int) + let editedSyntax = + Semantic.proofSyntaxId "edited-proof-syntax" + cachedCertificate = + Semantic.proofValidationRecordCertificate cachedRecord + corruptedKey = + Semantic.proofValidationKey + (Identity.theoremId + (Authority.factAuthorityTheorem + (Authority.validationTarget + cachedCertificate))) + editedSyntax + (Declaration.committedBatchPreviousPrefix batch) + corruptedRecord = + Semantic.proofValidationRecord + corruptedKey + cachedCertificate + mismatchResolver = Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' mismatchRuns (+ 1) + resolveAccepted executable prepared + mismatchingLookup = proofOnlyValidationLookup + (const (pure (Just corruptedRecord))) + mismatching <- Exception.try + (runDriverWithValidationAndResolver + fixture + mismatchingLookup + mismatchResolver + do + Declaration.commitProofDeclaration editedSyntax do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first)) + :: IO + (Either + Declaration.ValidationIntegrityError + (Declaration.DriverResult + Text + ((), Declaration.CommittedDeclarationBatch))) + case mismatching of + Left Declaration.CachedValidationIntegrityError{} -> + pure () + Right _ -> + assertFailure "mismatching hit did not abort as corruption" + assertEqual "mismatching hit does not fall back to Vampire" + 0 + =<< IORef.readIORef mismatchRuns + + withOpenedStore fixture root \store -> do + expectRightIO + (Store.writePendingModulePrefix store freshPrefix) + warmCalls <- IORef.newIORef (0 :: Int) + let storeLookup = proofOnlyValidationLookup \key -> do + IORef.modifyIORef' warmCalls (+ 1) + Store.loadProofValidation store key >>= expectRight + warm <- runSuccessfulWithValidation fixture + storeLookup + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "two-vampire-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "two-vampire-obligations") + Declaration.authorizeVampireCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + pure committed + assertEqual "warm lookup executes once through the store" + 1 + =<< IORef.readIORef warmCalls + assertEqual "warm path retains cached request IDs" + (Authority.CheckedSourceProof expectedRequests) + (case Declaration.committedBatchProofValidations warm of + [record] -> + Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) + records -> + error + ("unexpected warm validation records: " + <> show (length records))) + + emptyProof <- runDriver fixture do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "empty-vampire-proof") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "empty-vampire-proof") + Declaration.authorizeVampireCandidate candidate + (pure ()) + case emptyProof of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireProofHasNoAcceptedObligations) + prefix -> + assertEqual + "empty Vampire proof publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected empty-proof failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "empty Vampire proof was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "empty Vampire proof reached sealing" + + invalidClosure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId (fixtureFoundation fixture)) + []) + invalidTarget <- expectRight + (Identity.validatePropositionContent + invalidClosure + (Core.CImp Core.CFalsum Core.CFalsum)) + invalidCalls <- IORef.newIORef (0 :: Int) + let invalidResolver = + Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' invalidCalls (+ 1) + resolveAccepted executable prepared + invalid <- runDriverWithResolver fixture invalidResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "invalid-vampire-target") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + invalidTarget + Semantic.SearchEligible + [Semantic.semanticName + "invalid-vampire-target"]) + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first) + assertEqual + "invalid prepared problem does not invoke Vampire" + 0 + =<< IORef.readIORef invalidCalls + case invalid of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireTargetMismatch) + prefix -> + assertEqual + "invalid prepared problem publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected prepared-problem failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "invalid prepared problem was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "invalid prepared problem reached sealing" + + let mismatchedResolver = + Declaration.vampireResolver \_prepared -> + resolveAccepted executable second + mismatch <- runDriverWithResolver fixture mismatchedResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "mismatched-vampire-request") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "mismatched-vampire-request") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation first) + case mismatch of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.VampireRequestMismatch) + prefix -> + assertEqual + "mismatch publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected mismatch failure: " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "mismatched request was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "mismatched request reached sealing" + + unrecorded <- runDriver fixture do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "unrecorded-omission") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "unrecorded-omission") + Declaration.authorizeOmittedCandidate candidate + (pure ()) + case unrecorded of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.OmittedProofDidNotRecordUse) + prefix -> + assertEqual + "unrecorded omission publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) _prefix -> + assertFailure + ("unexpected unrecorded-omission failure: " + <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSucceeded{} -> + assertFailure "unrecorded omission was authorized" + Declaration.DriverSealFailed{} -> + assertFailure "unrecorded omission reached sealing" + + calls <- IORef.newIORef (0 :: Int) + let countingResolver = + Declaration.vampireResolver \prepared -> do + IORef.modifyIORef' calls (+ 1) + resolveAccepted executable prepared + omittedBatch <- runSuccessfulWithResolver fixture countingResolver do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "omitted-after-obligations") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "omitted-after-obligations") + Declaration.authorizeOmittedCandidate candidate do + Declaration.acceptVampireObligation first + Declaration.acceptVampireObligation second + Declaration.recordOmittedUse + pure committed + assertEqual + "omitted proof still checks preceding obligations" + 2 + =<< IORef.readIORef calls + case Declaration.committedBatchProofValidations omittedBatch of + [record] -> + assertEqual + "omitted direct authorization discards request IDs" + Authority.OmittedAuthorization + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + records -> + assertFailure + ("unexpected omitted validation count: " + <> show (length records)) + +validatesCompleteResolverBatchesBeforeRejection :: Assertion +validatesCompleteResolverBatchesBeforeRejection = + withTemporaryDirectory "felix-declaration-batch-integrity" \root -> do + fixture <- makeFixture + let executable = root Posix.</> "vampire" + firstLocation = mkLocation (FileId 76) 1 1 + secondLocation = mkLocation (FileId 76) 2 1 + writeAcceptedVampire executable + mismatchedTask <- + makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let integrityResolver = + Declaration.vampireBatchResolver \_tasks -> do + mismatched <- resolveAccepted executable mismatchedTask + pure + ( Right (Provers.CounterSatisfiable "earlier") + :| [mismatched] + ) + integrityOutcome <- + (runDriverWithResolver fixture integrityResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "batch-integrity-priority") do + candidates <- Declaration.reserveCandidateBatch + ( factSpec fixture "batch-integrity-first" + :| [factSpec fixture "batch-integrity-second"] + ) + Declaration.authorizeVampireCandidateBatch + ( ( firstLocation + , NonEmpty.head candidates + , Declaration.prepareCurrentCandidateVampire + ) + :| [ ( secondLocation + , NonEmpty.last candidates + , Declaration.prepareCurrentCandidateVampire + ) + ] + ) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + case integrityOutcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireRequestMismatch)) + prefix -> do + assertEqual + "later request mismatch retains its location" + secondLocation + location + assertEqual + "integrity failure rolls back the complete declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected batch-integrity failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure + "earlier ordinary rejection concealed no integrity failure" + Declaration.DriverSealFailed{} -> + assertFailure "invalid batch reached module sealing" + + prepared <- + makePreparedObligation + fixture + Foundation.EmptyCharacteristic + let excessResolver = + Declaration.vampireBatchResolver \_tasks -> + pure + ( Right (Provers.CounterSatisfiable "first") + :| [Right (Provers.CounterSatisfiable "excess")] + ) + excessOutcome <- + (runDriverWithResolver fixture excessResolver do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "singleton-excess-result") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "singleton-excess-result") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + case excessOutcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.VampireResolverBatchSizeMismatch 1 2)) + prefix -> + assertEqual + "malformed singleton response publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected singleton-cardinality failure: " + <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "singleton resolver ignored an excess result" + Declaration.DriverSealFailed{} -> + assertFailure "malformed singleton reached module sealing" + +rejectsRetainedPlanAdmissionDrift :: Assertion +rejectsRetainedPlanAdmissionDrift = do + fixture <- makeFixture + let checked = + Declaration.checkedProofDeclaration + (Semantic.proofSyntaxId "planned-admission-drift") + [] + [] + [] + [] + [ Declaration.checkedCandidate + (factSpec fixture "planned-admission-drift") + Declaration.checkedSourceAxiomPlanning + :| [] + ] + () + action = do + planned <- + Declaration.runProspectiveLoweringDriver + (Declaration.planCheckedDeclaration checked) + >>= either Declaration.failDeclarationDriver pure + Declaration.admitPlannedCheckedDeclaration planned + (\() stages -> + case concatMap toList stages of + [candidate] -> + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + _ -> error "planned drift fixture candidate shape") + outcome <- + Exception.try (runDriver fixture action) + :: IO + (Either + Declaration.PlanningIntegrityError + (Declaration.DriverResult + Void + Declaration.CommittedDeclarationBatch)) + case outcome of + Left (Declaration.PlanningIntegrityError diagnostic) -> + assertBool "fatal mismatch identifies prospective contract drift" + ("prospective contract" `Text.isInfixOf` diagnostic) + Right _ -> + assertFailure + "a changed admitted authority was accepted against its plan" + +preservesSourceAxiomSafetyThroughVampireValidation :: Assertion +preservesSourceAxiomSafetyThroughVampireValidation = + withTemporaryDirectory "felix-declaration-source-axiom" \root -> do + fixture <- makeFixture + let executable = root Posix.</> "vampire" + writeAcceptedVampire executable + prepared <- + makePreparedObligationWithPremise + fixture + (fixtureSourceAxiomFingerprint fixture) + freshCalls <- IORef.newIORef (0 :: Int) + let freshResolver = Declaration.vampireResolver \task -> do + IORef.modifyIORef' freshCalls (+ 1) + resolveAccepted executable task + freshOutcome <- + (runDriverWithResolver fixture freshResolver + (sourceAxiomThenVampire fixture prepared) + :: IO + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch)) + assertEqual + "fresh source-axiom theorem invokes Vampire once" + 1 + =<< IORef.readIORef freshCalls + freshBatch <- + case freshOutcome of + Declaration.DriverSucceeded batch _ _ _closure -> + pure batch + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh source-axiom driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh source-axiom driver did not seal: " + <> show failure) + >> fail "unreachable" + let freshRecord = singleProofValidation freshBatch + assertEqual + "fresh theorem retains source-axiom safety" + sourceAxiomSafety + (Authority.factAuthoritySafety + (Authority.validationTarget + (Semantic.proofValidationRecordCertificate freshRecord))) + separationCalls <- IORef.newIORef (0 :: Int) + let separationResolver = Declaration.vampireResolver \task -> do + IORef.modifyIORef' separationCalls (+ 1) + resolveAccepted executable task + separated <- + (runDriverWithResolver fixture separationResolver do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom") + Declaration.authorizeSourceAxiomCandidate candidate) + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "atp-does-not-import") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "atp-does-not-import") + Declaration.authorizeKernelProofCandidate candidate do + Declaration.acceptVampireObligation prepared + pure + (Kernel.importedFactDerivation + (Kernel.importIx 0)) + :: IO + (Declaration.DriverResult Text + ((), Declaration.CommittedDeclarationBatch))) + assertEqual "mixed proof executes its ATP obligation" + 1 + =<< IORef.readIORef separationCalls + case separated of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.KernelCompletionFailed + (Kernel.KernelReplayImportOutOfBounds index))) + prefix -> do + assertEqual "ATP premise is absent from kernel imports" + (Kernel.importIx 0) + index + assertEqual "failed mixed proof retains only its prefix" + 1 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected mixed-proof failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "ATP premise entered the kernel import inventory" + Declaration.DriverSealFailed{} -> + assertFailure "mixed proof unexpectedly reached sealing" + withOpenedStore fixture root \store -> do + freshPrefix <- + case freshOutcome of + Declaration.DriverSucceeded _ _ prefix _closure -> + pure prefix + Declaration.DriverFailed failure _ -> + assertFailure + ("fresh source-axiom driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _ -> + assertFailure + ("fresh source-axiom driver did not seal: " + <> show failure) + >> fail "unreachable" + expectRightIO + (Store.writePendingModulePrefix store freshPrefix) + warmCalls <- IORef.newIORef (0 :: Int) + let storeLookup = proofOnlyValidationLookup \key -> do + IORef.modifyIORef' warmCalls (+ 1) + Store.loadProofValidation store key >>= expectRight + warmBatch <- runSuccessfulWithValidation fixture + storeLookup + (sourceAxiomThenVampire fixture prepared) + assertEqual + "warm source-axiom theorem performs one store lookup" + 1 + =<< IORef.readIORef warmCalls + assertEqual + "warm theorem retains source-axiom safety" + sourceAxiomSafety + (Authority.factAuthoritySafety + (Authority.validationTarget + (Semantic.proofValidationRecordCertificate + (singleProofValidation warmBatch)))) + where + sourceAxiomSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + + singleProofValidation batch = + case Declaration.committedBatchProofValidations batch of + [record] -> record + records -> + error + ("unexpected proof validation count: " + <> show (length records)) + +sourceAxiomThenVampire + :: Fixture + -> Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId + -> Declaration.ModuleDriver failure + Declaration.CommittedDeclarationBatch +sourceAxiomThenVampire fixture prepared = do + void + (Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom") + Declaration.authorizeSourceAxiomCandidate candidate) + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "source-axiom-vampire") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "source-axiom-vampire") + Declaration.authorizeVampireCandidate candidate + (Declaration.acceptVampireObligation prepared) + pure batch + +fixtureSourceAxiomFingerprint + :: Fixture + -> Semantic.SemanticFactOccurrenceFingerprint +fixtureSourceAxiomFingerprint fixture = + Semantic.semanticFactOccurrenceFingerprint + (Semantic.factSlot + (fixtureOwner fixture) + (localFactOrdinal 0)) + (Authority.factAuthority + (Identity.theoremRef + (Identity.theoryId (fixtureFoundation fixture)) + (Identity.checkedPropositionId + (fixtureProposition fixture))) + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom))) + +makePreparedObligationWithPremise + :: Fixture + -> Semantic.SemanticFactOccurrenceFingerprint + -> IO + (Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId) +makePreparedObligationWithPremise fixture fingerprint = do + claim <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + factProposition <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + capability <- expectRight + (Backend.classifySupportedProposition + (const Nothing) + factProposition) + problem <- expectRight + (Backend.planTypedProblem + (const Nothing) + (Vector.singleton + (Backend.typedBackendFact + fingerprint + factProposition + capability)) + claim + [] + [] + Backend.FirstOrderLocals + Backend.ExplicitHigherOrderJustification) + expectRight + (Provers.prepareTypedProverTask + Provers.DirectTask + problem) + +makePreparedObligation + :: Fixture + -> Foundation.FoundationAxiomTag + -> IO + (Provers.PreparedTypedProverTask + Semantic.SemanticFactOccurrenceFingerprint + Void + () + Identity.ObjectId) +makePreparedObligation fixture tag = do + claim <- expectRight + (Backend.supportedProposition + (Vector.empty :: Vector.Vector (Void, Core.CoreType)) + (Core.embedClosedCore + [] + (Identity.checkedPropositionTerm + (fixtureProposition fixture)))) + problem <- expectRight + (Backend.planTypedProblem + (const Nothing) + Vector.empty + claim + [] + [Backend.typedFoundationAuxiliaryInput + (fixtureFoundation fixture) + tag] + Backend.CompleteLocals + Backend.ExplicitHigherOrderJustification) + expectRight + (Provers.prepareTypedProverTask + Provers.DirectTask + problem) + +acceptedResolver :: FilePath -> Declaration.VampireResolver +acceptedResolver executable = + Declaration.vampireResolver (resolveAccepted executable) + +resolveAccepted + :: FilePath + -> Provers.PreparedTypedProverTask + ref local origin global + -> IO + (Either + Provers.ProverProcessError + Provers.ProverAnswer) +resolveAccepted executable prepared = + Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared + +writeAcceptedVampire :: FilePath -> IO () +writeAcceptedVampire executable = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for typed'" + ]) + permissions <- Directory.getPermissions executable + Directory.setPermissions executable + (Directory.setOwnerExecutable True permissions) + +validatesExactKernelConstructionDescriptors :: Assertion +validatesExactKernelConstructionDescriptors = do + fixture <- makeFixture + proposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + let declaredObject = opaqueFixtureObject fixture + run descriptor = + runDriver fixture + (Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + "kernel-construction-descriptor") do + Declaration.addDeclarationObject declaredObject + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName "kernel-construction"]) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelConstructionCandidate + descriptor + candidate + (pure + (Kernel.foundationFactDerivation + Foundation.EmptyCharacteristic)))) + success <- run + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + case success of + Declaration.DriverSucceeded (_value, batch) _interface _prefix _closure -> do + assertEqual + "new object is included in the checked declaration batch" + 1 + (length (Declaration.committedBatchObjects batch)) + case Declaration.committedBatchDeclarationValidation batch of + Just record -> + case Semantic.declarationValidationRecordCertificates + record of + [certificate] -> + assertEqual + "exact kernel descriptor is retained" + (Authority.CheckedKernelConstruction + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic)) + (Authority.validationDirectAuthorization + certificate) + certificates -> + assertFailure + ("unexpected kernel certificate count: " + <> show (length certificates)) + Nothing -> + assertFailure "missing declaration validation" + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed failure) _prefix -> + assertFailure + ("valid kernel descriptor failed: " <> show failure) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) _prefix -> + assertFailure "unexpected ordinary driver failure" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) + + traverse_ + (\(label, descriptor) -> do + outcome <- run descriptor + case outcome of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.KernelConstructionDescriptorMismatch) + prefix -> + assertEqual + (label <> " publishes no declaration") + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed other) + _prefix -> + assertFailure + (label <> ": unexpected error " <> show other) + Declaration.DriverFailed + (Declaration.DriverActionFailed _failure) + _prefix -> + assertFailure (label <> ": ordinary driver failure") + Declaration.DriverSucceeded{} -> + assertFailure (label <> ": mismatch was accepted") + Declaration.DriverSealFailed{} -> + assertFailure (label <> ": mismatch reached sealing")) + [ ( "wrong foundation leaf" + , Authority.FoundationLeaf + Foundation.PairSetCharacteristic + ) + , ( "wrong construction family" + , Authority.GuardedFoundationRules + (Authority.guardedRuleSet + (Foundation.SetLfpBound :| [])) + ) + ] + +authorizesExactDatatypeCompilationFamilies :: Assertion +authorizesExactDatatypeCompilationFamilies = do + fixture <- makeFixture + firstProposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + secondProposition <- foundationProposition + fixture + Foundation.PairSetCharacteristic + let carrier = datatypeFixtureObject fixture 0 + constructor = datatypeFixtureObject fixture 1 + carrierId = Identity.assertedObjectId carrier + constructorId = Identity.assertedObjectId constructor + references = + fmap + (Identity.theoremRef + (Identity.theoryId + (fixtureFoundation fixture)) + . Identity.checkedPropositionId) + [firstProposition, secondProposition] + descriptor = + Authority.datatypeCompilationDescriptor + carrierId + (constructorId :| []) + references + action + :: Authority.DatatypeCompilationDescriptor + -> Declaration.ModuleDriver Text + ((), Declaration.CommittedDeclarationBatch) + action suppliedDescriptor = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "datatype-compilation") do + traverse_ Declaration.addDeclarationObject + [carrier, constructor] + candidates <- + Declaration.reserveCandidateBatch + ( Declaration.candidateSpec + firstProposition + Semantic.SearchEligible + [Semantic.semanticName "datatype-first"] + :| [ Declaration.candidateSpec + secondProposition + Semantic.SearchEligible + [Semantic.semanticName "datatype-second"] + ] + ) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeDatatypeCompilationCandidates + suppliedDescriptor + carrierId + (constructorId :| []) + candidates) + + (_value, batch) <- runSuccessful fixture (action descriptor) + assertEqual "complete object family was published" + [carrier, constructor] + (Declaration.committedBatchObjects batch) + case Declaration.committedBatchDeclarationValidation batch of + Just record -> do + let certificates = + Semantic.declarationValidationRecordCertificates record + assertEqual "complete fact family was authorized" 2 + (length certificates) + traverse_ + (\certificate -> do + assertEqual "datatype authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget certificate)) + assertEqual "one descriptor protects every member" + (Authority.TrustedCompilation + (Authority.DatatypeCompilation descriptor)) + (Authority.validationDirectAuthorization certificate)) + certificates + Nothing -> + assertFailure "datatype compilation omitted validation" + + let mismatched = + Authority.datatypeCompilationDescriptor + carrierId + (constructorId :| []) + (reverse references) + rejected <- runDriver fixture (action mismatched) + case rejected of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DatatypeCompilationDescriptorMismatch) + prefix -> + assertEqual "mismatched family publishes no declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected datatype-family failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "mismatched datatype family was authorized" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("mismatched datatype family reached sealing: " + <> show failure) + +reusesExactCompiledDeclarationValidation :: Assertion +reusesExactCompiledDeclarationValidation = do + fixture <- makeFixture + proposition <- foundationProposition + fixture + Foundation.EmptyCharacteristic + let declaredObject = opaqueFixtureObject fixture + syntax = + Semantic.declarationSyntaxId + "cached-kernel-construction" + action derivationTag = + Declaration.commitCompiledDeclaration syntax do + Declaration.addDeclarationObject declaredObject + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName + "cached-kernel-construction"]) + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeKernelConstructionCandidate + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + candidate + (pure + (Kernel.foundationFactDerivation + derivationTag))) + freshBatch <- runSuccessful fixture + (snd <$> action Foundation.EmptyCharacteristic) + freshRecord <- + case Declaration.committedBatchDeclarationValidation freshBatch of + Just record -> pure record + Nothing -> + assertFailure "fresh compiled declaration omitted validation" + >> fail "unreachable" + + missLookups <- IORef.newIORef (0 :: Int) + missBatch <- runSuccessfulWithValidation fixture + (compiledOnlyValidationLookup \_key -> do + IORef.modifyIORef' missLookups (+ 1) + pure Nothing) + (snd <$> action Foundation.EmptyCharacteristic) + assertEqual "compiled warm miss performs one exact lookup" + 1 + =<< IORef.readIORef missLookups + assertBool "compiled miss publishes fresh validation" + (isJust + (Declaration.committedBatchDeclarationValidation missBatch)) + + hitLookups <- IORef.newIORef [] + hitBatch <- runSuccessfulWithValidation fixture + (compiledOnlyValidationLookup \key -> do + IORef.modifyIORef' hitLookups (key :) + pure (Just freshRecord)) + (snd <$> action Foundation.PairSetCharacteristic) + assertEqual "compiled warm hit performs one exact lookup" + [Semantic.declarationValidationRecordKey freshRecord] + . reverse + =<< IORef.readIORef hitLookups + case Declaration.committedBatchDeclarationValidation hitBatch of + Just record -> + assertEqual + "compiled hit republishes the exact validation" + freshRecord + record + Nothing -> + assertFailure "compiled hit omitted validation" + +foundationProposition + :: Fixture + -> Foundation.FoundationAxiomTag + -> IO Identity.CheckedPropositionContent +foundationProposition fixture tag = do + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId (fixtureFoundation fixture)) + []) + expectRight + (Identity.validatePropositionContent + closure + (Core.frozenCoreTerm + (Core.mapFrozenGlobals + absurd + (Foundation.foundationAxiomFrozen + (fixtureFoundation fixture) + tag)))) + +opaqueFixtureObject :: Fixture -> Identity.AssertedObject +opaqueFixtureObject fixture = + let theory = Identity.theoryId (fixtureFoundation fixture) + seed = + Identity.opaqueDeclarationSeed + (fixtureOwner fixture) + (localDeclarationOrdinal 0) + SignatureDeclaration + (generatedObjectSlot 0) + identity = + Identity.opaqueObjectId + theory + seed + Core.TySet + in Identity.assertedObject + identity + (Identity.OpaqueObjectContent + theory + seed + Core.TySet) + +datatypeFixtureObject + :: Fixture + -> Natural + -> Identity.AssertedObject +datatypeFixtureObject fixture slot = + let theory = Identity.theoryId (fixtureFoundation fixture) + seed = + Identity.opaqueDeclarationSeed + (fixtureOwner fixture) + (localDeclarationOrdinal 0) + DatatypeDeclaration + (generatedObjectSlot slot) + identity = + Identity.opaqueObjectId theory seed Core.TySet + in Identity.assertedObject + identity + (Identity.OpaqueObjectContent theory seed Core.TySet) + + +data Fixture = Fixture + { fixtureFoundation :: !Foundation.CheckedFoundation + , fixtureOwner :: !ModuleName + , fixtureProposition :: !Identity.CheckedPropositionContent + } + +makeFixture :: IO Fixture +makeFixture = + makeNamedFixture "root" + +makeNamedFixture :: Text -> IO Fixture +makeNamedFixture name = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "declaration-test-namespace" + [TextEncoding.encodeUtf8 name]) + relative <- expectRight + (safeRelativePath + (Text.unpack name <> ".tex")) + let theory = Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + closure <- expectRight + (Identity.validateObjectClosure theory []) + proposition <- expectRight + (Identity.validatePropositionContent closure Core.CFalsum) + pure + Fixture + { fixtureFoundation = foundation + , fixtureOwner = owner + , fixtureProposition = proposition + } + +factSpec :: Fixture -> Text -> Declaration.CandidateSpec +factSpec fixture alias = + Declaration.candidateSpec + (fixtureProposition fixture) + Semantic.SearchEligible + [Semantic.semanticName alias] + +runDriver + :: Fixture + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriver fixture = + runDriverWithResolver fixture unavailableVampireResolver + +runDriverWithResolver + :: Fixture + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithResolver fixture resolver action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [] + resolver + Declaration.FreshValidation + action + expectRight result + +runDriverWithValidation + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithValidation fixture lookup action = do + runDriverWithValidationAndResolver + fixture + lookup + unavailableVampireResolver + action + +runDriverWithValidationAndResolver + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithValidationAndResolver fixture lookup resolver action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [] + resolver + (Declaration.WarmValidation lookup) + action + expectRight result + +proofOnlyValidationLookup + :: (Semantic.ProofValidationKey + -> IO (Maybe Semantic.ProofValidationRecord)) + -> Declaration.ValidationLookup +proofOnlyValidationLookup lookupProof = + Declaration.validationLookup + lookupProof + (const (pure Nothing)) + +compiledOnlyValidationLookup + :: (Semantic.DeclarationValidationKey + -> IO (Maybe Semantic.DeclarationValidationRecord)) + -> Declaration.ValidationLookup +compiledOnlyValidationLookup lookupDeclaration = + Declaration.validationLookup + (const (pure Nothing)) + lookupDeclaration + +runDriverWithDirect + :: Fixture + -> [Semantic.SemanticInterfaceId] + -> Declaration.ModuleDriver failure value + -> IO (Declaration.DriverResult failure value) +runDriverWithDirect fixture direct action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + direct + unavailableVampireResolver + Declaration.FreshValidation + action + expectRight result + +unavailableVampireResolver :: Declaration.VampireResolver +unavailableVampireResolver = + Declaration.vampireResolver \_prepared -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "Vampire resolver was not expected")) + +runSuccessful + :: Fixture + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessful fixture = + runSuccessfulWithResolver fixture unavailableVampireResolver + +runSuccessfulWithResolver + :: Fixture + -> Declaration.VampireResolver + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessfulWithResolver fixture resolver action = do + outcome <- runDriverWithResolver fixture resolver action + case outcome of + Declaration.DriverSucceeded value _interface _prefix _closure -> + pure value + Declaration.DriverFailed _failure _prefix -> + assertFailure "unexpected driver failure" >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) >> fail "unreachable" + +runSuccessfulWithValidation + :: Fixture + -> Declaration.ValidationLookup + -> Declaration.ModuleDriver failure value + -> IO value +runSuccessfulWithValidation fixture lookup action = do + outcome <- runDriverWithValidation fixture lookup action + case outcome of + Declaration.DriverSucceeded value _interface _prefix _closure -> + pure value + Declaration.DriverFailed _failure _prefix -> + assertFailure "unexpected driver failure" >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure (show failure) >> fail "unreachable" + +materializesSealedImport :: Assertion +materializesSealedImport = do + fixture <- makeFixture + producer <- runDriver fixture do + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "sealed-import-producer") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "producer-fact") + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure batch + (producerInterface, evidence, fingerprint) <- + case producer of + Declaration.DriverSucceeded _ interface prefix _closure -> + let imported = + Declaration.freshImportedModuleEvidence + [] interface prefix + in case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations interface) of + [occurrence] -> + pure + ( interface + , imported + , Semantic.semanticFactFingerprint occurrence + ) + occurrences -> + assertFailure + ("unexpected producer facts: " + <> show (length occurrences)) + >> fail "unreachable" + Declaration.DriverFailed failure _prefix -> + assertFailure + ("producer failed: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("producer did not seal: " <> show failure) + >> fail "unreachable" + consumerNamespace <- expectRight + (hashCanonicalFields + "declaration-import-consumer" + ["consumer"]) + consumerPath <- expectRight (safeRelativePath "consumer.tex") + let consumerFixture = + fixture + { fixtureOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest consumerNamespace) + consumerPath + } + consumer <- runDriverWithDirect consumerFixture + [Semantic.semanticInterfaceAssertedId producerInterface] + do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "sealed-import-consumer") do + Declaration.importSealedModule evidence + candidate <- Declaration.reserveCandidate + (factSpec fixture "consumer-fact") + Declaration.authorizeOmittedCandidate candidate do + _ <- Declaration.useAuthorizedFact fingerprint + Declaration.recordOmittedUse + pure committed + case consumer of + Declaration.DriverSucceeded committed _ _ _ -> do + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta committed) of + [localOccurrence] -> do + assertEqual + "the first local fact keeps ordinal zero" + (localFactOrdinal 0) + (Semantic.factSlotOrdinal + (Semantic.semanticFactSlot localOccurrence)) + assertEqual + "the local fact belongs to the consumer" + (fixtureOwner consumerFixture) + (Semantic.factSlotModule + (Semantic.semanticFactSlot localOccurrence)) + facts -> + assertFailure + ("unexpected consumer fact count: " + <> show (length facts)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("consumer failed: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("consumer did not seal: " <> show failure) + +elaboratesScopedExactPropositions :: Assertion +elaboratesScopedExactPropositions = do + fixture <- makeNamedFixture "exact-scoped-proposition" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (x :| [y]) + Raw.Unbounded + Nothing + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar x :| []) + Raw.Positive + (Raw.Relation + Nowhere + Raw.EqSymbol + []) + (Raw.ExprVar y :| [])))) + action + :: Declaration.ModuleDriver Text + (Either + Exact.ExactCompileError + Exact.PreparedExactProposition) + action = + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactProposition + Exact.emptyExactBinderContext + statement) + outcome <- runDriver fixture action + case outcome of + Declaration.DriverSucceeded (Right prepared) _interface _prefix _closure -> + assertEqual + "source-order universal binders" + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0)))) + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Declaration.DriverSucceeded (Left failure) _interface _prefix _closure -> + assertFailure + ("scoped exact elaboration failed: " + <> Text.unpack (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("scoped exact driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("scoped exact driver did not seal: " <> show failure) + +lowersFixedEqualityAliases :: Assertion +lowersFixedEqualityAliases = do + fixture <- makeNamedFixture "fixed-equality-aliases" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + term variable = Raw.TermExpr (Raw.ExprVar variable) + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (Raw.ExprVar right :| []))) + quantified variables statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + variables + Raw.Unbounded + Nothing + statement + adjective = + Raw.Adj + Nowhere + Lexicon.builtinEqualityRightAdjective + [term y] + copular = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPAdj (adjective :| [])) + rightAttribute = + Raw.StmtNoun + (term x :| []) + (Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [ Raw.AdjR + Nowhere + Lexicon.builtinEqualityRightAdjective + [term y] + ] + Nothing) + rightAttributeExpected = + Raw.StmtNoun + (term x :| []) + (Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [] + (Just (equality x y))) + verb argument = + Raw.Verb + Nowhere + Lexicon.builtinEqualityVerb + [term argument] + singular = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerb (verb y)) + negated = + Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerbNot (verb y)) + coordinated = + Raw.StmtVerbPhrase + (term x :| [term y]) + (Raw.VPVerb (verb z)) + coordinatedExpected = + Raw.StmtConnected + Raw.Conjunction + Nothing + (equality x z) + (equality y z) + comparisons = + [ ( "copular adjective" + , quantified (x :| [y]) copular + , quantified (x :| [y]) (equality x y) + ) + , ( "right adjective" + , quantified (x :| [y]) rightAttribute + , quantified (x :| [y]) rightAttributeExpected + ) + , ( "singular verb" + , quantified (x :| [y]) singular + , quantified (x :| [y]) (equality x y) + ) + , ( "negated verb" + , quantified (x :| [y]) negated + , quantified + (x :| [y]) + (Raw.StmtNeg Nowhere (equality x y)) + ) + , ( "quantified coordinated verb" + , quantified (x :| [y, z]) coordinated + , quantified (x :| [y, z]) coordinatedExpected + ) + ] + action + :: Declaration.ModuleDriver Text + [ ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + ] + action = + Declaration.runProspectiveLoweringDriver + (traverse + (\(_label, alias, symbolic) -> + (,) + <$> Exact.prepareExactProposition + Exact.emptyExactBinderContext alias + <*> Exact.prepareExactProposition + Exact.emptyExactBinderContext symbolic) + comparisons) + runDriver fixture action >>= \case + Declaration.DriverSucceeded results _interface _prefix _closure -> + for_ (zip comparisons results) \((label, _alias, _symbolic), result) -> + case result of + (Right alias, Right symbolic) -> do + let aliasTerm = + Core.scopedCoreTerm + (Exact.preparedExactPropositionCore alias) + symbolicTerm = + Core.scopedCoreTerm + (Exact.preparedExactPropositionCore symbolic) + assertEqual + (label <> " checked core") + symbolicTerm + aliasTerm + assertEqual + (label <> " global support") + Set.empty + (Core.canonicalTermGlobals aliasTerm) + assertEqual + (label <> " foundation support") + Set.empty + (Foundation.foundationAxiomDependencies aliasTerm) + (Left failure, _) -> + assertFailure + (label <> " alias failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + (_, Left failure) -> + assertFailure + (label <> " symbolic comparison failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("fixed equality driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("fixed equality driver did not seal: " <> show failure) + + let internalEquality = + Internal.FormulaVerb + Nowhere + (Internal.EmptySet Nowhere) + Lexicon.builtinEqualityVerb + [Internal.EmptySet Nowhere] + internalResult + :: Either + Typed.TypedInductiveError + (Core.FrozenCheckedCore Void) + internalResult = + Typed.prepareTypedClosedFormula + absurd + (const Nothing) + internalEquality + case internalResult of + Right checked -> do + assertEqual + "internal fixed verb core" + (Core.CEq + Core.TySet + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty)) + (Core.frozenCoreTerm checked) + assertEqual + "internal fixed verb global support" + Set.empty + (Core.frozenCoreGlobals checked) + Left failure -> + assertFailure + ("internal fixed verb failed: " <> show failure) + +scopesQuantifiedPropositionTerms :: Assertion +scopesQuantifiedPropositionTerms = do + fixture <- makeNamedFixture "quantified-proposition-terms" + let x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + term variable = Raw.TermExpr (Raw.ExprVar variable) + zero = Raw.TermExpr (Raw.ExprInteger Nowhere 0) + setNoun = Raw.Noun Nowhere Lexicon.builtinSetNoun [] + setPhrase named = Raw.NounPhrase [] setNoun named [] Nothing + quantified quantifier variable = + Raw.TermQuantified + quantifier Nowhere (setPhrase (Just variable)) + equalityVerb argument = + Raw.Verb Nowhere Lexicon.builtinEqualityVerb [argument] + equalityAdjective argument = + Raw.Adj + Nowhere Lexicon.builtinEqualityRightAdjective [argument] + equality left right = Core.CEq Core.TySet left right + notP proposition = Core.CImp proposition Core.CFalsum + andP left right = notP (Core.CImp left (notP right)) + existsP body = notP (Core.CForall Core.TySet (notP body)) + truth = Core.CImp Core.CFalsum Core.CFalsum + member left right = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) left) + right + soleSubject = + Raw.StmtNoun + (quantified Raw.Universally x :| []) + (setPhrase Nothing) + explicitSubject = + Raw.SymbolicQuantified + Nowhere Raw.Universally (x :| []) Raw.Unbounded Nothing + (Raw.StmtNoun (term x :| []) (setPhrase Nothing)) + multipleSubjects = + Raw.StmtVerbPhrase + ( quantified Raw.Universally x + :| [quantified Raw.Existentially y] + ) + (Raw.VPVerb (equalityVerb zero)) + adjectiveArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPAdj + (equalityAdjective + (quantified Raw.Universally x) :| [])) + nounArgument = + Raw.StmtNoun + (zero :| []) + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun + [quantified Raw.Universally x]) + Nothing [] Nothing) + negatedSubject = + Raw.StmtVerbPhrase + (quantified Raw.Universally x :| []) + (Raw.VPVerbNot (equalityVerb zero)) + negatedArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPVerbNot + (equalityVerb (quantified Raw.Universally x))) + nonexistentialArgument = + Raw.StmtVerbPhrase + (zero :| []) + (Raw.VPVerb + (equalityVerb (quantified Raw.Nonexistentially x))) + negatedStatement = + Raw.StmtNeg Nowhere soleSubject + siblingConstraints = + Raw.StmtNoun + (zero :| []) + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun + [quantified Raw.Universally x]) + Nothing + [Raw.AdjR + Nowhere Lexicon.builtinEqualityRightAdjective + [quantified Raw.Universally y]] + Nothing) + constrainedSubject = + Raw.TermQuantified Raw.Universally Nowhere + (Raw.NounPhrase + [] + (Raw.Noun + Nowhere Lexicon.builtinElementNoun [term x]) + (Just x) + [Raw.AdjR + Nowhere Lexicon.builtinEqualityRightAdjective [term x]] + (Just + (Raw.StmtVerbPhrase + (term x :| []) + (Raw.VPVerb (equalityVerb (term x)))))) + constrainedStatement = + Raw.StmtVerbPhrase + (constrainedSubject :| []) + (Raw.VPVerb (equalityVerb (term x))) + xEqualsX = equality (Core.CBound 0) (Core.CBound 0) + cases = + [ ( "sole quantified subject" + , soleSubject + , Core.CForall Core.TySet truth + ) + , ( "explicit sole quantified subject" + , explicitSubject + , Core.CForall Core.TySet truth + ) + , ( "multiple quantified subjects" + , multipleSubjects + , Core.CForall Core.TySet + (existsP + (andP + (equality + (Core.CBound 1) (Core.COpaqueInteger 0)) + (equality + (Core.CBound 0) (Core.COpaqueInteger 0)))) + ) + , ( "quantified adjective argument" + , adjectiveArgument + , Core.CForall Core.TySet + (equality (Core.COpaqueInteger 0) (Core.CBound 0)) + ) + , ( "quantified noun argument" + , nounArgument + , Core.CForall Core.TySet + (member (Core.COpaqueInteger 0) (Core.CBound 0)) + ) + , ( "quantified subject outside negation" + , negatedSubject + , Core.CForall Core.TySet + (notP + (equality + (Core.CBound 0) (Core.COpaqueInteger 0))) + ) + , ( "quantified argument inside negation" + , negatedArgument + , notP + (Core.CForall Core.TySet + (equality + (Core.COpaqueInteger 0) (Core.CBound 0))) + ) + , ( "nonexistential quantified verb argument" + , nonexistentialArgument + , notP + (existsP + (equality + (Core.COpaqueInteger 0) + (Core.CBound 0))) + ) + , ( "statement recursion bounds a quantified subject" + , negatedStatement + , notP (Core.CForall Core.TySet truth) + ) + , ( "sibling constraints own their argument quantifiers" + , siblingConstraints + , andP + (Core.CForall Core.TySet + (member + (Core.COpaqueInteger 0) + (Core.CBound 0))) + (Core.CForall Core.TySet + (equality + (Core.COpaqueInteger 0) + (Core.CBound 0))) + ) + , ( "quantified noun constraints share their binder" + , constrainedStatement + , Core.CForall Core.TySet + (Core.CImp + (andP + (member (Core.CBound 0) (Core.CBound 0)) + (andP xEqualsX xEqualsX)) + xEqualsX) + ) + ] + prepare context statement = + Exact.prepareExactProposition context statement + activeContext <- expectRight + (Exact.extendExactBinderContext + ((Exact.exactLocalId 0, x) :| []) + Exact.emptyExactBinderContext) + let action + :: Declaration.ModuleDriver Text + ( [ Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ] + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + action = + Declaration.runProspectiveLoweringDriver do + compiled <- traverse + (\(_label, statement, _expected) -> + prepare Exact.emptyExactBinderContext statement) + cases + collision <- prepare activeContext soleSubject + pure (compiled, collision) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (compiled, collision) _interface _prefix _closure -> do + for_ (zip cases compiled) \ + ((label, _statement, expected), result) -> + case result of + Right prepared -> + assertEqual label expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Left failure -> + assertFailure + (label <> " failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + case collision of + Left (Exact.ExactDuplicateLocalBinder _location variable) -> + assertEqual "quantified binder collision" x variable + Left failure -> + assertFailure + ("unexpected quantified-binder collision: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Right{} -> + assertFailure "an active quantified binder was shadowed" + case compiled of + Right sole : Right explicit : _ -> + assertEqual + "sole-subject lowering remains byte-for-byte identical" + (Exact.preparedExactPropositionCore sole) + (Exact.preparedExactPropositionCore explicit) + _ -> + assertFailure + "sole-subject equality comparison did not compile" + Declaration.DriverFailed failure _prefix -> + assertFailure + ("quantified proposition-term driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("quantified proposition-term driver did not seal: " + <> show failure) + +preparesExactClaimEnvelopes :: Assertion +preparesExactClaimEnvelopes = do + fixture <- makeNamedFixture "exact-claim-envelope" + let bLocation = mkLocation (FileId 78) 2 11 + aLocation = mkLocation (FileId 78) 2 15 + xLocation = mkLocation (FileId 78) 3 9 + b = Raw.NamedVarAt bLocation "b" + a = Raw.NamedVarAt aLocation "a" + x = Raw.NamedVarAt xLocation "x" + c = Raw.NamedVarAt Nowhere "c" + d = Raw.NamedVarAt Nowhere "d" + z = Raw.NamedVarAt Nowhere "z" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (Raw.ExprVar right :| []))) + quantified variable body = + Raw.SymbolicQuantified + (locate variable) + Raw.Universally + (variable :| []) + Raw.Unbounded + Nothing + body + sourceAssumptions = [Raw.AsmSuppose (equality b a)] + sourceConclusion = quantified x (equality x b) + alphaAssumptions = [Raw.AsmSuppose (equality c d)] + alphaConclusion = quantified z (equality z c) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactClaimEnvelope + , Either + Exact.ExactCompileError + Exact.PreparedExactClaimEnvelope + ) + action = + Declaration.runProspectiveLoweringDriver do + source <- Exact.prepareExactClaimEnvelope + sourceAssumptions sourceConclusion + alpha <- Exact.prepareExactClaimEnvelope + alphaAssumptions alphaConclusion + pure (source, alpha) + expected = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0)) + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 2))))) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (Right source, Right alpha) + _interface _prefix _closure -> do + let sourceTarget = Exact.preparedExactClaimTarget source + alphaTarget = Exact.preparedExactClaimTarget alpha + assertEqual "closed claim envelope core" + expected + (Core.scopedCoreTerm sourceTarget) + assertEqual "claim envelope is closed" + [] + (Core.scopedCoreContext sourceTarget) + assertEqual "first semantic occurrence binder order" + [bLocation, aLocation] + (locate <$> Exact.preparedExactClaimVariables source) + assertEqual "explicit binders are not generalized" + 2 + (length (Exact.preparedExactClaimVariables source)) + assertEqual "header antecedent count" + 1 + (Exact.preparedExactClaimAntecedentCount source) + assertEqual "alpha-renaming preserves the checked target" + sourceTarget alphaTarget + assertEqual "alpha-renaming preserves proposition identity" + (Identity.propositionIdOf + (Core.scopedCoreTerm sourceTarget)) + (Identity.propositionIdOf + (Core.scopedCoreTerm alphaTarget)) + Declaration.DriverSucceeded result _interface _prefix _closure -> + assertFailure + ("exact claim envelope preparation failed: " + <> case result of + (Left failure, _) -> + Text.unpack + (Exact.renderExactCompileError failure) + (_, Left failure) -> + Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure ("claim envelope driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("claim envelope driver did not seal: " <> show failure) + +lowersExactSeparationComprehensions :: Assertion +lowersExactSeparationComprehensions = do + fixture <- makeNamedFixture "exact-separation-comprehension" + let binderLocation = mkLocation (FileId 73) 2 7 + ambientLocation = mkLocation (FileId 73) 2 18 + boundOccurrenceLocation = mkLocation (FileId 73) 3 14 + x = Raw.NamedVarAt binderLocation "x" + a = Raw.NamedVarAt ambientLocation "A" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + separation bound = + Raw.ExprSep + binderLocation + x + bound + (equality (Raw.ExprVar x) (Raw.ExprVar a)) + validStatement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| []) + Raw.Unbounded + Nothing + (equality + (separation (Raw.ExprVar a)) + (Raw.ExprVar a)) + boundOccurrence = + Raw.NamedVarAt boundOccurrenceLocation "x" + invalidStatement = + equality + (separation (Raw.ExprVar boundOccurrence)) + (Raw.ExprVar a) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + ) + action = + Declaration.runProspectiveLoweringDriver do + valid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + validStatement + invalid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + invalidStatement + pure (valid, invalid) + outcome <- runDriver fixture action + case outcome of + Declaration.DriverSucceeded + (Right prepared, Left failure) _interface _prefix _closure -> do + assertEqual + "separation comprehension core" + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (Core.CBound 0)) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 1)))) + (Core.CBound 0))) + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "separation proposition type" + Core.TyProp + (Core.scopedCoreType + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "the separation binder is unavailable in its bound" + (Exact.ExactFreeVariable + boundOccurrenceLocation + boundOccurrence) + failure + Declaration.DriverSucceeded result _interface _prefix _closure -> + case result of + (Left validFailure, _) -> + assertFailure + ("valid separation failed: " + <> Text.unpack + (Exact.renderExactCompileError validFailure)) + (_, Right{}) -> + assertFailure "invalid separation was accepted" + Declaration.DriverFailed failure _prefix -> + assertFailure ("separation exact driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("separation exact driver did not seal: " <> show failure) + +lowersExactReplacementTelescopes :: Assertion +lowersExactReplacementTelescopes = do + fixture <- makeNamedFixture "exact-replacement-telescope" + let location = mkLocation (FileId 74) 2 1 + futureOccurrenceLocation = mkLocation (FileId 74) 7 19 + a = Raw.NamedVarAt location "A" + x = Raw.NamedVarAt location "x" + y = Raw.NamedVarAt location "y" + futureY = Raw.NamedVarAt futureOccurrenceLocation "y" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + replacement firstDomain = + Raw.ExprReplace + location + (Raw.ExprVar y) + ( (x, firstDomain) :| + [(y, Raw.ExprVar x)] + ) + (Just (equality (Raw.ExprVar x) (Raw.ExprVar y))) + validStatement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| []) + Raw.Unbounded + Nothing + (equality + (replacement (Raw.ExprVar a)) + (Raw.ExprVar a)) + invalidStatement = + equality + (replacement (Raw.ExprVar futureY)) + (Raw.ExprInteger Nowhere 0) + predicateReplacementLocation = mkLocation (FileId 74) 9 3 + predicateReplacementStatement = + equality + (Raw.ExprReplacePred + predicateReplacementLocation + y + x + (Raw.ExprInteger Nowhere 0) + (equality (Raw.ExprVar x) (Raw.ExprVar y))) + (Raw.ExprInteger Nowhere 0) + namedPredicateReplacement = + Raw.ExprReplacePred + predicateReplacementLocation + y + x + (Raw.ExprVar a) + (equality (Raw.ExprVar x) (Raw.ExprVar y)) + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + expected = + Core.CForall Core.TySet $ + Core.CEq Core.TySet + (app1 Core.FamilyUnion $ + app2 Core.Repl (Core.CBound 0) $ + Core.CLam Core.TySet $ + app2 Core.Repl + (app2 Core.Sep + (Core.CBound 0) + (Core.CLam Core.TySet $ + Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CBound 0))) + (Core.CBound 0) + action + :: Declaration.ModuleDriver Text + ( Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactSetExpression + ) + action = + Declaration.runProspectiveLoweringDriver do + valid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + validStatement + invalid <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + invalidStatement + predicateReplacement <- Exact.prepareExactProposition + Exact.emptyExactBinderContext + predicateReplacementStatement + namedContext <- + either + (impossible + . Text.unpack + . Exact.renderExactCompileError) + pure + (Exact.extendExactBinderContext + ((Exact.exactLocalId 0, a) :| []) + Exact.emptyExactBinderContext) + named <- Exact.prepareExactSetExpression + namedContext namedPredicateReplacement + pure (valid, invalid, predicateReplacement, named) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + ( Right prepared + , Left failure + , Left predicateReplacementFailure + , Right named + ) _interface _prefix _closure -> do + assertEqual + "dependent replacement core" + expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + assertEqual + "future replacement binder location" + (Exact.ExactFreeVariable futureOccurrenceLocation futureY) + failure + assertEqual + "predicate replacement remains unsupported at its location" + (Exact.ExactRelationalReplacementRequiresNamedDefinition + predicateReplacementLocation) + predicateReplacementFailure + case Exact.preparedExactSetExpressionConstruction named of + Just (Exact.PreparedRelationalSetConstruction construction) -> do + assertEqual "relational replacement canonical term" + expectedRelationalTerm + (Core.scopedCoreTerm + (SetConstruction.relationalSetConstructionTerm + construction)) + assertEqual "relational replacement functionality" + expectedFunctionality + (Core.scopedCoreTerm + (SetConstruction.relationalSetConstructionFunctionality + construction)) + let relationalObject = + Identity.assertedObjectId + (opaqueFixtureObject fixture) + closedFunctionality = + SetConstruction.relationalSetConstructionClosedFunctionality + construction + relationalFact <- + maybe + (assertFailure + "exact functionality did not unlock relational extensionality" + >> fail "unreachable") + pure + (SetConstruction.relationalSetConstructionObjectFact + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + relationalObject + construction + closedFunctionality) + assertEqual + "relational replacement flattened extensional proposition" + (expectedRelationalExtensional relationalObject) + (Core.frozenCoreTerm + (SetConstruction.relationalSetConstructionFactProposition + relationalFact)) + assertEqual + "unrelated functionality cannot unlock the relational view" + Nothing + (SetConstruction.relationalSetConstructionLocalViews + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + construction + (Core.falsumScopedCore [Core.TySet])) + wrongClosed <- expectRight + (Core.checkCanonicalCore + (const Nothing) + Core.CFalsum) + assertBool + "malformed relational authority is rejected" + (isNothing + (SetConstruction.relationalSetConstructionObjectFact + (SetConstruction.checkedFoundationSetConstruction + (fixtureFoundation fixture)) + relationalObject + construction + wrongClosed)) + _ -> + assertFailure + "named predicate replacement lost its relational construction" + Declaration.DriverSucceeded + (Left validFailure, _, _, _) _interface _prefix _closure -> + assertFailure + ("valid replacement failed: " + <> Text.unpack + (Exact.renderExactCompileError validFailure)) + Declaration.DriverSucceeded + (_, Right{}, _, _) _interface _prefix _closure -> + assertFailure "invalid replacement was accepted" + Declaration.DriverSucceeded + (_, _, Right{}, _) _interface _prefix _closure -> + assertFailure "predicate replacement was accepted" + Declaration.DriverSucceeded + (_, _, _, Left failure) _interface _prefix _closure -> + assertFailure + ("named predicate replacement failed: " + <> Text.unpack (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("replacement driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("replacement driver did not seal: " <> show failure) + where + relApp1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + relApp2 intrinsic first second = + Core.CApp (relApp1 intrinsic first) second + notP proposition = Core.CImp proposition Core.CFalsum + andP left right = notP (Core.CImp left (notP right)) + existsP body = notP (Core.CForall Core.TySet (notP body)) + relation = Core.CEq Core.TySet (Core.CBound 1) (Core.CBound 0) + restricted = + relApp2 Core.Sep (Core.CBound 0) + (Core.CLam Core.TySet (existsP relation)) + expectedRelationalTerm = + relApp2 Core.Repl restricted + (Core.CLam Core.TySet + (relApp1 Core.SetChoose (Core.CLam Core.TySet relation))) + expectedFunctionality = + Core.CForall Core.TySet + (Core.CImp + (relApp2 Core.Member (Core.CBound 0) (Core.CBound 1)) + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (andP + (Core.CEq Core.TySet + (Core.CBound 2) (Core.CBound 1)) + (Core.CEq Core.TySet + (Core.CBound 2) (Core.CBound 0))) + (Core.CEq Core.TySet + (Core.CBound 1) (Core.CBound 0)))))) + expectedRelationalExtensional object = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TyProp + (relApp2 Core.Member + (Core.CBound 0) + (Core.CApp + (Core.CGlobal object) + (Core.CBound 1))) + (existsP + (andP + (relApp2 Core.Member + (Core.CBound 0) + (Core.CBound 2)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 1)))))) + +lowersExactFiniteSets :: Assertion +lowersExactFiniteSets = do + fixture <- makeNamedFixture "exact-finite-set" + let location = mkLocation (FileId 75) 2 1 + a = Raw.NamedVarAt location "a" + b = Raw.NamedVarAt location "b" + equality left right = + Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (left :| []) + Raw.Positive + (Raw.Relation Nowhere Raw.EqSymbol []) + (right :| []))) + statement = + Raw.SymbolicQuantified + Nowhere + Raw.Universally + (a :| [b]) + Raw.Unbounded + Nothing + (equality + (Raw.ExprFiniteSet + location + (Raw.ExprVar a :| [Raw.ExprVar b])) + (Raw.ExprVar a)) + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + insert element rest = + app1 Core.FamilyUnion + (app2 Core.PairSet + (app2 Core.PairSet element element) + rest) + expected = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CEq Core.TySet + (insert + (Core.CBound 1) + (insert + (Core.CBound 0) + (Core.CIntrinsic Core.Empty))) + (Core.CBound 1))) + action + :: Declaration.ModuleDriver Text + (Either + Exact.ExactCompileError + Exact.PreparedExactProposition) + action = + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactProposition + Exact.emptyExactBinderContext + statement) + internal <- + expectRight + (evalState + (runExceptT (Meaning.glossStmt statement)) + Meaning.initialGlossState) + reusable <- + expectRight + (Typed.prepareTypedClosedFormula + absurd + (const Nothing) + internal + :: Either + Typed.TypedInductiveError + (Core.FrozenCheckedCore Void)) + assertEqual + "raw and reusable finite-set lowering" + expected + (Core.frozenCoreTerm reusable) + let internalSymbols = Internal.mentionedSymbols internal + assertBool + "finite-set meaning has no source-owned cons dependency" + (Internal.SymbolMixfix Raw.ConsSymbol + `Set.notMember` internalSymbols) + assertBool + "finite-set meaning retains fixed adjunction operations" + ( Set.fromList + [ Internal.SymbolMixfix Raw.UnionsSymbol + , Internal.SymbolMixfix Raw.UpairSymbol + ] + `Set.isSubsetOf` internalSymbols + ) + case Vocabulary.classifyExactSymbol + (Internal.SymbolMixfix Raw.ConsSymbol) of + Vocabulary.ExactSourceGlobal{} -> pure () + classification -> + assertFailure + ("explicit cons did not retain source ownership: " + <> show classification) + runDriver fixture action >>= \case + Declaration.DriverSucceeded + (Right prepared) _interface _prefix _closure -> + assertEqual + "source-order finite-set core" + expected + (Core.scopedCoreTerm + (Exact.preparedExactPropositionCore prepared)) + Declaration.DriverSucceeded + (Left failure) _interface _prefix _closure -> + assertFailure + ("valid finite set failed: " + <> Text.unpack + (Exact.renderExactCompileError failure)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("finite-set driver failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("finite-set driver did not seal: " <> show failure) + +lowersExactOrdinaryDeclarations :: Assertion +lowersExactOrdinaryDeclarations = do + fixture <- makeNamedFixture "exact-lowering" + level <- expectRight (Syntax.mixfixLevel 2) + let makeSymbol command marker = + Raw.mkMixfixItem + [ Just (Raw.Command command) + , Just Raw.InvisibleBraceL + , Nothing + , Just Raw.InvisibleBraceR + ] + (Raw.Marker marker) + Raw.NonAssoc + opaqueSymbol = makeSymbol "phasefiveopaque" "opaque-label" + aliasSymbol = makeSymbol "phasefivealias" "alias-label" + definitionSymbol = makeSymbol "phasefivedef" "definition-label" + entry symbol = + Syntax.CanonicalExpressionFunction + (Raw.mixfixPattern symbol) + (Raw.mixfixMarker symbol) + (Syntax.Fixity Raw.NonAssoc level) + parameter = Raw.NamedVar "x" + exactSet = + Raw.NounPhrase + [] + (Raw.Noun Nowhere Lexicon.builtinSetNoun []) + Nothing + [] + Nothing + signature = + Raw.BlockSig + Nowhere Nothing (Raw.Marker "opaque-declaration") [] + (Raw.SignatureSymbolic + (Raw.SymbolPattern opaqueSymbol [parameter]) + exactSet) + application symbol = + Raw.ExprOp Nowhere symbol [Raw.ExprVar parameter] + abbreviation = + Raw.BlockAbbr + Nowhere Nothing (Raw.Marker "alias-declaration") + (Raw.AbbreviationEq + (Raw.SymbolPattern aliasSymbol [parameter]) + (application opaqueSymbol)) + definition = + Raw.BlockDefn + Nowhere Nothing (Raw.Marker "definition-declaration") + (Raw.DefnOp + (Raw.SymbolPattern definitionSymbol [parameter]) + (application aliasSymbol)) + compile block lexicalEntry = do + Declaration.runProspectiveLoweringDriver + (Exact.prepareExactDeclaration block [lexicalEntry]) >>= \case + Left failure -> + Declaration.failModuleDriver + (Exact.renderExactCompileError failure) + Right prepared -> pure prepared + admit prepared = do + lowered <- + Declaration.runProspectiveLoweringDriver + (Exact.lowerPreparedExactBinding prepared) + checked <- + either Declaration.failDeclarationDriver pure lowered + void + (Declaration.admitCheckedDeclaration + checked + Exact.authorizeCheckedExactBinding) + outcome <- runFixtureDriver fixture [] do + preparedSignature <- + compile signature (entry opaqueSymbol) + admit preparedSignature + preparedAbbreviation <- + compile abbreviation (entry aliasSymbol) + admit preparedAbbreviation + preparedDefinition <- + compile definition (entry definitionSymbol) + admit preparedDefinition + pure + ( preparedSignature + , preparedAbbreviation + , preparedDefinition + ) + case outcome of + Declaration.DriverSucceeded + (preparedSignature, preparedAbbreviation, preparedDefinition) + interface prefix _closure -> do + assertEqual "three committed declarations" + 3 + (length (Semantic.semanticInterfaceDeclarations interface)) + assertEqual "three committed batches" + 3 + (length (Declaration.pendingModulePrefixBatches prefix)) + assertEqual "opaque signature family" + Identity.OpaqueObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedSignature)) + assertEqual "transparent abbreviation family" + Identity.TransparentObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedAbbreviation)) + assertEqual "transparent definition family" + Identity.TransparentObject + (Identity.objectIdFamily + (Exact.preparedExactObjectId preparedDefinition)) + assertEqual "expanded definition coalesces with abbreviation" + (Exact.preparedExactObjectId preparedAbbreviation) + (Exact.preparedExactObjectId preparedDefinition) + case Exact.preparedExactObject preparedAbbreviation of + Just object -> + case Identity.assertedObjectContent object of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual "definition type" + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual "expanded body retains opaque seed" + (Core.CLam Core.TySet + (Core.CApp + (Core.CGlobal + (Exact.preparedExactObjectId + preparedSignature)) + (Core.CBound 0))) + body + content -> + assertFailure + ("unexpected definition content: " <> show content) + Nothing -> + assertFailure "new abbreviation object was not prepared" + assertEqual "coalesced definition adds no object" + Nothing + (Exact.preparedExactObject preparedDefinition) + case reverse (Declaration.pendingModulePrefixBatches prefix) of + definitionBatch : _ -> do + case Declaration.committedBatchDeclarationValidation + definitionBatch of + Just record -> + case Semantic.declarationValidationRecordCertificates + record of + [certificate] -> do + assertEqual "definition authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Exact.preparedExactObjectId + preparedDefinition))) + (Authority.validationDirectAuthorization + certificate) + assertEqual "definition authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget + certificate)) + certificates -> + assertFailure + ("unexpected definition certificate count: " + <> show (length certificates)) + Nothing -> + assertFailure "definition has no declaration validation" + [] -> assertFailure "definition batch is absent" + Declaration.DriverFailed failure _prefix -> + assertFailure ("exact lowering failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("exact lowering did not seal: " <> show failure) + + let theory = Identity.theoryId (fixtureFoundation fixture) + mismatchBody = Core.COpaqueInteger 0 + mismatchType = Core.TySet + mismatchId = + Identity.transparentObjectId theory mismatchType mismatchBody + mismatchObject = + Identity.assertedObject + mismatchId + (Identity.TransparentObjectContent + theory mismatchType mismatchBody) + let mismatchAction + :: Declaration.ModuleDriver Text + ((), Declaration.CommittedDeclarationBatch) + mismatchAction = + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + "mismatched-definition-equation") do + Declaration.addDeclarationObject mismatchObject + candidate <- Declaration.reserveCandidate + (factSpec fixture "not-a-definition-equation") + Declaration.authorizeCompiledDeclaration + (Declaration.authorizeDefinitionEquationCandidate + mismatchId + candidate) + mismatch <- runDriver fixture mismatchAction + case mismatch of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + Declaration.DefinitionEquationCandidateMismatch) + prefix -> + assertEqual "mismatched equation publishes no batch" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected mismatched-equation failure: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "mismatched definition equation was authorized" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("mismatched definition equation reached sealing: " + <> show failure) + +reconstructsImportedGlobalBindings :: Assertion +reconstructsImportedGlobalBindings = do + producerFixture <- makeNamedFixture "global-producer" + consumerFixture <- makeNamedFixture "global-consumer" + conflictFixture <- makeNamedFixture "global-conflict" + rootFixture <- makeNamedFixture "global-root" + let key = + Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "phasefive") Raw.End) + asserted = opaqueFixtureObject producerFixture + target = Identity.assertedObjectId asserted + publishWith targetMode fixture object = do + (batch, sealed) <- sealFixture fixture [] do + (_value, committed) <- + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "global-binding") do + Declaration.addDeclarationObject object + Declaration.stageSemanticGlobalBinding + key + (targetMode + (Identity.assertedObjectId object)) + Declaration.authorizeCompiledDeclaration (pure ()) + pure committed + pure (batch, sealed) + (producerBatch, freshProducer) <- + publishWith Semantic.GlobalReference producerFixture asserted + let FixtureSealed producerInterface _freshEvidence = freshProducer + objects = Declaration.committedBatchObjects producerBatch + cachedEvidence <- expectRight + (Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + producerInterface + objects + []) + let cachedProducer = FixtureSealed producerInterface cachedEvidence + resolveThrough label parent = do + outcome <- runFixtureDriver consumerFixture [parent] do + fst <$> Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId + (TextEncoding.encodeUtf8 (Text.pack label))) do + found <- Declaration.resolveVisibleGlobal key + Declaration.authorizeCompiledDeclaration (pure ()) + pure found + case outcome of + Declaration.DriverSucceeded found _interface _prefix _closure -> + assertEqual label + (Just + ( Semantic.GlobalReference target + , Core.TySet + )) + found + Declaration.DriverFailed failure _prefix -> + assertFailure + ("global binding consumer failed: " <> show failure) + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("global binding consumer did not seal: " <> show failure) + resolveThrough "fresh-global-binding" freshProducer + resolveThrough "cached-global-binding" cachedProducer + + missingEnvironment <- expectRight + (Semantic.semanticEnvironmentDelta + [Semantic.semanticGlobalBinding + key + (Semantic.GlobalReference target)]) + missingDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + (fixtureOwner producerFixture) + (localDeclarationOrdinal 0)) + [] + [] + [] + [] + missingEnvironment) + missingInterface <- expectRight + (Semantic.semanticInterface + (fixtureOwner producerFixture) + [] + [missingDelta]) + case Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + missingInterface + [] + [] of + Left (Declaration.ImportedGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalTargetMissing missingTarget)) -> do + assertEqual "missing target key" key actualKey + assertEqual "missing target mode" + (Semantic.GlobalReference target) + actualTarget + assertEqual "missing target object" target missingTarget + Left failure -> + assertFailure + ("unexpected missing-target failure: " <> show failure) + Right _evidence -> + assertFailure "cached evidence accepted a missing target object" + + expansionEnvironment <- expectRight + (Semantic.semanticEnvironmentDelta + [Semantic.semanticGlobalBinding + key + (Semantic.TransparentExpansion target)]) + expansionDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + (fixtureOwner producerFixture) + (localDeclarationOrdinal 0)) + [] [] [target] [] expansionEnvironment) + expansionInterface <- expectRight + (Semantic.semanticInterface + (fixtureOwner producerFixture) [] [expansionDelta]) + case Declaration.validateImportedModuleEvidence + (Identity.theoryId + (fixtureFoundation producerFixture)) + [] + expansionInterface + [asserted] + [] of + Left (Declaration.ImportedGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalExpansionNotTransparent + invalidTarget)) -> do + assertEqual "nontransparent target key" key actualKey + assertEqual "nontransparent target mode" + (Semantic.TransparentExpansion target) + actualTarget + assertEqual "nontransparent target object" target invalidTarget + Left failure -> + assertFailure + ("unexpected nontransparent-target failure: " + <> show failure) + Right _evidence -> + assertFailure "cached evidence accepted a nontransparent expansion" + + let intrinsicTarget = + Identity.intrinsicObjectId + (Identity.theoryId + (fixtureFoundation producerFixture)) + Core.Empty + Core.TySet + intrinsicObject = + Identity.assertedObject + intrinsicTarget + (Identity.IntrinsicObjectContent + (Identity.theoryId + (fixtureFoundation producerFixture)) + Core.Empty + Core.TySet) + intrinsicFailure <- runFixtureDriver producerFixture [] do + Declaration.commitCompiledDeclaration + (Semantic.declarationSyntaxId "intrinsic-global-binding") do + Declaration.addDeclarationObject intrinsicObject + Declaration.stageSemanticGlobalBinding + key + (Semantic.GlobalReference intrinsicTarget) + Declaration.authorizeCompiledDeclaration (pure ()) + case intrinsicFailure of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.DeclarationGlobalTargetInvalid + actualKey actualTarget + (Semantic.SemanticGlobalTargetIsIntrinsic + invalidTarget))) + _prefix -> do + assertEqual "intrinsic target key" key actualKey + assertEqual "intrinsic target mode" + (Semantic.GlobalReference intrinsicTarget) + actualTarget + assertEqual "intrinsic target object" + intrinsicTarget invalidTarget + other -> + assertFailure + (case other of + Declaration.DriverSucceeded{} -> + "ordinary binding accepted an intrinsic target" + Declaration.DriverFailed failure _prefix -> + "unexpected intrinsic-target failure: " <> show failure + Declaration.DriverSealFailed failure _prefix -> + "intrinsic target reached sealing: " <> show failure) + + conflictObject <- pure (opaqueFixtureObject conflictFixture) + (_conflictBatch, conflicting) <- + publishWith Semantic.GlobalReference conflictFixture conflictObject + collision <- runFixtureDriver rootFixture + [freshProducer, conflicting] + (pure ()) + case collision of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedGlobalCollision + actualKey firstTarget secondTarget)) + _prefix -> do + assertEqual "colliding global key" key actualKey + assertEqual "first imported target" + (Semantic.GlobalReference target) + firstTarget + assertEqual "second imported target" + (Semantic.GlobalReference + (Identity.assertedObjectId conflictObject)) + secondTarget + Declaration.DriverFailed failure _prefix -> + assertFailure + ("unexpected imported collision: " <> show failure) + Declaration.DriverSucceeded{} -> + assertFailure "unequal imported bindings did not collide" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("global collision reached sealing: " <> show failure) + + let theory = Identity.theoryId (fixtureFoundation producerFixture) + transparentBody = Core.COpaqueInteger 0 + transparentTarget = + Identity.transparentObjectId + theory Core.TySet transparentBody + transparentObject = + Identity.assertedObject + transparentTarget + (Identity.TransparentObjectContent + theory Core.TySet transparentBody) + (_referenceBatch, referenceProducer) <- + publishWith + Semantic.GlobalReference + producerFixture + transparentObject + (_expansionBatch, expansionProducer) <- + publishWith + Semantic.TransparentExpansion + conflictFixture + transparentObject + modeCollision <- runFixtureDriver rootFixture + [referenceProducer, expansionProducer] + (pure ()) + case modeCollision of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedGlobalCollision + actualKey firstTarget secondTarget)) + _prefix -> do + assertEqual "mode collision key" key actualKey + assertEqual "reference target" + (Semantic.GlobalReference transparentTarget) + firstTarget + assertEqual "expansion target" + (Semantic.TransparentExpansion transparentTarget) + secondTarget + other -> + assertFailure + (case other of + Declaration.DriverSucceeded{} -> + "different global target modes did not collide" + Declaration.DriverFailed failure _prefix -> + "unexpected mode-collision failure: " <> show failure + Declaration.DriverSealFailed failure _prefix -> + "mode collision reached sealing: " <> show failure) + +data FixtureSealed = FixtureSealed + !Semantic.SemanticInterface + !Declaration.ImportedModuleEvidence + +foldsTransitiveAndDiamondEvidence :: Assertion +foldsTransitiveAndDiamondEvidence = do + baseFixture <- makeNamedFixture "base" + middleFixture <- makeNamedFixture "middle" + transitiveFixture <- makeNamedFixture "transitive" + leftFixture <- makeNamedFixture "left" + rightFixture <- makeNamedFixture "right" + diamondFixture <- makeNamedFixture "diamond" + conflictLeftFixture <- makeNamedFixture "conflict-left" + conflictRightFixture <- makeNamedFixture "conflict-right" + conflictRootFixture <- makeNamedFixture "conflict-root" + + (base, baseFingerprint) <- + sealFactFixture baseFixture [] "transitive-shared" + middle <- snd <$> sealFixture middleFixture [base] (pure ()) + transitive <- sealUsingImportedFact + transitiveFixture [middle] baseFingerprint + assertLocalFactOrdinalZero "transitive importer" transitive + + left <- snd <$> sealFixture leftFixture [base] (pure ()) + right <- snd <$> sealFixture rightFixture [base] (pure ()) + diamond <- sealUsingImportedFact + diamondFixture [left, right] baseFingerprint + assertLocalFactOrdinalZero "diamond importer" diamond + + (conflictLeft, leftFingerprint) <- + sealFactFixture conflictLeftFixture [] "diamond-conflict" + (conflictRight, rightFingerprint) <- + sealFactFixture conflictRightFixture [] "diamond-conflict" + conflict <- runFixtureDriver + conflictRootFixture + [conflictLeft, conflictRight] + (pure ()) + case conflict of + Declaration.DriverFailed + (Declaration.DriverDeclarationFailed + (Declaration.ImportedAliasCollision + alias + (Declaration.ImportedAliasOrigin + _leftSlot firstTarget) + (Declaration.ImportedAliasOrigin + _rightSlot secondTarget))) + _prefix -> do + assertEqual "conflicting alias" + (Semantic.semanticName "diamond-conflict") + alias + assertEqual "first alias origin" + leftFingerprint + firstTarget + assertEqual "second alias origin" + rightFingerprint + secondTarget + _ -> + assertFailure "conflicting diamond alias was not rejected" + where + sealUsingImportedFact fixture parents fingerprint = do + (batch, _sealed) <- sealFixture fixture parents do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "use-transitive-import") do + candidate <- Declaration.reserveCandidate + (factSpec fixture "local-after-import") + Declaration.authorizeOmittedCandidate candidate do + void (Declaration.useAuthorizedFact fingerprint) + Declaration.recordOmittedUse + pure committed + pure batch + + assertLocalFactOrdinalZero label batch = + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + assertEqual label + (localFactOrdinal 0) + (Semantic.factSlotOrdinal + (Semantic.semanticFactSlot occurrence)) + facts -> + assertFailure + (label <> ": unexpected fact count " + <> show (length facts)) + +sealFactFixture + :: Fixture + -> [FixtureSealed] + -> Text + -> IO + ( FixtureSealed + , Semantic.SemanticFactOccurrenceFingerprint + ) +sealFactFixture fixture parents alias = do + (batch, sealed) <- sealFixture fixture parents do + (_value, committed) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId + (TextEncoding.encodeUtf8 alias)) do + candidate <- Declaration.reserveCandidate + (factSpec fixture alias) + Declaration.authorizeSourceAxiomCandidate candidate + pure committed + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + pure + ( sealed + , Semantic.semanticFactFingerprint occurrence + ) + facts -> + assertFailure + ("unexpected sealed fact count: " <> show (length facts)) + >> fail "unreachable" + +sealFixture + :: Fixture + -> [FixtureSealed] + -> Declaration.ModuleDriver Text value + -> IO (value, FixtureSealed) +sealFixture fixture parents action = do + outcome <- runFixtureDriver fixture parents action + case outcome of + Declaration.DriverSucceeded value interface prefix _closure -> + pure + ( value + , FixtureSealed + interface + (Declaration.freshImportedModuleEvidence + [ evidence + | FixtureSealed _interface evidence <- parents + ] + interface + prefix) + ) + Declaration.DriverFailed failure _prefix -> + assertFailure ("fixture failed: " <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure ("fixture did not seal: " <> show failure) + >> fail "unreachable" + +runFixtureDriver + :: Fixture + -> [FixtureSealed] + -> Declaration.ModuleDriver Text value + -> IO (Declaration.DriverResult Text value) +runFixtureDriver fixture parents action = do + result <- Declaration.runModuleDriver + (fixtureFoundation fixture) + (fixtureOwner fixture) + [ Semantic.semanticInterfaceAssertedId interface + | FixtureSealed interface _evidence <- parents + ] + unavailableVampireResolver + Declaration.FreshValidation + do + traverse_ + (\(FixtureSealed _interface evidence) -> + Declaration.importSealedModuleDriver evidence) + parents + action + expectRight result + +requireSingleOccurrence + :: Declaration.CommittedDeclarationBatch + -> Declaration.ModuleDriver + Declaration.DeclarationError + Semantic.SemanticFactOccurrence +requireSingleOccurrence batch = + case Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) of + [occurrence] -> + pure occurrence + _ -> + Declaration.failModuleDriver + Declaration.ProofDeclarationMustProduceOneFact + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value + +expectRightIO :: Show error => IO (Either error value) -> IO value +expectRightIO action = + action >>= expectRight + +withOpenedStore + :: Fixture + -> FilePath + -> (Store.Store -> IO value) + -> IO value +withOpenedStore fixture root action = + bracket + (expectRightIO + (Store.openStore + (root Posix.</> "store.sqlite") + (Identity.theoryId (fixtureFoundation fixture)))) + (Store.closeStore . snd) + (action . snd) + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + root <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile root template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Foundation.hs b/source/Felix/Test/Unit/Foundation.hs new file mode 100644 index 0000000..18ead04 --- /dev/null +++ b/source/Felix/Test/Unit/Foundation.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Foundation (unitTests) where + +import Base +import Felix.Checking.Core +import Felix.Checking.Foundation + +import Data.List qualified as List +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Foundation manifest" + [ testCase + "accepts the exact compiled foundation" + acceptsCompiledFoundation + , testCase + "rejects incomplete and altered manifests" + rejectsManifestMutations + , testCase + "classifies the exact UnivOf schemas" + classifiesUnivOfSchemas + , testCase + "selects only intrinsic characteristic dependencies" + selectsOnlyIntrinsicCharacteristicDependencies + ] + +acceptsCompiledFoundation :: Assertion +acceptsCompiledFoundation = do + foundation <- + either + (assertFailure . show) + pure + checkedFoundation + assertEqual + "intrinsic coverage" + [minBound .. maxBound] + (fst <$> compiledFoundationIntrinsicRows) + assertEqual + "guarded-rule coverage" + [minBound .. maxBound] + [ tag + | FoundationRuleInput tag _signature <- + compiledFoundationRuleRows + ] + for_ [minBound .. maxBound] \tag -> + assertEqual + ("closed proposition type for " <> show tag) + TyProp + (frozenCoreType + (foundationAxiomFrozen foundation tag)) + +selectsOnlyIntrinsicCharacteristicDependencies :: Assertion +selectsOnlyIntrinsicCharacteristicDependencies = do + let separation = + CApp + (CApp (CIntrinsic Sep) (CBound 0)) + (CLam TySet CFalsum) + underUniverse = + CApp (CIntrinsic UnivOf) separation + assertEqual + "separation is found recursively without a universe bundle" + (Set.singleton SeparationCharacteristic) + (foundationAxiomDependencies underUniverse) + +rejectsManifestMutations :: Assertion +rejectsManifestMutations = do + let withoutMinimal = + List.filter + (\case + FoundationAxiomInput + UnivOfMinimal + _syntax + _backendClass -> + False + _ -> + True) + compiledFoundationAxiomRows + wrongUnivType = + [ if tag == UnivOf + then (tag, TySet) + else row + | row@(tag, _coreType) <- + compiledFoundationIntrinsicRows + ] + duplicatedEmpty = + case findAxiomInput EmptyCharacteristic of + Just row -> + row : compiledFoundationAxiomRows + Nothing -> + impossible + "compiled manifest omitted EmptyCharacteristic" + alteredEmpty = + replaceAxiomInput + EmptyCharacteristic + (FoundationAxiomInput + EmptyCharacteristic + (coreOpaqueInteger 0) + FoundationFofProjectable) + alteredExtensionality = + replaceAxiomInput + SetExtensionality + (FoundationAxiomInput + SetExtensionality + coreFalsum + FoundationFofProjectable) + misclassifiedEmpty = + case findAxiomInput EmptyCharacteristic of + Just + (FoundationAxiomInput + tag + syntax + _backendClass) -> + replaceAxiomInput + tag + (FoundationAxiomInput + tag + syntax + (FoundationRequiresTh0 + (HigherOrderLambda :| []))) + Nothing -> + impossible + "compiled manifest omitted EmptyCharacteristic" + withoutLeast = + [ row + | row@(FoundationRuleInput tag _signature) <- + compiledFoundationRuleRows + , tag /= SetLfpLeast + ] + alteredInductSignature = + [ if tag == SetLfpInduct + then + FoundationRuleInput + tag + (KernelRuleSignature [TySet] 0) + else row + | row@(FoundationRuleInput tag _signature) <- + compiledFoundationRuleRows + ] + assertAuditContains + (== MissingFoundationAxiom UnivOfMinimal) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + withoutMinimal) + assertAuditContains + (== FoundationIntrinsicTypeMismatch + UnivOf + (TySet `TyArrow` TySet) + TySet) + (auditFoundationManifest + wrongUnivType + compiledFoundationRuleRows + compiledFoundationAxiomRows) + assertAuditContains + (== MissingFoundationRule SetLfpLeast) + (auditFoundationManifest + compiledFoundationIntrinsicRows + withoutLeast + compiledFoundationAxiomRows) + assertAuditContains + (\case + FoundationRuleSignatureMismatch + SetLfpInduct + _expected + (KernelRuleSignature [TySet] 0) -> + True + _ -> + False) + (auditFoundationManifest + compiledFoundationIntrinsicRows + alteredInductSignature + compiledFoundationAxiomRows) + assertAuditContains + (== DuplicateFoundationAxiom EmptyCharacteristic) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + duplicatedEmpty) + assertAuditContains + (\case + FoundationAxiomIllTyped + EmptyCharacteristic + (ExpectedCoreType TyProp TySet) -> + True + _ -> + False) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + alteredEmpty) + assertAuditContains + (== FoundationAxiomStatementMismatch + SetExtensionality) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + alteredExtensionality) + assertAuditContains + (== FoundationAxiomBackendClassMismatch + EmptyCharacteristic + (FoundationRequiresTh0 + (HigherOrderLambda :| [])) + FoundationFofProjectable) + (auditFoundationManifest + compiledFoundationIntrinsicRows + compiledFoundationRuleRows + misclassifiedEmpty) + +classifiesUnivOfSchemas :: Assertion +classifiesUnivOfSchemas = do + foundation <- + either + (assertFailure . show) + pure + checkedFoundation + for_ + [ UnivOfContains + , UnivOfTransitive + , UnivOfFamilyUnionClosed + , UnivOfPowerSetClosed + ] + \tag -> + assertEqual + (show tag) + FoundationFofProjectable + (foundationAxiomBackendClass foundation tag) + for_ + [ UnivOfReplacementClosed + , UnivOfMinimal + ] + \tag -> + case foundationAxiomBackendClass foundation tag of + FoundationRequiresTh0 exclusions -> + assertBool + (show tag <> " has a structural exclusion") + (not (null exclusions)) + FoundationFofProjectable -> + assertFailure + (show tag <> " was classified as FOF") + +findAxiomInput + :: FoundationAxiomTag + -> Maybe FoundationAxiomInput +findAxiomInput wanted = + List.find + (\case + FoundationAxiomInput tag _syntax _backendClass -> + tag == wanted) + compiledFoundationAxiomRows + +replaceAxiomInput + :: FoundationAxiomTag + -> FoundationAxiomInput + -> [FoundationAxiomInput] +replaceAxiomInput wanted replacement = + fmap + (\row -> + case row of + FoundationAxiomInput tag _syntax _backendClass + | tag == wanted -> + replacement + _ -> + row) + compiledFoundationAxiomRows + +assertAuditContains + :: (FoundationManifestError -> Bool) + -> Either + (NonEmpty FoundationManifestError) + FoundationManifestAudit + -> Assertion +assertAuditContains predicate = \case + Left errors -> + assertBool + ("expected error not found in " <> show errors) + (any predicate errors) + Right _audit -> + assertFailure + "expected foundation-manifest audit to fail" diff --git a/source/Felix/Test/Unit/Html.hs b/source/Felix/Test/Unit/Html.hs new file mode 100644 index 0000000..c8395ec --- /dev/null +++ b/source/Felix/Test/Unit/Html.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Html (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph +import Felix.Workspace qualified as Workspace +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Abstract + +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.List.NonEmpty qualified as NonEmpty +import System.Directory qualified as Directory +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = testGroup "HTML renderer" + [ testCase "one shared index resolves local and cross-page previews" referencePreviews + , testCase "missing reference preview data falls back to readable text" missingReferenceFallback + , testCase "datatype rendering omits unchecked derived facts" datatypeDerivedFactsAreOmitted + ] + +referencePreviews :: Assertion +referencePreviews = do + environment <- expectRight =<< Workspace.prepareDefaultWorkspaceEnvironment + graph <- + expectRight =<< + Workspace.prepareDefaultSourceGraph + "test/html-fixtures/root-preview.tex" + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + hints <- TextIO.readFile "library/lexicon.tsv" + layout <- + expectRight + (layoutHtmlSourceGraph + (Workspace.workspaceHtmlMountPrefixes environment) + graph) + let nodes = Parse.parsedWorkspaceImportedBeforeImporter workspace + sourceBlocks = + (\node -> + ( Parse.parsedModuleResolved node + , Parse.parsedModuleBlocks node + )) + <$> nodes + (renderIndex, pages) = + Html.buildRenderIndex sourceBlocks + rootPage = NonEmpty.last pages + context <- + expectRight + (htmlRenderContext + layout + (Html.htmlPagePresentationSource rootPage)) + html <- + expectRight + (Html.renderDocument + context + hints + renderIndex + rootPage) + let supportScript = Html.supportScriptAssetContents + assertContains "local references keep page anchors" "href=\"#local_prop\"" html + assertContains "local references point previews at the visible target block" "data-reference-label=\"local_prop\" data-preview-target-id=\"local_prop\"" html + assertNotContains "local references do not use hidden preview ids" "data-reference-label=\"local_prop\" data-preview-id=\"" html + assertContains "visible target blocks expose preview metadata" "id=\"local_prop\" data-preview-kind=\"Proposition\" data-preview-label=\"local_prop\"" html + assertContains "imported references get preview metadata" "data-reference-label=\"imported_prop\"" html + assertContains "imported references link to their relative encoded theory route" "href=\"imported-preview#imported_prop\"" html + assertContains "imported references still use hidden preview templates" "data-reference-label=\"imported_prop\" data-preview-id=\"reference-preview-" html + assertNotContains "imported references do not get broken page anchors" "href=\"#imported_prop\"" html + assertNotContains "imported references are not non-clickable spans" "<span class=\"ref-badge has-preview\" data-reference-label=\"imported_prop\"" html + assertCount "hidden preview store only contains the imported fixture preview" 1 "class=\"reference-preview-template\"" html + assertContains "page grid is scoped to an explicit shell" "class=\"page-layout\"" html + assertNotContains "page grid does not apply to every body div" "body > div" html + assertContains "page heading uses the selected mounted source" "<h1>project:test/html-fixtures/root-preview.tex</h1>" html + assertContains "imported preview records its mounted source" "project:test/html-fixtures/imported-preview.tex" html + assertContains "imported preview source links to the same route" "href=\"imported-preview\"><code>project:test/html-fixtures/imported-preview.tex</code>" html + assertContains "imported source renders on its own line" "class=\"reference-preview-source\"" html + assertContains "multi-reference rendering preserves the comma separator" ", <a href=\"imported-preview#imported_prop\" class=\"ref-badge has-preview\" data-reference-label=\"imported_prop\"" html + assertContains "calculation justifications also use target previews" "Step 2: by <a href=\"#local_prop\" class=\"ref-badge has-preview\" data-reference-label=\"local_prop\" data-preview-target-id=\"local_prop\"" html + assertContains "large reference lists collapse to an ellipsis trigger" "Follows by <span class=\"ref-badge has-preview ref-badge-group\" data-preview-group=\"true\" data-reference-label=\"5 references\"" html + assertContains "collapsed references keep current-page item metadata" "data-reference-label=\"group_source\" data-preview-link=\"#group_source\" data-preview-target-id=\"group_source\"" html + assertContains "collapsed references keep imported item metadata" "data-reference-label=\"imported_prop\" data-preview-link=\"imported-preview#imported_prop\" data-preview-id=\"reference-preview-" html + assertNotContains "collapsed references do not inline the long list" "Follows by <a href=\"#local_prop\" class=\"ref-badge has-preview\" data-reference-label=\"local_prop\" data-preview-target-id=\"local_prop\" aria-describedby=\"reference-preview-popup\">local_prop</a>, <a href=\"#uses_refs\"" html + assertContains "collapsed tooltips compose full preview templates" "const preview = cloneHiddenPreview(item) || buildCurrentPreview(item) || buildMissingPreview(item);" supportScript + assertContains "collapsed tooltip labels become links" "template.append(linkGroupHeading(item, preview));" supportScript + assertContains "collapsed tooltip labels use generated reference links" "link.href = href;" supportScript + assertContains "collapsed tooltip heading links have hover affordance" ".reference-preview-heading a:hover," html + assertContains "collapsed tooltips use stacked preview sections" "className = 'reference-preview-group-template'" supportScript + assertContains "visible preview popup accepts pointer interaction" "pointer-events: auto;" html + assertContains "preview popup uses a wider bounded layout" "width: 44rem;" html + assertContains "preview popup uses a taller bounded layout" "max-height: min(34rem, calc(100vh - 2rem));" html + assertContains "behavior loads from the shared external script asset" "src=\"../../_static/naproche-html.js\"" html + assertNotContains "inline script bundles are not emitted" "<script type=\"text/javascript\">" html + assertContains "preview popup cancels delayed hide on pointer entry" "popup.addEventListener('pointerenter', clearHideTimer);" supportScript + assertContains "preview popup schedules delayed hide on pointer exit" "popup.addEventListener('pointerleave', scheduleHide);" supportScript + assertContains "group click pins the preview popup" "showPreview(trigger, event, true);" supportScript + assertContains "group keyboard activation pins the preview popup" "showPreview(trigger, null, true);" supportScript + assertContains "preview statements use a full-width paragraph" "class=\"reference-preview-statement\"" html + assertContains "preview popup is emitted once" "id=\"reference-preview-popup\"" html + +missingReferenceFallback :: Assertion +missingReferenceFallback = do + let proof = Qed (Just Nowhere) (JustificationRef ("missing_ref" :| [])) + blocks = [BlockProof Nowhere proof Nowhere] + html <- renderSynthetic blocks + assertContains "missing references remain visible" "missing_ref" html + assertNotContains "missing references do not claim preview content" "data-preview-id=" html + +datatypeDerivedFactsAreOmitted :: Assertion +datatypeDerivedFactsAreOmitted = do + let blocks = + [ propformDatatypeBlock Nowhere + , referenceClaimBlock "uses_datatype_fact" + , referenceProofBlock "propform_induct" + ] + html <- renderSynthetic blocks + assertContains "datatype declarations remain visible" "Datatype of " html + assertContains "derived fact references remain readable" "propform_induct" html + assertNotContains "unchecked datatype facts are not rendered" "<summary>Derived facts</summary>" html + assertNotContains "unchecked datatype facts do not become preview targets" "data-preview-label=\"propform_induct\"" html + +renderSynthetic :: [Block] -> IO Text +renderSynthetic blocks = do + currentDirectory <- Directory.getCurrentDirectory + mounts <- + expectRight =<< + prepareSourceMounts + [(sourceMountId "project", currentDirectory)] + request <- + expectRight + (searchedRoot "test/html-fixtures/root-preview.tex") + graph <- + expectRight =<< + buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph) + context <- + expectRight + (htmlRenderContext + layout + (sourceGraphRootSource graph)) + let (renderIndex, page :| _remainingPages) = + Html.buildRenderIndex + ((sourceGraphRootSource graph, blocks) :| []) + expectRight + (Html.renderDocument + context + "" + renderIndex + page) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +propformDatatypeBlock :: Location -> Block +propformDatatypeBlock blockLoc = + BlockData blockLoc Nothing "propform" propformDatatype + +propformDatatype :: Datatype +propformDatatype = + Datatype + { datatypeHeadExpr = ExprOp Nowhere (constSymbol "propform") [] + , datatypeClauses = + DatatypeClause (ExprOp Nowhere (constSymbol "propbot") []) (ExprOp Nowhere (constSymbol "propform") []) [] :| + [ DatatypeClause (ExprOp Nowhere (unarySymbol "propvar") [ExprVar "n"]) (ExprOp Nowhere (constSymbol "propform") []) [("n", ExprOp Nowhere (constSymbol "naturals") [])] + , DatatypeClause + (ExprOp Nowhere (infixSymbol "propto") [ExprVar "p", ExprVar "q"]) + (ExprOp Nowhere (constSymbol "propform") []) + [ ("p", ExprOp Nowhere (constSymbol "propform") []) + , ("q", ExprOp Nowhere (constSymbol "propform") []) + ] + ] + } + +referenceClaimBlock :: Marker -> Block +referenceClaimBlock marker = + BlockClaim Proposition Nowhere Nothing marker (Claim [] (StmtFormula (PropositionalConstant Nowhere IsTop))) + +referenceProofBlock :: Marker -> Block +referenceProofBlock marker = + BlockProof Nowhere (Qed (Just Nowhere) (JustificationRef (marker :| []))) Nowhere + +constSymbol :: Text -> FunctionSymbol +constSymbol name = + mkMixfixItem [Just (Command name)] (Marker name) NonAssoc + +unarySymbol :: Text -> FunctionSymbol +unarySymbol name = + mkMixfixItem [Just (Command name), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] (Marker name) NonAssoc + +infixSymbol :: Text -> FunctionSymbol +infixSymbol name = + mkMixfixItem [Nothing, Just (Command name), Nothing] (Marker name) NonAssoc + +assertContains :: HasCallStack => String -> Text -> Text -> Assertion +assertContains label needle haystack = + assertBool + (label <> "\nExpected to find: " <> Text.unpack needle) + (needle `Text.isInfixOf` haystack) + +assertNotContains :: HasCallStack => String -> Text -> Text -> Assertion +assertNotContains label needle haystack = + assertBool + (label <> "\nDid not expect to find: " <> Text.unpack needle) + (not (needle `Text.isInfixOf` haystack)) + +assertCount :: HasCallStack => String -> Int -> Text -> Text -> Assertion +assertCount label expected needle haystack = + assertEqual + (label <> "\nExpected count for: " <> Text.unpack needle) + expected + (Text.count needle haystack) diff --git a/source/Felix/Test/Unit/HtmlLayout.hs b/source/Felix/Test/Unit/HtmlLayout.hs new file mode 100644 index 0000000..a3d701f --- /dev/null +++ b/source/Felix/Test/Unit/HtmlLayout.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlLayout (unitTests) where + +import Base +import Felix.Source +import Felix.Source.Graph +import Felix.Render.Html.Layout + +import Control.Exception (bracket) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "HTML layout" + [ testCase + "encodes URL segments canonically" + encodesUrlSegments + , testCase + "renders relative typed URLs" + rendersRelativeUrls + , testCase + "separates mounted route namespaces" + separatesMountedNamespaces + , testCase + "routes searched and exact roots identically" + routesRootFormsIdentically + , testCase + "requires an explicit mount for an external root" + requiresExternalMount + , testCase + "reports URL and destination collisions independently" + reportsRouteCollisions + , testCase + "rejects ancestor and descendant destinations" + rejectsNestedDestinations + , testCase + "is independent of graph and configuration traversal order" + isTraversalOrderIndependent + ] + + +encodesUrlSegments :: Assertion +encodesUrlSegments = do + let accepted = + [ ("AZaz09-._~", "AZaz09-._~") + , ("#?% \\", "%23%3F%25%20%5C") + , ("über", "%C3%BCber") + , ("%2f", "%252f") + ] + for_ accepted \(decoded, expected) -> + assertEqual + ("encoded segment " <> Text.unpack decoded) + (Right expected) + (renderUrlSegment <$> urlSegment decoded) + let rejected = + [ ("", EmptyUrlSegment) + , (".", DotUrlSegment ".") + , ("..", DotUrlSegment "..") + , ("a/b", UrlSegmentContainsSeparator "a/b") + ] + for_ rejected \(decoded, expected) -> + assertEqual + ("rejected segment " <> Text.unpack decoded) + (Left expected) + (urlSegment decoded) + assertEqual + "fragment encoding" + "#name%23%C3%BC" + (renderUrlFragment "name#ü") + +rendersRelativeUrls :: Assertion +rendersRelativeUrls = do + let cases = + [ ( ["library", "nested", "über"] + , ["_static", "naproche-html.js"] + , "../../_static/naproche-html.js" + ) + , ( ["first", "entry"] + , ["second", "entry"] + , "../second/entry" + ) + , ( ["mount", "entry"] + , ["mount", "a?b"] + , "a%3Fb" + ) + ] + for_ cases \(currentSegments, targetSegments, expected) -> do + current <- expectRight (urlPath currentSegments) + target <- expectRight (urlPath targetSegments) + assertEqual + "relative URL" + expected + (renderRelativeUrlPath current target) + current <- expectRight (urlPath ["mount", "entry"]) + target <- expectRight (urlPath ["mount", "ü"]) + assertEqual + "encoded path and fragment remain separate" + "%C3%BC#part%23%3F" + ( renderRelativeUrlPath current target + <> renderUrlFragment "part#?" + ) + +separatesMountedNamespaces :: Assertion +separatesMountedNamespaces = + withTemporaryDirectory "felix-html-layout-mounts" \temp -> do + let mountSpecifications = + [ ("project", []) + , ("library", ["library"]) + , ("debug", ["debug"]) + , ("external", ["external"]) + ] + roots <- for mountSpecifications \(ident, _prefix) -> do + let root = temp Posix.</> Text.unpack ident + Directory.createDirectory root + writeTheory (root Posix.</> "entry.tex") [] + pure (sourceMountId ident, root) + mounts <- expectRight =<< prepareSourceMounts roots + routes <- for mountSpecifications \(ident, prefix) -> do + let sourcePath = + temp + Posix.</> Text.unpack ident + Posix.</> "entry.tex" + request <- expectRight =<< existingRoot sourcePath + graph <- expectRight =<< buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId configuredId, configuredPrefix) + | (configuredId, configuredPrefix) <- + mountSpecifications + ] + graph) + route <- requireRootRoute graph layout + pure + ( ident + , renderUrlPath (routeUrlPath route) + , safeRelativePathFilePath + (routeDestination route) + , prefix + ) + assertEqual + "mount URLs" + [ ("project", "/entry") + , ("library", "/library/entry") + , ("debug", "/debug/entry") + , ("external", "/external/entry") + ] + [ (ident, url) | (ident, url, _destination, _prefix) <- routes ] + assertEqual + "mount destinations" + [ ("project", "entry.html") + , ("library", "library/entry.html") + , ("debug", "debug/entry.html") + , ("external", "external/entry.html") + ] + [ (ident, destination) + | (ident, _url, destination, _prefix) <- routes + ] + +routesRootFormsIdentically :: Assertion +routesRootFormsIdentically = + withTemporaryDirectory "felix-html-layout-root-forms" \temp -> do + let libraryRoot = temp Posix.</> "library" + entry = libraryRoot Posix.</> "entry.tex" + Directory.createDirectory libraryRoot + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", temp) + , (sourceMountId "library", libraryRoot) + ] + searched <- expectRight (searchedRoot "library/entry.tex") + exact <- expectRight =<< existingRoot entry + searchedGraph <- + expectRight =<< buildResolvedSourceGraph mounts searched + exactGraph <- + expectRight =<< buildResolvedSourceGraph mounts exact + let configuration = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + ] + searchedLayout <- + expectRight + (layoutHtmlSourceGraph configuration searchedGraph) + exactLayout <- + expectRight + (layoutHtmlSourceGraph configuration exactGraph) + searchedRoute <- + requireRootRoute searchedGraph searchedLayout + exactRoute <- + requireRootRoute exactGraph exactLayout + assertEqual "selected route" searchedRoute exactRoute + assertEqual + "most-specific URL" + "/library/entry" + (renderUrlPath (routeUrlPath searchedRoute)) + +requiresExternalMount :: Assertion +requiresExternalMount = + withTemporaryDirectory "felix-html-layout-external" \temp -> do + let projectRoot = temp Posix.</> "project" + externalRoot = temp Posix.</> "vendor" + externalEntry = externalRoot Posix.</> "entry.tex" + Directory.createDirectory projectRoot + Directory.createDirectory externalRoot + writeTheory externalEntry [] + request <- expectRight =<< existingRoot externalEntry + projectMounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", projectRoot)] + outsideResult <- + buildResolvedSourceGraph projectMounts request + case outsideResult of + Left RootOutsideConfiguredMount{} -> + pure () + result -> + assertFailure + ("expected external root rejection, got " + <> show result) + mounted <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "external", externalRoot) + ] + graph <- expectRight =<< buildResolvedSourceGraph mounted request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId "project", []) + , (sourceMountId "external", ["vendor"]) + ] + graph) + route <- requireRootRoute graph layout + assertEqual + "external URL" + "/vendor/entry" + (renderUrlPath (routeUrlPath route)) + +reportsRouteCollisions :: Assertion +reportsRouteCollisions = do + reportsPageCollisions + reportsAssetUrlCollision + +reportsPageCollisions :: Assertion +reportsPageCollisions = + withTemporaryDirectory "felix-html-layout-page-collision" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + firstEntry = firstRoot Posix.</> "two" Posix.</> "a.tex" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + Directory.createDirectory (firstRoot Posix.</> "two") + writeTheory (secondRoot Posix.</> "a.tex") [] + writeTheory firstEntry ["a.tex"] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "first", firstRoot) + , (sourceMountId "second", secondRoot) + ] + request <- expectRight =<< existingRoot firstEntry + graph <- expectRight =<< buildResolvedSourceGraph mounts request + let configuration = + [ (sourceMountId "first", ["one"]) + , (sourceMountId "second", ["one", "two"]) + ] + case layoutHtmlSourceGraph configuration graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url owners] + [HtmlDestinationRouteCollision destination + destinationOwners]) -> do + assertEqual + "canonical URL collision" + "/one/two/a" + (renderUrlPath url) + assertEqual + "URL owners" + (NonEmpty.toList owners) + (NonEmpty.toList destinationOwners) + assertEqual + "destination collision" + "one/two/a.html" + (safeRelativePathFilePath destination) + result -> + assertFailure + ("expected paired route collisions, got " + <> show result) + +reportsAssetUrlCollision :: Assertion +reportsAssetUrlCollision = + withTemporaryDirectory "felix-html-layout-asset-collision" \temp -> do + let entry = + temp + Posix.</> "_static" + Posix.</> "naproche-html.js.tex" + Directory.createDirectory (temp Posix.</> "_static") + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- + expectRight + (searchedRoot "_static/naproche-html.js.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case + layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url _owners] + []) -> + assertEqual + "page/asset URL collision" + "/_static/naproche-html.js" + (renderUrlPath url) + result -> + assertFailure + ("expected URL-only asset collision, got " + <> show result) + +rejectsNestedDestinations :: Assertion +rejectsNestedDestinations = + withTemporaryDirectory "felix-html-layout-nested" \temp -> do + let nestedDirectory = temp Posix.</> "a.html" + Directory.createDirectory nestedDirectory + writeTheory (temp Posix.</> "a.tex") [] + writeTheory (nestedDirectory Posix.</> "b.tex") [] + writeTheory + (temp Posix.</> "entry.tex") + ["a.tex", "a.html/b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [] + [NestedHtmlDestinationRouteCollision + ancestor + ancestorOwner + descendant + descendantOwner]) -> do + assertEqual + "ancestor destination" + "a.html" + (safeRelativePathFilePath ancestor) + assertEqual + "ancestor owner" + "a.tex" + (pageOwnerPath ancestorOwner) + assertEqual + "descendant destination" + "a.html/b.html" + (safeRelativePathFilePath descendant) + assertEqual + "descendant owner" + "a.html/b.tex" + (pageOwnerPath descendantOwner) + result -> + assertFailure + ("expected nested destination collision, got " + <> show result) + where + pageOwnerPath = \case + HtmlPage source -> + safeRelativePathFilePath + (resolvedSourceRelativePath source) + HtmlSupportScript -> + "<support script>" + +isTraversalOrderIndependent :: Assertion +isTraversalOrderIndependent = + withTemporaryDirectory "felix-html-layout-order" \temp -> do + writeTheory (temp Posix.</> "a.tex") [] + writeTheory (temp Posix.</> "b.tex") [] + let root = temp Posix.</> "entry.tex" + writeTheory root ["a.tex", "b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + firstGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + writeTheory root ["b.tex", "a.tex"] + secondGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + let firstConfiguration = + [ (sourceMountId "unused", ["unused"]) + , (sourceMountId "project", []) + ] + firstLayout <- + expectRight + (layoutHtmlSourceGraph + firstConfiguration + firstGraph) + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations firstConfiguration)) + \(orderedGraph, configuration) -> do + layout <- + expectRight + (layoutHtmlSourceGraph + configuration + orderedGraph) + assertEqual + "route table" + firstLayout + layout + + let collidingConfiguration = + [ (sourceMountId "z", ["same"]) + , (sourceMountId "a", ["same"]) + , (sourceMountId "project", []) + ] + expectedCollision = + layoutHtmlSourceGraph + collidingConfiguration + firstGraph + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations collidingConfiguration)) + \(orderedGraph, configuration) -> + assertEqual + "collision diagnostic" + expectedCollision + (layoutHtmlSourceGraph + configuration + orderedGraph) + + +requireRootRoute + :: ResolvedSourceGraph + -> HtmlLayout + -> IO HtmlRoute +requireRootRoute graph layout = + case htmlPageRoute layout (sourceGraphRootSource graph) of + Just route -> + pure route + Nothing -> do + assertFailure "layout omitted the root source" + pure (impossible "requireRootRoute: assertFailure returned") + +writeTheory :: FilePath -> [FilePath] -> IO () +writeTheory path imports = + writeFile path + (unlines + (["\\import{" <> imported <> "}" | imported <- imports] + <> [ "\\begin{axiom}\\label{route_fixture}" + , " $x = x$." + , "\\end{axiom}" + ])) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/HtmlOutput.hs b/source/Felix/Test/Unit/HtmlOutput.hs new file mode 100644 index 0000000..34fe2e7 --- /dev/null +++ b/source/Felix/Test/Unit/HtmlOutput.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlOutput (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph qualified as SourceGraph +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Export +import Felix.Render.Html.Output + +import Control.Exception (bracket) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import System.Directory qualified as Directory +import System.FilePath.Posix ((</>)) +import System.Posix.Files qualified as PosixFiles +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "HTML output" + [ testCase + "publishes a mounted multi-page UTF-8 export" + publishesMountedExport + , testCase + "writes prepared strict bytes" + writesPreparedBytes + , testCase + "attaches bytes only to reserved routes" + attachesBytesToReservedRoutes + , testCase + "rejects a final symlink before publication" + rejectsFinalSymlink + , testCase + "replaces hard-linked targets without changing peers" + replacesHardLinkedTarget + , testCase + "rejects a FIFO before publication" + rejectsFifo + , testCase + "reports and cleans the source-order publication prefix" + reportsIncompletePublication + ] + + +publishesMountedExport :: Assertion +publishesMountedExport = + withTemporaryDirectory "felix-html-export" \temp -> do + let projectRoot = temp </> "project" + libraryRoot = temp </> "library" + projectDirectory = projectRoot </> "docs" + libraryDirectory = libraryRoot </> "shared" + rootSource = projectDirectory </> "über #.tex" + importedSource = + libraryDirectory </> "sets #.tex" + outputRoot = temp </> "html" + rootPage = outputRoot </> "docs" </> "über #.html" + importedPage = + outputRoot + </> "library" + </> "shared" + </> "sets #.html" + supportAsset = + outputRoot + </> "_static" + </> "naproche-html.js" + configuration = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + ] + hints = + "relation\teq\t0\t<mo>=</mo>\n" + Directory.createDirectory projectRoot + Directory.createDirectory libraryRoot + Directory.createDirectory projectDirectory + Directory.createDirectory libraryDirectory + writeImportedTheory importedSource + writeRootTheory rootSource + mounts <- + expectRight =<< + prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "library", libraryRoot) + ] + searched <- + expectRight + (searchedRoot "docs/über #.tex") + exact <- + expectRight =<< existingRoot rootSource + searchedExport <- + expectRight =<< + prepareTestHtmlExport + configuration + mounts + searched + hints + exactExport <- + expectRight =<< + prepareTestHtmlExport + configuration + mounts + exact + hints + assertEqual + "root-form-independent destinations" + (preparedHtmlArtifactDestination <$> searchedExport) + (preparedHtmlArtifactDestination <$> exactExport) + + let artifacts = searchedExport + rejectsArtifactEscape temp artifacts + + plan <- + requirePlan =<< + planHtmlOutput outputRoot artifacts + outputExistsBeforePublication <- + Directory.doesPathExist outputRoot + assertBool + "preflight created the output root" + (not outputExistsBeforePublication) + requirePublication =<< writeHtmlOutput plan + + rootText <- readUtf8 rootPage + importedText <- readUtf8 importedPage + supportText <- readUtf8 supportAsset + assertContains + "root heading" + "<h1>project:docs/über #.tex</h1>" + rootText + assertContains + "imported heading" + "<h1>library:shared/sets #.tex</h1>" + importedText + assertContains + "encoded imported reference" + "href=\"../library/shared/sets%20%23#imported_prop\"" + rootText + assertContains + "encoded imported source link" + "href=\"../library/shared/sets%20%23\"><code>library:shared/sets #.tex</code>" + rootText + assertContains + "root support route" + "src=\"../_static/naproche-html.js\"" + rootText + assertContains + "imported support route" + "src=\"../../_static/naproche-html.js\"" + importedText + for_ [rootText, importedText] \document -> + assertContains + "UTF-8 declaration" + "<meta charset=\"utf-8\">" + document + assertEqual + "support asset" + Html.supportScriptAssetContents + supportText + +rejectsArtifactEscape + :: FilePath + -> [PreparedHtmlArtifact] + -> Assertion +rejectsArtifactEscape temp artifacts = do + let outputRoot = temp </> "escape-html" + outsideRoot = temp </> "outside" + outsideMarker = outsideRoot </> "unchanged" + Directory.createDirectory outputRoot + Directory.createDirectory outsideRoot + ByteString.writeFile outsideMarker "outside" + Directory.createDirectoryLink + outsideRoot + (outputRoot </> "docs") + result <- planHtmlOutput outputRoot artifacts + case result of + Left + (HtmlOutputParentEscapesRoot + _parent + canonicalParent) -> do + expectedOutside <- + Directory.canonicalizePath outsideRoot + assertEqual + "escaping route target" + expectedOutside + canonicalParent + other -> + assertFailure + ("expected output-root escape rejection, got " + <> showPlanResult other) + outsideBytes <- ByteString.readFile outsideMarker + assertEqual + "escape planning changed the outside tree" + "outside" + outsideBytes + supportExists <- + Directory.doesPathExist + (outputRoot </> "_static") + assertBool + "escape preflight created another destination" + (not supportExists) + +writesPreparedBytes :: Assertion +writesPreparedBytes = + withTemporaryDirectory "felix-html-output-bytes" \temp -> do + let outputRoot = temp </> "html" + pageText = "∀ café" + supportText = "const π = 3;" + expectedPageBytes = + ByteString.pack + [ 0xe2, 0x88, 0x80 + , 0x20 + , 0x63, 0x61, 0x66 + , 0xc3, 0xa9 + ] + artifacts <- + makeArtifacts + [ ( "nested/über.html" + , TextEncoding.encodeUtf8 pageText + ) + , ( "_static/naproche-html.js" + , TextEncoding.encodeUtf8 supportText + ) + ] + publishArtifacts outputRoot artifacts + pageBytes <- + ByteString.readFile + (outputRoot </> "nested" </> "über.html") + supportBytes <- + ByteString.readFile + (outputRoot + </> "_static" + </> "naproche-html.js") + assertEqual + "exact page UTF-8 bytes" + expectedPageBytes + pageBytes + assertEqual + "exact support bytes" + (TextEncoding.encodeUtf8 supportText) + supportBytes + +attachesBytesToReservedRoutes :: Assertion +attachesBytesToReservedRoutes = + withTemporaryDirectory "felix-html-output-routes" \temp -> do + let outputRoot = temp </> "html" + reserved <- expectRight + (traverse safeRelativePath + ["page.html", "_static/naproche-html.js"]) + routes <- requireRoutePlan =<< + planHtmlRoutes outputRoot reserved + matching <- makeArtifacts + [ ("page.html", "page") + , ("_static/naproche-html.js", "support") + ] + case planHtmlOutputAgainst routes matching of + Right _ -> + pure () + Left failure -> + assertFailure (show failure) + mismatched <- makeArtifacts + [ ("other.html", "other") + , ("_static/naproche-html.js", "support") + ] + case planHtmlOutputAgainst routes mismatched of + Left HtmlOutputRouteMismatch{} -> + pure () + Left failure -> + assertFailure + ("unexpected route mismatch: " <> show failure) + Right _ -> + assertFailure "unreserved HTML route was accepted" + +rejectsFinalSymlink :: Assertion +rejectsFinalSymlink = + withTemporaryDirectory "felix-html-output-final-link" \temp -> do + let outputRoot = temp </> "html" + supportDirectory = outputRoot </> "_static" + page = outputRoot </> "page.html" + support = + supportDirectory </> "naproche-html.js" + outsideAsset = temp </> "outside.js" + Directory.createDirectory outputRoot + Directory.createDirectory supportDirectory + ByteString.writeFile page "old page" + ByteString.writeFile outsideAsset "outside asset" + Directory.createFileLink outsideAsset support + artifacts <- + makeArtifacts + [ ("page.html", "new page") + , ("_static/naproche-html.js", "new support") + ] + result <- planHtmlOutput outputRoot artifacts + case result of + Left (HtmlOutputTargetIsSymbolicLink target) -> + assertEqual "rejected target" support target + other -> + assertFailure + ("expected final symlink rejection, got " + <> showPlanResult other) + pageBytes <- ByteString.readFile page + outsideBytes <- ByteString.readFile outsideAsset + supportIsLink <- + Directory.pathIsSymbolicLink support + assertEqual + "page changed before complete preflight" + "old page" + pageBytes + assertEqual + "symlink referent changed" + "outside asset" + outsideBytes + assertBool "final symlink was replaced" supportIsLink + +replacesHardLinkedTarget :: Assertion +replacesHardLinkedTarget = + withTemporaryDirectory "felix-html-output-hard-link" \temp -> do + let outputRoot = temp </> "html" + page = outputRoot </> "page.html" + outsidePage = temp </> "outside.html" + Directory.createDirectory outputRoot + ByteString.writeFile outsidePage "outside page" + PosixFiles.createLink outsidePage page + artifacts <- + makeArtifacts [("page.html", "new page")] + publishArtifacts outputRoot artifacts + outsideBytes <- ByteString.readFile outsidePage + pageBytes <- ByteString.readFile page + assertEqual + "outside hard-link peer changed" + "outside page" + outsideBytes + assertEqual "page was not replaced" "new page" pageBytes + +rejectsFifo :: Assertion +rejectsFifo = + withTemporaryDirectory "felix-html-output-fifo" \temp -> do + let outputRoot = temp </> "html" + page = outputRoot </> "page.html" + Directory.createDirectory outputRoot + PosixFiles.createNamedPipe page PosixFiles.ownerModes + artifacts <- + makeArtifacts [("page.html", "page")] + result <- planHtmlOutput outputRoot artifacts + case result of + Left (HtmlOutputTargetNotRegularFile target) -> + assertEqual "rejected target" page target + other -> + assertFailure + ("expected FIFO rejection, got " + <> showPlanResult other) + pageStatus <- + PosixFiles.getSymbolicLinkStatus page + assertBool + "FIFO target was replaced" + (PosixFiles.isNamedPipe pageStatus) + +reportsIncompletePublication :: Assertion +reportsIncompletePublication = + withTemporaryDirectory "felix-html-output-incomplete" \temp -> do + let outputRoot = temp </> "html" + first = outputRoot </> "z.html" + blocked = outputRoot </> "b.html" + unpublished = outputRoot </> "a.html" + artifacts <- + makeArtifacts + [ ("z.html", "first") + , ("b.html", "blocked") + , ("a.html", "unpublished") + ] + plan <- + requirePlan =<< + planHtmlOutput outputRoot artifacts + Directory.createDirectory outputRoot + Directory.createDirectory blocked + result <- writeHtmlOutput plan + case result of + Left + IncompleteHtmlPublication + { committedHtmlDestinations + , failedHtmlDestination + } -> do + expectedFirst <- + expectRight + (safeRelativePath "z.html") + expectedBlocked <- + expectRight + (safeRelativePath "b.html") + assertEqual + "committed destinations" + [expectedFirst] + committedHtmlDestinations + assertEqual + "failed destination" + expectedBlocked + failedHtmlDestination + Right () -> + assertFailure + "expected incomplete publication" + firstBytes <- ByteString.readFile first + unpublishedExists <- + Directory.doesPathExist unpublished + blockedIsDirectory <- + Directory.doesDirectoryExist blocked + outputEntries <- + Directory.listDirectory outputRoot + assertEqual "first artifact" "first" firstBytes + assertBool + "later artifact was published" + (not unpublishedExists) + assertBool + "injected blocker was replaced" + blockedIsDirectory + assertBool + "unpublished temporary files remain" + (not + (any + (List.isInfixOf ".tmp") + outputEntries)) + + +publishArtifacts + :: FilePath + -> [PreparedHtmlArtifact] + -> IO () +publishArtifacts outputRoot artifacts = do + plan <- + requirePlan =<< planHtmlOutput outputRoot artifacts + requirePublication =<< writeHtmlOutput plan + +makeArtifacts + :: [(FilePath, ByteString.ByteString)] + -> IO [PreparedHtmlArtifact] +makeArtifacts artifacts = + for artifacts \(path, bytes) -> do + relative <- expectRight (safeRelativePath path) + pure (preparedHtmlArtifact relative (Right bytes)) + +requirePlan + :: Either HtmlOutputError HtmlOutputPlan + -> IO HtmlOutputPlan +requirePlan = + expectRight + +requireRoutePlan + :: Either HtmlOutputError HtmlRoutePlan + -> IO HtmlRoutePlan +requireRoutePlan = + expectRight + +requirePublication + :: Either HtmlPublicationError () + -> IO () +requirePublication = + expectRight + +showPlanResult + :: Either HtmlOutputError HtmlOutputPlan + -> String +showPlanResult = \case + Left err -> + show err + Right _plan -> + "successful output plan" + +readUtf8 :: FilePath -> IO Text +readUtf8 path = do + bytes <- ByteString.readFile path + case TextEncoding.decodeUtf8' bytes of + Left err -> + assertFailure + ("invalid UTF-8 output: " <> show err) + Right text -> + pure text + +prepareTestHtmlExport + :: [(SourceMountId, [Text])] + -> SourceMounts + -> RootRequest + -> Text + -> IO (Either HtmlExportError [PreparedHtmlArtifact]) +prepareTestHtmlExport configuration mounts request hints = do + graph <- + expectRight =<< + SourceGraph.buildResolvedSourceGraph mounts request + workspace <- + expectRight =<< Parse.parseResolvedSourceGraph graph + pure + (prepareHtmlExport + configuration + (htmlPresentationFromParsedWorkspace workspace) + hints) + +writeImportedTheory :: FilePath -> IO () +writeImportedTheory path = + writeFile path + (unlines + [ "\\begin{proposition}\\label{imported_prop}" + , " $i = i$." + , "\\end{proposition}" + ]) + +writeRootTheory :: FilePath -> IO () +writeRootTheory path = + writeFile path + (unlines + [ "\\import{shared/sets #.tex}" + , "\\begin{proposition}\\label{local_prop}" + , " $a = a$." + , "\\end{proposition}" + , "\\begin{proposition}\\label{uses_import}" + , " $b = b$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Follows by \\cref{imported_prop}." + , "\\end{proof}" + ]) + +assertContains + :: String + -> Text + -> Text + -> Assertion +assertContains description needle haystack = + assertBool + (description <> ": missing " <> show needle) + (needle `Text.isInfixOf` haystack) + +expectRight + :: (Show e, HasCallStack) + => Either e a + -> IO a +expectRight = \case + Left err -> + assertFailure + ("expected Right, got Left " <> show err) + Right value -> + pure value + +withTemporaryDirectory + :: String + -> (FilePath -> IO a) + -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- + Directory.getTemporaryDirectory + (path, handle) <- + openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Identity.hs b/source/Felix/Test/Unit/Identity.hs new file mode 100644 index 0000000..7e1e73f --- /dev/null +++ b/source/Felix/Test/Unit/Identity.hs @@ -0,0 +1,802 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Identity (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Source + +import Control.Exception (bracket) +import Data.ByteString qualified as ByteString +import Data.Either (isLeft) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Numeric.Natural (Natural) +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Content identities" + [ testCase "uses the frozen mathematical hash framing" + hashesCanonicalFields + , testCase "orders exhaustive foundation rows by stable tags" + ordersFoundationManifestTags + , testCase "uses the frozen source path codecs" + encodesSourcePaths + , testCase "separates durable namespaces from mount labels" + separatesModuleOwnership + , testCase "rejects duplicate canonical collection encodings" + rejectsDuplicateCanonicalCollections + , testCase "matches every frozen mathematical identity vector" + matchesMathematicalIdentityVectors + , testCase "validates recursive transparent object content" + validatesTransparentObjectClosure + , testCase "rejects cyclic and mismatched object content" + rejectsInvalidObjectContent + , testCase "validates proposition content and theorem closure" + validatesPropositionAndTheorem + , testCase "round-trips deterministic epoch cache values" + roundTripsEpochCacheValues + , testCase "validates compact fact authority" + validatesCompactFactAuthority + , testCase "propagates candidate safety through local claims" + propagatesCandidateSafety + ] + +ordersFoundationManifestTags :: Assertion +ordersFoundationManifestTags = do + let (intrinsics, rules, axioms) = + Identity.foundationManifestTags + assertEqual + "intrinsic stable-tag order" + [ Core.Member + , Core.Empty + , Core.PairSet + , Core.FamilyUnion + , Core.PowerSet + , Core.Sep + , Core.Repl + , Core.SetChoose + , Core.UnivOf + , Core.ISetLfp + ] + intrinsics + assertEqual + "kernel-rule stable-tag order" + [ Foundation.SetLfpBound + , Foundation.SetLfpLeast + , Foundation.SetLfpFixed + , Foundation.SetLfpInduct + ] + rules + assertEqual + "foundation-axiom stable-tag order" + [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + , Foundation.PowerSetCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + , Foundation.SetChooseWitness + , Foundation.SetExtensionality + , Foundation.SetInduction + , Foundation.PropositionalExtensionality + , Foundation.DoubleNegationElim + , Foundation.UnivOfContains + , Foundation.UnivOfTransitive + , Foundation.UnivOfFamilyUnionClosed + , Foundation.UnivOfPowerSetClosed + , Foundation.UnivOfReplacementClosed + , Foundation.UnivOfMinimal + ] + axioms + +hashesCanonicalFields :: Assertion +hashesCanonicalFields = do + let vectors = + [ ( [] + , "09ace37213e33d80b79e5f21fd60d03f25855e528cc2f25da4762be81d34a8c2" + ) + , ( [ByteString.empty] + , "cd166f5b566ebd02f00f202792699803df09e9a020afbaaa987f5001cb1d095e" + ) + , (["a", "bc"] + , "70c43385ae5b28bb862bc461a3c8d85ab94fd616528e7d94a9e7a52217b5c657" + ) + , (["ab", "c"] + , "d3588d1b26aac958d9f393d8528ad68ed34354aee41d7e405a156b3ffff20c90" + ) + ] + traverse_ + (\(fields, expected) -> do + digest <- expectRight + (hashCanonicalFields "felix-test-v1" fields) + assertEqual + ("fields " <> show fields) + expected + (mathematicalDigestHex digest)) + vectors + +encodesSourcePaths :: Assertion +encodesSourcePaths = do + let absoluteVectors = + [ ([] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000000" + ) + , (["a"] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000001000000000000000161" + ) + , (["a", "b"] + , "000000000000002266656c69782d6162736f6c7574652d736f757263652d726f6f742d706174682d763100000002000000000000000161000000000000000162" + ) + ] + relativeVectors = + [ (["a"] + , "000000000000001b66656c69782d736166652d72656c61746976652d706174682d763100000001000000000000000161" + ) + , (["a", "b"] + , "000000000000001b66656c69782d736166652d72656c61746976652d706174682d763100000002000000000000000161000000000000000162" + ) + ] + traverse_ + (\(components, expected) -> do + encoded <- expectRight + (encodeCanonicalPathRecord + "felix-absolute-source-root-path-v1" + components) + assertEqual + (show components) + expected + (hex encoded)) + absoluteVectors + traverse_ + (\(components, expected) -> do + encoded <- expectRight + (encodeCanonicalPathRecord + "felix-safe-relative-path-v1" + components) + assertEqual + (show components) + expected + (hex encoded)) + relativeVectors + +separatesModuleOwnership :: Assertion +separatesModuleOwnership = + withTemporaryDirectory "felix-module-owner" \root -> do + writeFile (root Posix.</> "b.tex") "" + mounts <- expectRight + =<< prepareSourceMounts + [(sourceMountId "display-only", root)] + request <- expectRight (searchedRoot "b.tex") + source <- expectRight =<< resolveRoot mounts request + mount <- case sourceMountList mounts of + [only] -> + pure only + _ -> + assertFailure "expected one prepared mount" + >> fail "unreachable" + relative <- expectRight (safeRelativePath "b.tex") + let owner = + moduleName (resolvedSourceAddress source) + assertEqual + "relative owner" + relative + (moduleNameRelativePath owner) + assertEqual + "namespace derives from the canonical root" + (sourceNamespaceId (sourceMountRoot mount)) + (moduleNameNamespace owner) + +rejectsDuplicateCanonicalCollections :: Assertion +rejectsDuplicateCanonicalCollections = do + assertEqual + "set duplicate" + (Left (DuplicateCanonicalSetElement "a")) + (encodeCanonicalSet ["b", "a", "a"]) + assertEqual + "map duplicate" + (Left (DuplicateCanonicalMapKey "a")) + (encodeCanonicalMap [("a", "first"), ("a", "second")]) + +matchesMathematicalIdentityVectors :: Assertion +matchesMathematicalIdentityVectors = do + fixture <- makeIdentityFixture + let vectors = + [ ( "theory" + , Identity.theoryIdDigest + (fixtureTheory fixture) + , "46665f15f80ad52d319188de307471f34905ec3849b84b9d6d0d5a584a90eb62" + ) + , ( "intrinsic Empty" + , Identity.objectIdDigest + (fixtureIntrinsic fixture) + , "a11f641738714ac806f3c3b902841b3178d32fff38fea353aac409e3cc1a8efc" + ) + , ( "transparent Empty" + , Identity.objectIdDigest + (fixtureTransparent fixture) + , "49dfb3c96f0db2cc81703bbed82c08e9d2eda7d4a2274f0529d22c592003d4d1" + ) + , ( "opaque signature" + , Identity.objectIdDigest + (fixtureOpaque fixture) + , "8723488e60ed09ffad378bc6d9916d07c348d12d01548a7b482726e6e18b2c8d" + ) + , ( "proposition" + , Identity.propositionIdDigest + (Identity.checkedPropositionId + (fixtureProposition fixture)) + , "c40b403f0422f4125065d83b5eba64e4b0c4b24fb1559967ef986f5265829b65" + ) + , ( "theorem" + , Identity.theoremIdDigest + (fixtureTheorem fixture) + , "6a328a4142fde3c9851186ea00f54d8978d2640dcbe51421536c9726f4f717d2" + ) + ] + traverse_ + (\(description, digest, expected) -> + assertEqual + description + expected + (mathematicalDigestHex digest)) + vectors + assertEqual + "opaque declaration seed" + "27697d641220b8bb63b32631492646277b28e70c8b7149206580337254ecc123" + (mathematicalDigestHex + (Identity.opaqueDeclarationSeedDigest + (fixtureOpaqueSeed fixture))) + assertEqual + "family domains remain distinct" + (length vectors) + (Set.size + (Set.fromList + [ digest + | (_description, digest, _expected) <- vectors + ])) + +validatesTransparentObjectClosure :: Assertion +validatesTransparentObjectClosure = do + fixture <- makeIdentityFixture + let theory = fixtureTheory fixture + child = fixtureTransparent fixture + parentBody = Core.CGlobal child + parent = + Identity.transparentObjectId + theory + Core.TySet + parentBody + assertions = + [ Identity.assertedObject + parent + (Identity.TransparentObjectContent + theory + Core.TySet + parentBody) + , Identity.assertedObject + child + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty)) + , Identity.assertedObject + (fixtureIntrinsic fixture) + (Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet) + ] + closure <- expectRight + (Identity.validateObjectClosure theory assertions) + assertEqual + "all recursively checked objects" + (Set.fromList + [ fixtureIntrinsic fixture + , child + , parent + ]) + (Identity.checkedObjectIds closure) + assertEqual + "parent type" + (Just Core.TySet) + (Identity.lookupCheckedObjectType parent closure) + +rejectsInvalidObjectContent :: Assertion +rejectsInvalidObjectContent = do + fixture <- makeIdentityFixture + firstDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-a" []) + secondDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-b" []) + mismatchDigest <- expectRight + (hashCanonicalFields "felix-invalid-object-mismatch" []) + let theory = fixtureTheory fixture + first = + Identity.objectId + Identity.TransparentObject + firstDigest + second = + Identity.objectId + Identity.TransparentObject + secondDigest + cycleAssertions = + [ Identity.assertedObject + first + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal second)) + , Identity.assertedObject + second + (Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal first)) + ] + case Identity.validateObjectClosure theory cycleAssertions of + Left (Identity.TransparentObjectCycle path) -> do + assertEqual + "cycle closes" + (NonEmpty.head path) + (NonEmpty.last path) + assertEqual + "cycle members" + (Set.fromList [first, second]) + (Set.fromList (NonEmpty.toList path)) + Left other -> + assertFailure + ("expected a transparent cycle, got " <> show other) + Right _ -> + assertFailure "expected a transparent cycle, got Right" + let mismatched = + Identity.objectId + Identity.TransparentObject + mismatchDigest + content = + Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + case + Identity.validateObjectClosure + theory + [Identity.assertedObject mismatched content] of + Left + (Identity.ObjectIdPayloadMismatch + supplied + computed) -> do + assertEqual "supplied ID" mismatched supplied + assertEqual + "computed ID" + (fixtureTransparent fixture) + computed + Left other -> + assertFailure + ("expected object ID disagreement, got " <> show other) + Right _ -> + assertFailure "expected object ID disagreement, got Right" + +validatesPropositionAndTheorem :: Assertion +validatesPropositionAndTheorem = do + fixture <- makeIdentityFixture + let proposition = + fixtureProposition fixture + reference = + fixtureTheoremRef fixture + assertEqual + "theorem retains its theory" + (fixtureTheory fixture) + (Identity.theoremRefTheory reference) + assertEqual + "theorem retains its proposition" + (Identity.checkedPropositionId proposition) + (Identity.theoremRefProposition reference) + falsum <- expectRight + (Identity.validatePropositionContent + (fixtureClosure fixture) + Core.CFalsum) + case + Identity.validateAssertedPropositionContent + (fixtureClosure fixture) + (Identity.checkedPropositionId falsum) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) of + Left + (Identity.PropositionIdPayloadMismatch + supplied + computed) -> do + assertEqual + "supplied proposition ID" + (Identity.checkedPropositionId falsum) + supplied + assertEqual + "computed proposition ID" + (Identity.checkedPropositionId proposition) + computed + Left other -> + assertFailure + ("expected proposition ID disagreement, got " + <> show other) + Right _ -> + assertFailure + "expected proposition ID disagreement, got Right" + +roundTripsEpochCacheValues :: Assertion +roundTripsEpochCacheValues = do + fixture <- makeIdentityFixture + let theory = fixtureTheory fixture + contents = + [ Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet + , Identity.TransparentObjectContent + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + , Identity.OpaqueObjectContent + theory + (fixtureOpaqueSeed fixture) + Core.TySet + ] + traverse_ + (\content -> + assertEqual + "object-content cache round trip" + (Right content) + (decodeCache + Identity.getObjectContentCache + (encodeCache + (Identity.putObjectContentCache + content)))) + contents + assertEqual + "constructive theorem reference cache round trip" + (Right (fixtureTheoremRef fixture)) + (decodeCache + Identity.getTheoremRefCache + (encodeCache + (Identity.putTheoremRefCache + (fixtureTheoremRef fixture)))) + assertBool + "cache bytes are not mathematical theorem-reference bytes" + ( encodeCache + (Identity.putTheoremRefCache + (fixtureTheoremRef fixture)) + /= Identity.encodeTheoremRef + (fixtureTheoremRef fixture) + ) + let ascending = + Map.fromList [("a", 1 :: Natural), ("b", 2)] + putMap = + putCanonicalCacheMap + putCacheText + putCacheNatural + assertEqual + "canonical cache map round trip" + (Right ascending) + (decodeCache + (getCanonicalCacheMap + getCacheText + getCacheNatural) + (encodeCache (putMap ascending))) + +validatesCompactFactAuthority :: Assertion +validatesCompactFactAuthority = do + fixture <- makeIdentityFixture + let reference = fixtureTheoremRef fixture + sourceKinds = + Authority.singletonEscapeKind Authority.SourceAxiom + bothKinds = + Authority.escapeKinds + [Authority.Omitted, Authority.SourceAxiom] + sourceTarget = + Authority.factAuthority + reference + (Authority.authoritySafety sourceKinds) + bothTarget = + Authority.factAuthority + reference + (Authority.authoritySafety bothKinds) + requests = + [ Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "first" + , Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "first" + , Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "second" + ] + directRequest = + Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "same bytes" + indirectRequest = + Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestIndirect + "same bytes" + directAuthorizations = + [ Authority.CheckedKernelConstruction + (Authority.FoundationLeaf + Foundation.EmptyCharacteristic) + , Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet + (Foundation.SetLfpBound :| []))) + , Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (fixtureIntrinsic fixture)) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + (fixtureIntrinsic fixture) + (hashCacheFields + "test-named-construction" ["checked"])) + , Authority.CheckedSourceProof requests + , Authority.TrustedCompilation + (Authority.DatatypeCompilation + (Authority.datatypeCompilationDescriptor + (fixtureIntrinsic fixture) + (NonEmpty.singleton + (fixtureIntrinsic fixture)) + [reference])) + , Authority.SourceAxiomAuthorization + , Authority.OmittedAuthorization + ] + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceTarget + Authority.SourceAxiomAuthorization) + proofCertificate <- expectRight + (Authority.validationCertificate + bothTarget + (Authority.CheckedSourceProof requests)) + assertEqual + "escape bits have canonical order" + [Authority.SourceAxiom, Authority.Omitted] + (Authority.escapeKindsToList bothKinds) + traverse_ + (\direct -> + assertEqual + ("direct authorization round trip: " <> show direct) + (Right direct) + (decodeCache + Authority.getDirectAuthorizationCache + (encodeCache + (Authority.putDirectAuthorizationCache + direct)))) + directAuthorizations + assertEqual + "certificate cache retains repeated ordered requests" + (Right proofCertificate) + (decodeCache + Authority.getValidationCertificateCache + (encodeCache + (Authority.putValidationCertificateCache + proofCertificate))) + assertBool + "request mode participates in exact request identity" + (directRequest /= indirectRequest) + assertEqual + "prepared-request cache identity vector" + "1d72b851cb8b1704617becbf9f2cf492aed1c674d9e6ca759e244f169b15f278" + (hex + (encodeCache + (Authority.putPreparedRequestIdCache + directRequest))) + assertEqual + "source certificate round trip" + (Right sourceCertificate) + (decodeCache + Authority.getValidationCertificateCache + (encodeCache + (Authority.putValidationCertificateCache + sourceCertificate))) + assertBool + "source axiom requires its exact singleton safety" + (isLeft + (Authority.validationCertificate + bothTarget + Authority.SourceAxiomAuthorization)) + assertBool + "omitted authorization requires its distinct bit" + (isLeft + (Authority.validationCertificate + sourceTarget + Authority.OmittedAuthorization)) + assertBool + "cache rejects an empty escape-backed value" + (isLeft + (decodeCache + Authority.getAuthoritySafetyCache + (encodeCache do + putCacheTag 0x01 + putCacheTag 0x00))) + let taintedCandidate = + Authority.addCandidateEscape + Authority.SourceAxiom + Authority.initialCandidateSafety + assertEqual + "candidate completion freezes accumulated safety" + sourceTarget + (Authority.candidateFactAuthority + reference + taintedCandidate) + +propagatesCandidateSafety :: Assertion +propagatesCandidateSafety = do + fixture <- makeIdentityFixture + let reference = fixtureTheoremRef fixture + imported = + Authority.factAuthority + reference + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + afterImported <- expectRight + (Authority.accumulateFactSafety + reference + imported + Authority.initialCandidateSafety) + -- A local claim shares the enclosing candidate value; citing that claim + -- does not create a second support representation. + afterLocalClaim <- expectRight + (Authority.accumulateFactSafety + reference + (Authority.factAuthority + reference + Authority.cleanAuthoritySafety) + afterImported) + let finalSafety = + Authority.addCandidateEscape + Authority.Omitted + afterLocalClaim + assertEqual + "local claim retains prior safety and direct omission" + [Authority.SourceAxiom, Authority.Omitted] + (Authority.escapeKindsToList + (Authority.authoritySafetyEscapeKinds + (Authority.candidateSafetyAuthority finalSafety))) + +data IdentityFixture = IdentityFixture + { fixtureTheory :: !Identity.TheoryId + , fixtureIntrinsic :: !Identity.ObjectId + , fixtureTransparent :: !Identity.ObjectId + , fixtureOpaqueSeed :: !Identity.OpaqueDeclarationSeed + , fixtureOpaque :: !Identity.ObjectId + , fixtureClosure :: !Identity.CheckedObjectClosure + , fixtureProposition :: !Identity.CheckedPropositionContent + , fixtureTheoremRef :: !Identity.TheoremRef + , fixtureTheorem :: !Identity.TheoremId + } + +makeIdentityFixture :: IO IdentityFixture +makeIdentityFixture = do + foundation <- expectRight Foundation.checkedFoundation + pathRecord <- expectRight + (encodeCanonicalPathRecord + "felix-absolute-source-root-path-v1" + ["a"]) + namespaceDigest <- expectRight + (hashCanonicalFields + "felix-source-namespace-v1" + [pathRecord]) + relative <- expectRight (safeRelativePath "b.tex") + let theory = + Identity.theoryId foundation + intrinsic = + Identity.intrinsicObjectId + theory + Core.Empty + Core.TySet + transparent = + Identity.transparentObjectId + theory + Core.TySet + (Core.CIntrinsic Core.Empty) + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest + namespaceDigest) + relative + seed = + Identity.opaqueDeclarationSeed + owner + (localDeclarationOrdinal 2) + SignatureDeclaration + (generatedObjectSlot 0) + opaque = + Identity.opaqueObjectId + theory + seed + Core.TySet + closure <- expectRight + (Identity.validateObjectClosure + theory + [ Identity.assertedObject + intrinsic + (Identity.IntrinsicObjectContent + theory + Core.Empty + Core.TySet) + ]) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal intrinsic) + (Core.CGlobal intrinsic))) + let reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + pure + IdentityFixture + { fixtureTheory = theory + , fixtureIntrinsic = intrinsic + , fixtureTransparent = transparent + , fixtureOpaqueSeed = seed + , fixtureOpaque = opaque + , fixtureClosure = closure + , fixtureProposition = proposition + , fixtureTheoremRef = reference + , fixtureTheorem = + Identity.theoremId reference + } + +hex :: ByteString.ByteString -> Text +hex = + Text.pack + . concatMap byteHex + . ByteString.unpack + where + byteHex byte = + let digits = "0123456789abcdef" + high = fromIntegral (byte `div` 16) + low = fromIntegral (byte `mod` 16) + in [digits `at` high, digits `at` low] + + at characters index = + fromMaybe + (impossible "hex digit index") + (nth index characters) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path diff --git a/source/Felix/Test/Unit/Kernel.hs b/source/Felix/Test/Unit/Kernel.hs new file mode 100644 index 0000000..7762a7e --- /dev/null +++ b/source/Felix/Test/Unit/Kernel.hs @@ -0,0 +1,858 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} + +module Felix.Test.Unit.Kernel (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp +import Felix.Checking.Typed.Inductive qualified as Inductive +import Felix.Report.Location (pattern Nowhere) +import Felix.Syntax.Internal qualified as Internal + +import Data.Set qualified as Set +import Data.Vector qualified as Vector +import Test.Tasty +import Test.Tasty.HUnit + + +data TestGlobal = TestGlobal + deriving (Show, Eq, Ord) + +testGlobalType :: TestGlobal -> CoreType +testGlobalType _global = TySet + +unitTests :: TestTree +unitTests = + testGroup "Kernel replay" + [ testCase + "replays equality reflexivity through kernel semantics" + replaysEqualityReflexivity + , testCase + "replays logical scopes and elimination" + replaysLogicalScopes + , testCase + "replays quantifier and equality structure" + replaysQuantifierAndEqualityStructure + , testCase + "records foundation and import leaves" + recordsAuthorityLeaves + , testCase + "checks and replays the exact set fixed-point rules" + checksSetLfpRules + , testCase + "replays direct inductive facts" + replaysDirectInductiveFacts + , testCase + "rejects altered set fixed-point applications" + rejectsAlteredSetLfpApplications + , testCase + "rejects invalid scoped replay" + rejectsInvalidScopedReplay + , testCase + "rejects a caller-supplied target mismatch" + rejectsTargetMismatch + ] + +replaysEqualityReflexivity :: Assertion +replaysEqualityReflexivity = do + foundation <- + expectRight Foundation.checkedFoundation + operand <- + expectRight + (checkCanonicalCore + absurd + (CIntrinsic Empty)) + direct <- + expectRight + (Semantics.equalityReflexivity + absurd + (embedClosedCore [] operand)) + directClosed <- + maybe + (assertFailure + "closed reflexivity result remained scoped") + pure + (closeScopedCore direct) + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + directClosed + (equalityReflexivityDerivation operand)) + assertEqual + "replay agrees with direct semantics" + directClosed + (replayedKernelTarget replayed) + assertEqual + "one replayed inference" + 1 + (replayedKernelNodeCount replayed) + +replaysLogicalScopes :: Assertion +replaysLogicalScopes = do + foundation <- + expectRight Foundation.checkedFoundation + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + implication <- + checkedScoped [] + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + let propositionScoped = + embedClosedCore [] proposition + identity = + implicationIntroductionDerivation + propositionScoped + (localHypothesisDerivation + (hypothesisIx 0)) + elimination = + implicationIntroductionDerivation + propositionScoped + (implicationIntroductionDerivation + implication + (implicationEliminationDerivation + (localHypothesisDerivation + (hypothesisIx 0)) + (localHypothesisDerivation + (hypothesisIx 1)))) + fromFalsum = + implicationIntroductionDerivation + falsum + (falsumEliminationDerivation + (localHypothesisDerivation + (hypothesisIx 0)) + propositionScoped) + falsum = + unsafeScoped [] CFalsum + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + identity + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (CImp + (scopedCoreTerm implication) + (frozenCoreTerm proposition))) + elimination + assertReplayTarget + foundation + (CImp + CFalsum + (frozenCoreTerm proposition)) + fromFalsum + +replaysQuantifierAndEqualityStructure :: Assertion +replaysQuantifierAndEqualityStructure = do + foundation <- + expectRight Foundation.checkedFoundation + boundSet <- + checkedScoped [TySet] (CBound 0) + emptySet <- + checkedScoped [] (CIntrinsic Empty) + unionFunction <- + checkedScoped [] (CIntrinsic FamilyUnion) + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + convertedTarget <- + checkedScoped [] + (CEq TySet + (CApp + (CLam TySet (CBound 0)) + (CIntrinsic Empty)) + (CIntrinsic Empty)) + oneReduction <- + expectRight (conversionPlan 1) + let boundReflexivity = + scopedEqualityReflexivityDerivation boundSet + universalReflexivity = + forallIntroductionDerivation + TySet + boundReflexivity + specializedReflexivity = + forallEliminationDerivation + universalReflexivity + emptySet + applicationCongruence = + equalityCongruenceApplicationDerivation + (scopedEqualityReflexivityDerivation + unionFunction) + (scopedEqualityReflexivityDerivation + emptySet) + lambdaCongruence = + equalityCongruenceLambdaDerivation + TySet + boundReflexivity + equalityMp = + implicationIntroductionDerivation + (embedClosedCore [] proposition) + (equalityModusPonensDerivation + (scopedEqualityReflexivityDerivation + (embedClosedCore [] + proposition)) + (localHypothesisDerivation + (hypothesisIx 0))) + conversion = + convertJudgmentDerivation + (scopedEqualityReflexivityDerivation + emptySet) + convertedTarget + oneReduction + assertReplayTarget + foundation + (CForall TySet + (CEq TySet + (CBound 0) + (CBound 0))) + universalReflexivity + assertReplayTarget + foundation + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + specializedReflexivity + assertReplayTarget + foundation + (CEq TySet + (CApp + (CIntrinsic FamilyUnion) + (CIntrinsic Empty)) + (CApp + (CIntrinsic FamilyUnion) + (CIntrinsic Empty))) + applicationCongruence + assertReplayTarget + foundation + (CEq + (TySet `TyArrow` TySet) + (CLam TySet (CBound 0)) + (CLam TySet (CBound 0))) + lambdaCongruence + assertReplayTarget + foundation + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + equalityMp + assertReplayTarget + foundation + (scopedCoreTerm convertedTarget) + conversion + +recordsAuthorityLeaves :: Assertion +recordsAuthorityLeaves = do + foundation <- + expectRight Foundation.checkedFoundation + let foundationTag = + Foundation.EmptyCharacteristic + foundationTarget = + mapFrozenGlobals + absurd + (Foundation.foundationAxiomFrozen + foundation + foundationTag) + foundationReplay <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + foundationTarget + (foundationFactDerivation + foundationTag)) + assertEqual + "exact foundation use" + (Set.singleton foundationTag) + (replayedKernelFoundationUses + foundationReplay) + importedStatement <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + importedJudgment <- + expectRight + (derivationImportJudgment + importedStatement) + importedReplay <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + (Vector.singleton importedJudgment) + importedStatement + (importedFactDerivation + (importIx 0))) + assertEqual + "exact import use" + (Set.singleton (importIx 0)) + (replayedKernelImportUses importedReplay) + +checksSetLfpRules :: Assertion +checksSetLfpRules = do + foundation <- + expectRight Foundation.checkedFoundation + ( domain + , operator + , predicate + , element + , fixedPoint + , closedPremise + , boundedPremise + , monotonePremise + , memberPremise + , closurePremise + ) <- + setLfpFixture + bound <- + expectRight + (SetLfp.setLfpBound + foundation + absurd + domain + operator) + least <- + expectRight + (SetLfp.setLfpLeast + foundation + absurd + domain + operator + domain + closedPremise + boundedPremise) + fixed <- + expectRight + (SetLfp.setLfpFixed + foundation + absurd + domain + operator + monotonePremise) + inducted <- + expectRight + (SetLfp.setLfpInduct + foundation + absurd + domain + operator + predicate + element + monotonePremise + memberPremise + closurePremise) + expectedSubset <- + expectRight + (SetLfp.subsetProposition + absurd + fixedPoint + domain) + expectedFixed <- + checkedScoped [] + (CEq TySet + (scopedCoreTerm fixedPoint) + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm fixedPoint))) + expectedPredicate <- + checkedScoped [] + (CApp + (scopedCoreTerm predicate) + (scopedCoreTerm element)) + assertEqual "bound conclusion" expectedSubset bound + assertEqual "least conclusion" expectedSubset least + assertEqual "fixed conclusion" expectedFixed fixed + assertEqual "induction conclusion" expectedPredicate inducted + + target <- + maybe + (assertFailure + "closed fixed-point bound remained scoped") + pure + (closeScopedCore bound) + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + target + (setLfpBoundDerivation + domain + operator)) + assertEqual + "exact guarded-rule use" + (Set.singleton Foundation.SetLfpBound) + (replayedKernelRuleUses replayed) + +replaysDirectInductiveFacts :: Assertion +replaysDirectInductiveFacts = do + foundation <- + expectRight Foundation.checkedFoundation + traverse_ + (replayInductive foundation) + [ Inductive.DirectInductive + [] + (Internal.EmptySet Nowhere) + (Inductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| []) + , let x = Internal.NamedVar "x" + in Inductive.DirectInductive + [] + (Internal.EmptySet Nowhere) + ( Inductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| [ Inductive.DirectInductiveClause + [x] + [Inductive.DirectRecursiveCondition + (Internal.TermVar x) + (Inductive.directRecursiveCarrierContext Nowhere)] + (Internal.TermVar x) + ] + ) + ] + where + replayInductive foundation inductive = do + prepared <- + expectRight + (Inductive.prepareTypedInductive + testGlobalType + foundation + (const Nothing) + (Internal.Marker "direct_inductive") + inductive) + imports <- + traverse + (expectRight . derivationImportJudgment) + (Inductive.typedInductiveGuardTargets + prepared) + traverse_ + (\fact -> do + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + (const Nothing) + imports + (Inductive.typedInductiveFactTarget + fact) + (Inductive.typedInductiveFactDerivation + fact)) + assertEqual + "replay target" + (Inductive.typedInductiveFactTarget + fact) + (replayedKernelTarget replayed)) + (Inductive.typedInductiveFacts + prepared) + +rejectsAlteredSetLfpApplications :: Assertion +rejectsAlteredSetLfpApplications = do + foundation <- + expectRight Foundation.checkedFoundation + ( domain + , operator + , predicate + , _element + , _fixedPoint + , _closedPremise + , boundedPremise + , _monotonePremise + , _memberPremise + , _closurePremise + ) <- + setLfpFixture + falsum <- + checkedScoped [] CFalsum + assertEqual + "altered leastness premise" + (Left + (SetLfp.SetLfpRulePremiseMismatch + Foundation.SetLfpLeast + 0)) + (SetLfp.setLfpLeast + foundation + absurd + domain + operator + domain + falsum + boundedPremise) + assertEqual + "operator type mismatch" + (Left + (SetLfp.SetLfpRuleArgumentTypeMismatch + Foundation.SetLfpBound + 1 + (TySet `TyArrow` TySet) + (TySet `TyArrow` TyProp))) + (SetLfp.setLfpBound + foundation + absurd + domain + predicate) + bound <- + expectRight + (SetLfp.setLfpBound + foundation + absurd + domain + operator) + wrongTarget <- + checkedClosed CFalsum + assertEqual + "altered replay target" + (Left KernelReplayTargetMismatch) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + wrongTarget + (setLfpBoundDerivation + domain + operator)) + assertEqual + "the direct bound remains well formed" + TyProp + (scopedCoreType bound) + +setLfpFixture + :: IO + ( ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + , ScopedCheckedCore Void + ) +setLfpFixture = do + domain <- + checkedScoped [] (CIntrinsic Empty) + operator <- + checkedScoped [] + (CLam TySet (CBound 0)) + predicate <- + checkedScoped [] + (CLam TySet + (CEq TySet + (CBound 0) + (CBound 0))) + element <- + checkedScoped [] (CIntrinsic Empty) + fixedPoint <- + expectRight + (SetLfp.setLfpTerm + absurd + domain + operator) + operatorDomain <- + checkedScoped [] + (CApp + (scopedCoreTerm operator) + (scopedCoreTerm domain)) + closedPremise <- + expectRight + (SetLfp.subsetProposition + absurd + operatorDomain + domain) + boundedPremise <- + expectRight + (SetLfp.subsetProposition + absurd + domain + domain) + monotonePremise <- + expectRight + (SetLfp.boundedMonoProposition + absurd + domain + operator) + memberPremise <- + expectRight + (SetLfp.memberProposition + absurd + element + fixedPoint) + closurePremise <- + expectRight + (SetLfp.inductionClosureProposition + absurd + domain + operator + predicate) + pure + ( domain + , operator + , predicate + , element + , fixedPoint + , closedPremise + , boundedPremise + , monotonePremise + , memberPremise + , closurePremise + ) + +rejectsInvalidScopedReplay :: Assertion +rejectsInvalidScopedReplay = do + foundation <- + expectRight Foundation.checkedFoundation + proposition <- + checkedClosed + (CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty)) + boundSet <- + checkedScoped [TySet] (CBound 0) + assertEqual + "missing local hypothesis" + (Left + (KernelReplayHypothesisOutOfBounds + (hypothesisIx 0))) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + proposition + (localHypothesisDerivation + (hypothesisIx 0))) + assertEqual + "stored term from another lexical context" + (Left + (KernelReplayStoredContextMismatch + [] + [TySet])) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + proposition + (scopedEqualityReflexivityDerivation + boundSet)) + expanded <- + checkedScoped [] + (CEq TySet + (CApp + (CLam TySet (CBound 0)) + (CIntrinsic Empty)) + (CIntrinsic Empty)) + noReductions <- + expectRight (conversionPlan 0) + assertEqual + "conversion budget" + (Left + (KernelReplaySemanticsError + Semantics.KernelConversionBudgetExhausted)) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + (unsafeClosed + (scopedCoreTerm expanded)) + (convertJudgmentDerivation + (equalityReflexivityDerivation + (unsafeClosed + (CIntrinsic Empty))) + expanded + noReductions)) + let checkedAsSet _global = + Just TySet + replayedAsProposition _global = + Just TyProp + globalTarget <- + expectRight + (checkCanonicalCore + checkedAsSet + (CEq TySet + (CGlobal TestGlobal) + (CGlobal TestGlobal))) + assertEqual + "stored global types are rechecked" + (Left + (KernelReplayStoredTermIllTyped + (EqualityOperandTypeMismatch + TySet + TyProp))) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + replayedAsProposition + Vector.empty + globalTarget + (equalityReflexivityDerivation + (unsafeGlobalOperand + checkedAsSet))) + oneNode <- + expectRight (kernelReplayLimits 1 10) + let propositionScoped = + embedClosedCore [] proposition + identityTarget = + unsafeClosed + (CImp + (frozenCoreTerm proposition) + (frozenCoreTerm proposition)) + assertEqual + "replay node limit" + (Left + (KernelReplayNodeLimitExceeded 1)) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + oneNode + absurd + Vector.empty + identityTarget + (implicationIntroductionDerivation + propositionScoped + (localHypothesisDerivation + (hypothesisIx 0)))) + +rejectsTargetMismatch :: Assertion +rejectsTargetMismatch = do + foundation <- + expectRight Foundation.checkedFoundation + operand <- + expectRight + (checkCanonicalCore + absurd + (CIntrinsic Empty)) + wrongTarget <- + expectRight + (checkCanonicalCore + absurd + (CImp CFalsum CFalsum)) + assertEqual + "the expected target is comparison input, not evidence" + (Left KernelReplayTargetMismatch) + (replayedKernelTarget + <$> replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + wrongTarget + (equalityReflexivityDerivation operand)) + +assertReplayTarget + :: Foundation.CheckedFoundation + -> CanonicalTerm Void + -> KernelDerivation Void + -> Assertion +assertReplayTarget foundation expectedTerm derivation = do + expected <- + checkedClosed expectedTerm + replayed <- + expectRight + (replayKernelDerivation + foundation + defaultKernelReplayLimits + absurd + Vector.empty + expected + derivation) + assertEqual + "replayed exact target" + expected + (replayedKernelTarget replayed) + +checkedClosed + :: CanonicalTerm Void + -> IO (FrozenCheckedCore Void) +checkedClosed = + expectRight . checkCanonicalCore absurd + +checkedScoped + :: [CoreType] + -> CanonicalTerm Void + -> IO (ScopedCheckedCore Void) +checkedScoped context = + expectRight + . checkScopedCanonicalCore absurd context + +unsafeScoped + :: [CoreType] + -> CanonicalTerm Void + -> ScopedCheckedCore Void +unsafeScoped context term = + case checkScopedCanonicalCore absurd context term of + Left coreError -> + impossible + ("invalid static kernel fixture: " + <> show coreError) + Right checked -> + checked + +unsafeClosed + :: CanonicalTerm Void + -> FrozenCheckedCore Void +unsafeClosed term = + case checkCanonicalCore absurd term of + Left coreError -> + impossible + ("invalid static closed kernel fixture: " + <> show coreError) + Right checked -> + checked + +unsafeGlobalOperand + :: (TestGlobal -> Maybe CoreType) + -> FrozenCheckedCore TestGlobal +unsafeGlobalOperand globalType = + case checkCanonicalCore + globalType + (CGlobal TestGlobal) of + Left coreError -> + impossible + ("invalid static global kernel fixture: " + <> show coreError) + Right checked -> + checked + +expectRight + :: Show error + => Either error value + -> IO value +expectRight = + either + (assertFailure . show) + pure diff --git a/source/Felix/Test/Unit/Lexicon.hs b/source/Felix/Test/Unit/Lexicon.hs new file mode 100644 index 0000000..4b7f9e7 --- /dev/null +++ b/source/Felix/Test/Unit/Lexicon.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Lexicon (unitTests) where + +import Base +import Felix.Cache.Codec +import Felix.Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon + +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Lexicon" + [ testCase "retains the literal ten-row base mixfix grouping" + retainsBaseMixfixGrouping + , testCase "checks literal mixfix levels" + checksMixfixLevels + , testCase "coalesces equal canonical syntax entries" + coalescesCanonicalEntries + , testCase "rejects shared plural parser surfaces" + rejectsSharedPluralSurfaces + , testCase "round-trips complete canonical lexical entries" + roundTripsCanonicalEntries + , testCase "round-trips asserted module syntax interfaces" + roundTripsSyntaxInterfaces + ] + +retainsBaseMixfixGrouping :: Assertion +retainsBaseMixfixGrouping = + do + assertEqual + "least-to-most-tight marker and associativity rows" + expectedBaseRows + (fmap (fmap entryShape) builtinMixfixLevels) + assertEqual + "canonical base manifest" + expectedBaseRows + (fmap (fmap canonicalEntryShape) baseSyntaxManifest) + assertEqual + "cache-epoch base syntax identity" + "97acdc8153821b20dd0f45cf9d44870705723bb60737f7bacbb9ac31a98987a5" + (cacheDigestHex + (baseSyntaxInterfaceIdDigest + baseSyntaxInterfaceId)) + where + entryShape (MixfixItem _pattern marker associativity) = + (marker, associativity) + + canonicalEntryShape = \case + CanonicalExpressionFunction + _pattern + marker + (Fixity associativity _level) -> + (marker, associativity) + entry -> + impossible + ("non-expression entry in base manifest: " + <> show entry) + +checksMixfixLevels :: Assertion +checksMixfixLevels = do + assertEqual + "lowest level" + (Right 0) + (mixfixLevelValue <$> mixfixLevel 0) + assertEqual + "highest internal level" + (Right 9) + (mixfixLevelValue <$> mixfixLevel 9) + assertEqual + "out-of-range level" + (Left (MixfixLevelOutOfRange 10)) + (mixfixLevel 10) + +coalescesCanonicalEntries :: Assertion +coalescesCanonicalEntries = do + level <- expectRight (mixfixLevel 3) + let pat = + patternFromHoley + [ Nothing + , Just (Command "star") + , Nothing + ] + first = + CanonicalExpressionFunction + pat + "star" + (Fixity LeftAssoc level) + conflicting = + CanonicalExpressionFunction + pat + "other_star" + (Fixity LeftAssoc level) + delta <- expectRight + (canonicalSyntaxDelta [first, first]) + assertEqual + "equal entries coalesce" + 1 + (canonicalSyntaxDeltaSize delta) + assertEqual + "coalesced entry" + [first] + (canonicalSyntaxDeltaEntries delta) + assertEqual + "collision is independent of occurrence order" + (canonicalSyntaxDelta [first, conflicting]) + (canonicalSyntaxDelta [conflicting, first]) + +rejectsSharedPluralSurfaces :: Assertion +rejectsSharedPluralSurfaces = do + let nounEntry = + CanonicalNoun + (wordPattern "member") + (wordPattern "objects") + "member" + otherNoun = + CanonicalNoun + (wordPattern "element") + (wordPattern "objects") + "element" + verbEntry = + CanonicalVerb + (wordPattern "belongs") + (wordPattern "objects") + "belongs" + assertPluralCollision nounEntry otherNoun + assertPluralCollision nounEntry verbEntry + case decodeCache + getCanonicalSyntaxDeltaCache + (encodeCache + (putCacheList + putCanonicalLexicalEntryCache + [nounEntry, otherNoun])) of + Left _ -> + pure () + Right _ -> + assertFailure + "decoded a delta with a shared plural collision" + where + wordPattern word = + TokenCons (Word word) End + + assertPluralCollision first second = + case canonicalSyntaxDelta [first, second] of + Left collision -> do + assertEqual + "shared plural pattern" + (wordPattern "objects") + (canonicalCollisionPattern collision) + assertEqual + "both complete entries" + (Set.fromList [first, second]) + (Set.fromList + (toList + (canonicalCollisionEntries collision))) + Right _ -> + assertFailure + "accepted two entries with one parser-active plural" + +roundTripsCanonicalEntries :: Assertion +roundTripsCanonicalEntries = do + level <- expectRight (mixfixLevel 4) + let unary = + patternFromHoley + [ Just (Word "red") + , Nothing + ] + singular = + patternFromHoley + [ Just (Word "member") + , Just (Word "of") + , Nothing + ] + plural = + patternFromHoley + [ Just (Word "members") + , Just (Word "of") + , Nothing + ] + binary = + patternFromHoley + [ Nothing + , Just (Command "star") + , Nothing + ] + entries = + [ CanonicalLeftAdjective unary "red" + , CanonicalRightAdjective unary "red_right" + , CanonicalFunctionPhrase singular plural "member_fun" + , CanonicalNoun singular plural "member" + , CanonicalStructureNoun singular plural "member_struct" + , CanonicalVerb singular plural "member_verb" + , CanonicalRelation (Command "rel") (ParameterArity 2) "rel" + , CanonicalExpressionFunction + binary + "star" + (Fixity LeftAssoc level) + , CanonicalPrefixPredicate "Pred" 3 "pred" + , CanonicalStructureOperation "operation" + ] + traverse_ + (\entry -> + assertEqual + ("cache round trip for " <> show entry) + (Right entry) + (decodeCache + getCanonicalLexicalEntryCache + (encodeCache + (putCanonicalLexicalEntryCache entry)))) + entries + +roundTripsSyntaxInterfaces :: Assertion +roundTripsSyntaxInterfaces = do + level <- expectRight (mixfixLevel 7) + changedLevel <- expectRight (mixfixLevel 6) + let entry = + CanonicalExpressionFunction + (patternFromHoley + [ Nothing + , Just (Command "diamond") + , Nothing + ]) + "diamond" + (Fixity NonAssoc level) + changedEntry = + CanonicalExpressionFunction + (patternFromHoley + [ Nothing + , Just (Command "diamond") + , Nothing + ]) + "diamond" + (Fixity RightAssoc changedLevel) + delta <- expectRight (canonicalSyntaxDelta [entry]) + changedDelta <- expectRight + (canonicalSyntaxDelta [changedEntry]) + interface <- expectRight + (moduleSyntaxInterface [] delta) + changedInterface <- expectRight + (moduleSyntaxInterface [] changedDelta) + assertEqual + "current fixed base" + baseSyntaxInterfaceId + (moduleSyntaxBase interface) + assertEqual + "module syntax cache round trip" + (Right interface) + (decodeCache + getModuleSyntaxInterfaceCache + (encodeCache + (putModuleSyntaxInterfaceCache interface))) + assertEqual + "asserted ID is deterministic" + (Right (moduleSyntaxAssertedId interface)) + (moduleSyntaxAssertedId + <$> moduleSyntaxInterface [] delta) + assertBool + "normalized fixity changes syntax identity" + (moduleSyntaxAssertedId interface + /= moduleSyntaxAssertedId changedInterface) + case moduleSyntaxInterface + [ moduleSyntaxAssertedId interface + , moduleSyntaxAssertedId interface + ] + delta of + Left (DuplicateDirectSyntaxInterface duplicate) -> + assertEqual + "duplicate direct interface" + (moduleSyntaxAssertedId interface) + duplicate + Left err -> + assertFailure + ("expected duplicate direct syntax input, got " + <> show err) + Right _ -> + assertFailure + "accepted a duplicate direct syntax input" + +expectRight :: Show err => Either err value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) + >> fail "unreachable" + Right value -> + pure value + +expectedBaseRows :: [[(Marker, Associativity)]] +expectedBaseRows = + [ [] + , [ ("add", LeftAssoc) + , ("union", LeftAssoc) + , ("minus", LeftAssoc) + , ("rminus", LeftAssoc) + , ("monus", LeftAssoc) + ] + , [("relcomp", LeftAssoc)] + , [("circ", LeftAssoc)] + , [ ("mul", LeftAssoc) + , ("inter", LeftAssoc) + , ("rmul", LeftAssoc) + ] + , [("setminus", LeftAssoc)] + , [("times", RightAssoc)] + , [] + , [ ("rfrac", NonAssoc) + , ("exp", NonAssoc) + , ("unions", NonAssoc) + , ("cumul", NonAssoc) + , ("fst", NonAssoc) + , ("snd", NonAssoc) + , ("pow", NonAssoc) + , ("neg", NonAssoc) + , ("inv", NonAssoc) + , ("abs", NonAssoc) + , ("cons", NonAssoc) + , ("pair", NonAssoc) + , ("upair", NonAssoc) + ] + , [ ("emptyset", NonAssoc) + , ("naturals", NonAssoc) + , ("naturalsPlus", NonAssoc) + , ("integers", NonAssoc) + , ("rationals", NonAssoc) + , ("reals", NonAssoc) + , ("unit", NonAssoc) + , ("zero", NonAssoc) + ] + ] diff --git a/source/Felix/Test/Unit/Materialization.hs b/source/Felix/Test/Unit/Materialization.hs new file mode 100644 index 0000000..9c4f54f --- /dev/null +++ b/source/Felix/Test/Unit/Materialization.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Materialization (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic qualified as Semantic +import Felix.Math.Codec +import Felix.Module +import Felix.Source + +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Validation applicability" + [ testCase "keeps serializable candidate validation inert" + keepsCandidateValidationInert + , testCase "rejects inexact candidate validation" + rejectsInexactCandidateValidation + , testCase "rejects mismatched candidate fields" + rejectsMismatchedCandidateFields + , testCase "selects ordered declaration certificates" + selectsDeclarationCertificate + , testCase "keeps raw interface membership inert" + keepsImportedMembershipInert + ] + +keepsCandidateValidationInert :: Assertion +keepsCandidateValidationInert = do + fixture <- makeFixture + let check = + Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + (fixtureProofValidation fixture) + assertEqual + "freely constructed records yield only inert applicability" + (Right ()) + check + assertEqual + "inert applicability data is reusable" + (Right ()) + check + +rejectsInexactCandidateValidation :: Assertion +rejectsInexactCandidateValidation = do + fixture <- makeFixture + let wrongKey = + Semantic.proofValidationKey + (Identity.theoremId + (fixtureReference fixture)) + (Semantic.proofSyntaxId "other-proof") + (fixturePrefix fixture) + wrongValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + wrongKey + (fixtureCertificate fixture)) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + wrongValidation of + Left Materialization.ProofValidationKeyMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected validation-key error: " <> show other) + Right _ -> + assertFailure "inexact proof validation key succeeded" + +rejectsMismatchedCandidateFields :: Assertion +rejectsMismatchedCandidateFields = do + fixture <- makeFixture + let sourceAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceAuthority + Authority.SourceAxiomAuthorization) + let key = + Semantic.proofValidationKey + (Identity.theoremId (fixtureReference fixture)) + (Semantic.proofSyntaxId "proof") + (fixturePrefix fixture) + sourceValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key + sourceCertificate) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + sourceValidation of + Left Materialization.CandidateCertificateTargetMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected target mismatch: " <> show other) + Right _ -> + assertFailure "mismatched safety was accepted" + differentDirect <- expectRight + (Authority.validationCertificate + (fixtureAuthority fixture) + (Authority.CheckedSourceProof + [Authority.preparedRequestId + Authority.PreparedRequestFof + Authority.PreparedRequestDirect + "different-request"])) + let directValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key + differentDirect) + (Semantic.proofSyntaxId "proof") + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + directValidation of + Left Materialization.CandidateDirectAuthorizationMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected direct-authorization mismatch: " + <> show other) + Right _ -> + assertFailure "mismatched request list was accepted" + closure <- expectRight + (Identity.validateObjectClosure + (fixtureTheory fixture) + []) + otherProposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CImp Core.CFalsum Core.CFalsum)) + case Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + otherProposition + (fixtureAuthority fixture) + (fixtureDirect fixture) + (fixtureProofValidation fixture) of + Left Materialization.CandidatePropositionMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected proposition mismatch: " <> show other) + Right _ -> + assertFailure "mismatched proposition content was accepted" + +selectsDeclarationCertificate :: Assertion +selectsDeclarationCertificate = do + fixture <- makeFixture + let sourceAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom)) + sourceCertificate <- expectRight + (Authority.validationCertificate + sourceAuthority + Authority.SourceAxiomAuthorization) + let syntax = + Semantic.declarationSyntaxId "declaration" + producedTheorems = + [ Identity.theoremId + (fixtureReference fixture) + , Identity.theoremId + (fixtureReference fixture) + ] + key = + Semantic.declarationValidationKey + syntax + (fixturePrefix fixture) + [] + producedTheorems + validation = + Materialization.candidateDeclarationValidation + (Semantic.declarationValidationRecord + key + [sourceCertificate, fixtureCertificate fixture]) + syntax [] + producedTheorems + 1 + assertEqual + "candidate ordinal selects the second certificate" + (Right ()) + (Materialization.checkCandidateValidation + (fixtureTheory fixture) + (fixturePrefix fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture) + (fixtureDirect fixture) + validation) + +keepsImportedMembershipInert :: Assertion +keepsImportedMembershipInert = do + fixture <- makeFixture + occurrence <- expectRight + (Materialization.checkImportedMembership + (fixtureTheory fixture) + (fixtureInterface fixture) + (fixtureFingerprint fixture) + (fixtureProposition fixture) + (fixtureAuthority fixture)) + assertEqual + "raw interface yields only its inert occurrence" + (fixtureAuthority fixture) + (Semantic.semanticFactAuthority occurrence) + let wrongAuthority = + Authority.factAuthority + (fixtureReference fixture) + (Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.Omitted)) + case Materialization.checkImportedMembership + (fixtureTheory fixture) + (fixtureInterface fixture) + (fixtureFingerprint fixture) + (fixtureProposition fixture) + wrongAuthority of + Left Materialization.ImportedAuthorityMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected imported-authority error: " <> show other) + Right _ -> + assertFailure "imported authority mismatch succeeded" + + +data Fixture = Fixture + { fixtureTheory :: !Identity.TheoryId + , fixtureReference :: !Identity.TheoremRef + , fixtureProposition :: !Identity.CheckedPropositionContent + , fixtureAuthority :: !Authority.FactAuthority + , fixtureDirect :: !Authority.DirectAuthorization + , fixtureCertificate :: !Authority.ValidationCertificate + , fixtureFingerprint + :: !Semantic.SemanticFactOccurrenceFingerprint + , fixtureInterface :: !Semantic.SemanticInterface + , fixturePrefix :: !Semantic.PrefixContextId + , fixtureProofValidation + :: !Materialization.CandidateValidation + } + +makeFixture :: IO Fixture +makeFixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "materialization-test-namespace" + ["root"]) + relative <- expectRight (safeRelativePath "producer.tex") + let theory = + Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + closure <- expectRight + (Identity.validateObjectClosure theory []) + proposition <- expectRight + (Identity.validatePropositionContent + closure Core.CFalsum) + let reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + authority = + Authority.factAuthority + reference + Authority.cleanAuthoritySafety + direct = + Authority.CheckedSourceProof [] + slot = + Semantic.factSlot owner (localFactOrdinal 0) + fingerprint = + Semantic.semanticFactOccurrenceFingerprint + slot authority + occurrence = + Semantic.semanticFactOccurrence + slot + authority + Semantic.SearchEligible + declaration = + Semantic.declarationSlot + owner + (localDeclarationOrdinal 0) + certificate <- expectRight + (Authority.validationCertificate authority direct) + delta <- expectRight + (Semantic.declarationInterfaceDelta + declaration + [occurrence] + [] + [] + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + interface <- expectRight + (Semantic.semanticInterface owner [] [delta]) + prefix <- expectRight + (Semantic.initialPrefixContextId theory owner []) + let syntax = + Semantic.proofSyntaxId "proof" + key = + Semantic.proofValidationKey + (Identity.theoremId reference) + syntax prefix + pure + Fixture + { fixtureTheory = theory + , fixtureReference = reference + , fixtureProposition = proposition + , fixtureAuthority = authority + , fixtureDirect = direct + , fixtureCertificate = certificate + , fixtureFingerprint = fingerprint + , fixtureInterface = interface + , fixturePrefix = prefix + , fixtureProofValidation = + Materialization.candidateProofValidation + (Semantic.proofValidationRecord + key certificate) + syntax + } + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Meaning.hs b/source/Felix/Test/Unit/Meaning.hs new file mode 100644 index 0000000..3093a84 --- /dev/null +++ b/source/Felix/Test/Unit/Meaning.hs @@ -0,0 +1,1119 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Meaning (unitTests) where + +import Base +import Felix.Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Sem +import Felix.Syntax.LexicalPhrase + ( unsafeReadPhrase + , unsafeReadPhraseSgPl + ) + +import Bound (instantiate) +import Control.Monad.Except (runExceptT) +import Control.Monad.State (evalState, gets) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Test.Tasty +import Test.Tasty.HUnit + +unitTests :: TestTree +unitTests = + testGroup "Meaning" + [ testCase "relation applications reject missing and extra parameters" do + for_ [(0, Raw.ParameterArity 0), (2, Raw.ParameterArity 2)] + \(actualCount, actualArity) -> + case meaning [relationClaim actualCount] of + Left + (GlossRelationApplicationError + (Sem.RelationParameterArityMismatch + actualLocation + actualSymbol + expectedArity + reportedActualArity)) -> do + assertEqual + "relation location" + relationLocation + actualLocation + assertEqual + "relation symbol" + relationSymbol + actualSymbol + assertEqual + "expected parameter arity" + (Raw.ParameterArity 1) + expectedArity + assertEqual + "actual parameter arity" + actualArity + reportedActualArity + Left err -> + assertFailure + ("expected a relation arity error, got " + <> show err) + Right _ -> + assertFailure + "expected relation arity validation to fail" + , testCase + "dependent replacement domains report their occurrences" + dependentReplacementDomains + , testCase + "replacement domains remain outside own and future binders" + independentReplacementDomains + , testCase + "functional definitions reject quantified terms with source context" + quantifiedFunctionalDefinition + , testCase + "unsupported source constructs return located errors" + unsupportedSourceConstructs + , testCase + "proof-local function definitions reject mismatched heads" + proofLocalFunctionDefinitionMismatches + , testCase + "abbreviations reject duplicate parameters with source context" + duplicateAbbreviationParameters + , testCase + "abbreviations reject named free body variables" + freeAbbreviationBodyVariable + , testCase + "abbreviation parameters retain positional slots" + orderedAbbreviationParameters + , testCase + "quantified noun binders resolve their whole scope" + quantifiedNounBinderScope + , testCase + "quantified noun binders obey lexical scope" + quantifiedNounLexicalScope + , testCase + "resolved binder adaptation is injective and ignores trivia" + resolvedBinderAdapter + ] + +dependentReplacementDomains :: Assertion +dependentReplacementDomains = + for_ cases \(label, replacement, expectedLocation) -> + assertEqual + label + (Left + (DependentReplacementDomainNotSupported + expectedLocation)) + (glossTestExpr replacement) + where + cases = + [ ( "two-domain replacement" + , replacementExpr + (Raw.ExprVar y) + ( (x, rawInteger 1) + :| [(y, rawVarAt twoXLocation "x")] + ) + , twoXLocation + ) + , ( "three-domain replacement reports its first dependent occurrence" + , replacementExpr + (Raw.ExprVar z) + ( (x, rawInteger 1) + :| [ (y, rawInteger 2) + , (z, Raw.ExprOp + Nowhere + (testFunctionSymbol "dependent_domain" 2) + [ rawVarAt threeYLocation "y" + , rawVarAt threeXLocation "x" + ]) + ] + ) + , threeYLocation + ) + ] + x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + twoXLocation = mkLocation replacementFile 3 17 + threeYLocation = mkLocation replacementFile 4 29 + threeXLocation = mkLocation replacementFile 4 32 + +independentReplacementDomains :: Assertion +independentReplacementDomains = + case glossTestExpr replacement of + Right + (Sem.ReplaceFun + ( (actualX, Sem.TermVar actualOwnX) + :| [ (actualY, Sem.TermVar actualFutureZ) + , ( actualZ + , Sem.TermSymbol + _thirdDomainLocation + (Sem.SymbolInteger 3) + [] + ) + ] + ) + valueScope + conditionScope) -> do + assertEqual + "replacement binder order" + [x, y, z] + [actualX, actualY, actualZ] + assertEqual + "own-domain occurrence remains free" + ownXLocation + (locate actualOwnX) + assertEqual + "future-binder occurrence remains free" + futureZLocation + (locate actualFutureZ) + assertEqual + "replacement value lowering" + expectedValue + (instantiate instantiateBinder valueScope) + assertEqual + "default replacement condition" + Sem.Top + (instantiate instantiateBinder conditionScope) + Right expr -> + assertFailure + ("expected an independent functional replacement, got " + <> show expr) + Left err -> + assertFailure + ("expected independent replacement domains to succeed, got " + <> show err) + where + replacement = + replacementExpr + ( Raw.ExprOp + replacementValueLocation + replacementValueSymbol + [ rawVarAt replacementValueLocation "x" + , rawVarAt replacementValueLocation "y" + , rawVarAt replacementValueLocation "z" + ] + ) + ( (x, rawVarAt ownXLocation "x") + :| [ (y, rawVarAt futureZLocation "z") + , (z, rawInteger 3) + ] + ) + x = Raw.NamedVar "x" + y = Raw.NamedVar "y" + z = Raw.NamedVar "z" + ownXLocation = mkLocation replacementFile 6 7 + futureZLocation = mkLocation replacementFile 6 16 + replacementValueLocation = mkLocation replacementFile 6 29 + replacementValueSymbol = testFunctionSymbol "replacement_value" 3 + expectedValue = + Sem.TermSymbol + replacementValueLocation + (Sem.SymbolMixfix replacementValueSymbol) + [ closedInteger 11 + , closedInteger 22 + , closedInteger 33 + ] + instantiateBinder binder + | binder == x = closedInteger 11 + | binder == y = closedInteger 22 + | binder == z = closedInteger 33 + | otherwise = closedInteger (-1) + +replacementExpr + :: Raw.Expr + -> NonEmpty (Raw.VarSymbol, Raw.Expr) + -> Raw.Expr +replacementExpr value bounds = + Raw.ExprReplace replacementLocation value bounds Nothing + +rawVarAt :: Location -> Text -> Raw.Expr +rawVarAt location name = + Raw.ExprVar (Raw.NamedVarAt location name) + +rawInteger :: Int -> Raw.Expr +rawInteger = + Raw.ExprInteger Nowhere + +glossTestExpr :: Raw.Expr -> Either GlossError Sem.Expr +glossTestExpr expr = + evalState + (runExceptT (glossExpr expr)) + initialGlossState + +glossTestStmt :: Raw.Stmt -> Either GlossError Sem.Formula +glossTestStmt statement = + evalState + (runExceptT (glossStmt statement)) + initialGlossState + +unsupportedSourceConstructs :: Assertion +unsupportedSourceConstructs = do + assertEqual + "definite-description term" + (Left (IotaTermNotSupported iotaLocation)) + (runGlossUnit (glossH0Term [] iotaTerm)) + assertEqual + "definite-function assumption" + (Left + (DefiniteFunctionAssumptionNotSupported + definiteFunctionLocation)) + (runGlossUnit (glossAsm definiteFunctionAssumption)) + where + iotaTerm = + Raw.TermIota + iotaLocation + (Raw.NamedVarAt iotaLocation "x") + (Raw.StmtFormula + (Raw.PropositionalConstant iotaLocation Raw.IsTop)) + definiteFunctionAssumption = + Raw.AsmLetThe + (Raw.NamedVarAt definiteFunctionLocation "f") + (Raw.Fun + definiteFunctionLocation + (Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "function[/s]") + "function") + []) + +runGlossUnit :: Gloss a -> Either GlossError () +runGlossUnit action = + void + (evalState + (runExceptT action) + initialGlossState) + +quantifiedNounBinderScope :: Assertion +quantifiedNounBinderScope = do + case glossTestStmt (namedSetEquality "x") of + Right formula@(Sem.Quantified Sem.Universally scope) -> do + assertEqual + "the written binder does not remain free" + Set.empty + (Sem.freeVars formula) + assertEqual + "the continuation uses the quantified witness" + (Sem.Top + `Sem.Implies` + Sem.Equals + equalityLocation + witness + witness) + (instantiate (const witness) scope) + Right formula -> + assertFailure + ("expected a universal named binder, got " <> show formula) + Left err -> + assertFailure + ("expected the named binder to gloss, got " <> show err) + + case glossTestStmt constrainedNamedBinder of + Right formula@(Sem.Quantified Sem.Universally scope) -> do + assertEqual + "only the ambient noun argument remains free" + (Set.singleton ambientVariable) + (Sem.freeVars formula) + assertEqual + "noun, modifier, such-that, and continuation share the binder" + expectedConstrainedBody + (instantiate (const witness) scope) + Right formula -> + assertFailure + ("expected a constrained universal binder, got " + <> show formula) + Left err -> + assertFailure + ("expected the constrained binder to gloss, got " + <> show err) + where + witness = closedInteger 17 + ambientVariable = + Raw.NamedVarAt ambientLocation "T" + nounConstraint = + Sem.FormulaNoun + nounLocation + witness + subsetNounPattern + [Sem.TermVar ambientVariable] + modifierConstraint = + Sem.FormulaAdj + modifierLocation + witness + modifierPattern + [witness] + suchThatConstraint = + Sem.Equals suchThatLocation witness witness + continuation = + Sem.Equals equalityLocation witness witness + expectedConstrainedBody = + Sem.makeConjunction + [ suchThatConstraint + , Sem.makeConjunction + [nounConstraint, modifierConstraint] + ] + `Sem.Implies` continuation + +quantifiedNounLexicalScope :: Assertion +quantifiedNounLexicalScope = do + assertEqual + "alpha-renaming a referenced binder" + (glossTestStmt (namedSetEquality "x")) + (glossTestStmt (namedSetEquality "renamed")) + assertEqual + "a vacuous written name is semantic trivia" + (glossTestStmt (vacuousSetStatement Nothing)) + (glossTestStmt + (vacuousSetStatement + (Just + (Raw.NamedVarAt binderLocation "unused")))) + + assertEqual + "overlapping sibling names are rejected" + (Left + (DuplicateQuantifiedNounBinder + firstSiblingLocation + secondSiblingLocation + "same")) + (glossTestStmt duplicateSiblingStatement) + + case glossTestStmt nestedShadowingStatement of + Right (Sem.Quantified Sem.Universally outerScope) -> + case instantiate (const outerWitness) outerScope of + Sem.Top + `Sem.Implies` + Sem.Quantified Sem.Existentially innerScope -> + assertEqual + "the nearest binder owns the nested occurrences" + expectedInnerBody + (instantiate + (const innerWitness) + innerScope) + body -> + assertFailure + ("expected a nested existential binder, got " + <> show body) + Right formula -> + assertFailure + ("expected an outer universal binder, got " <> show formula) + Left err -> + assertFailure + ("expected nested shadowing to gloss, got " <> show err) + where + outerWitness = closedInteger 23 + innerWitness = closedInteger 29 + expectedInnerBody = + Sem.makeConjunction + [ Sem.Equals + nestedSuchThatLocation + innerWitness + innerWitness + , Sem.Top + ] + `Sem.And` + Sem.Equals + nestedEqualityLocation + outerWitness + innerWitness + +resolvedBinderAdapter :: Assertion +resolvedBinderAdapter = do + case ( binderAdapterObservation + ("first", firstAdapterLocation) + ("second", secondAdapterLocation) + , binderAdapterObservation + ("alpha", alternateFirstLocation) + ("beta", alternateSecondLocation) + ) of + ( Right (firstId :| [secondId], firstTokens, firstResult) + , Right (alternateIds, alternateTokens, alternateResult) + ) -> do + assertBool + "pre-adapter local identities are distinct" + (firstId /= secondId) + case + ( Map.lookup firstId firstTokens + , Map.lookup secondId firstTokens + ) of + (Just firstToken, Just secondToken) -> do + assertBool + "legacy tokens are injective" + (firstToken /= secondToken) + assertBool + "legacy tokens avoid ambient variables" + ( firstToken /= adapterAmbientVariable + && secondToken + /= adapterAmbientVariable + ) + tokens -> + assertFailure + ("expected two adapter assignments, got " + <> show tokens) + assertEqual + "trivia does not affect local identities" + (firstId :| [secondId]) + alternateIds + assertEqual + "trivia does not affect adapter assignments" + firstTokens + alternateTokens + assertEqual + "trivia does not affect the alpha-normal result" + firstResult + alternateResult + assertEqual + "ambient references pass through unchanged" + (Set.singleton adapterAmbientVariable) + (Sem.freeVars firstResult) + (firstResult, secondResult) -> + assertFailure + ("expected successful adapter observations, got " + <> show (firstResult, secondResult)) + + assertEqual + "an unadapted local reference is a located typed error" + (Left + (GlossResolvedBinderAdapterError + firstAdapterLocation + (UnknownResolvedLocal (LocalId 0)))) + ( evalState + (runExceptT + do + binder <- + freshH0Binder + firstAdapterLocation + (Just + (Raw.NamedVarAt + firstAdapterLocation + "unadapted")) + lowerH0Expr + (Sem.TermVar + (LocalRef (h0BinderId binder)))) + initialGlossState + ) + +binderAdapterObservation + :: (Text, Location) + -> (Text, Location) + -> Either + GlossError + ( NonEmpty LocalId + , Map LocalId Sem.VarSymbol + , Sem.Expr + ) +binderAdapterObservation + (firstName, firstLocation) + (secondName, secondLocation) = + evalState + (runExceptT do + firstBinder <- + freshH0Binder + firstLocation + (Just + (Raw.NamedVarAt firstLocation firstName)) + secondBinder <- + freshH0Binder + secondLocation + (Just + (Raw.NamedVarAt secondLocation secondName)) + let firstId = h0BinderId firstBinder + secondId = h0BinderId secondBinder + resolvedBody = + Sem.TermSymbol + Nowhere + (Sem.SymbolMixfix adapterBodySymbol) + [ Sem.TermVar (LocalRef firstId) + , Sem.TermVar (LocalRef secondId) + , Sem.TermVar + (AmbientRef adapterAmbientVariable) + ] + quantifiedTerms = + [ H0QuantifiedTerm + Raw.Universally + firstBinder + [] + , H0QuantifiedTerm + Raw.Existentially + secondBinder + [] + ] + adapted <- + applyH0Quantifiers quantifiedTerms resolvedBody + >>= lowerH0Expr + assignments <- gets legacyLocalTokens + pure + ( firstId :| [secondId] + , assignments + , adapted + )) + initialGlossState + +namedSetEquality :: Text -> Raw.Stmt +namedSetEquality name = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + binderLocation + (Just + (Raw.NamedVarAt binderLocation name)) + [] + Nothing + :| [] + ) + (equalityVerbPhrase + equalityLocation + (rawTermVar equalityLocation name)) + +constrainedNamedBinder :: Raw.Stmt +constrainedNamedBinder = + Raw.StmtVerbPhrase + ( Raw.TermQuantified + Raw.Universally + binderLocation + ( Raw.NounPhrase + [ Raw.AdjL + modifierLocation + modifierPattern + [rawTermVar modifierLocation "x"] + ] + ( Raw.Noun + nounLocation + subsetNounPattern + [rawTermVar ambientLocation "T"] + ) + (Just + (Raw.NamedVarAt binderLocation "x")) + [] + (Just + (equalityStatement + suchThatLocation + "x" + "x")) + ) + :| [] + ) + (equalityVerbPhrase + equalityLocation + (rawTermVar equalityLocation "x")) + +vacuousSetStatement :: Maybe Raw.VarSymbol -> Raw.Stmt +vacuousSetStatement mayName = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + binderLocation + mayName + [] + Nothing + :| [] + ) + ( Raw.VPAdj + ( Raw.Adj + reflexiveLocation + reflexivePattern + [] + :| [] + ) + ) + +duplicateSiblingStatement :: Raw.Stmt +duplicateSiblingStatement = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + firstSiblingLocation + (Just + (Raw.NamedVarAt firstSiblingLocation "same")) + [] + Nothing + :| [ quantifiedSetTerm + Raw.Existentially + secondSiblingLocation + (Just + (Raw.NamedVarAt secondSiblingLocation "same")) + [] + Nothing + ] + ) + ( Raw.VPAdj + ( Raw.Adj + reflexiveLocation + reflexivePattern + [] + :| [] + ) + ) + +nestedShadowingStatement :: Raw.Stmt +nestedShadowingStatement = + Raw.StmtVerbPhrase + ( quantifiedSetTerm + Raw.Universally + outerBinderLocation + (Just + (Raw.NamedVarAt outerBinderLocation "shadow")) + [] + Nothing + :| [] + ) + ( equalityVerbPhrase + nestedEqualityLocation + ( Raw.TermQuantified + Raw.Existentially + innerBinderLocation + ( Raw.NounPhrase + [] + (setNoun innerBinderLocation) + (Just + (Raw.NamedVarAt + innerBinderLocation + "shadow")) + [] + (Just + (equalityStatement + nestedSuchThatLocation + "shadow" + "shadow")) + ) + ) + ) + +quantifiedSetTerm + :: Raw.Quantifier + -> Location + -> Maybe Raw.VarSymbol + -> [Raw.AdjL] + -> Maybe Raw.Stmt + -> Raw.Term +quantifiedSetTerm quantifier location mayName leftAdjectives maySuchThat = + Raw.TermQuantified + quantifier + location + ( Raw.NounPhrase + leftAdjectives + (setNoun location) + mayName + [] + maySuchThat + ) + +setNoun :: Location -> Raw.Noun +setNoun location = + Raw.Noun location setNounPattern [] + +rawTermVar :: Location -> Text -> Raw.Term +rawTermVar location name = + Raw.TermExpr (rawVarAt location name) + +equalityStatement :: Location -> Text -> Text -> Raw.Stmt +equalityStatement location leftName rightName = + Raw.StmtVerbPhrase + (rawTermVar location leftName :| []) + (equalityVerbPhrase + location + (rawTermVar location rightName)) + +equalityVerbPhrase :: Location -> Raw.Term -> Raw.VerbPhrase +equalityVerbPhrase location argument = + Raw.VPAdj + ( Raw.Adj + location + equalityPattern + [argument] + :| [] + ) + +setNounPattern :: Raw.LexicalItemSgPl +setNounPattern = + Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "set[/s]") + "set" + +subsetNounPattern :: Raw.LexicalItemSgPl +subsetNounPattern = + Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "subset[/s] of ?") + "test_subset" + +modifierPattern :: Raw.LexicalItem +modifierPattern = + Raw.mkLexicalItem + (unsafeReadPhrase "related to ?") + "test_modifier" + +equalityPattern :: Raw.LexicalItem +equalityPattern = + Raw.mkLexicalItem + (unsafeReadPhrase "equal to ?") + "eq" + +reflexivePattern :: Raw.LexicalItem +reflexivePattern = + Raw.mkLexicalItem + (unsafeReadPhrase "reflexive") + "test_reflexive" + +adapterBodySymbol :: Raw.FunctionSymbol +adapterBodySymbol = + testFunctionSymbol "adapter_body" 3 + +adapterAmbientVariable :: Sem.VarSymbol +adapterAmbientVariable = + Sem.FreshVar 0 + +binderLocation, equalityLocation, nounLocation, ambientLocation :: Location +binderLocation = mkLocation (FileId 48) 2 7 +equalityLocation = mkLocation (FileId 48) 2 24 +nounLocation = mkLocation (FileId 48) 3 7 +ambientLocation = mkLocation (FileId 48) 3 20 + +modifierLocation, suchThatLocation, reflexiveLocation :: Location +modifierLocation = mkLocation (FileId 48) 3 27 +suchThatLocation = mkLocation (FileId 48) 3 42 +reflexiveLocation = mkLocation (FileId 48) 4 17 + +firstSiblingLocation, secondSiblingLocation :: Location +firstSiblingLocation = mkLocation (FileId 48) 5 7 +secondSiblingLocation = mkLocation (FileId 48) 5 24 + +outerBinderLocation, innerBinderLocation :: Location +outerBinderLocation = mkLocation (FileId 48) 6 7 +innerBinderLocation = mkLocation (FileId 48) 6 31 + +nestedSuchThatLocation, nestedEqualityLocation :: Location +nestedSuchThatLocation = mkLocation (FileId 48) 6 45 +nestedEqualityLocation = mkLocation (FileId 48) 6 20 + +firstAdapterLocation, secondAdapterLocation :: Location +firstAdapterLocation = mkLocation (FileId 48) 7 7 +secondAdapterLocation = mkLocation (FileId 48) 7 19 + +alternateFirstLocation, alternateSecondLocation :: Location +alternateFirstLocation = mkLocation (FileId 48) 8 7 +alternateSecondLocation = mkLocation (FileId 48) 8 19 + +replacementFile :: FileId +replacementFile = FileId 47 + +replacementLocation :: Location +replacementLocation = mkLocation replacementFile 2 1 + +iotaLocation :: Location +iotaLocation = mkLocation (FileId 49) 3 5 + +definiteFunctionLocation :: Location +definiteFunctionLocation = mkLocation (FileId 49) 4 9 + +proofLocalFunctionDefinitionMismatches :: Assertion +proofLocalFunctionDefinitionMismatches = + for_ mismatchCases \(label, proof, expectedError) -> + assertEqual + label + (Left expectedError) + (meaning + [ Raw.BlockProof + proofLocation + proof + proofLocation + ]) + where + mismatchCases = + [ ( "argument and domain binder" + , Raw.DefineFunction + proofLocation + "f" + "x" + (Raw.ExprVar "x") + "y" + (Raw.ExprVar "domain") + (Raw.Omitted proofLocation) + , GlossProofFunctionArgumentMismatch + proofLocation + "x" + "y" + ) + , ( "declared and defined function name" + , Raw.DefineFunctionLocal + proofLocation + "f" + "domain" + (Raw.ExprVar "range") + "g" + "x" + ( ( Raw.ExprVar "x" + , Raw.PropositionalConstant + proofLocation + Raw.IsTop + ) + :| [] + ) + (Raw.Omitted proofLocation) + , GlossProofFunctionNameMismatch + proofLocation + "f" + "g" + ) + ] + proofLocation = mkLocation (FileId 46) 5 9 + +quantifiedFunctionalDefinition :: Assertion +quantifiedFunctionalDefinition = + case meaning [definitionBlock] of + Left + (GlossDefnError + actualLocation + DefnErrorQuantifiedRhsTerm + actualMarker) -> do + assertEqual + "quantified term location" + termLocation + actualLocation + assertEqual + "definition marker" + definitionMarker + actualMarker + Left err -> + assertFailure + ("expected a quantified definition term error, got " + <> show err) + Right _ -> + assertFailure + "expected quantified definition term validation to fail" + where + definitionBlock = + Raw.BlockDefn + blockLocation + Nothing + definitionMarker + ( Raw.DefnFun + [] + ( Raw.Fun + blockLocation + ( Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "value[/s] of ?") + "quantified_function" + ) + ["argument"] + ) + Nothing + ( Raw.TermQuantified + Raw.Existentially + termLocation + ( Raw.NounPhrase + [] + ( Raw.Noun + termLocation + ( Raw.mkLexicalItemSgPl + (unsafeReadPhraseSgPl "set[/s]") + "set" + ) + [] + ) + Nothing + [] + Nothing + ) + ) + ) + definitionMarker = "quantified_definition" + blockLocation = mkLocation (FileId 44) 8 1 + termLocation = mkLocation (FileId 44) 8 29 + +duplicateAbbreviationParameters :: Assertion +duplicateAbbreviationParameters = do + let marker = "duplicate_abbreviation" + duplicate = Raw.NamedVar "duplicate" + expectAbbreviationError + marker + [duplicate, duplicate] + (Raw.ExprVar duplicate) + \case + DuplicateAbbreviationParameters actualVariables -> + assertEqual + "duplicate parameter names" + (duplicate :| []) + actualVariables + err -> + assertFailure + ("expected duplicate abbreviation parameters, got " + <> show err) + +freeAbbreviationBodyVariable :: Assertion +freeAbbreviationBodyVariable = do + let marker = "free_abbreviation_body" + freeVariable = Raw.NamedVar "free" + expectAbbreviationError + marker + ["parameter"] + (Raw.ExprVar freeVariable) + \case + FreeAbbreviationBodyVariables actualVariables -> + assertEqual + "free body variable names" + (freeVariable :| []) + actualVariables + err -> + assertFailure + ("expected free abbreviation variables, got " + <> show err) + +orderedAbbreviationParameters :: Assertion +orderedAbbreviationParameters = do + let first = Raw.NamedVar "first" + second = Raw.NamedVar "second" + third = Raw.NamedVar "third" + firstArgument = closedInteger 11 + secondArgument = closedInteger 22 + thirdArgument = closedInteger 33 + arguments = + [ firstArgument + , secondArgument + , thirdArgument + ] + expectedBody = + Sem.TermSymbol + abbreviationLocation + (Sem.SymbolMixfix abbreviationBodySymbol) + [thirdArgument, firstArgument, secondArgument] + unexpectedArgument = closedInteger (-1) + case meaning + [ abbreviationBlock + abbreviationLocation + "ordered_abbreviation" + [first, second, third] + ( Raw.ExprOp + abbreviationLocation + abbreviationBodySymbol + [ Raw.ExprVar third + , Raw.ExprVar first + , Raw.ExprVar second + ] + ) + ] of + Right + [Sem.BlockAbbr + _actualLocation + _actualMarker + (Sem.Abbreviation _actualSymbol scope)] -> + assertEqual + "instantiated abbreviation body" + expectedBody + ( instantiate + (\parameterIndex -> + nth parameterIndex arguments + ?? unexpectedArgument) + scope + ) + Right blocks -> + assertFailure + ("expected one glossed abbreviation, got " + <> show blocks) + Left err -> + assertFailure + ("expected a valid abbreviation, got " + <> show err) + +expectAbbreviationError + :: Raw.Marker + -> [Raw.VarSymbol] + -> Raw.Expr + -> (AbbreviationParameterError -> Assertion) + -> Assertion +expectAbbreviationError marker parameters body checkError = + case meaning + [ abbreviationBlock + abbreviationLocation + marker + parameters + body + ] of + Left + (GlossAbbreviationError + actualLocation + actualMarker + abbreviationError) -> do + assertEqual + "abbreviation location" + abbreviationLocation + actualLocation + assertEqual + "abbreviation marker" + marker + actualMarker + checkError abbreviationError + Left err -> + assertFailure + ("expected an abbreviation parameter error, got " + <> show err) + Right _ -> + assertFailure + "expected abbreviation parameter validation to fail" + +abbreviationBlock + :: Location + -> Raw.Marker + -> [Raw.VarSymbol] + -> Raw.Expr + -> Raw.Block +abbreviationBlock location marker parameters body = + Raw.BlockAbbr + location + Nothing + marker + ( Raw.AbbreviationEq + ( Raw.SymbolPattern + (testFunctionSymbol + "abbreviation_head" + (length parameters)) + parameters + ) + body + ) + +abbreviationBodySymbol :: Raw.FunctionSymbol +abbreviationBodySymbol = + testFunctionSymbol "abbreviation_body" 3 + +testFunctionSymbol :: Text -> Int -> Raw.FunctionSymbol +testFunctionSymbol name arity = + Raw.mkMixfixItem + (Just (Raw.Command name) : replicate arity Nothing) + (Raw.Marker name) + Raw.NonAssoc + +closedInteger :: Int -> Sem.ExprOf a +closedInteger value = + Sem.TermSymbol + Nowhere + (Sem.SymbolInteger value) + [] + +abbreviationLocation :: Location +abbreviationLocation = + mkLocation (FileId 43) 8 12 + +relationClaim :: Int -> Raw.Block +relationClaim actualParameterCount = + Raw.BlockClaim + Raw.Proposition + relationLocation + Nothing + "relation_arity" + (Raw.Claim [] + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (Raw.ExprVar "x" :| []) + Raw.Positive + (Raw.Relation + relationLocation + relationSymbol + (replicate + actualParameterCount + (Raw.ExprVar "p"))) + (Raw.ExprVar "y" :| []))))) + +relationSymbol :: Raw.RelationSymbol +relationSymbol = + Raw.RelationSymbol + (Raw.Command "parametric") + (Raw.ParameterArity 1) + "parametric" + +relationLocation :: Location +relationLocation = mkLocation (FileId 42) 7 11 diff --git a/source/Felix/Test/Unit/Module.hs b/source/Felix/Test/Unit/Module.hs new file mode 100644 index 0000000..44f0ccb --- /dev/null +++ b/source/Felix/Test/Unit/Module.hs @@ -0,0 +1,9759 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Module (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Module +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as TypedInductive +import Felix.CommandLine qualified as CommandLine +import Felix.Math.Codec +import Felix.Module +import Felix.Parse qualified as Parse +import Felix.Prelude qualified as Prelude +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Source +import Felix.Source.Content qualified as Content +import Felix.Store qualified as Store +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon +import Felix.Syntax.Pragma qualified as Pragma +import Felix.Verification qualified as Verification +import Felix.Workspace qualified as Workspace +import Paths_felix qualified as Paths + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM + ( atomically + , check + , newEmptyTMVarIO + , newTQueueIO + , newTVarIO + , putTMVar + , readTQueue + , readTVar + , takeTMVar + , tryReadTMVar + , tryReadTQueue + , writeTQueue + , writeTVar + ) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad (foldM, when) +import Data.ByteString qualified as ByteString +import Data.Text qualified as StrictText +import Data.Text.Encoding qualified as Text +import Data.IORef + ( IORef + , atomicModifyIORef' + , modifyIORef' + , newIORef + , readIORef + ) +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) +import System.Directory + ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , getPermissions + , setOwnerExecutable + , setPermissions + ) +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO.Async (withAsync, wait) + + +unitTests :: TestTree +unitTests = + testGroup "Typed module inputs" + [ testCase "constructs the empty bootstrap ordinarily" + constructsEmptyBootstrap + , testCase "identifies comment-only reserved input" + identifiesCommentOnlyInput + , testCase "loads and parses the packaged final prelude" + parsesPackagedFinalPrelude + , testCase "renders packaged final-prelude failures" + rendersPackagedPreludeFailures + , testCase "confines exact foundation-leaf completion" + confinesFoundationLeafCompletion + , testCase "builds the confined final prelude" + buildsConfinedFinalPrelude + , testCase "publishes the final prelude as an ordinary sealed root" + publishesFinalPreludeRoot + , testCase "retains exact omitted-proof locations" + retainsExactOmittedProofLocation + , testCase "coalesces syntax without collapsing semantic imports" + coalescesSharedDirectSyntax + , testCase "makes selected source errors terminal" + rejectsUnsupportedTypedSource + , testCase "reuses one verification session for successive checks" + reusesVerificationSession + , testCase "compiles exact declarations across an import" + compilesExactDeclarationGraph + , testCase "compiles and imports exact structures" + compilesExactStructures + , testCase "compiles and caches contextual abbreviations" + compilesContextualAbbreviations + , testCase "rejects an unknown exact structure parent atomically" + rejectsUnknownExactStructureParent + , testCase "compiles exact relation expressions" + compilesExactRelationExpressions + , testCase "resolves source-owned set application" + resolvesSourceOwnedApplication + , testCase "scopes quantified terms in proposition contexts" + confinesExactQuantifiedTerms + , testCase "closes the exact definition declaration boundary" + closesExactDefinitionDeclarationBoundary + , testCase "compiles exact ordinary proofs" + compilesExactOrdinaryProofs + , testCase "restores exact binder and witness proof forms" + restoresExactBinderAndWitnessProofForms + , testCase "restores exact local reasoning and calculations" + restoresExactLocalReasoningAndCalculations + , testCase "selects calculation link failures by source order" + selectsCalculationLinkFailureBySourceOrder + , testCase "compiles and reuses proof-local set definitions" + compilesAndReusesProofLocalSetDefinitions + , testCase "compiles and reuses proof-local function graphs" + compilesAndReusesProofLocalFunctionGraphs + , testCase "restores exact cases and classical contradiction" + confinesTerminalExactContradiction + , testCase "compiles exact separation comprehensions" + compilesExactSeparationComprehensions + , testCase "compiles exact replacement comprehensions" + compilesExactReplacementComprehensions + , testCase "compiles and reuses relational replacement" + compilesAndReusesRelationalReplacement + , testCase "compiles and reuses exact finite sets" + compilesAndReusesExactFiniteSets + , testCase "prepares exact deterministic datatypes" + preparesExactDatatypes + , testCase "rejects nested exact datatype recursion" + rejectsNestedExactDatatypeRecursion + , testCase "compiles and reuses exact datatypes" + compilesAndReusesExactDatatypes + , testCase "prepares exact direct inductives" + preparesExactDirectInductives + , testCase "prepares nested exact inductive recursion" + preparesNestedExactInductiveRecursion + , testCase "compiles transparent nested inductive wrappers" + compilesTransparentNestedInductiveWrappers + , testCase "normalizes nested exact inductive contexts" + normalizesNestedExactInductiveContexts + , testCase "compiles and reuses exact inductives" + compilesAndReusesExactInductives + , testCase "authorizes recursive exact inductives" + authorizesRecursiveExactInductives + , testCase "reuses exact separation validation" + reusesExactSeparationValidation + , testCase "compiles exact source axioms" + compilesExactSourceAxioms + , testCase "does not treat marker-only nouns as the fixed set noun" + doesNotTreatMarkerOnlyNounAsSet + , testCase "rejects proof-local generalization" + rejectsProofLocalGeneralization + , testCase "restores checked set induction" + restoresCheckedSetInduction + , testCase "compiles exact omitted proofs" + compilesExactOmittedProofs + , testCase "propagates and reuses exact escape authority" + reusesExactEscapeAuthority + , testCase "checks continuations after omitted subclaims" + rejectsAfterExactOmittedSubclaim + , testCase "reuses exact proof validation across module misses" + reusesExactProofValidationAcrossModuleMisses + , testCase "rejects declarations of fixed semantics" + rejectsFixedSemanticDeclaration + , testCase "rejects inductive carriers with fixed semantics" + rejectsFixedSemanticInductive + , testCase "keeps exact semantics independent of fixity" + keepsExactSemanticsIndependentOfFixity + , testCase "loads a cached exact producer for a fresh importer" + loadsCachedExactProducerForFreshImporter + , testCase "reports admitted source escapes on fresh, warm, and failure paths" + reportsAdmittedSourceEscapes + , testCase "selects concurrent module failures by source order" + selectsConcurrentModuleFailureDeterministically + , testCase "batches independent structure obligations atomically" + batchesStructureObligationsAtomically + , testCase "speculates dependent proof obligations without admitting ahead" + speculatesDependentProofObligationsWithoutAdmittingAhead + , testCase "starts diamond consumers after sealed acknowledgements" + schedulesDiamondAfterSealedImports + , testCase "classifies typed Vampire failures conservatively" + classifiesTypedVampireFailures + , testCase "retains the exact prefix before a later failure" + retainsExactPrefixBeforeFailure + , testCase "routes every production root through exact checking" + routesProductionVerification + , testCase "installs nonempty implicit prelude evidence" + installsNonemptyImplicitPreludeEvidence + ] + +constructsEmptyBootstrap :: Assertion +constructsEmptyBootstrap = do + foundation <- expectRight Foundation.checkedFoundation + result <- + Module.buildBootstrapPreludeFixture + foundation + unusedResolver + session <- expectRight result + let input = Module.bootstrapPreludeInput session + parsed = Module.identifiedModuleParsed input + sealed = Module.bootstrapPreludeModule session + syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + assertEqual "reserved owner" + preludeModuleName + (Module.identifiedModuleOwner input) + case Module.identifiedModuleBinding input of + Module.ReservedModuleBinding fileId label -> do + assertEqual "diagnostic label" + Prelude.preludeDiagnosticLabel + label + assertEqual "registered display label" + (Just Prelude.preludeDiagnosticLabel) + (lookupFilePath fileId) + assertEqual "registered identity label" + (Just Prelude.preludeDiagnosticLabel) + (lookupFileIdentityPath fileId) + Module.PhysicalModuleBinding source -> + assertFailure + ("bootstrap acquired a physical source: " <> show source) + assertEqual "empty parsed blocks" + [] + (Parse.identifiedParsedModuleBlocks parsed) + assertEqual "exact empty source identity" + (Content.sourceContentIdBytes ByteString.empty) + (Parse.identifiedParsedModuleSourceContentId parsed) + assertEqual "no syntax imports" + [] + (Syntax.moduleSyntaxDirectInputs syntax) + assertEqual "empty local syntax" + [] + (Syntax.canonicalSyntaxDeltaEntries + (Syntax.moduleSyntaxLocalDelta syntax)) + assertEqual "semantic owner" + preludeModuleName + (Semantic.semanticInterfaceOwner semantic) + assertEqual "no semantic imports" + [] + (Semantic.semanticInterfaceDirectInputs semantic) + assertEqual "no semantic declarations" + [] + (Semantic.semanticInterfaceDeclarations semantic) + expectedPrefix <- + expectRight + (Semantic.initialPrefixContextId + (Identity.theoryId foundation) + preludeModuleName + []) + assertEqual "empty sealed prefix" + expectedPrefix + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + +identifiesCommentOnlyInput :: Assertion +identifiesCommentOnlyInput = do + emptySource <- + expectRight + =<< Prelude.parseReservedPreludeSource + Prelude.emptyBootstrapSourceInput + source <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 "% an in-memory comment\n")) + first <- + expectRight + =<< Prelude.parseReservedPreludeSource source + second <- + expectRight + =<< Prelude.parseReservedPreludeSource source + let emptyParsed = Prelude.reservedParsedPreludeModule emptySource + firstParsed = Prelude.reservedParsedPreludeModule first + secondParsed = Prelude.reservedParsedPreludeModule second + assertEqual "reserved live source binding" + Parse.FreshReservedSource + (Parse.freshModuleInputBinding + (Prelude.reservedParsedPreludeInput first)) + assertEqual "comment-only source has no blocks" + [] + (Parse.identifiedParsedModuleBlocks firstParsed) + assertBool "content changes parsed identity" + (Parse.identifiedParsedModuleId emptyParsed + /= Parse.identifiedParsedModuleId firstParsed) + assertEqual "same input has stable parsed identity" + (Parse.identifiedParsedModuleId firstParsed) + (Parse.identifiedParsedModuleId secondParsed) + assertEqual "comments do not change syntax" + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface emptyParsed)) + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface firstParsed)) + +parsesPackagedFinalPrelude :: Assertion +parsesPackagedFinalPrelude = do + path <- Paths.getDataFileName "data/felix-prelude.tex" + expectedBytes <- ByteString.readFile path + source <- expectRight =<< Prelude.loadReservedPreludeSourceInput + assertEqual "exact packaged bytes" + expectedBytes + (Prelude.reservedPreludeSourceBytes source) + assertEqual "reserved owner" + preludeModuleName + (Prelude.reservedPreludeSourceOwner source) + assertEqual "diagnostic label" + Prelude.preludeDiagnosticLabel + (Prelude.reservedPreludeSourceLabel source) + first <- expectRight =<< Prelude.parseReservedPreludeSource source + second <- expectRight =<< Prelude.parseReservedPreludeSource source + let firstInput = Prelude.reservedParsedPreludeInput first + firstParsed = Prelude.reservedParsedPreludeModule first + secondParsed = Prelude.reservedParsedPreludeModule second + assertEqual "no textual imports" + [] + (Parse.freshModuleInputImports firstInput) + assertBool "declaration-bearing source" + (not (null (Parse.identifiedParsedModuleBlocks firstParsed))) + assertEqual "deterministic syntax interface" + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface firstParsed)) + (Syntax.moduleSyntaxAssertedId + (Parse.identifiedParsedModuleSyntaxInterface secondParsed)) + +rendersPackagedPreludeFailures :: Assertion +rendersPackagedPreludeFailures = do + assertEqual "load failure" + "/missing/felix-prelude.tex: unable to read packaged final prelude: not found" + (Prelude.renderPreludeLoadError + (Prelude.PreludeSourceReadFailed + "/missing/felix-prelude.tex" + "not found")) + assertEqual "located syntax failure" + "<felix-prelude>: syntax pragma location is out of range at 7:3" + (Prelude.renderPreludeParseError parseFailure) + assertEqual "authority-free API presentation" + ("packaged final prelude parsing failed: " + <> "<felix-prelude>: syntax pragma location is out of range at 7:3") + (Workspace.renderAuthorityFreeParseError + (Workspace.AuthorityFreePreludeParseFailed parseFailure)) + where + parseFailure = + Prelude.PreludeSyntaxPragmaFailed + (Pragma.SyntaxPragmaLocationOutOfRange + Prelude.preludeDiagnosticLabel + 7 + 3) + +confinesFoundationLeafCompletion :: Assertion +confinesFoundationLeafCompletion = do + foundation <- expectRight Foundation.checkedFoundation + packaged <- expectRight =<< Prelude.loadReservedPreludeSourceInput + parsed <- expectRight =<< Prelude.parseReservedPreludeSource packaged + matching <- sole "matching foundation claim" + (take 1 + (Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed))) + mismatchInput <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 + "\\begin{proposition}\\label{not_foundation}\n $\\emptyset = \\emptyset$.\n\\end{proposition}\n")) + mismatchParsed <- + expectRight =<< Prelude.parseReservedPreludeSource mismatchInput + mismatch <- sole "mismatching claim" + (Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule mismatchParsed)) + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + explicit <- + admitFoundationClaim + foundation + matching + (Just (Raw.Omitted (locate matching))) + nonmatching <- + admitFoundationClaim + foundation + mismatch + Nothing + committed <- + admitFoundationClaim + foundation + matching + Nothing + pure (explicit, nonmatching, committed) + case outcome of + Right (Declaration.DriverSucceeded + (explicit, nonmatching, committed) + _semantic _prefix _closure) -> do + case explicit of + Left ExactProof.ExactProofFoundationLeafRequiresImplicitAuto{} -> + pure () + Left other -> + assertFailure + ("explicit foundation result: " <> show other) + Right{} -> + assertFailure "explicit foundation proof was accepted" + batch <- expectRight committed + case nonmatching of + Left ExactProof.ExactProofFoundationLeafTargetMismatch{} -> + pure () + Left other -> + assertFailure + ("mismatching foundation result: " <> show other) + Right{} -> + assertFailure "mismatching foundation claim was accepted" + assertEqual "foundation tag" + Foundation.UnivOfContains + (case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) of + Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) -> + tag + authorization -> + error + ("unexpected foundation authorization: " + <> show authorization) + records -> + error + ("unexpected foundation validation count: " + <> show (length records))) + Right Declaration.DriverFailed{} -> + assertFailure "foundation driver failed" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("foundation driver did not seal: " <> show failure) + Left failure -> + assertFailure ("foundation driver did not open: " <> show failure) + where + admitFoundationClaim foundation block proof = + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareFinalPreludeFoundationClaim + foundation block proof) >>= \case + Left failure -> pure (Left failure) + Right prepared -> do + lowered <- + Declaration.runProspectiveLoweringDriver + (ExactProof.lowerPreparedFinalPreludeFoundationClaim + prepared) + checked <- + either Declaration.failDeclarationDriver pure lowered + batch <- + Declaration.admitCheckedDeclaration + checked + ExactProof.authorizeCheckedFinalPreludeFoundationClaim + pure (Right batch) + +buildsConfinedFinalPrelude :: Assertion +buildsConfinedFinalPrelude = do + foundation <- expectRight Foundation.checkedFoundation + FinalPrelude.buildFinalPreludeCandidate + foundation finalPreludeResolver >>= \case + FinalPrelude.FinalPreludeBuilt candidate -> do + assertEqual "confined semantic owner" + preludeModuleName + (Semantic.semanticInterfaceOwner + (FinalPrelude.finalPreludeSemantic candidate)) + assertEqual "confined semantic imports" + [] + (Semantic.semanticInterfaceDirectInputs + (FinalPrelude.finalPreludeSemantic candidate)) + let baseDeltas = + [ delta + | delta <- Semantic.semanticInterfaceDeclarations + (FinalPrelude.finalPreludeSemantic candidate) + , not + (null + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta))) + ] + case baseDeltas of + [delta] -> do + assertEqual "base structure has no facts" + [] + (Semantic.declarationDeltaFacts delta) + assertEqual "base structure has no propositions" + [] + (Semantic.declarationDeltaPropositions delta) + case Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta) of + [descriptor] -> do + assertEqual "base structure is metadata-only" + Nothing + (Semantic.semanticStructureDescriptorPredicate + descriptor) + case Semantic.semanticStructureDescriptorOperations + descriptor of + [operation] -> + case Identity.lookupCheckedObjectContent + (Semantic.semanticStructureOperationObject + operation) + (FinalPrelude.finalPreludeObjects candidate) of + Just Identity.OpaqueObjectContent{} -> pure () + content -> + assertFailure + ("expected opaque carrier, got " + <> show content) + operations -> + assertFailure + ("expected one base operation, got " + <> show operations) + descriptors -> + assertFailure + ("expected one base descriptor, got " + <> show descriptors) + deltas -> + assertFailure + ("expected one base structure delta, got " + <> show (length deltas)) + let role roleName = + maybe + (assertFailure + ("missing final-prelude role " + <> show roleName)) + pure + (FinalPrelude.finalPreludePublicRole + candidate roleName) + omega <- role FinalPrelude.PreludeOmegaObject + naturals <- role FinalPrelude.PreludeNaturalsAlias + assertEqual "naturals expands to Omega" + omega naturals + traverse_ + (void . role) + (Set.toList FinalPrelude.expectedFinalPreludePublicRoles) + let foundationTags = Set.fromList + [ tag + | batch <- + Declaration.pendingModulePrefixBatches + (FinalPrelude.finalPreludePrefix candidate) + , record <- + Declaration.committedBatchProofValidations batch + , Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag) <- + [ Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) + ] + ] + assertBool "protected foundation presentation" + ( Set.fromList + [ Foundation.SetExtensionality + , Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + ] + `Set.isSubsetOf` foundationTags + ) + assertFinalPreludeFoundationAlias + candidate + "pairset_iff" + Foundation.PairSetCharacteristic + assertFinalPreludeFoundationAlias + candidate + "pow_iff" + Foundation.PowerSetCharacteristic + assertRejectsAdditionalOmegaFact candidate + FinalPrelude.FinalPreludeBuildFailed failure prefix -> + assertFailure + ("final prelude failed after " + <> show + (length + (Declaration.pendingModulePrefixBatches prefix)) + <> " declarations: " + <> show failure) + FinalPrelude.FinalPreludeBuildOpenFailed failure -> + assertFailure ("final prelude did not open: " <> show failure) + FinalPrelude.FinalPreludeSourceLoadFailed failure -> + assertFailure ("final prelude did not load: " <> show failure) + FinalPrelude.FinalPreludeSourceParseFailed failure -> + assertFailure ("final prelude did not parse: " <> show failure) + +assertRejectsAdditionalOmegaFact + :: FinalPrelude.FinalPreludeCandidate + -> Assertion +assertRejectsAdditionalOmegaFact candidate = do + omegaId <- + case FinalPrelude.finalPreludePublicRole + candidate FinalPrelude.PreludeOmegaObject of + Just (FinalPrelude.FinalPreludeObjectRole identity) -> + pure identity + role -> + assertFailure ("unexpected Omega role " <> show role) + >> fail "unreachable" + batch <- batchByAlias + (FinalPrelude.finalPreludePrefix candidate) + "prelude_omega" + let delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + propositions = Declaration.committedBatchPropositions batch + certificates <- + maybe + (assertFailure "Omega declaration validation is absent" + >> fail "unreachable") + (pure . Semantic.declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + (omegaBody, extensional, descriptor, extraFact, extraProposition, + extraCertificate) <- + case (facts, propositions, certificates) of + ( [_equationFact, extensionalFact] + , [equationProposition, extensionalProposition] + , [ _equationCertificate + , extensionalCertificate + ] + ) -> do + body <- case Core.frozenCoreTerm + (Identity.checkedPropositionTerm equationProposition) of + Core.CEq Core.TySet + (Core.CGlobal identity) candidateBody + | identity == omegaId -> pure candidateBody + target -> + assertFailure + ("unexpected Omega equation " <> show target) + >> fail "unreachable" + constructionDescriptor <- + case Authority.validationDirectAuthorization + extensionalCertificate of + Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + identity candidateDescriptor) + | identity == omegaId -> pure candidateDescriptor + authorization -> + assertFailure + ("unexpected Omega extensional authority " + <> show authorization) + >> fail "unreachable" + pure + ( body + , Identity.checkedPropositionTerm extensionalProposition + , constructionDescriptor + , extensionalFact + , extensionalProposition + , extensionalCertificate + ) + (candidateFacts, candidatePropositions, candidateCertificates) -> + assertFailure + ("unexpected Omega inventory shape " + <> show + ( length candidateFacts + , length candidatePropositions + , length candidateCertificates + )) + >> fail "unreachable" + case FinalPrelude.validateOmegaFactInventory + omegaId omegaBody extensional descriptor + (facts <> [extraFact]) + aliases + (propositions <> [extraProposition]) + (certificates <> [extraCertificate]) of + Left (FinalPrelude.FinalPreludeFactContentMismatch + "prelude_omega") -> + pure () + result -> + assertFailure + ("additional Omega construction fact was accepted: " + <> show result) + +publishesFinalPreludeRoot :: Assertion +publishesFinalPreludeRoot = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-final-prelude-root" \directory -> do + let path = directory Posix.</> "store.sqlite" + theory = Identity.theoryId foundation + open = do + (_startup, store) <- + Store.openStore path theory >>= expectRight + pure store + bracket open Store.closeStore \store -> do + freshMemo <- Store.newStoreMemo store + session <- + expectRight + =<< Module.acquireFinalPreludeSession + freshMemo store foundation finalPreludeResolver + let input = Module.finalPreludeInput session + sealed = Module.finalPreludeModule session + syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + assertEqual "empty store constructs the final-prelude root" + Module.ModuleRootMiss + (Module.finalPreludeAcquisition session) + assertEqual "final prelude owner" + preludeModuleName + (Module.identifiedModuleOwner input) + assertEqual "final prelude has no semantic parents" + [] + (Semantic.semanticInterfaceDirectInputs semantic) + warmMemo <- Store.newStoreMemo store + warmSession <- expectRight + =<< Module.acquireFinalPreludeSession + warmMemo store foundation unusedResolver + let cached = Module.finalPreludeModule warmSession + assertEqual "persisted final-prelude root is a cache hit" + Module.ModuleRootHit + (Module.finalPreludeAcquisition warmSession) + assertEqual "generic root syntax" + syntax + (Module.sealedTypedModuleSyntax cached) + assertEqual "generic root semantics" + semantic + (Module.sealedTypedModuleSemantic cached) + assertEqual "cached base structure descriptor" + (semanticStructureDescriptors semantic) + (semanticStructureDescriptors + (Module.sealedTypedModuleSemantic cached)) + assertEqual "generic root final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix cached)) + visits <- Store.storeMemoVisits warmMemo + assertEqual "cached prelude validates one artifact root" + 1 + (Store.storeArtifactsValidated visits) + +semanticStructureDescriptors + :: Semantic.SemanticInterface + -> [Semantic.SemanticStructureDescriptor] +semanticStructureDescriptors semantic = + [ descriptor + | delta <- Semantic.semanticInterfaceDeclarations semantic + , descriptor <- Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment delta) + ] + +assertTransparentObjectAlias + :: Module.SealedTypedModule + -> Text + -> Assertion +assertTransparentObjectAlias sealed name = do + target <- localObjectAliasTarget sealed name + assertEqual + ("transparent object for " <> StrictText.unpack name) + Identity.TransparentObject + (Identity.objectIdFamily target) + +localObjectKeyTarget + :: Module.SealedTypedModule + -> Semantic.SemanticGlobalKey + -> IO Identity.ObjectId +localObjectKeyTarget sealed key = do + binding <- sole + ("semantic binding for " <> show key) + [ candidate + | delta <- localSemanticDeltas sealed + , candidate <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + , Semantic.semanticGlobalBindingKey candidate == key + ] + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + +localObjectAliasTarget + :: Module.SealedTypedModule + -> Text + -> IO Identity.ObjectId +localObjectAliasTarget sealed name = do + delta <- localDeltaByAlias sealed name + binding <- sole + ("semantic binding for " <> StrictText.unpack name) + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta)) + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + +checkedPropositionTermByAlias + :: Module.SealedTypedModule + -> Text + -> IO (Core.FrozenCheckedCore Identity.ObjectId) +checkedPropositionTermByAlias sealed name = do + batch <- batchByAlias + (Module.sealedTypedModulePrefix sealed) + name + alias <- sole + ("semantic alias for " <> StrictText.unpack name) + [ candidate + | candidate <- Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch) + , Semantic.semanticAliasName candidate + == Semantic.semanticName name + ] + occurrence <- sole + ("semantic fact for " <> StrictText.unpack name) + [ candidate + | candidate <- Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch) + , Semantic.semanticFactFingerprint candidate + == Semantic.semanticAliasTarget alias + ] + proposition <- sole + ("checked proposition for " <> StrictText.unpack name) + [ candidate + | candidate <- Declaration.committedBatchPropositions batch + , Identity.checkedPropositionId candidate + == Semantic.semanticFactProposition occurrence + ] + pure (Identity.checkedPropositionTerm proposition) + +batchByAlias + :: Declaration.PendingModulePrefix + -> Text + -> IO Declaration.CommittedDeclarationBatch +batchByAlias prefix name = + sole + ("declaration batch for " <> StrictText.unpack name) + [ batch + | batch <- Declaration.pendingModulePrefixBatches prefix + , alias <- Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch) + , Semantic.semanticAliasName alias + == Semantic.semanticName name + ] + +assertFinalPreludeFoundationAlias + :: FinalPrelude.FinalPreludeCandidate + -> Text + -> Foundation.FoundationAxiomTag + -> Assertion +assertFinalPreludeFoundationAlias candidate name tag = do + batch <- batchByAlias + (FinalPrelude.finalPreludePrefix candidate) + name + fact <- sole + ("foundation fact " <> StrictText.unpack name) + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual + ("foundation safety for " <> StrictText.unpack name) + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + validation <- sole + ("foundation validation for " <> StrictText.unpack name) + (Declaration.committedBatchProofValidations batch) + assertEqual + ("exact foundation authority for " <> StrictText.unpack name) + (Authority.CheckedKernelConstruction + (Authority.FoundationLeaf tag)) + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate validation)) + +localDeltaByAlias + :: Module.SealedTypedModule + -> Text + -> IO Semantic.DeclarationInterfaceDelta +localDeltaByAlias sealed name = + sole + ("declaration delta for " <> StrictText.unpack name) + [ delta + | delta <- localSemanticDeltas sealed + , any + ((== Semantic.semanticName name) + . Semantic.semanticAliasName) + (Semantic.declarationDeltaAliases delta) + ] + +localSemanticDeltas + :: Module.SealedTypedModule + -> [Semantic.DeclarationInterfaceDelta] +localSemanticDeltas = + Semantic.semanticInterfaceDeclarations + . Module.sealedTypedModuleSemantic + +retainsExactOmittedProofLocation :: Assertion +retainsExactOmittedProofLocation = do + foundation <- expectRight Foundation.checkedFoundation + source <- + expectRight + (Prelude.reservedPreludeSourceInput + (Text.encodeUtf8 + (StrictText.unlines + [ "\\begin{proposition}\\label{omitted_location}" + , " For all $x$ we have $x = x$." + , "\\end{proposition}" + , "\\begin{proof}" + , " Omitted." + , "\\end{proof}" + ]))) + parsed <- expectRight =<< Prelude.parseReservedPreludeSource source + let blocks = + Parse.identifiedParsedModuleBlocks + (Prelude.reservedParsedPreludeModule parsed) + claim <- sole "omitted claim" + [ block + | block@Raw.BlockClaim{} <- blocks + ] + proof <- sole "omitted proof" + [ sourceProof + | Raw.BlockProof _location sourceProof _end <- blocks + ] + outcome <- + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof claim (Just proof)) + >>= either Declaration.failModuleDriver pure + case outcome of + Right (Declaration.DriverSucceeded + prepared _semantic prefix _closure) -> do + location <- + maybe + (assertFailure "prepared omitted proof lost its location") + pure + (ExactProof.preparedExactProofFirstOmission prepared) + assertEqual "omitted source line" 5 (locLine location) + assertBool "preparation publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure ("omitted preparation failed: " <> show failure) + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("omitted preparation did not seal: " <> show failure) + Left failure -> + assertFailure ("omitted preparation did not open: " <> show failure) + +coalescesSharedDirectSyntax :: Assertion +coalescesSharedDirectSyntax = do + foundation <- expectRight Foundation.checkedFoundation + session <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + root <- getCurrentDirectory + mounts <- + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", root) + , (sourceMountId "library", root Posix.</> "library") + , (sourceMountId "debug", root Posix.</> "debug") + ] + let bootstrapSyntax = + Module.sealedTypedModuleSyntax + (Module.bootstrapPreludeModule session) + syntaxInputs _source = [bootstrapSyntax] + request <- + expectRight + (searchedRoot "test/phase3/typed-shared-root.tex") + workspace <- + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + syntaxInputs + case Parse.parsedWorkspaceModules workspace of + [firstParsed, secondParsed, rootParsed] -> do + first <- seal foundation session firstParsed [] + second <- seal foundation session secondParsed [] + assertEqual "distinct modules share one syntax interface" + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax first)) + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax second)) + assertBool "semantic module owners remain distinct" + (Module.sealedTypedModuleOwner first + /= Module.sealedTypedModuleOwner second) + assertBool "semantic interfaces remain distinct" + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic first) + /= Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic second)) + let rootSyntax = Parse.parsedModuleSyntaxInterface rootParsed + assertEqual "root coalesces the shared direct syntax" + [ Syntax.moduleSyntaxAssertedId bootstrapSyntax + , Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax first) + ] + (Syntax.moduleSyntaxDirectInputs rootSyntax) + sealedRoot <- + seal foundation session rootParsed [first, second] + assertEqual "root retains both semantic imports" + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule session)) + , Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic first) + , Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic second) + ] + (Semantic.semanticInterfaceDirectInputs + (Module.sealedTypedModuleSemantic sealedRoot)) + modules -> + assertFailure + ("unexpected shared-syntax module count: " + <> show (length modules)) + where + seal foundation session parsed direct = do + input <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness session) + unusedResolver + Declaration.FreshValidation + parsed + direct) + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded sealed -> + pure sealed + Module.TypedModuleOpenFailed{} -> + assertFailure "empty typed module did not open" + >> fail "unreachable" + Module.TypedModuleFailed{} -> + assertFailure "empty typed module did not seal" + >> fail "unreachable" + +rejectsUnsupportedTypedSource :: Assertion +rejectsUnsupportedTypedSource = do + result <- + (checkFileFresh + (Provers.vampire + "vampire" + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + "test/phase3/typed-unsupported.tex") + case result of + Right + ( Verification.VerificationCheckingFailure _report + (failure@(Verification.VerificationTypedModuleError + source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactGuardedOpaqueSignature location))) + prefix)) + , _slowReport + ) -> do + assertEqual "failed source" + "test/phase3/typed-unsupported.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertEqual "unsupported source location line" + 2 + (locLine location) + assertEqual "failure retains the initial module prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + let diagnostic = + Verification.renderVerificationDriverError failure + assertBool "diagnostic retains resolved source" + ("project:test/phase3/typed-unsupported.tex" + `StrictText.isInfixOf` diagnostic) + assertBool "diagnostic retains best location" + ("typed-unsupported.tex 2:14" + `StrictText.isInfixOf` diagnostic) + assertBool "diagnostic explains the typed failure" + ("opaque signature cannot have a header assumption" + `StrictText.isInfixOf` diagnostic) + Left err -> + assertFailure ("unexpected verification driver error: " <> show err) + Right{} -> + assertFailure "unsupported typed source was admitted" + +reusesVerificationSession :: Assertion +reusesVerificationSession = + withAcceptedFixtureVampire "felix-session-reuse" \prover -> do + plan <- Store.planStore Store.FreshTemporaryStore >>= expectRight + graph <- Workspace.prepareDefaultSourceGraph source >>= expectRight + Store.withStoreLease plan \lease -> do + opened <- Verification.withVerificationSession lease \session -> do + let request = Verification.CheckRequest + { Verification.checkSourceGraph = graph + , Verification.checkStoreValidationMode = + Verification.FreshStoreValidation + , Verification.checkEffectiveJobs = testSequentialJobs + , Verification.checkVampire = prover + , Verification.checkRequestObserver = + ignoredVerificationRequests + } + first <- + Verification.checkWorkspace session request >>= expectRight + second <- + Verification.checkWorkspace session request >>= expectRight + traverse_ + assertUnsupported + [ Verification.checkVerificationResult first + , Verification.checkVerificationResult second + ] + void (expectRight opened) + where + source = "test/phase3/typed-unsupported.tex" + + assertUnsupported = \case + Verification.VerificationCheckingFailure + _report + Verification.VerificationTypedModuleError{} -> + pure () + other -> + assertFailure + ("successive session check had unexpected result: " + <> show other) + +compilesExactDeclarationGraph :: Assertion +compilesExactDeclarationGraph = do + (_foundation, _bootstrap, workspace, sealedModules) <- + compileExactFixture "test/phase5/exact-importer.tex" + assertEqual "dependency-closed module count" 2 (length sealedModules) + assertEqual "imported-before-importer source order" + [ "test/phase5/exact-producer.tex" + , "test/phase5/exact-importer.tex" + ] + [ safeRelativePathFilePath + (resolvedSourceRelativePath + (Parse.parsedModuleResolved parsed)) + | parsed <- toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + ] + case sealedModules of + [producer, importer] -> do + let producerPrefix = Module.sealedTypedModulePrefix producer + importerPrefix = Module.sealedTypedModulePrefix importer + producerBatches = + Declaration.pendingModulePrefixBatches producerPrefix + importerBatches = + Declaration.pendingModulePrefixBatches importerPrefix + assertEqual "producer declaration batches" 3 + (length producerBatches) + assertEqual "importer declaration batches" 1 + (length importerBatches) + assertEqual "producer declaration order" + [0, 1, 2] + [ localDeclarationOrdinalValue + (Semantic.declarationSlotOrdinal + (Declaration.committedBatchSlot batch)) + | batch <- producerBatches + ] + + let producerDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic producer) + importerDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic importer) + assertEqual "one exact binding per producer declaration" + [1, 1, 1] + (bindingCount <$> producerDeltas) + assertEqual "one exact importer binding" + [1] + (bindingCount <$> importerDeltas) + assertEqual "producer object families" + ["opaque", "transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | batch <- producerBatches + , object <- Declaration.committedBatchObjects batch + ] + + definitionDelta <- sole "producer definition delta" + (drop 2 producerDeltas) + definitionBinding <- sole "producer definition binding" + (bindings definitionDelta) + definitionFact <- sole "producer definition fact" + (Semantic.declarationDeltaFacts definitionDelta) + definitionAlias <- sole "producer definition alias" + (Semantic.declarationDeltaAliases definitionDelta) + assertEqual "definition alias" + (Semantic.semanticName "phase5_definition") + (Semantic.semanticAliasName definitionAlias) + assertEqual "definition is proof-search eligible" + Semantic.SearchEligible + (Semantic.semanticFactSearchEligibility definitionFact) + assertEqual "definition authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority definitionFact)) + definitionBatch <- sole "producer definition batch" + (drop 2 producerBatches) + validation <- + maybe + (assertFailure "definition declaration validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + certificate <- sole "definition validation certificate" + (Semantic.declarationValidationRecordCertificates validation) + assertEqual "direct defining-equation authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + definitionBinding)))) + (Authority.validationDirectAuthorization + certificate) + + aliasDelta <- sole "producer abbreviation delta" + (take 1 (drop 1 producerDeltas)) + aliasBinding <- sole "producer abbreviation binding" + (bindings aliasDelta) + seedDelta <- sole "producer signature delta" + (take 1 producerDeltas) + seedBinding <- sole "producer signature binding" + (bindings seedDelta) + let seedTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget seedBinding) + aliasTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget aliasBinding) + definitionTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + definitionBinding) + assertEqual "abbreviation expands transparently" + (Semantic.TransparentExpansion + aliasTarget) + (Semantic.semanticGlobalBindingTarget aliasBinding) + assertEqual "definition remains a named global" + (Semantic.GlobalReference definitionTarget) + (Semantic.semanticGlobalBindingTarget definitionBinding) + assertEqual "definition content coalesces with its expansion" + aliasTarget + definitionTarget + assertEqual "coalesced definition adds no object" + [] + (Declaration.committedBatchObjects definitionBatch) + aliasBatch <- sole "producer abbreviation batch" + (take 1 (drop 1 producerBatches)) + aliasObject <- sole "producer abbreviation object" + (Declaration.committedBatchObjects aliasBatch) + case Identity.assertedObjectContent aliasObject of + Identity.TransparentObjectContent _theory _coreType body -> + assertEqual + "expanded body retains only the opaque seed" + (Set.singleton seedTarget) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("abbreviation object is not transparent: " + <> show content) + importerBatch <- sole "importer declaration batch" importerBatches + importerDelta <- sole "importer semantic delta" importerDeltas + importerBinding <- sole "importer binding" + (bindings importerDelta) + assertEqual "equal transparent content reuses the producer object" + (Semantic.semanticGlobalBindingTarget definitionBinding) + (Semantic.semanticGlobalBindingTarget importerBinding) + assertEqual "reused transparent content adds no object" + [] + (Declaration.committedBatchObjects importerBatch) + modules -> + assertFailure + ("unexpected exact module count: " <> show (length modules)) + where + bindingCount = length . bindings + + bindings = + Semantic.semanticEnvironmentBindings + . Semantic.declarationDeltaEnvironment + + objectFamilyName :: Identity.ObjectContent -> String + objectFamilyName = \case + Identity.OpaqueObjectContent{} -> "opaque" + Identity.TransparentObjectContent{} -> "transparent" + Identity.IntrinsicObjectContent{} -> "intrinsic" + +compilesExactStructures :: Assertion +compilesExactStructures = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + Temp.withSystemTempDirectory "felix-exact-structures" \directory -> do + let path = directory Posix.</> "store.sqlite" + executable = directory Posix.</> "vampire" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore path (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + carrierOperation <- sole "base carrier operation" + [ operation + | descriptor <- semanticStructureDescriptors + (Module.sealedTypedModuleSemantic + (Module.finalPreludeModule prelude)) + , operation <- + Semantic.semanticStructureDescriptorOperations descriptor + ] + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-structure-child.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + freshRuns <- readIORef runs + warm <- installAndLoadStructures + opened foundation prelude workspace sealed + warmRuns <- readIORef runs + assertEqual "warm structures preserve descriptors" + (structureDescriptors <$> sealed) + (structureDescriptors <$> warm) + assertEqual "warm structures make no prover calls" + freshRuns warmRuns + case sealed of + [parent, child] -> do + let parentBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix parent) + parentDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic parent) + childBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix child) + childDeltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic child) + parentBatch <- sole "parent structure batch" + (take 1 parentBatches) + parentDelta <- sole "parent structure delta" + (take 1 parentDeltas) + parentDescriptor <- sole "parent structure descriptor" + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment parentDelta)) + parentOperation <- sole "parent structure operation" + (Semantic.semanticStructureDescriptorOperations + parentDescriptor) + parentPredicate <- + maybe + (assertFailure "parent structure has no predicate" + >> fail "unreachable") + pure + (Semantic.semanticStructureDescriptorPredicate + parentDescriptor) + assertEqual "structure object family order" + ["opaque", "transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | object <- Declaration.committedBatchObjects parentBatch + ] + assertEqual "structure fact aliases" + [ Semantic.semanticName "pointed_set" + , Semantic.semanticName "pointed_refl" + ] + (Semantic.semanticAliasName + <$> Semantic.declarationDeltaAliases parentDelta) + definitionFact <- sole "structure definition fact" + (take 1 (Semantic.declarationDeltaFacts parentDelta)) + definitionTarget <- + targetForOccurrence parentBatch definitionFact + assertEqual "pointwise structure definition" + (Core.CForall Core.TySet + (Core.CEq Core.TyProp + (Core.CApp + (Core.CGlobal parentPredicate) + (Core.CBound 0)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + definitionTarget + validations <- + maybe + (assertFailure "structure validation is absent" + >> fail "unreachable") + (pure + . Semantic.declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation + parentBatch) + case validations of + definitionValidation : projectionValidation : [] -> do + assertEqual "structure definition authority" + (Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + parentPredicate)) + (Authority.validationDirectAuthorization + definitionValidation) + projectionFact <- sole + "structure projection fact" + (drop 1 + (Semantic.declarationDeltaFacts + parentDelta)) + assertEqual + "projection has independent authority" + (Semantic.semanticFactAuthority projectionFact) + (Authority.validationTarget + projectionValidation) + assertEqual "projection authority is clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Authority.validationTarget + projectionValidation)) + records -> + assertFailure + ("expected two structure validations, got " + <> show records) + assertBool "all parent structure facts are clean" + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + (Semantic.declarationDeltaFacts parentDelta)) + + let claimGlobals marker = do + batch <- batchWithAlias marker parentBatches + occurrence <- sole (marker <> " occurrence") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + Core.canonicalTermGlobals + <$> targetForOccurrence batch occurrence + carrierGlobals <- claimGlobals "pointed_carrier" + operationGlobals <- claimGlobals "pointed_operation" + assertBool "membership uses inherited carrier" + (Semantic.semanticStructureOperationObject carrierOperation + `Set.member` carrierGlobals) + assertBool "implicit and explicit operation share one object" + (Semantic.semanticStructureOperationObject parentOperation + `Set.member` operationGlobals) + + let assertEquivalentClaim surface explicit = do + surfaceTerm <- + checkedPropositionTermByAlias parent surface + explicitTerm <- + checkedPropositionTermByAlias parent explicit + assertEqual + (StrictText.unpack surface + <> " uses the inherited carrier") + explicitTerm + surfaceTerm + assertEquivalentClaim + "pointed_self_member" + "pointed_self_member_explicit" + assertEquivalentClaim + "pointed_self_not_member" + "pointed_self_not_member_explicit" + assertEquivalentClaim + "pointed_self_element" + "pointed_self_element_explicit" + assertEquivalentClaim + "pointed_header_member" + "pointed_header_member_explicit" + + childBatch <- sole "child structure batch" childBatches + childDelta <- sole "child structure delta" childDeltas + childDescriptor <- sole "child structure descriptor" + (Semantic.semanticEnvironmentStructures + (Semantic.declarationDeltaEnvironment childDelta)) + assertEqual "child allocates no replacement operation" + [] + (Semantic.semanticStructureDescriptorOperations + childDescriptor) + assertEqual "child owns only its transparent predicate" + ["transparent"] + [ objectFamilyName + (Identity.assertedObjectContent object) + | object <- Declaration.committedBatchObjects childBatch + ] + modules -> + assertFailure + ("expected parent and child structures, got " + <> show (length modules)) + where + installAndLoadStructures store foundation prelude workspace sealed = do + memo <- Store.newStoreMemo store + case + ( toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + , sealed + ) of + ([parentParsed, childParsed], [parent, child]) -> do + cachedParent <- persistAndLoad memo [] parentParsed parent + cachedChild <- persistAndLoad + memo [cachedParent] childParsed child + pure [cachedParent, cachedChild] + (parsed, modules) -> + assertFailure + ("expected two structure installations, got " + <> show (length parsed) + <> " parsed and " + <> show (length modules) + <> " checked modules") + >> fail "unreachable" + where + preludeModule = Module.finalPreludeModule prelude + + persistAndLoad memo parents parsed sealedModule = do + let input = Module.identifiedPhysicalModule parsed + syntax = Module.sealedTypedModuleSyntax sealedModule + semantic = Module.sealedTypedModuleSemantic sealedModule + key <- expectRight + (Semantic.moduleArtifactKey + (Module.identifiedModuleOwner input) + (Parse.identifiedParsedModuleId + (Module.identifiedModuleParsed input)) + (Semantic.semanticInterfaceDirectInputs semantic) + (Identity.theoryId foundation)) + let artifact = Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + acknowledged <- expectRight + =<< Store.writeSealedModule + store + (Module.sealedTypedModulePrefix sealedModule) + [syntax] + [semantic] + artifact + assertEqual "cached structure artifact acknowledgement" + artifact acknowledged + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + installation <- maybe + (assertFailure "cached structure installation is absent" + >> fail "unreachable") + pure + loaded + expectRight + (Module.cachedSealedTypedModule + foundation + (preludeModule : parents) + installation) + + structureDescriptors = + semanticStructureDescriptors + . Module.sealedTypedModuleSemantic + + objectFamilyName :: Identity.ObjectContent -> String + objectFamilyName = \case + Identity.OpaqueObjectContent{} -> "opaque" + Identity.TransparentObjectContent{} -> "transparent" + Identity.IntrinsicObjectContent{} -> "intrinsic" + + targetForOccurrence batch occurrence = + maybe + (assertFailure "structure proposition is absent" + >> fail "unreachable") + (pure . Core.frozenCoreTerm . Identity.checkedPropositionTerm) + (find + ((== Semantic.semanticFactProposition occurrence) + . Identity.checkedPropositionId) + (Declaration.committedBatchPropositions batch)) + + batchWithAlias marker batches = + maybe + (assertFailure ("missing batch alias " <> marker) + >> fail "unreachable") + pure + (find + (elem (Semantic.semanticName (StrictText.pack marker)) + . fmap Semantic.semanticAliasName + . Semantic.declarationDeltaAliases + . Declaration.committedBatchDelta) + batches) + +compilesContextualAbbreviations :: Assertion +compilesContextualAbbreviations = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + Temp.withSystemTempDirectory "felix-contextual-abbreviation" \directory -> do + let storePath = directory Posix.</> "store.sqlite" + executable = directory Posix.</> "vampire" + relative = "test/phase5/exact-contextual-abbreviation.tex" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace prelude mounts relative + sealed <- sole "contextual abbreviation module" + =<< compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + let deltas = + Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed) + contextualTargets = + [ (identity, requirements) + | delta <- deltas + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + , Semantic.ContextualTransparentExpansion + identity requirements <- + [Semantic.semanticGlobalBindingTarget binding] + ] + assertEqual "contextual target count" 2 + (length contextualTargets) + requirements <- + sole "canonical contextual requirement set" + (nubOrd (snd <$> contextualTargets)) + assertEqual "one structure operation requirement" 1 + (Map.size requirements) + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + traverse_ + (assertReflexiveFact batches) + [ "phase5_context_dot_explicit" + , "phase5_context_inherited" + , "phase5_context_nested" + , "phase5_context_explicit_unique" + ] + + parsed <- pure (Parse.parsedWorkspaceRootModule workspace) + let syntax = Module.sealedTypedModuleSyntax sealed + semantic = Module.sealedTypedModuleSemantic sealed + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + (Semantic.semanticInterfaceDirectInputs semantic) + (Identity.theoryId foundation)) + let artifact = + Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + void + (expectRight + =<< Store.writeSealedModule + opened + (Module.sealedTypedModulePrefix sealed) + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo opened + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo opened key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + installation <- maybe + (assertFailure "contextual cached installation is absent" + >> fail "unreachable") + pure + loaded + cached <- expectRight + (Module.cachedSealedTypedModule + foundation + [Module.finalPreludeModule prelude] + installation) + assertEqual "cached contextual semantic target" + semantic + (Module.sealedTypedModuleSemantic cached) + + runsBeforeConsumer <- readIORef runs + consumerWorkspace <- + parseFinalExactWorkspace prelude mounts + "test/phase5/exact-contextual-abbreviation-consumer.tex" + let consumerParsed = + Parse.parsedWorkspaceRootModule consumerWorkspace + consumerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + consumerParsed + [cached]) + consumer <- Module.runTypedModule consumerInput >>= \case + Module.TypedModuleSucceeded sealedConsumer -> + pure sealedConsumer + Module.TypedModuleOpenFailed failure -> + assertFailure + ("contextual consumer did not open: " <> show failure) + >> fail "unreachable" + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("contextual consumer did not seal: " <> show failure) + >> fail "unreachable" + let consumerTargets = + [ Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding) + | delta <- localSemanticDeltas consumer + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + ] + assertEqual "two contextual consumer declarations" 2 + (length consumerTargets) + void + (sole + "quantified contextual binder matches its explicit parameter" + (nubOrd consumerTargets)) + runsAfterConsumer <- readIORef runs + assertEqual "contextual abbreviations require no prover call" + runsBeforeConsumer runsAfterConsumer + + verifyFailure foundation resolver prelude mounts sealed + "test/phase5/exact-contextual-abbreviation-missing.tex" + (\case + Exact.ExactContextualExpansionNotAvailable location _key -> + assertEqual "missing context line" 5 (locLine location) + failure -> + assertFailure + ("unexpected missing-context failure: " + <> show failure)) + verifyFailure foundation resolver prelude mounts sealed + "test/phase5/exact-contextual-abbreviation-ambiguous.tex" + (\case + Exact.ExactStructureOperationAmbiguous + location _symbol objects -> do + assertEqual "ambiguous operation line" 16 + (locLine location) + assertEqual "two distinct operation objects" 2 + (length objects) + failure -> + assertFailure + ("unexpected operation ambiguity failure: " + <> show failure)) + where + assertReflexiveFact batches marker = do + batch <- maybe + (assertFailure ("missing contextual fact " <> marker) + >> fail "unreachable") + pure + (find + (elem (Semantic.semanticName (StrictText.pack marker)) + . fmap Semantic.semanticAliasName + . Semantic.declarationDeltaAliases + . Declaration.committedBatchDelta) + batches) + proposition <- sole (marker <> " proposition") + (Declaration.committedBatchPropositions batch) + let body = stripClaimEnvelope + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) + case body of + Core.CEq _ left right -> + assertEqual (marker <> " canonical sides") left right + _ -> + assertFailure + (marker <> " did not elaborate to reflexive equality: " + <> show body) + + stripClaimEnvelope = \case + Core.CForall _ body -> stripClaimEnvelope body + Core.CImp _ body -> stripClaimEnvelope body + term -> term + + verifyFailure foundation resolver prelude mounts imported relative checkFailure = do + workspace <- parseFinalExactWorkspace prelude mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + parsed + [imported]) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed failure)) + _prefix -> + checkFailure failure + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed failure))) + _prefix -> + checkFailure failure + Module.TypedModuleSucceeded{} -> + assertFailure (relative <> " was unexpectedly accepted") + Module.TypedModuleOpenFailed failure -> + assertFailure + (relative <> " did not open: " <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + (relative <> " failed unexpectedly: " <> show failure) + +rejectsUnknownExactStructureParent :: Assertion +rejectsUnknownExactStructureParent = + Temp.withSystemTempDirectory "felix-exact-structure-parent" \root -> do + let relative = "entry.tex" + path = root Posix.</> relative + source = + "\\begin{struct}\\label{known_structure}\n" + <> " A known structure $X$ is a onesorted structure.\n" + <> "\\end{struct}\n\n" + <> "\\begin{struct}\\label{invalid_structure}\n" + <> " An invalid structure $X$ is a future structure.\n" + <> "\\end{struct}\n\n" + <> "\\begin{struct}\\label{future_structure}\n" + <> " A future structure $X$ is a onesorted structure.\n" + <> "\\end{struct}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-exact-structure-store" \directory -> do + let storePath = directory Posix.</> "store.sqlite" + executable = directory Posix.</> "vampire" + writeAcceptedFixtureVampire executable + runs <- newIORef (0 :: Int) + let resolver = countingAcceptedResolver executable runs + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \opened -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + opened foundation resolver + mounts <- exactFixtureMounts root + workspace <- parseFinalExactWorkspace prelude mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactStructureNotVisible + location _phrase))) + prefix -> do + assertEqual "unknown parent line" 5 (locLine location) + assertEqual "only the valid structure was published" + 1 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "unknown structure parent was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid structure module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected invalid structure failure: " + <> show failure) + +compilesExactRelationExpressions :: Assertion +compilesExactRelationExpressions = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-relation-expression.tex" + observed <- newIORef [] + withAcceptedFixtureVampire "felix-exact-relation-expression" \prover -> do + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observed + (<> [ [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ]) + (Provers.runPreparedTypedProver prover prepared) + void + (compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace) + assertEqual + "relation expression is ordered-pair membership" + [[True]] + =<< readIORef observed + + missingPair <- + withAcceptedFixtureVampire "felix-exact-relation-expression-missing-pair" \prover -> + (checkFileFresh + prover + "test/phase5/exact-relation-expression-missing-pair.tex") + case missingPair of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactGlobalNotVisible location key)))) + prefix) + , _slowReport + ) -> do + assertEqual "missing ordered-pair provider line" + 2 + (locLine location) + assertEqual "missing ordered-pair semantic key" + (Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.PairSymbol)) + key + assertEqual "missing provider publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected relation-expression failure: " <> show err) + Right{} -> + assertFailure "relation expression without ordered pairing was admitted" + +resolvesSourceOwnedApplication :: Assertion +resolvesSourceOwnedApplication = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + withAcceptedFixtureVampire "felix-exact-application" \prover -> + Temp.withSystemTempDirectory "felix-exact-application" \directory -> do + let storePath = directory Posix.</> "store.sqlite" + resolver = Declaration.vampireResolver + (Provers.runPreparedTypedProver prover) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + store foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-application.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + root <- case reverse sealed of + rootModule : _ -> pure rootModule + [] -> + assertFailure "application fixture root is absent" + >> fail "unreachable" + assertTransparentObjectAlias root "phase5_apply" + let applyKey = Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.ApplySymbol) + applyObject <- localObjectKeyTarget root applyKey + surface <- checkedPropositionTermByAlias + root "phase5_application_surface" + explicit <- checkedPropositionTermByAlias + root "phase5_application_explicit" + assertEqual + "surface and explicit application lower identically" + explicit + surface + assertBool + "surface application resolves through the declared object" + (applyObject `Set.member` Core.frozenCoreGlobals surface) + + missing <- + withAcceptedFixtureVampire "felix-exact-application-missing" + \prover -> + (checkFileFresh + prover + "test/phase5/exact-application-missing.tex") + case missing of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactGlobalNotVisible location key)))) + prefix) + , _slowReport + ) -> do + assertEqual "unresolved application line" 2 (locLine location) + assertEqual "unresolved application key" + (Semantic.SemanticExpressionFunction + (Raw.mixfixPattern Raw.ApplySymbol)) + key + assertEqual "unresolved application publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left failure -> + assertFailure + ("unexpected unresolved application failure: " <> show failure) + Right{} -> + assertFailure "application without its source binding was admitted" + +confinesExactQuantifiedTerms :: Assertion +confinesExactQuantifiedTerms = do + foundation <- expectRight Foundation.checkedFoundation + repository <- getCurrentDirectory + withAcceptedFixtureVampire "felix-exact-quantified-subject" \prover -> + Temp.withSystemTempDirectory "felix-quantified-subject" \directory -> do + let storePath = directory Posix.</> "store.sqlite" + resolver = Declaration.vampireResolver + (Provers.runPreparedTypedProver prover) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + prelude <- + expectRight + =<< acquireFinalPreludeSession + store foundation resolver + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts + "test/phase5/exact-quantified-subject.tex" + sealed <- compileFinalParsedWorkspaceWithResolver + foundation prelude resolver workspace + root <- case reverse sealed of + rootModule : _ -> pure rootModule + [] -> + assertFailure "quantified-subject root is absent" + >> fail "unreachable" + quantified <- checkedPropositionTermByAlias root + "phase5_quantified_subject" + explicit <- checkedPropositionTermByAlias root + "phase5_explicit_quantifier" + assertEqual + "quantified noun subject retains its domain constraint" + explicit + quantified + + propositionWorkspace <- parseFinalExactWorkspace + prelude mounts + "test/phase5/exact-quantified-proposition-terms.tex" + observations <- newIORef [] + let observingResolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem + prepared + request = + Provers.preparedTypedProverRequest + prepared + modifyIORef' observations + (<> [ ( Provers.preparedVerificationRequestId + request + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + , Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries + problem) + ) + ]) + (Provers.runPreparedTypedProver + prover prepared) + freshModules <- + compileFinalParsedWorkspaceWithResolver + foundation prelude observingResolver + propositionWorkspace + freshRoot <- case reverse freshModules of + rootModule : _ -> pure rootModule + [] -> + assertFailure + "quantified proposition-term root is absent" + >> fail "unreachable" + let member left right = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) left) + right + memberAtX = + member (Core.CBound 0) (Core.CBound 1) + expectedFunctionTarget = + Core.CForall Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)) + expectedVerbRequestTarget = + Core.CForall Core.TySet + (Core.CImp memberAtX memberAtX) + expectedVerbProposition = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp memberAtX memberAtX)) + expectedTargets = + [ expectedFunctionTarget + , expectedVerbRequestTarget + ] + ordinaryImplicitAuxiliaries = + [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + , Foundation.PowerSetCharacteristic + ] + freshObservations <- readIORef observations + assertEqual + "nested function and verb terms have exact FOF targets" + [ ( target + , Backend.RouteFof + , ordinaryImplicitAuxiliaries + ) + | target <- expectedTargets + ] + [ (target, route, auxiliaries) + | (_request, target, route, auxiliaries) <- + freshObservations + ] + functionTarget <- checkedPropositionTermByAlias freshRoot + "phase5_quantified_function_argument" + verbTarget <- checkedPropositionTermByAlias freshRoot + "phase5_quantified_verb_argument" + assertEqual "nested function proposition core" + expectedFunctionTarget + (Core.frozenCoreTerm functionTarget) + assertEqual "nested verb proposition core" + expectedVerbProposition + (Core.frozenCoreTerm verbTarget) + let proofRecords moduleValue = + concatMap + Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue)) + proofAuthorizations moduleValue = + Authority.validationDirectAuthorization + . Semantic.proofValidationRecordCertificate + <$> proofRecords moduleValue + case proofAuthorizations freshRoot of + [ Authority.CheckedSourceProof [_functionRequest] + , Authority.CheckedSourceProof [_verbRequest] + ] -> pure () + authorizations -> + assertFailure + ("unexpected quantified-term authority: " + <> show authorizations) + assertBool + "quantified terms add no escape-backed authority" + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + (concatMap + (Semantic.declarationDeltaFacts + . Declaration.committedBatchDelta) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix freshRoot)))) + + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithReadiness + foundation + (Module.finalPreludeReadiness prelude) + unusedResolver + validation + propositionWorkspace + warmRoot <- case reverse warmModules of + rootModule : _ -> pure rootModule + [] -> + assertFailure + "warm quantified proposition-term root is absent" + >> fail "unreachable" + assertEqual "fresh and warm quantified semantic interface" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic warmRoot) + assertEqual "fresh and warm quantified request authority" + (proofAuthorizations freshRoot) + (proofAuthorizations warmRoot) + assertEqual "fresh and warm quantified prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix freshRoot)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warmRoot)) + + negative <- + withAcceptedFixtureVampire "felix-exact-quantified-term-valued" + \prover -> + (checkFileFresh + prover + "test/phase5/exact-quantified-term-valued.tex") + case negative of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactQuantifiedTermRequiresPropositionContext + location))) + prefix) + , _slowReport + ) -> do + assertEqual "term-valued quantified term line" + 2 (locLine location) + assertBool "failed term-valued abbreviation publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + Left failure -> + assertFailure + ("unexpected term-valued quantified-term failure: " + <> show failure) + Right{} -> + assertFailure "term-valued quantified exact term was admitted" + +closesExactDefinitionDeclarationBoundary :: Assertion +closesExactDefinitionDeclarationBoundary = do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + repositoryMounts <- exactFixtureMounts repository + Temp.withSystemTempDirectory "felix-definition-boundary" \directory -> do + mounts <- exactFixtureMounts directory + annotatedText <- + readFile + (repository Posix.</> + "test/phase5/exact-definition-boundary.tex") + let relative = "entry.tex" + sourcePath = directory Posix.</> relative + unannotatedText = + StrictText.unpack + (StrictText.replace + "A set " + "" + (StrictText.pack annotatedText)) + writeFile sourcePath annotatedText + annotatedWorkspace <- + parseExactWorkspace bootstrap mounts relative + annotated <- sole "annotated definition module" + =<< compileParsedWorkspace + foundation bootstrap annotatedWorkspace + assertEqual "annotated definition declaration count" + 4 + (length + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated))) + assertBool "annotated definitions prepare no Vampire validations" + (null (proofValidationRecords annotated)) + let annotatedBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated) + symbolicBatch <- sole "symbolic primary declaration" + (take 1 (drop 2 annotatedBatches)) + wrapperBatch <- sole "functional wrapper declaration" + (take 1 (drop 3 annotatedBatches)) + symbolicObject <- bindingObject "symbolic primary" symbolicBatch + wrapperObject <- bindingObject "functional wrapper" wrapperBatch + wrapperContent <- sole "functional wrapper transparent object" + [ Identity.assertedObjectContent object + | batch <- + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix annotated) + , object <- Declaration.committedBatchObjects batch + , Identity.assertedObjectId object == wrapperObject + ] + case wrapperContent of + Identity.TransparentObjectContent _theory _type body -> + assertEqual + "functional wrapper applies the primary symbolic object" + (Set.singleton symbolicObject) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("functional wrapper is not transparent: " <> show content) + + writeFile sourcePath unannotatedText + unannotatedWorkspace <- + parseExactWorkspace bootstrap mounts relative + unannotated <- sole "unannotated definition module" + =<< compileParsedWorkspace + foundation bootstrap unannotatedWorkspace + assertEqual + "canonical set annotations do not change the semantic interface" + (Module.sealedTypedModuleSemantic unannotated) + (Module.sealedTypedModuleSemantic annotated) + assertEqual + "canonical set annotations do not change declaration identity" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix unannotated)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix annotated)) + assertEqual + "canonical set annotations do not change direct authority" + (directDeclarationAuthorizations unannotated) + (directDeclarationAuthorizations annotated) + + let storePath = directory Posix.</> "store.sqlite" + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix annotated)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warm <- sole "warm annotated definition module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver validation + annotatedWorkspace + assertEqual "warm annotated semantic interface" + (Module.sealedTypedModuleSemantic annotated) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm annotated declaration identity" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix annotated)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm annotated direct authority" + (directDeclarationAuthorizations annotated) + (directDeclarationAuthorizations warm) + assertBool "warm annotated definitions run no prover" + (null (proofValidationRecords warm)) + + annotationFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-annotation-failure.tex" + case annotationFailure of + ( Exact.ExactNonCanonicalSetDefinitionAnnotation location + , prefix + ) -> do + assertEqual "nontrivial annotation line" 2 (locLine location) + assertBool "nontrivial annotation publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "annotation diagnostic gives the explicit migration" + ("total condition in the definiens" + `StrictText.isInfixOf` + Exact.renderExactCompileError + (fst annotationFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected annotation failure: " <> show failure) + + aliasFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-alias-failure.tex" + case aliasFailure of + (Exact.ExactDefinitionCombinedSymbolicAlias location, prefix) -> do + assertEqual "combined symbolic alias line" 2 (locLine location) + assertBool "combined symbolic alias publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "combined alias diagnostic gives the wrapper migration" + ("define the symbolic operator first" + `StrictText.isInfixOf` + Exact.renderExactCompileError (fst aliasFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected combined-alias failure: " <> show failure) + + guardFailure <- exactFailure foundation bootstrap repositoryMounts + "test/phase5/exact-definition-guard-failure.tex" + case guardFailure of + (Exact.ExactGuardedTransparentDefinition location, prefix) -> do + assertEqual "guarded definition line" 2 (locLine location) + assertBool "guarded definition publishes no prefix" + (null (Declaration.pendingModulePrefixBatches prefix)) + assertBool "guard diagnostic gives the total-definition migration" + ("where a corresponding opaque signature form exists" + `StrictText.isInfixOf` + Exact.renderExactCompileError (fst guardFailure)) + (failure, _prefix) -> + assertFailure + ("unexpected guarded-definition failure: " <> show failure) + + assertRussellSetAnnotation bootstrap repository + where + proofValidationRecords moduleValue = + concatMap + Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue)) + + directDeclarationAuthorizations moduleValue = + [ Authority.validationDirectAuthorization certificate + | batch <- + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix moduleValue) + , validation <- + maybeToList + (Declaration.committedBatchDeclarationValidation batch) + , certificate <- + Semantic.declarationValidationRecordCertificates validation + ] + + bindingObject label batch = do + binding <- sole (label <> " semantic binding") + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment + (Declaration.committedBatchDelta batch))) + pure + (Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget binding)) + + exactFailure foundation bootstrap mounts relative = do + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- sole "failed exact definition module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed failure)) + prefix -> + pure (failure, prefix) + result -> + assertFailure + (case result of + Module.TypedModuleSucceeded{} -> + "expected exact definition failure, but the module succeeded" + Module.TypedModuleOpenFailed{} -> + "expected exact definition failure, but the module did not open" + Module.TypedModuleFailed{} -> + "expected an exact compile failure, but checking failed differently") + >> fail "unreachable" + + assertRussellSetAnnotation bootstrap repository = do + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/examples/russell.tex" + parsed <- sole "Russell parity module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + case Parse.identifiedParsedModuleBlocks + (Module.identifiedModuleParsed + (Module.identifiedPhysicalModule parsed)) of + Raw.BlockDefn _location _title _marker + (Raw.Defn [] + (Raw.DefnAdj + (Just (Raw.NounPhrase + [] (Raw.Noun _ noun []) Nothing [] Nothing)) + _subject _adjective) + _statement) : _ -> + assertBool "Russell uses the canonical built-in set noun" + (Lexicon.isBuiltinSetNoun noun) + _ -> + assertFailure + "Russell source does not retain its annotated adjective head" + +compilesExactOrdinaryProofs :: Assertion +compilesExactOrdinaryProofs = + Temp.withSystemTempDirectory "felix-exact-proofs" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proofs.tex" + let executable = root Posix.</> "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = + Backend.typedProblemClaim problem + locals = + Backend.typedProblemLocalPremises problem + modifyIORef' observations + (<> [ ( Vector.length + (Backend.typedProblemGlobalPremises problem) + , Vector.length + locals + , [ Vector.length + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition premise)) + | premise <- Vector.toList locals + ] + , [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + sealed <- + compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + rootModule <- sole "exact proof root" (drop 1 sealed) + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix rootModule) + assertEqual "one definition and five theorem declarations" + 6 + (length batches) + let proofBatches = drop 1 batches + assertEqual "only closed theorem facts are published" + [1, 1, 1, 1, 1] + [ length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + | batch <- proofBatches + ] + assertEqual "proof request aggregation follows source structure" + [1, 2, 2, 1, 1] + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + record) of + Authority.CheckedSourceProof requests -> + length requests + authorization -> + error + ("unexpected exact proof authority: " + <> show authorization) + records -> + error + ("unexpected exact proof validation count: " + <> show (length records)) + | batch <- proofBatches + ] + headerBatch <- sole "header-envelope proof batch" + (take 1 (drop 3 proofBatches)) + headerProposition <- sole "header-envelope checked proposition" + (Declaration.committedBatchPropositions headerBatch) + assertEqual "header-envelope closed target" + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.CBound 1)) + (member + (Core.CBound 0) + (Core.CBound 1))))) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm headerProposition)) + headerFact <- sole "header-envelope published fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta headerBatch)) + assertEqual "header-envelope proof remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority headerFact)) + observed <- readIORef observations + case observed of + (implicitGlobals, 0, [], []) + : [ (0, 1, [1], _structuralMatches) + , (1, 2, [1, 1], _subclaimMatches) + , (0, 0, [], []) + , (0, 1, [1], _followingMatches) + , (0, 1, [2], [True]) + , (generalizedGlobals, 0, [], []) + ] -> do + assertBool "implicit Auto selects visible FOF facts" + (implicitGlobals > 0) + assertBool "generalized Auto selects visible FOF facts" + (generalizedGlobals > 0) + _ -> + assertFailure + ("unexpected exact proof premise policies: " + <> show observed) + where + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + +restoresExactBinderAndWitnessProofForms :: Assertion +restoresExactBinderAndWitnessProofForms = + Temp.withSystemTempDirectory "felix-exact-proof-parity" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-parity.tex" + parsed <- sole "parsed proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claims = [claim | claim@Raw.BlockClaim{} <- blocks] + proofs = + [ proof + | Raw.BlockProof _location proof _end <- blocks + ] + omittedClaim <- + case reverse claims of + claim : _ -> pure claim + [] -> assertFailure "missing omitted witness claim" + >> fail "unreachable" + omittedProof <- + case reverse proofs of + proof : _ -> pure proof + [] -> assertFailure "missing omitted witness proof" + >> fail "unreachable" + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + omittedClaim (Just omittedProof)) + >>= either Declaration.failModuleDriver pure + >>= \case + Right (Declaration.DriverSucceeded + prepared _semantic _prefix _closure) -> + case ExactProof.preparedExactProofFirstOmission prepared of + Just location -> + assertEqual "nested Take retains first omission" + 106 (locLine location) + Nothing -> + assertFailure "nested Take lost its omission" + Right Declaration.DriverFailed{} -> + assertFailure "omitted witness preparation failed" + Right Declaration.DriverSealFailed{} -> + assertFailure "omitted witness preparation did not seal" + Left failure -> + assertFailure + ("omitted witness preparation did not open: " + <> show failure) + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof-parity'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + fresh <- + sole "proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingAcceptedResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "restored proof request count" 17 (length observed) + assertEqual + "restored proof declarations preserve discharge order" + [1, 1, 1, 1, 1, 1, 3, 2, 2, 3, 1] + (proofRequestCounts fresh) + case observed of + first : second : third : fourth : _rest -> do + assertGuardRequest "single bounded fix" 2 first + assertGuardRequest "multiple bounded fix" 3 second + assertGuardRequest "negative bounded fix" 2 third + assertGuardRequest "fix such that" 2 fourth + _ -> assertFailure "missing bounded-fix requests" + case drop 4 observed of + leftFirst : rightFirst : _ -> do + assertSequentialAssumptions "left conjunct first" leftFirst + assertSequentialAssumptions "right conjunct first" rightFirst + _ -> assertFailure "missing conjunction-assumption requests" + assertTakeSequence "bounded TakeVar" (drop 6 observed) + assertTakeSequence "existential Have" (drop 13 observed) + case drop 9 observed of + namedDischarge : _namedFinal : anonymousDischarge : _ -> do + assertExactDischarge "named noun" namedDischarge + assertEqual "named noun opens two witness binders" + 2 + (leadingExistentials + (observedClaimTerm namedDischarge)) + assertExactDischarge "anonymous noun" anonymousDischarge + assertEqual "anonymous noun opens one unnameable binder" + 1 + (leadingExistentials + (observedClaimTerm anonymousDischarge)) + _ -> assertFailure "missing noun-witness requests" + lastBatch <- + case reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) of + batch : _ -> pure batch + [] -> assertFailure "missing restored-proof batches" + >> fail "unreachable" + lastFact <- sole "omitted witness fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta lastBatch)) + assertEqual "omitted continuation remains escape-backed" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority lastFact)) + assertBool "proof-local witnesses publish no objects" + (all + (null . Declaration.committedBatchObjects) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh))) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm restored proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual + "fresh and warm proof validation keys and authority" + (proofValidationRecords fresh) + (proofValidationRecords warm) + assertEqual + "fresh and warm checked proposition identities" + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm)))) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix-shape.tex" + (\case + ExactProof.ExactProofExpectedUniversalGoal location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-assume.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + where + observingAcceptedResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + ProofParityObservation + (snd <$> Vector.toList + (Backend.supportedPropositionSupport claim)) + (Backend.supportedPropositionTerm claim) + [ ( Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + , snd <$> Vector.toList + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition + premise)) + , Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + ) + | premise <- Vector.toList locals + ] + modifyIORef' observations (<> [observation]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + assertGuardRequest label supportCount observation = do + assertEqual (label <> " support") + supportCount + (length (observedClaimSupport observation)) + case observedLocals observation of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact guard") + (observedClaimTerm observation) + local + locals -> + assertFailure + (label <> ": expected one guard, found " + <> show (length locals)) + + assertTakeSequence label observations = + case observations of + discharge : continuation : _ -> do + assertExactDischarge label discharge + assertEqual (label <> " continuation premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- + observedLocals continuation + ] + assertEqual (label <> " continuation witness support") + 2 + (length (observedClaimSupport continuation)) + _ -> assertFailure (label <> ": missing request sequence") + + assertSequentialAssumptions label observation = do + assertEqual (label <> " premise ordinals") + [0, 1] + [ ordinal + | (ordinal, _support, _term) <- observedLocals observation + ] + case observedLocals observation of + (_ordinal, _support, first) : _ -> + assertEqual (label <> " retained source order") + (observedClaimTerm observation) + first + [] -> assertFailure (label <> ": no scoped assumptions") + + assertExactDischarge label discharge = + case observedLocals discharge of + [(_ordinal, _support, local)] -> + assertEqual (label <> " exact existential discharge") + (observedClaimTerm discharge) + local + locals -> + assertFailure + (label <> ": unexpected discharge premises " + <> show (length locals)) + + proofRequestCounts sealed = + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) of + Authority.CheckedSourceProof requests -> length requests + Authority.OmittedAuthorization -> 1 + authorization -> + error ("unexpected restored-proof authority: " + <> show authorization) + records -> + error ("unexpected restored-proof validation count: " + <> show (length records)) + | batch <- Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + ] + + proofValidationRecords sealed = + concatMap Declaration.committedBatchProofValidations + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + + leadingExistentials + :: Core.CanonicalTerm Identity.ObjectId + -> Int + leadingExistentials = \case + Core.CImp + (Core.CForall Core.TySet + (Core.CImp body Core.CFalsum)) + Core.CFalsum -> + 1 + leadingExistentials body + _ -> 0 + +data ProofParityObservation = ProofParityObservation + { observedClaimSupport :: ![Core.CoreType] + , observedClaimTerm :: !(Core.CanonicalTerm Identity.ObjectId) + , observedLocals :: + ![(Natural, [Core.CoreType], Core.CanonicalTerm Identity.ObjectId)] + } + +restoresExactLocalReasoningAndCalculations :: Assertion +restoresExactLocalReasoningAndCalculations = + Temp.withSystemTempDirectory "felix-exact-local-reasoning" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-local-reasoning.tex" + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeAcceptedFixtureVampire executable + observations <- newIORef [] + fresh <- + sole "exact local-reasoning module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "local-reasoning request count" 16 (length observed) + assertEqual "proof forms retain source request order" + [2, 3, 3, 2, 2, 3, 1] + (requestCounts fresh) + case observed of + sufficesImplication : sufficesReduction + : equalityFirst : equalitySecond : equalityContinuation + : biconditionalFirst : biconditionalSecond + : biconditionalContinuation + : quantifiedLink : quantifiedContinuation + : sinceStructuralClaim : sinceStructuralContinuation + : sinceDischarge : sinceClaim : sinceContinuation + : _omittedSufficesImplication + : [] -> do + case localReasoningTarget sufficesImplication of + Core.CImp antecedent conclusion -> do + assertEqual + "Suffices implication starts from the reduction" + (localReasoningTarget sufficesReduction) + antecedent + assertBool + "Suffices keeps its distinct current goal as conclusion" + (conclusion /= antecedent) + implication -> + assertFailure + ("expected Suffices implication, found " + <> show implication) + assertEqual "first equality link uses its destination citation" + 1 (localReasoningGlobalCount equalityFirst) + assertEqual "second equality link uses local-only justification" + 0 (localReasoningGlobalCount equalitySecond) + assertDerivedContinuation + "equality calculation" + [0, 1] + (localReasoningTarget equalityContinuation) + equalityContinuation + assertPairwiseDistinct + "equality links and endpoint" + [ localReasoningTarget equalityFirst + , localReasoningTarget equalitySecond + , localReasoningTarget equalityContinuation + ] + assertEqual "first biconditional link remains proposition equality" + Core.TyProp + (equalityOperandType + (localReasoningTarget biconditionalFirst)) + assertDerivedContinuation + "biconditional calculation" + [0] + (localReasoningTarget biconditionalContinuation) + biconditionalContinuation + assertPairwiseDistinct + "biconditional links and endpoint" + [ localReasoningTarget biconditionalFirst + , localReasoningTarget biconditionalSecond + , localReasoningTarget biconditionalContinuation + ] + assertEqual "quantified calculation closes both binders" + 2 + (leadingForalls + (localReasoningTarget quantifiedLink)) + assertQuantifiedCalculationGuard + (localReasoningTarget quantifiedLink) + assertDerivedContinuation + "quantified calculation" + [0] + (localReasoningTarget quantifiedLink) + quantifiedContinuation + assertEqual + "quantified source goal and derived local retain the same guard shape" + (quantifiedCalculationShape + (localReasoningTarget quantifiedContinuation)) + (quantifiedCalculationShape + (localReasoningTarget quantifiedLink)) + assertQuantifiedCalculationGuard + (localReasoningTarget quantifiedContinuation) + assertEqual "structural Since submits no premise discharge" + [0] + (localReasoningLocalOrdinals sinceStructuralClaim) + assertEqual "structural Since does not duplicate its premise" + [0, 1] + (localReasoningLocalOrdinals + sinceStructuralContinuation) + assertEqual "ATP-backed Since starts from existing locals only" + [0] + (localReasoningLocalOrdinals sinceDischarge) + assertEqual "Since claim sees the admitted discourse premise" + [0, 1] + (localReasoningLocalOrdinals sinceClaim) + assertEqual "Since continuation sees premise then claim" + [0, 1, 2] + (localReasoningLocalOrdinals sinceContinuation) + assertEqual "local-only Since requests select no globals" + [0, 0, 0] + (localReasoningGlobalCount + <$> [sinceDischarge, sinceClaim, sinceContinuation]) + assertEqual "biconditional second link keeps local-only policy" + 0 (localReasoningGlobalCount biconditionalSecond) + _ -> + assertFailure + ("unexpected local-reasoning observations: " + <> show observed) + omittedBatch <- sole "omitted Suffices batch" + (take 1 + (reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + omittedFact <- sole "omitted Suffices fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta omittedBatch)) + assertEqual "Suffices continuation omission reaches final authority" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority omittedFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm local-reasoning module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm local-reasoning validation skips Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm local-reasoning validations" + (validationRecords fresh) + (validationRecords warm) + + assertRejectedPrefix + "Suffices implication failure" foundation bootstrap workspace + executable 0 0 1 + assertRejectedPrefix + "Suffices reduction failure" foundation bootstrap workspace + executable 1 0 2 + assertRejectedPrefix + "middle calculation link failure" foundation bootstrap workspace + executable 3 1 4 + where + observingResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + LocalReasoningObservation + { localReasoningTarget = + Backend.supportedPropositionTerm claim + , localReasoningGlobalCount = Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + [ Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + | premise <- Vector.toList locals + ] + , localReasoningLocalTerms = + [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + | premise <- Vector.toList locals + ] + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + modifyIORef' observations (<> [observation]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + requestCounts sealed = + [ case Declaration.committedBatchProofValidations batch of + [record] -> + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record) of + Authority.CheckedSourceProof requests -> length requests + Authority.OmittedAuthorization -> 1 + direct -> error + ("unexpected local-reasoning authority: " <> show direct) + records -> error + ("unexpected local-reasoning validation count: " + <> show (length records)) + | batch <- Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + ] + + validationRecords = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + + assertDerivedContinuation + label expectedOrdinals expectedEndpoint continuation = do + assertEqual (label <> " local source ordinals") + expectedOrdinals + (localReasoningLocalOrdinals continuation) + case reverse (localReasoningLocalTerms continuation) of + derived : _ -> + assertEqual (label <> " derived endpoint") + expectedEndpoint derived + [] -> + assertFailure + (label <> ": continuation has no derived endpoint") + + assertPairwiseDistinct label terms = + assertEqual (label <> ": " <> show terms) + (length terms) + (Set.size (Set.fromList terms)) + + assertQuantifiedCalculationGuard proposition = + case dropForalls 2 proposition of + Core.CImp constraint endpoint -> do + assertEqual "quantified guard retains both membership bounds" + 2 (countIntrinsic Core.Member constraint) + assertEqual "quantified guard retains its such-that equality" + 1 (countSetEqualities constraint) + case endpoint of + Core.CEq Core.TySet (Core.CBound left) (Core.CBound right) -> + assertBool "quantified endpoint keeps asymmetric binders" + (left /= right) + _ -> + assertFailure + ("unexpected quantified endpoint: " <> show endpoint) + target -> + assertFailure + ("expected quantified guarded implication, found " + <> show target) + + quantifiedCalculationShape proposition = + case dropForalls 2 proposition of + Core.CImp constraint endpoint -> + Just + ( countIntrinsic Core.Member constraint + , countSetEqualities constraint + , endpoint + ) + _ -> Nothing + + dropForalls + :: Int + -> Core.CanonicalTerm Identity.ObjectId + -> Core.CanonicalTerm Identity.ObjectId + dropForalls 0 term = term + dropForalls remaining (Core.CForall _binder body) = + dropForalls (remaining - 1) body + dropForalls _remaining term = term + + countIntrinsic + :: Core.CoreIntrinsicTag + -> Core.CanonicalTerm Identity.ObjectId + -> Int + countIntrinsic intrinsic = \case + Core.CBound{} -> 0 + Core.CGlobal{} -> 0 + Core.CIntrinsic found -> fromEnum (found == intrinsic) + Core.COpaqueInteger{} -> 0 + Core.CApp function argument -> + countIntrinsic intrinsic function + + countIntrinsic intrinsic argument + Core.CLam _binder body -> countIntrinsic intrinsic body + Core.CFalsum -> 0 + Core.CImp premise conclusion -> + countIntrinsic intrinsic premise + + countIntrinsic intrinsic conclusion + Core.CEq _operand left right -> + countIntrinsic intrinsic left + + countIntrinsic intrinsic right + Core.CForall _binder body -> countIntrinsic intrinsic body + + countSetEqualities + :: Core.CanonicalTerm Identity.ObjectId + -> Int + countSetEqualities = \case + Core.CBound{} -> 0 + Core.CGlobal{} -> 0 + Core.CIntrinsic{} -> 0 + Core.COpaqueInteger{} -> 0 + Core.CApp function argument -> + countSetEqualities function + countSetEqualities argument + Core.CLam _binder body -> countSetEqualities body + Core.CFalsum -> 0 + Core.CImp premise conclusion -> + countSetEqualities premise + countSetEqualities conclusion + Core.CEq operand left right -> + fromEnum (operand == Core.TySet) + + countSetEqualities left + + countSetEqualities right + Core.CForall _binder body -> countSetEqualities body + + equalityOperandType = \case + Core.CEq operandType _left _right -> operandType + term -> error ("expected checked equality, found " <> show term) + + leadingForalls + :: Core.CanonicalTerm Identity.ObjectId + -> Int + leadingForalls = \case + Core.CForall _binder body -> 1 + leadingForalls body + _ -> 0 + + assertRejectedPrefix + label foundation bootstrap workspace executable rejectedIndex + expectedPrefix expectedRuns = do + runs <- newIORef (0 :: Int) + parsed <- sole (label <> " parsed module") + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let resolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' runs \current -> + (current + 1, current) + if index == rejectedIndex + then pure + (Right + (Provers.CounterSatisfiable + "focused deterministic rejection")) + else + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed _failure prefix -> + assertEqual + (label <> " publishes only the prior prefix") + expectedPrefix + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure (label <> " unexpectedly succeeded") + Module.TypedModuleOpenFailed failure -> + assertFailure + (label <> " did not open: " <> show failure) + assertEqual (label <> " selects the first rejected request") + expectedRuns =<< readIORef runs + +data LocalReasoningObservation = LocalReasoningObservation + { localReasoningTarget :: !(Core.CanonicalTerm Identity.ObjectId) + , localReasoningGlobalCount :: !Int + , localReasoningLocalOrdinals :: ![Natural] + , localReasoningLocalTerms :: + ![Core.CanonicalTerm Identity.ObjectId] + , localReasoningAuxiliaries :: ![Foundation.FoundationAxiomTag] + } + deriving (Show) + +selectsCalculationLinkFailureBySourceOrder :: Assertion +selectsCalculationLinkFailureBySourceOrder = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-calculation-link-order" \root -> do + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + source = "test/phase7/calculation-link-order.tex" + laterCompleted = root Posix.</> "later-completed" + firstRun = root Posix.</> "first-run" + secondRun = root Posix.</> "second-run" + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + prover + "test/phase3/typed-unsupported.tex") + >>= expectRight) + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "if mkdir \"" <> firstRun <> "\" 2>/dev/null; then" + , " printf '%s\\n' '% SZS status Theorem for calculation-link-order'" + , "elif mkdir \"" <> secondRun <> "\" 2>/dev/null; then" + , " : > \"" <> laterCompleted <> "\"" + , " printf '%s\\n' '% SZS status Theorem for calculation-link-order'" + , "else" + , " printf '%s\\n' '% SZS status CounterSatisfiable for calculation-link-order'" + , "fi" + ]) + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + jobs <- + Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + positions <- newIORef [] + middleStarted <- newEmptyTMVarIO + laterStarted <- newEmptyTMVarIO + releaseMiddle <- newEmptyTMVarIO + let observer = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + modifyIORef' positions (position :) + case ordinal of + 1 -> pure () + 2 -> do + atomically (putTMVar middleStarted ()) + atomically (takeTMVar releaseMiddle) + 3 -> atomically (putTMVar laterStarted ()) + _ -> + assertFailure + ("unexpected calculation request ordinal: " + <> show ordinal) + withAsync + ( + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + prover + source) + >>= expectRight) + \verification -> do + void + (awaitTmvar "middle calculation link" middleStarted) + void + (awaitTmvar "later calculation continuation" laterStarted) + waitForFileSignal + "later calculation continuation" laterCompleted + atomically (putTMVar releaseMiddle ()) + (result, _slowReport) <- wait verification + case result of + Verification.VerificationFailure report failed -> do + assertEqual "middle link failure location" + (source, 10) + ( locFile + (Verification.failedVerificationLocation failed) + , locLine + (Verification.failedVerificationLocation failed) + ) + assertEqual "failed calculation admits no source fact" + [] (Verification.verificationDirectEscapes report) + other -> + assertFailure + ("calculation link order did not reject: " + <> show other) + observedPositions <- + fmap + (\position -> + ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal + position + )) + <$> readIORef positions + assertEqual "all calculation requests executed" + [(1, 1), (1, 2), (1, 3)] + (sort observedPositions) + + writeAcceptedFixtureVampire executable + retryPositions <- newIORef [] + let retryObserver = + Verification.verificationRequestObserver \position _request -> + modifyIORef' retryPositions (position :) + (retry, _retrySlowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + retryObserver + prover + source) + >>= expectRight + case retry of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("calculation rollback retry failed: " <> show other) + retryObserved <- readIORef retryPositions + assertEqual "retry executes the complete calculation proof" + 3 (length retryObserved) + where + awaitTmvar label variable = do + result <- Timeout.timeout 10000000 + (atomically (takeTMVar variable)) + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + +assertProofParityFailure + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> SourceMounts + -> FilePath + -> (ExactProof.ExactProofError -> Bool) + -> Assertion +assertProofParityFailure foundation bootstrap mounts relative matches = do + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- sole "invalid proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed failure)) + prefix -> do + assertBool ("unexpected proof failure: " <> show failure) + (matches failure) + assertBool "failing proof publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "invalid proof-parity module succeeded" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid proof-parity module did not open: " <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected proof-parity module failure: " <> show failure) + +compilesExactSeparationComprehensions :: Assertion +compilesExactSeparationComprehensions = + Temp.withSystemTempDirectory "felix-exact-separation" \root -> do + let relative = "test/phase5/exact-separation.tex" + executable = root Posix.</> "vampire" + failedSource = root Posix.</> relative + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace bootstrap mounts relative + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-separation'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + request = + Provers.preparedTypedProverRequest prepared + globals = + Backend.typedProblemGlobalPremises problem + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedBackendFactReference <$> globals + , all + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> True + Backend.RequiresTh0{} -> False) + globals + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList + (Backend.typedProblemLocalPremises problem) + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + , Provers.preparedVerificationRequestId request + , Provers.preparedVerificationByteCount request + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact separation module" modules + assertExactSeparationModule "fresh" sealed + definition <- batchByAlias + (Module.sealedTypedModulePrefix sealed) + "phase5_separation_definition" + let definitionFacts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definition) + extensional <- sole "searchable separation view" + [ Semantic.semanticFactFingerprint occurrence + | occurrence <- definitionFacts + , Semantic.semanticFactSearchEligibility occurrence + == Semantic.SearchEligible + ] + equation <- sole "explicit separation equation" + [ Semantic.semanticFactFingerprint occurrence + | occurrence <- definitionFacts + , Semantic.semanticFactSearchEligibility occurrence + == Semantic.SearchIneligible + ] + readIORef observations >>= \case + [ ( Backend.RouteFof + , selectedGlobals + , True + , [0] + , [] + , _requestId + , requestBytes + ) ] -> do + assertBool "searchable separation view is selected" + (extensional `elem` selectedGlobals) + assertBool "exact separation equation is not selected" + (equation `notElem` selectedGlobals) + assertBool "separation exact request has bytes" + (requestBytes > 0) + observed -> + assertFailure + ("unexpected implicit separation problem: " + <> show observed) + + createDirectoryIfMissing True (Posix.takeDirectory failedSource) + original <- ByteString.readFile relative + let invalid = + Text.encodeUtf8 + (StrictText.replace + "x \\in A \\mid x = x" + "x \\in x \\mid x = x" + (Text.decodeUtf8 original)) + ByteString.writeFile failedSource invalid + failedMounts <- exactFixtureMounts root + failedWorkspace <- + parseExactWorkspace bootstrap failedMounts relative + let parsed = Parse.parsedWorkspaceRootModule failedWorkspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "x")))) + prefix -> do + assertEqual "invalid separation bound line" + 2 (locLine location) + assertEqual + "invalid separation publishes none of its declaration" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "invalid separation was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("invalid separation module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected invalid separation failure: " + <> show failure) + +compilesAndReusesProofLocalSetDefinitions :: Assertion +compilesAndReusesProofLocalSetDefinitions = + Temp.withSystemTempDirectory "felix-exact-local-definition" \root -> do + let relative = "test/phase5/exact-local-definition.tex" + failedRelative = + "test/phase5/exact-local-definition-failure.tex" + sourcePath = root Posix.</> relative + failedSourcePath = root Posix.</> failedRelative + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + createDirectoryIfMissing True (Posix.takeDirectory failedSourcePath) + ByteString.readFile failedRelative + >>= ByteString.writeFile failedSourcePath + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + freshRuns <- newIORef (0 :: Int) + observations <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRuns (+ 1) + let problem = + Provers.preparedTypedProverLogicalProblem prepared + premises = + Backend.typedProblemLocalPremises problem + definition = + Vector.find + ((== Backend.localPremiseOrdinal 0) + . Backend.typedLocalPremiseOrdinal) + premises + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList premises + , fmap localDefinitionShape definition + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + freshResolver + Declaration.FreshValidation + workspace + assertEqual "fresh local-definition discharge count" + 2 =<< readIORef freshRuns + assertEqual "implicit and local-only definition views" + [ (Backend.RouteFof, [0, 2], Just expectedLocalDefinitionShape) + , (Backend.RouteTh0, [0, 1, 3], Just expectedLocalDefinitionShape) + ] + =<< readIORef observations + fresh <- sole "fresh local-definition module" freshModules + localDefinitionBatch <- sole + "proof-local definition publishes one declaration" + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) + assertEqual "proof-local definition publishes no object" + [] + (Declaration.committedBatchObjects localDefinitionBatch) + assertEqual "proof-local definition publishes only its theorem" + 1 + (length + (Declaration.committedBatchPropositions + localDefinitionBatch)) + localDefinitionFact <- sole + "proof-local definition theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta + localDefinitionBatch)) + assertEqual "proof-local definition remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority localDefinitionFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm local-definition proof skips Vampire" + 0 =<< readIORef warmRuns + warm <- sole "warm local-definition module" warmModules + assertEqual "warm local-definition semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm local-definition prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + + failedWorkspace <- + parseExactWorkspace bootstrap mounts failedRelative + let failedParsed = + Parse.parsedWorkspaceRootModule failedWorkspace + failedInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + failedParsed + []) + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "B"))))) + prefix -> do + assertEqual "self-reference rejection line" + 6 (locLine location) + assertBool "failed local definition publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "self-referential local definition was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("local-definition failure fixture did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected local-definition failure: " + <> show failure) + where + localDefinitionShape premise = + let proposition = + Backend.typedLocalPremiseProposition premise + in ( fmap + snd + (Vector.toList + (Backend.supportedPropositionSupport proposition)) + , Backend.supportedPropositionTerm proposition + ) + + expectedLocalDefinitionShape = + ( [Core.TySet, Core.TySet] + , Core.CForall Core.TySet + (Core.CEq Core.TyProp + (member (Core.CBound 0) (Core.CBound 1)) + (andP + (member (Core.CBound 0) (Core.CBound 2)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + ) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + + andP left right = + Core.CImp + (Core.CImp left (Core.CImp right Core.CFalsum)) + Core.CFalsum + +compilesAndReusesProofLocalFunctionGraphs :: Assertion +compilesAndReusesProofLocalFunctionGraphs = + Temp.withSystemTempDirectory "felix-exact-local-function" \root -> do + let relative = "test/phase5/exact-local-function.tex" + failedRelative = + "test/phase5/exact-local-function-failure.tex" + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts relative + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + premises = + [ ( Backend.typedProblemRoute problem + , fmap snd + (Vector.toList + (Backend.supportedPropositionSupport + proposition)) + , Backend.supportedPropositionTerm proposition + ) + | premise <- + Vector.toList + (Backend.typedProblemLocalPremises problem) + , let proposition = + Backend.typedLocalPremiseProposition premise + ] + modifyIORef' observations (<> premises) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + allObserved <- readIORef observations + let observed = + [ (route, proposition) + | (route, support, proposition) <- allObserved + , support == [Core.TySet, Core.TySet] + , isJust (localFunctionPair proposition) + ] + assertBool + ("the local graph characteristic reaches a discharge: " + <> show allObserved) + (not (null observed)) + for_ observed \(route, proposition) -> do + assertEqual "local function characteristic stays on FOF" + Backend.RouteFof route + assertExactLocalFunctionCharacteristic proposition + freshRoot <- sole "fresh local-function root" + (take 1 (reverse freshModules)) + rootBatch <- sole "local function publishes only its theorem" + (drop 1 + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix freshRoot))) + assertEqual "local function publishes no object" + [] (Declaration.committedBatchObjects rootBatch) + assertEqual "local function publishes only its theorem" + 1 + (length + (Declaration.committedBatchPropositions rootBatch)) + assertEqual "local function publishes no semantic binding" + [] + (Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment + (Declaration.committedBatchDelta rootBatch))) + rootFact <- sole "local-function theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta rootBatch)) + assertEqual "local-function theorem remains clean" + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority rootFact)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation workspace + assertEqual "warm local-function graph skips Vampire" + 0 =<< readIORef warmRuns + warmRoot <- sole "warm local-function root" + (take 1 (reverse warmModules)) + assertEqual "warm local-function semantic interface" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic warmRoot) + assertEqual "warm local-function prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix freshRoot)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warmRoot)) + + failedWorkspace <- + parseExactWorkspace bootstrap mounts failedRelative + failedInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failedWorkspace) + []) + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "f"))))) + prefix -> do + assertEqual "self-reference rejection line" + 6 (locLine location) + assertBool "failed local function publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "self-referential local function was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("local-function failure fixture did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected local-function failure: " + <> show failure) + where + assertExactLocalFunctionCharacteristic proposition = do + pair <- + maybe + (assertFailure "local function characteristic has wrong shape") + pure + (localFunctionPair proposition) + assertEqual "local function uses the exact replacement characteristic" + (expectedLocalFunctionCharacteristic pair) + proposition + + localFunctionPair proposition = + case Set.toList (Core.canonicalTermGlobals proposition) of + [pair] + | proposition == expectedLocalFunctionCharacteristic pair -> + Just pair + _ -> + Nothing + + expectedLocalFunctionCharacteristic pair = + Core.CForall Core.TySet + (Core.CEq Core.TyProp + (member (Core.CBound 0) (Core.CBound 1)) + (existsP + (andP + (member (Core.CBound 0) (Core.CBound 3)) + (Core.CEq Core.TySet + (Core.CBound 1) + (Core.CApp + (Core.CApp + (Core.CGlobal pair) + (Core.CBound 0)) + (Core.CBound 0)))))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + + andP left right = + notP (Core.CImp left (notP right)) + + existsP proposition = + notP (Core.CForall Core.TySet (notP proposition)) + + notP proposition = + Core.CImp proposition Core.CFalsum + +confinesTerminalExactContradiction :: Assertion +confinesTerminalExactContradiction = + Temp.withSystemTempDirectory "felix-exact-contradiction" \directory -> do + let acceptedExecutable = directory Posix.</> "accepted-vampire" + contradictoryExecutable = directory Posix.</> "contradictory-vampire" + storePath = directory Posix.</> "store.sqlite" + writeAcceptedFixtureVampire acceptedExecutable + writeFile contradictoryExecutable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status ContradictoryAxioms for exact-contradiction'" + ]) + permissions <- getPermissions contradictoryExecutable + setPermissions contradictoryExecutable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-cases-contradiction.tex" + assertEmptyCaseAstRejected foundation bootstrap workspace + observations <- newIORef [] + fresh <- + sole "cases and contradiction module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingResolver + acceptedExecutable + contradictoryExecutable + observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "cases and contradiction request count" + 8 (length observed) + case observed of + branchOne : branchTwo : branchThree : exhaustive + : byContradiction : arbitraryContradiction + : omittedLaterBranch : omittedExhaustive : [] -> do + assertEqual "case branches have isolated local ordinals" + [[0], [1], [2]] + (localReasoningLocalOrdinals + <$> [branchOne, branchTwo, branchThree]) + assertEqual "exhaustiveness sees pre-case locals only" + [] (localReasoningLocalOrdinals exhaustive) + case + ( localReasoningLocalTerms branchOne + , localReasoningLocalTerms branchTwo + , localReasoningLocalTerms branchThree + ) of + ([caseOne], [caseTwo], [caseThree]) -> + assertEqual + "case exhaustiveness is left-associated in source order" + (orP (orP caseOne caseTwo) caseThree) + (localReasoningTarget exhaustive) + branchTerms -> + assertFailure + ("unexpected branch-local premises: " + <> show branchTerms) + assertEqual "proof by contradiction targets falsum" + Core.CFalsum + (localReasoningTarget byContradiction) + assertBool + "double-negation elimination is not an ATP auxiliary" + (Foundation.DoubleNegationElim + `notElem` localReasoningAuxiliaries byContradiction) + case localReasoningLocalTerms byContradiction of + [Core.CImp negatedGoal Core.CFalsum] -> + assertEqual + "proof by contradiction assumes the exact negated goal" + (localReasoningTarget branchOne) + negatedGoal + locals -> + assertFailure + ("unexpected contradiction locals: " + <> show locals) + assertEqual "arbitrary terminal contradiction targets falsum" + Core.CFalsum + (localReasoningTarget arbitraryContradiction) + assertEqual "omitted case does not leak into its sibling" + [1] + (localReasoningLocalOrdinals omittedLaterBranch) + assertEqual "omitted exhaustiveness sees no branch local" + [] (localReasoningLocalOrdinals omittedExhaustive) + _ -> + assertFailure + ("unexpected cases/contradiction observations: " + <> show observed) + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh) of + [caseBatch, byContradictionBatch, terminalBatch, omittedBatch] -> do + traverse_ + (assertBatchSafety Authority.cleanAuthoritySafety) + [caseBatch, byContradictionBatch, terminalBatch] + assertBatchSafety + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + omittedBatch + batches -> + assertFailure + ("unexpected cases/contradiction declaration count: " + <> show (length batches)) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm cases and contradiction module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver + acceptedExecutable warmRuns) + validation + workspace + assertEqual "warm structural proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm structural proof validations" + (proofValidations fresh) + (proofValidations warm) + + failureWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-case-failure.tex" + assertCaseFailure + "middle case branch" + foundation bootstrap failureWorkspace acceptedExecutable 1 2 + assertCaseFailure + "case exhaustiveness" + foundation bootstrap failureWorkspace acceptedExecutable 3 4 + + directWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-direct-contradictory.tex" + directParsed <- sole "direct contradictory parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter directWorkspace)) + directInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + (Declaration.vampireResolver + (runWith contradictoryExecutable)) + Declaration.FreshValidation + directParsed + []) + Module.runTypedModule directInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + _location + Declaration.VampireObligationRejected{})) + prefix -> + assertBool + "direct contradictory input publishes no theorem" + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "direct contradictory input was accepted" + where + observingResolver acceptedExecutable contradictoryExecutable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + target = Backend.supportedPropositionTerm claim + modifyIORef' observations + (<> [ LocalReasoningObservation + { localReasoningTarget = target + , localReasoningGlobalCount = + Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + [ Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + | premise <- Vector.toList locals + ] + , localReasoningLocalTerms = + Backend.supportedPropositionTerm + . Backend.typedLocalPremiseProposition + <$> Vector.toList locals + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + ]) + runWith + (if target == Core.CFalsum + then contradictoryExecutable + else acceptedExecutable) + prepared + + runWith executable prepared = + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + assertEmptyCaseAstRejected foundation bootstrap workspace = do + parsed <- sole "cases parsed module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claim <- sole "cases source claim" + [ candidate + | candidate@Raw.BlockClaim{} <- take 1 blocks + ] + location <- + case + [ found + | Raw.BlockProof _ (Raw.ByCase found _cases) _ <- blocks + ] of + found : _ -> pure found + [] -> + assertFailure "cases source proof is absent" + >> fail "unreachable" + let preludeModule = Module.bootstrapPreludeModule bootstrap + outcome <- Declaration.runModuleDriver + foundation + (moduleName (Parse.parsedModuleAddress parsed)) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic preludeModule) + ] + unusedResolver + Declaration.FreshValidation do + Declaration.importSealedModuleDriver + (Module.sealedTypedModuleEvidence preludeModule) + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + claim + (Just (Raw.ByCase location []))) + case outcome of + Right (Declaration.DriverSucceeded + (Left (ExactProof.ExactProofEmptyCaseSplit found)) + _semantic prefix _closure) -> do + assertEqual "empty case AST failure location" + location found + assertBool "empty case AST publishes no declaration" + (null (Declaration.pendingModulePrefixBatches prefix)) + _ -> + assertFailure "empty programmatic case split was not rejected" + + assertBatchSafety expected batch = do + fact <- sole "structural proof fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual "structural proof authority safety" + expected + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + + proofValidations = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + + assertCaseFailure + label foundation bootstrap workspace executable rejectedIndex + expectedRuns = do + runs <- newIORef (0 :: Int) + parsed <- sole (label <> " parsed module") + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let resolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' runs \current -> + (current + 1, current) + if index == rejectedIndex + then pure + (Right + (Provers.CounterSatisfiable + "focused case rejection")) + else runWith executable prepared + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool + (label <> " publishes no declaration") + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure (label <> " unexpectedly succeeded") + assertEqual + (label <> " selects failures in source order") + expectedRuns =<< readIORef runs + + orP left right = Core.CImp (Core.CImp left Core.CFalsum) right + +compilesExactReplacementComprehensions :: Assertion +compilesExactReplacementComprehensions = + Temp.withSystemTempDirectory "felix-exact-replacement" \root -> do + let relative = "test/phase5/exact-replacement.tex" + executable = root Posix.</> "vampire" + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace bootstrap mounts relative + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-replacement'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact replacement module" modules + assertExactReplacementModule sealed + assertEqual + "replacement proof uses its checked characteristic on TH0" + [( Backend.RouteTh0 + , [Foundation.ReplacementCharacteristic] + )] + =<< readIORef observations + +assertExactReplacementModule + :: Module.SealedTypedModule + -> Assertion +assertExactReplacementModule sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + definitionObject <- sole + "replacement definition object" + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual "replacement definition type" + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual "replacement definition body" + expectedBody + body + assertEqual "replacement definition foundation helpers" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies body) + content -> + assertFailure + ("unexpected replacement object " <> show content) + let definitionDelta = + Declaration.committedBatchDelta definitionBatch + definitionFacts = + Semantic.declarationDeltaFacts definitionDelta + assertEqual "replacement definition fact count" + 2 (length definitionFacts) + assertEqual "replacement equation/search view eligibility" + [Semantic.SearchIneligible, Semantic.SearchEligible] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + assertEqual "replacement generated view is unaliased" + 1 + (length (Semantic.declarationDeltaAliases definitionDelta)) + assertEqual "replacement definition proposition count" + 2 + (length + (Declaration.committedBatchPropositions definitionBatch)) + assertEqual "replacement definition proof validations" + [] + (Declaration.committedBatchProofValidations definitionBatch) + definitionValidation <- + maybe + (assertFailure "replacement validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + definitionValidation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation target) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + generatedTarget _descriptor) + ] -> + assertEqual "replacement construction authority object" + target generatedTarget + authorizations -> + assertFailure + ("unexpected replacement definition authorities " + <> show authorizations) + + assertEqual "replacement theorem adds no object" + [] + (Declaration.committedBatchObjects theoremBatch) + assertEqual "replacement theorem fact count" + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch))) + assertEqual "replacement theorem proposition count" + 1 + (length + (Declaration.committedBatchPropositions theoremBatch)) + theoremValidation <- sole + "replacement theorem validation" + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + ("unexpected replacement theorem authority " + <> show authorization) + batches -> + assertFailure + ("expected replacement definition and theorem, found " + <> show (length batches)) + where + app1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + app2 intrinsic first second = + Core.CApp (app1 intrinsic first) second + expectedBody = + Core.CLam Core.TySet $ + app1 Core.FamilyUnion $ + app2 Core.Repl (Core.CBound 0) $ + Core.CLam Core.TySet $ + app2 Core.Repl + (app2 Core.Sep + (Core.CBound 0) + (Core.CLam Core.TySet $ + Core.CEq Core.TySet + (Core.CBound 1) + (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CBound 0)) + +compilesAndReusesRelationalReplacement :: Assertion +compilesAndReusesRelationalReplacement = + Temp.withSystemTempDirectory "felix-exact-relational-replacement" \root -> do + let relative = "test/phase5/exact-relational-replacement.tex" + failureRelative = + "test/phase5/exact-relational-replacement-failure.tex" + localFailureRelative = + "test/phase5/exact-relational-replacement-local-failure.tex" + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + workspace <- parseExactWorkspace bootstrap mounts relative + observed <- newIORef [] + runs <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList + (Backend.typedProblemLocalPremises problem) + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + fresh <- sole "fresh relational replacement module" freshModules + assertRelationalReplacementModule fresh + problems <- readIORef observed + assertEqual "relational replacement request count" + 3 (length problems) + firstProblem <- sole "module functionality request" (take 1 problems) + assertEqual "module functionality uses FOF" + Backend.RouteFof + (case firstProblem of (route, _, _) -> route) + assertEqual "module functionality has no local premises" + [] + (case firstProblem of (_, ordinals, _) -> ordinals) + assertEqual + "relational equivalence creates no ATP obligation or auxiliary" + [ (Backend.RouteFof, [], []) + , (Backend.RouteFof, [], []) + , (Backend.RouteFof, [0], []) + ] + problems + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation workspace + assertEqual "warm relational replacement skips Vampire" + 0 =<< readIORef warmRuns + warm <- sole "warm relational replacement module" warmModules + assertEqual "warm relational replacement interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm relational replacement prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + + let rejectingResolver = + Declaration.vampireResolver \_prepared -> + pure + (Right + (Provers.CounterSatisfiable + "relational functionality rejected")) + runRejected relativePath = do + failedWorkspace <- + parseExactWorkspace bootstrap mounts relativePath + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + rejectingResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failedWorkspace) + []) + Module.runTypedModule input + runRejected failureRelative >>= \case + Module.TypedModuleFailed _failure prefix -> do + batches <- pure + (Declaration.pendingModulePrefixBatches prefix) + assertEqual "failed relational definition keeps its prefix" + 1 (length batches) + prefixBatch <- sole "relational prefix declaration" batches + assertEqual "failed relational definition publishes no object" + 1 (length + (Declaration.committedBatchObjects prefixBatch)) + _result -> + assertFailure + "nonfunctional relational definition did not fail" + runRejected localFailureRelative >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool + "failed local functionality publishes no theorem" + (null + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure + "nonfunctional local definition did not fail" + +assertRelationalReplacementModule + :: Module.SealedTypedModule + -> Assertion +assertRelationalReplacementModule sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_axiomBatch, definitionBatch, proofBatch] -> do + _object <- sole "relational replacement object" + (Declaration.committedBatchObjects definitionBatch) + let definitionFacts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definitionBatch) + assertEqual "relational replacement fact eligibility" + [ Semantic.SearchIneligible + , Semantic.SearchIneligible + , Semantic.SearchEligible + ] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + let sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + assertEqual "relational extensionality inherits functionality safety" + [ Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + ] + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> definitionFacts + ) + assertEqual "relational replacement has only its equation alias" + 1 + (length + (Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta definitionBatch))) + validation <- + maybe + (assertFailure "relational replacement validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation equationObject) + , Authority.CheckedSourceProof [_functionalityRequest] + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + extensionalObject _descriptor) + ] -> + assertEqual "relational facts target one object" + equationObject extensionalObject + authorizations -> + assertFailure + ("unexpected relational authorities " + <> show authorizations) + assertEqual "module construction generates no proof row" + [] + (Declaration.committedBatchProofValidations definitionBatch) + + proofValidation <- sole "proof-local relational validation" + (Declaration.committedBatchProofValidations proofBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + proofValidation) of + Authority.CheckedSourceProof requests -> + assertEqual + "local functionality precedes its continuation" + 2 (length requests) + authorization -> + assertFailure + ("unexpected proof-local relational authority " + <> show authorization) + proofFact <- sole "proof-local relational theorem" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta proofBatch)) + assertEqual "local extensional premise retains discharge safety" + sourceSafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority proofFact)) + batches -> + assertFailure + ("expected relational axiom, definition, and proof, found " + <> show (length batches)) + +compilesAndReusesExactFiniteSets :: Assertion +compilesAndReusesExactFiniteSets = + Temp.withSystemTempDirectory "felix-exact-finite-set" \root -> do + let relative = "test/phase5/exact-finite-set.tex" + sourcePath = root Posix.</> relative + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-finite-set'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + observations <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observations + (<> [ ( Backend.typedProblemRoute problem + , Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + ) + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation + workspace + fresh <- sole "fresh finite-set module" freshModules + assertExactFiniteSetModule "fresh" fresh + assertEqual + "finite-set proof uses exactly its FOF characteristics" + [( Backend.RouteFof + , [ Foundation.EmptyCharacteristic + , Foundation.PairSetCharacteristic + , Foundation.FamilyUnionCharacteristic + ] + )] + =<< readIORef observations + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm finite-set proof skips Vampire" + 0 + =<< readIORef warmRuns + warm <- sole "warm finite-set module" warmModules + assertExactFiniteSetModule "warm" warm + assertEqual "warm finite-set semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm finite-set final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + +preparesExactDirectInductives :: Assertion +preparesExactDirectInductives = do + foundation <- expectRight Foundation.checkedFoundation + prepared <- + expectRight + =<< prepareExactInductiveFixture + "test/phase5/exact-inductive.tex" + assertEqual "exact inductive carrier type" + (Core.TyArrow Core.TySet Core.TySet) + (ExactInductive.preparedExactInductiveCarrierType prepared) + assertEqual "exact inductive carrier body" + expectedCarrier + (Core.frozenCoreTerm + (ExactInductive.preparedExactInductiveCarrierBody prepared)) + assertEqual "foundation guard needs no imported fact" + [] + (Vector.toList + (ExactInductive.preparedExactInductiveGuardTargets prepared)) + let facts = + toList + (ExactInductive.preparedExactInductiveFacts prepared) + assertEqual "generated fact order" + [ Raw.Marker "phase5_fin_intro_1" + , Raw.Marker "phase5_fin_dom_subset" + , Raw.Marker "phase5_fin_cases" + , Raw.Marker "phase5_fin_induct" + ] + (TypedInductive.typedInductiveFactMarker <$> facts) + assertEqual "generated guarded-rule descriptors" + [ Set.singleton Foundation.SetLfpFixed + , Set.singleton Foundation.SetLfpBound + , Set.singleton Foundation.SetLfpFixed + , Set.singleton Foundation.SetLfpInduct + ] + ( Set.fromList + . toList + . TypedInductive.typedInductiveFactRules + <$> facts + ) + assertBool "generated targets are closed propositions" + (all + (\fact -> + let target = TypedInductive.typedInductiveFactTarget fact + in Core.frozenCoreType target == Core.TyProp + && Set.null (Core.frozenCoreGlobals target)) + facts) + + let singleton = + Internal.finiteSet + Nowhere + (Internal.EmptySet Nowhere :| []) + noGlobalType :: Void -> Core.CoreType + noGlobalType = absurd + noGlobal + :: Internal.Symbol + -> Maybe (TypedInductive.SourceGlobal Void) + noGlobal = const Nothing + finite <- + expectRight + (TypedInductive.prepareTypedInductive + noGlobalType + foundation + noGlobal + (Internal.Marker "finite_internal") + (TypedInductive.DirectInductive + [] + singleton + (TypedInductive.DirectInductiveClause + [] + [] + (Internal.EmptySet Nowhere) + :| []))) + finiteGuard <- + sole + "finite-set inductive guard" + (Vector.toList + (TypedInductive.typedInductiveGuardTargets finite)) + assertEqual + "typed inductive path uses intrinsic finite-set adjunction" + (member + (Core.CIntrinsic Core.Empty) + (Core.canonicalSetInsert + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty))) + (Core.frozenCoreTerm finiteGuard) + where + apply1 intrinsic argument = + Core.CApp (Core.CIntrinsic intrinsic) argument + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + expectedCarrier = + Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.ISetLfp) + (apply1 Core.UnivOf (Core.CBound 0))) + (Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (apply1 Core.UnivOf (Core.CBound 1))) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 2)))))) + +preparesExactDatatypes :: Assertion +preparesExactDatatypes = do + (foundation, owner, prepared) <- + expectRight + =<< prepareExactDatatypeFixture + "test/phase5/exact-datatype.tex" + let objects = + toList + (ExactDatatype.preparedExactDatatypeObjects prepared) + objectIds = fst <$> objects + objectTypes = snd <$> objects + expectedTypes = + [ Core.TySet + , Core.TySet + , Core.TyArrow Core.TySet Core.TySet + , Core.TyArrow Core.TySet + (Core.TyArrow Core.TySet Core.TySet) + ] + theory = Identity.theoryId foundation + expectedIds = + [ Identity.opaqueObjectId theory + (Identity.opaqueDeclarationSeed + owner + (localDeclarationOrdinal 0) + DatatypeDeclaration + (generatedObjectSlot index)) + coreType + | (index, coreType) <- zip [0 ..] expectedTypes + ] + assertEqual "datatype opaque object types" + expectedTypes objectTypes + assertEqual "datatype opaque object slots" + expectedIds objectIds + assertBool "datatype objects are opaque" + (all ((== Identity.OpaqueObject) . Identity.objectIdFamily) objectIds) + (carrierId, zeroId, atomId, joinId, constructorIds) <- + case expectedIds of + [carrier, zero, atom, join] -> + pure + ( carrier + , zero + , atom + , join + , zero :| [atom, join] + ) + _ -> + assertFailure "datatype object inventory is incomplete" + >> fail "unreachable" + let facts = + toList + (ExactDatatype.preparedExactDatatypeFacts prepared) + markers = + ExactDatatype.preparedExactDatatypeFactMarker <$> facts + assertEqual "datatype generated fact order" + [ Internal.Marker "phase5_data_phasefivezero_intro" + , Internal.Marker "phase5_data_phasefiveatom_intro" + , Internal.Marker "phase5_data_phasefivejoin_intro" + , Internal.Marker + "phase5_data_phasefivezero_phasefiveatom_distinct" + , Internal.Marker + "phase5_data_phasefivezero_phasefivejoin_distinct" + , Internal.Marker + "phase5_data_phasefiveatom_phasefivejoin_distinct" + , Internal.Marker "phase5_data_phasefiveatom_injective" + , Internal.Marker "phase5_data_phasefivejoin_injective" + , Internal.Marker "phase5_data_cases" + , Internal.Marker "phase5_data_induct" + ] + markers + assertBool "datatype generated targets are checked propositions" + (all + (\fact -> + Core.frozenCoreType + (ExactDatatype.preparedExactDatatypeFactTarget fact) + == Core.TyProp) + facts) + atomIntroduction <- + sole "domain-bearing datatype introduction" + [ fact + | fact <- facts + , ExactDatatype.preparedExactDatatypeFactMarker fact + == Internal.Marker "phase5_data_phasefiveatom_intro" + ] + assertEqual "domain-bearing datatype introduction target" + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + singletonEmpty) + (member + (Core.CApp + (Core.CGlobal atomId) + (Core.CBound 0)) + (Core.CGlobal carrierId)))) + (Core.frozenCoreTerm + (ExactDatatype.preparedExactDatatypeFactTarget + atomIntroduction)) + induction <- + sole "datatype induction law" + [ fact + | fact <- facts + , ExactDatatype.preparedExactDatatypeFactMarker fact + == Internal.Marker "phase5_data_induct" + ] + assertEqual "datatype induction target" + (Core.CForall Core.TySet + (Core.CImp + (conjunctions + [ member + (Core.CGlobal zeroId) + (Core.CBound 0) + , Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + singletonEmpty) + (member + (Core.CApp + (Core.CGlobal atomId) + (Core.CBound 0)) + (Core.CBound 1))) + , Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (conjunction + (member + (Core.CBound 1) + (Core.CBound 2)) + (member + (Core.CBound 0) + (Core.CBound 2))) + (member + (Core.CApp + (Core.CApp + (Core.CGlobal joinId) + (Core.CBound 1)) + (Core.CBound 0)) + (Core.CBound 2)))) + ]) + (Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.CGlobal carrierId)) + (member + (Core.CBound 0) + (Core.CBound 1)))))) + (Core.frozenCoreTerm + (ExactDatatype.preparedExactDatatypeFactTarget induction)) + assertEqual "datatype descriptor membership" + (Authority.datatypeCompilationDescriptor + carrierId + constructorIds + (ExactDatatype.preparedExactDatatypeFactReference <$> facts)) + (ExactDatatype.preparedExactDatatypeDescriptor prepared) + where + singletonEmpty = + Core.canonicalSetInsert + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + + conjunction left right = + Core.CImp + (Core.CImp left (Core.CImp right Core.CFalsum)) + Core.CFalsum + + conjunctions = \case + [] -> Core.CImp Core.CFalsum Core.CFalsum + first : remaining -> foldl' conjunction first remaining + +rejectsNestedExactDatatypeRecursion :: Assertion +rejectsNestedExactDatatypeRecursion = do + result <- + prepareExactDatatypeFixture + "test/phase5/exact-datatype-nested.tex" + case result of + Left ExactDatatype.ExactDatatypeInvalid{} -> pure () + Left failure -> + assertFailure + ("unexpected nested datatype failure: " <> show failure) + Right _prepared -> + assertFailure "nested exact datatype recursion was accepted" + +compilesAndReusesExactDatatypes :: Assertion +compilesAndReusesExactDatatypes = + Temp.withSystemTempDirectory "felix-exact-datatype" \directory -> do + let relative = "test/phase5/exact-datatype.tex" + storePath = directory Posix.</> "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh exact datatype module" freshModules + assertExactDatatypeModule "fresh" fresh + parsed <- + sole "exact datatype parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let artifact sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + freshArtifact <- artifact fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm exact datatype module" warmModules + assertExactDatatypeModule "warm" warm + assertEqual "warm exact datatype semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm exact datatype final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm exact datatype module artifact" + freshArtifact + =<< artifact warm + + mounts <- exactFixtureMounts =<< getCurrentDirectory + nestedWorkspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-datatype-nested.tex" + nestedParsed <- + sole "nested exact datatype module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter + nestedWorkspace)) + nestedInput <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + nestedParsed + []) + Module.runTypedModule nestedInput >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactDatatypeFailed + (ExactDatatype.ExactDatatypeInvalid + location _message))) + prefix -> do + assertEqual "nested datatype failure line" + 4 + (locLine location) + assertBool "nested datatype publishes no prefix" + (null + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "unexpected nested datatype result" + +preparesNestedExactInductiveRecursion :: Assertion +preparesNestedExactInductiveRecursion = + withAcceptedFixtureVampire "felix-nested-inductive" \vampire -> do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-nested.tex" + parsed <- sole "nested exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + observed <- newIORef [] + let resolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + ) + ]) + (Provers.runPreparedTypedProver vampire prepared) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + sealed <- sole "nested exact inductive module" modules + observations <- readIORef observed + assertEqual "guard proof plus nested monotonicity request count" + 2 (length observations) + (route, target) <- + sole "nested monotonicity request" + [ observation + | observation@(_route, candidate) <- observations + , candidate == expectedPowerMonotonicity + ] + assertEqual "nested monotonicity target" + expectedPowerMonotonicity + target + assertEqual "nested monotonicity request is first-order" + Backend.RouteFof + route + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_guardBatch, _unsafeBatch, inductiveBatch] -> do + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + aliases = + Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta inductiveBatch) + sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom) + assertEqual "nested inductive fact eligibility" + ( Semantic.SearchEligible + : Semantic.SearchIneligible + : replicate 4 Semantic.SearchEligible + ) + (Semantic.semanticFactSearchEligibility <$> facts) + monotonicityFact <- case facts of + _definition : fact : _laws -> pure fact + _ -> assertFailure "nested inductive fact inventory" + >> fail "unreachable" + assertEqual "nested monotonicity fact is unaliased" + False + (Semantic.semanticFactFingerprint monotonicityFact + `elem` (Semantic.semanticAliasTarget <$> aliases)) + assertEqual "nested authority safety reaches generated laws" + [ Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + , Authority.cleanAuthoritySafety + , sourceSafety + , sourceSafety + ] + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- + maybe + (assertFailure "nested inductive validation is absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual "nested inductive candidate authority shape" + [ "definition" + , "source-proof" + , "kernel" + , "kernel" + , "kernel" + , "kernel" + ] + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + requestId <- nestedRequestId inductiveBatch + Temp.withSystemTempDirectory + "felix-nested-inductive-cache" \temporary -> do + let storePath = temporary Posix.</> "store.sqlite" + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix sealed)) + let warmValidation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation + store) + (expectRightIO + . Store.loadDeclarationValidation + store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver + warmValidation workspace + warm <- sole + "warm nested exact inductive module" + warmModules + warmBatch <- case + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm) of + [_warmGuard, _warmUnsafe, batch] -> pure batch + batches -> + assertFailure + ("warm nested batch count: " + <> show (length batches)) + >> fail "unreachable" + assertEqual "warm nested exact request" + requestId + =<< nestedRequestId warmBatch + assertEqual "warm nested semantic interface" + (Module.sealedTypedModuleSemantic sealed) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm nested admitted prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix sealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + freshArtifact <- + moduleArtifact + foundation bootstrap parsed sealed + warmArtifact <- + moduleArtifact + foundation bootstrap parsed warm + assertEqual "warm nested module artifact" + freshArtifact warmArtifact + batches -> + assertFailure + ("expected guard and nested inductive batches, found " + <> show (length batches)) + + failureWorkspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-nested-failure.tex" + successfulRequests <- newIORef [] + let successfulResolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' successfulRequests + (<> [Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem)]) + (Provers.runPreparedTypedProver vampire prepared) + successfulModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap successfulResolver + Declaration.FreshValidation failureWorkspace + successful <- sole + "successful repeated/distinct nested inductive module" + successfulModules + assertEqual + "repeated and distinct contexts use two monotonicity requests" + [ expectedPowerMonotonicity + , expectedDoublePowerMonotonicity + ] + =<< readIORef successfulRequests + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix successful) of + [_guardOne, _guardTwo, batch] -> do + validation <- maybe + (assertFailure + "successful multi-context validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + assertEqual + "deduplicated monotonicities precede all kernel laws" + ( ["definition", "source-proof", "source-proof"] + <> replicate 6 "kernel" + ) + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + batches -> + assertFailure + ("successful multi-context batch count: " + <> show (length batches)) + attempts <- newIORef (0 :: Int) + let rejectingResolver = + Declaration.vampireResolver \prepared -> do + index <- atomicModifyIORef' attempts \current -> + (current + 1, current) + if index == 0 + then pure + (Right + (Provers.CounterSatisfiable + "first monotonicity rejected")) + else + (Provers.runPreparedTypedProver vampire prepared) + failureInput <- + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + rejectingResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule failureWorkspace) + []) + Module.runTypedModule failureInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "earliest monotonicity failure location" + 14 (locLine location) + assertEqual + "later monotonicity still resolves before first rejection" + 2 =<< readIORef attempts + assertEqual + "rejected monotonicity preserves only earlier declarations" + 2 + (length + (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure + "nested monotonicity rejection unexpectedly succeeded" + where + authorizationKind = \case + Authority.CheckedKernelConstruction + Authority.CheckedDefinitionEquation{} -> "definition" + Authority.CheckedKernelConstruction{} -> "kernel" + Authority.CheckedSourceProof{} -> "source-proof" + authorization -> show authorization + + nestedRequestId batch = do + validation <- maybe + (assertFailure "nested declaration validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- case + Semantic.declarationValidationRecordCertificates validation of + _definition : monotonicity : _laws -> pure monotonicity + certificates -> + assertFailure + ("nested declaration certificate count: " + <> show (length certificates)) + >> fail "unreachable" + case Authority.validationDirectAuthorization certificate of + Authority.CheckedSourceProof [request] -> pure request + authorization -> + assertFailure + ("unexpected nested proof authorization " + <> show authorization) + >> fail "unreachable" + + moduleArtifact foundation bootstrap parsed sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + + expectedPowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (Core.CBound 1)) + (power (Core.CBound 0))))))) + + expectedDoublePowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (power (Core.CBound 1))) + (power (power (Core.CBound 0)))))))) + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +compilesTransparentNestedInductiveWrappers :: Assertion +compilesTransparentNestedInductiveWrappers = + withAcceptedFixtureVampire "felix-nested-wrapper" \vampire -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- + parseExactWorkspace bootstrap mounts + "test/phase5/exact-inductive-wrapper.tex" + observed <- newIORef [] + let resolver = + Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + modifyIORef' observed + (<> [ ( Backend.typedProblemRoute problem + , Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + ) + ]) + (Provers.runPreparedTypedProver vampire prepared) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap resolver + Declaration.FreshValidation workspace + sealed <- sole "transparent-wrapper nested module" modules + observations <- readIORef observed + assertEqual "wrapper guard plus monotonicity request count" + 2 (length observations) + (route, target) <- case + [ observation + | observation@(_route, candidate) <- observations + , candidate == expectedPowerMonotonicity + ] of + [observation] -> pure observation + matches -> + assertFailure + ("normalized wrapper monotonicity matches: " + <> show matches + <> "; observed: " <> show observations) + >> fail "unreachable" + assertEqual "transparent-wrapper monotonicity is FOF" + Backend.RouteFof route + assertEqual "transparent-wrapper monotonicity target" + expectedPowerMonotonicity target + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_wrapperDefinition, _guardProof, inductiveBatch] -> do + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + assertEqual "transparent-wrapper inductive stays clean" + (replicate 6 Authority.cleanAuthoritySafety) + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- maybe + (assertFailure + "transparent-wrapper declaration validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual "transparent-wrapper staged authority" + [ "definition" + , "source-proof" + , "kernel" + , "kernel" + , "kernel" + , "kernel" + ] + (authorizationKind + . Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation) + batches -> + assertFailure + ("transparent-wrapper declaration count: " + <> show (length batches)) + where + authorizationKind = \case + Authority.CheckedKernelConstruction + Authority.CheckedDefinitionEquation{} -> "definition" + Authority.CheckedKernelConstruction{} -> "kernel" + Authority.CheckedSourceProof{} -> "source-proof" + authorization -> show authorization + + expectedPowerMonotonicity = + Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (power (Core.CBound 1)) + (power (Core.CBound 0))))))) + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +normalizesNestedExactInductiveContexts :: Assertion +normalizesNestedExactInductiveContexts = do + foundation <- expectRight Foundation.checkedFoundation + powerSymbol <- fixedFunctionSymbol "pow" + carrierSymbol <- fixedFunctionSymbol "cumul" + let a = Internal.NamedVar "A" + x = Internal.NamedVar "x" + y = Internal.NamedVar "y" + z = Internal.NamedVar "z" + carrier = + Internal.TermOp Nowhere carrierSymbol [Internal.TermVar a] + powerCarrier = + Internal.TermOp Nowhere powerSymbol [carrier] + doublePowerCarrier = + Internal.TermOp Nowhere powerSymbol [powerCarrier] + parameterizedCarrier = + Internal.TermOp Nowhere powerSymbol + [ Internal.TermOp Nowhere Lexicon.UpairSymbol + [carrier, Internal.TermVar x] + ] + powerContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] powerCarrier) + doublePowerContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] doublePowerCarrier) + parameterizedContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] parameterizedCarrier) + deduplicated <- + expectRight + (TypedInductive.prepareTypedInductive + (const Core.TySet) + foundation + (const Nothing) + (Internal.Marker "nested_dedup") + (TypedInductive.DirectInductive + [a] + (Internal.EmptySet Nowhere) + (TypedInductive.DirectInductiveClause + [x, y, z] + [ TypedInductive.DirectRecursiveCondition + (Internal.TermVar x) powerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar y) powerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar z) doublePowerContext + , TypedInductive.DirectRecursiveCondition + (Internal.TermVar z) parameterizedContext + ] + (Internal.TermVar a) + :| []))) + assertEqual "equal contexts deduplicate in first-occurrence order" + [ monotonicityTarget 4 power + , monotonicityTarget 4 (power . power) + , monotonicityTarget 4 + (\hole -> power (pair hole (Core.CBound 4))) + ] + ( Core.frozenCoreTerm + . TypedInductive.typedInductiveMonotonicityTarget + <$> Vector.toList + (TypedInductive.typedInductiveMonotonicities deduplicated) + ) + + let wrapperSymbol = + Raw.mkMixfixItem + [ Just (Internal.Command "phasefivecheckedwrapper") + , Just Internal.InvisibleBraceL + , Nothing + , Just Internal.InvisibleBraceR + ] + (Internal.Marker "phasefivecheckedwrapper") + Raw.NonAssoc + wrapperCarrier = + Internal.TermOp Nowhere wrapperSymbol [carrier] + wrapperContext <- + expectRight + (TypedInductive.prepareRecursiveCarrierContext + carrierSymbol [a] wrapperCarrier) + wrapperBody <- + expectRight + (Core.checkCanonicalCore + (const Nothing) + (Core.CLam Core.TySet + (power (Core.CBound 0)))) + let wrapperId = + Identity.transparentObjectId + (Identity.theoryId foundation) + (Core.TyArrow Core.TySet Core.TySet) + (Core.frozenCoreTerm wrapperBody) + wrapped <- + expectRight + (TypedInductive.prepareTypedInductive + (const (Core.TyArrow Core.TySet Core.TySet)) + foundation + (\symbol -> + if symbol == Internal.SymbolMixfix wrapperSymbol + then Just + (TypedInductive.SourceGlobal + wrapperId (Just wrapperBody)) + else Nothing) + (Internal.Marker "nested_wrapper") + (TypedInductive.DirectInductive + [a] + (Internal.EmptySet Nowhere) + (TypedInductive.DirectInductiveClause + [x] + [TypedInductive.DirectRecursiveCondition + (Internal.TermVar x) wrapperContext] + (Internal.TermVar a) + :| []))) + assertEqual + "transparent content, not a primitive-name whitelist, owns context semantics" + [monotonicityTarget 2 power] + ( Core.frozenCoreTerm + . TypedInductive.typedInductiveMonotonicityTarget + <$> Vector.toList + (TypedInductive.typedInductiveMonotonicities wrapped) + ) + assertBool "transparent context target contains no wrapper global" + (all + (Set.null + . Core.frozenCoreGlobals + . TypedInductive.typedInductiveMonotonicityTarget) + (Vector.toList + (TypedInductive.typedInductiveMonotonicities wrapped))) + + assertExactFailure + "test/phase5/exact-inductive-wrong-arguments.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveCarrierWrongArguments{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-outside-membership.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveCarrierOutsideMembership{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-element.tex" + 4 + (\case + ExactInductive.ExactInductiveRecursiveTermMentionsCarrier{} -> + True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-domain.tex" + 2 + (\case + ExactInductive.ExactInductiveDomainMentionsCarrier{} -> True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-recursive-result.tex" + 4 + (\case + ExactInductive.ExactInductiveResultMentionsCarrier{} -> True + _ -> False) + assertExactFailure + "test/phase5/exact-inductive-unsupported-context.tex" + 4 + (\case + ExactInductive.ExactInductiveUnsupportedRecursiveCarrierContext{} -> + True + _ -> False) + where + fixedFunctionSymbol marker = + sole ("fixed function " <> StrictText.unpack marker) + [ symbol + | symbol <- Lexicon.prefixOps + , Raw.mixfixMarker symbol == Internal.Marker marker + ] + + assertExactFailure relative expectedLine expected = + prepareExactInductiveFixture relative >>= \case + Left failure + | expected failure -> + assertEqual + ("nested-context failure line for " <> relative) + expectedLine + (locLine + (ExactInductive.exactInductiveErrorLocation + failure)) + | otherwise -> + assertFailure + ("unexpected nested-context failure for " + <> relative <> ": " <> show failure) + Right{} -> + assertFailure + ("unsupported nested context was accepted: " <> relative) + + monotonicityTarget + :: Int + -> (Core.CanonicalTerm Identity.ObjectId + -> Core.CanonicalTerm Identity.ObjectId) + -> Core.CanonicalTerm Identity.ObjectId + monotonicityTarget sourceBinders context = + foldr + (const (Core.CForall Core.TySet)) + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (subset (Core.CBound 1) (Core.CBound 0)) + (subset + (context (Core.CBound 1)) + (context (Core.CBound 0)))))) + [1 .. sourceBinders] + + power argument = + Core.CApp (Core.CIntrinsic Core.PowerSet) argument + + pair left right = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.PairSet) left) + right + + subset left right = + Core.CForall Core.TySet + (Core.CImp + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 left)) + (member + (Core.CBound 0) + (Core.shiftCanonical 1 0 right))) + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + +compilesAndReusesExactInductives :: Assertion +compilesAndReusesExactInductives = + Temp.withSystemTempDirectory "felix-exact-inductive" \directory -> do + let relative = "test/phase5/exact-inductive.tex" + storePath = directory Posix.</> "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh exact inductive module" freshModules + assertExactInductiveModule foundation "fresh" fresh + parsed <- + sole "exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let artifact sealed = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + [ Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic + (Module.bootstrapPreludeModule bootstrap)) + ] + (Identity.theoryId foundation)) + pure + (Semantic.moduleArtifactResult + key + (Syntax.moduleSyntaxAssertedId + (Module.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic sealed))) + freshArtifact <- artifact fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm exact inductive module" warmModules + assertExactInductiveModule foundation "warm" warm + assertEqual "warm exact inductive semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm exact inductive final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + assertEqual "warm exact inductive module artifact" + freshArtifact + =<< artifact warm + +authorizesRecursiveExactInductives :: Assertion +authorizesRecursiveExactInductives = + Temp.withSystemTempDirectory "felix-recursive-inductive" \directory -> do + let relative = "test/phase5/exact-inductive-recursive.tex" + storePath = directory Posix.</> "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture relative + fresh <- sole "fresh recursive inductive module" freshModules + assertRecursiveExactInductiveModule "fresh" fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + unusedResolver + validation + workspace + warm <- sole "warm recursive inductive module" warmModules + assertRecursiveExactInductiveModule "warm" warm + assertEqual "warm recursive inductive semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm recursive inductive final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + +assertRecursiveExactInductiveModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertRecursiveExactInductiveModule label sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_axiomBatch, inductiveBatch] -> do + object <- + sole (label <> " recursive inductive carrier") + (Declaration.committedBatchObjects inductiveBatch) + let facts = + Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta inductiveBatch) + sourceSafety = + Authority.authoritySafety + (Authority.singletonEscapeKind + Authority.SourceAxiom) + assertEqual (label <> " recursive inductive safety") + (Authority.cleanAuthoritySafety : replicate 4 sourceSafety) + ( Authority.factAuthoritySafety + . Semantic.semanticFactAuthority + <$> facts + ) + validation <- + maybe + (assertFailure + (label <> ": recursive validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + inductiveBatch) + assertEqual (label <> " recursive inductive descriptors") + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Identity.assertedObjectId object)) + , guardedRules + (Foundation.SetLfpBound :| [Foundation.SetLfpFixed]) + , guardedRules (Foundation.SetLfpBound :| []) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpInduct :| []) + ] + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation + ) + batches -> + assertFailure + (label <> ": expected axiom and inductive batches, found " + <> show (length batches)) + where + guardedRules rules = + Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet rules)) + +assertExactDatatypeModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactDatatypeModule label sealed = do + assertEqual (label <> " datatype semantic declaration count") + 1 + (length + (Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed))) + batch <- + sole (label <> " datatype declaration batch") + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + let objects = Declaration.committedBatchObjects batch + objectIds = Identity.assertedObjectId <$> objects + delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + bindings = + Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + boundIds = + Semantic.semanticGlobalTargetObject + . Semantic.semanticGlobalBindingTarget + <$> bindings + assertEqual (label <> " datatype object count") 4 (length objects) + assertBool (label <> " datatype objects are opaque") + (all + ((== Identity.OpaqueObject) + . Identity.objectIdFamily + . Identity.assertedObjectId) + objects) + assertEqual (label <> " datatype global binding count") + 4 + (length bindings) + assertBool (label <> " datatype globals are references") + (all + (\binding -> + case Semantic.semanticGlobalBindingTarget binding of + Semantic.GlobalReference{} -> True + Semantic.TransparentExpansion{} -> False + Semantic.ContextualTransparentExpansion{} -> False) + bindings) + assertEqual (label <> " datatype global targets") + (Set.fromList objectIds) + (Set.fromList boundIds) + assertEqual (label <> " datatype fact count") 10 (length facts) + assertEqual (label <> " datatype aliases") + (Semantic.semanticName <$> + [ "phase5_data_phasefivezero_intro" + , "phase5_data_phasefiveatom_intro" + , "phase5_data_phasefivejoin_intro" + , "phase5_data_phasefivezero_phasefiveatom_distinct" + , "phase5_data_phasefivezero_phasefivejoin_distinct" + , "phase5_data_phasefiveatom_phasefivejoin_distinct" + , "phase5_data_phasefiveatom_injective" + , "phase5_data_phasefivejoin_injective" + , "phase5_data_cases" + , "phase5_data_induct" + ]) + (Semantic.semanticAliasName <$> aliases) + assertBool (label <> " datatype facts are clean") + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + facts) + assertEqual (label <> " datatype proof validations") + [] + (Declaration.committedBatchProofValidations batch) + validation <- + maybe + (assertFailure (label <> ": datatype validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + descriptor <- + case objectIds of + carrier : firstConstructor : remainingConstructors -> + pure + (Authority.datatypeCompilationDescriptor + carrier + (firstConstructor :| remainingConstructors) + ( Authority.factAuthorityTheorem + . Semantic.semanticFactAuthority + <$> facts + )) + _ -> + assertFailure (label <> ": datatype object family is absent") + >> fail "unreachable" + assertEqual (label <> " datatype validation descriptors") + (replicate 10 + (Authority.TrustedCompilation + (Authority.DatatypeCompilation descriptor))) + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates validation + ) + +assertExactInductiveModule + :: Foundation.CheckedFoundation + -> String + -> Module.SealedTypedModule + -> Assertion +assertExactInductiveModule foundation label sealed = + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [batch] -> do + object <- + sole (label <> " inductive carrier") + (Declaration.committedBatchObjects batch) + case Identity.assertedObjectContent object of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " inductive carrier type") + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual (label <> " inductive carrier identity") + (Identity.transparentObjectId + (Identity.theoryId foundation) + coreType + body) + (Identity.assertedObjectId object) + content -> + assertFailure + (label <> ": unexpected inductive carrier " + <> show content) + let delta = Declaration.committedBatchDelta batch + facts = Semantic.declarationDeltaFacts delta + aliases = Semantic.declarationDeltaAliases delta + assertEqual (label <> " inductive fact count") + 5 + (length facts) + assertEqual (label <> " inductive aliases") + (Semantic.semanticName <$> + [ "phase5_fin" + , "phase5_fin_intro_1" + , "phase5_fin_dom_subset" + , "phase5_fin_cases" + , "phase5_fin_induct" + ]) + (Semantic.semanticAliasName <$> aliases) + assertBool (label <> " inductive facts are clean") + (all + ((== Authority.cleanAuthoritySafety) + . Authority.factAuthoritySafety + . Semantic.semanticFactAuthority) + facts) + assertEqual (label <> " inductive proof validations") + [] + (Declaration.committedBatchProofValidations batch) + validation <- + maybe + (assertFailure + (label <> ": inductive validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + assertEqual (label <> " inductive validation descriptors") + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation + (Identity.assertedObjectId object)) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpBound :| []) + , guardedRules (Foundation.SetLfpFixed :| []) + , guardedRules (Foundation.SetLfpInduct :| []) + ] + ( Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + validation + ) + batches -> + assertFailure + (label <> ": expected one inductive batch, found " + <> show (length batches)) + where + guardedRules rules = + Authority.CheckedKernelConstruction + (Authority.GuardedFoundationRules + (Authority.guardedRuleSet rules)) + +assertExactFiniteSetModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactFiniteSetModule label sealed = do + assertEqual (label <> " finite-set semantic declarations") + 2 + (length + (Semantic.semanticInterfaceDeclarations + (Module.sealedTypedModuleSemantic sealed))) + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + definitionObject <- sole + (label <> " finite-set definition object") + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " finite-set definition type") + (Core.TyArrow Core.TySet + (Core.TyArrow Core.TySet Core.TySet)) + coreType + assertEqual (label <> " finite-set definition body") + expectedBody + body + content -> + assertFailure + (label <> ": unexpected finite-set object " + <> show content) + assertEqual (label <> " finite-set definition fact count") + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta definitionBatch))) + assertEqual (label <> " finite-set definition proof validations") + [] + (Declaration.committedBatchProofValidations definitionBatch) + + assertEqual (label <> " finite-set theorem adds no object") + [] + (Declaration.committedBatchObjects theoremBatch) + theoremFact <- sole + (label <> " finite-set theorem fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch)) + assertEqual (label <> " finite-set theorem safety") + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority theoremFact)) + theoremValidation <- sole + (label <> " finite-set theorem validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + (label <> ": unexpected finite-set theorem authority " + <> show authorization) + batches -> + assertFailure + (label <> ": expected finite-set definition and theorem, found " + <> show (length batches)) + where + expectedBody = + Core.CLam Core.TySet + (Core.CLam Core.TySet + (Core.canonicalSetInsert + (Core.CBound 1) + (Core.canonicalSetInsert + (Core.CBound 0) + (Core.CIntrinsic Core.Empty)))) + +assertExactSeparationModule + :: String + -> Module.SealedTypedModule + -> Assertion +assertExactSeparationModule label sealed = do + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [definitionBatch, theoremBatch] -> do + assertEqual (label <> " separation definition object count") + 1 + (length + (Declaration.committedBatchObjects definitionBatch)) + definitionObject <- sole + (label <> " separation definition object") + (Declaration.committedBatchObjects definitionBatch) + case Identity.assertedObjectContent definitionObject of + Identity.TransparentObjectContent + _theory coreType body -> do + assertEqual (label <> " separation definition type") + (Core.TyArrow Core.TySet Core.TySet) + coreType + assertEqual (label <> " separation definition body") + (Core.CLam Core.TySet + (Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Sep) + (Core.CBound 0)) + (Core.CLam Core.TySet + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0))))) + body + content -> + assertFailure + (label <> ": unexpected separation object " + <> show content) + let definitionDelta = + Declaration.committedBatchDelta definitionBatch + definitionFacts = + Semantic.declarationDeltaFacts definitionDelta + assertEqual (label <> " definition fact count") + 2 (length definitionFacts) + assertEqual (label <> " defining equation is explicit-only") + [Semantic.SearchIneligible, Semantic.SearchEligible] + (Semantic.semanticFactSearchEligibility <$> definitionFacts) + assertEqual (label <> " generated view is unaliased") + 1 + (length (Semantic.declarationDeltaAliases definitionDelta)) + assertEqual (label <> " definition proposition count") + 2 + (length + (Declaration.committedBatchPropositions definitionBatch)) + assertEqual (label <> " definition proof validations") + [] + (Declaration.committedBatchProofValidations definitionBatch) + definitionValidation <- + maybe + (assertFailure + (label <> ": definition validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + definitionBatch) + case Authority.validationDirectAuthorization + <$> Semantic.declarationValidationRecordCertificates + definitionValidation of + [ Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation target) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + generatedTarget _descriptor) + ] -> + assertEqual + (label <> " construction authority object") + target generatedTarget + authorizations -> + assertFailure + (label <> ": unexpected definition authorities " + <> show authorizations) + + assertEqual (label <> " theorem adds no object") + [] + (Declaration.committedBatchObjects theoremBatch) + theoremFact <- sole + (label <> " separation theorem fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta theoremBatch)) + assertEqual (label <> " theorem safety") + Authority.cleanAuthoritySafety + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority theoremFact)) + theoremValidation <- sole + (label <> " separation theorem validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate + theoremValidation) of + Authority.CheckedSourceProof [_request] -> + pure () + authorization -> + assertFailure + (label <> ": unexpected theorem authority " + <> show authorization) + batches -> + assertFailure + (label <> ": expected definition and theorem, found " + <> show (length batches)) + +reusesExactSeparationValidation :: Assertion +reusesExactSeparationValidation = + Temp.withSystemTempDirectory "felix-exact-separation-cache" \root -> do + let relative = "test/phase5/exact-separation.tex" + sourcePath = root Posix.</> relative + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + ByteString.readFile relative >>= ByteString.writeFile sourcePath + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-separation-cache'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + freshRequests <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRequests + (<> [Provers.preparedTypedProverRequest prepared]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + freshModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + freshResolver + Declaration.FreshValidation + workspace + assertEqual "fresh separation proof runs Vampire once" + 1 + . length + =<< readIORef freshRequests + fresh <- sole "fresh exact separation module" freshModules + assertExactSeparationModule "fresh cached" fresh + freshDefinitionBatch <- + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh) of + batch : _theorem : [] -> pure batch + batches -> + assertFailure + ("fresh separation declaration count: " + <> show (length batches)) + >> fail "unreachable" + freshDefinitionValidation <- + maybe + (assertFailure "fresh separation definition validation absent" + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation + freshDefinitionBatch) + corruptedDefinitionValidation <- + case Semantic.declarationValidationRecordCertificates + freshDefinitionValidation of + [equation, extensional] -> do + corruptedExtensional <- + expectRight + (Authority.validationCertificate + (Authority.validationTarget extensional) + (Authority.validationDirectAuthorization + equation)) + pure + (Semantic.declarationValidationRecord + (Semantic.declarationValidationRecordKey + freshDefinitionValidation) + [equation, corruptedExtensional]) + certificates -> + assertFailure + ("fresh separation certificate count: " + <> show (length certificates)) + >> fail "unreachable" + freshRequest <- + sole "fresh separation request" + =<< readIORef freshRequests + freshAcceptedRequest <- + acceptedRequestId "fresh separation" fresh + assertEqual "fresh authority binds the exact request bytes" + freshAcceptedRequest + (Provers.preparedVerificationRequestId freshRequest) + assertBool "fresh separation request bytes are retained by the caller" + (Provers.preparedVerificationByteCount freshRequest > 0) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warmModules <- + compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm separation proof skips Vampire" + 0 + =<< readIORef warmRuns + warm <- sole "warm exact separation module" warmModules + assertExactSeparationModule "warm cached" warm + warmAcceptedRequest <- + acceptedRequestId "warm separation" warm + assertEqual + "warm validation retains the fresh request-byte identity" + freshAcceptedRequest + warmAcceptedRequest + assertEqual "warm separation semantic interface" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm separation final prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + let components sealed = + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + in ( concatMap + Declaration.committedBatchObjects + batches + , concatMap + (fmap Identity.checkedPropositionId + . Declaration.committedBatchPropositions) + batches + , concatMap + Declaration.committedBatchProofValidations + batches + , Declaration.committedBatchDeclarationValidation + <$> batches + ) + assertEqual "warm separation checked artifacts" + (components fresh) + (components warm) + corruptRuns <- newIORef (0 :: Int) + let corruptedValidation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (\key -> + if key + == Semantic.declarationValidationRecordKey + corruptedDefinitionValidation + then pure + (Just corruptedDefinitionValidation) + else expectRightIO + (Store.loadDeclarationValidation + store key))) + corrupted <- Exception.try + (compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable corruptRuns) + corruptedValidation + workspace) + :: IO + (Either + Declaration.ValidationIntegrityError + [Module.SealedTypedModule]) + case corrupted of + Left Declaration.CachedValidationIntegrityError{} -> + pure () + Right _ -> + assertFailure + "mismatched generated authority replay succeeded" + assertEqual + "mismatched generated authority does not invoke Vampire" + 0 + =<< readIORef corruptRuns + where + acceptedRequestId label sealed = do + theoremBatch <- + case Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) of + [_definitionBatch, batch] -> pure batch + batches -> + assertFailure + (label <> ": unexpected declaration count " + <> show (length batches)) + >> fail "unreachable" + validation <- sole + (label <> " proof validation") + (Declaration.committedBatchProofValidations theoremBatch) + case Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate validation) of + Authority.CheckedSourceProof [request] -> pure request + authorization -> + assertFailure + (label <> ": unexpected direct authorization " + <> show authorization) + >> fail "unreachable" + +compilesExactSourceAxioms :: Assertion +compilesExactSourceAxioms = + Temp.withSystemTempDirectory "felix-exact-source-axiom" \root -> do + let storePath = root Posix.</> "store.sqlite" + (foundation, bootstrap, workspace, freshModules) <- + compileExactFixture + "test/phase5/exact-source-axiom-assumptions.tex" + fresh <- sole "fresh source-axiom module" freshModules + assertSourceAxiom "fresh" fresh + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap unusedResolver validation workspace + warm <- sole "warm source-axiom module" warmModules + assertSourceAxiom "warm" warm + assertEqual "warm source axiom preserves semantics" + (Module.sealedTypedModuleSemantic fresh) + (Module.sealedTypedModuleSemantic warm) + assertEqual "warm source axiom preserves prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix fresh)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix warm)) + where + assertSourceAxiom label sealed = do + batch <- sole (label <> " source-axiom batch") + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed)) + fact <- sole (label <> " source-axiom fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + alias <- sole (label <> " source-axiom alias") + (Semantic.declarationDeltaAliases + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " source-axiom search eligibility") + Semantic.SearchEligible + (Semantic.semanticFactSearchEligibility fact) + assertEqual (label <> " source-axiom marker alias") + (Semantic.semanticName "phase5_exact_source_axiom_assumptions") + (Semantic.semanticAliasName alias) + proposition <- sole (label <> " source-axiom proposition") + (Declaration.committedBatchPropositions batch) + assertEqual (label <> " source-axiom closed target") + (Core.CForall Core.TySet + (Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (Core.CImp + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)) + (member + (Core.CBound 0) + (Core.CBound 1)))))) + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition)) + assertEqual (label <> " source-axiom safety") + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.SourceAxiom)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + validation <- + maybe + (assertFailure (label <> " source-axiom validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- sole (label <> " source-axiom certificate") + (Semantic.declarationValidationRecordCertificates validation) + assertEqual (label <> " source-axiom direct authority") + Authority.SourceAxiomAuthorization + (Authority.validationDirectAuthorization certificate) + assertEqual (label <> " source axiom has no proof validations") + [] + (Declaration.committedBatchProofValidations batch) + + member element set = + Core.CApp + (Core.CApp + (Core.CIntrinsic Core.Member) + element) + set + +rejectsProofLocalGeneralization :: Assertion +rejectsProofLocalGeneralization = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts + "test/phase5/exact-proof-local-free.tex" + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule workspace) + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofElaborationFailed + (Exact.ExactFreeVariable location + (Raw.NamedVar "y"))))) + prefix -> do + assertEqual "proof-local free variable line" + 6 (locLine location) + assertEqual "proof-local failure commits nothing" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "proof-local variable was generalized" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("proof-local generalization module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected proof-local generalization failure: " + <> show failure) + +doesNotTreatMarkerOnlyNounAsSet :: Assertion +doesNotTreatMarkerOnlyNounAsSet = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts + "test/phase5/exact-set-marker.tex" + Temp.withSystemTempDirectory "felix-exact-set-marker" \root -> do + let executable = root Posix.</> "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for set-marker'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observed <- newIORef [] + let resolver = Declaration.vampireResolver \prepared -> do + let problem = + Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observed + (<> [ [ Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + == Backend.supportedPropositionTerm claim + | premise <- Vector.toList locals + ] + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + (Parse.parsedWorkspaceRootModule workspace) + []) + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded{} -> + assertEqual + "the source noun supplies the local proof premise" + [[True]] + =<< readIORef observed + Module.TypedModuleOpenFailed failure -> + assertFailure + ("marker-only set noun module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected marker-only set noun failure: " + <> show failure) + +compilesExactOmittedProofs :: Assertion +compilesExactOmittedProofs = + Temp.withSystemTempDirectory "felix-exact-omitted" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-omitted.tex" + let executable = root Posix.</> "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-omitted'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + calls <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + modifyIORef' calls (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + modules <- + compileParsedWorkspaceWithResolver + foundation bootstrap resolver workspace + sealed <- sole "exact omitted module" modules + assertEqual "only the non-omitted continuation invokes Vampire" + 1 + =<< readIORef calls + let batches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix sealed) + assertEqual "top-level and nested omitted declarations" + 2 (length batches) + for_ (zip ["top-level", "nested"] batches) \(label, batch) -> do + fact <- sole (label <> " omitted fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " omitted safety") + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)) + record <- sole (label <> " omitted validation") + (Declaration.committedBatchProofValidations batch) + assertEqual (label <> " omitted direct authority") + Authority.OmittedAuthorization + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + assertEqual (label <> " publishes only its final theorem") + 1 + (length + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch))) + +reusesExactEscapeAuthority :: Assertion +reusesExactEscapeAuthority = + Temp.withSystemTempDirectory "felix-exact-escape-cache" \root -> do + let consumerRelative = "test/phase5/exact-escape-consumer.tex" + producerRelative = "test/phase5/exact-escape-producer.tex" + consumerPath = root Posix.</> consumerRelative + producerPath = root Posix.</> producerRelative + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory consumerPath) + consumerSource <- ByteString.readFile consumerRelative + producerSource <- ByteString.readFile producerRelative + ByteString.writeFile consumerPath consumerSource + ByteString.writeFile producerPath producerSource + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-escape'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + freshWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + freshRuns <- newIORef (0 :: Int) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (acceptedResolver executable freshRuns) + Declaration.FreshValidation + freshWorkspace + assertEqual "fresh escape graph Vampire requests" + 5 + =<< readIORef freshRuns + assertEscapeGraph "fresh" freshModules + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + compileWarm workspace = do + runs <- newIORef (0 :: Int) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (acceptedResolver executable runs) + validation + workspace + runCount <- readIORef runs + pure (modules, runCount) + (warmModules, warmRuns) <- compileWarm freshWorkspace + assertEqual "exact escape warm hit skips Vampire" + 0 warmRuns + assertEscapeGraph "warm" warmModules + assertEqual "warm escape graph preserves module semantics" + (moduleSemantics freshModules) + (moduleSemantics warmModules) + assertEqual "warm escape graph preserves module prefixes" + (modulePrefixes freshModules) + (modulePrefixes warmModules) + + let formattingOnly = + Text.encodeUtf8 + ("% shifted exact escape source\n" + <> Text.decodeUtf8 consumerSource) + ByteString.writeFile consumerPath formattingOnly + formattedWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + assertBool "formatting changes the escape parsed identity" + (Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule freshWorkspace) + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule + formattedWorkspace)) + (formattedModules, formattedRuns) <- + compileWarm formattedWorkspace + assertEqual "formatting-only escape edit reuses validation" + 0 formattedRuns + assertEqual "formatting-only escape edit preserves semantics" + (moduleSemantics freshModules) + (moduleSemantics formattedModules) + + let omittedGoalEdit = + Text.encodeUtf8 + (StrictText.replace + " Show $x = x$." + " Show if $x = x$, then $x = x$." + (Text.decodeUtf8 consumerSource)) + ByteString.writeFile consumerPath omittedGoalEdit + editedWorkspace <- + parseExactWorkspace bootstrap mounts consumerRelative + (editedModules, editedRuns) <- + compileWarm editedWorkspace + assertEqual "changed omitted goal misses its proof validation" + 1 editedRuns + assertEqual "changed omitted goal preserves public semantics" + (moduleSemantics freshModules) + (moduleSemantics editedModules) + where + acceptedResolver executable runs = + Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + moduleSemantics = fmap Module.sealedTypedModuleSemantic + modulePrefixes = + fmap + (Declaration.pendingModulePrefixCurrent + . Module.sealedTypedModulePrefix) + + assertEscapeGraph label = \case + [producer, consumer] -> do + let producerBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix producer) + consumerBatches = + Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix consumer) + case producerBatches of + [sourceAxiom, omitted] -> do + assertEscapeSafety + (label <> " source axiom") + [Authority.SourceAxiom] + sourceAxiom + assertDeclarationDirect + (label <> " source axiom") + Authority.SourceAxiomAuthorization + sourceAxiom + assertEscapeSafety + (label <> " omitted theorem") + [Authority.Omitted] + omitted + assertProofDirectOmitted + (label <> " omitted theorem") + omitted + batches -> + assertFailure + (label <> " producer batch count: " + <> show (length batches)) + case consumerBatches of + [fromAxiom, fromOmitted, throughLocal, ownOmission] -> do + assertEscapeSafety + (label <> " source-axiom consumer") + [Authority.SourceAxiom] + fromAxiom + assertProofDirectChecked + (label <> " source-axiom consumer") 1 fromAxiom + assertEscapeSafety + (label <> " omitted consumer") + [Authority.Omitted] + fromOmitted + assertProofDirectChecked + (label <> " omitted consumer") 1 fromOmitted + assertEscapeSafety + (label <> " local source-axiom consumer") + [Authority.SourceAxiom] + throughLocal + assertProofDirectChecked + (label <> " local source-axiom consumer") + 2 throughLocal + assertEscapeSafety + (label <> " own omission") + [Authority.SourceAxiom, Authority.Omitted] + ownOmission + assertProofDirectOmitted + (label <> " own omission") ownOmission + batches -> + assertFailure + (label <> " consumer batch count: " + <> show (length batches)) + modules -> + assertFailure + (label <> " escape module count: " + <> show (length modules)) + + assertEscapeSafety label expected batch = do + fact <- sole (label <> " fact") + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta batch)) + assertEqual (label <> " public escape kinds") + expected + (Authority.escapeKindsToList + (Authority.authoritySafetyEscapeKinds + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority fact)))) + + assertDeclarationDirect label expected batch = do + validation <- + maybe + (assertFailure (label <> " declaration validation is absent") + >> fail "unreachable") + pure + (Declaration.committedBatchDeclarationValidation batch) + certificate <- sole (label <> " declaration certificate") + (Semantic.declarationValidationRecordCertificates validation) + assertEqual (label <> " direct authorization") + expected + (Authority.validationDirectAuthorization certificate) + + assertProofDirectChecked label expectedCount batch = do + authorization <- proofDirect label batch + case authorization of + Authority.CheckedSourceProof requests -> + assertEqual (label <> " accepted request count") + expectedCount (length requests) + direct -> + assertFailure + (label <> " has unexpected direct authority: " + <> show direct) + + assertProofDirectOmitted label batch = do + authorization <- proofDirect label batch + assertEqual (label <> " direct authorization") + Authority.OmittedAuthorization authorization + + proofDirect label batch = do + record <- sole (label <> " proof validation") + (Declaration.committedBatchProofValidations batch) + pure + (Authority.validationDirectAuthorization + (Semantic.proofValidationRecordCertificate record)) + +rejectsAfterExactOmittedSubclaim :: Assertion +rejectsAfterExactOmittedSubclaim = + Temp.withSystemTempDirectory "felix-exact-omitted-rollback" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-escape-consumer.tex" + parsedModules <- + pure + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + (producerParsed, consumerParsed) <- + case parsedModules of + [producer, consumer] -> pure (producer, consumer) + modules -> + assertFailure + ("unexpected rollback graph size: " + <> show (length modules)) + >> fail "unreachable" + producerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + producerParsed + []) + producer <- Module.runTypedModule producerInput >>= \case + Module.TypedModuleSucceeded sealed -> pure sealed + _ -> + assertFailure "escape producer did not seal" + >> fail "unreachable" + let executable = root Posix.</> "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for omitted-rollback'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + calls <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + runCount <- readIORef calls + modifyIORef' calls (+ 1) + if runCount < 4 + then + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + else + pure + (Right + (Provers.CounterSatisfiable + "rejected continuation")) + consumerInput <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + consumerParsed + [producer]) + Module.runTypedModule consumerInput >>= \case + Module.TypedModuleFailed + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "the continuation is the fifth request" + 5 + =<< readIORef calls + assertEqual "rejected continuation location" + 37 (locLine location) + assertEqual "omitted declaration rolls back atomically" + 3 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "rejected omitted continuation was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("omitted rollback module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected omitted rollback failure: " + <> show failure) + +reusesExactProofValidationAcrossModuleMisses :: Assertion +reusesExactProofValidationAcrossModuleMisses = + Temp.withSystemTempDirectory "felix-exact-proof-cache" \root -> do + let relative = "test/phase5/exact-proofs.tex" + producerRelative = "test/phase5/exact-producer.tex" + sourcePath = root Posix.</> relative + producerPath = root Posix.</> producerRelative + executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + createDirectoryIfMissing True (Posix.takeDirectory sourcePath) + original <- ByteString.readFile relative + producer <- ByteString.readFile producerRelative + ByteString.writeFile sourcePath original + ByteString.writeFile producerPath producer + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-cache'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + freshWorkspace <- parseExactWorkspace bootstrap mounts relative + freshRuns <- newIORef (0 :: Int) + freshModules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable freshRuns) + Declaration.FreshValidation + freshWorkspace + assertEqual "fresh proof obligations run Vampire" + 7 + =<< readIORef freshRuns + freshRoot <- sole "fresh exact proof root" (drop 1 freshModules) + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + traverse_ + (expectRightIO + . Store.writePendingModulePrefix store + . Module.sealedTypedModulePrefix) + freshModules + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + compileWarm workspace = do + runs <- newIORef (0 :: Int) + modules <- + compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable runs) + validation + workspace + rootModule <- sole "warm exact proof root" (drop 1 modules) + runCount <- readIORef runs + pure (rootModule, runCount) + (unchangedRoot, unchangedRuns) <- + compileWarm freshWorkspace + assertEqual "exact warm hit skips Vampire" + 0 unchangedRuns + assertEqual "exact warm hit preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic unchangedRoot) + + let formattingOnly = + Text.encodeUtf8 + (StrictText.replace + "\\begin{proposition}\\label{phase5_structural_proof}" + ("% shifted source location\n" + <> "\\begin{proposition}\\label{phase5_structural_proof}") + (Text.decodeUtf8 original)) + ByteString.writeFile sourcePath formattingOnly + formattedWorkspace <- + parseExactWorkspace bootstrap mounts relative + assertBool "formatting changes parsed module identity" + (Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule freshWorkspace) + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule formattedWorkspace)) + (formattedRoot, formattedRuns) <- + compileWarm formattedWorkspace + assertEqual "formatting-only module miss reuses proof validation" + 0 formattedRuns + assertEqual "formatting-only miss preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic formattedRoot) + + let semanticEdit = + Text.encodeUtf8 + (StrictText.replace + " We have $x = x$ by assumption." + (StrictText.intercalate "\n" + [ " Show $x = x$." + , " \\begin{subproof}" + , " Follows by assumption." + , " \\end{subproof}" + ]) + (Text.decodeUtf8 original)) + ByteString.writeFile sourcePath semanticEdit + editedWorkspace <- + parseExactWorkspace bootstrap mounts relative + (editedRoot, editedRuns) <- + compileWarm editedWorkspace + assertEqual "semantic proof edit reruns its obligations" + 2 editedRuns + assertEqual "request-equivalent proof preserves public semantics" + (Module.sealedTypedModuleSemantic freshRoot) + (Module.sealedTypedModuleSemantic editedRoot) +rejectsFixedSemanticDeclaration :: Assertion +rejectsFixedSemanticDeclaration = + Temp.withSystemTempDirectory "felix-fixed-semantic" \root -> do + let relative = "entry.tex" + path = root Posix.</> relative + source = + "\\begin{signature}\\label{source_unions}\n" + <> " $\\unions{X}$ is a set.\n" + <> "\\end{signature}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactFixedSemanticCollision + location key))) + prefix -> do + assertEqual "fixed collision line" 1 (locLine location) + assertEqual "fixed collision key" + (Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "unions") + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons + Raw.InvisibleBraceR Raw.End))))) + key + assertEqual "fixed collision commits no prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "fixed semantic declaration was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("fixed semantic module did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected fixed semantic failure: " + <> show failure) + +rejectsFixedSemanticInductive :: Assertion +rejectsFixedSemanticInductive = + Temp.withSystemTempDirectory "felix-fixed-inductive" \root -> do + let relative = "entry.tex" + path = root Posix.</> relative + source = + "\\begin{inductive}\\label{source_pow}\n" + <> " Define $\\pow{A}\\subseteq\\cumul{A}$ inductively as follows.\n" + <> " \\begin{enumerate}\n" + <> " \\item $A\\in\\pow{A}$.\n" + <> " \\end{enumerate}\n" + <> "\\end{inductive}\n" + ByteString.writeFile path + (Text.encodeUtf8 (StrictText.pack source)) + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + unusedResolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input >>= \case + Module.TypedModuleFailed + (Module.TypedActionFailed + (Module.TypedExactInductiveFailed + (ExactInductive.ExactInductiveFixedSemanticCollision + location key))) + prefix -> do + assertEqual "fixed inductive collision line" + 1 + (locLine location) + assertEqual "fixed inductive collision key" + (Semantic.SemanticExpressionFunction + (Raw.TokenCons (Raw.Command "pow") + (Raw.TokenCons Raw.InvisibleBraceL + (Raw.HoleCons + (Raw.TokenCons + Raw.InvisibleBraceR Raw.End))))) + key + assertEqual "fixed inductive collision commits no prefix" + 0 + (length + (Declaration.pendingModulePrefixBatches prefix)) + Module.TypedModuleSucceeded{} -> + assertFailure "fixed semantic inductive was accepted" + Module.TypedModuleOpenFailed failure -> + assertFailure + ("fixed semantic inductive did not open: " + <> show failure) + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("unexpected fixed inductive failure: " + <> show failure) + +keepsExactSemanticsIndependentOfFixity :: Assertion +keepsExactSemanticsIndependentOfFixity = + Temp.withSystemTempDirectory "felix-exact-fixity" \root -> do + let relative = "test/phase5/exact-producer.tex" + path = root Posix.</> relative + createDirectoryIfMissing True (Posix.takeDirectory path) + original <- ByteString.readFile relative + let changed = + Text.encodeUtf8 + (StrictText.replace + "infixl 2" + "infixr 6" + (Text.decodeUtf8 original)) + ByteString.writeFile path original + first <- compileExactRootAt root relative + ByteString.writeFile path changed + second <- compileExactRootAt root relative + let firstParsed = Parse.parsedWorkspaceRootModule (fst first) + secondParsed = Parse.parsedWorkspaceRootModule (fst second) + firstSealed = snd first + secondSealed = snd second + assertBool "fixity changes syntax identity" + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface firstParsed) + /= Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface secondParsed)) + assertBool "fixity changes parsed identity" + (Parse.parsedModuleId firstParsed + /= Parse.parsedModuleId secondParsed) + assertEqual "fixity preserves semantic interface" + (Module.sealedTypedModuleSemantic firstSealed) + (Module.sealedTypedModuleSemantic secondSealed) + assertEqual "fixity preserves semantic prefix" + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix firstSealed)) + (Declaration.pendingModulePrefixCurrent + (Module.sealedTypedModulePrefix secondSealed)) + +loadsCachedExactProducerForFreshImporter :: Assertion +loadsCachedExactProducerForFreshImporter = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-exact-cache" \root -> do + let path = root Posix.</> "store.sqlite" + executable = root Posix.</> "vampire" + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore path (Identity.theoryId foundation) + >>= expectRight + let observer = Verification.verificationRequestObserver \_ordinal _request -> + pure () + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + verify mode source = + (checkResultWithStore + store mode observer prover source) + >>= expectRight + producer <- + verify Verification.FreshStoreValidation + "test/phase5/exact-producer.tex" + importer <- + verify Verification.WarmStoreValidation + "test/phase5/exact-importer.tex" + assertTypedSuccess "fresh producer" producer + assertTypedSuccess "warm producer/fresh importer" importer + memo <- Store.newStoreMemo store + prelude <- + expectRight + =<< Module.acquireFinalPreludeSession + memo store foundation unusedResolver + preludeVisits <- Store.storeMemoVisits memo + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseFinalExactWorkspace + prelude mounts "test/phase5/exact-importer.tex" + let parsedModules = + toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace) + preludeSemantic = + Module.sealedTypedModuleSemantic + (Module.finalPreludeModule prelude) + preludeId = + Semantic.semanticInterfaceAssertedId preludeSemantic + theory = Identity.theoryId foundation + loadInstallation parsed direct = do + key <- expectRight + (Semantic.moduleArtifactKey + (moduleName (Parse.parsedModuleAddress parsed)) + (Parse.parsedModuleId parsed) + direct + theory) + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface parsed)) + maybe + (assertFailure "exact cached installation is absent" + >> fail "unreachable") + pure + loaded + environmentBindings installation = + [ binding + | delta <- Semantic.semanticInterfaceDeclarations + (Store.cachedInstallationSemantic installation) + , binding <- Semantic.semanticEnvironmentBindings + (Semantic.declarationDeltaEnvironment delta) + ] + case parsedModules of + [producerParsed, importerParsed] -> do + producerInstallation <- + loadInstallation producerParsed [preludeId] + producerVisits <- Store.storeMemoVisits memo + assertEqual "ordinary root adds one artifact validation" + (Store.storeArtifactsValidated preludeVisits + 1) + (Store.storeArtifactsValidated producerVisits) + assertEqual "ordinary root reuses prelude syntax validation" + (Store.storeSyntaxRowsValidated preludeVisits + 1) + (Store.storeSyntaxRowsValidated producerVisits) + assertEqual "ordinary root reuses prelude semantic validation" + (Store.storeSemanticRowsValidated preludeVisits + 1) + (Store.storeSemanticRowsValidated producerVisits) + let producerSemanticId = + Semantic.semanticInterfaceAssertedId + (Store.cachedInstallationSemantic + producerInstallation) + importerInstallation <- + loadInstallation + importerParsed [preludeId, producerSemanticId] + case ( environmentBindings producerInstallation + , environmentBindings importerInstallation + ) of + (seedBinding : aliasBinding : _definitionBinding : [], + [importerBinding]) -> do + let seedTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + seedBinding) + aliasTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + aliasBinding) + importerTarget = + Semantic.semanticGlobalTargetObject + (Semantic.semanticGlobalBindingTarget + importerBinding) + assertEqual "cached importer reuses expanded content" + aliasTarget importerTarget + assertEqual "cached importer adds no object" + [] + (Store.cachedInstallationObjects + importerInstallation) + expandedObject <- + maybe + (assertFailure + "cached expanded object is absent" + >> fail "unreachable") + pure + (find + ((== aliasTarget) + . Identity.assertedObjectId) + (Store.cachedInstallationObjects + producerInstallation)) + case Identity.assertedObjectContent expandedObject of + Identity.TransparentObjectContent + _identity _coreType body -> + assertEqual + "cached expansion retains the opaque seed" + (Set.singleton seedTarget) + (Core.canonicalTermGlobals body) + content -> + assertFailure + ("cached expansion is not transparent: " + <> show content) + (producerBindings, importerBindings) -> + assertFailure + ("unexpected cached exact bindings: " + <> show + ( length producerBindings + , length importerBindings + )) + modules -> + assertFailure + ("unexpected cached exact module count: " + <> show (length modules)) + Store.closeStore store + +selectsConcurrentModuleFailureDeterministically :: Assertion +selectsConcurrentModuleFailureDeterministically = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-concurrent-module-failure" \root -> do + let executable = root Posix.</> "vampire" + source = "test/phase7/concurrent-failure-root.tex" + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + select amount = + Provers.selectEffectiveJobs + (Provers.effectiveJobs amount) + (fail "explicit jobs unexpectedly detected processors") + reportEntry escape = + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + ) + inspect label expectedPositions + (result, _slowReport, positions) = do + case result of + Verification.VerificationFailure report failed -> do + assertEqual (label <> " selected earlier failure") + "test/phase7/concurrent-earlier.tex" + (locFile (Verification.failedVerificationLocation failed)) + assertEqual (label <> " admitted source prefix") + [ ( Verification.ReportedSourceAxiom + , "test/phase7/concurrent-earlier.tex" + , 1 + ) + ] + (reportEntry + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + (label <> " did not reject deterministically: " + <> show other) + assertEqual (label <> " executed only sibling obligations") + expectedPositions + (sort + [ ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal position + ) + | position <- positions + ]) + runCase label jobsAmount = do + let storePath = root Posix.</> (label <> ".sqlite") + processLock = root Posix.</> (label <> ".process-lock") + processStarted = + root Posix.</> (label <> ".process-started") + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Seed only the final prelude. The unsupported ordinary + -- module cannot publish a root. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + prover + "test/phase3/typed-unsupported.tex") + >>= expectRight) + writeFile executable + (unlines + [ "#!/bin/sh" + , "while ! mkdir \"" <> processLock + <> "\" 2>/dev/null; do sleep 0.01; done" + , "trap 'rmdir \"" <> processLock + <> "\"' EXIT" + , ": > \"" <> processStarted <> "\"" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status CounterSatisfiable for concurrent-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + positionsRef <- newIORef [] + let observer = + Verification.verificationRequestObserver + (\position _request -> do + atomicModifyIORef' positionsRef + (\positions -> + (position : positions, ())) + when + (jobsAmount > 1 + && Provers.workPositionModuleOrdinal + position == 1) + (waitForFileSignal + "later module process" + processStarted)) + jobs <- select jobsAmount + (result, slowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + prover + source) + >>= expectRight + positions <- readIORef positionsRef + pure (result, slowReport, positions) + void $ runCase "parallel" 2 + >>= inspect "parallel" [(1, 1), (2, 1)] + void $ runCase "sequential" 1 + >>= inspect "sequential" [(1, 1)] + +waitForFileSignal :: String -> FilePath -> Assertion +waitForFileSignal label path = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just () -> + pure () + Nothing -> + assertFailure (label <> " was not observed") + where + loop = do + exists <- doesFileExist path + if exists + then pure () + else do + threadDelay 10000 + loop + +batchesStructureObligationsAtomically :: Assertion +batchesStructureObligationsAtomically = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-structure-obligation-batch" \root -> do + let storePath = root Posix.</> "store.sqlite" + executable = root Posix.</> "vampire" + unavailable = root Posix.</> "must-not-run-vampire" + source = "test/phase7/structure-obligation-batch.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + select amount = + Provers.selectEffectiveJobs + (Provers.effectiveJobs amount) + (fail "explicit jobs unexpectedly detected processors") + run openStore jobs observer vampireCommand = + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + vampireCommand + source) + >>= expectRight + inspectFailure label positions (result, _slowReport) = do + case result of + Verification.VerificationFailure report failed -> do + assertEqual (label <> " selects first consequence") + (source, 12) + ( locFile (Verification.failedVerificationLocation failed) + , locLine (Verification.failedVerificationLocation failed) + ) + assertEqual (label <> " retains preceding prefix") + [(Verification.ReportedSourceAxiom, source, 1)] + [ ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + ) + | escape <- Verification.verificationDirectEscapes report + ] + other -> + assertFailure + (label <> " did not reject its structure batch: " + <> show other) + assertEqual (label <> " assigns consecutive positions") + [(1, 1), (1, 2)] + (sort positions) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + -- Seed only the confined prelude so this fixture observes exactly + -- the ordinary structure module's ready batch. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + parallelJobs <- select 2 + parallelPositions <- newIORef [] + firstStarted <- newEmptyTMVarIO + secondStarted <- newEmptyTMVarIO + releaseFirst <- newEmptyTMVarIO + let laterCompleted = root Posix.</> "later-completed" + writeLaterAcceptingVampire executable laterCompleted + let parallelObserver = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + atomicModifyIORef' parallelPositions + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , ordinal + ) : positions + , () + )) + case ordinal of + 1 -> do + atomically (putTMVar firstStarted ()) + atomically (takeTMVar releaseFirst) + 2 -> + atomically (putTMVar secondStarted ()) + _ -> + assertFailure + ("unexpected structure request ordinal: " + <> show ordinal) + withAsync + (run openStore parallelJobs parallelObserver + (prover executable)) + \verification -> do + void + (awaitSignal "first structure request" + (atomically (takeTMVar firstStarted))) + void + (awaitSignal "second structure request" + (atomically (takeTMVar secondStarted))) + -- Only the later member can reach the subprocess while + -- the first observer is gated. Its completed signal + -- therefore establishes reversed wall-clock completion. + waitForFileSignal + "later structure consequence" + laterCompleted + atomically (putTMVar releaseFirst ()) + parallelResult <- wait verification + positions <- readIORef parallelPositions + inspectFailure "parallel" positions parallelResult + + sequentialJobs <- select 1 + sequentialPositions <- newIORef [] + let sequentialCompleted = root Posix.</> "sequential-completed" + writeRejectingVampire executable sequentialCompleted + let sequentialObserver = + Verification.verificationRequestObserver \position _request -> + atomicModifyIORef' sequentialPositions + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , Provers.workPositionLocalRequestOrdinal + position + ) : positions + , () + )) + sequentialResult <- + run openStore sequentialJobs sequentialObserver + (prover executable) + sequentialObserved <- readIORef sequentialPositions + inspectFailure "sequential" + sequentialObserved sequentialResult + + -- A rejected sibling wrote neither validation nor a module root: + -- the complete batch executes again, while the earlier source + -- axiom remains the admitted prefix. A subsequent hit executes + -- no request at all. + writeAcceptedFixtureVampire executable + acceptedPositions <- newIORef [] + let acceptedObserver = + Verification.verificationRequestObserver \position _request -> + modifyIORef' acceptedPositions + (position :) + (accepted, _acceptedSlowReport) <- + run openStore parallelJobs acceptedObserver + (prover executable) + case accepted of + Verification.VerificationCompleted report _presentation -> + assertEqual "successful retry retains only source axiom" + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + ("successful structure retry failed: " <> show other) + acceptedObserved <- readIORef acceptedPositions + assertEqual "successful retry executes the complete batch" + 2 + (length acceptedObserved) + let forbiddenObserver = + Verification.verificationRequestObserver \position _request -> + assertFailure + ("warm structure batch invoked Vampire at " + <> show position) + (warm, _warmSlowReport) <- + run openStore parallelJobs forbiddenObserver + (prover unavailable) + case warm of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm structure batch did not install: " <> show other) + where + awaitSignal label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + + writeRejectingVampire executable completed = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , ": > \"" <> completed <> "\"" + , "printf '%s\\n' '% SZS status CounterSatisfiable for structure-batch-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + + writeLaterAcceptingVampire executable completed = do + let firstProcess = completed <> ".first-process" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , ": > \"" <> completed <> "\"" + , "if mkdir \"" <> firstProcess <> "\" 2>/dev/null; then" + , " printf '%s\\n' '% SZS status Theorem for structure-batch-fixture'" + , "else" + , " printf '%s\\n' '% SZS status CounterSatisfiable for structure-batch-fixture'" + , "fi" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + +speculatesDependentProofObligationsWithoutAdmittingAhead :: Assertion +speculatesDependentProofObligationsWithoutAdmittingAhead = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-dependent-proof-chain" \root -> do + let executable = root Posix.</> "vampire" + unavailable = root Posix.</> "must-not-run-vampire" + storePath = root Posix.</> "store.sqlite" + source = "test/phase7/dependent-proof-chain.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Seed only the final prelude so the observed work belongs to the + -- ordinary proof module. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + jobs <- + Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + firstStarted <- newEmptyTMVarIO + secondStarted <- newEmptyTMVarIO + releaseFirst <- newEmptyTMVarIO + positionsRef <- newIORef [] + let observer = + Verification.verificationRequestObserver \position _request -> do + let ordinal = + Provers.workPositionLocalRequestOrdinal position + atomicModifyIORef' positionsRef + (\positions -> + ( ( Provers.workPositionModuleOrdinal position + , ordinal + ) : positions + , () + )) + case ordinal of + 1 -> do + atomically (putTMVar firstStarted ()) + atomically (takeTMVar releaseFirst) + 2 -> atomically (putTMVar secondStarted ()) + _ -> + assertFailure + ("unexpected dependent proof request: " + <> show ordinal) + withAsync + ( + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + observer + (prover executable) + source) + >>= expectRight) + \checking -> do + void + (awaitSignal "local subclaim request" + (atomically (takeTMVar firstStarted))) + -- The continuation is semantically dependent, but its + -- already checked request may execute prospectively. It + -- cannot be admitted until the local claim succeeds. + void + (awaitSignal "dependent continuation request" + (atomically (takeTMVar secondStarted))) + atomically (putTMVar releaseFirst ()) + (result, _slowReport) <- wait checking + case result of + Verification.VerificationCompleted report _presentation -> + assertEqual "only the preceding axiom is reported" + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) + other -> + assertFailure + ("dependent proof module did not seal: " + <> show other) + positions <- readIORef positionsRef + assertEqual "dependent requests retain source positions" + [(1, 1), (1, 2)] + (sort positions) + + let forbiddenObserver = + Verification.verificationRequestObserver \position _request -> + assertFailure + ("warm dependent proof invoked Vampire at " + <> show position) + (warm, _warmSlowReport) <- + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + forbiddenObserver + (prover unavailable) + source) + >>= expectRight + case warm of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm dependent proof did not install: " <> show other) + where + awaitSignal label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + +schedulesDiamondAfterSealedImports :: Assertion +schedulesDiamondAfterSealedImports = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-concurrent-diamond" \root -> do + let storePath = root Posix.</> "store.sqlite" + executable = root Posix.</> "vampire" + unavailable = root Posix.</> "must-not-run-vampire" + source = "test/phase7/diamond-root.tex" + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + ignored = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + -- Acquire the final prelude before introducing scheduler gates. + void + ( + (checkFileWithStore + openStore + Verification.WarmStoreValidation + ignored + (prover executable) + "test/phase3/typed-unsupported.tex") + >>= expectRight) + jobs <- Provers.selectEffectiveJobs + (Provers.effectiveJobs 2) + (fail "explicit jobs unexpectedly detected processors") + baseStarted <- newEmptyTMVarIO + branchStarted <- newTQueueIO + rootStarted <- newEmptyTMVarIO + releaseBase <- newTVarIO False + releaseBranches <- newTVarIO False + let awaitRelease released = + atomically (readTVar released >>= check) + observer = + Verification.verificationRequestObserver + (\position _request -> + case Provers.workPositionModuleOrdinal position of + 1 -> do + atomically (putTMVar baseStarted ()) + awaitRelease releaseBase + ordinal@2 -> do + atomically + (writeTQueue branchStarted ordinal) + awaitRelease releaseBranches + ordinal@3 -> do + atomically + (writeTQueue branchStarted ordinal) + awaitRelease releaseBranches + 4 -> + atomically (putTMVar rootStarted ()) + _ -> + pure ()) + verify vampireCommand requestObserver = + (checkFileWithStoreAndJobs + openStore + Verification.WarmStoreValidation + jobs + requestObserver + vampireCommand + source) + >>= expectRight + await label action = do + result <- Timeout.timeout 10000000 action + maybe + (assertFailure (label <> " was not observed") + >> fail "unreachable") + pure + result + withAsync (verify (prover executable) observer) \verification -> do + void (await "base request" (atomically (takeTMVar baseStarted))) + threadDelay 50000 + atomically (tryReadTQueue branchStarted) >>= \case + Nothing -> pure () + Just ordinal -> + assertFailure + ("dependent module started before base seal: " + <> show ordinal) + atomically (writeTVar releaseBase True) + firstBranch <- await "first branch" + (atomically (readTQueue branchStarted)) + secondBranch <- await "second branch" + (atomically (readTQueue branchStarted)) + assertEqual "both diamond branches became ready together" + [2, 3] + (sort [firstBranch, secondBranch]) + atomically (tryReadTMVar rootStarted) >>= \case + Nothing -> pure () + Just () -> + assertFailure + "diamond root started before both branch seals" + atomically (writeTVar releaseBranches True) + void (await "diamond root" (atomically (takeTMVar rootStarted))) + (coldResult, _coldSlowReport) <- wait verification + case coldResult of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("cold diamond did not complete: " <> show other) + let forbiddenObserver = + Verification.verificationRequestObserver + (\position _request -> + assertFailure + ("warm diamond invoked Vampire at " + <> show position)) + (warmResult, _warmSlowReport) <- + verify (prover unavailable) forbiddenObserver + case warmResult of + Verification.VerificationCompleted{} -> pure () + other -> + assertFailure + ("warm diamond did not install: " <> show other) + +reportsAdmittedSourceEscapes :: Assertion +reportsAdmittedSourceEscapes = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-admitted-source-report" \root -> do + let storePath = root Posix.</> "store.sqlite" + executable = root Posix.</> "vampire" + unavailable = root Posix.</> "must-not-run-vampire" + observer = + Verification.verificationRequestObserver \_ordinal _request -> pure () + prover path = + Provers.vampire + path + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let verify mode vampirePath source = + (checkFileWithStore + openStore + mode + observer + (prover vampirePath) + source) + >>= expectRight + reportEntries = + fmap + (\escape -> + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) + )) + . Verification.verificationDirectEscapes + expectedConsumer = + [ ( Verification.ReportedSourceAxiom + , "test/phase5/exact-escape-producer.tex" + , 1 + ) + , ( Verification.ReportedOmitted + , "test/phase5/exact-escape-producer.tex" + , 9 + ) + , ( Verification.ReportedOmitted + , "test/phase5/exact-escape-consumer.tex" + , 35 + ) + ] + (freshResult, _freshSlowReport) <- + verify + Verification.FreshStoreValidation + executable + "test/phase5/exact-escape-consumer.tex" + freshReport <- case freshResult of + Verification.CompletedWithExplicitGaps report _presentation -> pure report + other -> + assertFailure + ("fresh escape report did not complete with gaps: " + <> show other) + >> fail "unreachable" + assertEqual "fresh direct escapes" + expectedConsumer + (reportEntries freshReport) + (warmResult, _warmSlowReport) <- + verify + Verification.WarmStoreValidation + unavailable + "test/phase5/exact-escape-consumer.tex" + warmReport <- case warmResult of + Verification.CompletedWithExplicitGaps report _presentation -> pure report + other -> + assertFailure + ("warm escape report did not complete with gaps: " + <> show other) + >> fail "unreachable" + assertEqual "warm report uses rebound current locations" + freshReport warmReport + + void + (verify + Verification.FreshStoreValidation + executable + "test/phase5/exact-source-axiom.tex") + (failedResult, _failedSlowReport) <- + verify + Verification.WarmStoreValidation + unavailable + "test/phase6/admitted-prefix-failure.tex" + failedReport <- case failedResult of + Verification.VerificationCheckingFailure report _failure -> pure report + other -> + assertFailure + ("typed suffix failure was not report-bearing: " + <> show other) + >> fail "unreachable" + assertEqual "failure report retains only admitted source prefix" + (take 2 expectedConsumer + <> [ ( Verification.ReportedOmitted + , "test/phase6/admitted-prefix-failure.tex" + , 7 + ) + ]) + (reportEntries failedReport) + +classifiesTypedVampireFailures :: Assertion +classifiesTypedVampireFailures = do + foundation <- expectRight Foundation.checkedFoundation + Temp.withSystemTempDirectory "felix-typed-failure-classification" \root -> do + let storePath = root Posix.</> "store.sqlite" + executable = root Posix.</> "vampire" + observer = + Verification.verificationRequestObserver \_ordinal _request -> pure () + prover = + Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit + writeAcceptedFixtureVampire executable + (_startup, store) <- + Store.openStore storePath (Identity.theoryId foundation) + >>= expectRight + bracket (pure store) Store.closeStore \openStore -> do + let verify source = + (checkFileWithStore + openStore + Verification.WarmStoreValidation + observer + prover + source) + >>= expectRight + writeProtocol lines = do + writeFile executable + (unlines (["#!/bin/sh", "cat >/dev/null"] <> lines)) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + expectTypedFailure classify = do + (result, slowReport) <- + verify "test/phase5/exact-runtime-failure.tex" + case result of + Verification.VerificationFailure report failed -> do + assertEqual "typed failure has no direct escapes" + [] + (Verification.verificationDirectEscapes report) + assertEqual "typed failure retains source location" + "test/phase5/exact-runtime-failure.tex" + (locFile + (Verification.failedVerificationLocation failed)) + classify + (Verification.failedVerificationReason failed) + (CommandLine.verificationCommandOutcome + result slowReport) + other -> + assertFailure + ("typed prover outcome was misclassified: " + <> show other) + + -- Populate only the confined prelude. The selected ordinary + -- module then remains a miss for each classified live failure. + (_preludeResult, _preludeSlowReport) <- + verify "test/phase3/typed-unsupported.tex" + + writeProtocol + [ "printf '%s\\n' '% SZS status CounterSatisfiable for typed-failure'" + , "exit 0" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.CountermodelFailure{} -> pure () + other -> assertFailure ("expected countermodel: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected rejection: " <> show other) + + writeProtocol + [ "printf '%s\\n' '% SZS status Timeout for typed-failure'" + , "exit 0" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.IndeterminateFailure{} -> pure () + other -> assertFailure ("expected indeterminate result: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + + writeProtocol + [ "printf '%s\\n' '% SZS status Theorem for typed-failure'" + , "exit 7" + ] + expectTypedFailure \reason outcome -> do + case reason of + Verification.ProtocolFailure{} -> pure () + other -> assertFailure ("expected protocol failure: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + + writeFile executable "not executable" + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable False permissions) + expectTypedFailure \reason outcome -> do + case reason of + Verification.TransportFailure{} -> pure () + other -> assertFailure ("expected transport failure: " <> show other) + case outcome of + CommandLine.VerificationRejected{} -> pure () + other -> assertFailure ("expected prover failure: " <> show other) + +retainsExactPrefixBeforeFailure :: Assertion +retainsExactPrefixBeforeFailure = do + result <- + withAcceptedFixtureVampire "felix-exact-failure" \prover -> + (checkFileFresh + prover + "test/phase5/exact-failure.tex") + case result of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + source + (Module.TypedActionFailed + (Module.TypedExactCompileFailed + (Exact.ExactGuardedOpaqueSignature location))) + prefix) + , _slowReport + ) -> do + assertEqual "failed exact source" + "test/phase5/exact-failure.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertEqual "unsupported declaration line" 6 (locLine location) + assertEqual "earlier exact declaration remains committed" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure ("unexpected exact failure: " <> show err) + Right{} -> + assertFailure "unsupported declaration was admitted" + + proofFailure <- + withAcceptedFixtureVampire "felix-exact-proof-failure" \prover -> + (checkFileFresh + prover + "test/phase5/exact-proof-failure.tex") + case proofFailure of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedExactProofFailed + (ExactProof.ExactProofGoalStatementMismatch + location))) + prefix) + , _slowReport + ) -> do + assertEqual "mismatched assumption line" 10 (locLine location) + assertEqual "failed proof publishes no theorem" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected exact proof failure: " <> show err) + Right{} -> + assertFailure "mismatched exact proof was admitted" + + unmatched <- + withAcceptedFixtureVampire "felix-unmatched-proof" \prover -> + (checkFileFresh + prover + "test/phase5/unmatched-proof.tex") + case unmatched of + Right + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError + _source + (Module.TypedActionFailed + (Module.TypedUnmatchedProof location)) + prefix) + , _slowReport + ) -> do + assertEqual "unmatched proof line" 1 (locLine location) + assertEqual "unmatched proof publishes no declaration" + 0 + (length (Declaration.pendingModulePrefixBatches prefix)) + Left err -> + assertFailure + ("unexpected unmatched-proof failure: " <> show err) + Right{} -> + assertFailure "unmatched proof was admitted" + + runtimeFailure <- + Temp.withSystemTempDirectory "felix-runtime-proof-failure" \root -> do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + repository <- getCurrentDirectory + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-runtime-failure.tex" + let executable = root Posix.</> "vampire" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for located-proof'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + runs <- newIORef (0 :: Int) + let resolver = Declaration.vampireResolver \prepared -> do + runNumber <- readIORef runs + modifyIORef' runs (+ 1) + if runNumber == 0 + then + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + else + pure + (Right + (Provers.CounterSatisfiable + "later exact obligation")) + parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + Declaration.FreshValidation + parsed + []) + Module.runTypedModule input + case runtimeFailure of + Module.TypedModuleFailed + failure@(Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + Declaration.VampireObligationRejected{})) + prefix -> do + assertEqual "later rejected obligation line" + 11 + (locLine location) + assertEqual "typed failure retains obligation location" + (Just location) + (Module.typedModuleFailureLocation failure) + assertEqual "runtime proof failure publishes no theorem" + 1 + (length (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "unexpected runtime proof failure" + +restoresCheckedSetInduction :: Assertion +restoresCheckedSetInduction = + Temp.withSystemTempDirectory "felix-checked-set-induction" \root -> do + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeAcceptedFixtureVampire executable + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation unusedResolver + mounts <- exactFixtureMounts =<< getCurrentDirectory + + initialWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-initial.tex" + initialObservations <- newIORef [] + initial <- + sole "initial set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable initialObservations) + Declaration.FreshValidation + initialWorkspace + [initialRequest] <- + expectCount "initial set-induction request" 1 + =<< readIORef initialObservations + assertEqual "initial induction retains header then hypothesis ordinals" + [0, 1] + (localReasoningLocalOrdinals initialRequest) + let initialTarget = + Core.CEq Core.TySet (Core.CBound 0) (Core.CBound 0) + initialAntecedent = + member (Core.CBound 1) (Core.CBound 0) + initialHypothesis = + Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 2)) + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (Core.CEq Core.TySet + (Core.CBound 0) + (Core.CBound 0)))) + assertEqual "initial induction child target" + initialTarget + (localReasoningTarget initialRequest) + assertEqual "initial induction uses the complete guarded property" + [initialAntecedent, initialHypothesis] + (localReasoningLocalTerms initialRequest) + + nestedWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-nested.tex" + nestedObservations <- newIORef [] + nested <- + sole "nested set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable nestedObservations) + Declaration.FreshValidation + nestedWorkspace + [nestedChild, nestedContinuation] <- + expectCount "nested set-induction requests" 2 + =<< readIORef nestedObservations + let x = Core.CBound 0 + a = Core.CBound 1 + y = Core.CBound 0 + xUnderY = Core.CBound 1 + aUnderY = Core.CBound 2 + guardAtX = + andP + (member x a) + (notP (Core.CEq Core.TySet x a)) + guardAtY = + andP + (member y aUnderY) + (notP (Core.CEq Core.TySet y aUnderY)) + nestedHypothesis = + Core.CForall Core.TySet + (Core.CImp + (member y xUnderY) + (Core.CImp + guardAtY + (Core.CEq Core.TySet y y))) + nestedTarget = Core.CEq Core.TySet x x + assertEqual + "omitted leading induction retains its source binder and guard" + ([0, 1], [nestedHypothesis, guardAtX], nestedTarget) + ( localReasoningLocalOrdinals nestedChild + , localReasoningLocalTerms nestedChild + , localReasoningTarget nestedChild + ) + case localReasoningLocalTerms nestedContinuation of + [derived] -> do + assertEqual "subproof continuation uses one derived local" + [2] (localReasoningLocalOrdinals nestedContinuation) + assertEqual "subproof closes the exact binder-level result" + derived (localReasoningTarget nestedContinuation) + locals -> + assertFailure + ("unexpected induction continuation locals: " + <> show locals) + + formulaWorkspace <- parseExactWorkspace bootstrap mounts + "test/phase5/exact-induction-formula-quantified.tex" + formulaObservations <- newIORef [] + _formula <- + sole "formula-quantified set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable formulaObservations) + Declaration.FreshValidation + formulaWorkspace + [formulaChild, formulaContinuation] <- + expectCount "formula-quantified set-induction requests" 2 + =<< readIORef formulaObservations + assertEqual + "formula-quantified omitted induction retains its written binder" + (Core.CEq Core.TySet (Core.CBound 0) (Core.CBound 0)) + (localReasoningTarget formulaChild) + assertEqual + "formula-quantified continuation retains hypothesis and derived local" + [0, 1] + (localReasoningLocalOrdinals formulaContinuation) + + anchorWorkspace <- parseExactWorkspace bootstrap mounts + "test/examples/no-reflexive-set.tex" + anchorObservations <- newIORef [] + _anchor <- + sole "omitted-focus set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (observingResolver executable anchorObservations) + Declaration.FreshValidation + anchorWorkspace + [anchorRequest] <- + expectCount "omitted-focus set-induction request" 1 + =<< readIORef anchorObservations + anchorLocal <- + case localReasoningLocalTerms anchorRequest of + [term] -> pure term + terms -> + assertFailure + ("unexpected omitted-focus locals: " <> show terms) + >> fail "unreachable" + assertEqual "omitted focus retains its source binder in the child" + ([0], Core.CForall Core.TySet + (Core.CImp + (member (Core.CBound 0) (Core.CBound 1)) + (notP (member (Core.CBound 0) (Core.CBound 0))))) + ( localReasoningLocalOrdinals anchorRequest + , anchorLocal + ) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-induction-ambiguous.tex" + (\case + ExactProof.ExactProofSetInductionFocusAmbiguous location -> + locLine location == 5 + _failure -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-induction-fixed.tex" + (\case + ExactProof.ExactProofSetInductionActiveBinderIneligible + location (Raw.NamedVar "x") -> + locLine location == 7 + _failure -> False) + + failedInput <- + moduleInput + foundation bootstrap initialWorkspace + (Declaration.vampireResolver \_prepared -> + pure + (Right + (Provers.CounterSatisfiable + "focused induction child rejection"))) + Declaration.FreshValidation + Module.runTypedModule failedInput >>= \case + Module.TypedModuleFailed _failure prefix -> + assertBool "failed induction child publishes no theorem" + (null (Declaration.pendingModulePrefixBatches prefix)) + _result -> + assertFailure "rejected induction child unexpectedly succeeded" + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix nested)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm nested set-induction module" + =<< compileParsedWorkspaceWithValidation + foundation bootstrap + (countingAcceptedResolver executable warmRuns) + validation nestedWorkspace + assertEqual "warm set induction skips Vampire" + 0 =<< readIORef warmRuns + assertEqual "fresh and warm induction proof validations" + (proofValidations nested) + (proofValidations warm) + assertBool "initial induction publishes one theorem" + (not + (null + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix initial)))) + where + observingResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + locals = Backend.typedProblemLocalPremises problem + modifyIORef' observations + (<> [ LocalReasoningObservation + { localReasoningTarget = + Backend.supportedPropositionTerm + (Backend.typedProblemClaim problem) + , localReasoningGlobalCount = + Vector.length + (Backend.typedProblemGlobalPremises problem) + , localReasoningLocalOrdinals = + Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList locals + , localReasoningLocalTerms = + Backend.supportedPropositionTerm + . Backend.typedLocalPremiseProposition + <$> Vector.toList locals + , localReasoningAuxiliaries = + Backend.typedProblemAuxiliaryTag + <$> Vector.toList + (Backend.typedProblemAuxiliaries problem) + } + ]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + + expectCount label expected values = do + assertEqual label expected (length values) + pure values + + member element set = + Core.CApp + (Core.CApp (Core.CIntrinsic Core.Member) element) + set + + notP proposition = Core.CImp proposition Core.CFalsum + + andP left right = notP (Core.CImp left (notP right)) + + moduleInput foundation bootstrap workspace resolver validation = do + parsed <- sole "set-induction parsed module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + expectRight + (Module.typedModuleInput + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver validation parsed []) + + proofValidations = + concatMap Declaration.committedBatchProofValidations + . Declaration.pendingModulePrefixBatches + . Module.sealedTypedModulePrefix + +routesProductionVerification :: Assertion +routesProductionVerification = + Temp.withSystemTempDirectory "felix-production-route" \directory -> do + let executable = directory Posix.</> "vampire" + counter = directory Posix.</> "runs" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' run >> " <> show counter + , "printf '%s\\n' '% SZS status Theorem for production-route'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + producer <- verifyFixture executable "test/phase3/typed-producer.tex" + assertTypedSuccess "exact producer" producer + selectedRuns <- runCount counter + assertBool "ordinary roots construct the final prelude" + (selectedRuns > 0) + importer <- verifyFixture executable "test/phase3/typed-importer.tex" + assertTypedSuccess "ordinary importer" importer + assertBool "every root constructs the final prelude" + . (> selectedRuns) + =<< runCount counter + where + verifyFixture executable path = + fst + <$> ( + (checkFileFresh + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + path) + >>= expectRight) + + runCount path = + length . StrictText.lines . StrictText.pack <$> readFile path + +installsNonemptyImplicitPreludeEvidence :: Assertion +installsNonemptyImplicitPreludeEvidence = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId foundation) + []) + proposition <- expectRight + (Identity.validatePropositionContent closure Core.CFalsum) + preludeDriver <- Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation + do + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "nonempty-prelude") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchEligible + [Semantic.semanticName "prelude-fact"]) + Declaration.authorizeSourceAxiomCandidate candidate + preludeResult <- expectRight preludeDriver + (preludeSemantic, preludePrefix) <- + case preludeResult of + Declaration.DriverSucceeded _value semantic prefix _closure -> + pure (semantic, prefix) + _ -> + assertFailure "nonempty prelude fixture did not seal" + >> fail "unreachable" + preludeFingerprint <- + case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations preludeSemantic) of + [occurrence] -> + pure (Semantic.semanticFactFingerprint occurrence) + facts -> + assertFailure + ("unexpected prelude fact count: " + <> show (length facts)) + >> fail "unreachable" + let preludeSyntax = + Module.sealedTypedModuleSyntax + (Module.bootstrapPreludeModule bootstrap) + nonemptyPrelude <- + Temp.withSystemTempDirectory "felix-nonempty-prelude" \directory -> do + let path = directory Posix.</> "store.sqlite" + theory = Identity.theoryId foundation + parsed = + Module.identifiedModuleParsed + (Module.bootstrapPreludeInput bootstrap) + (_startup, store) <- + Store.openStore path theory >>= expectRight + artifactKey <- expectRight + (Semantic.moduleArtifactKey + preludeModuleName + (Parse.identifiedParsedModuleId parsed) + [] + theory) + let artifact = + Semantic.moduleArtifactResult + artifactKey + (Syntax.moduleSyntaxAssertedId preludeSyntax) + (Semantic.semanticInterfaceAssertedId + preludeSemantic) + _ <- expectRight + =<< Store.writeSealedModule + store + preludePrefix + [preludeSyntax] + [preludeSemantic] + artifact + memo <- Store.newStoreMemo store + loaded <- expectRight + =<< Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId preludeSyntax) + installation <- maybe + (assertFailure "nonempty prelude was not installed" + >> fail "unreachable") + pure + loaded + sealed <- expectRight + (Module.cachedSealedTypedModule + foundation + [] + installation) + Store.closeStore store + pure sealed + + root <- getCurrentDirectory + mounts <- + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", root) + , (sourceMountId "library", root Posix.</> "library") + , (sourceMountId "debug", root Posix.</> "debug") + ] + request <- expectRight + (searchedRoot "test/phase3/typed-producer.tex") + workspace <- + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) + let parsed = Parse.parsedWorkspaceRootModule workspace + input <- expectRight + (Module.typedModuleInput + foundation + (Module.fixtureFinalPreludeReadinessFromSealed nonemptyPrelude) + unusedResolver + Declaration.FreshValidation + parsed + []) + ordinary <- Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded sealed -> pure sealed + _ -> + assertFailure "ordinary module rejected the nonempty prelude" + >> fail "unreachable" + + consumerDigest <- expectRight + (hashCanonicalFields + "implicit-prelude-consumer" + ["consumer"]) + consumerPath <- expectRight (safeRelativePath "consumer.tex") + let consumerOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest consumerDigest) + consumerPath + consumed <- Declaration.runModuleDriver + foundation + consumerOwner + [Semantic.semanticInterfaceAssertedId + (Module.sealedTypedModuleSemantic ordinary)] + unusedResolver + Declaration.FreshValidation + do + Declaration.importSealedModuleDriver + (Module.sealedTypedModuleEvidence ordinary) + Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "use-implicit-prelude") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate do + void + (Declaration.useAuthorizedFact + preludeFingerprint) + Declaration.recordOmittedUse + consumedResult <- expectRight consumed + case consumedResult of + Declaration.DriverSucceeded{} -> pure () + _ -> + assertFailure + "implicit prelude fact was not transitively visible" + +unusedResolver :: Declaration.VampireResolver +unusedResolver = + Declaration.vampireResolver \_prepared -> + fail "empty bootstrap invoked Vampire" + +writeAcceptedFixtureVampire :: FilePath -> IO () +writeAcceptedFixtureVampire executable = do + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for typed-fixture'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + +withAcceptedFixtureVampire + :: String + -> (Provers.Vampire -> IO value) + -> IO value +withAcceptedFixtureVampire label action = + Temp.withSystemTempDirectory label \directory -> do + let executable = directory Posix.</> "vampire" + writeAcceptedFixtureVampire executable + action + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + +finalPreludeResolver :: Declaration.VampireResolver +finalPreludeResolver = + Declaration.vampireResolver \prepared -> + (Provers.runPreparedTypedProver + (Provers.vampire + "vampire" + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + +countingAcceptedResolver + :: FilePath + -> IORef Int + -> Declaration.VampireResolver +countingAcceptedResolver executable runs = + Declaration.vampireResolver \prepared -> do + modifyIORef' runs (+ 1) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) + +prepareExactInductiveFixture + :: FilePath + -> IO + (Either + ExactInductive.ExactInductiveError + ExactInductive.PreparedExactInductive) +prepareExactInductiveFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- + sole "exact inductive parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let identified = Module.identifiedPhysicalModule parsed + owner = Module.identifiedModuleOwner identified + parsedModule = Module.identifiedModuleParsed identified + (blockIndex, block) <- + sole "exact inductive block" + [ (index, candidate) + | (index, candidate@Raw.BlockInductive{}) <- + zip [0..] + (Parse.identifiedParsedModuleBlocks parsedModule) + ] + let entries = + [ Parse.parsedSyntaxOccurrenceEntry occurrence + | occurrence <- + Parse.identifiedParsedModuleSyntaxOccurrences parsedModule + , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == blockIndex + ] + action + :: Declaration.ModuleDriver Void + (Either + ExactInductive.ExactInductiveError + ExactInductive.PreparedExactInductive) + action = + Declaration.runProspectiveLoweringDriver + (ExactInductive.prepareExactInductive + foundation + block + entries) + result <- + Declaration.runModuleDriver + foundation + owner + [] + unusedResolver + Declaration.FreshValidation + action + driver <- expectRight result + case driver of + Declaration.DriverSucceeded prepared _semantic _prefix _closure -> + pure prepared + Declaration.DriverFailed failure _prefix -> + assertFailure + ("exact inductive preparation driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("exact inductive preparation driver did not seal: " + <> show failure) + >> fail "unreachable" + +prepareExactDatatypeFixture + :: FilePath + -> IO + (Either + ExactDatatype.ExactDatatypeError + ( Foundation.CheckedFoundation + , ModuleName + , ExactDatatype.PreparedExactDatatype + )) +prepareExactDatatypeFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + parsed <- + sole "exact datatype parsed module" + (toList + (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let identified = Module.identifiedPhysicalModule parsed + owner = Module.identifiedModuleOwner identified + parsedModule = Module.identifiedModuleParsed identified + block <- + sole "exact datatype block" + (Parse.identifiedParsedModuleBlocks parsedModule) + let occurrences = + [ ( Parse.parsedSyntaxOccurrenceLocation occurrence + , Parse.parsedSyntaxOccurrenceMarker occurrence + , Parse.parsedSyntaxOccurrenceEntry occurrence + ) + | occurrence <- + Parse.identifiedParsedModuleSyntaxOccurrences parsedModule + , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == 0 + ] + action + :: Declaration.ModuleDriver Void + (Either + ExactDatatype.ExactDatatypeError + ExactDatatype.PreparedExactDatatype) + action = + Declaration.runProspectiveLoweringDriver + (ExactDatatype.prepareExactDatatype block occurrences) + result <- + Declaration.runModuleDriver + foundation + owner + [] + unusedResolver + Declaration.FreshValidation + action + driver <- expectRight result + case driver of + Declaration.DriverSucceeded prepared _semantic _prefix _closure -> + pure + ((\datatype -> (foundation, owner, datatype)) + <$> prepared) + Declaration.DriverFailed failure _prefix -> + assertFailure + ("exact datatype preparation driver failed: " + <> show failure) + >> fail "unreachable" + Declaration.DriverSealFailed failure _prefix -> + assertFailure + ("exact datatype preparation driver did not seal: " + <> show failure) + >> fail "unreachable" + +compileExactFixture + :: FilePath + -> IO + ( Foundation.CheckedFoundation + , Module.BootstrapPreludeFixture + , Parse.ParsedSourceWorkspace + , [Module.SealedTypedModule] + ) +compileExactFixture relative = do + root <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts root + workspace <- parseExactWorkspace bootstrap mounts relative + sealed <- compileParsedWorkspace foundation bootstrap workspace + pure (foundation, bootstrap, workspace, sealed) + +compileExactRootAt + :: FilePath + -> FilePath + -> IO (Parse.ParsedSourceWorkspace, Module.SealedTypedModule) +compileExactRootAt projectRoot relative = do + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts projectRoot + workspace <- parseExactWorkspace bootstrap mounts relative + sealed <- compileParsedWorkspace foundation bootstrap workspace + rootModule <- sole "exact root module" (reverse sealed) + pure (workspace, rootModule) + +exactFixtureMounts :: FilePath -> IO SourceMounts +exactFixtureMounts projectRoot = do + repository <- getCurrentDirectory + expectRight + =<< prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "library", repository Posix.</> "library") + , (sourceMountId "debug", repository Posix.</> "debug") + ] + +parseExactWorkspace + :: Module.BootstrapPreludeFixture + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseExactWorkspace bootstrap mounts relative = + parseExactWorkspaceWithPrelude + (Module.bootstrapPreludeModule bootstrap) + mounts + relative + +parseFinalExactWorkspace + :: Module.FinalPreludeSession + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseFinalExactWorkspace prelude mounts relative = + parseExactWorkspaceWithPrelude + (Module.finalPreludeModule prelude) + mounts + relative + +parseExactWorkspaceWithPrelude + :: Module.SealedTypedModule + -> SourceMounts + -> FilePath + -> IO Parse.ParsedSourceWorkspace +parseExactWorkspaceWithPrelude prelude mounts relative = do + request <- expectRight (searchedRoot relative) + let preludeSyntax = + Module.sealedTypedModuleSyntax + prelude + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) + +compileParsedWorkspace + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspace foundation bootstrap workspace = + compileParsedWorkspaceWithResolver + foundation + bootstrap + unusedResolver + workspace + +compileParsedWorkspaceWithResolver + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Declaration.VampireResolver + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithResolver foundation bootstrap resolver workspace = + compileParsedWorkspaceWithValidation + foundation + bootstrap + resolver + Declaration.FreshValidation + workspace + +compileParsedWorkspaceWithValidation + :: Foundation.CheckedFoundation + -> Module.BootstrapPreludeFixture + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithValidation + foundation bootstrap resolver validation workspace = + compileParsedWorkspaceWithReadiness + foundation + (Module.bootstrapPreludeReadiness bootstrap) + resolver + validation + workspace + +compileFinalParsedWorkspaceWithResolver + :: Foundation.CheckedFoundation + -> Module.FinalPreludeSession + -> Declaration.VampireResolver + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileFinalParsedWorkspaceWithResolver foundation prelude resolver workspace = + compileParsedWorkspaceWithReadiness + foundation + (Module.finalPreludeReadiness prelude) + resolver + Declaration.FreshValidation + workspace + +compileParsedWorkspaceWithReadiness + :: Foundation.CheckedFoundation + -> Module.FinalPreludeReadiness + -> Declaration.VampireResolver + -> Declaration.ValidationRun + -> Parse.ParsedSourceWorkspace + -> IO [Module.SealedTypedModule] +compileParsedWorkspaceWithReadiness + foundation readiness resolver validation workspace = + snd + <$> foldM + compileOne + (Map.empty, []) + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + where + compileOne (admitted, ordered) parsed = do + direct <- + traverse + (\address -> + maybe + (assertFailure + ("missing exact direct module: " <> show address) + >> fail "unreachable") + pure + (Map.lookup address admitted)) + (nubOrd + (Parse.parsedImportedAddress + <$> Parse.parsedModuleImports parsed)) + input <- + expectRight + (Module.typedModuleInput + foundation + readiness + resolver + validation + parsed + direct) + sealed <- + Module.runTypedModule input >>= \case + Module.TypedModuleSucceeded module' -> pure module' + Module.TypedModuleOpenFailed failure -> + assertFailure + ("exact module did not open: " <> show failure) + >> fail "unreachable" + Module.TypedModuleFailed failure _prefix -> + assertFailure + ("exact module did not seal: " <> show failure) + >> fail "unreachable" + pure + ( Map.insert (Parse.parsedModuleAddress parsed) sealed admitted + , ordered <> [sealed] + ) + +checkFileFresh + :: Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileFresh prover source = do + plan <- Store.planStore Store.FreshTemporaryStore >>= expectRight + Store.withStoreLease plan \lease -> do + opened <- Verification.withVerificationSession lease + (\session -> + checkFileWithSession + session + Verification.FreshStoreValidation + testSequentialJobs + ignoredVerificationRequests + prover + source) + case opened of + Left failure -> + assertFailure + ("test verification session failed: " <> show failure) + >> fail "unreachable" + Right result -> pure result + +checkFileWithStore + :: Store.Store + -> Verification.StoreValidationMode + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithStore store mode = + checkFileWithStoreAndJobs store mode testSequentialJobs + +checkFileWithStoreAndJobs + :: Store.Store + -> Verification.StoreValidationMode + -> Provers.EffectiveJobs + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithStoreAndJobs store mode jobs observer prover source = do + opened <- Verification.withVerificationSessionUsingStore store + (\session -> + checkFileWithSession session mode jobs observer prover source) + case opened of + Left failure -> + assertFailure + ("test verification session failed: " <> show failure) + >> fail "unreachable" + Right result -> pure result + +checkResultWithStore + :: Store.Store + -> Verification.StoreValidationMode + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + Verification.VerificationResult) +checkResultWithStore store mode observer prover source = + fmap (fmap fst) + (checkFileWithStore store mode observer prover source) + +checkFileWithSession + :: Verification.VerificationSession + -> Verification.StoreValidationMode + -> Provers.EffectiveJobs + -> Verification.VerificationRequestObserver + -> Provers.Vampire + -> FilePath + -> IO + (Either + Verification.VerificationDriverError + (Verification.VerificationResult, Provers.SlowAtpReport)) +checkFileWithSession session mode jobs observer prover source = + Workspace.prepareDefaultSourceGraph source >>= \case + Left failure -> + pure (Left (Verification.VerificationWorkspaceError failure)) + Right graph -> + fmap + (fmap + (\outcome -> + ( Verification.checkVerificationResult outcome + , Verification.checkSlowAtpReport outcome + ))) + (Verification.checkWorkspace + session + Verification.CheckRequest + { Verification.checkSourceGraph = graph + , Verification.checkStoreValidationMode = mode + , Verification.checkEffectiveJobs = jobs + , Verification.checkVampire = prover + , Verification.checkRequestObserver = observer + }) + +ignoredVerificationRequests :: Verification.VerificationRequestObserver +ignoredVerificationRequests = + Verification.verificationRequestObserver + (\_position _request -> pure ()) + +testSequentialJobs :: Provers.EffectiveJobs +testSequentialJobs = + fromMaybe + (impossible "one is a positive worker count") + (Provers.effectiveJobs 1) + +assertTypedSuccess :: String -> Verification.VerificationResult -> Assertion +assertTypedSuccess label = \case + Verification.VerificationCompleted _report _presentation -> + pure () + Verification.CompletedWithExplicitGaps _report _presentation -> + assertFailure (label <> " completed with gaps") + Verification.VerificationFailure _report failure -> + assertFailure (label <> " failed: " <> show failure) + Verification.VerificationCheckingFailure _report failure -> + assertFailure (label <> " failed: " <> show failure) + +sole :: String -> [value] -> IO value +sole label = \case + [value] -> pure value + values -> + assertFailure + (label <> ": expected one value, found " <> show (length values)) + >> fail "unreachable" + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> assertFailure (show err) >> fail "unreachable" + Right value -> pure value + +expectRightIO :: Show error => IO (Either error value) -> IO value +expectRightIO action = + action >>= expectRight + +acquireFinalPreludeSession + :: Store.Store + -> Foundation.CheckedFoundation + -> Declaration.VampireResolver + -> IO + (Either + Module.FinalPreludeReadinessError + Module.FinalPreludeSession) +acquireFinalPreludeSession store foundation resolver = do + memo <- Store.newStoreMemo store + Module.acquireFinalPreludeSession + memo store foundation resolver diff --git a/source/Felix/Test/Unit/OutputPlan.hs b/source/Felix/Test/Unit/OutputPlan.hs new file mode 100644 index 0000000..803b7da --- /dev/null +++ b/source/Felix/Test/Unit/OutputPlan.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.OutputPlan (unitTests) where + +import Base +import Felix.OutputPlan qualified as Output +import Felix.Source +import Felix.Store qualified as Store + +import Control.Exception qualified as Exception +import System.Directory qualified as Directory +import System.Environment qualified as Environment +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Verification output preflight" + [ testCase "accepts absent and empty dump destinations" + acceptsAbsentAndEmptyDumpDestinations + , testCase "rejects a nonempty dump before store startup" + rejectsNonemptyDumpBeforeStoreStartup + , testCase "rejects persistent and fresh store collisions" + rejectsStoreCollisions + , testCase "reserves the store rollback journal" + reservesRollbackJournal + , testCase "rejects dump and HTML route collisions" + rejectsDumpHtmlCollisions + ] + +acceptsAbsentAndEmptyDumpDestinations :: Assertion +acceptsAbsentAndEmptyDumpDestinations = + Temp.withSystemTempDirectory "felix-output-dump" \root -> do + let storeParent = root Posix.</> "store" + storeFile = storeParent Posix.</> "store.sqlite" + dump = root Posix.</> "dump" + Directory.createDirectory storeParent + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + absent <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + plannedAbsent <- expectOutputRight absent + assertEqual "absent dump path" + (Just dump) + (Output.dumpOutputPath + <$> Output.verificationDumpOutput plannedAbsent) + + Directory.createDirectory dump + emptyResult <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + void (expectOutputRight emptyResult) + +rejectsNonemptyDumpBeforeStoreStartup :: Assertion +rejectsNonemptyDumpBeforeStoreStartup = + Temp.withSystemTempDirectory "felix-output-before-store" \root -> do + let cacheRoot = root Posix.</> "cache" + dump = root Posix.</> "dump" + Directory.createDirectory cacheRoot + Directory.createDirectory dump + writeFile (dump Posix.</> "old.p") "stale" + withEnvironment "XDG_CACHE_HOME" cacheRoot do + plan <- expectRightIO + (Store.planStore Store.DefaultStore) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + case result of + Left Output.DumpDestinationNotEmpty{} -> + pure () + Left other -> + assertFailure + ("unexpected nonempty result: " <> show other) + Right _ -> + assertFailure "nonempty dump was accepted" + assertBool "preflight did not create the default store" + . not + =<< Directory.doesPathExist + (cacheRoot Posix.</> "felix") + +rejectsStoreCollisions :: Assertion +rejectsStoreCollisions = + Temp.withSystemTempDirectory "felix-output-store-collision" \root -> do + let dump = root Posix.</> "dump" + persistentStore = dump Posix.</> "store.sqlite" + Directory.createDirectory dump + persistentPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore persistentStore)) + Store.withStoreLease persistentPlan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just dump) + Nothing + expectCollision result + + freshPlan <- expectRightIO + (Store.planStore Store.FreshTemporaryStore) + Store.withStoreLease freshPlan \lease -> do + let freshParent = + Posix.takeDirectory + (Store.storePathFilePath + (Store.storeLeasePath lease)) + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just freshParent) + Nothing + expectCollision result + + relative <- expectRight (safeRelativePath "page.html") + let htmlRoot = root Posix.</> "html" + htmlStore = htmlRoot Posix.</> "page.html" + Directory.createDirectory htmlRoot + htmlPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore htmlStore)) + Store.withStoreLease htmlPlan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + Nothing + (Just (htmlRoot, [relative])) + expectCollision result + +rejectsDumpHtmlCollisions :: Assertion +rejectsDumpHtmlCollisions = + Temp.withSystemTempDirectory "felix-output-cross-collision" \root -> do + let storeParent = root Posix.</> "store" + storeFile = storeParent Posix.</> "store.sqlite" + htmlRoot = root Posix.</> "html" + Directory.createDirectory storeParent + Directory.createDirectory htmlRoot + relative <- expectRight (safeRelativePath "nested/page.html") + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just htmlRoot) + (Just (htmlRoot, [relative])) + expectCollision result + +reservesRollbackJournal :: Assertion +reservesRollbackJournal = + Temp.withSystemTempDirectory "felix-output-journal" \root -> do + let storeParent = root Posix.</> "store" + storeFile = storeParent Posix.</> "store.sqlite" + journal = storeFile <> "-journal" + Directory.createDirectory storeParent + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore storeFile)) + Store.withStoreLease plan \lease -> do + result <- Output.planVerificationOutputs + (Store.storeLeasePath lease) + (Just journal) + Nothing + case result of + Left + (Output.CollidingOutputNamespaces + (Output.OutputNamespaceCollision + Output.StoreJournalOutputNamespace + reserved + Output.DumpOutputNamespace + requested :| [])) -> do + assertEqual "reserved journal" journal reserved + assertEqual "requested dump" journal requested + Left other -> + assertFailure + ("unexpected journal collision: " <> show other) + Right _ -> + assertFailure "store rollback journal was not reserved" + +expectCollision + :: Either Output.OutputPlanError Output.VerificationOutputPlan + -> Assertion +expectCollision = \case + Left Output.CollidingOutputNamespaces{} -> + pure () + Left other -> + assertFailure + ("unexpected output-plan result: " <> show other) + Right _ -> + assertFailure "colliding output namespaces were accepted" + +expectOutputRight + :: Either Output.OutputPlanError Output.VerificationOutputPlan + -> IO Output.VerificationOutputPlan +expectOutputRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right plan -> + pure plan + +expectRight :: Show failure => Either failure value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +expectRightIO + :: Show failure + => IO (Either failure value) + -> IO value +expectRightIO action = + expectRight =<< action + +withEnvironment + :: String + -> String + -> IO value + -> IO value +withEnvironment name value action = + Exception.bracket + (Environment.lookupEnv name) + restore + \_previous -> do + Environment.setEnv name value + action + where + restore = \case + Nothing -> + Environment.unsetEnv name + Just previous -> + Environment.setEnv name previous diff --git a/source/Felix/Test/Unit/Provers.hs b/source/Felix/Test/Unit/Provers.hs new file mode 100644 index 0000000..f1e3cc1 --- /dev/null +++ b/source/Felix/Test/Unit/Provers.hs @@ -0,0 +1,1159 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Provers (unitTests) where + +import Base hiding (Empty) +import Felix.Checking.Backend.Problem +import Felix.Checking.Core +import Felix.Provers + +import Control.Concurrent + ( newEmptyMVar + , putMVar + , takeMVar + , threadDelay + ) +import Control.Exception (bracket) +import Control.Exception qualified as Exception +import Control.Monad (when) +import Data.IORef + ( atomicModifyIORef' + , newIORef + , readIORef + , writeIORef + ) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Data.Vector qualified as Vector +import Felix.Report.Location (Location(..)) +import System.Directory qualified as Directory +import System.Exit (ExitCode(..)) +import System.FilePath.Posix ((</>)) +import System.Posix.Signals + ( nullSignal + , sigTERM + , signalProcess + ) +import System.Posix.Types (ProcessID) +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit +import Text.Read (readMaybe) +import Text.Megaparsec (parseMaybe) +import UnliftIO.Async (cancel, mapConcurrently, withAsync) +import UnliftIO.Async qualified as Async + +unitTests :: TestTree +unitTests = + testGroup "Provers" + [ vampireStatusParserTests + , vampireClassifierTests + , jobsSelectionTests + , slowAtpReportTests + , vampireExecutorTests + , vampireProcessTests + ] + +jobsSelectionTests :: TestTree +jobsSelectionTests = + testGroup "effective jobs" + [ testCase "uses a positive override exactly" do + detectorCalled <- newIORef False + selected <- selectEffectiveJobs + (effectiveJobs 3) + (writeIORef detectorCalled True >> pure 99) + selected `shouldBe` positiveJobs 3 + readIORef detectorCalled >>= (`shouldBe` False) + , testCase "rounds automatic jobs to one third of detected processors" do + for_ + [(8, 3), (16, 5), (24, 8), (32, 11)] + \(detected, expected) -> do + selected <- selectEffectiveJobs Nothing (pure detected) + selected `shouldBe` positiveJobs expected + , testCase "falls back to one after bad detection" do + nonPositive <- selectEffectiveJobs Nothing (pure 0) + nonPositive `shouldBe` positiveJobs 1 + failed <- selectEffectiveJobs Nothing + (Exception.throwIO (userError "processor detection failed")) + failed `shouldBe` positiveJobs 1 + ] + +slowAtpReportTests :: TestTree +slowAtpReportTests = + testGroup "slow ATP report" + [ testCase "applies the threshold and retains the twelve slowest" do + prepared <- preparedTypedTask 0 + let requestId = + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + task nanoseconds position = + SlowAtpTask + { slowAtpDuration = + atpDurationFromNanoseconds nanoseconds + , slowAtpOutcome = SlowAtpAccepted + , slowAtpPosition = workPosition 1 position + , slowAtpLocation = testLocation + , slowAtpRequestId = requestId + } + report = slowAtpReportFromTasks + ( task 4999999999 0 + : [ task (5000000000 + fromIntegral position) position + | position <- [0..13] + ] + ) + slowAtpQualifyingTaskCount report `shouldBe` 14 + length (slowAtpTasks report) `shouldBe` 12 + slowAtpOmittedTaskCount report `shouldBe` 2 + atpDurationNanoseconds + (slowAtpDuration + (fromMaybe + (error "slow report unexpectedly empty") + (listToMaybe (slowAtpTasks report)))) + `shouldBe` 5000000013 + , testCase "keeps earlier source positions on equal durations" do + prepared <- preparedTypedTask 0 + let requestId = + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + task position = + SlowAtpTask + { slowAtpDuration = + atpDurationFromNanoseconds 5000000000 + , slowAtpOutcome = SlowAtpAccepted + , slowAtpPosition = workPosition 1 position + , slowAtpLocation = testLocation + , slowAtpRequestId = requestId + } + report = slowAtpReportFromTasks (task <$> [1..13]) + (workPositionLocalRequestOrdinal . slowAtpPosition + <$> slowAtpTasks report) + `shouldBe` [1..12] + ] + +vampireExecutorTests :: TestTree +vampireExecutorTests = + testGroup "bounded Vampire executor" + [ testCase "records completed qualifying tasks with runtime context" do + prepared <- preparedTypedTask 0 + clock <- scriptedClock [10, 5000000010] + let position = workPosition 2 3 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutorUsingClock + clock + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + position + testLocation + (preparedTypedProverRequest prepared) + awaitVampireRequest handle + >>= assertAcceptedRequest prepared + report <- vampireExecutorSlowAtpReport executor + slowAtpQualifyingTaskCount report `shouldBe` 1 + case slowAtpTasks report of + [task] -> do + atpDurationNanoseconds + (slowAtpDuration task) + `shouldBe` 5000000000 + slowAtpOutcome task `shouldBe` SlowAtpAccepted + slowAtpPosition task `shouldBe` position + slowAtpLocation task `shouldBe` testLocation + slowAtpRequestId task `shouldBe` + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + tasks -> + assertFailure + ("unexpected slow-task report: " + <> show tasks) + , testCase "does not report a cancelled partial task" do + prepared <- preparedTypedTask 0 + clock <- scriptedClock [0, 6000000000] + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutorUsingClock + clock + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + cancelVampireRequest handle + report <- vampireExecutorSlowAtpReport executor + slowAtpQualifyingTaskCount report `shouldBe` 0 + assertBool "cancelled report is empty" + (null (slowAtpTasks report)) + assertProcessesGone processIds + , testCase "opaque handles complete out of submission order" do + prepared <- preparedTypedTask 0 + firstStarted <- newEmptyMVar + releaseFirst <- newEmptyMVar + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 2) + vampireCommand + (\position _request -> + when + (workPositionLocalRequestOrdinal position == 1) + (putMVar firstStarted () >> takeMVar releaseFirst)) + \executor -> withVampireRequestOwner executor \owner -> do + first <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + takeMVar firstStarted + second <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + secondCompletion <- awaitVampireRequest second + assertAcceptedRequest prepared secondCompletion + putMVar releaseFirst () + firstCompletion <- awaitVampireRequest first + assertAcceptedRequest prepared firstCompletion + , testCase "validates request identity before a rejection" do + submitted <- preparedTypedTask 0 + mismatched <- preparedTypedTask 1 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status CounterSatisfiable for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest submitted) + outcome <- Exception.try + (awaitPreparedVampireRequest + (preparedTypedProverRequest mismatched) + handle) + case outcome of + Left (failure :: VampireExecutorFault) -> + assertBool + "request mismatch is an integrity fault" + ("wrong request id" + `Text.isInfixOf` + Text.pack (show failure)) + Right answer -> + assertFailure + ("mismatched rejection was accepted: " + <> show answer) + , testCase "runs requests through the bounded worker pool" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "previous=''" + , "found=0" + , "for argument in \"$@\"; do" + , " if [ \"$previous\" = '--cores' ]; then" + , " [ \"$argument\" = '2' ] || exit 17" + , " found=1" + , " fi" + , " previous=$argument" + , "done" + , "[ \"$found\" = '1' ] || exit 18" + , "cat >/dev/null" + , "sleep 0.2" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 2) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + answers <- mapConcurrently + (\ordinal -> + runPreparedTypedProverWithExecutor + owner + (workPosition 1 ordinal) + testLocation + prepared) + [1..4] + traverse_ assertProved answers + , testCase "propagates observer failure to the submitter" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> + Exception.throwIO + (userError "observer failed")) + \executor -> withVampireRequestOwner executor \owner -> do + result <- Exception.try + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) + case result of + Left (failure :: VampireExecutorFault) -> + assertBool + "global executor fault" + ("observer failed" + `Text.isInfixOf` + Text.pack (show failure)) + Right answer -> + assertFailure + ("observer failure was lost: " + <> show answer) + , testCase "cancels queued and running jobs independently" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> + withAsync + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) + \running -> do + processIds <- waitForProcessIds pidFile + queuedSubmitted <- newEmptyMVar + withAsync + (do + handle <- submitVampireRequest + owner + (workPosition 2 1) + testLocation + (preparedTypedProverRequest prepared) + putMVar queuedSubmitted () + awaitPreparedVampireRequest + (preparedTypedProverRequest prepared) + handle) + \queued -> do + takeMVar queuedSubmitted + cancel queued + cancel running + assertProcessesGone processIds + , testCase "explicit cancellation completes queued and running handles" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + running <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + queued <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + cancelVampireRequest queued + awaitVampireRequest queued + >>= assertCancelled prepared + cancelVampireRequest running + awaitVampireRequest running + >>= assertCancelled prepared + assertProcessesGone processIds + , testCase "structured shutdown wakes waiter and full-queue submitter" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> do + (waiter, blockedSubmit, processIds) <- + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> + withVampireRequestOwner executor \owner -> do + running <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + processIds <- waitForProcessIds pidFile + _queuedOne <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + _queuedTwo <- submitVampireRequest + owner + (workPosition 1 3) + testLocation + (preparedTypedProverRequest prepared) + waiter <- Async.async + (awaitVampireRequest running) + submitStarted <- newEmptyMVar + blockedSubmit <- Async.async do + putMVar submitStarted () + submitVampireRequest + owner + (workPosition 1 4) + testLocation + (preparedTypedProverRequest prepared) + takeMVar submitStarted + pure (waiter, blockedSubmit, processIds) + Async.waitCatch waiter >>= \case + Right completion -> + assertCancelled prepared completion + Left failure -> + assertFailure + ("shutdown waiter failed: " <> show failure) + Async.waitCatch blockedSubmit >>= \case + Left failure -> + assertBool + "backpressured submit observes owner shutdown" + ("VampireRequestOwnerClosed" + `Text.isInfixOf` + Text.pack (show failure)) + Right _handle -> + assertFailure + "backpressured submit survived structured shutdown" + assertProcessesGone processIds + , testCase "worker fault wakes a waiter and a full-queue submitter" do + prepared <- preparedTypedTask 0 + observerEntered <- newEmptyMVar + failObserver <- newEmptyMVar + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' '% SZS status Theorem for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\position _request -> + when + (workPositionLocalRequestOrdinal position == 1) + (putMVar observerEntered () + >> takeMVar failObserver + >> Exception.throwIO + (userError "fatal observer fault"))) + \executor -> withVampireRequestOwner executor \owner -> do + first <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + takeMVar observerEntered + _second <- submitVampireRequest + owner + (workPosition 1 2) + testLocation + (preparedTypedProverRequest prepared) + _third <- submitVampireRequest + owner + (workPosition 1 3) + testLocation + (preparedTypedProverRequest prepared) + withAsync + (submitVampireRequest + owner + (workPosition 1 4) + testLocation + (preparedTypedProverRequest prepared)) + \blockedSubmit -> do + putMVar failObserver () + awaitFault (awaitVampireRequest first) + Async.waitCatch blockedSubmit >>= \case + Left failure -> + assertExecutorFault failure + Right _handle -> + assertFailure + "full-queue submission survived executor fault" + , testCase "declared launch failure remains request-local" do + prepared <- preparedTypedTask 0 + let missing = vampire + "/definitely/missing/felix-vampire" + defaultTimeLimit + defaultMemoryLimit + withVampireExecutor + (positiveJobs 1) + missing + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireProcessFailed ProverLaunchFailed{} -> pure () + terminal -> + assertFailure + ("expected a local launch failure, got " + <> show terminal) + , testCase "protocol failure is distinct from ATP rejection" do + prepared <- preparedTypedTask 0 + withFakeVampire + [ "cat >/dev/null" + , "printf '%s\n' 'completed without an SZS status'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireProtocolFailed{} -> pure () + terminal -> + assertFailure + ("expected a protocol terminal, got " + <> show terminal) + , testCase "completed rejection diagnostics are compact" do + prepared <- preparedTypedTask 0 + let headMarker :: Text + headMarker = "HEAD-MARKER" + tailMarker :: Text + tailMarker = "TAIL-MARKER" + status :: Text + status = "% SZS status CounterSatisfiable for fake" + originalByteCount = + Text.length headMarker + + 1048576 + + Text.length tailMarker + 1 + + Text.length status + 1 + withFakeVampire + [ "printf '%s' 'HEAD-MARKER'" + , "head -c 1048576 /dev/zero" + , "printf '%s\n' 'TAIL-MARKER'" + , "printf '%s\n' '% SZS status CounterSatisfiable for fake'" + ] + \vampireCommand -> + withVampireExecutor + (positiveJobs 1) + vampireCommand + (\_position _request -> pure ()) + \executor -> withVampireRequestOwner executor \owner -> do + handle <- submitVampireRequest + owner + (workPosition 1 1) + testLocation + (preparedTypedProverRequest prepared) + completion <- awaitVampireRequest handle + case renderVampireTerminalDiagnostic + (vampireCompletionTerminal completion) of + Just diagnostic -> do + assertBool + "retained diagnostic is bounded" + (Text.length diagnostic < 70000) + assertBool + "truncation is reported" + ("retained first and last 16 KiB" + `Text.isInfixOf` diagnostic) + assertBool + "original byte count is reported" + (("of " + <> Text.pack + (show originalByteCount) + <> " bytes)") + `Text.isInfixOf` diagnostic) + assertBool + "diagnostic head is retained" + (headMarker `Text.isInfixOf` diagnostic) + assertBool + "diagnostic tail is retained" + (tailMarker `Text.isInfixOf` diagnostic) + Nothing -> + assertFailure "expected a rejected terminal" + ] + +positiveJobs :: Int -> EffectiveJobs +positiveJobs amount = + fromMaybe + (error "test requested a non-positive job count") + (effectiveJobs amount) + +scriptedClock :: [Word64] -> IO (IO Word64) +scriptedClock ticks = do + remaining <- newIORef ticks + pure + (atomicModifyIORef' remaining \case + next : rest -> (rest, next) + [] -> error "test monotonic clock exhausted") + +testLocation :: Location +testLocation = Location maxBound + +vampireStatusParserTests :: TestTree +vampireStatusParserTests = + testGroup "Vampire status parser" + [ testCase "parses canonical status lines" do + parseMaybe + vampireStatusParser + "% SZS status ContradictoryAxioms for 2260" + `shouldBe` Just StatusContradictoryAxioms + , testCase "parses worker-prefixed status lines" do + parseMaybe + vampireStatusParser + "% (2581105)SZS status Timeout for " + `shouldBe` Just StatusTimeout + , testCase "parses ResourceOut status" do + parseMaybe + vampireStatusParser + "% SZS status ResourceOut for 2260" + `shouldBe` Just StatusResourceOut + , testCase "retains unsupported status values" do + parseMaybe + vampireStatusParser + "% SZS status AlienResult for 2260" + `shouldBe` Just (UnsupportedStatus "AlienResult") + ] + +vampireClassifierTests :: TestTree +vampireClassifierTests = + testGroup "Vampire completed transcript classifier" + [ testCase "maps each terminal status in both task modes" do + classify DirectTask [StatusTheorem] + `shouldBe` Right Proved + classify DirectTask [StatusCounterSatisfiable] + `shouldBe` Right Counterexample + classify DirectTask [StatusContradictoryAxioms] + `shouldBe` Right ContradictoryInput + classify IndirectTask [StatusContradictoryAxioms] + `shouldBe` Right Proved + , testCase "maps every resource status to indeterminate" do + for_ indeterminateStatuses \status -> + classify DirectTask [status] + `shouldBe` Right Indeterminate + , testCase "lets a unique terminal outcome override resource statuses" do + for_ indeterminateStatuses \status -> + classify DirectTask [status, StatusTheorem] + `shouldBe` Right Proved + , testCase "accepts duplicate and equivalent terminal statuses" do + classify DirectTask [StatusTheorem, StatusTheorem] + `shouldBe` Right Proved + classify + IndirectTask + [StatusTheorem, StatusContradictoryAxioms] + `shouldBe` Right Proved + , testCase "rejects every pair of different terminal outcomes" do + for_ conflictingTerminalCases + \(mode, statuses, outcomes) -> + classify mode statuses + `shouldBe` + Left (ConflictingTerminalOutcomes outcomes) + , testCase "is independent of status order" do + for_ orderCases \(mode, statuses) -> + classify mode statuses + `shouldBe` classify mode (reverse statuses) + , testCase "rejects unsupported status values" do + classify + DirectTask + [StatusTheorem, UnsupportedStatus "AlienResult"] + `shouldBe` + Left + (UnsupportedVampireStatuses + (Set.singleton "AlienResult")) + , testCase "rejects a successful exit without an outcome" do + classify DirectTask [] + `shouldBe` Left MissingVampireOutcome + , testCase "rejects every status after a nonzero exit" do + classifyVampireProtocol + DirectTask + (ExitFailure 7) + [StatusTheorem] + `shouldBe` + Left (UnsuccessfulVampireExit (ExitFailure 7)) + ] + +vampireProcessTests :: TestTree +vampireProcessTests = + testGroup "Vampire process boundary" + [ testCase "classifies statuses from both completed streams" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Timeout for fake'" + , "printf '%s\\n' '% SZS status Theorem for fake' >&2" + , "exit 0" + ] + assertProved answer + , testCase "rejects a split-stream terminal conflict" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for fake'" + , "printf '%s\\n' '% SZS status CounterSatisfiable for fake' >&2" + , "exit 0" + ] + assertProtocolError "ConflictingTerminalOutcomes" answer + , testCase "rejects a theorem from a nonzero exit" do + answer <- runFakeVampire + [ "printf '%s\\n' '% SZS status Theorem for fake'" + , "exit 7" + ] + assertProtocolError "ExitFailure 7" answer + , testCase "rejects malformed UTF-8 output" do + answer <- runFakeVampire + [ "printf '\\377'" + , "exit 0" + ] + case answer of + Left + (ProverOutputMalformedUtf8 + _ + ProverOutputStdout + _) -> + pure () + result -> + assertFailure + ("expected malformed stdout, got " <> show result) + , testCase "returns a broken stdin pipe" do + prepared <- preparedTypedTask 20000 + result <- withFakeVampire + [ "exec 0<&-" + , "sleep 1" + ] + \vampireCommand -> + runPreparedTypedProver vampireCommand prepared + case result of + Left (ProverCommunicationFailed _ ProverStdin _) -> + pure () + processResult -> + assertFailure + ("expected a communication failure, got " + <> show processResult) + , testCase "drains output while feeding prover input" do + prepared <- preparedTypedTask 20000 + guardedAnswer <- Timeout.timeout + 30000000 + (withFakeVampire + [ "head -c 1048576 /dev/zero &" + , "head -c 1048576 /dev/zero >&2 &" + , "wait" + , "printf '\\n'" + , "printf '\\n' >&2" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for fake'" + , "exit 0" + ] + \vampireCommand -> do + runPreparedTypedProver vampireCommand prepared) + case guardedAnswer of + Nothing -> + assertFailure "prover communication did not finish" + Just answer -> + assertProved answer + , testCase "reports signal termination separately" do + prepared <- preparedTypedTask 0 + result <- withFakeVampire + [ "kill -TERM $$" + ] + \vampireCommand -> + runPreparedTypedProver vampireCommand prepared + case result of + Left + (ProverTerminatedBySignal + _ + signalNumber + _) -> + assertEqual + "termination signal" + (fromIntegral sigTERM) + signalNumber + processResult -> + assertFailure + ("expected signal termination, got " + <> show processResult) + , testCase "deadline terminates and reaps the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + (Seconds 0) + [] + \pidFile vampireCommand -> do + result <- + runPreparedTypedProver vampireCommand prepared + assertTimedOut result + processIds <- readProcessIds pidFile + assertProcessesGone processIds + , testCase "output exhaustion terminates the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [ "head -c 33554432 /dev/zero" + ] + \pidFile vampireCommand -> do + result <- + runPreparedTypedProver vampireCommand prepared + case result of + Left + (ProverOutputLimitExceeded + _ + ProverOutputStdout + _) -> + pure () + processResult -> + assertFailure + ("expected stdout limit exhaustion, got " + <> show processResult) + processIds <- readProcessIds pidFile + assertProcessesGone processIds + , testCase "cancellation terminates and reaps the process group" do + prepared <- preparedTypedTask 0 + withProcessGroupFake + defaultTimeLimit + [] + \pidFile vampireCommand -> + withAsync + (runPreparedTypedProver vampireCommand prepared) + \worker -> do + processIds <- waitForProcessIds pidFile + cancel worker + assertProcessesGone processIds + ] + +classify + :: VampireTaskMode + -> [VampireStatus] + -> Either VampireProtocolError CanonicalAtpOutcome +classify mode = + classifyVampireProtocol mode ExitSuccess + +indeterminateStatuses :: [VampireStatus] +indeterminateStatuses = + [ StatusTimeout + , StatusResourceOut + , StatusGaveUp + , StatusUnknown + ] + +conflictingTerminalCases + :: [(VampireTaskMode, [VampireStatus], Set CanonicalAtpOutcome)] +conflictingTerminalCases = + [ ( DirectTask + , [StatusTheorem, StatusCounterSatisfiable] + , Set.fromList [Proved, Counterexample] + ) + , ( DirectTask + , [StatusTheorem, StatusContradictoryAxioms] + , Set.fromList [Proved, ContradictoryInput] + ) + , ( DirectTask + , [StatusCounterSatisfiable, StatusContradictoryAxioms] + , Set.fromList [Counterexample, ContradictoryInput] + ) + , ( IndirectTask + , [StatusTheorem, StatusCounterSatisfiable] + , Set.fromList [Proved, Counterexample] + ) + , ( IndirectTask + , [StatusCounterSatisfiable, StatusContradictoryAxioms] + , Set.fromList [Proved, Counterexample] + ) + ] + +orderCases :: [(VampireTaskMode, [VampireStatus])] +orderCases = + [ (DirectTask, StatusTheorem : indeterminateStatuses) + , (DirectTask, [StatusTheorem, StatusCounterSatisfiable]) + , (IndirectTask, [StatusTheorem, StatusContradictoryAxioms]) + , (DirectTask, [UnsupportedStatus "B", UnsupportedStatus "A"]) + ] + +assertProved + :: Either ProverProcessError ProverAnswer + -> Assertion +assertProved = \case + Right Yes -> + pure () + answer -> + assertFailure ("expected a proof, got " <> show answer) + +assertAcceptedRequest + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertAcceptedRequest prepared completion = do + assertCompletionRequest prepared completion + case vampireCompletionTerminal completion of + VampireAccepted -> pure () + terminal -> + assertFailure ("expected an accepted terminal, got " <> show terminal) + +assertCompletionRequest + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertCompletionRequest prepared completion = + vampireCompletionRequestId completion + `shouldBe` + preparedVerificationRequestId + (preparedTypedProverRequest prepared) + +assertCancelled + :: PreparedTypedProverTask ref local origin global + -> VampireCompletion + -> Assertion +assertCancelled prepared completion = do + assertCompletionRequest prepared completion + vampireCompletionTerminal completion `shouldBe` VampireCancelled + +awaitFault :: IO value -> Assertion +awaitFault action = do + result <- Exception.try action + case result of + Left failure -> assertExecutorFault failure + Right _value -> assertFailure "expected a global executor fault" + +assertExecutorFault :: Exception.SomeException -> Assertion +assertExecutorFault failure = + case Exception.fromException failure :: Maybe VampireExecutorFault of + Just _fault -> pure () + Nothing -> + assertFailure + ("expected VampireExecutorFault, got " <> show failure) + +assertProtocolError + :: Text + -> Either ProverProcessError ProverAnswer + -> Assertion +assertProtocolError expected = \case + Right (Error _label diagnostic) -> + assertBool + ( "expected protocol error containing " + <> show expected + <> ", got " + <> show diagnostic + ) + (expected `Text.isInfixOf` diagnostic) + answer -> + assertFailure ("expected a protocol error, got " <> show answer) + +assertTimedOut + :: Either ProverProcessError a + -> Assertion +assertTimedOut = \case + Left ProverTimedOut{} -> + pure () + result -> + assertFailure ("expected prover timeout, got " <> showResult result) + where + showResult = \case + Left err -> + show err + Right _ -> + "successful process result" + +withProcessGroupFake + :: TimeLimit + -> [String] + -> (FilePath -> Vampire -> IO a) + -> IO a +withProcessGroupFake timeLimit body action = + withFakeVampireIn + (\temp -> + let pidFile = temp </> "process-ids" + in [ "trap '' TERM" + , "sleep 60 &" + , "printf '%s %s\\n' \"$$\" \"$!\" > " <> pidFile + ] + <> body + <> ["wait"]) + timeLimit + \temp -> + action (temp </> "process-ids") + +readProcessIds :: FilePath -> IO [ProcessID] +readProcessIds path = do + contents <- Text.readFile path + case traverse + (readMaybe . Text.unpack) + (Text.words contents) of + Just processIds@[_leader, _descendant] -> + pure processIds + _ -> + assertFailure + ("expected leader and descendant process ids, got " + <> show contents) + +waitForProcessIds :: FilePath -> IO [ProcessID] +waitForProcessIds path = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just processIds -> + pure processIds + Nothing -> + assertFailure "fake prover did not publish its process ids" + where + loop = do + exists <- Directory.doesFileExist path + if exists + then readProcessIds path + else do + threadDelay 10000 + loop + +assertProcessesGone :: [ProcessID] -> Assertion +assertProcessesGone processIds = do + guarded <- Timeout.timeout 10000000 loop + case guarded of + Just () -> + pure () + Nothing -> + assertFailure + ("supervisor left processes running: " + <> show processIds) + where + loop = do + alive <- traverse processIsAlive processIds + if or alive + then do + threadDelay 10000 + loop + else pure () + +processIsAlive :: ProcessID -> IO Bool +processIsAlive processId = + (signalProcess nullSignal processId >> pure True) + `Exception.catch` \(err :: Exception.IOException) -> + if isDoesNotExistError err + then pure False + else throwIO err + +runFakeVampire + :: [String] + -> IO (Either ProverProcessError ProverAnswer) +runFakeVampire scriptLines = + withFakeVampire + (["cat >/dev/null"] <> scriptLines) + \vampireCommand -> do + prepared <- preparedTypedTask 0 + runPreparedTypedProver vampireCommand prepared + +withFakeVampire + :: [String] + -> (Vampire -> IO a) + -> IO a +withFakeVampire scriptLines action = + withFakeVampireIn + (const scriptLines) + defaultTimeLimit + (const action) + +withFakeVampireIn + :: (FilePath -> [String]) + -> TimeLimit + -> (FilePath -> Vampire -> IO a) + -> IO a +withFakeVampireIn makeScript timeLimit action = + withTemporaryDirectory "felix-fake-vampire" \temp -> do + let executablePath = temp </> "vampire" + writeFile executablePath + (unlines + ( [ "#!/bin/sh" + ] + <> makeScript temp + )) + permissions <- Directory.getPermissions executablePath + Directory.setPermissions executablePath + (Directory.setOwnerExecutable True permissions) + action + temp + (vampire + executablePath + timeLimit + defaultMemoryLimit) + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = + flip (assertEqual "") + +preparedTypedTask + :: Int + -> IO (PreparedTypedProverTask Int Void Void Void) +preparedTypedTask factCount = do + checked <- expectRight + (checkScopedCanonicalCore + (const Nothing) + [] + propositionTerm) + proposition <- expectRight + (supportedProposition Vector.empty checked) + capability <- expectRight + (classifySupportedProposition (const Nothing) proposition) + let facts = + Vector.generate + factCount + (\reference -> + typedBackendFact reference proposition capability) + problem <- expectRight + (planTypedProblem + (const Nothing) + facts + proposition + [] + [] + FirstOrderLocals + ExplicitHigherOrderJustification) + expectRight (prepareTypedProverTask DirectTask problem) + where + propositionTerm = + CEq TySet + (CIntrinsic Empty) + (CIntrinsic Empty) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Semantic.hs b/source/Felix/Test/Unit/Semantic.hs new file mode 100644 index 0000000..f62a003 --- /dev/null +++ b/source/Felix/Test/Unit/Semantic.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Semantic (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity +import Felix.Source +import Felix.Source.Content +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Abstract qualified as Raw + +import Data.ByteString (ByteString) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "Semantic interfaces" + [ testCase "separates syntax and semantic Merkle identities" + separatesSyntaxAndSemantics + , testCase "round-trips closed semantic declaration state" + roundTripsSemanticState + , testCase "round-trips exact semantic global keys" + roundTripsSemanticGlobalKeys + , testCase "round-trips canonical structure descriptors" + roundTripsStructureDescriptors + , testCase "keys exact proof and module inputs" + keysExactInputs + ] + +separatesSyntaxAndSemantics :: Assertion +separatesSyntaxAndSemantics = do + fixture <- makeFixture + firstSyntax <- makeSyntax "first" + secondSyntax <- makeSyntax "second" + assertBool + "notation changes syntax identity" + ( Syntax.moduleSyntaxAssertedId firstSyntax + /= Syntax.moduleSyntaxAssertedId secondSyntax + ) + assertEqual + "notation does not enter semantic prefix identity" + (fixtureNextPrefix fixture) + (Semantic.nextPrefixContextId + (fixtureInitialPrefix fixture) + (fixtureDelta fixture)) + +roundTripsSemanticState :: Assertion +roundTripsSemanticState = do + fixture <- makeFixture + assertEqual + "semantic interface cache round trip" + (Right (fixtureInterface fixture)) + (decodeCache + Semantic.getSemanticInterfaceCache + (encodeCache + (Semantic.putSemanticInterfaceCache + (fixtureInterface fixture)))) + assertEqual + "walking-subset environment delta round trip" + (Right Semantic.emptySemanticEnvironmentDelta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache + Semantic.emptySemanticEnvironmentDelta))) + +roundTripsSemanticGlobalKeys :: Assertion +roundTripsSemanticGlobalKeys = do + fixture <- makeFixture + let unary = Raw.HoleCons (Raw.TokenCons (Raw.Command "f") Raw.End) + plural = Raw.HoleCons (Raw.TokenCons (Raw.Word "things") Raw.End) + keys = + [ Semantic.SemanticLeftAdjective unary + , Semantic.SemanticRightAdjective unary + , Semantic.SemanticFunctionPhrase unary plural + , Semantic.SemanticNoun unary plural + , Semantic.SemanticVerb unary plural + , Semantic.SemanticRelation + (Raw.Command "rel") + (Raw.ParameterArity 2) + , Semantic.SemanticExpressionFunction unary + , Semantic.SemanticPrefixPredicate "Pred" 3 + ] + target = + Identity.intrinsicObjectId + (fixtureTheory fixture) + Core.Empty + Core.TySet + bindings = + List.sortOn Semantic.semanticGlobalBindingKey + ( case keys of + [] -> [] + first : rest -> + Semantic.semanticGlobalBinding + first + (Semantic.ContextualTransparentExpansion + target + (Map.singleton + (Raw.StructSymbol "operation") + target)) + : [ Semantic.semanticGlobalBinding + key + (Semantic.GlobalReference target) + | key <- rest + ] + ) + delta <- expectRight (Semantic.semanticEnvironmentDelta bindings) + assertEqual "binding cache round trip" + (Right delta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache delta))) + case bindings of + first : second : _ -> do + assertEqual "rejects noncanonical order" + (Left Semantic.NonCanonicalSemanticGlobalBindingOrder) + (Semantic.semanticEnvironmentDelta + (second : first : drop 2 bindings)) + assertEqual "rejects duplicate key" + (Left + (Semantic.DuplicateSemanticGlobalKey + (Semantic.semanticGlobalBindingKey first))) + (Semantic.semanticEnvironmentDelta [first, first]) + _ -> assertFailure "semantic key fixture is unexpectedly empty" + +roundTripsStructureDescriptors :: Assertion +roundTripsStructureDescriptors = do + fixture <- makeFixture + let structurePhrase marker word = + Semantic.semanticStructurePhrase + (Raw.LexicalItemSgPl + (Raw.SgPl + (Raw.TokenCons (Raw.Word word) Raw.End) + (Raw.TokenCons (Raw.Word (word <> "s")) Raw.End)) + marker) + base = structurePhrase "onesorted_structure" "base" + child = structurePhrase "ordered_structure" "ordered" + object = + Identity.intrinsicObjectId + (fixtureTheory fixture) + Core.Empty + Core.TySet + operation = + Semantic.semanticStructureOperation + (Raw.StructSymbol "carrier") + object + descriptor <- expectRight + (Semantic.semanticStructureDescriptor + child + (Just object) + [base] + [operation]) + delta <- expectRight + (Semantic.semanticEnvironmentWithStructures [] [descriptor]) + assertEqual + "structure environment cache round trip" + (Right delta) + (decodeCache + Semantic.getSemanticEnvironmentDeltaCache + (encodeCache + (Semantic.putSemanticEnvironmentDeltaCache delta))) + assertEqual + "duplicate local operation is rejected" + (Left + (Semantic.DuplicateSemanticStructureOperation + (Raw.StructSymbol "carrier"))) + (Semantic.semanticStructureDescriptor + child + (Just object) + [base] + [operation, operation]) + +keysExactInputs :: Assertion +keysExactInputs = do + fixture <- makeFixture + let authority = + Authority.factAuthority + (fixtureTheorem fixture) + Authority.cleanAuthoritySafety + certificate <- expectRight + (Authority.validationCertificate + authority + (Authority.CheckedSourceProof [])) + let theorem = + Identity.theoremId + (fixtureTheorem fixture) + firstProof = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-a") + (fixtureInitialPrefix fixture) + secondProof = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-b") + (fixtureInitialPrefix fixture) + laterContext = + Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "proof-a") + (fixtureNextPrefix fixture) + assertBool + "proof syntax is an exact validation input" + (firstProof /= secondProof) + assertBool + "semantic predecessor is an exact validation input" + (firstProof /= laterContext) + let proofRecord = + Semantic.proofValidationRecord + firstProof certificate + declarationKey = + Semantic.declarationValidationKey + (Semantic.declarationSyntaxId "declaration") + (fixtureInitialPrefix fixture) + [] + [theorem, theorem] + declarationRecord = + Semantic.declarationValidationRecord + declarationKey + [certificate, certificate] + assertEqual + "proof validation record cache round trip" + (Right proofRecord) + (decodeCache + Semantic.getProofValidationRecordCache + (encodeCache + (Semantic.putProofValidationRecordCache + proofRecord))) + assertEqual + "ordered declaration certificates retain repetitions" + (Right declarationRecord) + (decodeCache + Semantic.getDeclarationValidationRecordCache + (encodeCache + (Semantic.putDeclarationValidationRecordCache + declarationRecord))) + firstParsedKey <- expectRight + (parsedModuleKey + (fixtureSourceContentId "source-a") + Syntax.baseSyntaxInterfaceId + []) + secondParsedKey <- expectRight + (parsedModuleKey + (fixtureSourceContentId "source-b") + Syntax.baseSyntaxInterfaceId + []) + directSyntax <- makeSyntax "direct" + let directSyntaxId = + Syntax.moduleSyntaxAssertedId directSyntax + assertEqual + "parsed identity rejects duplicate direct syntax" + (Left + (DuplicateParsedDirectSyntaxInput + directSyntaxId)) + (parsedModuleKey + (fixtureSourceContentId "source-a") + Syntax.baseSyntaxInterfaceId + [directSyntaxId, directSyntaxId]) + let + firstParsed = + parsedModuleId firstParsedKey "parsed" + secondParsed = + parsedModuleId secondParsedKey "parsed" + firstArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (fixtureOwner fixture) + firstParsed + [] + (fixtureTheory fixture)) + secondArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (fixtureOwner fixture) + secondParsed + [] + (fixtureTheory fixture)) + let firstArtifact = + Semantic.moduleArtifactId firstArtifactKey + secondArtifact = + Semantic.moduleArtifactId secondArtifactKey + assertBool + "module artifact binds parsed source identity" + (firstArtifact /= secondArtifact) + let semanticId = + Semantic.semanticInterfaceAssertedId + (fixtureInterface fixture) + assertEqual + "prefix identity rejects duplicate direct semantics" + (Left + (Semantic.DuplicateInitialPrefixSemanticInput + semanticId)) + (Semantic.initialPrefixContextId + (fixtureTheory fixture) + (fixtureOwner fixture) + [semanticId, semanticId]) + assertEqual + "module artifact key cache round trip" + (Right firstArtifactKey) + (decodeCache + Semantic.getModuleArtifactKeyCache + (encodeCache + (Semantic.putModuleArtifactKeyCache + firstArtifactKey))) + syntax <- makeSyntax "artifact" + let artifactResult = + Semantic.moduleArtifactResult + firstArtifactKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId + (fixtureInterface fixture)) + assertEqual + "module artifact root round trip" + (Right artifactResult) + (decodeCache + (Semantic.getModuleArtifactResultCache + firstArtifact) + (encodeCache + (Semantic.putModuleArtifactResultCache + artifactResult))) + + +data Fixture = Fixture + { fixtureTheory :: !Identity.TheoryId + , fixtureOwner :: !ModuleName + , fixtureTheorem :: !Identity.TheoremRef + , fixtureDelta :: !Semantic.DeclarationInterfaceDelta + , fixtureInterface :: !Semantic.SemanticInterface + , fixtureInitialPrefix :: !Semantic.PrefixContextId + , fixtureNextPrefix :: !Semantic.PrefixContextId + } + +makeFixture :: IO Fixture +makeFixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields + "semantic-test-namespace" + ["root"]) + relative <- expectRight (safeRelativePath "module.tex") + closure <- expectRight + (Identity.validateObjectClosure + (Identity.theoryId foundation) + []) + proposition <- expectRight + (Identity.validatePropositionContent + closure + Core.CFalsum) + let theory = + Identity.theoryId foundation + owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + reference = + Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + authority = + Authority.factAuthority + reference + Authority.cleanAuthoritySafety + occurrence = + Semantic.semanticFactOccurrence + (Semantic.factSlot owner (localFactOrdinal 0)) + authority + Semantic.SearchEligible + slot = + Semantic.declarationSlot + owner + (localDeclarationOrdinal 0) + delta <- expectRight + (Semantic.declarationInterfaceDelta + slot + [occurrence] + [ Semantic.semanticAlias + (Semantic.semanticName "theorem") + (Semantic.semanticFactOccurrenceFingerprint + (Semantic.factSlot owner (localFactOrdinal 0)) + authority) + ] + [] + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + interface <- expectRight + (Semantic.semanticInterface owner [] [delta]) + initial <- expectRight + (Semantic.initialPrefixContextId theory owner []) + pure + Fixture + { fixtureTheory = theory + , fixtureOwner = owner + , fixtureTheorem = reference + , fixtureDelta = delta + , fixtureInterface = interface + , fixtureInitialPrefix = initial + , fixtureNextPrefix = + Semantic.nextPrefixContextId initial delta + } + +makeSyntax :: Text -> IO Syntax.ModuleSyntaxInterface +makeSyntax command = do + delta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation command]) + expectRight (Syntax.moduleSyntaxInterface [] delta) + +fixtureSourceContentId :: ByteString -> SourceContentId +fixtureSourceContentId bytes = + either + (impossible . show) + id + (decodeCache + getSourceContentIdCache + (encodeCache + (putCacheDigest + (hashCacheFields + "semantic-test-source" + [bytes])))) + +expectRight :: Show error => Either error value -> IO value +expectRight = \case + Left err -> + assertFailure (show err) >> fail "unreachable" + Right value -> + pure value diff --git a/source/Felix/Test/Unit/Source.hs b/source/Felix/Test/Unit/Source.hs new file mode 100644 index 0000000..6216381 --- /dev/null +++ b/source/Felix/Test/Unit/Source.hs @@ -0,0 +1,2581 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Felix.Test.Unit.Source (unitTests) where + +import Base +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec qualified as Cache +import Felix.Module qualified as Module +import Felix.Parse qualified as Parse +import Felix.Parsed.Identity qualified as ParsedIdentity +import Felix.Parsed.Payload qualified as Parsed +import Felix.Prelude qualified as Prelude +import Felix.Source +import Felix.Source.Content qualified as Content +import Felix.Source.Graph +import Felix.Store qualified as Store +import Felix.Report.Location + ( FileId(..) + , FileIdAllocator(..) + , Location(..) + , LocationRegistrationError(..) + , allocateFileId + , locColumn + , locFile + , locFileId + , locLine + , lookupFileIdentityPath + ) +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt qualified as Adapt +import Felix.Syntax.Interface qualified as Interface +import Felix.Syntax.Token (runLexer) + +import Control.Exception (bracket, evaluate) +import Data.ByteString qualified as ByteString +import Data.IORef +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Data.Word (Word8, Word16) +import Database.SQLite.Simple qualified as SQLite +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import System.Posix.Files qualified as PosixFiles +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = testGroup "Source resolution" + [ testCase "validates mount-root-relative POSIX paths" validatesRelativePaths + , testCase "rejects duplicate source mount ids" rejectsDuplicateMountIds + , testCase "rejects duplicate canonical mount roots" rejectsDuplicateMountRoots + , testCase "permits missing and rejects non-directory mounts" + validatesMountRootTypes + , testCase "rejects relative exact roots" rejectsRelativeExactRoots + , testCase "retains exact root spelling as diagnostic trivia" retainsRootSpelling + , testCase "searched and exact roots share canonical identity" rootFormsShareIdentity + , testCase "attributes nested sources to the most specific mount" attributesNestedSources + , testCase "configured order selects searched candidates" candidateOrderSelectsWinner + , testCase "rejects a higher-priority special source" + rejectsHigherPrioritySpecialSource + , testCase "rejects exact roots outside configured mounts" rejectsOutsideExactRoot + , testCase "loads source text as strict UTF-8" loadsStrictUtf8 + , testCase "reports malformed UTF-8 sequence starts" + reportsInvalidUtf8Offsets + , testCase "reserves the all-ones file identifier" + preservesReservedFileId + , testCase "builds an imported-before-importer source graph" buildsSourceGraph + , testCase "rejects the packaged prelude as ordinary source" + rejectsPackagedPreludeAsOrdinarySource + , testCase "orders sibling imports by textual occurrence" + ordersSiblingImports + , testCase "orders shared dependencies before their importers" + ordersSharedDependencies + , testCase "retains repeated import-edge occurrences" retainsRepeatedImports + , testCase "deduplicates canonical source nodes" deduplicatesCanonicalNodes + , testCase "reports missing imports at their source location" reportsMissingImports + , testCase "rejects unsafe imports at their source location" rejectsUnsafeImports + , testCase "reports the located import cycle chain" reportsImportCycles + , testCase "rejects malformed imported source before discovery" rejectsMalformedImportedSource + , testCase "builds empty modules through the ordinary pipeline" + buildsEmptyModules + , testCase "identifies owner-independent parsed modules" + identifiesOwnerIndependentParsedModules + , testCase "keys effective direct syntax inputs" + keysEffectiveDirectSyntaxInputs + , testCase "reuses exact parsed syntax on a warm pass" + reusesExactParsedSyntax + , testCase "invalidates exact parsed inputs transitively" + invalidatesExactParsedInputs + , testCase "rebinds relocated parsed artifacts" + rebindsRelocatedParsedArtifacts + , testCase "rejects a corrupted cached declaration anchor" + rejectsCorruptedCachedDeclarationAnchor + , testCase "parses source-local blocks in graph order" parsesSourceGraph + , testCase "does not leak syntax between sibling imports" + rejectsSiblingSyntaxLeakage + , testCase "parses source fixity levels and grouping" + parsesSourceFixities + , testCase "parses cdot and symdiff fixities" + parsesLibraryFixities + , testCase "validates source pragma associations" + validatesSourcePragmaAssociations + , testCase "rejects fixed-base category mismatches" + rejectsFixedBaseCategoryMismatch + , testCase "retains multi-item syntax occurrence order" + retainsMultiItemSyntaxOccurrences + , testCase "propagates and coalesces imported syntax" + propagatesImportedSyntax + , testCase "rejects unequal imported syntax" + rejectsUnequalImportedSyntax + , testCase "qualifies same-display cross-mount collisions" + distinguishesPhysicalSourceLocations + , testCase "retains each workspace location display path" + retainsWorkspaceLocationDisplayPath + , testCase "reports imported scanner errors before importer tokenizer errors" + reportsImportedScannerErrorFirst + , testCase "returns malformed lexical declarations as typed errors" + reportsMalformedLexicalDeclaration + , testCase "validates inductive function patterns during scanning" + rejectsMalformedInductivePattern + , testCase "scans and parses adjective signatures" + acceptsAdjectiveSignature + , testCase "rejects malformed math-led signature heads" + rejectsMalformedSignatureHead + , testCase "locates conflicting declarations within one environment" + reportsSameSourceLexiconCollision + , testCase "accepts the first source declaration of a built-in pattern" + acceptsBuiltinSourceDeclaration + , testCase "keeps the built-in marker for a prefix predicate declaration" + acceptsBuiltinPrefixPredicateDeclaration + , testCase "does not rescan repeated canonical imports" + avoidsAliasImportLexiconCollision + , testCase "parses loaded sources without rereading files" parsesWithoutRereading + , testCase "returns source-local failures after prior chunk callbacks" + returnsSourceParseFailures + , testCase "rejects guarded symbolic declarations before publication" + rejectsGuardedSymbolicDeclarations + ] + +validatesRelativePaths :: Assertion +validatesRelativePaths = do + assertRight (safeRelativePath "theory/set.tex") + assertRight (safeRelativePath "theory\\set.tex") + assertLeft EmptyRelativePath (safeRelativePath "") + assertLeft AbsoluteRelativePath (safeRelativePath "/theory.tex") + assertLeft CurrentDirectoryComponent (safeRelativePath "./theory.tex") + assertLeft ParentDirectoryComponent (safeRelativePath "a/../theory.tex") + assertLeft EmptyPathComponent (safeRelativePath "a//theory.tex") + assertLeft EmptyPathComponent (safeRelativePath "a/") + assertLeft NullPathCharacter (safeRelativePath "a\0b") + +rejectsDuplicateMountIds :: Assertion +rejectsDuplicateMountIds = + withTemporaryDirectory "felix-source-duplicate-id" \temp -> do + result <- prepareSourceMounts + [ (sourceMountId "same", temp Posix.</> "one") + , (sourceMountId "same", temp Posix.</> "two") + ] + assertEqual + "duplicate id" + (Left (DuplicateSourceMountId (sourceMountId "same"))) + result + +rejectsDuplicateMountRoots :: Assertion +rejectsDuplicateMountRoots = + withTemporaryDirectory "felix-source-duplicate-root" \temp -> do + result <- prepareSourceMounts + [ (sourceMountId "one", temp) + , (sourceMountId "two", temp Posix.</> ".") + ] + canonical <- Directory.canonicalizePath temp + case result of + Left (DuplicateCanonicalMountRoot root firstId secondId) -> do + assertEqual "canonical root" canonical (canonicalPathFilePath root) + assertEqual "first mount id" (sourceMountId "one") firstId + assertEqual "second mount id" (sourceMountId "two") secondId + Left err -> + assertFailure ("expected DuplicateCanonicalMountRoot, got " <> show err) + Right mounts -> + assertFailure ("expected duplicate-root rejection, got " <> show mounts) + +validatesMountRootTypes :: Assertion +validatesMountRootTypes = + withTemporaryDirectory "felix-source-mount-type" \temp -> do + let ident = sourceMountId "project" + missing = temp Posix.</> "missing" + regularFile = temp Posix.</> "file" + assertRight =<< prepareSourceMounts [(ident, missing)] + + writeFile regularFile "" + result <- prepareSourceMounts [(ident, regularFile)] + case result of + Left SourceMountNotDirectory{} -> + pure () + Left err -> + assertFailure + ("expected SourceMountNotDirectory, got " <> show err) + Right mounts -> + assertFailure + ("expected non-directory rejection, got " <> show mounts) + +rejectsRelativeExactRoots :: Assertion +rejectsRelativeExactRoots = + assertEqual + "relative exact roots are rejected" + (Left (ExistingRootNotAbsolute "entry.tex")) + =<< existingRoot "entry.tex" + +retainsRootSpelling :: Assertion +retainsRootSpelling = + withTemporaryDirectory "felix-source-root-spelling" \temp -> do + let source = temp Posix.</> "entry.tex" + alias = temp Posix.</> "entry-alias.tex" + writeFile source "" + Directory.createFileLink source alias + direct <- expectRight =<< existingRoot source + throughAlias <- expectRight =<< existingRoot alias + assertEqual "canonical request identity" direct throughAlias + assertEqual "diagnostic spelling" alias + (rootRequestSpelling throughAlias) + +rootFormsShareIdentity :: Assertion +rootFormsShareIdentity = + withTemporaryDirectory "felix-source-root-identity" \temp -> do + let source = temp Posix.</> "entry.tex" + writeFile source "source" + mounts <- oneMount "project" temp + searched <- expectRight (searchedRoot "entry.tex") + exact <- expectRight =<< existingRoot source + searchedLoaded <- expectRight =<< resolveAndLoadRoot mounts searched + exactLoaded <- expectRight =<< resolveAndLoadRoot mounts exact + assertEqual "loaded source" searchedLoaded exactLoaded + assertEqual "source mount" + (resolvedSourceMount (loadedSource searchedLoaded)) + (resolvedSourceMount (loadedSource exactLoaded)) + assertEqual "mount-relative source path" + (resolvedSourceRelativePath (loadedSource searchedLoaded)) + (resolvedSourceRelativePath (loadedSource exactLoaded)) + +rejectsPackagedPreludeAsOrdinarySource :: Assertion +rejectsPackagedPreludeAsOrdinarySource = do + packaged <- expectRight =<< Prelude.loadReservedPreludeSourceInput + canonical <- expectJust "packaged canonical path" + (Prelude.reservedPreludeSourceCanonicalPath packaged) + let path = canonicalPathFilePath canonical + mounts <- oneMount "packaged" (Posix.takeDirectory path) + request <- expectRight (searchedRoot (Posix.takeFileName path)) + let validate = Prelude.rejectOrdinaryPreludeSourceGraph packaged + syntaxInputs = const [] + Parse.parseSourceWorkspaceWithSyntaxInputsAndGraphValidation + mounts request syntaxInputs validate >>= \case + Left + (Parse.SourceWorkspaceError + (PackagedPreludeSelectedAsOrdinarySource source)) -> + assertEqual "authority-free rejected path" + canonical + (resolvedSourceCanonicalPath source) + other -> + assertFailure + ("unexpected authority-free result: " <> show other) + + withTemporaryDirectory "felix-reserved-parse-store" \temp -> do + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix.</> "store.sqlite") + (Identity.theoryId foundation) + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation + store mounts request syntaxInputs validate >>= \case + Left + (Parse.ParseExecutionWorkspaceError + (Parse.SourceWorkspaceError + (PackagedPreludeSelectedAsOrdinarySource source))) -> + assertEqual "typed rejected path" + canonical + (resolvedSourceCanonicalPath source) + other -> + assertFailure + ("unexpected typed result: " <> show other) + Store.closeStore store + +attributesNestedSources :: Assertion +attributesNestedSources = + withTemporaryDirectory "felix-source-nested-mount" \temp -> do + let nested = temp Posix.</> "library" + source = nested Posix.</> "entry.tex" + Directory.createDirectory nested + writeFile source "source" + exact <- expectRight =<< existingRoot source + outerFirst <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", temp) + , (sourceMountId "library", nested) + ] + innerFirst <- expectRight =<< prepareSourceMounts + [ (sourceMountId "library", nested) + , (sourceMountId "project", temp) + ] + searched <- expectRight (searchedRoot "library/entry.tex") + outerFirstSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot outerFirst exact) + innerFirstSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot innerFirst exact) + searchedSource <- loadedSource <$> (expectRight =<< resolveAndLoadRoot outerFirst searched) + assertEqual "order-independent attribution" outerFirstSource innerFirstSource + assertEqual "root-form-independent attribution" outerFirstSource searchedSource + assertEqual "most specific mount" (sourceMountId "library") (resolvedSourceMount outerFirstSource) + assertEqual "mount-relative identity" "entry.tex" + (safeRelativePathFilePath (resolvedSourceRelativePath outerFirstSource)) + +candidateOrderSelectsWinner :: Assertion +candidateOrderSelectsWinner = + withTemporaryDirectory "felix-source-precedence" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + firstSource = firstRoot Posix.</> "entry.tex" + secondSource = secondRoot Posix.</> "entry.tex" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile firstSource "first" + writeFile secondSource "second" + request <- expectRight (searchedRoot "entry.tex") + firstMounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "first", firstRoot) + , (sourceMountId "second", secondRoot) + ] + secondMounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "second", secondRoot) + , (sourceMountId "first", firstRoot) + ] + firstWinner <- expectRight =<< resolveAndLoadRoot firstMounts request + secondWinner <- expectRight =<< resolveAndLoadRoot secondMounts request + assertEqual "first configured source" "first" (loadedText firstWinner) + assertEqual "reversed configured source" "second" (loadedText secondWinner) + +rejectsHigherPrioritySpecialSource :: Assertion +rejectsHigherPrioritySpecialSource = + withTemporaryDirectory "felix-source-special-precedence" \temp -> do + let higherRoot = temp Posix.</> "higher" + lowerRoot = temp Posix.</> "lower" + higherSource = higherRoot Posix.</> "entry.tex" + lowerSource = lowerRoot Posix.</> "entry.tex" + Directory.createDirectory higherRoot + Directory.createDirectory lowerRoot + PosixFiles.createNamedPipe higherSource PosixFiles.ownerModes + writeFile lowerSource "ordinary source" + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "higher", higherRoot) + , (sourceMountId "lower", lowerRoot) + ] + request <- expectRight (searchedRoot "entry.tex") + result <- resolveRoot mounts request + case result of + Left + (SelectedSourceNotRegular + (SearchedRootLookup relative) + selectedPath + canonical) -> do + assertEqual "searched path" + "entry.tex" + (safeRelativePathFilePath relative) + assertEqual "selected higher candidate" + higherSource + selectedPath + canonicalHigher <- + Directory.canonicalizePath higherSource + assertEqual "selected canonical target" + canonicalHigher + (canonicalPathFilePath canonical) + Left err -> + assertFailure + ("expected SelectedSourceNotRegular, got " <> show err) + Right source -> + assertFailure + ("expected special-source rejection, got " <> show source) + +rejectsOutsideExactRoot :: Assertion +rejectsOutsideExactRoot = + withTemporaryDirectory "felix-source-outside-root" \temp -> do + let mountRoot = temp Posix.</> "mount" + outsideRoot = temp Posix.</> "outside" + source = outsideRoot Posix.</> "entry.tex" + Directory.createDirectory mountRoot + Directory.createDirectory outsideRoot + writeFile source "source" + mounts <- oneMount "project" mountRoot + exact <- expectRight =<< existingRoot source + result <- resolveAndLoadRoot mounts exact + case result of + Left (RootOutsideConfiguredMount spelling _canonical) -> + assertEqual "exact-root diagnostic spelling" source spelling + Left err -> + assertFailure ("expected RootOutsideConfiguredMount, got " <> show err) + Right loaded -> + assertFailure ("expected outside-root rejection, got " <> show loaded) + +loadsStrictUtf8 :: Assertion +loadsStrictUtf8 = + withTemporaryDirectory "felix-source-utf8" \temp -> do + let source = temp Posix.</> "unicode.tex" + bytes = + ByteString.pack + [ 0xCE, 0xB1, 0x20, 0xE2 + , 0x88, 0x88, 0x20, 0x41 + ] + ByteString.writeFile source bytes + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "unicode.tex") + loaded <- expectRight =<< resolveAndLoadRoot mounts request + assertEqual "exact bytes" bytes (loadedBytes loaded) + assertEqual "decoded text" ("α ∈ A" :: Text) (loadedText loaded) + assertEqual + "byte count" + (fromIntegral (ByteString.length bytes)) + (loadedByteCount loaded) + let identifier = + Content.sourceContentId loaded + assertEqual + "content identity cache round trip" + (Right identifier) + (Cache.decodeCache + Content.getSourceContentIdCache + (Cache.encodeCache + (Content.putSourceContentIdCache + identifier))) + ByteString.writeFile source (bytes <> "\n") + changed <- expectRight + =<< loadResolvedSource (loadedSource loaded) + assertBool + "exact byte edits change source identity" + (identifier /= Content.sourceContentId changed) + +reportsInvalidUtf8Offsets :: Assertion +reportsInvalidUtf8Offsets = + withTemporaryDirectory "felix-source-invalid-utf8" \temp -> do + let source = temp Posix.</> "invalid.tex" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "invalid.tex") + let assertOffset label bytes expected = do + ByteString.writeFile source (ByteString.pack bytes) + result <- resolveAndLoadRoot mounts request + case result of + Left (SourceDecodeError _source offset) -> + assertEqual label expected offset + Left err -> + assertFailure + ("expected SourceDecodeError, got " <> show err) + Right loaded -> + assertFailure + ("expected malformed UTF-8 rejection, got " + <> show loaded) + assertOffset "malformed sequence start" [0x61, 0xC3, 0x28] 1 + assertOffset "incomplete sequence start" [0x61, 0xC3] 1 + +preservesReservedFileId :: Assertion +preservesReservedFileId = + case allocateFileId boundaryAllocator of + Left err -> + assertFailure + ("could not allocate last available file id: " <> show err) + Right (fileId, exhaustedAllocator) -> do + assertEqual "last available file id" + (maxBound - 1) + (unFileId fileId) + assertBool "allocator returned reserved file id" + (unFileId fileId /= maxBound) + assertEqual "allocator reports exhaustion" + (Left FileIdSpaceExhausted) + (allocateFileId exhaustedAllocator) + where + boundaryAllocator = + FileIdAllocator + (fromIntegral (maxBound :: Word16) - 1) + +buildsSourceGraph :: Assertion +buildsSourceGraph = + withTemporaryDirectory "felix-source-graph" \temp -> do + writeTheory (temp Posix.</> "shared.tex") [] "shared" + writeTheory (temp Posix.</> "entry.tex") ["shared.tex"] "entry" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + assertEqual "two source nodes" 2 (length (sourceGraphNodes graph)) + case sourceGraphImportEdges graph of + [edge] -> do + assertEqual "root imports" (sourceGraphRoot graph) (sourceImportingNode edge) + assertEqual + "imported-before-importer order" + [sourceImportedNode edge, sourceGraphRoot graph] + ( sourceNodeCanonicalPathForTest + <$> toList + (sourceGraphImportedBeforeImporter graph) + ) + assertEqual "import location line" 1 + (locLine (importLocation (sourceImportReference edge))) + assertEqual "selected location path" "entry.tex" + (locFile (importLocation (sourceImportReference edge))) + edges -> + assertFailure ("expected one import edge, got " <> show edges) + +ordersSiblingImports :: Assertion +ordersSiblingImports = + withTemporaryDirectory "felix-source-sibling-order" \temp -> do + writeTheory (temp Posix.</> "a.tex") [] "a" + writeTheory (temp Posix.</> "b.tex") [] "b" + writeTheory + (temp Posix.</> "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + order <- sourceGraphOrderPaths graph + assertEqual "DFS completion order" + ["a.tex", "b.tex", "entry.tex"] + order + +ordersSharedDependencies :: Assertion +ordersSharedDependencies = + withTemporaryDirectory "felix-source-shared-order" \temp -> do + writeTheory (temp Posix.</> "shared.tex") [] "shared" + writeTheory (temp Posix.</> "a.tex") ["shared.tex"] "a" + writeTheory (temp Posix.</> "b.tex") ["shared.tex"] "b" + writeTheory + (temp Posix.</> "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + order <- sourceGraphOrderPaths graph + assertEqual "shared dependency occurs once before both importers" + ["shared.tex", "a.tex", "b.tex", "entry.tex"] + order + +retainsRepeatedImports :: Assertion +retainsRepeatedImports = + withTemporaryDirectory "felix-source-repeated-import" \temp -> do + writeTheory (temp Posix.</> "shared.tex") [] "shared" + writeTheory + (temp Posix.</> "entry.tex") + ["shared.tex", "shared.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + assertEqual "canonical node count" 2 (length (sourceGraphNodes graph)) + assertEqual "repeated edge count" 2 (length (sourceGraphImportEdges graph)) + +deduplicatesCanonicalNodes :: Assertion +deduplicatesCanonicalNodes = + withTemporaryDirectory "felix-source-canonical-dedup" \temp -> do + let shared = temp Posix.</> "shared.tex" + alias = temp Posix.</> "alias.tex" + writeTheory shared [] "shared" + Directory.createFileLink shared alias + writeTheory + (temp Posix.</> "entry.tex") + ["shared.tex", "alias.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + assertEqual "one node for symlink aliases" 2 (length (sourceGraphNodes graph)) + case sourceGraphImportEdges graph of + [firstEdge, secondEdge] -> + assertEqual + "both occurrences reach one node" + (sourceImportedNode firstEdge) + (sourceImportedNode secondEdge) + edges -> + assertFailure ("expected two import edges, got " <> show edges) + +reportsMissingImports :: Assertion +reportsMissingImports = + withTemporaryDirectory "felix-source-missing-import" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "% heading" + , "\\import{missing.tex}" + , theoryBlock "entry" + ]) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceNotFound (ImportedSourceLookup _ reference) _candidates) -> do + assertEqual "missing import line" 2 (locLine (importLocation reference)) + assertEqual "missing import source" "entry.tex" + (locFile (importLocation reference)) + Left err -> + assertFailure ("expected located SourceNotFound, got " <> show err) + Right graph -> + assertFailure ("expected missing-import rejection, got " <> show graph) + +rejectsUnsafeImports :: Assertion +rejectsUnsafeImports = + withTemporaryDirectory "felix-source-unsafe-import" \temp -> do + writeTheory (temp Posix.</> "entry.tex") ["./shared.tex"] "entry" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (InvalidImportPath _source location raw CurrentDirectoryComponent) -> do + assertEqual "raw import" "./shared.tex" raw + assertEqual "unsafe import line" 1 (locLine location) + assertEqual "unsafe import source" "entry.tex" (locFile location) + Left err -> + assertFailure ("expected InvalidImportPath, got " <> show err) + Right graph -> + assertFailure ("expected unsafe-import rejection, got " <> show graph) + +reportsImportCycles :: Assertion +reportsImportCycles = + withTemporaryDirectory "felix-source-cycle" \temp -> do + writeTheory (temp Posix.</> "a.tex") ["b.tex"] "a" + writeTheory (temp Posix.</> "b.tex") ["a.tex"] "b" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "a.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceImportCycle steps) -> do + assertEqual "cycle length" 2 (length steps) + assertEqual + "cycle importer sequence" + ["a.tex", "b.tex"] + [ safeRelativePathFilePath + (resolvedSourceRelativePath (cycleImporter step)) + | step <- toList steps + ] + assertEqual + "cycle import locations" + ["a.tex", "b.tex"] + [ locFile (importLocation (cycleImport step)) + | step <- toList steps + ] + Left err -> + assertFailure ("expected SourceImportCycle, got " <> show err) + Right graph -> + assertFailure ("expected cycle rejection, got " <> show graph) + +rejectsMalformedImportedSource :: Assertion +rejectsMalformedImportedSource = + withTemporaryDirectory "felix-source-import-utf8" \temp -> do + writeTheory (temp Posix.</> "entry.tex") ["bad.tex"] "entry" + ByteString.writeFile + (temp Posix.</> "bad.tex") + (ByteString.pack [0x61, 0xFF]) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + result <- buildResolvedSourceGraph mounts request + case result of + Left (SourceDecodeError source offset) -> do + assertEqual "bad source" "bad.tex" + (safeRelativePathFilePath (resolvedSourceRelativePath source)) + assertEqual "bad byte offset" 1 offset + Left err -> + assertFailure ("expected SourceDecodeError, got " <> show err) + Right graph -> + assertFailure ("expected malformed-source rejection, got " <> show graph) + +buildsEmptyModules :: Assertion +buildsEmptyModules = + withTemporaryDirectory "felix-source-empty" \temp -> + forM_ + [ ("empty.tex", "") + , ("comments.tex", "% heading\n% body") + ] + \(relative, contents) -> do + writeFile (temp Posix.</> relative) contents + graph <- buildSearchedGraph temp relative + assertEqual + "one ordinary graph node" + 1 + (length (sourceGraphNodes graph)) + emittedRef <- newIORef (0 :: Int) + workspace <- + expectRight + =<< Parse.parseResolvedSourceGraphWith + graph + (\_source _block -> + modifyIORef' emittedRef (+ 1)) + assertEqual + "no block callbacks" + 0 + =<< readIORef emittedRef + assertEqual + "empty parsed projection" + [] + (Parse.importedBeforeImporterBlocks workspace) + assertBool + "empty syntax declarations" + (null + (Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface + (Parse.parsedWorkspaceRootModule + workspace))))) + +identifiesOwnerIndependentParsedModules :: Assertion +identifiesOwnerIndependentParsedModules = + withTemporaryDirectory "felix-parsed-identity" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + bytes = axiomBlock "same" "x = x" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix.</> "entry.tex") bytes + writeFile (secondRoot Posix.</> "entry.tex") bytes + firstWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph firstRoot "entry.tex" + secondWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + assertBool + "logical owners remain distinct" + ( Module.moduleName (Parse.parsedModuleAddress first) + /= Module.moduleName (Parse.parsedModuleAddress second) + ) + assertEqual + "equal bytes retain one content identity" + (Parse.parsedModuleSourceContentId first) + (Parse.parsedModuleSourceContentId second) + assertEqual + "physical source registration is outside parsed identity" + (Parse.parsedModuleId first) + (Parse.parsedModuleId second) + assertEqual + "canonical payload is owner-independent" + (Parse.parsedModulePayload first) + (Parse.parsedModulePayload second) + let payload = Parse.parsedModulePayload first + assertEqual + "canonical parsed payload cache round trip" + (Right payload) + (Cache.decodeCache + Parsed.getCanonicalParsedPayloadCache + (Cache.encodeCache + (Parsed.putCanonicalParsedPayloadCache payload))) + rebound <- expectRight + (Parsed.decodeCanonicalParsedPayload + (FileId 123) + payload) + case Parsed.decodedParsedBlocks rebound of + Raw.BlockAxiom location _title _marker _axiom : _ -> + assertEqual + "decoded locations bind only to the current live file" + (Just (FileId 123)) + (locFileId location) + blocks -> + assertFailure + ("expected decoded axiom, got " <> show blocks) + writeFile + (secondRoot Posix.</> "entry.tex") + (bytes <> "% content identity change\n") + changedWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + assertBool + "exact source changes parsed identity" + ( Parse.parsedModuleId first + /= Parse.parsedModuleId + (Parse.parsedWorkspaceRootModule changedWorkspace) + ) + +keysEffectiveDirectSyntaxInputs :: Assertion +keysEffectiveDirectSyntaxInputs = + withTemporaryDirectory "felix-parsed-syntax-input" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + rootBytes = "\\import{notation.tex}\n" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix.</> "entry.tex") rootBytes + writeFile (secondRoot Posix.</> "entry.tex") rootBytes + writeFile + (firstRoot Posix.</> "notation.tex") + (syntaxFunctionDefinition + "first_notation" + "firstop" + (Just "%! infixl 1")) + writeFile + (secondRoot Posix.</> "notation.tex") + (syntaxFunctionDefinition + "second_notation" + "secondop" + (Just "%! infixl 1")) + firstWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph firstRoot "entry.tex" + secondWorkspace <- expectRight + =<< Parse.parseResolvedSourceGraph + =<< buildSearchedGraph secondRoot "entry.tex" + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + assertEqual + "root source bytes are unchanged" + (Parse.parsedModuleSourceContentId first) + (Parse.parsedModuleSourceContentId second) + assertBool + "effective syntax changes the parsed key" + (Parse.parsedModuleKey first /= Parse.parsedModuleKey second) + assertBool + "effective syntax changes parsed identity" + (Parse.parsedModuleId first /= Parse.parsedModuleId second) + +reusesExactParsedSyntax :: Assertion +reusesExactParsedSyntax = + withTemporaryDirectory "felix-parsed-warm" \temp -> do + let datatype = unlines + [ "\\begin{datatype}\\label{multi_item}" + , " Define $\\itemkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $\\itemzero \\in \\itemkind$." + , " \\item $\\itemsucc{x} \\in \\itemkind$ for $x \\in \\itemkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ] + writeFile + (temp Posix.</> "entry.tex") + (builtinZeroDefinition "source_zero" <> datatype) + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix.</> "store.sqlite") + (Identity.theoryId foundation) + coldCallbacks <- newIORef (0 :: Int) + cold <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + store mounts request (const []) + (\_source _block -> modifyIORef' coldCallbacks (+ 1)) + warmCallbacks <- newIORef (0 :: Int) + warm <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + store mounts request (const []) + (\_source _block -> modifyIORef' warmCallbacks (+ 1)) + let coldRoot = Parse.parsedWorkspaceRootModule cold + warmRoot = Parse.parsedWorkspaceRootModule warm + let expectedChunkCount = + length (Parse.parsedModuleBlocks warmRoot) + assertBool "fixture has source chunks" (expectedChunkCount > 0) + assertEqual "cold callbacks" expectedChunkCount + =<< readIORef coldCallbacks + assertEqual "warm callbacks" expectedChunkCount + =<< readIORef warmCallbacks + assertEqual "warm blocks" (Parse.parsedModuleBlocks coldRoot) + (Parse.parsedModuleBlocks warmRoot) + assertEqual "warm occurrences" + (Parse.parsedModuleSyntaxOccurrences coldRoot) + (Parse.parsedModuleSyntaxOccurrences warmRoot) + assertEqual "warm syntax interface" + (Parse.parsedModuleSyntaxInterface coldRoot) + (Parse.parsedModuleSyntaxInterface warmRoot) + assertEqual "warm parsed identity" + (Parse.parsedModuleId coldRoot) + (Parse.parsedModuleId warmRoot) + case Parse.parsedModuleSyntaxOccurrences warmRoot of + first : second : third : fourth : [] -> do + assertEqual "fixed source marker" "source_zero" + (Parse.parsedSyntaxOccurrenceMarker first) + case Parse.parsedSyntaxOccurrenceEntry first of + Interface.CanonicalExpressionFunction + _pattern marker _fixity -> + assertEqual "fixed authoritative marker" "zero" marker + entry -> + assertFailure + ("unexpected fixed cached entry: " <> show entry) + assertEqual "multi-item block order" [1, 1, 1] + (Parse.parsedSyntaxOccurrenceBlockIndex + <$> [second, third, fourth]) + assertEqual "multi-item scanner order" + ["multi_item", "itemzero", "itemsucc"] + (Parse.parsedSyntaxOccurrenceMarker + <$> [second, third, fourth]) + case drop 1 (Parse.parsedModuleBlocks warmRoot) of + block : _ -> + case block of + Raw.BlockData _location _title marker _datatype -> + assertEqual "cached declaration-head anchor" + marker + (Parse.parsedSyntaxOccurrenceMarker second) + other -> + assertFailure + ("expected cached datatype block, got " + <> show other) + [] -> + assertFailure "cached datatype block is absent" + occurrences -> + assertFailure + ("unexpected cached syntax occurrences: " + <> show occurrences) + assertEqual "cold callback projection" 2 + =<< readIORef coldCallbacks + assertEqual "warm callback projection" 2 + =<< readIORef warmCallbacks + Store.closeStore store + +invalidatesExactParsedInputs :: Assertion +invalidatesExactParsedInputs = + withTemporaryDirectory "felix-parsed-invalidation" \temp -> do + let notationPath = temp Posix.</> "notation.tex" + entryPath = temp Posix.</> "entry.tex" + notation associativity level = + syntaxFunctionDefinition + "join" + "join" + (Just + ("%! " <> associativity <> " " <> show level)) + entry suffix = + "\\import{notation.tex}\n" + <> axiomBlock + "imported_syntax_use" + "a\\join b\\join c = a" + <> suffix + writeFile notationPath (notation "infixl" (1 :: Int)) + writeFile entryPath (entry "") + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + store <- openTestStore + (temp Posix.</> "store.sqlite") + (Identity.theoryId foundation) + let parse = + expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store mounts request (const []) + coldWorkspace <- parse + warmWorkspace <- parse + coldNotation <- findParsedModule "notation.tex" coldWorkspace + warmNotation <- findParsedModule "notation.tex" warmWorkspace + let coldRoot = Parse.parsedWorkspaceRootModule coldWorkspace + warmRoot = Parse.parsedWorkspaceRootModule warmWorkspace + assertEqual "unchanged import identity" + (Parse.parsedModuleId coldNotation) + (Parse.parsedModuleId warmNotation) + assertEqual "unchanged importer identity" + (Parse.parsedModuleId coldRoot) + (Parse.parsedModuleId warmRoot) + + writeFile entryPath (entry "% formatting-only edit\n") + editedWorkspace <- parse + editedNotation <- findParsedModule "notation.tex" editedWorkspace + let editedRoot = Parse.parsedWorkspaceRootModule editedWorkspace + assertEqual "cached import retains identity" + (Parse.parsedModuleId warmNotation) + (Parse.parsedModuleId editedNotation) + assertBool "exact source edit changes importer key" + (Parse.parsedModuleKey warmRoot + /= Parse.parsedModuleKey editedRoot) + assertEqual "formatting retains parsed projection" + (Parse.parsedModulePayload warmRoot) + (Parse.parsedModulePayload editedRoot) + + writeFile notationPath (notation "infixr" (2 :: Int)) + syntaxWorkspace <- parse + syntaxNotation <- findParsedModule "notation.tex" syntaxWorkspace + let syntaxRoot = Parse.parsedWorkspaceRootModule syntaxWorkspace + assertBool "local syntax identity changes" + ( Interface.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface editedNotation) + /= Interface.moduleSyntaxAssertedId + (Parse.parsedModuleSyntaxInterface syntaxNotation) + ) + assertEqual "importer source is unchanged" + (Parse.parsedModuleSourceContentId editedRoot) + (Parse.parsedModuleSourceContentId syntaxRoot) + assertBool "direct syntax invalidates importer key" + (Parse.parsedModuleKey editedRoot + /= Parse.parsedModuleKey syntaxRoot) + Store.closeStore store + +rebindsRelocatedParsedArtifacts :: Assertion +rebindsRelocatedParsedArtifacts = + withTemporaryDirectory "felix-parsed-relocation" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + sourceBytes = axiomBlock "same" "x = x" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + writeFile (firstRoot Posix.</> "entry.tex") sourceBytes + writeFile (secondRoot Posix.</> "entry.tex") sourceBytes + firstMounts <- oneMount "first" firstRoot + secondMounts <- oneMount "second" secondRoot + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + let theory = Identity.theoryId foundation + store <- openTestStore (temp Posix.</> "store.sqlite") theory + firstWorkspace <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store firstMounts request (const []) + secondWorkspace <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store secondMounts request (const []) + let first = Parse.parsedWorkspaceRootModule firstWorkspace + second = Parse.parsedWorkspaceRootModule secondWorkspace + firstSource = Parse.parsedModuleResolved first + secondSource = Parse.parsedModuleResolved second + assertEqual "relocation retains parsed identity" + (Parse.parsedModuleId first) + (Parse.parsedModuleId second) + assertEqual "relocation retains canonical payload" + (Parse.parsedModulePayload first) + (Parse.parsedModulePayload second) + assertBool "relocation rebinds the physical source" + (resolvedSourceCanonicalPath firstSource + /= resolvedSourceCanonicalPath secondSource) + assertBool "relocation rebinds the logical owner" + (Parse.parsedModuleAddress first + /= Parse.parsedModuleAddress second) + firstFileId <- expectJust "first location file id" + (locFileId (onlyAxiomLocation first)) + secondFileId <- expectJust "second location file id" + (locFileId (onlyAxiomLocation second)) + assertBool "relocation rebinds locations" + (firstFileId /= secondFileId) + firstArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (Module.moduleName (Parse.parsedModuleAddress first)) + (Parse.parsedModuleId first) + [] + theory) + secondArtifactKey <- expectRight + (Semantic.moduleArtifactKey + (Module.moduleName (Parse.parsedModuleAddress second)) + (Parse.parsedModuleId second) + [] + theory) + assertBool "module artifact remains owner-dependent" + (Semantic.moduleArtifactId firstArtifactKey + /= Semantic.moduleArtifactId secondArtifactKey) + Store.closeStore store + +rejectsCorruptedCachedDeclarationAnchor :: Assertion +rejectsCorruptedCachedDeclarationAnchor = + withTemporaryDirectory "felix-parsed-corrupt-anchor" \temp -> do + writeBuiltinZeroDefinition + (temp Posix.</> "entry.tex") + "source_zero" + mounts <- oneMount "project" temp + request <- expectRight (searchedRoot "entry.tex") + foundation <- expectRight Foundation.checkedFoundation + let storePath = temp Posix.</> "store.sqlite" + theory = Identity.theoryId foundation + store <- openTestStore storePath theory + cold <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs + store mounts request (const []) + let parsed = Parse.parsedWorkspaceRootModule cold + key = Parse.parsedModuleKey parsed + fileId <- case Parse.parsedModuleSyntaxOccurrences parsed of + occurrence : _ -> + expectJust + "parsed occurrence file id" + (locFileId + (Parse.parsedSyntaxOccurrenceLocation occurrence)) + [] -> + assertFailure "parsed fixed occurrence is absent" + >> fail "unreachable" + decoded <- expectRight + (Parsed.decodeCanonicalParsedPayload + fileId + (Parse.parsedModulePayload parsed)) + Store.closeStore store + let corruptedOccurrences = case Parsed.decodedParsedOccurrences decoded of + (blockIndex, location, _marker, entry) : rest -> + (blockIndex, location, "corrupted_anchor", entry) : rest + [] -> + [] + corruptedPayload = + Parsed.canonicalParsedPayload + (Parsed.decodedParsedImports decoded) + (Parsed.decodedParsedBlocks decoded) + corruptedOccurrences + (Parsed.decodedParsedSyntaxInterface decoded) + corruptedId = + ParsedIdentity.parsedModuleId + key + (Parsed.canonicalParsedPayloadBytes corruptedPayload) + connection <- SQLite.open storePath + SQLite.execute connection + "UPDATE parsed_artifacts \ + \SET parsed_module_id = ?, payload = ? \ + \WHERE parsed_module_key = ?" + ( Cache.cacheDigestBytes + (ParsedIdentity.parsedModuleIdDigest corruptedId) + , Parsed.canonicalParsedPayloadBytes corruptedPayload + , Cache.cacheDigestBytes + (ParsedIdentity.parsedModuleKeyDigest key) + ) + SQLite.close connection + current <- openTestStore storePath theory + callbacks <- newIORef (0 :: Int) + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback + current mounts request (const []) + (\_source _block -> modifyIORef' callbacks (+ 1)) >>= \case + Left + (Parse.ParseExecutionArtifactIntegrityFailure + _source + (Parse.ParsedArtifactAssociationFailure + Parse.SyntaxOccurrenceMarkerMismatch{})) -> + pure () + other -> + assertFailure + ("unexpected corrupted parsed result: " <> show other) + assertEqual "corrupt hit invokes no parse callback" 0 + =<< readIORef callbacks + Store.closeStore current + +openTestStore :: FilePath -> Identity.TheoryId -> IO Store.Store +openTestStore path theory = + Store.openStore path theory >>= \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right (_startup, store) -> + pure store + +expectParseExecution + :: Either Parse.ParseExecutionError value + -> IO value +expectParseExecution = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +parsesSourceGraph :: Assertion +parsesSourceGraph = + withTemporaryDirectory "felix-source-parse" \temp -> do + writeTheory (temp Posix.</> "shared.tex") [] "shared" + writeTheory (temp Posix.</> "entry.tex") ["shared.tex"] "entry" + graph <- buildSearchedGraph temp "entry.tex" + emittedRef <- newIORef [] + workspace <- expectRight =<< + Parse.parseResolvedSourceGraphWith graph + (\source _block -> + modifyIORef' + emittedRef + (safeRelativePathFilePath + (resolvedSourceRelativePath source) :)) + assertEqual "two parsed source nodes" 2 + (length (Parse.parsedWorkspaceModules workspace)) + assertEqual "one source-local block per node" [1, 1] + (toList + (length . Parse.parsedModuleBlocks + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace)) + assertEqual "imported-before-importer source order" + ["shared.tex", "entry.tex"] + (toList + (safeRelativePathFilePath + . resolvedSourceRelativePath + . Parse.parsedModuleResolved + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace)) + assertEqual "flattened block view" 2 + (length (Parse.importedBeforeImporterBlocks workspace)) + emitted <- reverse <$> readIORef emittedRef + assertEqual "streamed block order" + ["shared.tex", "entry.tex"] + emitted + +rejectsSiblingSyntaxLeakage :: Assertion +rejectsSiblingSyntaxLeakage = + withTemporaryDirectory "felix-source-syntax-world" \temp -> do + writeFile + (temp Posix.</> "use.tex") + (unlines + [ "\\begin{axiom}\\label{use}" + , " $x$ is special." + , "\\end{axiom}" + ]) + writeAdjectiveDefinition + (temp Posix.</> "declare.tex") + "shared_special" + writeTheory + (temp Posix.</> "entry.tex") + ["use.tex", "declare.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left (Parse.SourceParseError source _parseError) -> + assertEqual + "syntax consumer fails in its own module" + "use.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + Left err -> + assertFailure + ("expected a source-local parse error, got " + <> show err) + Right workspace -> + assertFailure + ("sibling syntax leaked into use.tex: " + <> show workspace) + +parsesSourceFixities :: Assertion +parsesSourceFixities = + withTemporaryDirectory "felix-source-fixity" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + ( syntaxFunctionDefinition + "loose" + "loose" + (Just "%! infixl 0") + <> syntaxFunctionDefinition + "tight" + "tight" + (Just "%! infixr 7") + <> axiomBlock + "loose_associativity" + "a\\loose b\\loose c = a" + <> axiomBlock + "tight_associativity" + "a\\tight b\\tight c = a" + <> axiomBlock + "mixed_precedence" + "a\\loose b\\tight c = a" + <> axiomBlock + "parenthesized_precedence" + "(a\\loose b)\\tight c = a" + ) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + localEntries = + Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface root)) + assertExpressionFixity + "loose" + Raw.LeftAssoc + 0 + localEntries + assertExpressionFixity + "tight" + Raw.RightAssoc + 7 + localEntries + assertEqual + "source declaration occurrences" + [0, 1] + (Parse.parsedSyntaxOccurrenceBlockIndex + <$> Parse.parsedModuleSyntaxOccurrences root) + case drop 2 (Parse.parsedModuleBlocks root) of + [ looseAssociativity + , tightAssociativity + , mixedPrecedence + , parenthesizedPrecedence + ] -> do + assertAxiomLeftShape + "left associativity" + "loose(loose(a,b),c)" + looseAssociativity + assertAxiomLeftShape + "right associativity" + "tight(a,tight(b,c))" + tightAssociativity + assertAxiomLeftShape + "mixed precedence" + "loose(a,tight(b,c))" + mixedPrecedence + assertAxiomLeftShape + "parentheses override precedence" + "tight(loose(a,b),c)" + parenthesizedPrecedence + blocks -> + assertFailure + ("expected four fixity axioms, got " + <> show blocks) + +parsesLibraryFixities :: Assertion +parsesLibraryFixities = + withTemporaryDirectory "felix-source-library-fixity" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + ( syntaxFunctionDefinition + "cdot" + "cdot" + (Just "%! infixl 4") + <> syntaxFunctionDefinition + "symdiff" + "symdiff" + (Just "%! infixl 1") + <> axiomBlock + "cdot_associativity" + "a\\cdot b\\cdot c = a" + <> axiomBlock + "symdiff_associativity" + "a\\symdiff b\\symdiff c = a" + <> axiomBlock + "library_mixed_precedence" + "a\\symdiff b\\cdot c = a" + <> axiomBlock + "library_parentheses" + "(a\\symdiff b)\\cdot c = a" + ) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + case drop 2 + (Parse.parsedModuleBlocks + (Parse.parsedWorkspaceRootModule workspace)) of + [ cdotAssociativity + , symdiffAssociativity + , mixedPrecedence + , parenthesizedPrecedence + ] -> do + assertAxiomLeftShape + "cdot left associativity" + "cdot(cdot(a,b),c)" + cdotAssociativity + assertAxiomLeftShape + "symdiff left associativity" + "symdiff(symdiff(a,b),c)" + symdiffAssociativity + assertAxiomLeftShape + "cdot binds tighter than symdiff" + "symdiff(a,cdot(b,c))" + mixedPrecedence + assertAxiomLeftShape + "library parentheses override precedence" + "cdot(symdiff(a,b),c)" + parenthesizedPrecedence + blocks -> + assertFailure + ("expected four library-fixity axioms, got " + <> show blocks) + +validatesSourcePragmaAssociations :: Assertion +validatesSourcePragmaAssociations = + forM_ cases \(description, contents, checkProblem) -> + withTemporaryDirectory + ("felix-source-pragma-" <> description) + \temp -> do + writeFile + (temp Posix.</> "entry.tex") + contents + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left + (Parse.SourceSyntaxDeclarationError + source + problem) -> do + assertEqual + "pragma source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + checkProblem problem + Left err -> + assertFailure + ("expected source pragma error, got " + <> show err) + Right workspace -> + assertFailure + ("expected source pragma rejection, got " + <> show workspace) + where + cases + :: [ ( String + , String + , Parse.SyntaxDeclarationError -> Assertion + ) + ] + cases = + [ ( "outside" + , "%! infixl 1\n" <> theoryBlock "outside" + , \case + Parse.SyntaxPragmaOutsideDeclaration{} -> + pure () + problem -> + unexpected "outside-declaration pragma" problem + ) + , ( "inside-nonsyntax" + , unlines + [ "\\begin{axiom}\\label{inside_nonsyntax}" + , " %! infixl 1" + , " $x = x$." + , "\\end{axiom}" + ] + , \case + Parse.SyntaxPragmaOutsideDeclaration location -> + assertEqual + "pragma in non-syntax chunk" + 2 + (locLine location) + problem -> + unexpected "non-syntax declaration pragma" problem + ) + , ( "missing" + , syntaxFunctionDefinition + "missing" + "missing" + Nothing + , \case + Parse.MissingSyntaxPragma{} -> + pure () + problem -> + unexpected "missing pragma" problem + ) + , ( "duplicate" + , unlines + [ "\\begin{abbreviation}\\label{duplicate}" + , " %! infixl 1" + , " %! infixl 1" + , " $x\\duplicate y = x$." + , "\\end{abbreviation}" + ] + , \case + Parse.DuplicateSyntaxPragma{} -> + pure () + problem -> + unexpected "duplicate pragma" problem + ) + , ( "irrelevant" + , unlines + [ "\\begin{definition}\\label{irrelevant}" + , " %! infixl 1" + , " $x$ is irrelevant iff $x = x$." + , "\\end{definition}" + ] + , \case + Parse.IrrelevantSyntaxPragma{} -> + pure () + problem -> + unexpected "irrelevant pragma" problem + ) + , ( "multiple-without-pragma" + , unlines + [ "\\begin{datatype}\\label{multiple_patterns}" + , " Define $\\patternkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $(x \\firstpattern y) \\in \\patternkind$." + , " \\item $(x \\secondpattern y) \\in \\patternkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ] + , \case + problem@(Parse.MultipleNewSyntaxPatternsWithoutPragma + location + patterns) -> do + assertEqual + "first new pattern location" + 4 + (locLine location) + assertEqual + "new pattern count" + 2 + (NonEmpty.length patterns) + assertBool + "accurate multiple-pattern message" + ("several new eligible patterns that V1 cannot select between" + `List.isInfixOf` show problem) + assertBool + "message requires an unambiguous declaration" + ("make the declaration unambiguous" + `List.isInfixOf` show problem) + problem -> + unexpected "multiple unannotated patterns" problem + ) + , ( "fixed" + , unlines + [ "\\begin{abbreviation}\\label{local_addition}" + , " %! infixl 1" + , " $x + y = x$." + , "\\end{abbreviation}" + ] + , \case + Parse.SyntaxPragmaOnFixedReuse{} -> + pure () + problem -> + unexpected "fixed-base pragma" problem + ) + ] + + unexpected expected problem = + assertFailure + ("expected " <> expected <> ", got " <> show problem) + +rejectsFixedBaseCategoryMismatch :: Assertion +rejectsFixedBaseCategoryMismatch = + withTemporaryDirectory "felix-source-fixed-category" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\begin{definition}\\label{local_add_relation}" + , " $x + y$ iff $x = y$." + , "\\end{definition}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + assertEqual + "fixed collision pattern" + (Raw.HoleCons + (Raw.TokenCons + (Raw.Symbol "+") + (Raw.HoleCons Raw.End))) + (Parse.lexiconCollisionPattern collision) + case toList (Parse.lexiconCollisionOrigins collision) of + [ Parse.FixedLexiconOrigin + Interface.CanonicalExpressionFunction{} + , Parse.SourceLexiconOrigin + Interface.CanonicalRelation{} + source + location + ] -> do + assertEqual + "local collision source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertLocation + "local collision declaration" + "entry.tex" + 1 + location + origins -> + assertFailure + ("expected fixed/source category origins, got " + <> show origins) + +retainsMultiItemSyntaxOccurrences :: Assertion +retainsMultiItemSyntaxOccurrences = + withTemporaryDirectory "felix-source-multi-item-syntax" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\begin{datatype}\\label{multi_item}" + , " Define $\\itemkind$ inductively as follows." + , " \\begin{enumerate}" + , " \\item $\\itemzero \\in \\itemkind$." + , " \\item $\\itemsucc{x} \\in \\itemkind$ for $x \\in \\itemkind$." + , " \\end{enumerate}" + , "\\end{datatype}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + occurrences = + Parse.parsedModuleSyntaxOccurrences root + summarize occurrence = + case Parse.parsedSyntaxOccurrenceEntry occurrence of + Interface.CanonicalExpressionFunction + _pattern + marker + _fixity -> + Right + ( Parse.parsedSyntaxOccurrenceBlockIndex + occurrence + , locLine + (Parse.parsedSyntaxOccurrenceLocation + occurrence) + , Parse.parsedSyntaxOccurrenceMarker occurrence + , marker + ) + entry -> + Left entry + case traverse summarize occurrences of + Right summaries -> + assertEqual + "block association and scanner order" + [ (0, 2, "multi_item", "multi_item") + , (0, 4, "itemzero", "itemzero") + , (0, 5, "itemsucc", "itemsucc") + ] + summaries + Left entry -> + assertFailure + ("expected an expression occurrence, got " + <> show entry) + case (Parse.parsedModuleBlocks root, occurrences) of + ( Raw.BlockData _location _title blockMarker _datatype : _ + , firstOccurrence : _ + ) -> + assertEqual + "first occurrence is the declaration-head anchor" + blockMarker + (Parse.parsedSyntaxOccurrenceMarker firstOccurrence) + _ -> + assertFailure "expected a datatype block and its occurrences" + +propagatesImportedSyntax :: Assertion +propagatesImportedSyntax = + withTemporaryDirectory "felix-source-syntax-diamond" \temp -> do + writeFile + (temp Posix.</> "base.tex") + (syntaxFunctionDefinition + "star" + "star" + (Just "%! infixl 3")) + writeFile + (temp Posix.</> "left.tex") + ("\\import{base.tex}\n" + <> syntaxFunctionDefinition + "star" + "star" + Nothing) + writeTheory + (temp Posix.</> "right.tex") + ["base.tex"] + "right" + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\import{left.tex}" + , "\\import{right.tex}" + ] + <> axiomBlock + "imported_use" + "a\\star b\\star c = a") + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + baseModule <- findParsedModule "base.tex" workspace + leftModule <- findParsedModule "left.tex" workspace + rightModule <- findParsedModule "right.tex" workspace + let root = + Parse.parsedWorkspaceRootModule workspace + interface = + Parse.parsedModuleSyntaxInterface + localEntries parsed = + Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (interface parsed)) + assertEqual "base exports one syntax entry" + 1 + (length (localEntries baseModule)) + assertEqual "imported reuse emits no local entry" + [] + (localEntries leftModule) + assertEqual "imported reuse retains its occurrence" + 1 + (length + (Parse.parsedModuleSyntaxOccurrences leftModule)) + assertEqual "empty diamond branch has no occurrence" + [] + (Parse.parsedModuleSyntaxOccurrences rightModule) + assertEqual "equal diamond interfaces" + (Interface.moduleSyntaxAssertedId + (interface leftModule)) + (Interface.moduleSyntaxAssertedId + (interface rightModule)) + assertEqual "root coalesces equal direct interfaces" + 1 + (length + (Interface.moduleSyntaxDirectInputs + (interface root))) + case Parse.parsedModuleBlocks root of + [block] -> + assertAxiomLeftShape + "imported left associativity" + "star(star(a,b),c)" + block + blocks -> + assertFailure + ("expected one imported-syntax axiom, got " + <> show blocks) + writeFile + (temp Posix.</> "left.tex") + ("\\import{base.tex}\n" + <> syntaxFunctionDefinition + "star" + "star" + (Just "%! infixl 3")) + reuseGraph <- buildSearchedGraph temp "left.tex" + reuseResult <- + Parse.parseResolvedSourceGraph reuseGraph + case reuseResult of + Left + (Parse.SourceSyntaxDeclarationError + _source + Parse.SyntaxPragmaOnImportedReuse{}) -> + pure () + Left err -> + assertFailure + ("expected imported-reuse pragma rejection, got " + <> show err) + Right reused -> + assertFailure + ("expected imported-reuse pragma rejection, got " + <> show reused) + +rejectsUnequalImportedSyntax :: Assertion +rejectsUnequalImportedSyntax = + forM_ cases \(description, leftDefinition, rightDefinition) -> + withTemporaryDirectory + ("felix-source-imported-collision-" <> description) + \temp -> do + writeFile + (temp Posix.</> "a.tex") + leftDefinition + writeFile + (temp Posix.</> "b.tex") + rightDefinition + writeTheory + (temp Posix.</> "entry.tex") + ["a.tex", "b.tex"] + "entry" + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + (firstLocation, secondLocation) <- + expectTwoCollisionLocations collision + assertLocation + "first imported declaration" + "a.tex" + 1 + firstLocation + assertLocation + "second imported declaration" + "b.tex" + 1 + secondLocation + where + cases = + [ ( "marker" + , syntaxFunctionDefinition + "clash_left" + "clash" + (Just "%! infixl 2") + , syntaxFunctionDefinition + "clash_right" + "clash" + (Just "%! infixl 2") + ) + , ( "fixity" + , syntaxFunctionDefinition + "clash" + "clash" + (Just "%! infixl 2") + , syntaxFunctionDefinition + "clash" + "clash" + (Just "%! infixr 2") + ) + ] + +distinguishesPhysicalSourceLocations :: Assertion +distinguishesPhysicalSourceLocations = + withTemporaryDirectory "felix-source-location-identity" \temp -> do + let projectRoot = temp Posix.</> "project" + libraryRoot = temp Posix.</> "library" + projectEntry = projectRoot Posix.</> "entry.tex" + libraryEntry = libraryRoot Posix.</> "entry.tex" + Directory.createDirectory projectRoot + Directory.createDirectory libraryRoot + writeFile projectEntry + ("\\import{entry.tex}\n" + <> adjectiveDefinition "project_adjective") + writeNounDefinition libraryEntry "library_noun" + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "library", libraryRoot) + , (sourceMountId "project", projectRoot) + ] + request <- expectRight =<< existingRoot projectEntry + graph <- expectRight =<< buildResolvedSourceGraph mounts request + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + assertEqual "normalized cross-category pattern" + (Raw.TokenCons (Raw.Word "special") Raw.End) + (Parse.lexiconCollisionPattern collision) + (libraryLocation, projectLocation) <- + expectTwoCollisionLocations collision + assertEqual "accepted display path" + "entry.tex" + (locFile libraryLocation) + assertEqual "accepted declaration line" + 1 + (locLine libraryLocation) + assertEqual "colliding display path" + "entry.tex" + (locFile projectLocation) + assertEqual "colliding declaration line" + 2 + (locLine projectLocation) + canonicalProject <- Directory.canonicalizePath projectEntry + canonicalLibrary <- Directory.canonicalizePath libraryEntry + let rendered = show collision + quotedLibrary = show canonicalLibrary + quotedProject = show canonicalProject + assertBool "rendered error includes accepted canonical path" + (quotedLibrary `List.isInfixOf` rendered) + assertBool "rendered error includes colliding canonical path" + (quotedProject `List.isInfixOf` rendered) + assertBool "canonical locations render in declaration order" + (substringIndex quotedLibrary rendered + < substringIndex quotedProject rendered) + +retainsWorkspaceLocationDisplayPath :: Assertion +retainsWorkspaceLocationDisplayPath = + withTemporaryDirectory "felix-source-location-display" \temp -> do + let nested = temp Posix.</> "nested" + entry = nested Posix.</> "entry.tex" + Directory.createDirectory nested + writeTheory entry [] "entry" + outerMounts <- oneMount "project" temp + outerRequest <- expectRight (searchedRoot "nested/entry.tex") + outerGraph <- expectRight =<< + buildResolvedSourceGraph outerMounts outerRequest + outerWorkspace <- expectRight =<< + Parse.parseResolvedSourceGraph outerGraph + innerMounts <- oneMount "library" nested + innerRequest <- expectRight (searchedRoot "entry.tex") + innerGraph <- expectRight =<< + buildResolvedSourceGraph innerMounts innerRequest + innerWorkspace <- expectRight =<< + Parse.parseResolvedSourceGraph innerGraph + let outerLocation = + onlyAxiomLocation + (Parse.parsedWorkspaceRootModule outerWorkspace) + innerLocation = + onlyAxiomLocation + (Parse.parsedWorkspaceRootModule innerWorkspace) + assertEqual "outer-mount display path" + "nested/entry.tex" + (locFile outerLocation) + assertEqual "more-specific-mount display path" + "entry.tex" + (locFile innerLocation) + outerFileId <- expectJust "outer workspace file id" + (locFileId outerLocation) + innerFileId <- expectJust "inner workspace file id" + (locFileId innerLocation) + assertBool "distinct display registrations use distinct file ids" + (outerFileId /= innerFileId) + canonicalEntry <- Directory.canonicalizePath entry + assertEqual "outer physical location key" + (Just canonicalEntry) + (lookupFileIdentityPath outerFileId) + assertEqual "inner physical location key" + (Just canonicalEntry) + (lookupFileIdentityPath innerFileId) + +reportsImportedScannerErrorFirst :: Assertion +reportsImportedScannerErrorFirst = + withTemporaryDirectory "felix-source-lexer-error-order" \temp -> do + let scannerFailure = unlines + [ "\\begin{abbreviation}\\label{malformed_function}" + , " $x = \\emptyset$." + , "\\end{abbreviation}" + ] + tokenizerFailure = unlines + [ "\\begin{axiom}" + , "#" + , "\\end{axiom}" + ] + writeFile + (temp Posix.</> "imported.tex") + scannerFailure + writeFile + (temp Posix.</> "entry.tex") + ("\\import{imported.tex}\n" <> tokenizerFailure) + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + case result of + Left + (Parse.SourceParseError + source + (Parse.LexicalScanFailure + Adapt.InvalidFunctionPattern{})) -> + assertEqual + "dependency scanner error" + "imported.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + Left err -> + assertFailure + ("expected imported scanner error, got " <> show err) + Right workspace -> + assertFailure + ("expected imported scanner error, got " + <> show workspace) + +reportsMalformedLexicalDeclaration :: Assertion +reportsMalformedLexicalDeclaration = + withTemporaryDirectory "felix-source-malformed-lexical" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\begin{abbreviation}\\label{malformed_function}" + , " $x = \\emptyset$." + , "\\end{abbreviation}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + result <- Parse.parseResolvedSourceGraph graph + void (evaluate (length (show result))) + case result of + Left + (Parse.SourceParseError + source + (Parse.LexicalScanFailure + (Adapt.InvalidFunctionPattern + location + Adapt.FunctionPatternBareVariable))) -> do + assertEqual "malformed source" + "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + assertLocation + "malformed declaration" + "entry.tex" + 1 + location + Left err -> + assertFailure + ("expected typed lexical scan failure, got " <> show err) + Right workspace -> + assertFailure + ("expected typed lexical scan failure, got " + <> show workspace) + +rejectsMalformedInductivePattern :: Assertion +rejectsMalformedInductivePattern = + case runLexer (FileId 0) "inductive.tex" source of + Left err -> + assertFailure ("could not tokenize fixture: " <> show err) + Right (_imports, [chunk]) -> + case Adapt.scanChunk chunk of + Left + (Adapt.InvalidFunctionPattern + _location + Adapt.FunctionPatternBareVariable) -> + pure () + Left err -> + assertFailure + ("expected bare-variable scan failure, got " + <> show err) + Right scans -> + assertFailure + ("expected bare-variable scan failure, got " + <> show scans) + Right (_imports, chunks) -> + assertFailure + ("expected one lexical chunk, got " <> show (length chunks)) + where + source = + Text.pack + (unlines + [ "\\begin{inductive}\\label{malformed_inductive}" + , " Define $x\\subseteq\\pow{x}$ inductively." + , "\\end{inductive}" + ]) + +acceptsAdjectiveSignature :: Assertion +acceptsAdjectiveSignature = + withTemporaryDirectory "felix-source-signature-adjective" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\begin{signature}\\label{reflexive_signature}" + , " Suppose $A$ is a set." + , " Then $x$ can be reflexive." + , "\\end{signature}" + , "\\begin{axiom}\\label{reflexive_use}" + , " $x$ is reflexive." + , "\\end{axiom}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let blocks = Parse.importedBeforeImporterBlocks workspace + case blocks of + [ Raw.BlockSig + _signatureLocation + _signatureTitle + _signatureMarker + [_signatureAssumption] + (Raw.SignatureAdj + _variable + (Raw.Adj _adjectiveLocation declaredAdjective [])) + , Raw.BlockAxiom{} + ] -> do + assertEqual + "signature marker enters the lexicon" + "reflexive_signature" + (Raw.lexicalItemMarker declaredAdjective) + _ -> + assertFailure + ("unexpected adjective-signature blocks: " <> show blocks) + +rejectsMalformedSignatureHead :: Assertion +rejectsMalformedSignatureHead = do + case runLexer + (FileId 49) + "malformed-signature.tex" + (Text.unlines + [ "\\begin{signature}\\label{bad_signature}" + , " $x$ can be." + , "\\end{signature}" + ]) of + Left err -> + assertFailure ("unexpected token error: " <> show err) + Right (_imports, [chunk]) -> + case Adapt.scanChunk chunk of + Left + (Adapt.InvalidFunctionPattern + location + Adapt.FunctionPatternBareVariable) -> do + assertEqual "error line" 1 (locLine location) + assertEqual "error column" 1 (locColumn location) + Left err -> + assertFailure + ("expected malformed signature error, got " <> show err) + Right scans -> + assertFailure + ("expected malformed signature rejection, got " + <> show scans) + Right (_imports, chunks) -> + assertFailure + ("expected one malformed signature chunk, got " + <> show (length chunks)) + +reportsSameSourceLexiconCollision :: Assertion +reportsSameSourceLexiconCollision = + withTemporaryDirectory "felix-source-local-lexicon-collision" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\begin{struct}\\label{duplicate_operations}" + , " A \\duplicateop $X$ is equipped with" + , " \\begin{enumerate}" + , " \\item $\\duplicateop$" + , " \\end{enumerate}" + , "\\end{struct}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + collision <- expectLexiconCollision + =<< Parse.parseResolvedSourceGraph graph + (firstLocation, secondLocation) <- + expectTwoCollisionLocations collision + assertEqual "first declaration file" + "entry.tex" + (locFile firstLocation) + assertEqual "first declaration line" 1 (locLine firstLocation) + assertEqual "colliding declaration file" + "entry.tex" + (locFile secondLocation) + assertEqual "colliding declaration line" 4 (locLine secondLocation) + assertBool "declarations have distinct locations" + (firstLocation /= secondLocation) + +acceptsBuiltinSourceDeclaration :: Assertion +acceptsBuiltinSourceDeclaration = + withTemporaryDirectory "felix-source-builtin-declaration" \temp -> do + writeBuiltinZeroDefinition + (temp Posix.</> "entry.tex") + "source_zero" + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + let root = + Parse.parsedWorkspaceRootModule workspace + assertEqual + "fixed reuse emits no local syntax" + [] + (Interface.canonicalSyntaxDeltaEntries + (Interface.moduleSyntaxLocalDelta + (Parse.parsedModuleSyntaxInterface root))) + case Parse.parsedModuleBlocks root of + [Raw.BlockAbbr + _location + _title + blockMarker + (Raw.AbbreviationEq + (Raw.SymbolPattern + (Raw.MixfixItem + _pattern + symbolMarker + _associativity) + []) + _expression)] -> do + assertEqual + "declaration label remains independent" + "source_zero" + blockMarker + assertEqual + "built-in marker remains authoritative" + "zero" + symbolMarker + case Parse.parsedModuleSyntaxOccurrences root of + [occurrence] -> + case Parse.parsedSyntaxOccurrenceEntry occurrence of + Interface.CanonicalExpressionFunction + _pattern + occurrenceMarker + _fixity -> do + assertEqual + "occurrence retains source marker" + "source_zero" + (Parse.parsedSyntaxOccurrenceMarker + occurrence) + assertEqual + "occurrence uses fixed marker" + "zero" + occurrenceMarker + fileId <- expectJust + "fixed occurrence file id" + (locFileId + (Parse.parsedSyntaxOccurrenceLocation + occurrence)) + decoded <- expectRight + (Parsed.decodeCanonicalParsedPayload + fileId + (Parse.parsedModulePayload root)) + case Parsed.decodedParsedOccurrences decoded of + [ ( _blockIndex + , _location + , storedMarker + , Interface.CanonicalExpressionFunction + _storedPattern + storedEntryMarker + _storedFixity + ) + ] -> do + assertEqual + "payload source marker" + "source_zero" + storedMarker + assertEqual + "payload authoritative marker" + "zero" + storedEntryMarker + stored -> + assertFailure + ("unexpected decoded fixed occurrence: " + <> show stored) + entry -> + assertFailure + ("unexpected fixed occurrence: " + <> show entry) + occurrences -> + assertFailure + ("unexpected fixed occurrences: " + <> show occurrences) + blocks -> + assertFailure + ("unexpected built-in declaration parse: " + <> show blocks) + +acceptsBuiltinPrefixPredicateDeclaration :: Assertion +acceptsBuiltinPrefixPredicateDeclaration = + withTemporaryDirectory "felix-source-builtin-prefix" \temp -> do + writeBuiltinCongDefinition + (temp Posix.</> "entry.tex") + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + case Parse.parsedModuleBlocks + (Parse.parsedWorkspaceRootModule workspace) of + [Raw.BlockDefn + _location + _title + _blockMarker + (Raw.Defn + _assumptions + (Raw.DefnSymbolicPredicate + predicate + predicateMarker + _variables) + _statement)] -> do + assertEqual "built-in prefix predicate" + (Raw.PrefixPredicate "Cong" 4) + predicate + assertEqual + "built-in prefix marker remains authoritative" + "cong" + predicateMarker + blocks -> + assertFailure + ("unexpected built-in prefix declaration parse: " + <> show blocks) + +avoidsAliasImportLexiconCollision :: Assertion +avoidsAliasImportLexiconCollision = + withTemporaryDirectory "felix-source-alias-lexicon" \temp -> do + let shared = temp Posix.</> "shared.tex" + alias = temp Posix.</> "alias.tex" + writeAdjectiveDefinition shared "shared_special" + Directory.createFileLink shared alias + writeFile + (temp Posix.</> "entry.tex") + (unlines + [ "\\import{shared.tex}" + , "\\import{shared.tex}" + , "\\import{alias.tex}" + , "\\begin{axiom}\\label{root}" + , " $x$ is special." + , "\\end{axiom}" + ]) + graph <- buildSearchedGraph temp "entry.tex" + workspace <- expectRight + =<< Parse.parseResolvedSourceGraph graph + assertEqual "canonical source is parsed once" + ["shared.tex", "entry.tex"] + (toList + ( safeRelativePathFilePath + . resolvedSourceRelativePath + . Parse.parsedModuleResolved + <$> Parse.parsedWorkspaceImportedBeforeImporter workspace + )) + +parsesWithoutRereading :: Assertion +parsesWithoutRereading = + withTemporaryDirectory "felix-source-no-reread" \temp -> do + let shared = temp Posix.</> "shared.tex" + entry = temp Posix.</> "entry.tex" + writeTheory shared [] "shared" + writeTheory entry ["shared.tex"] "entry" + graph <- buildSearchedGraph temp "entry.tex" + Directory.removeFile entry + Directory.removeFile shared + firstWorkspace <- expectRight =<< Parse.parseResolvedSourceGraph graph + secondWorkspace <- expectRight =<< Parse.parseResolvedSourceGraph graph + assertEqual "first flat projection" 2 + (length (Parse.importedBeforeImporterBlocks firstWorkspace)) + assertEqual "repeated downstream projection" 2 + (length (Parse.importedBeforeImporterBlocks secondWorkspace)) + +returnsSourceParseFailures :: Assertion +returnsSourceParseFailures = + withTemporaryDirectory "felix-source-parse-error" \temp -> do + writeFile + (temp Posix.</> "entry.tex") + (theoryBlock "accepted" + <> "\\begin{axiom}\\label{late_failure}\n") + graph <- buildSearchedGraph temp "entry.tex" + emittedRef <- newIORef [] + result <- + Parse.parseResolvedSourceGraphWith graph + (\_source block -> + case block of + Raw.BlockAxiom _location _title marker _axiom -> + modifyIORef' emittedRef (marker :) + _ -> + assertFailure + ("unexpected emitted block: " <> show block)) + case result of + Left (Parse.SourceParseError source _err) -> do + assertEqual "failed source" "entry.tex" + (safeRelativePathFilePath + (resolvedSourceRelativePath source)) + emitted <- reverse <$> readIORef emittedRef + assertEqual "completed callbacks before later failure" + ["accepted"] + emitted + Left err -> + assertFailure ("expected SourceParseError, got " <> show err) + Right workspace -> + assertFailure ("expected parse failure, got " <> show workspace) + +rejectsGuardedSymbolicDeclarations :: Assertion +rejectsGuardedSymbolicDeclarations = + for_ [("definition", 3 :: Int), ("abbreviation", 2)] + \(kind, failureLine) -> + withTemporaryDirectory + ("felix-guarded-symbolic-" <> kind) + \temp -> do + let relative = "entry.tex" + source = unlines + [ "\\begin{" <> kind <> "}\\label{guarded_symbolic}" + , " Suppose $\\top$." + , " $\\guardedsymbolic{X} = X$." + , "\\end{" <> kind <> "}" + ] + writeFile (temp Posix.</> relative) source + graph <- buildSearchedGraph temp relative + emittedRef <- newIORef ([] :: [Raw.Block]) + result <- + Parse.parseResolvedSourceGraphWith graph + (\_source block -> modifyIORef' emittedRef (block :)) + case result of + Left (Parse.SourceParseError failed parseFailure) -> do + assertEqual (kind <> " source") relative + (safeRelativePathFilePath + (resolvedSourceRelativePath failed)) + assertBool + (kind <> " parse failure retains a located source position: " + <> show parseFailure) + (("entry.tex " <> show failureLine <> ":") + `List.isInfixOf` show parseFailure) + assertEqual + (kind <> " publishes no completed source block") + [] + =<< readIORef emittedRef + Left failure -> + assertFailure + ("expected guarded-symbolic parse failure, got " + <> show failure) + Right workspace -> + assertFailure + ("guarded symbolic " <> kind + <> " was silently accepted: " <> show workspace) + +buildSearchedGraph :: FilePath -> FilePath -> IO ResolvedSourceGraph +buildSearchedGraph root path = do + mounts <- oneMount "project" root + request <- expectRight (searchedRoot path) + expectRight =<< buildResolvedSourceGraph mounts request + +sourceGraphOrderPaths :: ResolvedSourceGraph -> IO [FilePath] +sourceGraphOrderPaths graph = + pure + [ safeRelativePathFilePath + (resolvedSourceRelativePath (sourceNodeResolved node)) + | node <- toList (sourceGraphImportedBeforeImporter graph) + ] + +sourceNodeCanonicalPathForTest :: SourceNode -> CanonicalPath +sourceNodeCanonicalPathForTest = + resolvedSourceCanonicalPath . sourceNodeResolved + +onlyAxiomLocation :: Parse.ParsedModule -> Location +onlyAxiomLocation node = + case Parse.parsedModuleBlocks node of + [Raw.BlockAxiom location _title _marker _axiom] -> + location + blocks -> + error ("expected one axiom block, got " <> show blocks) + +syntaxFunctionDefinition + :: String + -> String + -> Maybe String + -> String +syntaxFunctionDefinition marker command pragma = + unlines + ( [ "\\begin{abbreviation}\\label{" <> marker <> "}" + ] + <> maybe [] (\line -> [" " <> line]) pragma + <> [ " $x\\" <> command <> " y = x$." + , "\\end{abbreviation}" + ] + ) + +axiomBlock :: String -> String -> String +axiomBlock marker statement = + unlines + [ "\\begin{axiom}\\label{" <> marker <> "}" + , " $" <> statement <> "$." + , "\\end{axiom}" + ] + +assertExpressionFixity + :: Text + -> Raw.Associativity + -> Word8 + -> [Interface.CanonicalLexicalEntry] + -> Assertion +assertExpressionFixity marker associativity level entries = + case + [ fixity + | Interface.CanonicalExpressionFunction + _pattern + (Raw.Marker candidate) + fixity <- + entries + , candidate == marker + ] of + [Interface.Fixity actualAssociativity actualLevel] -> do + assertEqual + (Text.unpack marker <> " associativity") + associativity + actualAssociativity + assertEqual + (Text.unpack marker <> " level") + level + (Interface.mixfixLevelValue actualLevel) + actual -> + assertFailure + ("expected one fixity for " + <> Text.unpack marker + <> ", got " + <> show actual) + +assertAxiomLeftShape + :: String + -> String + -> Raw.Block + -> Assertion +assertAxiomLeftShape description expected block = + case block of + Raw.BlockAxiom + _location + _title + _marker + (Raw.Axiom + _assumptions + (Raw.StmtFormula + (Raw.FormulaChain + (Raw.ChainBase + (expression :| []) + _sign + _relation + _right)))) -> + assertEqual + description + expected + (expressionShape expression) + _ -> + assertFailure + ("expected an axiom with one left expression, got " + <> show block) + +expressionShape :: Raw.Expr -> String +expressionShape = \case + Raw.ExprVar (Raw.NamedVarAt _location name) -> + Text.unpack name + Raw.ExprOp + _location + symbol + arguments -> + let Raw.Marker marker = + Raw.mixfixMarker symbol + in + Text.unpack marker + <> "(" + <> List.intercalate "," + (expressionShape <$> arguments) + <> ")" + expression -> + show expression + +findParsedModule + :: FilePath + -> Parse.ParsedSourceWorkspace + -> IO Parse.ParsedModule +findParsedModule relative workspace = + case List.find hasPath + (Parse.parsedWorkspaceModules workspace) of + Just parsed -> + pure parsed + Nothing -> + assertFailure + ("could not find parsed module " <> relative) + where + hasPath parsed = + safeRelativePathFilePath + (resolvedSourceRelativePath + (Parse.parsedModuleResolved parsed)) + == relative + +writeAdjectiveDefinition :: FilePath -> String -> IO () +writeAdjectiveDefinition path marker = + writeFile path (adjectiveDefinition marker) + +adjectiveDefinition :: String -> String +adjectiveDefinition marker = + unlines + [ "\\begin{definition}\\label{" <> marker <> "}" + , " $x$ is special iff $x = x$." + , "\\end{definition}" + ] + +writeNounDefinition :: FilePath -> String -> IO () +writeNounDefinition path marker = + writeFile path + (unlines + [ "\\begin{definition}\\label{" <> marker <> "}" + , " $x$ is a special iff $x = x$." + , "\\end{definition}" + ]) + +writeBuiltinZeroDefinition :: FilePath -> String -> IO () +writeBuiltinZeroDefinition path marker = + writeFile path (builtinZeroDefinition marker) + +builtinZeroDefinition :: String -> String +builtinZeroDefinition marker = + unlines + [ "\\begin{abbreviation}\\label{" <> marker <> "}" + , " $\\zero = \\emptyset$." + , "\\end{abbreviation}" + ] + +writeBuiltinCongDefinition :: FilePath -> IO () +writeBuiltinCongDefinition path = + writeFile path + (unlines + [ "\\begin{definition}\\label{source_cong}" + , " $\\Cong{x}{y}{z}{w}$ iff $x = x$." + , "\\end{definition}" + ]) + +writeTheory :: FilePath -> [FilePath] -> String -> IO () +writeTheory path imports label = + writeFile path + (unlines + (["\\import{" <> imported <> "}" | imported <- imports] + <> [theoryBlock label])) + +theoryBlock :: String -> String +theoryBlock label = + unlines + [ "\\begin{axiom}\\label{" <> label <> "}" + , " $x = x$." + , "\\end{axiom}" + ] + +oneMount :: Text -> FilePath -> IO SourceMounts +oneMount ident root = + expectRight =<< prepareSourceMounts [(sourceMountId ident, root)] + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path + +assertRight :: (Show e, HasCallStack) => Either e a -> Assertion +assertRight = void . expectRight + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +expectJust :: HasCallStack => String -> Maybe a -> IO a +expectJust description = \case + Nothing -> + assertFailure ("expected " <> description) + Just value -> + pure value + +expectLexiconCollision + :: Either Parse.ParseWorkspaceError a + -> IO Parse.LexiconCollision +expectLexiconCollision = \case + Left (Parse.SourceLexiconCollision collision) -> + pure collision + Left err -> + assertFailure + ("expected SourceLexiconCollision, got " <> show err) + Right _value -> + assertFailure "expected SourceLexiconCollision, got Right" + +expectTwoCollisionLocations + :: Parse.LexiconCollision + -> IO (Location, Location) +expectTwoCollisionLocations collision = + case Parse.lexiconCollisionDeclarations collision of + firstLocation : secondLocation : _ -> + pure (firstLocation, secondLocation) + locations -> + assertFailure + ("expected two source collision locations, got " + <> show locations) + +assertLocation :: String -> FilePath -> Int -> Location -> Assertion +assertLocation description expectedFile expectedLine location = do + assertEqual (description <> " file") + expectedFile + (locFile location) + assertEqual (description <> " line") + expectedLine + (locLine location) + assertEqual (description <> " column") + 1 + (locColumn location) + +substringIndex :: String -> String -> Int +substringIndex needle haystack = + fromMaybe maxBound + (List.findIndex + (List.isPrefixOf needle) + (List.tails haystack)) + +assertLeft :: (Eq e, Eq a, Show e, Show a, HasCallStack) => e -> Either e a -> Assertion +assertLeft expected actual = + assertEqual "expected Left value" (Left expected) actual diff --git a/source/Felix/Test/Unit/Store.hs b/source/Felix/Test/Unit/Store.hs new file mode 100644 index 0000000..423204c --- /dev/null +++ b/source/Felix/Test/Unit/Store.hs @@ -0,0 +1,1675 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Test.Unit.Store (unitTests) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Typed +import Felix.Checking.Semantic qualified as Semantic +import Felix.Cache.Codec qualified as Cache +import Felix.Math.Codec +import Felix.Module +import Felix.Parsed.Identity qualified as Parsed +import Felix.Parsed.Payload qualified as ParsedPayload +import Felix.Source.Content qualified as Content +import Felix.Source +import Felix.Store qualified as Store +import Felix.Provers qualified as Provers +import Felix.Syntax.Interface qualified as Syntax + +import Control.Concurrent (threadDelay) +import Control.Exception qualified as Exception +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.IORef qualified as IORef +import Database.SQLite.Simple qualified as SQLite +import Database.SQLite.Simple.Types (Only(..)) +import System.Directory qualified as Directory +import System.Environment qualified as Environment +import System.FilePath.Posix qualified as Posix +import System.IO.Temp qualified as Temp +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO.Async (concurrently) + + +unitTests :: TestTree +unitTests = + testGroup "SQLite store" + [ testCase "initializes and reopens the current schema" + initializesAndReopensCurrentSchema + , testCase "serializes invocation-local coordinator access" + serializesCoordinatorAccess + , testCase "rejects incompatibility without configuring the store" + rejectsIncompatibilityWithoutConfiguration + , testCase "rejects malformed compatibility metadata" + rejectsMalformedCompatibilityMetadata + , testCase "rejects a compatible incomplete schema" + rejectsCompatibleIncompleteSchema + , testCase "round-trips exact parsed artifacts" + roundTripsExactParsedArtifacts + , testCase "rejects malformed parsed payloads" + rejectsMalformedParsedPayloads + , testCase "rejects disagreeing parsed artifact identities" + rejectsDisagreeingParsedArtifactIdentities + , testCase "rejects malformed typed validation rows" + rejectsMalformedTypedValidationRows + , testCase "publishes a completed prefix before readiness" + publishesCompletedPrefixBeforeReadiness + , testCase "installs a sealed producer for a cached importer" + installsSealedProducerForCachedImporter + , testCase "validates exact cached installation inputs" + validatesExactCachedInstallationInputs + , testCase "rejects invalid cached root authority and closure" + rejectsInvalidCachedRootAuthorityAndClosure + , testCase "rejects disagreeing module artifact columns" + rejectsDisagreeingModuleArtifactColumns + , testCase "validates shared closures once per invocation" + validatesSharedClosuresOncePerInvocation + , testCase "rolls back a failed readiness transaction" + rollsBackFailedReadiness + , testCase "rolls back an unequal duplicate batch" + rollsBackUnequalDuplicateBatch + , testCase "rejects malformed canonical payloads" + rejectsMalformedCanonicalPayloads + , testCase "plans default and explicit persistent stores" + plansPersistentStores + , testCase "cleans fresh stores on return and exceptions" + cleansFreshStores + , testCase "does not fall back after fatal startup" + doesNotFallBackAfterFatalStartup + ] + +serializesCoordinatorAccess :: Assertion +serializesCoordinatorAccess = do + coordinator <- Store.newStoreCoordinator + active <- IORef.newIORef (0 :: Int) + maximumActive <- IORef.newIORef (0 :: Int) + let operation = + Store.withStoreCoordinator coordinator + (Exception.bracket_ + (IORef.atomicModifyIORef' active + (\current -> + let next = current + 1 + in (next, ()))) + (IORef.atomicModifyIORef' active + (\current -> (current - 1, ()))) + (do + current <- IORef.readIORef active + IORef.atomicModifyIORef' maximumActive + (\observed -> (max current observed, ())) + threadDelay 50000)) + void (concurrently operation operation) + IORef.readIORef maximumActive >>= assertEqual "maximum owner count" 1 + +roundTripsExactParsedArtifacts :: Assertion +roundTripsExactParsedArtifacts = + withStoreFixture "felix-store-parsed" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, unequal) <- makeParsedArtifacts + assertEqual "initial exact lookup misses" (Right Nothing) + =<< Store.loadParsedArtifact store key + assertEqual "published parsed artifact" + (Right artifact) + =<< Store.writeParsedArtifact store key artifact + assertEqual "exact parsed round trip" + (Right (Just artifact)) + =<< Store.loadParsedArtifact store key + assertEqual "equal publication is idempotent" + (Right artifact) + =<< Store.writeParsedArtifact store key artifact + Store.writeParsedArtifact store key unequal >>= \case + Left Store.StoreRowPayloadMismatch{} -> + pure () + other -> + assertFailure + ("unexpected unequal parsed publication: " <> show other) + Store.closeStore store + +rejectsMalformedParsedPayloads :: Assertion +rejectsMalformedParsedPayloads = do + check "malformed" (ByteString.singleton 0xff) + check "noncanonical" . (<> ByteString.singleton 0x00) + =<< parsedPayloadBytes + where + check label corrupted = + withStoreFixture ("felix-store-parsed-" <> label) + \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, _unequal) <- makeParsedArtifacts + _ <- expectRightIO + (Store.writeParsedArtifact store key artifact) + Store.closeStore store + updateParsedPayload path key corrupted + (_reopened, current) <- expectOpen path theory + Store.loadParsedArtifact current key >>= \case + Left Store.StoreRowDecodeFailure{} -> + pure () + other -> + assertFailure + ("unexpected " <> label + <> " parsed row result: " <> show other) + Store.closeStore current + + parsedPayloadBytes = do + (_key, artifact, _unequal) <- makeParsedArtifacts + pure + (ParsedPayload.canonicalParsedPayloadBytes + (ParsedPayload.parsedArtifactPayload artifact)) + +rejectsDisagreeingParsedArtifactIdentities :: Assertion +rejectsDisagreeingParsedArtifactIdentities = + withStoreFixture "felix-store-parsed-id" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + (key, artifact, _unequal) <- makeParsedArtifacts + _ <- expectRightIO (Store.writeParsedArtifact store key artifact) + Store.closeStore store + connection <- SQLite.open path + SQLite.execute connection + "UPDATE parsed_artifacts SET parsed_module_id = ? \ + \WHERE parsed_module_key = ?" + ( ByteString.replicate 32 0 + , Cache.cacheDigestBytes (Parsed.parsedModuleKeyDigest key) + ) + SQLite.close connection + (_reopened, current) <- expectOpen path theory + Store.loadParsedArtifact current key >>= \case + Left Store.StoreParsedArtifactIdMismatch -> + pure () + other -> + assertFailure + ("unexpected parsed identity result: " <> show other) + Store.closeStore current + +makeParsedArtifacts + :: IO + ( Parsed.ParsedModuleKey + , ParsedPayload.ParsedArtifact + , ParsedPayload.ParsedArtifact + ) +makeParsedArtifacts = do + key <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "parsed-source") + Syntax.baseSyntaxInterfaceId + []) + emptyDelta <- expectRight (Syntax.canonicalSyntaxDelta []) + emptySyntax <- expectRight (Syntax.moduleSyntaxInterface [] emptyDelta) + otherDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "other"]) + otherSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] otherDelta) + let payload syntax = + ParsedPayload.canonicalParsedPayload + [] [] [] (Syntax.moduleSyntaxAssertedId syntax) + pure + ( key + , ParsedPayload.parsedArtifact key (payload emptySyntax) + , ParsedPayload.parsedArtifact key (payload otherSyntax) + ) + +updateParsedPayload + :: FilePath + -> Parsed.ParsedModuleKey + -> ByteString.ByteString + -> IO () +updateParsedPayload path key payload = do + connection <- SQLite.open path + SQLite.execute connection + "UPDATE parsed_artifacts SET payload = ? \ + \WHERE parsed_module_key = ?" + ( payload + , Cache.cacheDigestBytes (Parsed.parsedModuleKeyDigest key) + ) + SQLite.close connection + +rejectsMalformedTypedValidationRows :: Assertion +rejectsMalformedTypedValidationRows = + withStoreFixture "felix-store-malformed-typed" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, _syntax, _semantic, _key, _artifact, _proposition) <- + makeCommittedModule theory fixture + batch <- case Declaration.pendingModulePrefixBatches prefix of + [one] -> pure one + batches -> + assertFailure + ("unexpected prefix batch count: " <> show (length batches)) + >> fail "unreachable" + proof <- case Declaration.committedBatchProofValidations batch of + [one] -> pure one + proofs -> + assertFailure + ("unexpected proof validation count: " <> show (length proofs)) + >> fail "unreachable" + let key = Semantic.proofValidationRecordKey proof + certificate = Semantic.proofValidationRecordCertificate proof + theorem = Identity.theoremId + (Authority.factAuthorityTheorem + (Authority.validationTarget certificate)) + wrongKey = Semantic.proofValidationKey + theorem + (Semantic.proofSyntaxId "other-row") + (Declaration.committedBatchPreviousPrefix batch) + wrongProof = + Semantic.proofValidationRecord wrongKey certificate + expectRightIO (Store.writePendingModulePrefix store prefix) + Store.closeStore store + connection <- SQLite.open path + SQLite.execute connection + "UPDATE proof_validations SET payload = ? \ + \WHERE validation_key = ?" + ( Cache.encodeCache + (Semantic.putProofValidationRecordCache wrongProof) + , Cache.cacheDigestBytes + (Semantic.proofValidationKeyDigest key) + ) + SQLite.close connection + (_reopened, current) <- expectOpen path theory + Store.loadProofValidation current key >>= \case + Left Store.StoreValidationRecordKeyMismatch{} -> pure () + Left other -> + assertFailure + ("unexpected typed key mismatch: " <> show other) + Right _ -> + assertFailure "typed key mismatch was accepted" + Store.closeStore current + connection' <- SQLite.open path + SQLite.execute connection' + "UPDATE proof_validations SET payload = ? \ + \WHERE validation_key = ?" + ( ByteString.singleton 0xff + , Cache.cacheDigestBytes + (Semantic.proofValidationKeyDigest key) + ) + SQLite.close connection' + (_reopenedMalformed, malformed) <- expectOpen path theory + Store.loadProofValidation malformed key >>= \case + Left Store.StoreRowDecodeFailure{} -> pure () + Left other -> + assertFailure + ("unexpected malformed typed row: " <> show other) + Right _ -> + assertFailure "malformed typed row was accepted" + Store.closeStore malformed + +publishesCompletedPrefixBeforeReadiness :: Assertion +publishesCompletedPrefixBeforeReadiness = + withStoreFixture "felix-store-prefix" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + expectRightIO (Store.writePendingModulePrefix store prefix) + connection <- SQLite.open path + [Only propositionRows] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_propositions \ + \WHERE proposition_id = ?" + (Only + (Cache.encodeCache + (Identity.putPropositionIdCache + (Identity.checkedPropositionId proposition)))) + :: IO [Only Int] + [Only artifactRowsBefore] <- SQLite.query_ connection + "SELECT COUNT(*) FROM module_artifacts" + :: IO [Only Int] + SQLite.close connection + assertEqual "completed prefix proposition is visible" 1 propositionRows + assertEqual "prefix publication does not publish readiness" + 0 artifactRowsBefore + expectRightIO + (Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo store + installation <- expectRightIO + (Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId syntax)) + case installation of + Just loaded -> do + assertEqual "validated semantic interface" semantic + (Store.cachedInstallationSemantic loaded) + assertEqual "validated imported proposition count" 1 + (length (Store.cachedInstallationPropositions loaded)) + Nothing -> + assertFailure "validated module installation was absent" + Store.closeStore store + +installsSealedProducerForCachedImporter :: Assertion +installsSealedProducerForCachedImporter = + withStoreFixture "felix-store-cached-import" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + foundation <- expectRight Foundation.checkedFoundation + (_owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + expectRightIO + (Store.writeSealedModule + store + prefix + [syntax] + [semantic] + artifact) + memo <- Store.newStoreMemo store + installation <- + expectRightIO + (Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId syntax)) + >>= \case + Nothing -> + assertFailure "sealed producer was not loadable" + >> fail "unreachable" + Just loaded -> + pure loaded + cached <- expectRight + (Typed.cachedSealedTypedModule + foundation + [] + installation) + let loadedSemantic = Store.cachedInstallationSemantic installation + fingerprint <- + case concatMap + Semantic.declarationDeltaFacts + (Semantic.semanticInterfaceDeclarations loadedSemantic) of + [occurrence] -> + pure (Semantic.semanticFactFingerprint occurrence) + occurrences -> + assertFailure + ("unexpected cached producer facts: " + <> show (length occurrences)) + >> fail "unreachable" + namespaceDigest <- expectRight + (hashCanonicalFields + "store-cached-import-consumer" + ["consumer"]) + relative <- expectRight (safeRelativePath "consumer.tex") + let consumerOwner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "cached importer does not run Vampire")) + result <- + (Declaration.runModuleDriver + foundation + consumerOwner + [Semantic.semanticInterfaceAssertedId loadedSemantic] + resolver + Declaration.FreshValidation + do + Declaration.importSealedModuleDriver + (Typed.sealedTypedModuleEvidence cached) + (_value, batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "cached-import-consumer") do + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate do + _ <- Declaration.useAuthorizedFact fingerprint + Declaration.recordOmittedUse + pure batch + :: IO + (Either + Declaration.DriverOpenError + (Declaration.DriverResult Text + Declaration.CommittedDeclarationBatch))) + case result of + Left failure -> + assertFailure ("cached importer could not open: " <> show failure) + Right (Declaration.DriverSucceeded _ _ _ _closure) -> + pure () + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure ("cached importer failed: " <> show failure) + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("cached importer did not seal: " <> show failure) + Store.closeStore store + +validatesExactCachedInstallationInputs :: Assertion +validatesExactCachedInstallationInputs = + withStoreFixture "felix-store-exact-install" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, prefix, syntax, semantic, artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + _ <- expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + otherDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "other-syntax"]) + otherSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] otherDelta) + wrongSyntaxMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + wrongSyntaxMemo + store + artifactKey + (Syntax.moduleSyntaxAssertedId otherSyntax) + >>= \case + Left Store.StoreModuleArtifactSyntaxMismatch{} -> pure () + _ -> + assertFailure "unexpected syntax-input result" + + parent <- expectRight + (Semantic.semanticInterface preludeModuleName [] []) + mismatched <- expectRight + (Semantic.semanticInterface + owner + [Semantic.semanticInterfaceAssertedId parent] + (Semantic.semanticInterfaceDeclarations semantic)) + mismatchKey <- makeArtifactKey owner theory "direct-mismatch" + let mismatchArtifact = + Semantic.moduleArtifactResult + mismatchKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId mismatched) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [parent, mismatched] + mismatchArtifact + directMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + directMemo + store + mismatchKey + (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreModuleArtifactDirectMismatch{} -> pure () + _ -> + assertFailure "unexpected direct-input result" + Store.closeStore store + +rejectsInvalidCachedRootAuthorityAndClosure :: Assertion +rejectsInvalidCachedRootAuthorityAndClosure = + withStoreFixture "felix-store-invalid-install" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, _prefix, syntax, semantic, _artifactKey, _artifact, proposition) <- + makeCommittedModule theory fixture + otherTheory <- expectRight + (Cache.decodeCache + Identity.getTheoryIdCache + (ByteString.replicate 32 0x5a)) + original <- case Semantic.semanticInterfaceDeclarations semantic of + [delta] -> pure delta + deltas -> + assertFailure + ("unexpected declaration count: " <> show (length deltas)) + >> fail "unreachable" + occurrence <- case Semantic.declarationDeltaFacts original of + [fact] -> pure fact + facts -> + assertFailure + ("unexpected fact count: " <> show (length facts)) + >> fail "unreachable" + let badAuthority = + Authority.factAuthority + (Identity.theoremRef + otherTheory + (Semantic.semanticFactProposition occurrence)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority occurrence)) + badOccurrence = + Semantic.semanticFactOccurrence + (Semantic.semanticFactSlot occurrence) + badAuthority + (Semantic.semanticFactSearchEligibility occurrence) + badDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationDeltaSlot original) + [badOccurrence] + (Semantic.declarationDeltaAliases original) + (Semantic.declarationDeltaObjects original) + (Semantic.declarationDeltaPropositions original) + (Semantic.declarationDeltaEnvironment original)) + badSemantic <- expectRight + (Semantic.semanticInterface owner [] [badDelta]) + badKey <- makeArtifactKey owner theory "bad-authority" + let badArtifact = + Semantic.moduleArtifactResult + badKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId badSemantic) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [badSemantic] + badArtifact + badMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + badMemo store badKey (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreImportedOccurrenceValidationFailure{} -> pure () + _ -> + assertFailure "unexpected root-authority result" + + childKey <- makeArtifactKey owner theory "missing-late-child" + let childArtifact = + Semantic.moduleArtifactResult + childKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + writeRawModuleRows + path + [fixtureFirstObject fixture] + [proposition] + syntax + [semantic] + childArtifact + connection <- SQLite.open path + SQLite.execute connection + "DELETE FROM canonical_objects WHERE object_id = ?" + (Only + (Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId + (fixtureFirstObject fixture))))) + SQLite.close connection + childMemo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + childMemo store childKey (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreAssertedChildMissing{} -> pure () + _ -> + assertFailure "unexpected missing-child result" + Store.closeStore store + +rejectsDisagreeingModuleArtifactColumns :: Assertion +rejectsDisagreeingModuleArtifactColumns = + withStoreFixture "felix-store-artifact-columns" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (_owner, prefix, syntax, semantic, key, artifact, _proposition) <- + makeCommittedModule theory fixture + _ <- expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + connection <- SQLite.open path + SQLite.execute_ connection "PRAGMA foreign_keys = OFF" + SQLite.execute connection + "UPDATE module_artifacts SET syntax_interface_id = ? \ + \WHERE module_artifact_id = ?" + ( ByteString.replicate 32 0x3c + , Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest + (Semantic.moduleArtifactResultId artifact)) + ) + SQLite.close connection + memo <- Store.newStoreMemo store + Store.loadCachedModuleInstallation + memo + store + key + (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Left Store.StoreModuleArtifactColumnsMismatch -> pure () + Left other -> + assertFailure + ("unexpected artifact-column load: " <> show other) + Right _ -> + assertFailure "disagreeing artifact columns were accepted" + Store.writeSealedModule + store prefix [syntax] [semantic] artifact >>= \case + Left Store.StoreRowPayloadMismatch{} -> pure () + other -> + assertFailure + ("unexpected artifact-column rewrite: " <> show other) + Store.closeStore store + +validatesSharedClosuresOncePerInvocation :: Assertion +validatesSharedClosuresOncePerInvocation = + withStoreFixture "felix-store-linear-closure" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let baseObject = fixtureFirstObject fixture + first = transparentSetObject theory baseObject + second = transparentSetObject theory first + third = transparentSetObject theory second + objects = [baseObject, first, second, third] + closure <- expectRight + (Identity.validateObjectClosure theory objects) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal (Identity.assertedObjectId third)) + (Core.CGlobal (Identity.assertedObjectId third)))) + baseOwner <- testModuleName "linear-base.tex" + leftOwner <- testModuleName "linear-left.tex" + rightOwner <- testModuleName "linear-right.tex" + rootOwner <- testModuleName "linear-root.tex" + let theorem = Identity.theoremRef + theory + (Identity.checkedPropositionId proposition) + occurrence = Semantic.semanticFactOccurrence + (Semantic.factSlot baseOwner (localFactOrdinal 0)) + (Authority.factAuthority + theorem Authority.cleanAuthoritySafety) + Semantic.SearchEligible + baseDelta <- expectRight + (Semantic.declarationInterfaceDelta + (Semantic.declarationSlot + baseOwner + (localDeclarationOrdinal 0)) + [occurrence] + [] + (Identity.assertedObjectId <$> objects) + [Identity.checkedPropositionId proposition] + Semantic.emptySemanticEnvironmentDelta) + baseSemantic <- expectRight + (Semantic.semanticInterface baseOwner [] [baseDelta]) + leftSemantic <- expectRight + (Semantic.semanticInterface + leftOwner + [Semantic.semanticInterfaceAssertedId baseSemantic] + []) + rightSemantic <- expectRight + (Semantic.semanticInterface + rightOwner + [Semantic.semanticInterfaceAssertedId baseSemantic] + []) + rootSemantic <- expectRight + (Semantic.semanticInterface + rootOwner + [ Semantic.semanticInterfaceAssertedId leftSemantic + , Semantic.semanticInterfaceAssertedId rightSemantic + ] + []) + + emptyDelta <- expectRight (Syntax.canonicalSyntaxDelta []) + leftDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "linear-left"]) + rightDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "linear-right"]) + baseSyntax <- expectRight + (Syntax.moduleSyntaxInterface [] emptyDelta) + leftSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId baseSyntax] + leftDelta) + rightSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId baseSyntax] + rightDelta) + rootSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [ Syntax.moduleSyntaxAssertedId leftSyntax + , Syntax.moduleSyntaxAssertedId rightSyntax + ] + emptyDelta) + + rootKey <- makeArtifactKeyWithDirect + rootOwner + theory + [ Semantic.semanticInterfaceAssertedId leftSemantic + , Semantic.semanticInterfaceAssertedId rightSemantic + ] + "linear-root" + leftKey <- makeArtifactKeyWithDirect + leftOwner + theory + [Semantic.semanticInterfaceAssertedId baseSemantic] + "linear-left" + let rootArtifact = Semantic.moduleArtifactResult + rootKey + (Syntax.moduleSyntaxAssertedId rootSyntax) + (Semantic.semanticInterfaceAssertedId rootSemantic) + leftArtifact = Semantic.moduleArtifactResult + leftKey + (Syntax.moduleSyntaxAssertedId leftSyntax) + (Semantic.semanticInterfaceAssertedId leftSemantic) + connection <- SQLite.open path + SQLite.withTransaction connection do + traverse_ (insertRawObject connection) objects + insertRawProposition connection proposition + traverse_ + (insertRawSyntaxInterface connection) + [baseSyntax, leftSyntax, rightSyntax, rootSyntax] + traverse_ + (insertRawSemanticInterface connection) + [baseSemantic, leftSemantic, rightSemantic, rootSemantic] + insertRawModuleArtifact connection rootArtifact + insertRawModuleArtifact connection leftArtifact + SQLite.close connection + + memo <- Store.newStoreMemo store + expectInstallation memo store rootKey rootSyntax + expectInstallation memo store leftKey leftSyntax + expectInstallation memo store rootKey rootSyntax + visits <- Store.storeMemoVisits memo + assertEqual "unique artifact rows" 2 + (Store.storeArtifactRowsDecoded visits) + assertEqual "unique artifact validations" 2 + (Store.storeArtifactsValidated visits) + assertEqual "syntax diamond rows" 4 + (Store.storeSyntaxRowsDecoded visits) + assertEqual "syntax diamond validations" 4 + (Store.storeSyntaxRowsValidated visits) + assertEqual "semantic diamond rows" 4 + (Store.storeSemanticRowsDecoded visits) + assertEqual "semantic diamond validations" 4 + (Store.storeSemanticRowsValidated visits) + assertEqual "transparent-chain rows" 4 + (Store.storeObjectRowsDecoded visits) + assertEqual "transparent-chain validations" 4 + (Store.storeObjectRowsValidated visits) + assertEqual "proposition rows" 1 + (Store.storePropositionRowsDecoded visits) + assertEqual "proposition validations" 1 + (Store.storePropositionRowsValidated visits) + Store.closeStore store + where + expectInstallation memo store key syntax = + Store.loadCachedModuleInstallation + memo store key (Syntax.moduleSyntaxAssertedId syntax) + >>= \case + Right (Just _installation) -> pure () + _ -> assertFailure "cached closure installation failed" + +transparentSetObject + :: Identity.TheoryId + -> Identity.AssertedObject + -> Identity.AssertedObject +transparentSetObject theory dependency = + Identity.assertedObject identity content + where + content = Identity.TransparentObjectContent + theory + Core.TySet + (Core.CGlobal (Identity.assertedObjectId dependency)) + identity = Identity.transparentObjectId + theory + Core.TySet + (Core.CGlobal (Identity.assertedObjectId dependency)) + +testModuleName :: FilePath -> IO ModuleName +testModuleName path = do + digest <- expectRight + (hashCanonicalFields + "store-linear-module" + [ByteString.Char8.pack path]) + relative <- expectRight (safeRelativePath path) + pure + (moduleNameFromParts + (sourceNamespaceIdFromDigest digest) + relative) + +makeArtifactKey + :: ModuleName + -> Identity.TheoryId + -> ByteString.ByteString + -> IO Semantic.ModuleArtifactKey +makeArtifactKey owner theory label = do + makeArtifactKeyWithDirect owner theory [] label + +makeArtifactKeyWithDirect + :: ModuleName + -> Identity.TheoryId + -> [Semantic.SemanticInterfaceId] + -> ByteString.ByteString + -> IO Semantic.ModuleArtifactKey +makeArtifactKeyWithDirect owner theory direct label = do + parsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes label) + Syntax.baseSyntaxInterfaceId + []) + expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId parsedKey label) + direct + theory) + +writeRawModuleRows + :: FilePath + -> [Identity.AssertedObject] + -> [Identity.CheckedPropositionContent] + -> Syntax.ModuleSyntaxInterface + -> [Semantic.SemanticInterface] + -> Semantic.ModuleArtifactResult + -> IO () +writeRawModuleRows path objects propositions syntax semantics artifact = do + connection <- SQLite.open path + SQLite.withTransaction connection do + traverse_ (insertRawObject connection) objects + traverse_ (insertRawProposition connection) propositions + insertRawSyntaxInterface connection syntax + traverse_ (insertRawSemanticInterface connection) semantics + insertRawModuleArtifact connection artifact + SQLite.close connection + +insertRawObject :: SQLite.Connection -> Identity.AssertedObject -> IO () +insertRawObject connection object = + SQLite.execute connection + "INSERT OR IGNORE INTO canonical_objects (object_id, payload) \ + \VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId object)) + , Cache.encodeCache + (Identity.putObjectContentCache + (Identity.assertedObjectContent object)) + ) + +insertRawProposition + :: SQLite.Connection + -> Identity.CheckedPropositionContent + -> IO () +insertRawProposition connection proposition = + SQLite.execute connection + "INSERT OR IGNORE INTO canonical_propositions \ + \(proposition_id, payload) VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putPropositionIdCache + (Identity.checkedPropositionId proposition)) + , Cache.encodeCache + (Cache.putCanonicalTermCache + Identity.putObjectIdCache + (Core.frozenCoreTerm + (Identity.checkedPropositionTerm proposition))) + ) + +insertRawSyntaxInterface + :: SQLite.Connection + -> Syntax.ModuleSyntaxInterface + -> IO () +insertRawSyntaxInterface connection interface = + SQLite.execute connection + "INSERT OR IGNORE INTO syntax_interfaces \ + \(syntax_interface_id, payload) VALUES (?, ?)" + ( Cache.cacheDigestBytes + (Syntax.syntaxInterfaceIdDigest + (Syntax.moduleSyntaxAssertedId interface)) + , Cache.encodeCache + (Syntax.putModuleSyntaxInterfaceCache interface) + ) + +insertRawSemanticInterface + :: SQLite.Connection + -> Semantic.SemanticInterface + -> IO () +insertRawSemanticInterface connection interface = + SQLite.execute connection + "INSERT OR IGNORE INTO semantic_interfaces \ + \(semantic_interface_id, payload) VALUES (?, ?)" + ( Cache.cacheDigestBytes + (Semantic.semanticInterfaceIdDigest + (Semantic.semanticInterfaceAssertedId interface)) + , Cache.encodeCache + (Semantic.putSemanticInterfaceCache interface) + ) + +insertRawModuleArtifact + :: SQLite.Connection + -> Semantic.ModuleArtifactResult + -> IO () +insertRawModuleArtifact connection artifact = + SQLite.execute connection + "INSERT OR IGNORE INTO module_artifacts \ + \(module_artifact_id, syntax_interface_id, \ + \semantic_interface_id, payload) VALUES (?, ?, ?, ?)" + ( Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest + (Semantic.moduleArtifactResultId artifact)) + , Cache.cacheDigestBytes + (Syntax.syntaxInterfaceIdDigest + (Semantic.moduleArtifactResultSyntax artifact)) + , Cache.cacheDigestBytes + (Semantic.semanticInterfaceIdDigest + (Semantic.moduleArtifactResultSemantic artifact)) + , Cache.encodeCache + (Semantic.putModuleArtifactResultCache artifact) + ) + +storedPropositionCount + :: FilePath + -> Identity.PropositionId + -> IO Int +storedPropositionCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_propositions \ + \WHERE proposition_id = ?" + (Only + (Cache.encodeCache + (Identity.putPropositionIdCache identity))) + SQLite.close connection + pure rowCount + +storedObjectCount + :: FilePath + -> Identity.ObjectId + -> IO Int +storedObjectCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM canonical_objects WHERE object_id = ?" + (Only + (Cache.encodeCache + (Identity.putObjectIdCache identity))) + SQLite.close connection + pure rowCount + +storedArtifactCount + :: FilePath + -> Semantic.ModuleArtifactId + -> IO Int +storedArtifactCount path identity = do + connection <- SQLite.open path + [Only rowCount] <- SQLite.query connection + "SELECT COUNT(*) FROM module_artifacts \ + \WHERE module_artifact_id = ?" + (Only + (Cache.cacheDigestBytes + (Semantic.moduleArtifactIdDigest identity))) + SQLite.close connection + pure rowCount + +rollsBackFailedReadiness :: Assertion +rollsBackFailedReadiness = + withStoreFixture "felix-store-readiness-rollback" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + (owner, prefix, _syntax, semantic, _artifactKey, artifact, proposition) <- + makeCommittedModule theory fixture + missingDelta <- expectRight + (Syntax.canonicalSyntaxDelta + [Syntax.CanonicalStructureOperation "missing-child"]) + missingInterface <- expectRight + (Syntax.moduleSyntaxInterface [] missingDelta) + syntaxDelta <- expectRight + (Syntax.canonicalSyntaxDelta []) + brokenSyntax <- expectRight + (Syntax.moduleSyntaxInterface + [Syntax.moduleSyntaxAssertedId missingInterface] + syntaxDelta) + brokenParsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "rollback-source") + Syntax.baseSyntaxInterfaceId + []) + brokenArtifactKey <- expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId + brokenParsedKey + "rollback-parsed") + [] + theory) + let brokenArtifact = + Semantic.moduleArtifactResult + brokenArtifactKey + (Syntax.moduleSyntaxAssertedId brokenSyntax) + (Semantic.semanticInterfaceAssertedId semantic) + result <- Store.writeSealedModule + store + prefix + [brokenSyntax] + [semantic] + brokenArtifact + case result of + Left Store.StoreAssertedChildMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected readiness failure: " <> show other) + Right _ -> + assertFailure "broken readiness transaction was accepted" + assertEqual "failed readiness did not publish the prefix" 0 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + assertEqual "failed readiness leaves no module root" 0 + =<< storedArtifactCount + path + (Semantic.moduleArtifactResultId artifact) + -- A later failed seal must not erase a prefix published by an + -- earlier successful source prefix flush. + expectRightIO (Store.writePendingModulePrefix store prefix) + assertEqual "successful prefix is visible before retry" 1 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + retry <- Store.writeSealedModule + store + prefix + [brokenSyntax] + [semantic] + brokenArtifact + case retry of + Left Store.StoreAssertedChildMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected retry readiness failure: " <> show other) + Right _ -> + assertFailure "broken readiness retry was accepted" + assertEqual "failed retry retains successful prefix" 1 + =<< storedPropositionCount + path + (Identity.checkedPropositionId proposition) + assertEqual "failed retry still leaves no module root" 0 + =<< storedArtifactCount + path + (Semantic.moduleArtifactResultId artifact) + Store.closeStore store +makeCommittedModule + :: Identity.TheoryId + -> StoreFixture + -> IO + ( ModuleName + , Declaration.PendingModulePrefix + , Syntax.ModuleSyntaxInterface + , Semantic.SemanticInterface + , Semantic.ModuleArtifactKey + , Semantic.ModuleArtifactResult + , Identity.CheckedPropositionContent + ) +makeCommittedModule theory fixture = do + foundation <- expectRight Foundation.checkedFoundation + namespaceDigest <- expectRight + (hashCanonicalFields "store-module-test" ["prefix"]) + relative <- expectRight (safeRelativePath "module.tex") + let owner = + moduleNameFromParts + (sourceNamespaceIdFromDigest namespaceDigest) + relative + proposition = fixtureProposition fixture + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "store fixture does not run Vampire")) + driver <- Declaration.runModuleDriver + foundation + owner + [] + resolver + Declaration.FreshValidation + do + (_value, _batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "store-prefix") do + Declaration.addDeclarationObject + (fixtureFirstObject fixture) + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure () + (_value, prefix, semantic) <- + case driver of + Right (Declaration.DriverSucceeded value interface pending _closure) -> + pure (value, pending, interface) + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure + ("unexpected declaration failure: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("unexpected seal failure: " <> show failure) + >> fail "unreachable" + Left failure -> + assertFailure ("unexpected driver-open failure: " <> show failure) + >> fail "unreachable" + delta <- expectRight (Syntax.canonicalSyntaxDelta []) + syntax <- expectRight (Syntax.moduleSyntaxInterface [] delta) + parsedKey <- expectRight + (Parsed.parsedModuleKey + (Content.sourceContentIdBytes "store-module-source") + Syntax.baseSyntaxInterfaceId + []) + artifactKey <- expectRight + (Semantic.moduleArtifactKey + owner + (Parsed.parsedModuleId parsedKey "store-module-parsed") + [] + theory) + let artifact = + Semantic.moduleArtifactResult + artifactKey + (Syntax.moduleSyntaxAssertedId syntax) + (Semantic.semanticInterfaceAssertedId semantic) + pure + ( owner + , prefix + , syntax + , semantic + , artifactKey + , artifact + , proposition + ) + +makePendingPrefix + :: StoreFixture + -> [Identity.AssertedObject] + -> IO Declaration.PendingModulePrefix +makePendingPrefix fixture objects = do + foundation <- expectRight Foundation.checkedFoundation + owner <- testModuleName "rollback-prefix.tex" + let proposition = fixtureProposition fixture + resolver = Declaration.vampireResolver \_ -> + pure + (Left + (Provers.ProverLaunchFailed + "unused" + "store fixture does not run Vampire")) + driver <- Declaration.runModuleDriver + foundation + owner + [] + resolver + Declaration.FreshValidation + do + (_value, _batch) <- Declaration.commitProofDeclaration + (Semantic.proofSyntaxId "store-rollback") do + traverse_ Declaration.addDeclarationObject objects + candidate <- Declaration.reserveCandidate + (Declaration.candidateSpec + proposition + Semantic.SearchIneligible + []) + Declaration.authorizeOmittedCandidate candidate + Declaration.recordOmittedUse + pure () + case driver of + Right (Declaration.DriverSucceeded _value _interface prefix _closure) -> + pure prefix + Right (Declaration.DriverFailed failure _prefix) -> + assertFailure + ("unexpected declaration failure: " + <> show + (failure + :: Declaration.DriverFailure + Declaration.DeclarationError)) + >> fail "unreachable" + Right (Declaration.DriverSealFailed failure _prefix) -> + assertFailure ("unexpected seal failure: " <> show failure) + >> fail "unreachable" + Left failure -> + assertFailure ("unexpected driver-open failure: " <> show failure) + >> fail "unreachable" + +initializesAndReopensCurrentSchema :: Assertion +initializesAndReopensCurrentSchema = + withStoreFixture "felix-store-startup" \path theory _fixture -> do + (startup, store) <- expectOpen path theory + assertEqual "new store status" + Store.InitializedNewStore startup + Store.closeStore store + + (reopened, current) <- expectOpen path theory + assertEqual "current store status" + Store.OpenedCurrentStore reopened + Store.closeStore current + + connection <- SQLite.open path + names <- SQLite.query_ connection + "SELECT name FROM sqlite_master \ + \WHERE type = 'table' AND name NOT LIKE 'sqlite_%' \ + \ORDER BY name" + :: IO [Only Text] + journal <- SQLite.query_ connection + "PRAGMA journal_mode" + :: IO [Only Text] + SQLite.close connection + assertEqual "complete schema table count" 9 (length names) + assertEqual "rollback journal persists" + [Only "delete"] journal + +rejectsIncompatibilityWithoutConfiguration :: Assertion +rejectsIncompatibilityWithoutConfiguration = + withStoreFixture "felix-store-incompatible" \path theory _fixture -> do + connection <- SQLite.open path + _ <- SQLite.query_ connection + "PRAGMA journal_mode = WAL" + :: IO [Only Text] + SQLite.execute_ connection + "CREATE TABLE store_compatibility ( \ + \singleton INTEGER, cache_epoch INTEGER, theory_id BLOB )" + SQLite.execute connection + "INSERT INTO store_compatibility VALUES (1, ?, ?)" + ( 999 :: Int + , Cache.encodeCache (Identity.putTheoryIdCache theory) + ) + SQLite.execute_ connection + "CREATE TABLE untouched (value INTEGER)" + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.IncompatibleStore + Store.StoreCompatibilityMismatch{}) -> + pure () + Left other -> + assertFailure + ("unexpected incompatibility result: " <> show other) + Right (_startup, store) -> do + Store.closeStore store + assertFailure "incompatible store was accepted" + + inspected <- SQLite.open path + names <- SQLite.query_ inspected + "SELECT name FROM sqlite_master \ + \WHERE type = 'table' AND name NOT LIKE 'sqlite_%' \ + \ORDER BY name" + :: IO [Only Text] + journal <- SQLite.query_ inspected + "PRAGMA journal_mode" + :: IO [Only Text] + SQLite.close inspected + assertEqual "startup creates no schema" + [Only "store_compatibility", Only "untouched"] names + assertEqual "startup applies no journal configuration" + [Only "wal"] journal + +rejectsMalformedCompatibilityMetadata :: Assertion +rejectsMalformedCompatibilityMetadata = + withStoreFixture "felix-store-malformed" \path theory _fixture -> do + connection <- SQLite.open path + SQLite.execute_ connection + "CREATE TABLE store_compatibility ( \ + \singleton INTEGER, cache_epoch, theory_id )" + SQLite.execute connection + "INSERT INTO store_compatibility VALUES (1, ?, ?)" + ( "not-an-epoch" :: Text + , Cache.encodeCache (Identity.putTheoryIdCache theory) + ) + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.IncompatibleStore + Store.StoreCompatibilityMalformed{}) -> + pure () + Left other -> + assertFailure + ("unexpected malformed result: " <> show other) + Right (_startup, store) -> do + Store.closeStore store + assertFailure "malformed metadata was accepted" + +rejectsCompatibleIncompleteSchema :: Assertion +rejectsCompatibleIncompleteSchema = + withStoreFixture "felix-store-incomplete" \path theory _fixture -> do + (_startup, store) <- expectOpen path theory + Store.closeStore store + connection <- SQLite.open path + SQLite.execute_ connection + "DROP TABLE canonical_propositions" + SQLite.close connection + + result <- Store.openStore path theory + case result of + Left + (Store.FatalStoreStartup + Store.StoreSchemaIntegrityFailure{}) -> + pure () + Left other -> + assertFailure + ("unexpected incomplete-schema result: " <> show other) + Right (_startup, current) -> do + Store.closeStore current + assertFailure "incomplete current schema was accepted" + +rollsBackUnequalDuplicateBatch :: Assertion +rollsBackUnequalDuplicateBatch = + withStoreFixture "felix-store-rollback" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let first = fixtureFirstObject fixture + second = fixtureSecondObject fixture + prefix <- makePendingPrefix fixture [first, second] + Store.closeStore store + + connection <- SQLite.open path + SQLite.execute connection + "INSERT INTO canonical_objects (object_id, payload) VALUES (?, ?)" + ( Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId second)) + , Cache.encodeCache + (Identity.putObjectContentCache + (Identity.assertedObjectContent + first)) + ) + SQLite.close connection + + (_reopened, current) <- expectOpen path theory + result <- Store.writePendingModulePrefix current prefix + case result of + Left Store.StoreRowPayloadMismatch{} -> + pure () + Left other -> + assertFailure + ("unexpected duplicate result: " <> show other) + Right () -> + assertFailure "unequal duplicate was accepted" + assertEqual "earlier insertion was rolled back" 0 + =<< storedObjectCount path (Identity.assertedObjectId first) + Store.closeStore current + +rejectsMalformedCanonicalPayloads :: Assertion +rejectsMalformedCanonicalPayloads = + withStoreFixture "felix-store-decode" \path theory fixture -> do + (_startup, store) <- expectOpen path theory + let object = fixtureFirstObject fixture + (_owner, prefix, syntax, semantic, key, artifact, _proposition) <- + makeCommittedModule theory fixture + expectRightIO + (Store.writeSealedModule + store prefix [syntax] [semantic] artifact) + Store.closeStore store + + connection <- SQLite.open path + SQLite.execute connection + "UPDATE canonical_objects SET payload = ? \ + \WHERE object_id = ?" + ( ByteString.singleton 0xff + , Cache.encodeCache + (Identity.putObjectIdCache + (Identity.assertedObjectId object)) + ) + SQLite.close connection + + (_reopened, current) <- expectOpen path theory + memo <- Store.newStoreMemo current + result <- Store.loadCachedModuleInstallation + memo current key (Syntax.moduleSyntaxAssertedId syntax) + case result of + Left Store.StoreRowDecodeFailure{} -> + pure () + Left other -> + assertFailure + ("unexpected malformed-row result: " <> show other) + Right _ -> + assertFailure "malformed canonical payload was accepted" + Store.closeStore current + +plansPersistentStores :: Assertion +plansPersistentStores = + Temp.withSystemTempDirectory "felix-store-planning" \root -> do + (theory, _fixture) <- makeStoreFixture + let cacheRoot = root Posix.</> "cache" + expectedDefault = + cacheRoot Posix.</> "felix" Posix.</> "store.sqlite" + explicitParent = root Posix.</> "explicit" + explicitPath = explicitParent Posix.</> "selected.sqlite" + Directory.createDirectory cacheRoot + Directory.createDirectory explicitParent + withEnvironment "XDG_CACHE_HOME" cacheRoot do + defaultPlan <- expectRightIO + (Store.planStore Store.DefaultStore) + defaultResult <- Store.withStoreLease defaultPlan \lease -> do + assertEqual "default store path" + expectedDefault + (Store.storePathFilePath + (Store.storeLeasePath lease)) + assertBool "planning does not create the default parent" + . not + =<< Directory.doesPathExist + (cacheRoot Posix.</> "felix") + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist expectedDefault + assertEqual "default store opens at the XDG path" + (Right True) defaultResult + + explicitPlan <- expectRightIO + (Store.planStore + (Store.ExplicitStore explicitPath)) + explicitResult <- Store.withStoreLease explicitPlan \lease -> do + assertEqual "explicit store path" + explicitPath + (Store.storePathFilePath + (Store.storeLeasePath lease)) + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist explicitPath + assertEqual "explicit store opens without creating its parent" + (Right True) explicitResult + + missing <- Store.planStore + (Store.ExplicitStore + (root Posix.</> "missing" Posix.</> "store.sqlite")) + case missing of + Left Store.ExplicitStoreParentMissing{} -> + pure () + Left other -> + assertFailure + ("unexpected missing-parent result: " <> show other) + Right _ -> + assertFailure "missing explicit parent was accepted" + +cleansFreshStores :: Assertion +cleansFreshStores = do + (theory, _fixture) <- makeStoreFixture + plan <- expectRightIO + (Store.planStore Store.FreshTemporaryStore) + + successPath <- IORef.newIORef Nothing + success <- Store.withStoreLease plan \lease -> do + let path = Store.storePathFilePath + (Store.storeLeasePath lease) + IORef.writeIORef successPath (Just path) + Store.withOpenStore lease theory \_startup _store -> + Directory.doesFileExist path + assertEqual "fresh store opened" (Right True) success + assertFreshRemoved successPath + + failurePath <- IORef.newIORef Nothing + failed <- Exception.try + (Store.withStoreLease plan \lease -> do + let path = Store.storePathFilePath + (Store.storeLeasePath lease) + IORef.writeIORef failurePath (Just path) + void + (Store.withOpenStore lease theory \_startup _store -> + ioError (userError "fresh action failed"))) + :: IO (Either IOError ()) + case failed of + Left _ -> + pure () + Right () -> + assertFailure "fresh-store action exception did not escape" + assertFreshRemoved failurePath + +doesNotFallBackAfterFatalStartup :: Assertion +doesNotFallBackAfterFatalStartup = + Temp.withSystemTempDirectory "felix-store-no-fallback" \root -> do + (theory, _fixture) <- makeStoreFixture + let persistentParent = root Posix.</> "persistent" + persistentPath = persistentParent Posix.</> "store.sqlite" + cacheRoot = root Posix.</> "cache" + Directory.createDirectory persistentParent + Directory.createDirectory cacheRoot + plan <- expectRightIO + (Store.planStore + (Store.ExplicitStore persistentPath)) + initialized <- Store.withStoreLease plan \lease -> + Store.withOpenStore lease theory \_startup _store -> + pure () + assertEqual "fixture store initialized" + (Right ()) initialized + connection <- SQLite.open persistentPath + SQLite.execute_ connection + "DROP TABLE canonical_objects" + SQLite.close connection + + withEnvironment "XDG_CACHE_HOME" cacheRoot do + result <- Store.withStoreLease plan \lease -> + Store.withOpenStore lease theory \_startup _store -> + pure () + case result of + Left + (Store.StoreLifecycleOpenFailed + (Store.FatalStoreStartup + Store.StoreSchemaIntegrityFailure{})) -> + pure () + Left other -> + assertFailure + ("unexpected fatal-startup result: " <> show other) + Right () -> + assertFailure "corrupt persistent store was accepted" + assertBool "fatal startup creates no default fallback" + . not + =<< Directory.doesPathExist + (cacheRoot Posix.</> "felix") + + +data StoreFixture = StoreFixture + !Identity.AssertedObject + !Identity.AssertedObject + !Identity.CheckedPropositionContent + +fixtureFirstObject :: StoreFixture -> Identity.AssertedObject +fixtureFirstObject (StoreFixture object _second _proposition) = + object + +fixtureSecondObject :: StoreFixture -> Identity.AssertedObject +fixtureSecondObject (StoreFixture _first object _proposition) = + object + +fixtureProposition + :: StoreFixture + -> Identity.CheckedPropositionContent +fixtureProposition (StoreFixture _first _second proposition) = + proposition + +makeStoreFixture + :: IO (Identity.TheoryId, StoreFixture) +makeStoreFixture = do + foundation <- expectRight Foundation.checkedFoundation + let theory = Identity.theoryId foundation + first = intrinsicObject theory Core.Empty + second = intrinsicObject theory Core.PairSet + closure <- expectRight + (Identity.validateObjectClosure theory [first, second]) + proposition <- expectRight + (Identity.validatePropositionContent + closure + (Core.CEq + Core.TySet + (Core.CGlobal (Identity.assertedObjectId first)) + (Core.CGlobal (Identity.assertedObjectId first)))) + pure + ( theory + , StoreFixture first second proposition + ) + +intrinsicObject + :: Identity.TheoryId + -> Core.CoreIntrinsicTag + -> Identity.AssertedObject +intrinsicObject theory tag = + Identity.assertedObject identity content + where + coreType = Core.coreIntrinsicType tag + content = + Identity.IntrinsicObjectContent + theory tag coreType + identity = + Identity.intrinsicObjectId + theory tag coreType + +withStoreFixture + :: String + -> ( FilePath + -> Identity.TheoryId + -> StoreFixture + -> IO a + ) + -> IO a +withStoreFixture template action = + Temp.withSystemTempDirectory template \root -> do + (theory, fixture) <- makeStoreFixture + action + (root Posix.</> "store.sqlite") + theory + fixture + +expectOpen + :: FilePath + -> Identity.TheoryId + -> IO (Store.StoreStartup, Store.Store) +expectOpen path theory = do + result <- Store.openStore path theory + case result of + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right opened -> + pure opened + +expectRight :: Show failure => Either failure value -> IO value +expectRight = \case + Left failure -> + assertFailure (show failure) >> fail "unreachable" + Right value -> + pure value + +expectRightIO + :: Show failure + => IO (Either failure value) + -> IO value +expectRightIO action = + expectRight =<< action + +assertFreshRemoved :: IORef.IORef (Maybe FilePath) -> Assertion +assertFreshRemoved pathReference = do + selected <- IORef.readIORef pathReference + case selected of + Nothing -> + assertFailure "fresh store path was not allocated" + Just path -> do + assertBool "fresh database was removed" + . not + =<< Directory.doesPathExist path + assertBool "fresh database directory was removed" + . not + =<< Directory.doesPathExist + (Posix.takeDirectory path) + +withEnvironment + :: String + -> String + -> IO value + -> IO value +withEnvironment name value action = + Exception.bracket + (Environment.lookupEnv name) + restore + \_previous -> do + Environment.setEnv name value + action + where + restore = \case + Nothing -> + Environment.unsetEnv name + Just previous -> + Environment.setEnv name previous diff --git a/source/Felix/Test/Unit/Token.hs b/source/Felix/Test/Unit/Token.hs new file mode 100644 index 0000000..00c6755 --- /dev/null +++ b/source/Felix/Test/Unit/Token.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.Token (unitTests) where + +import Base +import Felix.Report.Location +import Felix.Syntax.Adapt +import Felix.Syntax.Abstract (Associativity(..)) +import Felix.Syntax.Interface +import Felix.Syntax.Pragma +import Felix.Syntax.Token + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.Megaparsec (errorBundlePretty) + +unitTests :: TestTree +unitTests = testGroup "Lexer" + [ testCase "nested math inside text returns to text" nestedMathInsideText + , testCase "nested text and math returns to the enclosing frame" deeperAlternation + , testCase "braces inside text do not close the text frame" textBraceNesting + , testCase "cases is tokenized as an environment only inside math" casesOnlyInsideMath + , testCase "imports retain source locations and POSIX spellings" locatedImports + , testCase "commented environment starts are ignored" + ignoresCommentedEnvironmentStart + , testCase "empty inputs construct empty lexical syntax" + constructsEmptyLexicalSyntax + , testCase "extracts exact source fixity pragmas" + extractsSourceFixityPragmas + , testCase "rejects malformed reserved pragma lines" + rejectsMalformedPragmas + ] + +nestedMathInsideText :: Assertion +nestedMathInsideText = do + tokens <- tokensInProof "$\\text{if $x \\in A$ then}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "if" + , BeginEnv "math" + , Variable "x" + , Command "in" + , Variable "A" + , EndEnv "math" + , Word "then" + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +deeperAlternation :: Assertion +deeperAlternation = do + tokens <- tokensInProof "$\\text{a $ \\text{b $c$ d} e$ f}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "a" + , BeginEnv "math" + , BeginEnv "text" + , Word "b" + , BeginEnv "math" + , Variable "c" + , EndEnv "math" + , Word "d" + , EndEnv "text" + , Variable "e" + , EndEnv "math" + , Word "f" + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +textBraceNesting :: Assertion +textBraceNesting = do + tokens <- tokensInProof "$\\text{a {b}}$" + tokens `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "text" + , Word "a" + , InvisibleBraceL + , Word "b" + , InvisibleBraceR + , EndEnv "text" + , EndEnv "math" + , EndEnv "proof" + ] + +casesOnlyInsideMath :: Assertion +casesOnlyInsideMath = do + tokensInsideMath <- tokensInProof "$\\begin{cases}x\\end{cases}$" + tokensInsideMath `shouldBe` + [ BeginEnv "proof" + , BeginEnv "math" + , BeginEnv "cases" + , Variable "x" + , EndEnv "cases" + , EndEnv "math" + , EndEnv "proof" + ] + + tokensOutsideMath <- tokensInProof "\\begin{cases}x\\end{cases}" + assertBool + "cases should not be tokenized as an environment outside math" + (BeginEnv "cases" `notElem` tokensOutsideMath && EndEnv "cases" `notElem` tokensOutsideMath) + +locatedImports :: Assertion +locatedImports = do + let raw = Text.unlines + [ "% heading" + , "\\import{set/base.tex}" + , "\\import{set\\special.tex}" + , "\\begin{axiom}" + , " $x = x$." + , "\\end{axiom}" + ] + case gatherImports (FileId maxBound) "import-unit" raw of + Left err -> + assertFailure (errorBundlePretty err) + Right imports@[firstImport, secondImport] -> do + assertEqual + "import paths" + ["set/base.tex", "set\\special.tex"] + (unLocated <$> imports) + assertEqual "first import line" 2 (locLine (startPos firstImport)) + assertEqual "second import line" 3 (locLine (startPos secondImport)) + Right imports -> + assertFailure ("expected two imports, got " <> show imports) + +ignoresCommentedEnvironmentStart :: Assertion +ignoresCommentedEnvironmentStart = do + let raw = Text.unlines + [ "% \\begin{signature}" + , "ordinary text" + , "\\begin{struct}" + , " an ordered set $X$ is a onesorted structure." + , "\\end{struct}" + ] + (_, chunks) <- + either + (assertFailure . errorBundlePretty) + pure + (runLexer (FileId maxBound) "commented-environment" raw) + case chunks of + [Located{unLocated = BeginEnv "struct"} : _] -> pure () + _ -> assertFailure ("expected the real structure environment, got " <> show chunks) + +constructsEmptyLexicalSyntax :: Assertion +constructsEmptyLexicalSyntax = + forM_ + [ ("empty", "") + , ("comment-only", "% heading\n% body") + ] + \(description, raw) -> do + let input = Text.pack raw + imports <- + either + (assertFailure . errorBundlePretty) + pure + (gatherImports + (FileId maxBound) + description + input) + assertEqual (description <> " imports") [] imports + (lexedImports, chunks) <- + either + (assertFailure . errorBundlePretty) + pure + (runLexer + (FileId maxBound) + description + input) + assertEqual (description <> " lexer imports") [] lexedImports + assertEqual (description <> " chunks") [] chunks + scanned <- + either + (assertFailure . show) + pure + (concat <$> traverse scanChunk chunks) + assertEqual (description <> " scanned declarations") [] scanned + delta <- + either + (assertFailure . show) + pure + (canonicalSyntaxDelta []) + assertBool + (description <> " syntax declarations") + (null (canonicalSyntaxDeltaEntries delta)) + +extractsSourceFixityPragmas :: Assertion +extractsSourceFixityPragmas = do + let input = + " %! infixl 0\n" + <> "\t%! infixr 07\r\n" + <> "%! infix 3" + ordinaryComments = + Text.unlines + [ "% ! infixl 1" + , "text %! infixr 2" + , "% ordinary" + ] + pragmas <- + either + (assertFailure . Text.unpack . renderSyntaxPragmaError) + pure + (extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + input) + assertEqual + "normalized pragmas" + [ (LeftAssoc, 0, 1, 3) + , (RightAssoc, 7, 2, 2) + , (NonAssoc, 3, 3, 1) + ] + [ ( syntaxPragmaAssociativity pragma + , sourceMixfixLevelValue (syntaxPragmaLevel pragma) + , locLine (syntaxPragmaLocation pragma) + , locColumn (syntaxPragmaLocation pragma) + ) + | pragma <- pragmas + ] + assertEqual + "ordinary comments" + (Right []) + (extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + ordinaryComments) + +rejectsMalformedPragmas :: Assertion +rejectsMalformedPragmas = + forM_ + [ ("%!infixl 1\n", SyntaxPragmaMissingSpaceAfterPrefix) + , ("%!\n", SyntaxPragmaMissingKeyword) + , ("%! Infixl 1\n", SyntaxPragmaUnknownKeyword "Infixl") + , ("%! infixl\n", SyntaxPragmaMissingLevel) + , ("%! infixl -1\n", SyntaxPragmaInvalidLevel) + , ("%! infixl ١\n", SyntaxPragmaInvalidLevel) + , ("%! infixl 8\n", SyntaxPragmaLevelOutOfRange) + , ("%! infixl 1 extra\n", SyntaxPragmaTrailingContent) + , ("%! infixl 1\r", SyntaxPragmaLoneCarriageReturn) + ] + \(input, expectedProblem) -> + case extractSyntaxPragmas + (FileId maxBound) + "pragma-unit" + input of + Left (InvalidSyntaxPragma location actualProblem) -> do + assertEqual + ("problem for " <> show input) + expectedProblem + actualProblem + assertEqual "error line" 1 (locLine location) + assertEqual "error column" 1 (locColumn location) + Left err -> + assertFailure + ("unexpected pragma error: " + <> Text.unpack (renderSyntaxPragmaError err)) + Right pragmas -> + assertFailure + ("expected malformed pragma rejection, got " + <> show pragmas) + +tokensInProof :: Text -> IO [Token] +tokensInProof raw = + case runLexer (FileId maxBound) "lexer-unit" wrapped of + Left err -> + assertFailure (errorBundlePretty err) + Right (_imports, chunks) -> + pure (concatMap (map unLocated) chunks) + where + wrapped = Text.unlines + [ "\\begin{proof}" + , raw + , "\\end{proof}" + ] + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = flip (assertEqual "") diff --git a/source/Felix/Verification.hs b/source/Felix/Verification.hs index 572f3ce..716beea 100644 --- a/source/Felix/Verification.hs +++ b/source/Felix/Verification.hs @@ -48,11 +48,11 @@ module Felix.Verification import Base -import Checking.Declaration qualified as Declaration -import Checking.Foundation qualified as Foundation -import Checking.Identity qualified as Identity -import Checking.Module qualified as Typed -import Checking.Semantic qualified as Semantic +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Typed +import Felix.Checking.Semantic qualified as Semantic import Felix.Module (localDeclarationOrdinal) import Felix.Parse (ParseWorkspaceError(..), ParsedSourceWorkspace) import Felix.Parse qualified as Felix @@ -61,10 +61,10 @@ import Felix.Provers import Felix.Source import Felix.Source.Graph (ResolvedSourceGraph) import Felix.Store qualified as Store -import Render.Html.Export qualified as HtmlExport -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface qualified as Syntax +import Felix.Render.Html.Export qualified as HtmlExport +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax import Control.Exception qualified as Exception import Control.Monad (unless) diff --git a/source/Felix/Workspace.hs b/source/Felix/Workspace.hs index 6a13d42..b9034c5 100644 --- a/source/Felix/Workspace.hs +++ b/source/Felix/Workspace.hs @@ -29,11 +29,11 @@ import Felix.Prelude qualified as Prelude import Felix.Source import Felix.Source.Graph (ResolvedSourceGraph) import Felix.Source.Graph qualified as SourceGraph -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Adapt (ScannedLexicalItem, scanChunk) -import Syntax.Lexicon (builtins) -import Syntax.Token +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt (ScannedLexicalItem, scanChunk) +import Felix.Syntax.Lexicon (builtins) +import Felix.Syntax.Token import Control.Exception qualified as Exception import Data.Bifunctor (first) |