summaryrefslogtreecommitdiff
path: root/source/Test/Unit
diff options
context:
space:
mode:
authoradelon <22380201+adelon@users.noreply.github.com>2026-08-06 17:54:00 +0200
committeradelon <22380201+adelon@users.noreply.github.com>2026-08-06 17:54:00 +0200
commit82328890108bae64b372b8d58620ebc62699de76 (patch)
tree575404c6b425c19259c0ded296f1c8ffb7ff0e2b /source/Test/Unit
parent1a25421c2a168d420581358c8733fcd8f36f379b (diff)
Migrate to `Felix` namespaceHEADhotg
Diffstat (limited to 'source/Test/Unit')
-rw-r--r--source/Test/Unit/Abstract.hs114
-rw-r--r--source/Test/Unit/Backend.hs752
-rw-r--r--source/Test/Unit/CommandLine.hs799
-rw-r--r--source/Test/Unit/Concrete.hs221
-rw-r--r--source/Test/Unit/Core.hs670
-rw-r--r--source/Test/Unit/Declaration.hs3596
-rw-r--r--source/Test/Unit/Foundation.hs284
-rw-r--r--source/Test/Unit/Html.hs225
-rw-r--r--source/Test/Unit/HtmlLayout.hs478
-rw-r--r--source/Test/Unit/HtmlOutput.hs560
-rw-r--r--source/Test/Unit/Identity.hs802
-rw-r--r--source/Test/Unit/Kernel.hs858
-rw-r--r--source/Test/Unit/Lexicon.hs333
-rw-r--r--source/Test/Unit/Materialization.hs357
-rw-r--r--source/Test/Unit/Meaning.hs1119
-rw-r--r--source/Test/Unit/Module.hs9759
-rw-r--r--source/Test/Unit/OutputPlan.hs236
-rw-r--r--source/Test/Unit/Provers.hs1159
-rw-r--r--source/Test/Unit/Semantic.hs437
-rw-r--r--source/Test/Unit/Source.hs2581
-rw-r--r--source/Test/Unit/Store.hs1675
-rw-r--r--source/Test/Unit/Token.hs285
22 files changed, 0 insertions, 27300 deletions
diff --git a/source/Test/Unit/Abstract.hs b/source/Test/Unit/Abstract.hs
deleted file mode 100644
index 61118bd..0000000
--- a/source/Test/Unit/Abstract.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Abstract (unitTests) where
-
-import Base
-import Report.Location
-import 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/Test/Unit/Backend.hs b/source/Test/Unit/Backend.hs
deleted file mode 100644
index 5243c96..0000000
--- a/source/Test/Unit/Backend.hs
+++ /dev/null
@@ -1,752 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Backend (unitTests) where
-
-import Base hiding (Empty)
-import Checking.Backend.Problem
-import Checking.Backend.Tptp
-import Checking.Core
-import 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/Test/Unit/CommandLine.hs b/source/Test/Unit/CommandLine.hs
deleted file mode 100644
index 110e00d..0000000
--- a/source/Test/Unit/CommandLine.hs
+++ /dev/null
@@ -1,799 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module 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 Render.Html.Output qualified as HtmlOutput
-import 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/Test/Unit/Concrete.hs b/source/Test/Unit/Concrete.hs
deleted file mode 100644
index 7776552..0000000
--- a/source/Test/Unit/Concrete.hs
+++ /dev/null
@@ -1,221 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Concrete (unitTests) where
-
-import Base
-import Report.Location
-import Syntax.Abstract qualified as Raw
-import Syntax.Concrete (grammar)
-import Syntax.Lexicon (builtins)
-import 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/Test/Unit/Core.hs b/source/Test/Unit/Core.hs
deleted file mode 100644
index 643dc38..0000000
--- a/source/Test/Unit/Core.hs
+++ /dev/null
@@ -1,670 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Core (unitTests) where
-
-import Base hiding (Empty)
-import Checking.Core
-import Checking.Foundation qualified as Foundation
-import 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/Test/Unit/Declaration.hs b/source/Test/Unit/Declaration.hs
deleted file mode 100644
index 32d979c..0000000
--- a/source/Test/Unit/Declaration.hs
+++ /dev/null
@@ -1,3596 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Declaration (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Backend.Problem qualified as Backend
-import Checking.Core qualified as Core
-import Checking.Declaration qualified as Declaration
-import Checking.Foundation qualified as Foundation
-import Checking.Exact qualified as Exact
-import Checking.Exact.Vocabulary qualified as Vocabulary
-import Checking.Identity qualified as Identity
-import Checking.Kernel.Derivation qualified as Kernel
-import Checking.SetConstruction qualified as SetConstruction
-import Checking.Semantic qualified as Semantic
-import 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 Report.Location
-import Syntax.Abstract qualified as Raw
-import Syntax.Interface qualified as Syntax
-import Syntax.Internal qualified as Internal
-import 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/Test/Unit/Foundation.hs b/source/Test/Unit/Foundation.hs
deleted file mode 100644
index 17ff526..0000000
--- a/source/Test/Unit/Foundation.hs
+++ /dev/null
@@ -1,284 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Foundation (unitTests) where
-
-import Base
-import Checking.Core
-import 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/Test/Unit/Html.hs b/source/Test/Unit/Html.hs
deleted file mode 100644
index c7f24c4..0000000
--- a/source/Test/Unit/Html.hs
+++ /dev/null
@@ -1,225 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module 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 Render.Html qualified as Html
-import Render.Html.Context
-import Render.Html.Layout
-import Report.Location (Location, pattern Nowhere)
-import Syntax.Abstract
-
-import Data.Text qualified as Text
-import Data.Text.IO qualified as TextIO
-import Data.List.NonEmpty qualified as NonEmpty
-import System.Directory qualified as Directory
-import Test.Tasty
-import Test.Tasty.HUnit
-
-unitTests :: TestTree
-unitTests = testGroup "HTML renderer"
- [ testCase "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/Test/Unit/HtmlLayout.hs b/source/Test/Unit/HtmlLayout.hs
deleted file mode 100644
index a248f3b..0000000
--- a/source/Test/Unit/HtmlLayout.hs
+++ /dev/null
@@ -1,478 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.HtmlLayout (unitTests) where
-
-import Base
-import Felix.Source
-import Felix.Source.Graph
-import 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/Test/Unit/HtmlOutput.hs b/source/Test/Unit/HtmlOutput.hs
deleted file mode 100644
index 0087f82..0000000
--- a/source/Test/Unit/HtmlOutput.hs
+++ /dev/null
@@ -1,560 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.HtmlOutput (unitTests) where
-
-import Base
-import Felix.Parse qualified as Parse
-import Felix.Source
-import Felix.Source.Graph qualified as SourceGraph
-import Render.Html qualified as Html
-import Render.Html.Export
-import Render.Html.Output
-
-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/Test/Unit/Identity.hs b/source/Test/Unit/Identity.hs
deleted file mode 100644
index 0cb46a5..0000000
--- a/source/Test/Unit/Identity.hs
+++ /dev/null
@@ -1,802 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Identity (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Core qualified as Core
-import Checking.Foundation qualified as Foundation
-import 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/Test/Unit/Kernel.hs b/source/Test/Unit/Kernel.hs
deleted file mode 100644
index d01a194..0000000
--- a/source/Test/Unit/Kernel.hs
+++ /dev/null
@@ -1,858 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Test.Unit.Kernel (unitTests) where
-
-import Base hiding (Empty)
-import Checking.Core
-import Checking.Foundation qualified as Foundation
-import Checking.Kernel.Derivation
-import Checking.Kernel.Semantics qualified as Semantics
-import Checking.Kernel.SetLfp qualified as SetLfp
-import Checking.Typed.Inductive qualified as Inductive
-import Report.Location (pattern Nowhere)
-import 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/Test/Unit/Lexicon.hs b/source/Test/Unit/Lexicon.hs
deleted file mode 100644
index 54b4bd4..0000000
--- a/source/Test/Unit/Lexicon.hs
+++ /dev/null
@@ -1,333 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Lexicon (unitTests) where
-
-import Base
-import Felix.Cache.Codec
-import Syntax.Abstract
-import Syntax.Interface
-import 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/Test/Unit/Materialization.hs b/source/Test/Unit/Materialization.hs
deleted file mode 100644
index fcad7b5..0000000
--- a/source/Test/Unit/Materialization.hs
+++ /dev/null
@@ -1,357 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Materialization (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Core qualified as Core
-import Checking.Foundation qualified as Foundation
-import Checking.Identity qualified as Identity
-import Checking.Materialization qualified as Materialization
-import 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/Test/Unit/Meaning.hs b/source/Test/Unit/Meaning.hs
deleted file mode 100644
index acb33d0..0000000
--- a/source/Test/Unit/Meaning.hs
+++ /dev/null
@@ -1,1119 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Meaning (unitTests) where
-
-import Base
-import Felix.Meaning
-import Report.Location
-import Syntax.Abstract qualified as Raw
-import Syntax.Internal qualified as Sem
-import 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/Test/Unit/Module.hs b/source/Test/Unit/Module.hs
deleted file mode 100644
index 13fe90d..0000000
--- a/source/Test/Unit/Module.hs
+++ /dev/null
@@ -1,9759 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Module (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Backend.Problem qualified as Backend
-import Checking.Core qualified as Core
-import Checking.Declaration qualified as Declaration
-import Checking.Exact qualified as Exact
-import Checking.Exact.Datatype qualified as ExactDatatype
-import Checking.Exact.Inductive qualified as ExactInductive
-import Checking.Exact.Proof qualified as ExactProof
-import Checking.FinalPrelude qualified as FinalPrelude
-import Checking.Foundation qualified as Foundation
-import Checking.Identity qualified as Identity
-import Checking.Module qualified as Module
-import Checking.Semantic qualified as Semantic
-import Checking.Typed.Inductive qualified as TypedInductive
-import Felix.CommandLine qualified as CommandLine
-import Felix.Module
-import Felix.Math.Codec
-import Felix.Parse qualified as Parse
-import Felix.Prelude qualified as Prelude
-import Felix.Source
-import Felix.Source.Content qualified as Content
-import Felix.Store qualified as Store
-import Felix.Verification qualified as Verification
-import Felix.Workspace qualified as Workspace
-import Report.Location
-import Felix.Provers qualified as Provers
-import Paths_felix qualified as Paths
-import Syntax.Abstract qualified as Raw
-import Syntax.Internal qualified as Internal
-import Syntax.Interface qualified as Syntax
-import Syntax.Lexicon qualified as Lexicon
-import Syntax.Pragma qualified as Pragma
-
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.STM
- ( atomically
- , check
- , newEmptyTMVarIO
- , newTQueueIO
- , newTVarIO
- , putTMVar
- , readTQueue
- , readTVar
- , takeTMVar
- , tryReadTMVar
- , tryReadTQueue
- , writeTQueue
- , writeTVar
- )
-import Control.Exception (bracket)
-import Control.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/Test/Unit/OutputPlan.hs b/source/Test/Unit/OutputPlan.hs
deleted file mode 100644
index 45658bf..0000000
--- a/source/Test/Unit/OutputPlan.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module 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/Test/Unit/Provers.hs b/source/Test/Unit/Provers.hs
deleted file mode 100644
index 0d0cf1b..0000000
--- a/source/Test/Unit/Provers.hs
+++ /dev/null
@@ -1,1159 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Provers (unitTests) where
-
-import Base hiding (Empty)
-import Checking.Backend.Problem
-import 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 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/Test/Unit/Semantic.hs b/source/Test/Unit/Semantic.hs
deleted file mode 100644
index 160735c..0000000
--- a/source/Test/Unit/Semantic.hs
+++ /dev/null
@@ -1,437 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Semantic (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Core qualified as Core
-import Checking.Foundation qualified as Foundation
-import Checking.Identity qualified as Identity
-import 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 Syntax.Interface qualified as Syntax
-import Syntax.Abstract qualified as Raw
-
-import Data.ByteString (ByteString)
-import Data.List qualified as List
-import Data.Map.Strict qualified as Map
-import Test.Tasty
-import Test.Tasty.HUnit
-
-
-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/Test/Unit/Source.hs b/source/Test/Unit/Source.hs
deleted file mode 100644
index a8e4506..0000000
--- a/source/Test/Unit/Source.hs
+++ /dev/null
@@ -1,2581 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Test.Unit.Source (unitTests) where
-
-import Base
-import Checking.Foundation qualified as Foundation
-import Checking.Identity qualified as Identity
-import 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 Report.Location
- ( FileId(..)
- , FileIdAllocator(..)
- , Location(..)
- , LocationRegistrationError(..)
- , allocateFileId
- , locColumn
- , locFile
- , locFileId
- , locLine
- , lookupFileIdentityPath
- )
-import Syntax.Abstract qualified as Raw
-import Syntax.Adapt qualified as Adapt
-import Syntax.Interface qualified as Interface
-import 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/Test/Unit/Store.hs b/source/Test/Unit/Store.hs
deleted file mode 100644
index fb207d1..0000000
--- a/source/Test/Unit/Store.hs
+++ /dev/null
@@ -1,1675 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Test.Unit.Store (unitTests) where
-
-import Base
-import Checking.Authority qualified as Authority
-import Checking.Core qualified as Core
-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.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 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/Test/Unit/Token.hs b/source/Test/Unit/Token.hs
deleted file mode 100644
index d399e2a..0000000
--- a/source/Test/Unit/Token.hs
+++ /dev/null
@@ -1,285 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Test.Unit.Token (unitTests) where
-
-import Base
-import Report.Location
-import Syntax.Adapt
-import Syntax.Abstract (Associativity(..))
-import Syntax.Interface
-import Syntax.Pragma
-import 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 "")
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-06 19:07:52 +0000