diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/Api.hs | 1973 | ||||
| -rw-r--r-- | source/Checking/Exact/Proof.hs | 1359 | ||||
| -rw-r--r-- | source/CommandLine.hs | 961 | ||||
| -rw-r--r-- | source/Felix/Cache/Codec.hs | 4 | ||||
| -rw-r--r-- | source/Felix/Checking/Authority.hs (renamed from source/Checking/Authority.hs) | 15 | ||||
| -rw-r--r-- | source/Felix/Checking/Backend/Problem.hs (renamed from source/Checking/Backend/Problem.hs) | 217 | ||||
| -rw-r--r-- | source/Felix/Checking/Backend/Tptp.hs (renamed from source/Checking/Backend/Tptp.hs) | 26 | ||||
| -rw-r--r-- | source/Felix/Checking/Core.hs (renamed from source/Checking/Core.hs) | 232 | ||||
| -rw-r--r-- | source/Felix/Checking/Datatype.hs (renamed from source/Checking/Datatype.hs) | 8 | ||||
| -rw-r--r-- | source/Felix/Checking/Declaration.hs (renamed from source/Checking/Declaration.hs) | 429 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact.hs (renamed from source/Checking/Exact.hs) | 1323 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact/Datatype.hs (renamed from source/Checking/Exact/Datatype.hs) | 30 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact/Global.hs (renamed from source/Checking/Exact/Global.hs) | 16 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact/Inductive.hs (renamed from source/Checking/Exact/Inductive.hs) | 257 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact/Proof.hs | 2639 | ||||
| -rw-r--r-- | source/Felix/Checking/Exact/Vocabulary.hs (renamed from source/Checking/Exact/Vocabulary.hs) | 42 | ||||
| -rw-r--r-- | source/Felix/Checking/FinalPrelude.hs (renamed from source/Checking/FinalPrelude.hs) | 265 | ||||
| -rw-r--r-- | source/Felix/Checking/Foundation.hs (renamed from source/Checking/Foundation.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Checking/Identity.hs (renamed from source/Checking/Identity.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Checking/Kernel/Derivation.hs (renamed from source/Checking/Kernel/Derivation.hs) | 10 | ||||
| -rw-r--r-- | source/Felix/Checking/Kernel/Proof.hs (renamed from source/Checking/Kernel/Proof.hs) | 289 | ||||
| -rw-r--r-- | source/Felix/Checking/Kernel/Semantics.hs (renamed from source/Checking/Kernel/Semantics.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Checking/Kernel/SetLfp.hs (renamed from source/Checking/Kernel/SetLfp.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Checking/Materialization.hs (renamed from source/Checking/Materialization.hs) | 8 | ||||
| -rw-r--r-- | source/Felix/Checking/Module.hs (renamed from source/Checking/Module.hs) | 29 | ||||
| -rw-r--r-- | source/Felix/Checking/Semantic.hs (renamed from source/Checking/Semantic.hs) | 12 | ||||
| -rw-r--r-- | source/Felix/Checking/SetConstruction.hs | 1191 | ||||
| -rw-r--r-- | source/Felix/Checking/Typed/Inductive.hs (renamed from source/Checking/Typed/Inductive.hs) | 958 | ||||
| -rw-r--r-- | source/Felix/CommandLine.hs | 911 | ||||
| -rw-r--r-- | source/Felix/Math/Codec.hs | 2 | ||||
| -rw-r--r-- | source/Felix/Meaning.hs (renamed from source/Meaning.hs) | 18 | ||||
| -rw-r--r-- | source/Felix/Output/Atomic.hs | 29 | ||||
| -rw-r--r-- | source/Felix/OutputPlan.hs | 2 | ||||
| -rw-r--r-- | source/Felix/Parse.hs | 426 | ||||
| -rw-r--r-- | source/Felix/Parsed/Identity.hs | 2 | ||||
| -rw-r--r-- | source/Felix/Parsed/Payload.hs | 10 | ||||
| -rw-r--r-- | source/Felix/Prelude.hs | 8 | ||||
| -rw-r--r-- | source/Felix/Provers.hs (renamed from source/Provers.hs) | 542 | ||||
| -rw-r--r-- | source/Felix/Render/Html.hs (renamed from source/Render/Html.hs) | 13 | ||||
| -rw-r--r-- | source/Felix/Render/Html/Context.hs (renamed from source/Render/Html/Context.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Render/Html/Export.hs (renamed from source/Render/Html/Export.hs) | 95 | ||||
| -rw-r--r-- | source/Felix/Render/Html/Layout.hs (renamed from source/Render/Html/Layout.hs) | 2 | ||||
| -rw-r--r-- | source/Felix/Render/Html/Output.hs (renamed from source/Render/Html/Output.hs) | 20 | ||||
| -rw-r--r-- | source/Felix/Report/Location.hs (renamed from source/Report/Location.hs) | 2 | ||||
| -rw-r--r-- | source/Felix/RequestDump.hs | 97 | ||||
| -rw-r--r-- | source/Felix/Source.hs | 101 | ||||
| -rw-r--r-- | source/Felix/Source/Graph.hs | 45 | ||||
| -rw-r--r-- | source/Felix/Store.hs | 16 | ||||
| -rw-r--r-- | source/Felix/Syntax/Abstract.hs (renamed from source/Syntax/Abstract.hs) | 29 | ||||
| -rw-r--r-- | source/Felix/Syntax/Adapt.hs (renamed from source/Syntax/Adapt.hs) | 10 | ||||
| -rw-r--r-- | source/Felix/Syntax/Concrete.hs (renamed from source/Syntax/Concrete.hs) | 15 | ||||
| -rw-r--r-- | source/Felix/Syntax/Concrete/Keywords.hs (renamed from source/Syntax/Concrete/Keywords.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Syntax/Interface.hs (renamed from source/Syntax/Interface.hs) | 8 | ||||
| -rw-r--r-- | source/Felix/Syntax/Internal.hs (renamed from source/Syntax/Internal.hs) | 41 | ||||
| -rw-r--r-- | source/Felix/Syntax/LexicalPhrase.hs (renamed from source/Syntax/LexicalPhrase.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Syntax/Lexicon.hs (renamed from source/Syntax/Lexicon.hs) | 23 | ||||
| -rw-r--r-- | source/Felix/Syntax/Mixfix.hs (renamed from source/Syntax/Mixfix.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Syntax/Pragma.hs (renamed from source/Syntax/Pragma.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Syntax/Token.hs (renamed from source/Syntax/Token.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Test/All.hs (renamed from source/Test/All.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Test/Golden.hs (renamed from source/Test/Golden.hs) | 14 | ||||
| -rw-r--r-- | source/Felix/Test/Unit.hs | 52 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Abstract.hs (renamed from source/Test/Unit/Abstract.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Backend.hs (renamed from source/Test/Unit/Backend.hs) | 277 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/CommandLine.hs (renamed from source/Test/Unit/CommandLine.hs) | 70 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Concrete.hs (renamed from source/Test/Unit/Concrete.hs) | 12 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Core.hs (renamed from source/Test/Unit/Core.hs) | 216 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Declaration.hs (renamed from source/Test/Unit/Declaration.hs) | 682 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Foundation.hs (renamed from source/Test/Unit/Foundation.hs) | 6 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Html.hs (renamed from source/Test/Unit/Html.hs) | 19 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/HtmlLayout.hs (renamed from source/Test/Unit/HtmlLayout.hs) | 4 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/HtmlOutput.hs (renamed from source/Test/Unit/HtmlOutput.hs) | 8 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Identity.hs (renamed from source/Test/Unit/Identity.hs) | 15 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Kernel.hs (renamed from source/Test/Unit/Kernel.hs) | 21 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Lexicon.hs (renamed from source/Test/Unit/Lexicon.hs) | 8 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Materialization.hs (renamed from source/Test/Unit/Materialization.hs) | 14 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Meaning.hs (renamed from source/Test/Unit/Meaning.hs) | 12 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Module.hs (renamed from source/Test/Unit/Module.hs) | 4159 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/OutputPlan.hs (renamed from source/Test/Unit/OutputPlan.hs) | 2 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Provers.hs (renamed from source/Test/Unit/Provers.hs) | 363 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Semantic.hs (renamed from source/Test/Unit/Semantic.hs) | 16 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Source.hs (renamed from source/Test/Unit/Source.hs) | 155 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Store.hs (renamed from source/Test/Unit/Store.hs) | 20 | ||||
| -rw-r--r-- | source/Felix/Test/Unit/Token.hs (renamed from source/Test/Unit/Token.hs) | 14 | ||||
| -rw-r--r-- | source/Felix/Verification.hs | 1157 | ||||
| -rw-r--r-- | source/Felix/Version.hs (renamed from source/Version.hs) | 2 | ||||
| -rw-r--r-- | source/Felix/Workspace.hs | 242 | ||||
| -rw-r--r-- | source/Test/Unit.hs | 52 |
88 files changed, 15437 insertions, 6995 deletions
diff --git a/source/Api.hs b/source/Api.hs deleted file mode 100644 index d9fca1d..0000000 --- a/source/Api.hs +++ /dev/null @@ -1,1973 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} - -module Api - ( tokenize, TokStream - , scan - , parse - , parseWorkspace - , AuthorityFreeParseError(..) - , renderAuthorityFreeParseError - , simpleStream - , builtins - , ParseException(..) - , verify, verifyMeasured - , verifyWithObserverAndStoreMode - , verifyMeasuredWithObserverAndStoreMode - , verifyWithObserverAndStoreModeAndJobs - , verifyMeasuredWithObserverAndStoreModeAndJobs - , StoreValidationMode(..) - , WorkPosition - , workPosition - , workPositionModuleOrdinal - , workPositionLocalRequestOrdinal - , VerificationRequestObserver - , verificationRequestObserver - , ProverAnswer - ( CounterSatisfiable - , ContradictoryAxioms - , Uncertain - , Error - ) - , pattern Yes - , VerificationResult(..) - , VerificationPresentation - , ReportedEscapeKind(..) - , ReportedEscape(..) - , VerificationReport(..) - , VerificationMeasurements(..) - , VerificationDriverError(..) - , FailedVerification(..) - , VerificationFailureReason(..) - , prepareVerifiedHtmlExportResult - , prepareDefaultSourceGraph - , defaultHtmlMountPrefixes - ) where - - -import Base -import Checking.Declaration qualified as Declaration -import Checking.Foundation qualified as Foundation -import Checking.Identity qualified as Identity -import Checking.Module qualified as Typed -import Checking.Semantic qualified as Semantic -import Felix.Module (localDeclarationOrdinal) -import Felix.Parse (ParseException(..), ParseWorkspaceError(..), ParsedSourceWorkspace) -import Felix.Parse qualified as Felix -import Felix.Prelude qualified as Prelude -import Felix.Source -import Felix.Store qualified as Store -import Felix.Source.Graph (ResolvedSourceGraph) -import Felix.Source.Graph qualified as SourceGraph -import Provers -import Render.Html.Export qualified as HtmlExport -import Render.Html.Output (PreparedHtmlArtifact) -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Adapt (scanChunk, ScannedLexicalItem) -import Syntax.Interface qualified as Syntax -import Syntax.Lexicon (builtins) -import Syntax.Token - -import Control.Exception qualified as Exception -import Control.Monad.Logger -import Control.Monad (unless) -import Data.Bifunctor (first) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict qualified as Map -import Data.Text qualified as StrictText -import Data.Text.Encoding.Error (UnicodeException) -import Data.Text.IO qualified as Text -import Numeric.Natural (Natural) -import System.FilePath.Posix -import Text.Megaparsec hiding (failure, parse, Token, try) -import UnliftIO -import UnliftIO.Async qualified as Async -import UnliftIO.Directory -import UnliftIO.Environment - --- Renderer data follows the established current-directory, configured-library, --- and debug-directory lookup policy. -findAndReadRendererFile - :: FilePath - -> IO (Either HtmlExport.HtmlExportError Text) -findAndReadRendererFile path = do - rootsResult <- tryRendererIO do - currentDir <- getCurrentDirectory - configuredLibrary <- lookupEnv "NAPROCHE_LIB" - let libraryDir = - fromMaybe - (currentDir </> "library") - configuredLibrary - pure - [ currentDir </> path - , libraryDir </> path - , currentDir </> "debug" </> path - ] - case rootsResult of - Left failure -> - pure - (Left - (HtmlExport.HtmlRendererDataLookupFailed - path - (StrictText.pack - (displayException failure)))) - Right candidates -> do - selected <- selectRendererData path candidates - case selected of - Left failure -> - pure (Left failure) - Right selectedPath -> do - readResult <- tryRendererRead - (Text.readFile selectedPath) - pure case readResult of - Left reason -> - Left - (HtmlExport.HtmlRendererDataReadFailed - selectedPath - reason) - Right contents -> - Right contents - -selectRendererData - :: FilePath - -> [FilePath] - -> IO (Either HtmlExport.HtmlExportError FilePath) -selectRendererData requested candidates = - go candidates - where - go = \case - [] -> - pure - (Left - (HtmlExport.HtmlRendererDataNotFound - requested - candidates)) - candidate : remaining -> do - inspected <- tryRendererIO - (doesFileExist candidate) - case inspected of - Left failure -> - pure - (Left - (HtmlExport.HtmlRendererDataLookupFailed - candidate - (StrictText.pack - (displayException failure)))) - Right True -> - pure (Right candidate) - Right False -> - go remaining - -tryRendererIO :: IO value -> IO (Either IOException value) -tryRendererIO = Exception.try - -tryRendererRead :: IO value -> IO (Either Text value) -tryRendererRead action = - Exception.catch - (Exception.catch - (Right <$> action) - renderIOException) - renderUnicodeException - where - renderIOException :: IOException -> IO (Either Text value) - renderIOException = - pure . Left . StrictText.pack . displayException - - renderUnicodeException - :: UnicodeException - -> IO (Either Text value) - renderUnicodeException = - pure . Left . StrictText.pack . displayException - -lexFile :: MonadIO io => FilePath -> io (Text, [[Located Token]]) -lexFile file = do - prepared <- liftIO (prepareDefaultSourceRequest file) - (mounts, request) <- either throwWorkspaceError pure prepared - loaded <- - liftIO (resolveAndLoadRoot mounts request) - >>= either throwIO pure - let source = loadedSource loaded - raw = loadedText loaded - locationPath = resolvedSourceLocationPath source - canonicalPath = - canonicalPathFilePath - (resolvedSourceCanonicalPath source) - registration <- - registerFilePathWithDisplay - canonicalPath - locationPath - fileId <- either - (throwIO . SourceLocationRegistrationFailed source) - pure - registration - case runLexer fileId locationPath raw of - Left tokenError -> - throwIO (TokenError (errorBundlePretty tokenError)) - Right (_imports, chunks) -> - pure (raw, chunks) - --- | Throws a 'ParseException' when tokenizing fails. -tokenize :: MonadIO io => FilePath -> io TokStream -tokenize file = do - (raw, chunks) <- lexFile file - pure (TokStream raw chunks) - --- | Scan the given file for lexical items. The actual parsing process --- builds one workspace lexicon instead. -scan :: MonadIO io => FilePath -> io [ScannedLexicalItem] -scan input = do - tokenStream <- tokenize input - fmap (concatMap (fmap unLocated)) $ - traverse - (either (throwIO . LexicalScanFailure) pure . scanChunk) - (unTokStream tokenStream) - - --- | Parse a file. Throws an 'AuthorityFreeParseError' when packaged-prelude --- loading/parsing or ordinary workspace parsing fails. -parse :: MonadIO io => FilePath -> io [Raw.Block] -parse file = do - result <- parseWorkspace file - either throwIO pure result - -data AuthorityFreeParseError - = AuthorityFreePreludeLoadFailed !Prelude.PreludeLoadError - | AuthorityFreePreludeParseFailed !Prelude.PreludeParseError - | AuthorityFreeWorkspaceFailed !ParseWorkspaceError - deriving (Show) - -instance Exception AuthorityFreeParseError - -renderAuthorityFreeParseError :: AuthorityFreeParseError -> Text -renderAuthorityFreeParseError = \case - AuthorityFreePreludeLoadFailed failure -> - "packaged final prelude loading failed: " - <> Prelude.renderPreludeLoadError failure - AuthorityFreePreludeParseFailed failure -> - "packaged final prelude parsing failed: " - <> Prelude.renderPreludeParseError failure - AuthorityFreeWorkspaceFailed failure -> - Felix.renderParseWorkspaceError failure - -parseWorkspace - :: MonadIO io - => FilePath - -> io (Either AuthorityFreeParseError [Raw.Block]) -parseWorkspace file = - fmap Felix.importedBeforeImporterBlocks - <$> liftIO (parseDefaultWorkspaceWithPrelude file) - -parseDefaultWorkspaceWithPrelude - :: FilePath - -> IO - (Either - AuthorityFreeParseError - ParsedSourceWorkspace) -parseDefaultWorkspaceWithPrelude file = - Prelude.loadReservedPreludeSourceInput >>= \case - Left failure -> - pure (Left (AuthorityFreePreludeLoadFailed failure)) - Right source -> - Prelude.parseReservedPreludeSource source >>= \case - Left failure -> - pure (Left (AuthorityFreePreludeParseFailed failure)) - Right prelude -> do - prepared <- prepareDefaultSourceRequest file - case prepared of - Left failure -> - pure - (Left - (AuthorityFreeWorkspaceFailed failure)) - Right (mounts, request) -> do - let syntax = - Felix.identifiedParsedModuleSyntaxInterface - (Prelude.reservedParsedPreludeModule - prelude) - fmap - (first AuthorityFreeWorkspaceFailed . fmap fst) - (Felix.parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation - mounts - request - (const [syntax]) - (Prelude.rejectOrdinaryPreludeSourceGraph - source)) - -prepareDefaultSourceRequest - :: FilePath - -> IO (Either ParseWorkspaceError (SourceMounts, RootRequest)) -prepareDefaultSourceRequest file = do - mountsResult <- prepareDefaultSourceMounts - requestResult <- classifyRootRequest file - pure case (mountsResult, requestResult) of - (Left err, _) -> - Left (SourceWorkspaceError err) - (_, Left err) -> - Left (SourceWorkspaceError err) - (Right mounts, Right request) -> - Right (mounts, request) - -prepareDefaultSourceGraph - :: FilePath - -> IO (Either ParseWorkspaceError ResolvedSourceGraph) -prepareDefaultSourceGraph file = do - prepared <- prepareDefaultSourceRequest file - case prepared of - Left sourceFailure -> - pure (Left sourceFailure) - Right (mounts, request) -> - first SourceWorkspaceError - <$> SourceGraph.buildResolvedSourceGraph mounts request - -prepareDefaultSourceMounts :: IO (Either SourceError SourceMounts) -prepareDefaultSourceMounts = do - currentDir <- getCurrentDirectory - configuredLibrary <- lookupEnv "NAPROCHE_LIB" - let libraryDir = configuredLibrary ?? (currentDir </> "library") - debugDir = currentDir </> "debug" - prepareSourceMounts - [ (sourceMountId "project", currentDir) - , (sourceMountId "library", libraryDir) - , (sourceMountId "debug", debugDir) - ] - -classifyRootRequest :: FilePath -> IO (Either SourceError RootRequest) -classifyRootRequest file - | isAbsolute file = - existingRoot file - | otherwise = - pure (searchedRoot file) - -throwWorkspaceError :: MonadIO io => ParseWorkspaceError -> io a -throwWorkspaceError = \case - SourceWorkspaceError err -> - throwIO err - err@(SourceLexiconCollision _) -> - throwIO err - err@(SourceSyntaxPragmaError _source _pragmaError) -> - throwIO err - err@(SourceSyntaxDeclarationError _source _declarationError) -> - throwIO err - err@(SourceSyntaxMaterializationError _materializationError) -> - throwIO err - err@(SourceParsedModuleKeyError _source _keyError) -> - throwIO err - SourceParseError _source err -> - throwIO err - - -simpleStream :: TokStream -> [[Token]] -simpleStream TokStream{unTokStream=chunks} = [unLocated <$> ch | ch <- chunks] - -data VerificationResult - = VerificationCompleted - !VerificationReport - !VerificationPresentation - | CompletedWithExplicitGaps - !VerificationReport - !VerificationPresentation - | VerificationFailure !VerificationReport !FailedVerification - | VerificationCheckingFailure - !VerificationReport - !VerificationDriverError - deriving (Show) - --- | Strict owner-independent source presentation retained only after the --- complete typed workspace succeeds. -data VerificationPresentation = VerificationPresentation - !HtmlExport.HtmlPresentation - -instance Show VerificationPresentation where - show _presentation = - "VerificationPresentation <HTML presentation>" - -data ReportedEscapeKind - = ReportedSourceAxiom - | ReportedOmitted - deriving (Show, Eq) - -data ReportedEscape = ReportedEscape - { reportedEscapeKind :: !ReportedEscapeKind - , reportedEscapeLocation :: !Location - } - deriving (Show, Eq) - -data VerificationReport = VerificationReport - { verificationDirectEscapes :: ![ReportedEscape] - } - deriving (Show, Eq) - --- | Invocation-local observation of the verification pipeline. --- --- Durations use the monotonic clock and are never part of fact authority or --- deterministic verification results. -data VerificationMeasurements = VerificationMeasurements - { verificationParseMeasurements :: !Felix.ParseMeasurements - , verificationSourcePreparationNanoseconds :: !Word64 - , verificationInvocationNanoseconds :: !Word64 - , verificationCheckingNanoseconds :: !Word64 - , verificationModuleCount :: !Int - , verificationDetectedProcessorCount :: !(Maybe Int) - , verificationEffectiveJobs :: !Int - , verificationJobsOverridden :: !Bool - , verificationMaximumLiveModuleCheckers :: !Int - , verificationMaximumLiveVampireProcesses :: !Int - , verificationMaximumReadyModuleCount :: !Int - , verificationObligationBatchCount :: !Int - , verificationPreparedObligationCount :: !Int - , verificationMaximumObligationBatchSize :: !Int - , verificationPreparedRequestBytes :: !Word64 - , verificationRequestPreparationNanoseconds :: !Word64 - , verificationVampireRunCount :: !Int - , verificationModuleRootHitCount :: !Int - , verificationModuleRootMissCount :: !Int - , verificationFirstVampireStartNanoseconds - :: !(Maybe Word64) - , verificationFinalVampireSubmissionNanoseconds - :: !(Maybe Word64) - , verificationFinalVampireCompletionNanoseconds - :: !(Maybe Word64) - , verificationVampireExecutionNanoseconds :: !Word64 - , verificationLongestVampireExecutionNanoseconds :: !Word64 - } - deriving (Show, Eq) - -data VerificationObservation = VerificationObservation - { observedModuleCount :: !Int - , observedDetectedProcessorCount :: !(Maybe Int) - , observedEffectiveJobs :: !Int - , observedJobsOverridden :: !Bool - , observedLiveModuleCheckers :: !Int - , observedMaximumLiveModuleCheckers :: !Int - , observedMaximumLiveVampireProcesses :: !Int - , observedMaximumReadyModuleCount :: !Int - , observedObligationBatchCount :: !Int - , observedPreparedObligationCount :: !Int - , observedMaximumObligationBatchSize :: !Int - , observedPreparedRequestBytes :: !Word64 - , observedRequestPreparationNanoseconds :: !Word64 - , observedVampireRunCount :: !Int - , observedModuleRootHitCount :: !Int - , observedModuleRootMissCount :: !Int - , observedFirstVampireStart :: !(Maybe Word64) - , observedFinalVampireSubmission :: !(Maybe Word64) - , observedFinalVampireCompletion :: !(Maybe Word64) - , observedVampireExecutionNanoseconds :: !Word64 - , observedLongestVampireExecutionNanoseconds :: !Word64 - } - -initialVerificationObservation :: VerificationObservation -initialVerificationObservation = - VerificationObservation - { observedModuleCount = 0 - , observedDetectedProcessorCount = Nothing - , observedEffectiveJobs = 1 - , observedJobsOverridden = False - , observedLiveModuleCheckers = 0 - , observedMaximumLiveModuleCheckers = 0 - , observedMaximumLiveVampireProcesses = 0 - , observedMaximumReadyModuleCount = 0 - , observedObligationBatchCount = 0 - , observedPreparedObligationCount = 0 - , observedMaximumObligationBatchSize = 0 - , observedPreparedRequestBytes = 0 - , observedRequestPreparationNanoseconds = 0 - , observedVampireRunCount = 0 - , observedModuleRootHitCount = 0 - , observedModuleRootMissCount = 0 - , observedFirstVampireStart = Nothing - , observedFinalVampireSubmission = Nothing - , observedFinalVampireCompletion = Nothing - , observedVampireExecutionNanoseconds = 0 - , observedLongestVampireExecutionNanoseconds = 0 - } - -newtype VerificationRequestObserver = VerificationRequestObserver - { observeVerificationRequest - :: WorkPosition - -> PreparedVerificationRequest - -> IO () - } - -verificationRequestObserver - :: (WorkPosition - -> PreparedVerificationRequest - -> IO ()) - -> VerificationRequestObserver -verificationRequestObserver = - VerificationRequestObserver - -ignoreVerificationRequests :: VerificationRequestObserver -ignoreVerificationRequests = - VerificationRequestObserver \_ordinal _request -> pure () - -data FailedVerification = FailedVerification - { failedVerificationLocation :: !Location - , failedVerificationReason :: !VerificationFailureReason - } - deriving (Show) - -data VerificationFailureReason - = CountermodelFailure !Text - | ContradictoryInputFailure !Text - | IndeterminateFailure !Text - | ProtocolFailure !Text !Text - | TransportFailure !ProverProcessError - deriving (Show) - -verificationFailureReason - :: Either ProverProcessError ProverAnswer - -> Maybe VerificationFailureReason -verificationFailureReason = \case - Left processError -> - Just (TransportFailure processError) - Right Yes -> - Nothing - Right (CounterSatisfiable tptp) -> - Just (CountermodelFailure tptp) - Right (ContradictoryAxioms tptp) -> - Just (ContradictoryInputFailure tptp) - Right (Uncertain tptp) -> - Just (IndeterminateFailure tptp) - Right (Error taskLabel message) -> - Just (ProtocolFailure taskLabel message) - -data VerificationDriverError - = VerificationWorkspaceError - !ParseWorkspaceError - | VerificationFoundationManifestError - !(NonEmpty Foundation.FoundationManifestError) - | VerificationMissingImportedModule - !ResolvedSourceAddress - | VerificationMissingRootModule - !ResolvedSourceAddress - | VerificationFinalPreludeReadinessError - !Typed.FinalPreludeReadinessError - | VerificationTypedInputError - !ResolvedSource - !Typed.TypedModuleInputError - | VerificationTypedOpenError - !ResolvedSource - !Declaration.DriverOpenError - | VerificationTypedCachedModuleError - !ResolvedSource - !Typed.CachedTypedModuleError - | VerificationTypedModuleError - !ResolvedSource - !Typed.TypedModuleFailure - !Declaration.PendingModulePrefix - | VerificationValidationIntegrityError - !ResolvedSource - !Declaration.ValidationIntegrityError - | VerificationAdmittedViewError - !ResolvedSource - !AdmittedViewError - | VerificationParsedArtifactIntegrityError - !ResolvedSource - !Felix.ParsedArtifactIntegrityError - | VerificationStoreFailure !Store.StoreFailure - | VerificationStorePlanningFailure !Store.StorePlanningError - | VerificationStoreLifecycleFailure !Store.StoreLifecycleError - | VerificationModuleArtifactKeyError !Semantic.ModuleArtifactKeyError - | VerificationModuleSchedulerInvariant !Text - deriving (Show) - -instance Exception VerificationDriverError - -data TypedWorkspaceOutcome - = TypedWorkspaceSucceeded - !AdmittedTypedWorkspace - | TypedWorkspaceRejected - !AdmittedTypedWorkspace - !TypedWorkspaceFailure - -data TypedWorkspaceFailure - = TypedWorkspaceCheckingRejected !VerificationDriverError - | TypedWorkspaceProverRejected !FailedVerification - -data ModuleTask = ModuleTask - { moduleTaskOrdinal :: !Natural - , moduleTaskParsed :: !Felix.ParsedModule - , moduleTaskDirectAddresses :: ![ResolvedSourceAddress] - } - -data ModuleCheckResult - = ModuleCheckSucceeded - !ResolvedSourceAddress - !Typed.SealedTypedModule - !AdmittedTypedModule - | ModuleCheckRejected - !AdmittedTypedModule - !TypedWorkspaceFailure - -data ModuleFailureCandidate = ModuleFailureCandidate - !Natural - !AdmittedTypedModule - !TypedWorkspaceFailure - -data AdmittedTypedDeclaration = AdmittedTypedDeclaration - !Semantic.DeclarationSlot - !Typed.TypedSourceDeclaration - -newtype AdmittedTypedModule = AdmittedTypedModule - [AdmittedTypedDeclaration] - -newtype AdmittedTypedWorkspace = AdmittedTypedWorkspace - [AdmittedTypedModule] - -data AdmittedViewError - = AdmittedDeclarationCountMismatch - !Int - !Int - | AdmittedDeclarationSlotMismatch - ![Semantic.DeclarationSlot] - ![Semantic.DeclarationSlot] - deriving (Show, Eq) - -completeAdmittedModule - :: Typed.IdentifiedModuleInput - -> AdmittedTypedModule -completeAdmittedModule input = - AdmittedTypedModule - (uncurry AdmittedTypedDeclaration <$> expectedDeclarations input) - -checkedAdmittedModule - :: Bool - -> Typed.IdentifiedModuleInput - -> Declaration.PendingModulePrefix - -> Either AdmittedViewError AdmittedTypedModule -checkedAdmittedModule requireComplete input prefix = do - let expected = expectedDeclarations input - expectedSlots = fst <$> expected - actualSlots = - Declaration.committedBatchSlot - <$> Declaration.pendingModulePrefixBatches prefix - admittedCount = length actualSlots - if requireComplete - then unless - (admittedCount == length expected) - (Left - (AdmittedDeclarationCountMismatch - (length expected) - admittedCount)) - else unless - (admittedCount <= length expected) - (Left - (AdmittedDeclarationCountMismatch - (length expected) - admittedCount)) - unless - (actualSlots == take admittedCount expectedSlots) - (Left - (AdmittedDeclarationSlotMismatch - (take admittedCount expectedSlots) - actualSlots)) - pure - (AdmittedTypedModule - [ AdmittedTypedDeclaration slot declaration - | (slot, declaration) <- take admittedCount expected - ]) - -expectedDeclarations - :: Typed.IdentifiedModuleInput - -> [(Semantic.DeclarationSlot, Typed.TypedSourceDeclaration)] -expectedDeclarations input = - zipWith - (\ordinal declaration -> - ( Semantic.declarationSlot - (Typed.identifiedModuleOwner input) - (localDeclarationOrdinal ordinal) - , declaration - )) - [0..] - (Typed.typedSourceDeclarations - (Typed.identifiedModuleParsed input)) - -data StoreValidationMode - = FreshStoreValidation - | WarmStoreValidation - deriving (Show, Eq) - -verifyWithObserverAndStoreMode - :: (MonadUnliftIO io, MonadLogger io) - => Store.Store - -> StoreValidationMode - -> VerificationRequestObserver - -> Vampire - -> FilePath - -> io (Either VerificationDriverError VerificationResult) -verifyWithObserverAndStoreMode store validationMode observer prover file = - verifyWithObserverAndStoreModeAndJobs - store validationMode sequentialJobs observer prover file - -verifyWithObserverAndStoreModeAndJobs - :: (MonadUnliftIO io, MonadLogger io) - => Store.Store - -> StoreValidationMode - -> JobsSelection - -> VerificationRequestObserver - -> Vampire - -> FilePath - -> io (Either VerificationDriverError VerificationResult) -verifyWithObserverAndStoreModeAndJobs - store validationMode jobs observer prover file = - fmap (fmap fst) - (verifyMeasuredWithObserverAndStoreModeAndJobs - store validationMode jobs observer prover file) - -verifyMeasuredWithObserverAndStoreMode - :: (MonadUnliftIO io, MonadLogger io) - => Store.Store - -> StoreValidationMode - -> VerificationRequestObserver - -> Vampire - -> FilePath - -> io - (Either - VerificationDriverError - (VerificationResult, VerificationMeasurements)) -verifyMeasuredWithObserverAndStoreMode - store validationMode observer prover file = - verifyMeasuredWithObserverAndStoreModeAndJobs - store validationMode sequentialJobs observer prover file - -verifyMeasuredWithObserverAndStoreModeAndJobs - :: (MonadUnliftIO io, MonadLogger io) - => Store.Store - -> StoreValidationMode - -> JobsSelection - -> VerificationRequestObserver - -> Vampire - -> FilePath - -> io - (Either - VerificationDriverError - (VerificationResult, VerificationMeasurements)) -verifyMeasuredWithObserverAndStoreModeAndJobs - store validationMode jobs observer prover file = - try - (verifyMeasuredThrowingWithStore - store validationMode jobs observer prover file) - -sequentialJobs :: JobsSelection -sequentialJobs = - JobsSelection - { jobsSelectionDetectedProcessors = Nothing - , jobsSelectionEffectiveJobs = - fromMaybe - (impossible "one is not a positive worker count") - (effectiveJobs 1) - , jobsSelectionWasOverridden = True - } - -verifyMeasured - :: (MonadUnliftIO io, MonadLogger io) - => Vampire - -> FilePath - -> io - (Either - VerificationDriverError - (VerificationResult, VerificationMeasurements)) -verifyMeasured prover file = - verifyMeasuredWithObserver - ignoreVerificationRequests - prover - file - -verifyMeasuredWithObserver - :: (MonadUnliftIO io, MonadLogger io) - => VerificationRequestObserver - -> Vampire - -> FilePath - -> io - (Either - VerificationDriverError - (VerificationResult, VerificationMeasurements)) -verifyMeasuredWithObserver observer prover file = - try (verifyMeasuredThrowing observer prover file) - -verifyMeasuredThrowing - :: (MonadUnliftIO io, MonadLogger io) - => VerificationRequestObserver - -> Vampire - -> FilePath - -> io (VerificationResult, VerificationMeasurements) -verifyMeasuredThrowing requestObserver prover file = do - foundation <- - either - (throwIO . VerificationFoundationManifestError) - pure - Foundation.checkedFoundation - planned <- liftIO (Store.planStore Store.FreshTemporaryStore) - plan <- either - (throwIO . VerificationStorePlanningFailure) - pure - planned - withRunInIO \runInIO -> - Store.withStoreLease plan \lease -> do - opened <- Store.withOpenStore - lease - (Identity.theoryId foundation) - (\_startup store -> - runInIO - (verifyMeasuredThrowingWithStore - store - FreshStoreValidation - sequentialJobs - requestObserver - prover - file)) - either - (throwIO . VerificationStoreLifecycleFailure) - pure - opened - -verifyMeasuredThrowingWithStore - :: (MonadUnliftIO io, MonadLogger io) - => Store.Store - -> StoreValidationMode - -> JobsSelection - -> VerificationRequestObserver - -> Vampire - -> FilePath - -> io (VerificationResult, VerificationMeasurements) -verifyMeasuredThrowingWithStore - store validationMode jobsSelection requestObserver prover file = do - invocationStart <- liftIO getMonotonicTimeNSec - memo <- liftIO (Store.newStoreMemo store) - storeCoordinator <- liftIO Store.newStoreCoordinator - ( admittedResult - , parseMeasurements - , sourcePreparation - , checkingStart - , checkingEnd - , observation - , parsedPresentation - ) <- - liftIO - (withVampireExecutor - (jobsSelectionEffectiveJobs jobsSelection) - prover - (observeVerificationRequest requestObserver) - \executor -> do - observationRef <- newIORef - initialVerificationObservation - { observedDetectedProcessorCount = - jobsSelectionDetectedProcessors jobsSelection - , observedEffectiveJobs = - effectiveJobsValue - (jobsSelectionEffectiveJobs jobsSelection) - , observedJobsOverridden = - jobsSelectionWasOverridden jobsSelection - } - foundation <- - either - (throwIO - . VerificationFoundationManifestError) - pure - Foundation.checkedFoundation - preparationStart <- getMonotonicTimeNSec - prepared <- - prepareDefaultSourceRequest file - >>= either - (throwIO . VerificationWorkspaceError) - pure - let (mounts, request) = prepared - preparationEnd <- getMonotonicTimeNSec - prelude <- withVampireRequestOwner executor \owner -> do - preludeResolver <- - typedVampireResolver - owner - 0 - observationRef - Typed.acquireFinalPreludeSession - memo store foundation preludeResolver - >>= either - (throwIO - . VerificationFinalPreludeReadinessError) - pure - observeModuleRootAcquisition observationRef - (Typed.finalPreludeAcquisition prelude) - let preludeSyntax = - Typed.sealedTypedModuleSyntax - (Typed.finalPreludeModule prelude) - syntaxInputs _source = [preludeSyntax] - (parsed, measured) <- - Felix.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation - store - mounts - request - syntaxInputs - (Prelude.rejectOrdinaryPreludeSourceGraph - (Typed.finalPreludeSource prelude)) - >>= either throwParseExecutionError pure - checkingStart <- getMonotonicTimeNSec - outcome <- - checkTypedWorkspace - memo - storeCoordinator - foundation - prelude - executor - (jobsSelectionEffectiveJobs jobsSelection) - validationMode - observationRef - parsed - store - checkingEnd <- getMonotonicTimeNSec - executorObserved <- vampireExecutorObservation executor - mergeExecutorObservation observationRef executorObserved - observed <- readIORef observationRef - pure - ( outcome - , measured - , preparationEnd - preparationStart - , checkingStart - , checkingEnd - , observed - , parsed - )) - let result = - case admittedResult of - TypedWorkspaceRejected admitted failure -> - let report = admittedWorkspaceReport admitted - in case failure of - TypedWorkspaceCheckingRejected checkingFailure -> - VerificationCheckingFailure - report checkingFailure - TypedWorkspaceProverRejected proverFailure -> - VerificationFailure report proverFailure - TypedWorkspaceSucceeded admitted -> - completedResult - (admittedWorkspaceReport admitted) - (VerificationPresentation - (HtmlExport.htmlPresentationFromParsedWorkspace - parsedPresentation)) - measurements = - finalizeVerificationMeasurements - invocationStart - checkingStart - checkingEnd - parseMeasurements - sourcePreparation - observation - logInfoN - (renderVerificationMeasurements measurements) - pure (result, measurements) - where - throwParseExecutionError = \case - Felix.ParseExecutionWorkspaceError failure -> - throwIO (VerificationWorkspaceError failure) - Felix.ParseExecutionStoreFailure failure -> - throwIO (VerificationStoreFailure failure) - Felix.ParseExecutionArtifactIntegrityFailure source failure -> - throwIO - (VerificationParsedArtifactIntegrityError source failure) - -checkTypedWorkspace - :: Store.StoreMemo - -> Store.StoreCoordinator - -> Foundation.CheckedFoundation - -> Typed.FinalPreludeSession - -> VampireExecutor - -> EffectiveJobs - -> StoreValidationMode - -> IORef VerificationObservation - -> ParsedSourceWorkspace - -> Store.Store - -> IO TypedWorkspaceOutcome -checkTypedWorkspace - memo - storeCoordinator - foundation - prelude - executor - selectedJobs - validationMode - observationRef - workspace - store = do - let modules = - zipWith - makeTask - [1..] - (toList - (Felix.parsedWorkspaceImportedBeforeImporter workspace)) - rootAddress = - Felix.parsedModuleAddress - (Felix.parsedWorkspaceRootModule workspace) - atomicModifyIORef' observationRef - (\observation -> - ( observation - { observedModuleCount = length modules - } - , () - )) - scheduleModules - rootAddress - modules - Map.empty - Map.empty - Map.empty - Nothing - where - workerBound = effectiveJobsValue selectedJobs - - makeTask ordinal parsed = - ModuleTask - { moduleTaskOrdinal = ordinal - , moduleTaskParsed = parsed - , moduleTaskDirectAddresses = - nubOrd - (Felix.parsedImportedAddress - <$> Felix.parsedModuleImports parsed) - } - - scheduleModules - rootAddress - pending - running - sealedByAddress - admittedByOrdinal - candidate = do - let readyCount = - length - [ () - | task <- pending - , taskMayStart candidate sealedByAddress task - ] - observeReadyModules observationRef readyCount - (pending', running') <- - startReadyModules - pending - running - sealedByAddress - candidate - Exception.onException - (if Map.null running' - then case candidate of - Just selected - | any - (\task -> - moduleTaskOrdinal task - < candidateOrdinal selected) - pending' -> - throwIO - (VerificationModuleSchedulerInvariant - "an earlier module is not terminal") - | otherwise -> - pure - (TypedWorkspaceRejected - (admittedWorkspaceThrough - admittedByOrdinal - selected) - (candidateFailure selected)) - Nothing - | null pending' -> do - unless - (Map.member rootAddress sealedByAddress) - (throwIO - (VerificationMissingRootModule - rootAddress)) - pure - (TypedWorkspaceSucceeded - (completeAdmittedWorkspace - admittedByOrdinal)) - | otherwise -> - throwIO - (VerificationModuleSchedulerInvariant - "no ready module and no running module") - else do - (_completedAsync, (ordinal, completed)) <- - Async.waitAny (Map.elems running') - let runningWithoutCompleted = - Map.delete ordinal running' - case completed of - Left fatal -> do - cancelModuleCheckers runningWithoutCompleted - Exception.throwIO fatal - Right (ModuleCheckSucceeded - address sealed admittedModule) -> - scheduleModules - rootAddress - pending' - runningWithoutCompleted - (Map.insert address sealed sealedByAddress) - (Map.insert - ordinal - admittedModule - admittedByOrdinal) - candidate - Right (ModuleCheckRejected - admittedModule failure) -> do - let selected = - chooseEarlierFailure - candidate - (ModuleFailureCandidate - ordinal - admittedModule - failure) - cutoff = candidateOrdinal selected - (later, retained) = - Map.partitionWithKey - (\runningOrdinal _async -> - runningOrdinal > cutoff) - runningWithoutCompleted - cancelModuleCheckers later - scheduleModules - rootAddress - pending' - retained - sealedByAddress - admittedByOrdinal - (Just selected) - ) - (cancelModuleCheckers running') - - startReadyModules - pending - running - sealedByAddress - candidate - | Map.size running >= workerBound = - pure (pending, running) - | otherwise = - case extractFirstReady candidate sealedByAddress pending of - Nothing -> - pure (pending, running) - Just (task, remaining) -> do - checker <- Async.async do - completed <- - (Exception.try - (observeModuleChecker observationRef - (checkModule task sealedByAddress)) - :: IO - (Either - SomeException - ModuleCheckResult)) - pure (moduleTaskOrdinal task, completed) - startReadyModules - remaining - (Map.insert - (moduleTaskOrdinal task) - checker - running) - sealedByAddress - candidate - - checkModule task sealedByAddress = - withVampireRequestOwner executor \requestOwner -> do - let parsed = moduleTaskParsed task - source = Felix.parsedModuleResolved parsed - address = Felix.parsedModuleAddress parsed - direct <- - traverse - (\directAddress -> - maybe - (throwIO - (VerificationMissingImportedModule - directAddress)) - pure - (Map.lookup directAddress sealedByAddress)) - (moduleTaskDirectAddresses task) - resolver <- - typedVampireResolver - requestOwner - (moduleTaskOrdinal task) - observationRef - input <- - either - (throwIO . VerificationTypedInputError source) - pure - (Typed.typedModuleInput - foundation - (Typed.finalPreludeReadiness prelude) - resolver - validationRun - parsed - direct) - loadCachedModule parsed direct >>= \case - Just sealed -> do - observeModuleRootAcquisition - observationRef Typed.ModuleRootHit - pure - (ModuleCheckSucceeded - address - sealed - (completeAdmittedModule - (Typed.identifiedPhysicalModule parsed))) - Nothing -> do - typedResult <- - Exception.catch - (Typed.runTypedModule input) - (\failure -> - throwIO - (VerificationValidationIntegrityError - source - failure)) - case typedResult of - Typed.TypedModuleOpenFailed err -> - throwIO (VerificationTypedOpenError source err) - Typed.TypedModuleFailed err prefix -> do - let driverFailure = - VerificationTypedModuleError - source err prefix - case classifyTypedModuleFailure err of - TypedIntegrityFailure -> - throwIO driverFailure - TypedCheckingRejection -> - reportFailure - parsed - prefix - (TypedWorkspaceCheckingRejected - driverFailure) - TypedVerificationRejection failed -> - reportFailure - parsed - prefix - (TypedWorkspaceProverRejected failed) - TypedProverFailure failed -> - reportFailure - parsed - prefix - (TypedWorkspaceProverRejected failed) - Typed.TypedModuleSucceeded sealed -> do - admittedModule <- - either - (throwIO - . VerificationAdmittedViewError source) - pure - (checkedAdmittedModule - True - (Typed.identifiedPhysicalModule parsed) - (Typed.sealedTypedModulePrefix sealed)) - persistSealed - (Typed.identifiedPhysicalModule parsed) - sealed - observeModuleRootAcquisition - observationRef Typed.ModuleRootMiss - pure - (ModuleCheckSucceeded - address sealed admittedModule) - - reportFailure parsed prefix failure = do - let source = Felix.parsedModuleResolved parsed - admittedModule <- - either - (throwIO . VerificationAdmittedViewError source) - pure - (checkedAdmittedModule - False - (Typed.identifiedPhysicalModule parsed) - prefix) - Store.withStoreCoordinator storeCoordinator - (Store.writePendingModulePrefix store prefix) - >>= either - (throwIO . VerificationStoreFailure) - pure - pure (ModuleCheckRejected admittedModule failure) - - storeValidationLookup lookupStore = - Declaration.validationLookup - (\key -> - Store.withStoreCoordinator storeCoordinator - (Store.loadProofValidation lookupStore key) - >>= either - (throwIO . VerificationStoreFailure) - pure) - (\key -> - Store.withStoreCoordinator storeCoordinator - (Store.loadDeclarationValidation lookupStore key) - >>= either - (throwIO . VerificationStoreFailure) - pure) - - validationRun = - case validationMode of - FreshStoreValidation -> - Declaration.FreshValidation - WarmStoreValidation -> - Declaration.WarmValidation - (storeValidationLookup store) - - persistSealed input sealed = do - artifactKey <- - either - (throwIO . VerificationModuleArtifactKeyError) - pure - (Semantic.moduleArtifactKey - (Typed.identifiedModuleOwner input) - (Felix.identifiedParsedModuleId - (Typed.identifiedModuleParsed input)) - (Semantic.semanticInterfaceDirectInputs - (Typed.sealedTypedModuleSemantic sealed)) - (Identity.theoryId foundation)) - let artifact = - Semantic.moduleArtifactResult - artifactKey - (Syntax.moduleSyntaxAssertedId - (Typed.sealedTypedModuleSyntax sealed)) - (Semantic.semanticInterfaceAssertedId - (Typed.sealedTypedModuleSemantic sealed)) - acknowledged <- - Store.withStoreCoordinator storeCoordinator - (Store.writeSealedModule - store - (Typed.sealedTypedModulePrefix sealed) - [Typed.sealedTypedModuleSyntax sealed] - [Typed.sealedTypedModuleSemantic sealed] - artifact) - >>= either - (throwIO . VerificationStoreFailure) - pure - unless - (acknowledged == artifact) - (throwIO - (VerificationStoreFailure - Store.StoreModuleArtifactIdMismatch)) - - loadCachedModule parsed direct = - case validationMode of - WarmStoreValidation -> do - let owner = - Typed.identifiedModuleOwner - (Typed.identifiedPhysicalModule parsed) - directSemantic = - Semantic.semanticInterfaceAssertedId - (Typed.sealedTypedModuleSemantic - (Typed.finalPreludeModule prelude)) - : ( Semantic.semanticInterfaceAssertedId - . Typed.sealedTypedModuleSemantic - <$> direct - ) - artifactKey <- - either - (throwIO . VerificationModuleArtifactKeyError) - pure - (Semantic.moduleArtifactKey - owner - (Felix.identifiedParsedModuleId - (Typed.identifiedModuleParsed - (Typed.identifiedPhysicalModule parsed))) - directSemantic - (Identity.theoryId foundation)) - loaded <- - Store.withStoreCoordinator storeCoordinator - (Store.loadCachedModuleInstallation - memo - store - artifactKey - (Syntax.moduleSyntaxAssertedId - (Felix.parsedModuleSyntaxInterface parsed))) - case loaded of - Left failure -> - throwIO (VerificationStoreFailure failure) - Right Nothing -> - pure Nothing - Right (Just installation) -> - either - (throwIO - . VerificationTypedCachedModuleError - (Felix.parsedModuleResolved parsed)) - (pure . Just) - (Typed.cachedSealedTypedModule - foundation - (Typed.finalPreludeModule prelude : direct) - installation) - FreshStoreValidation -> - pure Nothing - - taskMayStart candidate sealedByAddress task = - maybe True - (moduleTaskOrdinal task <) - (candidateOrdinal <$> candidate) - && all - (`Map.member` sealedByAddress) - (moduleTaskDirectAddresses task) - - extractFirstReady candidate sealedByAddress = go [] - where - go _before [] = Nothing - go before (task : after) - | taskMayStart candidate sealedByAddress task = - Just (task, reverse before <> after) - | otherwise = - go (task : before) after - - chooseEarlierFailure Nothing incoming = incoming - chooseEarlierFailure (Just current) incoming - | candidateOrdinal incoming < candidateOrdinal current = incoming - | otherwise = current - - candidateOrdinal (ModuleFailureCandidate ordinal _admitted _failure) = - ordinal - - candidateFailure (ModuleFailureCandidate _ordinal _admitted failure) = - failure - - candidateAdmitted (ModuleFailureCandidate _ordinal admitted _failure) = - admitted - - completeAdmittedWorkspace admittedByOrdinal = - AdmittedTypedWorkspace - ( completeAdmittedModule (Typed.finalPreludeInput prelude) - : fmap snd (Map.toAscList admittedByOrdinal) - ) - - admittedWorkspaceThrough admittedByOrdinal selected = - let cutoff = candidateOrdinal selected - earlier = Map.filterWithKey - (\ordinal _admitted -> ordinal < cutoff) - admittedByOrdinal - in AdmittedTypedWorkspace - ( completeAdmittedModule (Typed.finalPreludeInput prelude) - : ( fmap snd (Map.toAscList earlier) - <> [candidateAdmitted selected] - ) - ) - - cancelModuleCheckers running = do - traverse_ Async.cancel (Map.elems running) - traverse_ Async.waitCatch (Map.elems running) - -data TypedFailureClassification - = TypedCheckingRejection - | TypedVerificationRejection !FailedVerification - | TypedProverFailure !FailedVerification - | TypedIntegrityFailure - --- | Classify failures at the typed checking boundary conservatively. --- --- Only source elaboration and recognized prover outcomes may retain an --- admitted source report. Every declaration/sealing invariant, including a --- future constructor not explicitly recognized below, remains fatal. -classifyTypedModuleFailure - :: Typed.TypedModuleFailure - -> TypedFailureClassification -classifyTypedModuleFailure = \case - Typed.TypedActionFailed{} -> - TypedCheckingRejection - Typed.TypedDeclarationFailed - (Declaration.ProofObligationFailedAt - location - (Declaration.VampireProcessFailed processError)) -> - classifyTypedProverResult location (Left processError) - Typed.TypedDeclarationFailed - (Declaration.ProofObligationFailedAt - location - (Declaration.VampireObligationRejected answer)) -> - classifyTypedProverResult location (Right answer) - _failure -> - TypedIntegrityFailure - -classifyTypedProverResult - :: Location - -> Either ProverProcessError ProverAnswer - -> TypedFailureClassification -classifyTypedProverResult location result = - case verificationFailureReason result of - Nothing -> - TypedIntegrityFailure - Just reason -> - let failed = FailedVerification location reason - in case reason of - CountermodelFailure{} -> - TypedVerificationRejection failed - ContradictoryInputFailure{} -> - TypedVerificationRejection failed - IndeterminateFailure{} -> - TypedProverFailure failed - ProtocolFailure{} -> - TypedProverFailure failed - TransportFailure{} -> - TypedProverFailure failed - -typedVampireResolver - :: VampireRequestOwner - -> Natural - -> IORef VerificationObservation - -> IO Declaration.VampireResolver -typedVampireResolver - requestOwner moduleOrdinal observationRef = do - localOrdinalRef <- newIORef 1 - let reserve requests = do - let batchSize = NonEmpty.length requests - ordinalCount = fromIntegral batchSize - firstOrdinal <- atomicModifyIORef' localOrdinalRef - (\current -> (current + ordinalCount, current)) - let positions = - NonEmpty.fromList - [ workPosition moduleOrdinal ordinal - | ordinal <- - [firstOrdinal .. firstOrdinal + ordinalCount - 1] - ] - preparedBytes = - foldl' - (\total request -> - total - + fromIntegral - (preparedVerificationByteCount request)) - 0 - requests - atomicModifyIORef' observationRef \observation -> - ( observation - { observedObligationBatchCount = - observedObligationBatchCount observation + 1 - , observedPreparedObligationCount = - observedPreparedObligationCount observation + batchSize - , observedMaximumObligationBatchSize = - max batchSize - (observedMaximumObligationBatchSize observation) - , observedPreparedRequestBytes = - observedPreparedRequestBytes observation - + preparedBytes - } - , () - ) - pure positions - submit requests = do - positions <- reserve requests - traverse - (uncurry (submitVampireRequest requestOwner)) - (NonEmpty.zip positions requests) - observe elapsed = - atomicModifyIORef' observationRef \observation -> - ( observation - { observedRequestPreparationNanoseconds = - observedRequestPreparationNanoseconds observation - + elapsed - } - , () - ) - pure (Declaration.vampireSubmissionResolver submit observe) - -observeModuleRootAcquisition - :: IORef VerificationObservation - -> Typed.ModuleRootAcquisition - -> IO () -observeModuleRootAcquisition observationRef acquisition = - atomicModifyIORef' observationRef \observation -> - ( case acquisition of - Typed.ModuleRootHit -> - observation - { observedModuleRootHitCount = - observedModuleRootHitCount observation + 1 - } - Typed.ModuleRootMiss -> - observation - { observedModuleRootMissCount = - observedModuleRootMissCount observation + 1 - } - , () - ) - -observeReadyModules - :: IORef VerificationObservation - -> Int - -> IO () -observeReadyModules observationRef readyCount = - atomicModifyIORef' observationRef \observation -> - ( observation - { observedMaximumReadyModuleCount = - max readyCount - (observedMaximumReadyModuleCount observation) - } - , () - ) - -observeModuleChecker - :: IORef VerificationObservation - -> IO value - -> IO value -observeModuleChecker observationRef action = do - atomicModifyIORef' observationRef \observation -> - let live = observedLiveModuleCheckers observation + 1 - in - ( observation - { observedLiveModuleCheckers = live - , observedMaximumLiveModuleCheckers = - max live - (observedMaximumLiveModuleCheckers observation) - } - , () - ) - action `Exception.finally` - atomicModifyIORef' observationRef - (\observation -> - ( observation - { observedLiveModuleCheckers = - observedLiveModuleCheckers observation - 1 - } - , () - )) - -mergeExecutorObservation - :: IORef VerificationObservation - -> VampireExecutorObservation - -> IO () -mergeExecutorObservation observationRef executorObserved = - atomicModifyIORef' observationRef \observation -> - ( observation - { observedVampireRunCount = - vampireExecutorRunCount executorObserved - , observedMaximumLiveVampireProcesses = - vampireExecutorMaximumLiveCount executorObserved - , observedFirstVampireStart = - vampireExecutorFirstStartNanoseconds executorObserved - , observedFinalVampireSubmission = - vampireExecutorFinalSubmissionNanoseconds executorObserved - , observedFinalVampireCompletion = - vampireExecutorFinalCompletionNanoseconds executorObserved - , observedVampireExecutionNanoseconds = - vampireExecutorExecutionNanoseconds executorObserved - , observedLongestVampireExecutionNanoseconds = - vampireExecutorLongestExecutionNanoseconds executorObserved - } - , () - ) - -finalizeVerificationMeasurements - :: Word64 - -> Word64 - -> Word64 - -> Felix.ParseMeasurements - -> Word64 - -> VerificationObservation - -> VerificationMeasurements -finalizeVerificationMeasurements - invocationStart - checkingStart - checkingEnd - parseMeasurements - sourcePreparation - observation = - VerificationMeasurements - { verificationParseMeasurements = - parseMeasurements - , verificationSourcePreparationNanoseconds = - sourcePreparation - , verificationInvocationNanoseconds = - checkingEnd - invocationStart - , verificationCheckingNanoseconds = - checkingEnd - checkingStart - , verificationModuleCount = - observedModuleCount observation - , verificationDetectedProcessorCount = - observedDetectedProcessorCount observation - , verificationEffectiveJobs = - observedEffectiveJobs observation - , verificationJobsOverridden = - observedJobsOverridden observation - , verificationMaximumLiveModuleCheckers = - observedMaximumLiveModuleCheckers observation - , verificationMaximumLiveVampireProcesses = - observedMaximumLiveVampireProcesses observation - , verificationMaximumReadyModuleCount = - observedMaximumReadyModuleCount observation - , verificationObligationBatchCount = - observedObligationBatchCount observation - , verificationPreparedObligationCount = - observedPreparedObligationCount observation - , verificationMaximumObligationBatchSize = - observedMaximumObligationBatchSize observation - , verificationPreparedRequestBytes = - observedPreparedRequestBytes observation - , verificationRequestPreparationNanoseconds = - observedRequestPreparationNanoseconds observation - , verificationVampireRunCount = - observedVampireRunCount observation - , verificationModuleRootHitCount = - observedModuleRootHitCount observation - , verificationModuleRootMissCount = - observedModuleRootMissCount observation - , verificationFirstVampireStartNanoseconds = - fmap - (\started -> started - invocationStart) - (observedFirstVampireStart observation) - , verificationFinalVampireSubmissionNanoseconds = - fmap - (\submitted -> submitted - invocationStart) - (observedFinalVampireSubmission observation) - , verificationFinalVampireCompletionNanoseconds = - fmap - (\completed -> completed - invocationStart) - (observedFinalVampireCompletion observation) - , verificationVampireExecutionNanoseconds = - observedVampireExecutionNanoseconds observation - , verificationLongestVampireExecutionNanoseconds = - observedLongestVampireExecutionNanoseconds observation - } - -renderVerificationMeasurements - :: VerificationMeasurements - -> Text -renderVerificationMeasurements measurements = - StrictText.unwords - [ "M0" - , "source_setup_ms=" - <> renderNanoseconds - (verificationSourcePreparationNanoseconds - measurements) - , "resolution_ms=" - <> renderNanoseconds - (Felix.parseMeasurementResolutionNanoseconds - parseMeasurements) - , "candidate_probes=" <> renderIntegral - (Felix.parseMeasurementCandidateProbeCount - parseMeasurements) - , "canonicalizations=" <> renderIntegral - (Felix.parseMeasurementCanonicalizationCount - parseMeasurements) - , "target_inspections=" <> renderIntegral - (Felix.parseMeasurementTargetInspectionCount - parseMeasurements) - , "tokenization_ms=" - <> renderNanoseconds - (Felix.parseMeasurementTokenizationNanoseconds - parseMeasurements) - , "scanning_ms=" - <> renderNanoseconds - (Felix.parseMeasurementScanningNanoseconds - parseMeasurements) - , "syntax_interface_ms=" - <> renderNanoseconds - (Felix.parseMeasurementSyntaxInterfaceNanoseconds - parseMeasurements) - , "parsing_ms=" - <> renderNanoseconds - (Felix.parseMeasurementParsingNanoseconds - parseMeasurements) - , "parsed_hits=" <> renderIntegral - (Felix.parseMeasurementParsedHitCount parseMeasurements) - , "parsed_misses=" <> renderIntegral - (Felix.parseMeasurementParsedMissCount parseMeasurements) - , "parser_tables=" <> renderIntegral - (Felix.parseMeasurementParserTableMaterializationCount - parseMeasurements) - , "modules=" <> renderIntegral - (verificationModuleCount measurements) - , "detected_processors=" - <> maybe - "unavailable" - renderIntegral - (verificationDetectedProcessorCount measurements) - , "effective_jobs=" <> renderIntegral - (verificationEffectiveJobs measurements) - , "jobs_overridden=" - <> if verificationJobsOverridden measurements - then "yes" - else "no" - , "max_module_checkers=" <> renderIntegral - (verificationMaximumLiveModuleCheckers measurements) - , "max_vampire_processes=" <> renderIntegral - (verificationMaximumLiveVampireProcesses measurements) - , "files_read=" <> renderIntegral - (Felix.parseMeasurementModuleCount - parseMeasurements) - , "import_occurrences=" <> renderIntegral - (Felix.parseMeasurementImportOccurrenceCount - parseMeasurements) - , "chunks=" <> renderIntegral - (Felix.parseMeasurementChunkCount - parseMeasurements) - , "source_bytes=" <> renderIntegral - (Felix.parseMeasurementSourceByteCount - parseMeasurements) - , "checking_ms=" - <> renderNanoseconds - (verificationCheckingNanoseconds - measurements) - , "batches=" <> renderIntegral - (verificationObligationBatchCount measurements) - , "obligations=" <> renderIntegral - (verificationPreparedObligationCount measurements) - , "max_batch=" <> renderIntegral - (verificationMaximumObligationBatchSize - measurements) - , "prepared_bytes=" <> renderIntegral - (verificationPreparedRequestBytes measurements) - , "request_preparation_ms=" - <> renderNanoseconds - (verificationRequestPreparationNanoseconds measurements) - , "vampire_runs=" <> renderIntegral - (verificationVampireRunCount measurements) - , "module_root_hits=" <> renderIntegral - (verificationModuleRootHitCount measurements) - , "module_root_misses=" <> renderIntegral - (verificationModuleRootMissCount measurements) - , "first_vampire_ms=" - <> maybe - "none" - renderNanoseconds - (verificationFirstVampireStartNanoseconds - measurements) - , "vampire_ms=" - <> renderNanoseconds - (verificationVampireExecutionNanoseconds - measurements) - , "final_submission_ms=" - <> maybe - "none" - renderNanoseconds - (verificationFinalVampireSubmissionNanoseconds - measurements) - , "final_completion_ms=" - <> maybe - "none" - renderNanoseconds - (verificationFinalVampireCompletionNanoseconds - measurements) - , "vampire_span_ms=" - <> maybe - "none" - renderNanoseconds - (vampireExecutionSpan measurements) - , "longest_vampire_ms=" - <> renderNanoseconds - (verificationLongestVampireExecutionNanoseconds - measurements) - , "max_ready_modules=" <> renderIntegral - (verificationMaximumReadyModuleCount - measurements) - , "total_ms=" - <> renderNanoseconds - (verificationInvocationNanoseconds - measurements) - ] - where - parseMeasurements = - verificationParseMeasurements measurements - - vampireExecutionSpan measured = do - started <- verificationFirstVampireStartNanoseconds measured - completed <- verificationFinalVampireCompletionNanoseconds measured - pure (completed - started) - -renderNanoseconds :: Word64 -> Text -renderNanoseconds nanoseconds = - renderIntegral (nanoseconds `div` 1000000) - -renderIntegral :: Show number => number -> Text -renderIntegral = - StrictText.pack . show - -admittedWorkspaceReport - :: AdmittedTypedWorkspace - -> VerificationReport -admittedWorkspaceReport (AdmittedTypedWorkspace modules) = - VerificationReport - { verificationDirectEscapes = - concatMap admittedModuleEscapes modules - } - -admittedModuleEscapes - :: AdmittedTypedModule - -> [ReportedEscape] -admittedModuleEscapes (AdmittedTypedModule declarations) = - concatMap admittedDeclarationEscapes declarations - -admittedDeclarationEscapes - :: AdmittedTypedDeclaration - -> [ReportedEscape] -admittedDeclarationEscapes - (AdmittedTypedDeclaration _slot declaration) = - axiomEscape <> proofEscapes - where - axiomEscape = - case Typed.typedSourceDeclarationHead declaration of - Raw.BlockAxiom location _title _marker _axiom -> - [ReportedEscape ReportedSourceAxiom location] - _ -> - [] - proofEscapes = - maybe [] omittedProofEscapes - (Typed.typedSourceDeclarationProof declaration) - -omittedProofEscapes :: Raw.Proof -> [ReportedEscape] -omittedProofEscapes = \case - Raw.Omitted location -> - [ReportedEscape ReportedOmitted location] - Raw.Qed{} -> - [] - Raw.Contradiction{} -> - [] - Raw.ByCase _location cases -> - concatMap (omittedProofEscapes . Raw.caseProof) cases - Raw.ByContradiction _location proof -> - omittedProofEscapes proof - Raw.BySetInduction _location _term proof -> - omittedProofEscapes proof - Raw.ByOrdInduction _location proof -> - omittedProofEscapes proof - Raw.Assume _location _statement proof -> - omittedProofEscapes proof - Raw.FixSymbolic _location _variables _bound proof -> - omittedProofEscapes proof - Raw.FixSuchThat _location _variables _statement proof -> - omittedProofEscapes proof - Raw.Calc _location _quantifier _calculation proof -> - omittedProofEscapes proof - Raw.TakeVar _location _variables _bound _statement _justification proof -> - omittedProofEscapes proof - Raw.TakeNoun _location _noun _justification proof -> - omittedProofEscapes proof - Raw.Have _location _condition _statement _justification proof -> - omittedProofEscapes proof - Raw.Suffices _location _statement _justification proof -> - omittedProofEscapes proof - Raw.Subclaim _location _statement subproof continuation -> - omittedProofEscapes subproof <> omittedProofEscapes continuation - Raw.Define _location _variable _expression proof -> - omittedProofEscapes proof - Raw.DefineFunction - _location _function _argument _value _domainVariable _domain - proof -> - omittedProofEscapes proof - Raw.DefineFunctionLocal - _location _function _argument _domain _target _ruleVariable - _rules proof -> - omittedProofEscapes proof - -completedResult - :: VerificationReport - -> VerificationPresentation - -> VerificationResult -completedResult report presentation - | any ((== ReportedOmitted) . reportedEscapeKind) - (verificationDirectEscapes report) = - CompletedWithExplicitGaps report presentation - | otherwise = - VerificationCompleted report presentation - -verify - :: (MonadUnliftIO io, MonadLogger io) - => Vampire - -> FilePath - -> io (Either VerificationDriverError VerificationResult) -verify prover file = - fmap fst <$> verifyMeasured prover file - -prepareVerifiedHtmlExportResult - :: MonadIO io - => VerificationPresentation - -> io (Either HtmlExport.HtmlExportError [PreparedHtmlArtifact]) -prepareVerifiedHtmlExportResult - (VerificationPresentation workspace) = liftIO do - hintsResult <- findAndReadRendererFile "lexicon.tsv" - pure do - hints <- hintsResult - HtmlExport.prepareHtmlExport - defaultHtmlMountPrefixes - workspace - hints - -defaultHtmlMountPrefixes :: [(SourceMountId, [Text])] -defaultHtmlMountPrefixes = - [ (sourceMountId "project", []) - , (sourceMountId "library", ["library"]) - , (sourceMountId "debug", ["debug"]) - ] diff --git a/source/Checking/Exact/Proof.hs b/source/Checking/Exact/Proof.hs deleted file mode 100644 index 40911b0..0000000 --- a/source/Checking/Exact/Proof.hs +++ /dev/null @@ -1,1359 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Exact lowering for the first ordinary theorem/proof fragment. --- --- This module is the trusted owner of structural local-proof composition. Its --- private prepared tree controls when assumptions and proved local claims --- become available and executes discharges depth-first. The declaration --- boundary validates typed tasks and authority; it does not reconstruct this --- derivation. -module Checking.Exact.Proof - ( PreparedExactProof - , preparedExactProofSyntaxId - , preparedExactProofFirstOmission - , prepareExactProof - , CheckedExactProofAuthorization - , lowerPreparedExactProof - , authorizeCheckedExactProof - , PreparedFinalPreludeFoundationClaim - , prepareFinalPreludeFoundationClaim - , CheckedFinalPreludeFoundationAuthorization - , lowerPreparedFinalPreludeFoundationClaim - , authorizeCheckedFinalPreludeFoundationClaim - , ExactProofError(..) - , exactProofErrorLocation - , renderExactProofError - ) where - -import Base -import Checking.Authority qualified as Authority -import Checking.Backend.Problem qualified as Backend -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Foundation -import Checking.Identity -import Checking.Kernel.Derivation (foundationFactDerivation) -import Checking.Semantic -import Felix.Cache.Codec -import Report.Location -import Syntax.Abstract qualified as Raw - -import Control.Monad.Except (ExceptT) -import Control.Monad.Except qualified as Except -import Control.Monad (foldM, unless, when) -import Control.Monad.State.Strict (StateT) -import Control.Monad.State.Strict qualified as State -import Data.ByteString (ByteString) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Vector (Vector) -import Numeric.Natural (Natural) - - -data ExactProofError - = ExactProofUnsupportedClaim !Location - | ExactProofUnsupportedStep !Location - | ExactProofBoundedFixNotSupported !Location - | ExactProofBoundedTakeNotSupported !Location - | ExactProofSetInductionVariableRequired !Location - | ExactProofSetInductionVariableNotActive - !Location !Raw.VarSymbol - | ExactProofSetInductionNotOutermost !Location - | ExactProofSetInductionGoalMismatch !Location - | ExactProofSetExtensionalityGoalMismatch !Location - | ExactProofSetExtensionalityDirectionsUnavailable !Location - | ExactProofExpectedUniversalGoal !Location - | ExactProofExpectedImplicationGoal !Location - | ExactProofGoalStatementMismatch !Location - | ExactProofContradictionGoalMismatch !Location - | ExactProofLocalFunctionBinderMismatch !Location - | ExactProofLocalFunctionNameConflict !Location - | ExactProofUnknownReference !Location !Raw.Marker - | ExactProofElaborationFailed !Exact.ExactCompileError - | ExactProofObligationPreparationFailed - !Location - !(Declaration.VampireObligationPreparationError - Exact.ExactLocalId) - | ExactProofFoundationLeafRequiresImplicitAuto !Location - | ExactProofFoundationLeafTargetMismatch !Location - | ExactProofFoundationLeafTargetAmbiguous !Location - deriving stock (Show, Eq) - -exactProofErrorLocation :: ExactProofError -> Location -exactProofErrorLocation = \case - ExactProofUnsupportedClaim location -> location - ExactProofUnsupportedStep location -> location - ExactProofBoundedFixNotSupported location -> location - ExactProofBoundedTakeNotSupported location -> location - ExactProofSetInductionVariableRequired location -> location - ExactProofSetInductionVariableNotActive location _variable -> - location - ExactProofSetInductionNotOutermost location -> location - ExactProofSetInductionGoalMismatch location -> location - ExactProofSetExtensionalityGoalMismatch location -> location - ExactProofSetExtensionalityDirectionsUnavailable location -> location - ExactProofExpectedUniversalGoal location -> location - ExactProofExpectedImplicationGoal location -> location - ExactProofGoalStatementMismatch location -> location - ExactProofContradictionGoalMismatch location -> location - ExactProofLocalFunctionBinderMismatch location -> location - ExactProofLocalFunctionNameConflict location -> location - ExactProofUnknownReference location _marker -> location - ExactProofElaborationFailed failure -> - Exact.exactCompileErrorLocation failure - ExactProofObligationPreparationFailed location _failure -> location - ExactProofFoundationLeafRequiresImplicitAuto location -> location - ExactProofFoundationLeafTargetMismatch location -> location - ExactProofFoundationLeafTargetAmbiguous location -> location - -renderExactProofError :: ExactProofError -> Text -renderExactProofError = \case - ExactProofUnsupportedClaim location -> - at location <> "this claim is not yet supported by the typed checker" - ExactProofUnsupportedStep location -> - at location <> "this proof step is not yet supported by the typed checker" - ExactProofBoundedFixNotSupported location -> - at location <> "bounded proof binders are not yet supported" - ExactProofBoundedTakeNotSupported location -> - at location <> "bounded proof witnesses are not yet supported" - ExactProofSetInductionVariableRequired location -> - at location <> "exact set induction requires a named set variable" - ExactProofSetInductionVariableNotActive location variable -> - at location <> "the set-induction variable " <> shown variable - <> " is not an active exact binder" - ExactProofSetInductionNotOutermost location -> - at location <> "set induction must currently be outermost" - ExactProofSetInductionGoalMismatch location -> - at location <> "the set-induction variable does not belong to this goal" - ExactProofSetExtensionalityGoalMismatch location -> - at location <> "set extensionality requires a set-equality goal" - ExactProofSetExtensionalityDirectionsUnavailable location -> - at location - <> "set extensionality requires both directions as proved local claims" - ExactProofExpectedUniversalGoal location -> - at location <> "this fix step requires a universal goal" - ExactProofExpectedImplicationGoal location -> - at location <> "this assume step requires an implication goal" - ExactProofGoalStatementMismatch location -> - at location <> "the proof step does not match the current goal" - ExactProofContradictionGoalMismatch location -> - at location <> "contradiction requires falsum as the current goal" - ExactProofLocalFunctionBinderMismatch location -> - at location <> "the function argument must match its domain binder" - ExactProofLocalFunctionNameConflict location -> - at location <> "the function and argument names must be distinct" - ExactProofUnknownReference location marker -> - at location <> "the cited fact " <> shown marker <> " is not visible" - ExactProofElaborationFailed failure -> - Exact.renderExactCompileError failure - ExactProofObligationPreparationFailed location failure -> - at location <> "the exact proof obligation is invalid: " <> shown failure - ExactProofFoundationLeafRequiresImplicitAuto location -> - at location - <> "a confined foundation claim requires an implicit Auto proof" - ExactProofFoundationLeafTargetMismatch location -> - at location <> "the claim does not exactly match a foundation axiom" - ExactProofFoundationLeafTargetAmbiguous location -> - at location <> "the claim matches more than one foundation axiom" - where - at location = locationToText location <> ": " - shown :: Show value => value -> Text - shown = Text.pack . show - -data ExactLocalOrigin - = ExactAssumption - | ExactDerivedClaim - | ExactLocalDefinition - deriving stock (Show, Eq, Ord) - -data PreparedLocal = PreparedLocal - !Backend.LocalPremiseOrdinal - !ExactLocalOrigin - !(Vector (Exact.ExactLocalId, CoreType)) - !(ScopedCheckedCore ObjectId) - -data PreparedJustification - = PreparedAuto - | PreparedReferences - !(NonEmpty SemanticFactOccurrenceFingerprint) - | PreparedLocalOnly - -data PreparedDischarge - = PreparedVampireDischarge - !Location - !PreparedJustification - !(ScopedCheckedCore ObjectId) - !(Declaration.PreparedVampireObligation - Exact.ExactLocalId - ExactLocalOrigin) - | PreparedSetExtensionality - !Location - !(ScopedCheckedCore ObjectId) - -data PreparedProof - = PreparedImplicitAuto !PreparedDischarge - | PreparedQed !PreparedDischarge - | PreparedOmitted - !Location - !(ScopedCheckedCore ObjectId) - | PreparedFix ![Exact.ExactLocalId] !PreparedProof - | PreparedAssume - !(ScopedCheckedCore ObjectId) - !PreparedProof - | PreparedTake - ![Exact.ExactLocalId] - !(ScopedCheckedCore ObjectId) - !PreparedDischarge - !PreparedProof - | PreparedSetInduction - !(ScopedCheckedCore ObjectId) - !PreparedDischarge - | PreparedHave - !(ScopedCheckedCore ObjectId) - !PreparedDischarge - !PreparedProof - | PreparedSubclaim - !(ScopedCheckedCore ObjectId) - !PreparedProof - !PreparedProof - | PreparedDefine - !Exact.ExactLocalId - !(ScopedCheckedCore ObjectId) - !(ScopedCheckedCore ObjectId) - !PreparedProof - | PreparedDefineFunction - !Exact.ExactLocalId - !(ScopedCheckedCore ObjectId) - !(ScopedCheckedCore ObjectId) - !PreparedProof - | PreparedContradiction !PreparedDischarge - -data PreparedExactProof = PreparedExactProof - !Location - !SemanticName - !(ScopedCheckedCore ObjectId) - !PreparedProof - !ProofSyntaxId - -data PreparedFinalPreludeFoundationClaim = - PreparedFinalPreludeFoundationClaim - !Location - !SemanticName - !(ScopedCheckedCore ObjectId) - !FoundationAxiomTag - !ProofSyntaxId - -preparedExactProofSyntaxId :: PreparedExactProof -> ProofSyntaxId -preparedExactProofSyntaxId - (PreparedExactProof _location _alias _target _proof syntax) = - syntax - -preparedExactProofFirstOmission :: PreparedExactProof -> Maybe Location -preparedExactProofFirstOmission - (PreparedExactProof _location _alias _target proof _syntax) = - preparedProofFirstOmission proof - -data PrepareState = PrepareState - { prepareNextLocal :: !Natural - , prepareNextPremise :: !Natural - } - -type Prepare = - StateT - PrepareState - (ExceptT ExactProofError (Declaration.LoweringDriver)) - -prepareExactProof - :: Raw.Block - -> Maybe Raw.Proof - -> Declaration.LoweringDriver - (Either ExactProofError PreparedExactProof) -prepareExactProof block explicitProof = - Except.runExceptT - (State.evalStateT prepare initialState) - where - initialState = PrepareState 0 0 - - prepare = - case block of - Raw.BlockClaim - _kind location _title (Raw.Marker marker) - (Raw.Claim assumptions statement) -> do - envelope <- - liftDriver - (Exact.prepareExactClaimEnvelope assumptions statement) - >>= either - (throwProof . ExactProofElaborationFailed) - pure - let targetCore = Exact.preparedExactClaimTarget envelope - unless (null (scopedCoreContext targetCore)) - (throwProof - (ExactProofUnsupportedClaim location)) - (context, openedGoal, identities) <- - openEnvelopeVariables - targetCore - (Exact.preparedExactClaimVariables envelope) - (Exact.preparedExactClaimContext envelope) - (locals, bodyGoal, antecedents) <- - openEnvelopeAntecedents - context - openedGoal - (Exact.preparedExactClaimAntecedentCount envelope) - bodyProof <- - case explicitProof of - Nothing -> - PreparedImplicitAuto - <$> prepareDischargeWith - DirectDischarge - [] - Nothing - location - context - locals - bodyGoal - Raw.JustificationEmpty - Just sourceProof -> - prepareProof - location - context - locals - (Just antecedents) - bodyGoal - sourceProof - let withAssumptions = - foldr PreparedAssume bodyProof antecedents - proof = - case identities of - [] -> withAssumptions - _ -> PreparedFix identities withAssumptions - pure - (PreparedExactProof - location - (semanticName marker) - targetCore - proof - (proofSyntaxId - (encodePreparedProof proof))) - _ -> - throwProof - (ExactProofUnsupportedClaim (locate block)) - -prepareFinalPreludeFoundationClaim - :: CheckedFoundation - -> Raw.Block - -> Maybe Raw.Proof - -> Declaration.LoweringDriver - (Either ExactProofError PreparedFinalPreludeFoundationClaim) -prepareFinalPreludeFoundationClaim foundation block explicitProof = - Except.runExceptT do - case (block, explicitProof) of - ( Raw.BlockClaim - _kind location _title (Raw.Marker marker) - (Raw.Claim assumptions statement) - , Nothing - ) -> do - envelope <- - Except.lift - (Exact.prepareExactClaimEnvelope - assumptions - statement) - >>= either - (Except.throwError - . ExactProofElaborationFailed) - pure - unless - ( null (Exact.preparedExactClaimVariables envelope) - && Exact.preparedExactClaimAntecedentCount envelope - == 0 - ) - (Except.throwError - (ExactProofFoundationLeafRequiresImplicitAuto - location)) - let target = Exact.preparedExactClaimTarget envelope - matches = - [ tag - | tag <- [minBound .. maxBound] - , target == foundationTarget tag - ] - tag <- case matches of - [] -> - Except.throwError - (ExactProofFoundationLeafTargetMismatch location) - [only] -> - pure only - _ -> - Except.throwError - (ExactProofFoundationLeafTargetAmbiguous location) - pure - (PreparedFinalPreludeFoundationClaim - location - (semanticName marker) - target - tag - (implicitAutoProofSyntaxId target)) - (Raw.BlockClaim _kind location _title _marker _claim, Just{}) -> - Except.throwError - (ExactProofFoundationLeafRequiresImplicitAuto location) - _ -> - Except.throwError - (ExactProofUnsupportedClaim (locate block)) - where - foundationTarget tag = - embedClosedCore [] - (mapFrozenGlobals - absurd - (foundationAxiomFrozen foundation tag)) - -openEnvelopeVariables - :: ScopedCheckedCore ObjectId - -> [Raw.VarSymbol] - -> Exact.ExactBinderContext - -> Prepare - ( Exact.ExactBinderContext - , ScopedCheckedCore ObjectId - , [Exact.ExactLocalId] - ) -openEnvelopeVariables target variables preparedContext = - case NonEmpty.nonEmpty variables of - Nothing -> - pure (preparedContext, target, []) - Just nonempty -> do - (_unannotated, opened, identities) <- - openFixedVariables - Exact.emptyExactBinderContext - target - nonempty - let expected = - reverse - (fst <$> toList - (Exact.exactBinderContextSupport preparedContext)) - unless - (identities == expected) - (impossible - "prepared claim annotations do not match opened binders") - pure (preparedContext, opened, identities) - -openEnvelopeAntecedents - :: Exact.ExactBinderContext - -> ScopedCheckedCore ObjectId - -> Natural - -> Prepare - ( [PreparedLocal] - , ScopedCheckedCore ObjectId - , [ScopedCheckedCore ObjectId] - ) -openEnvelopeAntecedents context initialGoal initialCount = - go [] [] initialGoal initialCount - where - go locals antecedents goal 0 = - pure (locals, goal, antecedents) - go locals antecedents goal remaining = do - (antecedent, conclusion) <- - maybe - (impossible - "a prepared claim envelope has too few implications") - pure - (openScopedImplication goal) - local <- allocateLocal ExactAssumption context antecedent - go - (locals <> [local]) - (antecedents <> [antecedent]) - conclusion - (remaining - 1) - -prepareProof - :: Location - -> Exact.ExactBinderContext - -> [PreparedLocal] - -- Only the initial proof carries set-induction antecedents. - -> Maybe [ScopedCheckedCore ObjectId] - -> ScopedCheckedCore ObjectId - -> Raw.Proof - -> Prepare PreparedProof -prepareProof fallback context locals inductionAntecedents goal = \case - Raw.Omitted location -> - pure (PreparedOmitted location goal) - Raw.Qed maybeLocation justification -> - PreparedQed - <$> prepareDischarge - (fromMaybe fallback maybeLocation) - context - locals - goal - justification - Raw.FixSymbolic location variables bound continuation -> do - unless (bound == Raw.Unbounded) - (throwProof - (ExactProofBoundedFixNotSupported location)) - (context', goal', identities) <- - openFixedVariables context goal variables - PreparedFix identities - <$> prepareProof - fallback - context' - locals - Nothing - goal' - continuation - Raw.Assume location statement continuation -> do - (antecedent, conclusion) <- - maybe - (throwProof - (ExactProofExpectedImplicationGoal location)) - pure - (openScopedImplication goal) - supplied <- prepareStatement context statement - unless - (Exact.preparedExactPropositionCore supplied - == antecedent) - (throwProof - (ExactProofGoalStatementMismatch location)) - local <- allocateLocal ExactAssumption context antecedent - PreparedAssume antecedent - <$> prepareProof - fallback - context - (locals <> [local]) - Nothing - conclusion - continuation - Raw.TakeVar location variables bound statement justification continuation -> do - unless (bound == Raw.Unbounded) - (throwProof - (ExactProofBoundedTakeNotSupported location)) - identities <- - traverse (const allocateLocalIdentity) variables - context' <- - either - (throwProof . ExactProofElaborationFailed) - pure - (Exact.extendExactBinderContext - (NonEmpty.zip identities variables) - context) - witness <- - Exact.preparedExactPropositionCore - <$> prepareStatement context' statement - let witnessCount = length (toList variables) - existence = closeTakenWitnesses witnessCount witness - goal' = weakenForTakenWitnesses witnessCount goal - discharge <- - prepareDischarge - location context locals existence justification - local <- allocateLocal ExactAssumption context' witness - PreparedTake (toList identities) witness discharge - <$> prepareProof - fallback - context' - (locals <> [local]) - Nothing - goal' - continuation - Raw.BySetInduction location variable continuation -> - case (inductionAntecedents, continuation) of - (Nothing, _proof) -> - throwProof - (ExactProofSetInductionNotOutermost location) - (Just antecedents, Raw.Qed maybeLocation justification) -> do - sourceVariable <- - case variable of - Just (Raw.TermExpr (Raw.ExprVar candidate)) -> - pure candidate - _ -> - throwProof - (ExactProofSetInductionVariableRequired - location) - selected <- - maybe - (throwProof - (ExactProofSetInductionVariableNotActive - location - sourceVariable)) - pure - (Exact.exactBinderContextIndex - sourceVariable context) - let property = - foldr implyChecked goal antecedents - hypothesis <- - maybe - (throwProof - (ExactProofSetInductionGoalMismatch - location)) - pure - (scopedSetInductionHypothesis selected property) - local <- allocateLocal ExactAssumption context hypothesis - PreparedSetInduction hypothesis - <$> prepareDischarge - (fromMaybe location maybeLocation) - context - (locals <> [local]) - goal - justification - (Just _antecedents, _proof) -> - throwProof (ExactProofUnsupportedStep location) - Raw.Have location since statement justification continuation -> do - when (isJust since) - (throwProof (ExactProofUnsupportedStep location)) - claim <- - Exact.preparedExactPropositionCore - <$> prepareStatement context statement - discharge <- - prepareDischarge - location context locals claim justification - local <- allocateLocal ExactDerivedClaim context claim - PreparedHave claim discharge - <$> prepareProof - fallback - context - (locals <> [local]) - Nothing - goal - continuation - Raw.Subclaim location statement subproof continuation -> do - claim <- - Exact.preparedExactPropositionCore - <$> prepareStatement context statement - preparedSubproof <- - prepareProof - location - context - locals - Nothing - claim - subproof - local <- allocateLocal ExactDerivedClaim context claim - PreparedSubclaim claim preparedSubproof - <$> prepareProof - fallback - context - (locals <> [local]) - Nothing - goal - continuation - Raw.Define _location variable expression continuation -> do - body <- - Exact.preparedExactSetExpressionCore - <$> ( liftDriver - (Exact.prepareExactSetExpression - context expression) - >>= either - (throwProof . ExactProofElaborationFailed) - pure - ) - identity <- allocateLocalIdentity - context' <- - either - (throwProof . ExactProofElaborationFailed) - pure - (Exact.extendExactBinderContext - ((identity, variable) :| []) - context) - separationCharacteristic <- - liftDriver - (Declaration.currentFoundationAxiomLowering - SeparationCharacteristic) - definition <- - maybe - (impossible - "an exact set expression did not form a local definition") - pure - (scopedSetDefinition separationCharacteristic body) - local <- - allocateLocal ExactLocalDefinition context' definition - PreparedDefine identity body definition - <$> prepareProof - fallback - context' - (locals <> [local]) - Nothing - (weakenCheckedScopedCore TySet goal) - continuation - Raw.DefineFunction - location function argument value bound domain continuation -> do - unless (argument == bound) - (throwProof - (ExactProofLocalFunctionBinderMismatch (locate bound))) - when (function == argument) - (throwProof - (ExactProofLocalFunctionNameConflict (locate function))) - argumentIdentity <- allocateLocalIdentity - argumentContext <- - either - (throwProof . ExactProofElaborationFailed) - pure - (Exact.extendExactBinderContext - ((argumentIdentity, argument) :| []) - context) - graph <- - liftDriver - (Exact.prepareExactLocalFunctionGraph - location context argumentContext domain value) - >>= either - (throwProof . ExactProofElaborationFailed) - pure - functionIdentity <- allocateLocalIdentity - functionContext <- - either - (throwProof . ExactProofElaborationFailed) - pure - (Exact.extendExactBinderContext - ((functionIdentity, function) :| []) - context) - replacementCharacteristic <- - liftDriver - (Declaration.currentFoundationAxiomLowering - ReplacementCharacteristic) - definition <- - maybe - (impossible - "a checked replacement graph did not form a local definition") - pure - (scopedCharacteristicDefinition - replacementCharacteristic - (Exact.preparedExactLocalFunctionGraphCore graph) - ( Exact.preparedExactLocalFunctionGraphDomain graph - :| [Exact.preparedExactLocalFunctionGraphMap graph] - )) - local <- - allocateLocal ExactLocalDefinition functionContext definition - PreparedDefineFunction - functionIdentity - (Exact.preparedExactLocalFunctionGraphCore graph) - definition - <$> prepareProof - fallback - functionContext - (locals <> [local]) - Nothing - (weakenCheckedScopedCore TySet goal) - continuation - Raw.Contradiction location justification -> do - unless - ( scopedCoreType goal == TyProp - && scopedCoreTerm goal == CFalsum - ) - (throwProof - (ExactProofContradictionGoalMismatch location)) - PreparedContradiction - <$> prepareDischargeWith - IndirectContradictionDischarge - [] - Nothing - location - context - locals - goal - justification - proof -> - throwProof - (ExactProofUnsupportedStep - (proofLocation fallback proof)) - where - implyChecked antecedent conclusion = - fromMaybe - (impossible "an exact claim antecedent changed context") - (implyScopedCore antecedent conclusion) - --- The discharged existential and the opened witness premise are the same --- checked proposition viewed on opposite sides of existential elimination. -closeTakenWitnesses - :: Int - -> ScopedCheckedCore ObjectId - -> ScopedCheckedCore ObjectId -closeTakenWitnesses binderCount = go binderCount - where - go 0 proposition = proposition - go remaining proposition = - go (remaining - 1) - (fromMaybe - (impossible "a taken witness has no checked binder") - (closeScopedExists proposition)) - -weakenForTakenWitnesses - :: Int - -> ScopedCheckedCore ObjectId - -> ScopedCheckedCore ObjectId -weakenForTakenWitnesses binderCount = go binderCount - where - go 0 proposition = proposition - go remaining proposition = - go (remaining - 1) - (weakenCheckedScopedCore TySet proposition) - -openFixedVariables - :: Exact.ExactBinderContext - -> ScopedCheckedCore ObjectId - -> NonEmpty Raw.VarSymbol - -> Prepare - ( Exact.ExactBinderContext - , ScopedCheckedCore ObjectId - , [Exact.ExactLocalId] - ) -openFixedVariables initialContext initialGoal variables = - foldM openOne - (initialContext, initialGoal, []) - (toList variables) - where - openOne (context, goal, identities) variable = do - (binderType, body) <- - maybe - (throwProof - (ExactProofExpectedUniversalGoal - (locate variable))) - pure - (openScopedForall goal) - unless (binderType == TySet) - (throwProof - (ExactProofExpectedUniversalGoal - (locate variable))) - identity <- allocateLocalIdentity - context' <- - either - (throwProof . ExactProofElaborationFailed) - pure - (Exact.extendExactBinderContext - ((identity, variable) :| []) - context) - pure (context', body, identities <> [identity]) - -allocateLocalIdentity :: Prepare Exact.ExactLocalId -allocateLocalIdentity = do - state <- State.get - State.put - state - { prepareNextLocal = prepareNextLocal state + 1 - } - pure (Exact.exactLocalId (prepareNextLocal state)) - -allocateLocal - :: ExactLocalOrigin - -> Exact.ExactBinderContext - -> ScopedCheckedCore ObjectId - -> Prepare PreparedLocal -allocateLocal origin context proposition = do - state <- State.get - State.put - state - { prepareNextPremise = prepareNextPremise state + 1 - } - pure - (PreparedLocal - (Backend.localPremiseOrdinal - (prepareNextPremise state)) - origin - (Exact.exactBinderContextSupport context) - proposition) - -prepareDischarge - :: Location - -> Exact.ExactBinderContext - -> [PreparedLocal] - -> ScopedCheckedCore ObjectId - -> Raw.Justification - -> Prepare PreparedDischarge -prepareDischarge location context locals goal justification = - prepareDischargeWith - DirectDischarge - [] Nothing location context locals goal justification - -data DischargeMode - = DirectDischarge - | IndirectContradictionDischarge - -prepareDischargeWith - :: DischargeMode - -> [FoundationAxiomTag] - -> Maybe Declaration.VampirePremiseSelection - -> Location - -> Exact.ExactBinderContext - -> [PreparedLocal] - -> ScopedCheckedCore ObjectId - -> Raw.Justification - -> Prepare PreparedDischarge -prepareDischargeWith - dischargeMode auxiliaries selectionOverride - location context locals goal justification = - case justification of - Raw.JustificationSetExt -> do - (leftToRight, rightToLeft) <- - maybe - (throwProof - (ExactProofSetExtensionalityGoalMismatch location)) - pure - (splitScopedSetEquality goal) - unless - ( hasDerivedLocal leftToRight - && hasDerivedLocal rightToLeft - ) - (throwProof - (ExactProofSetExtensionalityDirectionsUnavailable - location)) - pure (PreparedSetExtensionality location goal) - _ -> do - preparedJustification <- - prepareJustification location justification - prepared <- - liftDriver - (prepareObligation - (Exact.exactBinderContextSupport context) - goal - (toScopedPremise <$> locals) - auxiliaries - (fromMaybe - (vampirePremiseSelection preparedJustification) - selectionOverride)) - >>= either - (throwProof - . ExactProofObligationPreparationFailed location) - pure - pure - (PreparedVampireDischarge - location - preparedJustification - goal - prepared) - where - prepareObligation = - case dischargeMode of - DirectDischarge -> - Declaration.prepareScopedVampireObligationLowering - IndirectContradictionDischarge -> - Declaration.prepareScopedContradictionObligationLowering - - hasDerivedLocal proposition = - any - (\case - PreparedLocal - _ordinal ExactDerivedClaim _support local -> - local == proposition - PreparedLocal{} -> - False) - locals - - toScopedPremise - (PreparedLocal ordinal origin support proposition) = - Declaration.scopedVampirePremise - ordinal origin support proposition - -prepareJustification - :: Location - -> Raw.Justification - -> Prepare PreparedJustification -prepareJustification _location Raw.JustificationEmpty = - pure PreparedAuto -prepareJustification location (Raw.JustificationRef markers) = do - resolved <- traverse (resolveReference location) (toList markers) - let unique = stableUnique resolved - case unique of - [] -> - impossible "a nonempty citation list resolved to no facts" - first : rest -> - pure (PreparedReferences (first :| rest)) -prepareJustification _location Raw.JustificationLocal = - pure PreparedLocalOnly -prepareJustification location Raw.JustificationSetExt = - throwProof (ExactProofUnsupportedStep location) - -vampirePremiseSelection - :: PreparedJustification - -> Declaration.VampirePremiseSelection -vampirePremiseSelection = \case - PreparedAuto -> - Declaration.VampireImplicitPremises - PreparedReferences fingerprints -> - Declaration.VampireExplicitPremises fingerprints - PreparedLocalOnly -> - Declaration.VampireLocalPremises - -resolveReference - :: Location - -> Raw.Marker - -> Prepare SemanticFactOccurrenceFingerprint -resolveReference location marker@(Raw.Marker name) = do - resolved <- - liftDriver - (Declaration.resolveVisibleFactAliasLowering - (semanticName name)) - maybe - (throwProof - (ExactProofUnknownReference location marker)) - pure - resolved - -prepareStatement - :: Exact.ExactBinderContext - -> Raw.Stmt - -> Prepare Exact.PreparedExactProposition -prepareStatement context statement = - liftDriver - (Exact.prepareExactProposition context statement) - >>= either - (throwProof . ExactProofElaborationFailed) - pure - -data CheckedExactProofAuthorization = CheckedExactProofAuthorization - !PreparedProof - !Bool - -lowerPreparedExactProof - :: PreparedExactProof - -> Declaration.LoweringDriver - (Either - Declaration.DeclarationError - (Declaration.CheckedDeclaration CheckedExactProofAuthorization)) -lowerPreparedExactProof - (PreparedExactProof _location alias target proof syntax) = - fmap checked - <$> Declaration.prepareCandidateSpecLowering - [] target SearchEligible [alias] - where - checked spec = - Declaration.checkedProofDeclaration - syntax [] [] [] [] - [Declaration.checkedCandidate spec planning :| []] - (CheckedExactProofAuthorization - proof - (isJust (preparedProofFirstOmission proof))) - where - requests = plannedProofRequests proof - planning - | isJust (preparedProofFirstOmission proof) = - Declaration.checkedOmittedPlanning requests [] - | otherwise = - Declaration.checkedSourceProofPlanning requests [] - -authorizeCheckedExactProof - :: CheckedExactProofAuthorization - -> [NonEmpty Declaration.ReservedCandidate] - -> Declaration.Declaration () -authorizeCheckedExactProof - (CheckedExactProofAuthorization proof hasOmission) = \case - [candidate :| []] - | hasOmission -> - Declaration.authorizeOmittedCandidate - candidate - (executePreparedProof proof) - | otherwise -> - Declaration.authorizeVampireCandidate - candidate - (executePreparedProof proof) - stages -> - Declaration.failDeclaration - (Declaration.CheckedAuthorizationCandidateShapeMismatch - 1 (length stages)) - -data CheckedFinalPreludeFoundationAuthorization = - CheckedFinalPreludeFoundationAuthorization !FoundationAxiomTag - -lowerPreparedFinalPreludeFoundationClaim - :: PreparedFinalPreludeFoundationClaim - -> Declaration.LoweringDriver - (Either - Declaration.DeclarationError - (Declaration.CheckedDeclaration - CheckedFinalPreludeFoundationAuthorization)) -lowerPreparedFinalPreludeFoundationClaim - (PreparedFinalPreludeFoundationClaim - _location alias target tag syntax) = - fmap checked - <$> Declaration.prepareCandidateSpecLowering - [] target SearchEligible [alias] - where - checked spec = - Declaration.checkedProofDeclaration - syntax [] [] [] [] - [ Declaration.checkedCandidate spec - (Declaration.checkedKernelPlanning - (Authority.FoundationLeaf tag) []) - :| [] - ] - (CheckedFinalPreludeFoundationAuthorization tag) - -authorizeCheckedFinalPreludeFoundationClaim - :: CheckedFinalPreludeFoundationAuthorization - -> [NonEmpty Declaration.ReservedCandidate] - -> Declaration.Declaration () -authorizeCheckedFinalPreludeFoundationClaim - (CheckedFinalPreludeFoundationAuthorization tag) = \case - [candidate :| []] -> - Declaration.authorizeKernelConstructionCandidate - (Authority.FoundationLeaf tag) - candidate - (pure (foundationFactDerivation tag)) - stages -> - Declaration.failDeclaration - (Declaration.CheckedAuthorizationCandidateShapeMismatch - 1 (length stages)) - -preparedProofFirstOmission :: PreparedProof -> Maybe Location -preparedProofFirstOmission = \case - PreparedImplicitAuto{} -> Nothing - PreparedQed{} -> Nothing - PreparedOmitted location _goal -> Just location - PreparedFix _identities continuation -> - preparedProofFirstOmission continuation - PreparedAssume _antecedent continuation -> - preparedProofFirstOmission continuation - PreparedTake _identities _witness _discharge continuation -> - preparedProofFirstOmission continuation - PreparedSetInduction _hypothesis _discharge -> Nothing - PreparedHave _claim _discharge continuation -> - preparedProofFirstOmission continuation - PreparedSubclaim _claim subproof continuation -> - preparedProofFirstOmission subproof - <|> preparedProofFirstOmission continuation - PreparedDefine _identity _body _definition continuation -> - preparedProofFirstOmission continuation - PreparedDefineFunction _identity _graph _definition continuation -> - preparedProofFirstOmission continuation - PreparedContradiction{} -> Nothing - -plannedProofRequests - :: PreparedProof - -> [Declaration.CheckedPlannedVampireRequest] -plannedProofRequests = \case - PreparedImplicitAuto discharge -> plannedDischargeRequests discharge - PreparedQed discharge -> plannedDischargeRequests discharge - PreparedOmitted{} -> [] - PreparedFix _identities continuation -> - plannedProofRequests continuation - PreparedAssume _antecedent continuation -> - plannedProofRequests continuation - PreparedTake _identities _witness discharge continuation -> - plannedDischargeRequests discharge <> plannedProofRequests continuation - PreparedSetInduction _hypothesis discharge -> - plannedDischargeRequests discharge - PreparedHave _claim discharge continuation -> - plannedDischargeRequests discharge <> plannedProofRequests continuation - PreparedSubclaim _claim subproof continuation -> - plannedProofRequests subproof <> plannedProofRequests continuation - PreparedDefine _identity _body _definition continuation -> - plannedProofRequests continuation - PreparedDefineFunction _identity _graph _definition continuation -> - plannedProofRequests continuation - PreparedContradiction discharge -> - plannedDischargeRequests discharge - -plannedDischargeRequests - :: PreparedDischarge - -> [Declaration.CheckedPlannedVampireRequest] -plannedDischargeRequests = \case - PreparedVampireDischarge location _justification _goal obligation -> - [Declaration.checkedPlannedVampireRequest location obligation] - PreparedSetExtensionality{} -> [] - -executePreparedProof - :: PreparedProof - -> Declaration.CandidateProof () -executePreparedProof = \case - PreparedImplicitAuto discharge -> - executeDischarge discharge - PreparedQed discharge -> - executeDischarge discharge - PreparedOmitted _location _goal -> - Declaration.recordOmittedUse - PreparedFix _identities continuation -> - executePreparedProof continuation - PreparedAssume _antecedent continuation -> - executePreparedProof continuation - PreparedTake _identities _witness discharge continuation -> do - executeDischarge discharge - executePreparedProof continuation - PreparedSetInduction _hypothesis discharge -> - executeDischarge discharge - PreparedHave _claim discharge continuation -> do - executeDischarge discharge - executePreparedProof continuation - PreparedSubclaim _claim subproof continuation -> do - executePreparedProof subproof - executePreparedProof continuation - PreparedDefine _identity _body _definition continuation -> - executePreparedProof continuation - PreparedDefineFunction _identity _graph _definition continuation -> - executePreparedProof continuation - PreparedContradiction discharge -> - executeDischarge discharge - -executeDischarge - :: PreparedDischarge - -> Declaration.CandidateProof () -executeDischarge - (PreparedVampireDischarge - location _justification _goal obligation) = - Declaration.locateProofObligation location - (Declaration.acceptPreparedVampireObligation obligation) -executeDischarge PreparedSetExtensionality{} = - pure () - -encodePreparedProof :: PreparedProof -> ByteString -encodePreparedProof = - encodeCache . putPreparedProof - -putPreparedProof :: PreparedProof -> CachePut -putPreparedProof = \case - PreparedImplicitAuto discharge -> do - putCacheTag 0x00 - putPreparedDischarge discharge - PreparedQed discharge -> do - putCacheTag 0x01 - putPreparedDischarge discharge - PreparedOmitted _location goal -> do - putCacheTag 0x06 - putScopedProposition goal - PreparedFix identities continuation -> do - putCacheTag 0x02 - putCacheList - (putCacheNatural . Exact.exactLocalIdValue) - identities - putPreparedProof continuation - PreparedAssume antecedent continuation -> do - putCacheTag 0x03 - putScopedProposition antecedent - putPreparedProof continuation - PreparedTake identities witness discharge continuation -> do - putCacheTag 0x08 - putCacheList - (putCacheNatural . Exact.exactLocalIdValue) - identities - putScopedProposition witness - putPreparedDischarge discharge - putPreparedProof continuation - PreparedSetInduction hypothesis discharge -> do - putCacheTag 0x07 - putScopedProposition hypothesis - putPreparedDischarge discharge - PreparedHave claim discharge continuation -> do - putCacheTag 0x04 - putScopedProposition claim - putPreparedDischarge discharge - putPreparedProof continuation - PreparedSubclaim claim subproof continuation -> do - putCacheTag 0x05 - putScopedProposition claim - putPreparedProof subproof - putPreparedProof continuation - PreparedDefine identity body definition continuation -> do - putCacheTag 0x09 - putCacheNatural (Exact.exactLocalIdValue identity) - putScopedTerm body - putScopedProposition definition - putPreparedProof continuation - PreparedContradiction discharge -> do - putCacheTag 0x0a - putPreparedDischarge discharge - PreparedDefineFunction identity graph definition continuation -> do - putCacheTag 0x0b - putCacheNatural (Exact.exactLocalIdValue identity) - putScopedTerm graph - putScopedProposition definition - putPreparedProof continuation - -putPreparedDischarge :: PreparedDischarge -> CachePut -putPreparedDischarge - (PreparedVampireDischarge - _location justification goal _obligation) = do - putPreparedDischargeSyntax justification goal -putPreparedDischarge - (PreparedSetExtensionality _location goal) = do - putCacheTag 0x03 - putScopedProposition goal - -putPreparedDischargeSyntax - :: PreparedJustification - -> ScopedCheckedCore ObjectId - -> CachePut -putPreparedDischargeSyntax justification goal = do - putPreparedJustification justification - putScopedProposition goal - -implicitAutoProofSyntaxId - :: ScopedCheckedCore ObjectId - -> ProofSyntaxId -implicitAutoProofSyntaxId goal = - proofSyntaxId - (encodeCache do - putCacheTag 0x00 - putPreparedDischargeSyntax PreparedAuto goal) - -putPreparedJustification :: PreparedJustification -> CachePut -putPreparedJustification = \case - PreparedAuto -> - putCacheTag 0x00 - PreparedReferences fingerprints -> do - putCacheTag 0x01 - putCacheList - putSemanticFactOccurrenceFingerprintCache - (toList fingerprints) - PreparedLocalOnly -> - putCacheTag 0x02 - -putScopedProposition - :: ScopedCheckedCore ObjectId - -> CachePut -putScopedProposition proposition = do - putCacheList putCoreTypeCache - (scopedCoreContext proposition) - putCanonicalTermCache putObjectIdCache - (scopedCoreTerm proposition) - -putScopedTerm - :: ScopedCheckedCore ObjectId - -> CachePut -putScopedTerm term = do - putCacheList putCoreTypeCache - (scopedCoreContext term) - putCoreTypeCache (scopedCoreType term) - putCanonicalTermCache putObjectIdCache - (scopedCoreTerm term) - -proofLocation :: Location -> Raw.Proof -> Location -proofLocation fallback = \case - Raw.Omitted location -> location - Raw.Qed maybeLocation _justification -> - fromMaybe fallback maybeLocation - Raw.Contradiction location _justification -> location - Raw.ByCase location _cases -> location - Raw.ByContradiction location _proof -> location - Raw.BySetInduction location _term _proof -> location - Raw.ByOrdInduction location _proof -> location - Raw.Assume location _statement _proof -> location - Raw.FixSymbolic location _variables _bound _proof -> location - Raw.FixSuchThat location _variables _statement _proof -> location - Raw.Calc location _quantifier _calculation _proof -> location - Raw.TakeVar location _variables _bound _statement _justification _proof -> - location - Raw.TakeNoun location _noun _justification _proof -> location - Raw.Have location _since _statement _justification _proof -> location - Raw.Suffices location _statement _justification _proof -> location - Raw.Subclaim location _statement _subproof _proof -> location - Raw.Define location _variable _expression _proof -> location - Raw.DefineFunction location _function _argument _value _bound _domain _proof -> - location - Raw.DefineFunctionLocal - location _function _argument _value _bound _target _rules _proof -> - location - -throwProof :: ExactProofError -> Prepare value -throwProof = - State.lift . Except.throwError - -liftDriver - :: Declaration.LoweringDriver value - -> Prepare value -liftDriver = - State.lift . Except.lift - -stableUnique :: Ord value => [value] -> [value] -stableUnique = - reverse . snd - . foldl' - (\(seen, reversed) value -> - if value `Set.member` seen - then (seen, reversed) - else - ( Set.insert value seen - , value : reversed - )) - (Set.empty, []) diff --git a/source/CommandLine.hs b/source/CommandLine.hs deleted file mode 100644 index ff970d3..0000000 --- a/source/CommandLine.hs +++ /dev/null @@ -1,961 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module CommandLine where - -import Api -import Base -import Checking.Declaration qualified as Declaration -import Checking.Foundation qualified as Foundation -import Checking.Identity qualified as Identity -import Checking.Module qualified as Typed -import Felix.OutputPlan qualified as Output -import Felix.Parse (ParseWorkspaceError) -import Felix.Parse qualified as Parse -import Felix.Source -import Felix.Source.Graph qualified as SourceGraph -import Felix.Store qualified as Store -import Provers qualified -import Render.Html.Export qualified as HtmlExport -import Render.Html.Layout qualified as HtmlLayout -import Render.Html.Output qualified as HtmlOutput -import Report.Location -import Version qualified - -import Control.Exception (displayException) -import Control.Exception qualified as Exception -import Control.Monad.Logger -import Data.ByteString qualified as ByteString -import Data.Maybe (catMaybes) -import Data.Text qualified as StrictText -import Data.Text.IO qualified as Text -import GHC.Conc qualified -import Options.Applicative hiding (renderFailure) -import System.Directory qualified as Directory -import System.Environment (getArgs, lookupEnv) -import System.Exit (ExitCode(..), exitWith) -import System.FilePath.Posix qualified as Posix -import System.IO (stderr) -import Text.Read (readMaybe) - - -newtype Input = Input - { inputFilePath :: FilePath - } - deriving stock (Show, Eq) - -data VerificationDiagnostics - = QuietVerification - | LogVerification - deriving stock (Show, Eq) - -data VerificationOptions = VerificationOptions - { verificationStoreSelection :: !Store.StoreSelection - , verificationTimeLimit :: !Provers.TimeLimit - , verificationMemoryLimit :: !Provers.MemoryLimit - , verificationJobsOverride :: !(Maybe Provers.EffectiveJobs) - , verificationDumpDestination :: !(Maybe FilePath) - , verificationHtmlRequested :: !Bool - , verificationDiagnostics :: !VerificationDiagnostics - } - deriving stock (Show, Eq) - -data Command - = Version - | ParseOnly !Input - | Verify !Input !VerificationOptions - deriving stock (Show, Eq) - -data CommandOutcome - = CommandCompleted - | VerificationSucceeded !VerificationReport - | VerificationCompletedWithGaps !VerificationReport - | VerificationRejected - !VerificationReport - !Location - !VerificationRejection - | ProverFailed !VerificationReport !Location !ProverFailure - | VerificationCheckingRejected - !VerificationReport - !VerificationDriverError - | SourcePlanningFailed !ParseWorkspaceError - | ParseOnlyFailed !AuthorityFreeParseError - | VerificationDriverFailed !VerificationDriverError - | StorePlanningFailed !Store.StorePlanningError - | StoreIncompatible !Store.StorePath !Store.StoreIncompatibility - | StoreFailed !Store.StorePath !Store.StoreLifecycleError - | OutputPlanningFailed !Output.OutputPlanError - | HtmlLayoutFailed !HtmlLayout.HtmlLayoutError - | DumpObservationFailed !DumpObservationError - | HtmlExportFailed - !VerificationReport - !HtmlExport.HtmlExportError - | HtmlOutputPlanningFailed - !VerificationReport - !HtmlOutput.HtmlOutputError - | HtmlPublicationFailed - !VerificationReport - !HtmlOutput.HtmlPublicationError - deriving stock (Show) - -data VerificationRejection - = CountermodelFound !Text - | ContradictoryInputFound !Text - deriving stock (Show, Eq) - -data ProverFailure - = ProverIndeterminate !Text - | ProverProtocolFailure !Text !Text - | ProverTransportFailure !Provers.ProverProcessError - deriving stock (Show, Eq) - -data DumpObservationError - = DumpDirectoryCreationFailed !FilePath !Text - | DumpRequestWriteFailed - !WorkPosition - !FilePath - !Text - deriving stock (Show, Eq) - -instance Exception.Exception DumpObservationError - - -runCommandLine :: IO () -runCommandLine = do - arguments <- getArgs - selected <- handleParseResult (parseCommandArguments arguments) - outcome <- runCommand selected - renderCommandOutcome outcome - exitWith (commandOutcomeExitCode outcome) - -rawCommandParserInfo :: ParserInfo RawCommand -rawCommandParserInfo = - info - (helper <*> rawCommandParser) - (fullDesc <> header "Felix") - -runCommand :: Command -> IO CommandOutcome -runCommand = \case - Version -> do - Text.putStrLn Version.info - pure CommandCompleted - ParseOnly (Input input) -> - parseWorkspace input >>= \case - Left failure -> - pure (ParseOnlyFailed failure) - Right _blocks -> - pure CommandCompleted - Verify input options -> - runVerification input options - -runVerification - :: Input - -> VerificationOptions - -> IO CommandOutcome -runVerification input options = do - plannedStore <- - Store.planStore - (verificationStoreSelection options) - case plannedStore of - Left failure -> - pure (StorePlanningFailed failure) - Right storePlan -> do - htmlResult <- discoverHtmlDestinations input options - case htmlResult of - Left failure -> - pure failure - Right htmlDestinations -> - Store.withStoreLease storePlan \lease -> do - outputResult <- - Output.planVerificationOutputs - (Store.storeLeasePath lease) - (verificationDumpDestination options) - (fmap ((,) "html") htmlDestinations) - case outputResult of - Left failure -> - pure (OutputPlanningFailed failure) - Right outputPlan -> - openSelectedStore - input - options - lease - outputPlan - -discoverHtmlDestinations - :: Input - -> VerificationOptions - -> IO (Either CommandOutcome (Maybe [SafeRelativePath])) -discoverHtmlDestinations input options - | not (verificationHtmlRequested options) = - pure (Right Nothing) - | otherwise = do - sourcePlan <- - prepareDefaultSourceGraph - (inputFilePath input) - pure case sourcePlan of - Left failure -> - Left (SourcePlanningFailed failure) - Right graph -> - case planHtmlDestinations graph of - Left failure -> - Left (HtmlLayoutFailed failure) - Right destinations -> - Right (Just destinations) - -planHtmlDestinations - :: SourceGraph.ResolvedSourceGraph - -> Either HtmlLayout.HtmlLayoutError [SafeRelativePath] -planHtmlDestinations graph = do - layout <- - HtmlLayout.layoutHtmlSourceGraph - defaultHtmlMountPrefixes - graph - pure - ( [ HtmlLayout.routeDestination route - | (_source, route) <- - HtmlLayout.htmlPageRoutes layout - ] - <> [HtmlLayout.routeDestination - (HtmlLayout.htmlSupportScriptRoute layout)] - ) - -openSelectedStore - :: Input - -> VerificationOptions - -> Store.StoreLease - -> Output.VerificationOutputPlan - -> IO CommandOutcome -openSelectedStore input options lease outputPlan = - case Foundation.checkedFoundation of - Left failures -> - pure - (VerificationDriverFailed - (VerificationFoundationManifestError failures)) - Right foundation -> do - opened <- - Store.withOpenStore - lease - (Identity.theoryId foundation) - \_startup store -> - runOpenVerification - input - options - outputPlan - store - pure - (case opened of - Left - (Store.StoreLifecycleOpenFailed - (Store.IncompatibleStore incompatibility)) -> - StoreIncompatible - (Store.storeLeasePath lease) - incompatibility - Left failure -> - StoreFailed - (Store.storeLeasePath lease) - failure - Right outcome -> - outcome) - -runOpenVerification - :: Input - -> VerificationOptions - -> Output.VerificationOutputPlan - -> Store.Store - -> IO CommandOutcome -runOpenVerification input options outputPlan store = do - observerResult <- - prepareRequestObserver - (Output.verificationDumpOutput outputPlan) - case observerResult of - Left failure -> - pure (DumpObservationFailed failure) - Right observer -> do - vampirePath <- getVampireExecutable - let vampire = - Provers.vampire - vampirePath - (verificationTimeLimit options) - (verificationMemoryLimit options) - validationMode = - case verificationStoreSelection options of - Store.FreshTemporaryStore -> - FreshStoreValidation - Store.DefaultStore -> - WarmStoreValidation - Store.ExplicitStore{} -> - WarmStoreValidation - jobs <- - Provers.selectEffectiveJobs - (verificationJobsOverride options) - GHC.Conc.getNumProcessors - observed <- - captureDumpFailure - (case verificationDiagnostics options of - QuietVerification -> - runNoLoggingT - (verifyWithObserverAndStoreModeAndJobs - store - validationMode - jobs - observer - vampire - (inputFilePath input)) - LogVerification -> - runStderrLoggingT - (verifyWithObserverAndStoreModeAndJobs - store - validationMode - jobs - observer - vampire - (inputFilePath input))) - case observed of - Left failure -> - pure (DumpObservationFailed failure) - Right (Left failure) -> - pure (VerificationDriverFailed failure) - Right (Right result) -> - finishVerification - outputPlan - result - -prepareRequestObserver - :: Maybe Output.DumpOutputPlan - -> IO - (Either - DumpObservationError - VerificationRequestObserver) -prepareRequestObserver = \case - Nothing -> - pure - (Right - (verificationRequestObserver - \_ordinal _request -> pure ())) - Just dumpPlan -> do - let root = Output.dumpOutputPath dumpPlan - created <- tryIOError - (Directory.createDirectoryIfMissing True root) - pure case created of - Left failure -> - Left - (DumpDirectoryCreationFailed - root - (StrictText.pack - (displayException failure))) - Right () -> - Right - (verificationRequestObserver - (writeDumpRequest root)) - -writeDumpRequest - :: FilePath - -> WorkPosition - -> Provers.PreparedVerificationRequest - -> IO () -writeDumpRequest root position request = do - let destination = - root - Posix.</> ( show - (workPositionModuleOrdinal position) - <> "-" - <> show - (workPositionLocalRequestOrdinal position) - ) - Posix.<.> "p" - result <- tryIOError - (publishDumpFile - destination - (Provers.preparedVerificationBytes request)) - case result of - Left failure -> - Exception.throwIO - (DumpRequestWriteFailed - position - destination - (StrictText.pack - (displayException failure))) - Right () -> - pure () - -publishDumpFile :: FilePath -> ByteString.ByteString -> IO () -publishDumpFile destination bytes = do - let directory = Posix.takeDirectory destination - template = Posix.takeFileName destination <> ".tmp" - bracketOnError - (openBinaryTempFileWithDefaultPermissions directory template) - cleanupTemporary - \(temporary, handle) -> do - ByteString.hPut handle bytes - hFlush handle - hClose handle - Directory.renameFile temporary destination - -cleanupTemporary :: (FilePath, Handle) -> IO () -cleanupTemporary (temporary, handle) = do - void (tryIOError (hClose handle)) - void (tryIOError (Directory.removeFile temporary)) - -captureDumpFailure - :: IO value - -> IO (Either DumpObservationError value) -captureDumpFailure = - Exception.try - -finishVerification - :: Output.VerificationOutputPlan - -> VerificationResult - -> IO CommandOutcome -finishVerification outputPlan result = - case result of - VerificationFailure{} -> - pure (verificationCommandOutcome result) - VerificationCheckingFailure{} -> - pure (verificationCommandOutcome result) - VerificationCompleted report presentation -> - publishHtmlIfRequested - outputPlan - report - presentation - (VerificationSucceeded report) - CompletedWithExplicitGaps report presentation -> - publishHtmlIfRequested - outputPlan - report - presentation - (VerificationCompletedWithGaps report) - -publishHtmlIfRequested - :: Output.VerificationOutputPlan - -> VerificationReport - -> VerificationPresentation - -> CommandOutcome - -> IO CommandOutcome -publishHtmlIfRequested outputPlan report presentation successOutcome = - case Output.verificationHtmlRoutes outputPlan of - Nothing -> - pure successOutcome - Just routes -> do - prepared <- - prepareVerifiedHtmlExportResult presentation - case prepared of - Left failure -> - pure (HtmlExportFailed report failure) - Right artifacts -> - case HtmlOutput.planHtmlOutputAgainst routes artifacts of - Left failure -> - pure (HtmlOutputPlanningFailed report failure) - Right plan -> - HtmlOutput.writeHtmlOutput plan >>= \case - Left failure -> - pure (HtmlPublicationFailed report failure) - Right () -> - pure successOutcome - -verificationCommandOutcome :: VerificationResult -> CommandOutcome -verificationCommandOutcome = \case - VerificationCompleted report _presentation -> - VerificationSucceeded report - CompletedWithExplicitGaps report _presentation -> - VerificationCompletedWithGaps report - VerificationFailure - report - FailedVerification - { failedVerificationLocation = location - , failedVerificationReason = reason - } -> - case reason of - CountermodelFailure tptp -> - VerificationRejected - report location (CountermodelFound tptp) - ContradictoryInputFailure tptp -> - VerificationRejected - report location (ContradictoryInputFound tptp) - IndeterminateFailure tptp -> - ProverFailed report location (ProverIndeterminate tptp) - ProtocolFailure label message -> - ProverFailed - report location - (ProverProtocolFailure label message) - TransportFailure processError -> - ProverFailed - report location - (ProverTransportFailure processError) - VerificationCheckingFailure report failure -> - VerificationCheckingRejected report failure - -commandOutcomeExitCode :: CommandOutcome -> ExitCode -commandOutcomeExitCode = \case - CommandCompleted -> - ExitSuccess - VerificationSucceeded{} -> - ExitSuccess - VerificationCompletedWithGaps{} -> - ExitSuccess - VerificationRejected{} -> - ExitFailure 1 - ProverFailed{} -> - ExitFailure 2 - VerificationCheckingRejected{} -> - ExitFailure 1 - SourcePlanningFailed{} -> - ExitFailure 1 - ParseOnlyFailed{} -> - ExitFailure 1 - VerificationDriverFailed{} -> - ExitFailure 1 - StorePlanningFailed{} -> - ExitFailure 2 - StoreIncompatible{} -> - ExitFailure 2 - StoreFailed{} -> - ExitFailure 2 - OutputPlanningFailed{} -> - ExitFailure 2 - HtmlLayoutFailed{} -> - ExitFailure 2 - DumpObservationFailed{} -> - ExitFailure 2 - HtmlExportFailed{} -> - ExitFailure 2 - HtmlOutputPlanningFailed{} -> - ExitFailure 2 - HtmlPublicationFailed{} -> - ExitFailure 2 - -renderCommandOutcome :: CommandOutcome -> IO () -renderCommandOutcome = \case - CommandCompleted -> - pure () - VerificationSucceeded report -> do - Text.hPutStrLn stderr "Verification successful." - renderVerificationReport report - VerificationCompletedWithGaps report -> do - Text.hPutStrLn stderr - "Verification completed with explicit proof gaps." - renderVerificationReport report - VerificationRejected report location rejection -> do - renderVerificationRejection location rejection - renderVerificationReport report - ProverFailed report location failure -> do - renderProverFailure location failure - renderVerificationReport report - VerificationCheckingRejected report failure -> do - renderVerificationDriverFailure failure - renderVerificationReport report - SourcePlanningFailed failure -> - renderFailure - ("Source planning failed: " - <> Parse.renderParseWorkspaceError failure) - ParseOnlyFailed failure -> - renderFailure - ("Parsing failed: " - <> renderAuthorityFreeParseError failure) - VerificationDriverFailed failure -> - renderVerificationDriverFailure failure - StorePlanningFailed failure -> - renderFailure - ("Store path planning failed: " - <> Store.renderStorePlanningError failure) - StoreIncompatible path failure -> - renderFailure - ("Disposable store " - <> quotePath (Store.storePathFilePath path) - <> " is incompatible: " - <> Store.renderStoreIncompatibility failure - <> ". Use --fresh, choose another --store path, or remove the disposable store.") - StoreFailed path failure -> - renderFailure - ("Store failure at " - <> quotePath (Store.storePathFilePath path) - <> ": " <> Store.renderStoreLifecycleError failure) - OutputPlanningFailed failure -> - renderFailure - ("Verification output preflight failed: " - <> Output.renderOutputPlanError failure) - HtmlLayoutFailed failure -> - renderFailure - ("HTML route planning failed: " - <> HtmlLayout.renderHtmlLayoutError failure) - DumpObservationFailed failure -> - renderDumpObservationFailure failure - HtmlExportFailed report failure -> do - renderFailure - ("Verification succeeded, but HTML preparation failed: " - <> HtmlExport.renderHtmlExportError failure) - renderVerificationReport report - HtmlOutputPlanningFailed report failure -> do - renderFailure - ("Verification succeeded, but prepared HTML did not match the reserved routes: " - <> HtmlOutput.renderHtmlOutputError failure) - renderVerificationReport report - HtmlPublicationFailed report failure -> do - renderFailure - "Verification succeeded, but HTML publication did not complete." - traverse_ - renderFailure - (HtmlOutput.renderHtmlPublicationError failure) - renderVerificationReport report - -renderFailure :: Text -> IO () -renderFailure = - Text.hPutStrLn stderr - -renderVerificationDriverFailure - :: VerificationDriverError - -> IO () -renderVerificationDriverFailure = - renderFailure . verificationDriverFailureMessage - -verificationDriverFailureMessage - :: VerificationDriverError - -> Text -verificationDriverFailureMessage = \case - VerificationWorkspaceError failure -> - "Verification input failed: " - <> Parse.renderParseWorkspaceError failure - VerificationTypedInputError source failure -> - "Typed module input failed in " - <> resolvedSourceDisplay source - <> ": " <> Typed.renderTypedModuleInputError failure - VerificationTypedOpenError source failure -> - "Typed module startup failed in " - <> resolvedSourceDisplay source - <> ": " <> Declaration.renderDriverOpenError failure - VerificationTypedCachedModuleError source failure -> - "Cached typed module is invalid in " - <> resolvedSourceDisplay source - <> ": " <> Typed.renderCachedTypedModuleError failure - VerificationTypedModuleError source failure _prefix -> - "Typed module checking failed in " - <> resolvedSourceDisplay source - <> ": " <> Typed.renderTypedModuleFailure failure - VerificationValidationIntegrityError source failure -> - "Typed module validation store is inconsistent in " - <> resolvedSourceDisplay source - <> ": " <> Declaration.renderValidationIntegrityError failure - VerificationAdmittedViewError source failure -> - "Typed admitted-source association is inconsistent in " - <> resolvedSourceDisplay source - <> ": " <> StrictText.pack (show failure) - VerificationParsedArtifactIntegrityError source failure -> - "Parsed artifact is inconsistent in " - <> resolvedSourceDisplay source - <> ": " <> StrictText.pack (show failure) - VerificationStoreFailure failure -> - "Verification store failed: " - <> Store.renderStoreFailure failure - VerificationStorePlanningFailure failure -> - "Verification store planning failed: " - <> Store.renderStorePlanningError failure - VerificationStoreLifecycleFailure failure -> - "Verification store lifecycle failed: " - <> Store.renderStoreLifecycleError failure - VerificationModuleArtifactKeyError{} -> - "Typed module artifact inputs are inconsistent." - VerificationModuleSchedulerInvariant message -> - "Typed module scheduler invariant failed: " <> message - VerificationFoundationManifestError{} -> - "The fixed foundation manifest is invalid." - VerificationMissingImportedModule address -> - "Verification could not find checked imported module " - <> StrictText.pack (show address) <> "." - VerificationMissingRootModule address -> - "Verification could not find checked root module " - <> StrictText.pack (show address) <> "." - VerificationFinalPreludeReadinessError{} -> - "The packaged final prelude failed." - -resolvedSourceDisplay :: ResolvedSource -> Text -resolvedSourceDisplay source = - sourceMountIdText (resolvedSourceMount source) - <> ":" - <> StrictText.pack (resolvedSourceLocationPath source) - -quotePath :: FilePath -> Text -quotePath = StrictText.pack . show - -renderDumpObservationFailure :: DumpObservationError -> IO () -renderDumpObservationFailure = \case - DumpDirectoryCreationFailed path message -> - renderFailure - ("Could not create dump directory " - <> StrictText.pack (show path) - <> ": " - <> message) - DumpRequestWriteFailed _ordinal path message -> - renderFailure - ("Could not write request dump " - <> StrictText.pack (show path) - <> ": " - <> message) - -renderVerificationRejection - :: Location - -> VerificationRejection - -> IO () -renderVerificationRejection location = \case - CountermodelFound tptp -> do - renderFailedTask tptp - Text.hPutStrLn stderr - ("Verification failed: prover found countermodel at " - <> locationToText location) - Text.hPutStrLn stderr - "This often happens when an explicit justification with \\cref{...} is missing some references." - ContradictoryInputFound tptp -> do - renderFailedTask tptp - Text.hPutStrLn stderr - ("Verification failed: contradictory axioms at " - <> locationToText location) - Text.hPutStrLn stderr - "This is usually caused by an incorrect axiom or a theorem that has its proof omitted." - -renderProverFailure :: Location -> ProverFailure -> IO () -renderProverFailure location = \case - ProverIndeterminate tptp -> do - renderFailedTask tptp - Text.hPutStrLn stderr - ("Verification failed: prover returned an indeterminate result at " - <> locationToText location) - ProverProtocolFailure label message -> do - Text.hPutStrLn stderr - ("Prover error at " <> locationToText location <> ":") - Text.hPutStrLn stderr ("Task: " <> label) - Text.hPutStrLn stderr ("Error: " <> message) - ProverTransportFailure processError -> do - Text.hPutStrLn stderr - ("Prover process error at " <> locationToText location <> ":") - Text.hPutStrLn stderr (StrictText.pack (show processError)) - -renderFailedTask :: Text -> IO () -renderFailedTask tptp = do - Text.hPutStrLn stderr "(Failed TPTP task follows.)" - Text.hPutStrLn stderr tptp - -renderVerificationReport :: VerificationReport -> IO () -renderVerificationReport report = do - Text.hPutStrLn stderr - ( "Direct source authorization summary: " - <> renderCount - sourceAxiomCount - "source axiom" - <> ", " - <> renderCount - omittedCount - "explicit proof gap" - <> "." - ) - for_ - (verificationDirectEscapes report) - \escape -> - Text.hPutStrLn stderr case reportedEscapeKind escape of - ReportedSourceAxiom -> - "Source axiom at " - <> locationToText (reportedEscapeLocation escape) - ReportedOmitted -> - "Explicit proof gap at " - <> locationToText (reportedEscapeLocation escape) - where - sourceAxiomCount = - length - [ () - | escape <- verificationDirectEscapes report - , reportedEscapeKind escape == ReportedSourceAxiom - ] - omittedCount = - length - [ () - | escape <- verificationDirectEscapes report - , reportedEscapeKind escape == ReportedOmitted - ] - renderCount amount noun = - StrictText.pack (show amount) - <> " " - <> noun - <> if amount == 1 then "" else "s" - -getVampireExecutable :: IO FilePath -getVampireExecutable = - fromMaybe "vampire" <$> lookupEnv "NAPROCHE_ZF_VAMPIRE" - - -data RawCommand - = RawVersion - | RawFile !RawFileCommand - -data RawFileCommand = RawFileCommand - { rawInput :: !Input - , rawParseOnly :: !Bool - , rawStore :: !(Maybe FilePath) - , rawFresh :: !Bool - , rawTimeLimit :: !(Maybe Provers.TimeLimit) - , rawMemoryLimit :: !(Maybe Provers.MemoryLimit) - , rawJobs :: !(Maybe Provers.EffectiveJobs) - , rawDump :: !(Maybe FilePath) - , rawHtml :: !Bool - , rawLogging :: !Bool - } - -rawCommandParser :: Parser RawCommand -rawCommandParser = - versionParser - <|> (RawFile <$> rawFileCommandParser) - -versionParser :: Parser RawCommand -versionParser = - flag' - RawVersion - (long "version" <> help "Show the Felix version.") - -inputParser :: Parser Input -inputParser = - Input - <$> strArgument - (help "Source file" <> metavar "FILE") - -rawFileCommandParser :: Parser RawFileCommand -rawFileCommandParser = - RawFileCommand - <$> inputParser - <*> switch - (long "parseonly" - <> help "Resolve and parse source without verification.") - <*> optional - (strOption - (long "store" - <> metavar "PATH" - <> help "Use the disposable SQLite store at PATH.")) - <*> switch - (long "fresh" - <> help "Use a fresh temporary disposable store.") - <*> optional timeLimitParser - <*> optional memoryLimitParser - <*> optional jobsParser - <*> optional - (strOption - (long "dump" - <> metavar "DUMPDIR" - <> help "Dump exact Vampire requests as they execute.")) - <*> switch - (long "html" - <> help "Publish verified HTML under ./html.") - <*> switch - (long "log" - <> help "Enable verification diagnostics.") - -parseCommandArguments :: [String] -> ParserResult Command -parseCommandArguments arguments = - case execParserPure - defaultPrefs - rawCommandParserInfo - arguments of - Success raw -> - case validateRawCommand raw of - Left message -> - Failure - (parserFailure - defaultPrefs - rawCommandParserInfo - (ErrorMsg message) - []) - Right selected -> - Success selected - Failure failure -> - Failure failure - CompletionInvoked completion -> - CompletionInvoked completion - -validateRawCommand :: RawCommand -> Either String Command -validateRawCommand = \case - RawVersion -> - Right Version - RawFile raw - | rawParseOnly raw - , not (null verificationOnlyOptions) -> - Left - ("--parseonly cannot be combined with verification options: " - <> unwords verificationOnlyOptions) - | rawParseOnly raw -> - Right (ParseOnly (rawInput raw)) - | isJust (rawStore raw) && rawFresh raw -> - Left "--store and --fresh are mutually exclusive" - | otherwise -> - Right - (Verify - (rawInput raw) - VerificationOptions - { verificationStoreSelection = - case rawStore raw of - Just path -> - Store.ExplicitStore path - Nothing - | rawFresh raw -> - Store.FreshTemporaryStore - | otherwise -> - Store.DefaultStore - , verificationTimeLimit = - fromMaybe - Provers.defaultTimeLimit - (rawTimeLimit raw) - , verificationMemoryLimit = - fromMaybe - Provers.defaultMemoryLimit - (rawMemoryLimit raw) - , verificationJobsOverride = rawJobs raw - , verificationDumpDestination = - rawDump raw - , verificationHtmlRequested = - rawHtml raw - , verificationDiagnostics = - if rawLogging raw - then LogVerification - else QuietVerification - }) - where - verificationOnlyOptions = - catMaybes - [ "--store" <$ rawStore raw - , if rawFresh raw then Just "--fresh" else Nothing - , "--timelimit" <$ rawTimeLimit raw - , "--memlimit" <$ rawMemoryLimit raw - , "--jobs" <$ rawJobs raw - , "--dump" <$ rawDump raw - , if rawHtml raw then Just "--html" else Nothing - , if rawLogging raw then Just "--log" else Nothing - ] - -timeLimitParser :: Parser Provers.TimeLimit -timeLimitParser = - Provers.Seconds - <$> option auto - ( long "timelimit" - <> short 't' - <> metavar "SECONDS" - <> help "Time limit for each Vampire request." - ) - -memoryLimitParser :: Parser Provers.MemoryLimit -memoryLimitParser = - Provers.Megabytes - <$> option auto - ( long "memlimit" - <> short 'm' - <> metavar "MB" - <> help "Memory limit for each Vampire process." - ) - -jobsParser :: Parser Provers.EffectiveJobs -jobsParser = - option - (eitherReader parseJobs) - ( long "jobs" - <> short 'j' - <> metavar "JOBS" - <> help - "Run at most JOBS module checkers and Vampire invocations." - ) - where - parseJobs raw = - case readMaybe raw >>= Provers.effectiveJobs of - Just jobs -> Right jobs - Nothing -> Left "JOBS must be a positive integer" diff --git a/source/Felix/Cache/Codec.hs b/source/Felix/Cache/Codec.hs index 2d81e57..34f2694 100644 --- a/source/Felix/Cache/Codec.hs +++ b/source/Felix/Cache/Codec.hs @@ -49,7 +49,7 @@ module Felix.Cache.Codec ) where import Base hiding (Empty) -import Checking.Core +import Felix.Checking.Core import Felix.Math.Codec import Control.DeepSeq (NFData) @@ -75,7 +75,7 @@ newtype CacheEpoch = CacheEpoch Word32 currentCacheEpoch :: CacheEpoch currentCacheEpoch = - CacheEpoch 23 + CacheEpoch 38 cacheEpochValue :: CacheEpoch -> Word32 cacheEpochValue (CacheEpoch value) = diff --git a/source/Checking/Authority.hs b/source/Felix/Checking/Authority.hs index 2fa21f2..58c123f 100644 --- a/source/Checking/Authority.hs +++ b/source/Felix/Checking/Authority.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Compact public fact authority and exact contextual authorization. -module Checking.Authority +module Felix.Checking.Authority ( EscapeKind(..) , EscapeKinds , emptyEscapeKinds @@ -59,8 +59,8 @@ module Checking.Authority ) where import Base -import Checking.Foundation -import Checking.Identity +import Felix.Checking.Foundation +import Felix.Checking.Identity import Felix.Cache.Codec import Control.DeepSeq (NFData) @@ -230,6 +230,7 @@ data KernelConstructionDescriptor = FoundationLeaf !FoundationAxiomTag | GuardedFoundationRules !GuardedRuleSet | CheckedDefinitionEquation !ObjectId + | CheckedSetConstructionExtensionality !ObjectId !CacheDigest deriving stock (Show, Eq, Ord, Generic) -- | Exact semantic members of one trusted datatype compilation. @@ -487,6 +488,10 @@ putKernelDescriptor = \case CheckedDefinitionEquation identity -> do putCacheTag 0x02 putObjectIdCache identity + CheckedSetConstructionExtensionality identity construction -> do + putCacheTag 0x03 + putObjectIdCache identity + putCacheDigest construction getKernelDescriptor :: CacheGet KernelConstructionDescriptor getKernelDescriptor = @@ -503,6 +508,10 @@ getKernelDescriptor = (fail "cache guarded-rule tags are not in canonical order") pure (GuardedFoundationRules (guardedRuleSet rules)) 0x02 -> CheckedDefinitionEquation <$> getObjectIdCache + 0x03 -> + CheckedSetConstructionExtensionality + <$> getObjectIdCache + <*> getCacheDigest tag -> fail ("unknown cache kernel-construction tag " <> show tag) diff --git a/source/Checking/Backend/Problem.hs b/source/Felix/Checking/Backend/Problem.hs index 61a31d2..0390020 100644 --- a/source/Checking/Backend/Problem.hs +++ b/source/Felix/Checking/Backend/Problem.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Complete-problem FOF/TH0 classification and construction. -module Checking.Backend.Problem +module Felix.Checking.Backend.Problem ( SupportedProposition , supportedProposition , projectSupportedProposition @@ -38,8 +38,8 @@ module Checking.Backend.Problem , typedProblemAuxiliaryTag , typedProblemAuxiliaryProposition , typedProblemAuxiliaryCapability - , GlobalPremiseMode(..) , LocalPremisePolicy(..) + , HigherOrderJustificationPolicy(..) , selectTypedLocalPremises , TypedProblemRoute(..) , TypedProblem @@ -55,8 +55,8 @@ module Checking.Backend.Problem ) where import Base -import Checking.Core -import Checking.Foundation +import Felix.Checking.Core +import Felix.Checking.Foundation import Control.Monad (foldM, unless) import Data.Bifunctor (first) @@ -806,34 +806,43 @@ typedProblemAuxiliaryCapability capability -data GlobalPremiseMode - = ImplicitFofPremises - | ExplicitGlobalPremises - | NoGlobalPremises - deriving stock (Show, Eq) - +-- | Source justification policy for premise selection. Higher-order routing +-- is validated separately after the complete selected problem is known. data LocalPremisePolicy = FirstOrderLocals - | AllLocals + | CompleteLocals + deriving stock (Show, Eq) + +-- | Whether selected higher-order components must be justified by one of the +-- two approved inline construction forms. Premise selection has already +-- happened when this policy is applied. +data HigherOrderJustificationPolicy + = ImplicitConstructionJustification + | ExplicitHigherOrderJustification deriving stock (Show, Eq) selectTypedLocalPremises :: LocalPremisePolicy -> [TypedLocalPremise local origin global] -> Vector (TypedLocalPremise local origin global) -selectTypedLocalPremises localPolicy availableLocals = +selectTypedLocalPremises selection availableLocals = Vector.fromList (List.sortOn typedLocalPremiseOrdinal - (case localPolicy of + (case selection of FirstOrderLocals -> List.filter (isFofCapability . typedLocalPremiseCapability) availableLocals - AllLocals -> + CompleteLocals -> availableLocals)) +data ImplicitHigherOrderConstruction + = ImplicitSeparation + | ImplicitFunctionalReplacement + deriving stock (Show, Eq, Ord) + data TypedProblemRoute = RouteFof | RouteTh0 @@ -855,9 +864,6 @@ data TypedProblemError local global !(BackendClassificationError global) | TypedProblemExplicitHigherOrderJustificationRequired !(NonEmpty BackendFofExclusion) - | TypedProblemInvalidPolicyCombination - !GlobalPremiseMode - !LocalPremisePolicy | TypedProblemDuplicateLocalPremiseOrdinal !LocalPremiseOrdinal | TypedProblemLocalTypeMismatch @@ -873,8 +879,8 @@ planTypedProblem -> SupportedProposition local global -> [TypedLocalPremise local origin global] -> [TypedFoundationAuxiliaryInput global] - -> GlobalPremiseMode -> LocalPremisePolicy + -> HigherOrderJustificationPolicy -> Either (TypedProblemError local global) (TypedProblem ref local origin global) @@ -884,11 +890,8 @@ planTypedProblem claim availableLocals auxiliaries - globalPolicy - localPolicy = do - validatePolicyCombination - globalPolicy localPolicy + higherOrderPolicy = do validateLocalPremiseOrdinals availableLocals claimCapability <- @@ -906,19 +909,15 @@ planTypedProblem prepareAuxiliary [0..] auxiliaries - case globalPolicy of - ImplicitFofPremises -> - case implicitTh0Requirement - claimCapability - (typedProblemAuxiliaryCapability - <$> preparedAuxiliaries) of - Nothing -> - pure () - Just exclusions -> - Left - (TypedProblemExplicitHigherOrderJustificationRequired - exclusions) - _ -> + case higherOrderPolicy of + ImplicitConstructionJustification -> + validateImplicitHigherOrderAdmission + claim + claimCapability + selectedFacts + selectedLocals + preparedAuxiliaries + ExplicitHigherOrderJustification -> pure () let selectedFofCapabilities = isFofCapability claimCapability @@ -956,23 +955,6 @@ planTypedProblem globalTypes localTypes) where - implicitTh0Requirement claimCapability - auxiliaryCapabilities = - case claimCapability of - RequiresTh0 exclusions -> - Just exclusions - FofProjectable{} -> - firstAuxiliaryRequirement - auxiliaryCapabilities - - firstAuxiliaryRequirement = \case - [] -> - Nothing - FofProjectable{} : remaining -> - firstAuxiliaryRequirement remaining - RequiresTh0 exclusions : _remaining -> - Just exclusions - prepareAuxiliary ordinal (TypedFoundationAuxiliaryInput @@ -985,25 +967,120 @@ planTypedProblem proposition capability -validatePolicyCombination - :: GlobalPremiseMode - -> LocalPremisePolicy - -> Either - (TypedProblemError local global) - () -validatePolicyCombination globalPolicy localPolicy = - case (globalPolicy, localPolicy) of - (ImplicitFofPremises, FirstOrderLocals) -> - Right () - (ExplicitGlobalPremises, FirstOrderLocals) -> - Right () - (NoGlobalPremises, AllLocals) -> - Right () +-- | Implicit automation admits higher-order routing only for a checked +-- proposition that itself contains one of the two approved set constructions. +-- This classification selects no premise and grants no authority. +implicitConstructionAdmission + :: SupportedProposition local global + -> FofCapability projection + -> Maybe (Set ImplicitHigherOrderConstruction) +implicitConstructionAdmission proposition capability = + case capability of + FofProjectable{} -> + Nothing + RequiresTh0 exclusions + | Set.null constructions -> + Nothing + | all (admittedExclusion constructions) exclusions -> + Just constructions + | otherwise -> + Nothing + where + dependencies = + foundationAxiomDependencies + (supportedPropositionTerm proposition) + constructions = + Set.fromList + ( [ ImplicitSeparation + | SeparationCharacteristic `Set.member` dependencies + ] + <> [ ImplicitFunctionalReplacement + | ReplacementCharacteristic `Set.member` dependencies + ] + ) + + admittedExclusion allowed = \case + StructuralFofExclusion HigherOrderLambda -> + True + StructuralFofExclusion (HigherOrderIntrinsic Sep) -> + ImplicitSeparation `Set.member` allowed + StructuralFofExclusion (HigherOrderIntrinsic Repl) -> + ImplicitFunctionalReplacement `Set.member` allowed + -- The checked proposition is the deliberate granularity: its typed + -- global occurrences neither select another fact nor grant authority. + HigherOrderGlobalType{} -> + True + StructuralFofExclusion{} -> + False + HigherOrderAmbientLocal{} -> + False + +validateImplicitHigherOrderAdmission + :: SupportedProposition local global + -> FofCapability claimProjection + -> Vector (TypedBackendFact ref global) + -> Vector (TypedLocalPremise local origin global) + -> [TypedProblemAuxiliary global] + -> Either (TypedProblemError local global) () +validateImplicitHigherOrderAdmission + claim claimCapability selectedFacts selectedLocals auxiliaries = do + claimConstructions <- + admittedPropositionConstructions claim claimCapability + traverse_ requireFirstOrderGlobal selectedFacts + localConstructions <- + foldM + (\admitted premise -> + (admitted <>) + <$> admittedPropositionConstructions + (typedLocalPremiseProposition premise) + (typedLocalPremiseCapability premise)) + Set.empty + (Vector.toList selectedLocals) + let admitted = claimConstructions <> localConstructions + traverse_ (requireAdmittedAuxiliary admitted) auxiliaries + where + admittedPropositionConstructions proposition = \case + FofProjectable{} -> + Right Set.empty + RequiresTh0 exclusions -> + maybe + (Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions)) + Right + (implicitConstructionAdmission + proposition + (RequiresTh0 exclusions)) + + requireFirstOrderGlobal fact = + case typedBackendFactCapability fact of + FofProjectable{} -> + Right () + RequiresTh0 exclusions -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + requireAdmittedAuxiliary admitted auxiliary = + case typedProblemAuxiliaryCapability auxiliary of + FofProjectable{} -> + Right () + RequiresTh0 exclusions + | auxiliaryAdmitted admitted + (typedProblemAuxiliaryTag auxiliary) -> + Right () + | otherwise -> + Left + (TypedProblemExplicitHigherOrderJustificationRequired + exclusions) + + auxiliaryAdmitted admitted = \case + SeparationCharacteristic -> + ImplicitSeparation `Set.member` admitted + ReplacementCharacteristic -> + ImplicitFunctionalReplacement `Set.member` admitted _ -> - Left - (TypedProblemInvalidPolicyCombination - globalPolicy - localPolicy) + False validateLocalPremiseOrdinals :: [TypedLocalPremise local origin global] diff --git a/source/Checking/Backend/Tptp.hs b/source/Felix/Checking/Backend/Tptp.hs index 4601b11..a5c0546 100644 --- a/source/Checking/Backend/Tptp.hs +++ b/source/Felix/Checking/Backend/Tptp.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Deterministic task-wide TPTP preparation for checked typed problems. -module Checking.Backend.Tptp +module Felix.Checking.Backend.Tptp ( TypedFormulaOccurrence(..) , TypedTptpNameOrigin(..) , PreparedTypedTptpProblem @@ -16,8 +16,8 @@ module Checking.Backend.Tptp ) where import Base hiding (Empty) -import Checking.Backend.Problem -import Checking.Core +import Felix.Checking.Backend.Problem +import Felix.Checking.Core import Tptp.UnsortedFirstOrder qualified as Tptp import Control.Monad (foldM) @@ -194,27 +194,27 @@ allocateNames allocateNames problem = do globalAllocations <- allocateCategory - "zf_g" + "tg_g" TypedGlobalNameOrigin (Map.keys (typedProblemGlobalTypes problem)) localAllocations <- allocateCategory - "zf_l" + "tg_l" TypedLocalNameOrigin (Map.keys (typedProblemLocalTypes problem)) intrinsicAllocations <- allocateCategory - "zf_i" + "tg_i" TypedIntrinsicNameOrigin (Set.toAscList (problemIntrinsics problem)) integerAllocations <- allocateCategory - "zf_n" + "tg_n" TypedIntegerNameOrigin (Set.toAscList (problemIntegers problem)) @@ -482,13 +482,13 @@ renderOccurrence names problem occurrence proposition = do case occurrence of TypedConjectureOccurrence -> liftEither - (generatedAtomicWord "zf_q0") + (generatedAtomicWord "tg_q0") _ -> do ordinal <- nextHypothesisOrdinal liftEither (generatedAtomicWord - ("zf_h" + ("tg_h" <> Text.pack (show ordinal))) registerOrigin @@ -949,7 +949,7 @@ renderTh0Declarations names problem = do label <- liftEither (generatedAtomicWord - ("zf_g_type_" + ("tg_g_type_" <> Text.pack (show ordinal))) pure @@ -969,7 +969,7 @@ renderTh0Declarations names problem = do label <- liftEither (generatedAtomicWord - ("zf_l_type_" + ("tg_l_type_" <> Text.pack (show ordinal))) pure @@ -989,7 +989,7 @@ renderTh0Declarations names problem = do label <- liftEither (generatedAtomicWord - ("zf_i_type_" + ("tg_i_type_" <> Text.pack (show ordinal))) pure @@ -1010,7 +1010,7 @@ renderTh0Declarations names problem = do label <- liftEither (generatedAtomicWord - ("zf_n_type_" + ("tg_n_type_" <> Text.pack (show ordinal))) pure diff --git a/source/Checking/Core.hs b/source/Felix/Checking/Core.hs index 4b7478f..13ec218 100644 --- a/source/Checking/Core.hs +++ b/source/Felix/Checking/Core.hs @@ -8,7 +8,7 @@ -- -- Scoped syntax is an operational construction language. Only a checked, -- frozen value is semantic input to later kernel and backend boundaries. -module Checking.Core +module Felix.Checking.Core ( CoreType(..) , CoreIntrinsicTag(..) , coreIntrinsicType @@ -52,14 +52,22 @@ module Checking.Core , scopedCharacteristicDefinition , scopedReplacementGraph , implyScopedCore + , equalScopedCore + , conjoinScopedCore + , disjoinScopedCore + , negateScopedCore + , falsumScopedCore , splitScopedSetEquality - , scopedSetInductionHypothesis + , scopedSetInductionInstance , closeScopedForall , closeScopedExists , openScopedForall , openScopedImplication + , openScopedAssumption , closeScopedCore + , betaNormalizeCanonical , instantiateCanonical + , shiftCanonical , mapCanonicalGlobals , canonicalTermGlobals , checkCanonicalCore @@ -463,7 +471,8 @@ data CanonicalTerm global -- | The fixed checked-core interpretation of set insertion. -- --- Finite-set notation and typed 'ConsSymbol' lowering share this form. +-- Finite-set notation uses this intrinsic HOTG adjunction directly. The +-- ordinary source-owned @cons@ function is not consulted during lowering. canonicalSetInsert :: CanonicalTerm global -> CanonicalTerm global @@ -904,6 +913,90 @@ implyScopedCore implyScopedCore _premise _conclusion = Nothing +-- | Form an equality between checked operands under the same lexical +-- context. This preserves the checked-core invariant without requiring a +-- caller to recover global types merely to combine already checked terms. +equalScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +equalScopedCore + (ScopedCheckedCore leftContext leftType left) + (ScopedCheckedCore rightContext rightType right) + | leftContext == rightContext + , leftType == rightType = + Just + (ScopedCheckedCore + leftContext + TyProp + (CEq leftType left right)) +equalScopedCore _left _right = + Nothing + +-- | Conjoin two checked propositions under the same lexical context. Truth +-- is normalized away so callers can build an optional source guard without +-- retaining an inert conjunct. +conjoinScopedCore + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +conjoinScopedCore + left@(ScopedCheckedCore leftContext TyProp leftTerm) + right@(ScopedCheckedCore rightContext TyProp rightTerm) + | leftContext == rightContext + , leftTerm == truth = Just right + | leftContext == rightContext + , rightTerm == truth = Just left + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp + (CImp leftTerm (CImp rightTerm CFalsum)) + CFalsum)) + where + truth = CImp CFalsum CFalsum +conjoinScopedCore _left _right = + Nothing + +-- | Disjoin two checked propositions under the same lexical context using +-- the fixed classical encoding owned by the checked core. +disjoinScopedCore + :: ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +disjoinScopedCore + (ScopedCheckedCore leftContext TyProp left) + (ScopedCheckedCore rightContext TyProp right) + | leftContext == rightContext = + Just + (ScopedCheckedCore + leftContext + TyProp + (CImp (CImp left CFalsum) right)) +disjoinScopedCore _left _right = + Nothing + +-- | Negate a checked proposition without changing its lexical context. +negateScopedCore + :: ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) +negateScopedCore (ScopedCheckedCore context TyProp proposition) = + Just + (ScopedCheckedCore + context + TyProp + (CImp proposition CFalsum)) +negateScopedCore _proposition = + Nothing + +-- | Checked falsum at an already established lexical context. +falsumScopedCore :: [CoreType] -> ScopedCheckedCore global +falsumScopedCore context = + ScopedCheckedCore context TyProp CFalsum + -- | Split a checked set equality into its two extensionality directions. splitScopedSetEquality :: ScopedCheckedCore global @@ -934,30 +1027,61 @@ splitScopedSetEquality splitScopedSetEquality _proposition = Nothing --- | Form the set-induction hypothesis for one set-valued ambient binder. -scopedSetInductionHypothesis +-- | Derive the exact predicate, member-wise hypothesis, induction step, and +-- binder-level result for one set-valued ambient binder. The selected binder +-- is replaced by the newly introduced set variable; every other ambient +-- binder remains a parameter. +scopedSetInductionInstance :: Natural -> ScopedCheckedCore global - -> Maybe (ScopedCheckedCore global) -scopedSetInductionHypothesis selected + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + , ScopedCheckedCore global + ) +scopedSetInductionInstance selected (ScopedCheckedCore context TyProp property) | binderTypeAt selected context == Just TySet = - Just - (ScopedCheckedCore - context - TyProp - (CForall - TySet - (CImp - (CApp - (CApp - (CIntrinsic Member) - (CBound 0)) - (CBound (selected + 1))) - (replaceSelectedWithNearest - 0 property)))) + Just (predicate, hypothesis, step, result) where - replaceSelectedWithNearest depth = \case + abstractedProperty = abstractSelected 0 property + predicate = + ScopedCheckedCore + context + (TySet `TyArrow` TyProp) + (CLam TySet abstractedProperty) + hypothesis = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (CApp + (CApp + (CIntrinsic Member) + (CBound 0)) + (CBound (selected + 1))) + abstractedProperty)) + step = + ScopedCheckedCore + context + TyProp + (CForall + TySet + (CImp + (abstractSelected + 0 + (scopedCoreTerm hypothesis)) + abstractedProperty)) + result = + ScopedCheckedCore + context + TyProp + (CForall TySet abstractedProperty) + + abstractSelected depth = \case CBound index | index == depth + selected -> CBound depth @@ -973,25 +1097,25 @@ scopedSetInductionHypothesis selected COpaqueInteger integer CApp function argument -> CApp - (replaceSelectedWithNearest depth function) - (replaceSelectedWithNearest depth argument) + (abstractSelected depth function) + (abstractSelected depth argument) CLam binderType body -> CLam binderType - (replaceSelectedWithNearest (depth + 1) body) + (abstractSelected (depth + 1) body) CFalsum -> CFalsum CImp premise conclusion -> CImp - (replaceSelectedWithNearest depth premise) - (replaceSelectedWithNearest depth conclusion) + (abstractSelected depth premise) + (abstractSelected depth conclusion) CEq operandType left right -> CEq operandType - (replaceSelectedWithNearest depth left) - (replaceSelectedWithNearest depth right) + (abstractSelected depth left) + (abstractSelected depth right) CForall binderType body -> CForall binderType - (replaceSelectedWithNearest (depth + 1) body) -scopedSetInductionHypothesis _selected _property = + (abstractSelected (depth + 1) body) +scopedSetInductionInstance _selected _property = Nothing -- | Close the nearest checked binder as one leading universal. @@ -1058,6 +1182,52 @@ openScopedImplication openScopedImplication _scoped = Nothing +-- | Open a checked proof assumption against the current goal. Besides a +-- direct implication antecedent, the source language historically permits +-- either immediate side of one binary conjunction antecedent to be assumed +-- first. The other side remains the next implication antecedent. This is a +-- deliberately shallow structural rule: it neither flattens conjunctions nor +-- treats disjunction as an eliminable assumption. +openScopedAssumption + :: Eq global + => ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +openScopedAssumption supplied goal = do + (antecedent, conclusion) <- openScopedImplication goal + if supplied == antecedent + then pure (antecedent, conclusion) + else do + (left, right) <- splitScopedConjunction antecedent + if supplied == left + then do + remaining <- implyScopedCore right conclusion + pure (left, remaining) + else if supplied == right + then do + remaining <- implyScopedCore left conclusion + pure (right, remaining) + else Nothing + +splitScopedConjunction + :: ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +splitScopedConjunction + (ScopedCheckedCore context TyProp + (CImp (CImp left (CImp right CFalsum)) CFalsum)) = + Just + ( ScopedCheckedCore context TyProp left + , ScopedCheckedCore context TyProp right + ) +splitScopedConjunction _scoped = + Nothing + closeScopedCore :: ScopedCheckedCore global -> Maybe (FrozenCheckedCore global) diff --git a/source/Checking/Datatype.hs b/source/Felix/Checking/Datatype.hs index a47f93d..66e64db 100644 --- a/source/Checking/Datatype.hs +++ b/source/Felix/Checking/Datatype.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NamedFieldPuns #-} -module Checking.Datatype +module Felix.Checking.Datatype ( CheckedDatatype , DatatypeValidationError , datatypeValidationErrorLocation @@ -16,9 +16,9 @@ module Checking.Datatype ) where import Base -import Report.Location -import Syntax.Internal -import Syntax.Lexicon +import Felix.Report.Location +import Felix.Syntax.Internal +import Felix.Syntax.Lexicon import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty diff --git a/source/Checking/Declaration.hs b/source/Felix/Checking/Declaration.hs index 65b7675..15050c7 100644 --- a/source/Checking/Declaration.hs +++ b/source/Felix/Checking/Declaration.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} -- | Builder-confined authorization and atomic typed declaration append. -module Checking.Declaration +module Felix.Checking.Declaration ( ModuleDriver , DriverFailure(..) , DriverResult(..) @@ -35,6 +35,7 @@ module Checking.Declaration , runProspectiveLoweringDriver , nextDeclarationSlotLowering , currentTheoryLowering + , currentFoundationLowering , currentFoundationAxiomLowering , resolveVisibleFactAliasLowering , resolveVisibleFactTargetsLowering @@ -51,8 +52,8 @@ module Checking.Declaration , failModuleDriver , failDeclarationDriver , VampireResolver + , VampireSubmission(..) , vampireBatchResolver - , vampireBatchResolverWithPreparationObserver , vampireResolver , vampireSubmissionResolver , Declaration @@ -71,6 +72,8 @@ module Checking.Declaration , checkedSourceAxiomPlanning , checkedDatatypePlanning , checkedKernelPlanning + , checkedKernelPlanningWithStaged + , checkedStagedKernelPlanning , checkedSourceProofPlanning , checkedOmittedPlanning , CheckedPlannedVampireRequest @@ -95,6 +98,9 @@ module Checking.Declaration , prepareCandidateSpecLowering , prepareFrozenCandidateSpecLowering , prepareDefinitionEquationSpecLowering + , prepareDefinitionEquationSpecWithEligibilityLowering + , prepareNamedSetConstructionSpecLowering + , prepareRelationalSetConstructionSpecLowering , preparePointwiseDefinitionEquationSpecLowering , prepareStagedCandidateVampireLowering , ReservedCandidate @@ -127,6 +133,8 @@ module Checking.Declaration , authorizeKernelProofCandidate , authorizeKernelConstructionCandidate , authorizeDefinitionEquationCandidate + , authorizeNamedSetConstructionCandidate + , authorizeRelationalSetConstructionCandidate , acceptVampireObligation , acceptPreparedVampireObligation , acceptCurrentCandidateVampire @@ -163,20 +171,21 @@ module Checking.Declaration ) where import Base -import Checking.Authority -import Checking.Backend.Problem qualified as Backend -import Checking.Backend.Tptp qualified as Tptp -import Checking.Core -import Checking.Foundation -import Checking.Identity -import Checking.Kernel.Derivation -import Checking.Semantic -import Checking.Materialization qualified as Materialization import Felix.Cache.Codec (encodeCache) +import Felix.Checking.Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Backend.Tptp qualified as Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction import Felix.Module -import Provers qualified -import Report.Location -import Syntax.Abstract (StructSymbol) +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract (StructSymbol) import Control.Exception qualified as Exception import Control.DeepSeq (deepseq) @@ -528,12 +537,14 @@ data VampireResolverMode Provers.ProverProcessError Provers.ProverAnswer))) | AsynchronousVampireSubmission - (NonEmpty Provers.PreparedVerificationRequest + (NonEmpty VampireSubmission -> IO (NonEmpty Provers.VampireHandle)) -data VampireResolver = VampireResolver - !VampireResolverMode - !(Word64 -> IO ()) +data VampireResolver = VampireResolver !VampireResolverMode + +data VampireSubmission = VampireSubmission + !Location + !Provers.PreparedVerificationRequest vampireBatchResolver :: (forall local origin. @@ -550,35 +561,16 @@ vampireBatchResolver Provers.ProverAnswer))) -> VampireResolver vampireBatchResolver resolve = - vampireBatchResolverWithPreparationObserver resolve (const (pure ())) - -vampireBatchResolverWithPreparationObserver - :: (forall local origin. - NonEmpty - (Provers.PreparedTypedProverTask - SemanticFactOccurrenceFingerprint - local - origin - ObjectId) - -> IO - (NonEmpty - (Either - Provers.ProverProcessError - Provers.ProverAnswer))) - -> (Word64 -> IO ()) - -> VampireResolver -vampireBatchResolverWithPreparationObserver resolve observe = - VampireResolver (SynchronousVampireResolution resolve) observe + VampireResolver (SynchronousVampireResolution resolve) -- | Production submission-only resolver. Retained-plan admission consumes -- the submitted handles through its private synchronous replay resolver. vampireSubmissionResolver - :: (NonEmpty Provers.PreparedVerificationRequest + :: (NonEmpty VampireSubmission -> IO (NonEmpty Provers.VampireHandle)) - -> (Word64 -> IO ()) -> VampireResolver -vampireSubmissionResolver submit observe = - VampireResolver (AsynchronousVampireSubmission submit) observe +vampireSubmissionResolver submit = + VampireResolver (AsynchronousVampireSubmission submit) vampireResolver :: (forall local origin. @@ -628,7 +620,7 @@ resolveSynchronousVampireBatch Provers.ProverProcessError Provers.ProverAnswer)) resolveSynchronousVampireBatch - (VampireResolver mode _observe) tasks = + (VampireResolver mode) tasks = case mode of SynchronousVampireResolution resolve -> resolve tasks AsynchronousVampireSubmission{} -> @@ -636,12 +628,6 @@ resolveSynchronousVampireBatch (PlanningIntegrityError "asynchronous Vampire resolver reached synchronous admission") -observeVampirePreparation - :: VampireResolver - -> Word64 - -> IO () -observeVampirePreparation (VampireResolver _mode observe) = observe - validateVampireResolverResultCount :: Int -> NonEmpty value @@ -1338,6 +1324,10 @@ currentTheoryLowering :: LoweringDriver TheoryId currentTheoryLowering = withLoweringBuilder logicalBuilderTheory +currentFoundationLowering :: LoweringDriver CheckedFoundation +currentFoundationLowering = + withLoweringBuilder logicalBuilderFoundation + currentFoundationAxiomLowering :: FoundationAxiomTag -> LoweringDriver (FrozenCheckedCore Void) @@ -1515,6 +1505,29 @@ checkedKernelPlanning descriptor facts = [] [] +checkedKernelPlanningWithStaged + :: KernelConstructionDescriptor + -> [SemanticFactOccurrenceFingerprint] + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedKernelPlanningWithStaged descriptor facts staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + facts + staged + [] + +checkedStagedKernelPlanning + :: KernelConstructionDescriptor + -> [PlannedCandidatePosition] + -> CandidatePlanningSpec +checkedStagedKernelPlanning descriptor staged = + CandidatePlanningSpec + (PlanningKernelConstruction descriptor) + [] + staged + [] + checkedSourceProofPlanning :: [CheckedPlannedVampireRequest] -> [PlannedCandidatePosition] @@ -1672,9 +1685,74 @@ prepareDefinitionEquationSpecLowering -> SemanticName -> LoweringDriver (Either DeclarationError CandidateSpec) prepareDefinitionEquationSpecLowering objects identity alias = + prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibilityLowering + :: [AssertedObject] + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> LoweringDriver (Either DeclarationError CandidateSpec) +prepareDefinitionEquationSpecWithEligibilityLowering + objects identity eligibility alias = prepareCandidateSpecWithLoweringClosure objects (\closure -> - prepareDefinitionEquationSpec closure identity alias) + prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias) + +-- | Prepare the unaliased first-order view of one checked, named set +-- construction. The returned descriptor binds direct authorization to the +-- transparent object and the complete checked source decomposition. +prepareNamedSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> NamedSetConstruction ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareNamedSetConstructionSpecLowering objects identity construction = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareNamedSetConstruction + (logicalBuilderFoundation builder) + closure identity construction + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) + +prepareRelationalSetConstructionSpecLowering + :: [AssertedObject] + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> LoweringDriver + (Either + DeclarationError + (CandidateSpec, KernelConstructionDescriptor)) +prepareRelationalSetConstructionSpecLowering + objects identity construction functionality = + withLoweringBuilder \builder -> do + closure <- + first DeclarationObjectValidationFailed + (extendObjectClosure + (logicalBuilderObjectClosure builder) + objects) + (proposition, descriptor) <- + prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + closure identity construction functionality + spec <- + prepareFrozenCandidateSpec + closure proposition SearchEligible [] + pure (spec, descriptor) preparePointwiseDefinitionEquationSpecLowering :: [AssertedObject] @@ -1703,11 +1781,11 @@ prepareStagedCandidateVampireDriver prepareStagedCandidateVampireDriver location objects premiseSpec targetSpec = ModuleDriver do - DriverState resolver builder _prefix _validation <- State.get + DriverState _resolver builder _prefix _validation <- State.get State.lift (liftIO (prepareStagedCandidateVampireWith - resolver builder location objects premiseSpec targetSpec)) + builder location objects premiseSpec targetSpec)) prepareStagedCandidateVampireLowering :: Location @@ -1721,15 +1799,14 @@ prepareStagedCandidateVampireLowering prepareStagedCandidateVampireLowering location objects premiseSpec targetSpec = LoweringDriver do - LoweringState resolver (ProspectiveBuilder builder) _validation <- + LoweringState _resolver (ProspectiveBuilder builder) _validation <- State.get liftIO (prepareStagedCandidateVampireWith - resolver builder location objects premiseSpec targetSpec) + builder location objects premiseSpec targetSpec) prepareStagedCandidateVampireWith - :: VampireResolver - -> BuilderState evidence + :: BuilderState evidence -> Location -> [AssertedObject] -> CandidateSpec @@ -1739,7 +1816,7 @@ prepareStagedCandidateVampireWith DeclarationError (PreparedVampireObligation Void ())) prepareStagedCandidateVampireWith - resolver builder location objects premiseSpec targetSpec = do + builder location objects premiseSpec targetSpec = do let staged = do closure <- first DeclarationObjectValidationFailed @@ -1754,7 +1831,7 @@ prepareStagedCandidateVampireWith Left failure -> pure (Left failure) Right (closure, premise) -> do prepared <- - measureVampirePreparation resolver + forceVampirePreparation (prepareClosedCandidateVampire builder closure (candidateSpecProposition targetSpec) @@ -1860,8 +1937,8 @@ prepareCandidateSpecWithDriverClosure objects prepare = ModuleDriver do prepareCandidateSpecWithLoweringClosure :: [AssertedObject] - -> (CheckedObjectClosure -> Either DeclarationError CandidateSpec) - -> LoweringDriver (Either DeclarationError CandidateSpec) + -> (CheckedObjectClosure -> Either DeclarationError value) + -> LoweringDriver (Either DeclarationError value) prepareCandidateSpecWithLoweringClosure objects prepare = withLoweringBuilder \builder -> do closure <- @@ -2100,6 +2177,17 @@ prepareDefinitionEquationSpec -> SemanticName -> Either DeclarationError CandidateSpec prepareDefinitionEquationSpec closure identity alias = do + prepareDefinitionEquationSpecWithEligibility + closure identity SearchEligible alias + +prepareDefinitionEquationSpecWithEligibility + :: CheckedObjectClosure + -> ObjectId + -> FactSearchEligibility + -> SemanticName + -> Either DeclarationError CandidateSpec +prepareDefinitionEquationSpecWithEligibility + closure identity eligibility alias = do content <- maybe (Left (DefinitionEquationObjectMissing identity)) @@ -2116,7 +2204,70 @@ prepareDefinitionEquationSpec closure identity alias = do (validatePropositionContent closure (CEq coreType (CGlobal identity) body)) - pure (candidateSpec proposition SearchEligible [alias]) + pure (candidateSpec proposition eligibility [alias]) + +prepareNamedSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> NamedSetConstruction ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareNamedSetConstruction foundation closure identity construction = do + let expectedContent = namedSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction) + pure + ( namedSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (namedSetConstructionFactDescriptor derived) + ) + +prepareRelationalSetConstruction + :: CheckedFoundation + -> CheckedObjectClosure + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Either + DeclarationError + (FrozenCheckedCore ObjectId, KernelConstructionDescriptor) +prepareRelationalSetConstruction + foundation closure identity construction functionality = do + let expectedContent = relationalSetConstructionClosedBody construction + case lookupCheckedObjectContent identity closure of + Just (TransparentObjectContent _theory coreType body) + | coreType == frozenCoreType expectedContent + , body == frozenCoreTerm expectedContent -> pure () + _ -> Left KernelConstructionDescriptorMismatch + derived <- + maybe + (Left KernelConstructionDescriptorMismatch) + Right + (relationalSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + identity + construction + functionality) + pure + ( relationalSetConstructionFactProposition derived + , CheckedSetConstructionExtensionality + identity + (relationalSetConstructionFactDescriptor derived) + ) preparePointwiseDefinitionEquationSpec :: CheckedObjectClosure @@ -2712,11 +2863,11 @@ prepareScopedVampireObligationForModeLowering prepareScopedVampireObligationForModeLowering taskMode claimSupport claim scopedLocals auxiliaryTags selection = LoweringDriver do - LoweringState resolver (ProspectiveBuilder builder) _validation <- + LoweringState _resolver (ProspectiveBuilder builder) _validation <- State.get liftIO (prepareScopedVampireObligationWith - resolver builder taskMode claimSupport claim scopedLocals + builder taskMode claimSupport claim scopedLocals auxiliaryTags selection) prepareScopedVampireObligationForMode @@ -2734,17 +2885,16 @@ prepareScopedVampireObligationForMode prepareScopedVampireObligationForMode taskMode claimSupport claim scopedLocals auxiliaryTags selection = ModuleDriver do - DriverState resolver builder _prefix _validation <- State.get + DriverState _resolver builder _prefix _validation <- State.get State.lift (Except.liftIO (prepareScopedVampireObligationWith - resolver builder taskMode claimSupport claim scopedLocals + builder taskMode claimSupport claim scopedLocals auxiliaryTags selection)) prepareScopedVampireObligationWith :: (Ord local) - => VampireResolver - -> BuilderState evidence + => BuilderState evidence -> Provers.VampireTaskMode -> Vector (local, CoreType) -> ScopedCheckedCore ObjectId @@ -2756,9 +2906,9 @@ prepareScopedVampireObligationWith (VampireObligationPreparationError local) (PreparedVampireObligation local origin)) prepareScopedVampireObligationWith - resolver builder taskMode claimSupport claim scopedLocals + builder taskMode claimSupport claim scopedLocals auxiliaryTags selection = - measureVampirePreparation resolver preparation + forceVampirePreparation preparation where closure = logicalBuilderObjectClosure builder globalType = (`lookupCheckedObjectType` closure) @@ -2817,20 +2967,30 @@ prepareVampireObligationWith globalType builder selection - let (globalMode, localPolicy) = + let localPremisePolicy = case selection of VampireImplicitPremises -> - ( Backend.ImplicitFofPremises - , Backend.FirstOrderLocals - ) + Backend.FirstOrderLocals + VampireExplicitPremises{} + | any + (\fact -> + case Backend.typedBackendFactCapability fact of + Backend.FofProjectable{} -> False + Backend.RequiresTh0{} -> True) + selected -> + Backend.CompleteLocals + | otherwise -> + Backend.FirstOrderLocals + VampireLocalPremises -> + Backend.CompleteLocals + higherOrderPolicy = + case selection of + VampireImplicitPremises -> + Backend.ImplicitConstructionJustification VampireExplicitPremises{} -> - ( Backend.ExplicitGlobalPremises - , Backend.FirstOrderLocals - ) + Backend.ExplicitHigherOrderJustification VampireLocalPremises -> - ( Backend.NoGlobalPremises - , Backend.AllLocals - ) + Backend.ExplicitHigherOrderJustification propositionDependencies = foundationAxiomDependencies . Backend.supportedPropositionTerm @@ -2846,7 +3006,7 @@ prepareVampireObligationWith (propositionDependencies . Backend.typedLocalPremiseProposition) (Backend.selectTypedLocalPremises - localPolicy + localPremisePolicy locals) ) auxiliaries = @@ -2861,8 +3021,8 @@ prepareVampireObligationWith claim locals auxiliaries - globalMode - localPolicy) + localPremisePolicy + higherOrderPolicy) task <- first VampireObligationEncodingFailed (Provers.prepareTypedProverTask @@ -2870,21 +3030,16 @@ prepareVampireObligationWith problem) pure (PreparedVampireObligation problem task) -measureVampirePreparation - :: VampireResolver - -> Either +forceVampirePreparation + :: Either (VampireObligationPreparationError local) (PreparedVampireObligation local origin) -> IO (Either (VampireObligationPreparationError local) (PreparedVampireObligation local origin)) -measureVampirePreparation resolver preparation = do - started <- getMonotonicTimeNSec - prepared <- Exception.evaluate (forcePrepared preparation) - finished <- getMonotonicTimeNSec - observeVampirePreparation resolver (finished - started) - pure prepared +forceVampirePreparation preparation = + Exception.evaluate (forcePrepared preparation) where forcePrepared result = case result of @@ -3617,6 +3772,81 @@ authorizeDefinitionEquationCandidate identity candidate = (candidateProofSafety initial) initial +-- | Authorize only the extensional fact deterministically derived from the +-- checked source construction and its committed transparent object. +authorizeNamedSetConstructionCandidate + :: ObjectId + -> NamedSetConstruction ObjectId + -> ReservedCandidate + -> Declaration () +authorizeNamedSetConstructionCandidate identity construction candidate = + authorizeOneCandidate candidate \initial -> do + let builder = candidateProofBuilder initial + (expected, descriptor) <- + Except.liftEither + (prepareNamedSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure initial) + identity + construction) + when (isNothing (candidateProofCachedValidation initial)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate)) + ) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety initial) + initial + +-- | Authorize the relational extensional view only after consuming the exact +-- strictly-earlier functionality candidate. The consumed candidate supplies +-- both real authority safety and the proposition rechecked by the confined +-- construction schema; a caller cannot substitute an arbitrary theorem. +authorizeRelationalSetConstructionCandidate + :: ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> ReservedCandidate + -> ReservedCandidate + -> Declaration () +authorizeRelationalSetConstructionCandidate + identity construction functionality candidate = + authorizeOneCandidate candidate \initial -> do + (_used, final) <- + State.runStateT + (runCandidateProof (useStagedCandidate functionality)) + initial + let builder = candidateProofBuilder final + functionalityTerm = + checkedPropositionTerm + (candidateCheckedProposition functionality) + (expected, descriptor) <- + Except.liftEither + (prepareRelationalSetConstruction + (logicalBuilderFoundation builder) + (candidateProofObjectClosure final) + identity + construction + functionalityTerm) + when (isNothing (candidateProofCachedValidation final)) do + unless + (frozenCoreTerm expected + == frozenCoreTerm + (checkedPropositionTerm + (candidateCheckedProposition candidate))) + (Except.throwError + KernelConstructionDescriptorMismatch) + completeCandidateWithValidation + candidate + (CheckedKernelConstruction descriptor) + (candidateProofSafety final) + final + authorizeSourceAxiomCandidate :: ReservedCandidate -> Declaration () @@ -3770,16 +4000,13 @@ prepareCurrentCandidateVampire = CandidateProof do | CandidatePremise proposition <- reverse (candidateProofPremisesReversed initial) ] - resolver = - declarationVampireResolver - (candidateProofDeclaration initial) preparation = prepareClosedCandidateVampire builder closure target premises preparedResult <- State.lift (liftIO - (measureVampirePreparation resolver preparation)) + (forceVampirePreparation preparation)) prepared <- State.lift (Except.liftEither @@ -4685,6 +4912,8 @@ validateKernelConstruction descriptor proposition replayed proofState = && noFoundation && noRules && matchesDefinitionEquation identity proposition proofState + CheckedSetConstructionExtensionality{} -> + False matchesDefinitionEquation :: ObjectId @@ -5342,17 +5571,17 @@ submitPlannedCandidates resolver selection candidates pure (fmap (fmap cachedCandidate) candidates) | otherwise = do let requests = - [ request + [ VampireSubmission location request | stage <- candidates , (_candidate, plannedRequests) <- toList stage , CheckedPlannedVampireRequest - _location request _facts <- plannedRequests + location request _facts <- plannedRequests ] case resolver of - VampireResolver SynchronousVampireResolution{} _observe -> + VampireResolver SynchronousVampireResolution{} -> pure (fmap (fmap synchronousCandidate) candidates) VampireResolver - (AsynchronousVampireSubmission submit) _observe -> do + (AsynchronousVampireSubmission submit) -> do handles <- case NonEmpty.nonEmpty requests of Nothing -> pure [] Just nonempty -> do @@ -5582,9 +5811,7 @@ plannedReplayResolver -> IORef [PlannedReplayRequest] -> IO VampireResolver plannedReplayResolver original liveRef = - pure - (vampireBatchResolverWithPreparationObserver resolve - (observeVampirePreparation original)) + pure (vampireBatchResolver resolve) where resolve :: forall local origin. diff --git a/source/Checking/Exact.hs b/source/Felix/Checking/Exact.hs index ebd01bc..c829743 100644 --- a/source/Checking/Exact.hs +++ b/source/Felix/Checking/Exact.hs @@ -2,20 +2,26 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Direct compiler for the first exact monomorphic declaration family. -module Checking.Exact +module Felix.Checking.Exact ( ExactLocalId , exactLocalId , exactLocalIdValue , ExactBinderContext , emptyExactBinderContext , extendExactBinderContext + , extendExactAnonymousBinderContext , exactBinderContextSupport , exactBinderContextIndex , PreparedExactProposition , preparedExactPropositionCore , prepareExactProposition + , prepareExactSymbolicBoundConstraints + , prepareExactSymbolicWitnessConstraints + , prepareExactNounWitnessConstraints , PreparedExactSetExpression + , PreparedExactSetConstruction(..) , preparedExactSetExpressionCore + , preparedExactSetExpressionConstruction , prepareExactSetExpression , PreparedExactLocalFunctionGraph , preparedExactLocalFunctionGraphCore @@ -37,6 +43,7 @@ module Checking.Exact , preparedExactIsDefinition , prepareExactDeclaration , lowerPreparedExactBinding + , CheckedExactBindingAuthorization , authorizeCheckedExactBinding , PreparedExactStructure , prepareExactStructure @@ -53,17 +60,18 @@ module Checking.Exact ) where import Base hiding (Empty) -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.Semantic import Felix.Cache.Codec +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.SetConstruction import Felix.Module -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface (CanonicalLexicalEntry(..)) -import Syntax.Lexicon qualified as Lexicon +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface (CanonicalLexicalEntry(..)) +import Felix.Syntax.Lexicon qualified as Lexicon import Control.Monad.Except (ExceptT) import Control.Monad.Except (MonadError, throwError) @@ -95,7 +103,7 @@ exactLocalIdValue (ExactLocalId value) = value data ExactBinder = ExactBinder !ExactLocalId - !Raw.VarSymbol + !(Maybe Raw.VarSymbol) !CoreType !(Maybe ExactStructureAnnotation) @@ -123,14 +131,33 @@ extendExactBinderContext additions (ExactBinderContext initial) = | any (sameIdentity identity) binders = Left (ExactDuplicateLocalIdentity (locate variable) identity) | otherwise = - Right (ExactBinder identity variable TySet Nothing : binders) + Right (ExactBinder identity (Just variable) TySet Nothing : binders) sameVariable variable (ExactBinder _identity existing _coreType _structure) = - existing == variable + existing == Just variable sameIdentity identity (ExactBinder existing _variable _coreType _structure) = existing == identity +-- | Add one proof-owned binder which deliberately has no source-resolvable +-- spelling. This is used for a nameless singular witness; it participates in +-- checked support and de Bruijn weakening but cannot shadow or be looked up by +-- a later source variable. +extendExactAnonymousBinderContext + :: ExactLocalId + -> ExactBinderContext + -> Either ExactCompileError ExactBinderContext +extendExactAnonymousBinderContext identity (ExactBinderContext binders) + | any sameIdentity binders = + Left (ExactDuplicateLocalIdentity Nowhere identity) + | otherwise = + Right + (ExactBinderContext + (ExactBinder identity Nothing TySet Nothing : binders)) + where + sameIdentity (ExactBinder existing _variable _coreType _structure) = + existing == identity + exactBinderContextSupport :: ExactBinderContext -> Vector (ExactLocalId, CoreType) @@ -150,7 +177,7 @@ exactBinderContextIndex variable (ExactBinderContext binders) = go _index [] = Nothing go index (ExactBinder _identity candidate _coreType _structure : rest) - | candidate == variable = Just index + | candidate == Just variable = Just index | otherwise = go (index + 1) rest newtype PreparedExactProposition = PreparedExactProposition @@ -162,15 +189,29 @@ preparedExactPropositionCore preparedExactPropositionCore (PreparedExactProposition proposition) = proposition -newtype PreparedExactSetExpression = PreparedExactSetExpression - (ScopedCheckedCore ObjectId) +data PreparedExactSetExpression = PreparedExactSetExpression + !(ScopedCheckedCore ObjectId) + !(Maybe PreparedExactSetConstruction) + +data PreparedExactSetConstruction + = PreparedUnconditionalSetConstruction + !(NamedSetConstruction ObjectId) + | PreparedRelationalSetConstruction + !(CheckedRelationalSetConstruction ObjectId) preparedExactSetExpressionCore :: PreparedExactSetExpression -> ScopedCheckedCore ObjectId -preparedExactSetExpressionCore (PreparedExactSetExpression expression) = +preparedExactSetExpressionCore (PreparedExactSetExpression expression _construction) = expression +preparedExactSetExpressionConstruction + :: PreparedExactSetExpression + -> Maybe PreparedExactSetConstruction +preparedExactSetExpressionConstruction + (PreparedExactSetExpression _expression construction) = + construction + -- | A checked replacement graph and the two checked arguments used to -- specialize its foundation characteristic. This is transient proof -- preparation data, not a declaration or durable object. @@ -251,40 +292,41 @@ data PreparedExactDeclaration = PreparedExactDeclaration !SemanticGlobalTarget !(Maybe AssertedObject) !(Maybe SemanticName) + !(Maybe PreparedExactSetConstruction) !DeclarationSyntaxId preparedExactLocation :: PreparedExactDeclaration -> Location preparedExactLocation - (PreparedExactDeclaration location _family _key _target _object _alias _syntax) = + (PreparedExactDeclaration location _family _key _target _object _alias _construction _syntax) = location preparedExactGlobalKey :: PreparedExactDeclaration -> SemanticGlobalKey preparedExactGlobalKey - (PreparedExactDeclaration _location _family key _target _object _alias _syntax) = + (PreparedExactDeclaration _location _family key _target _object _alias _construction _syntax) = key preparedExactObjectId :: PreparedExactDeclaration -> ObjectId preparedExactObjectId - (PreparedExactDeclaration _location _family _key target _object _alias _syntax) = + (PreparedExactDeclaration _location _family _key target _object _alias _construction _syntax) = semanticGlobalTargetObject target preparedExactObject :: PreparedExactDeclaration -> Maybe AssertedObject preparedExactObject - (PreparedExactDeclaration _location _family _key _target object _alias _syntax) = + (PreparedExactDeclaration _location _family _key _target object _alias _construction _syntax) = object preparedExactSyntaxId :: PreparedExactDeclaration -> DeclarationSyntaxId preparedExactSyntaxId - (PreparedExactDeclaration _location _family _key _target _object _alias syntax) = + (PreparedExactDeclaration _location _family _key _target _object _alias _construction syntax) = syntax preparedExactIsDefinition :: PreparedExactDeclaration -> Bool preparedExactIsDefinition - (PreparedExactDeclaration _location family _key _target _object _alias _syntax) = + (PreparedExactDeclaration _location family _key _target _object _alias _construction _syntax) = family == ExactDefinition preparedExactGlobalTarget @@ -292,7 +334,7 @@ preparedExactGlobalTarget -> SemanticGlobalTarget preparedExactGlobalTarget (PreparedExactDeclaration - _location _family _key target _object _alias _syntax) = + _location _family _key target _object _alias _construction _syntax) = target preparedDefinitionAlias @@ -300,9 +342,17 @@ preparedDefinitionAlias -> Maybe SemanticName preparedDefinitionAlias (PreparedExactDeclaration - _location _family _key _target _object alias _syntax) = + _location _family _key _target _object alias _construction _syntax) = alias +preparedDefinitionConstruction + :: PreparedExactDeclaration + -> Maybe PreparedExactSetConstruction +preparedDefinitionConstruction + (PreparedExactDeclaration + _location _family _key _target _object _alias construction _syntax) = + construction + data PreparedExactSourceAxiom = PreparedExactSourceAxiom !Location !SemanticName @@ -331,6 +381,11 @@ data CheckedExactStructureAuthorization = data ExactCompileError = ExactUnsupportedDeclaration !Location | ExactUnsupportedDeclarationBody !Location + | ExactNonCanonicalSetDefinitionAnnotation !Location + | ExactGuardedTransparentDefinition !Location + | ExactGuardedOpaqueSignature !Location + | ExactDefinitionCombinedSymbolicAlias !Location + | ExactRelationalReplacementRequiresNamedDefinition !Location | ExactDeclarationOccurrenceMissing !Location | ExactDeclarationOccurrenceAmbiguous !Location | ExactDeclarationHeadMismatch !Location @@ -349,7 +404,7 @@ data ExactCompileError | ExactCoreCheckFailed !Location !CoreCheckError | ExactObjectTypeMismatch !Location !CoreType !CoreType | ExactUnsupportedHeaderAssumption !Location - | ExactQuantifiedTermRequiresStatementSubject !Location + | ExactQuantifiedTermRequiresPropositionContext !Location | ExactStructureNotVisible !Location !SemanticStructurePhrase | ExactBaseStructureNotAssertable !Location !SemanticStructurePhrase | ExactDuplicateStructureAnnotation !Location !Raw.VarSymbol @@ -378,6 +433,11 @@ exactCompileErrorLocation :: ExactCompileError -> Location exactCompileErrorLocation = \case ExactUnsupportedDeclaration location -> location ExactUnsupportedDeclarationBody location -> location + ExactNonCanonicalSetDefinitionAnnotation location -> location + ExactGuardedTransparentDefinition location -> location + ExactGuardedOpaqueSignature location -> location + ExactDefinitionCombinedSymbolicAlias location -> location + ExactRelationalReplacementRequiresNamedDefinition location -> location ExactDeclarationOccurrenceMissing location -> location ExactDeclarationOccurrenceAmbiguous location -> location ExactDeclarationHeadMismatch location -> location @@ -395,7 +455,7 @@ exactCompileErrorLocation = \case ExactCoreCheckFailed location _failure -> location ExactObjectTypeMismatch location _expected _actual -> location ExactUnsupportedHeaderAssumption location -> location - ExactQuantifiedTermRequiresStatementSubject location -> location + ExactQuantifiedTermRequiresPropositionContext location -> location ExactStructureNotVisible location _phrase -> location ExactBaseStructureNotAssertable location _phrase -> location ExactDuplicateStructureAnnotation location _variable -> location @@ -420,6 +480,25 @@ renderExactCompileError = \case at location <> "this declaration is not yet supported by the typed checker" ExactUnsupportedDeclarationBody location -> at location <> "this source form is not yet supported by exact elaboration" + ExactNonCanonicalSetDefinitionAnnotation location -> + at location + <> "only the unmodified built-in noun `set` is a harmless definition annotation; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedTransparentDefinition location -> + at location + <> "a transparent definition cannot have a header assumption; " + <> "state a total condition in the definiens, or, where a corresponding opaque signature form exists, use it with a following explicit axiom; otherwise migrate the spelling or leave it unsupported" + ExactGuardedOpaqueSignature location -> + at location + <> "an opaque signature cannot have a header assumption; " + <> "state the condition in a following explicit axiom" + ExactDefinitionCombinedSymbolicAlias location -> + at location + <> "a functional definition cannot declare a symbolic equivalent at the same time; " + <> "define the symbolic operator first, then define the functional phrase as an abbreviation applying it" + ExactRelationalReplacementRequiresNamedDefinition location -> + at location + <> "relational replacement is supported only as the outer body of a named definition" ExactDeclarationOccurrenceMissing location -> at location <> "the declaration has no associated syntax occurrence" ExactDeclarationOccurrenceAmbiguous location -> @@ -457,9 +536,9 @@ renderExactCompileError = \case <> " instead of " <> shown expected ExactUnsupportedHeaderAssumption location -> at location <> "this top-level header assumption is not yet supported by exact elaboration" - ExactQuantifiedTermRequiresStatementSubject location -> + ExactQuantifiedTermRequiresPropositionContext location -> at location - <> "a quantified term must be the sole subject of an exact statement" + <> "a quantified term requires a containing proposition" ExactStructureNotVisible location structurePhrase -> at location <> "the structure " <> shown structurePhrase <> " is not visible" ExactBaseStructureNotAssertable location structurePhrase -> @@ -517,6 +596,9 @@ renderExactCompileError = \case data ElaborationState = ElaborationState { elaborationBinders :: !(Map.Map Raw.VarSymbol Natural) + -- Counts every active de Bruijn binder, including anonymous and + -- contextual binders which have no entry in 'elaborationBinders'. + , elaborationBinderDepth :: !Natural , elaborationStructures :: !(Map.Map Natural ExactStructureAnnotation) , elaborationGlobals :: !(Map.Map ObjectId CoreType) , elaborationContextualBinder :: !(Maybe Natural) @@ -536,27 +618,117 @@ data PreparedHead = PreparedHead data PreparedBody = OpaqueBody - | TransparentBody !(CanonicalTerm ObjectId) + | TransparentBody + !(CanonicalTerm ObjectId) + !(Maybe PreparedExactSetConstruction) | ContextualTransparentBody !(Map.Map Raw.StructSymbol ObjectId) !(CanonicalTerm ObjectId) +data CompiledBody = CompiledBody + !(CanonicalTerm ObjectId) + !(Maybe CompiledNamedSetConstruction) + +data CompiledNamedSetConstruction + = CompiledSeparationConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + | CompiledFunctionalReplacementConstruction + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + | CompiledRelationalReplacementConstruction + !(CanonicalTerm ObjectId) + !(CanonicalTerm ObjectId) + prepareExactProposition :: ExactBinderContext -> Raw.Stmt -> Declaration.LoweringDriver (Either ExactCompileError PreparedExactProposition) prepareExactProposition context statement = + prepareExactPropositionTerm + context + (locate statement) + (compileStatement statement) + +-- | Compile the source bound of already-opened symbolic binders. This is the +-- shared checked constraint seam used by quantified statements and proof +-- binders, so relation signs, carrier casts, and global occurrences are +-- elaborated exactly once by the ordinary expression compiler. +prepareExactSymbolicBoundConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicBoundConstraints context variables bound = + prepareExactPropositionTerm + context + (case bound of + Raw.Unbounded -> locate (NonEmpty.head variables) + _ -> locate bound) + (logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound) + +-- | Compile the opened body used by a symbolic existential witness. Its +-- grouping is deliberately identical to 'SymbolicExists': all bound +-- constraints form the existential restriction and the stated proposition is +-- its body. +prepareExactSymbolicWitnessConstraints + :: ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactSymbolicWitnessConstraints context variables bound statement = + prepareExactPropositionTerm context (locate statement) do + constraints <- + logicalConjunction + <$> compileSymbolicBoundConstraintList variables bound + body <- compileStatement statement + pure + (if constraints == logicalTruth + then body + else logicalAnd constraints body) + +-- | Compile the checked constraint of an already-opened noun witness. Named +-- binders are resolved normally; a nameless singular noun uses the nearest +-- anonymous binder and therefore introduces no lookup spelling. +prepareExactNounWitnessConstraints + :: ExactBinderContext + -> Raw.NounPhrase [] + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactNounWitnessConstraints context nounPhrase = + case nounPhrase of + Raw.NounPhrase left noun variables right suchThat -> + prepareExactPropositionTerm context (locate noun) do + subjects <- + case NonEmpty.nonEmpty variables of + Just binders -> + toList + <$> traverse compileIntroducedVariable binders + Nothing -> + pure [CBound 0] + compileNounPhraseConstraints + subjects left noun right suchThat + +prepareExactPropositionTerm + :: ExactBinderContext + -> Location + -> Elaborate (CanonicalTerm ObjectId) + -> Declaration.LoweringDriver + (Either ExactCompileError PreparedExactProposition) +prepareExactPropositionTerm context location compile = Except.runExceptT do let initialElaboration = initialElaborationState context (term, finalElaboration) <- - State.runStateT - (compileStatement statement) - initialElaboration + State.runStateT compile initialElaboration checked <- either - (Except.throwError - . ExactCoreCheckFailed (locate statement)) + (Except.throwError . ExactCoreCheckFailed location) pure (checkScopedCanonicalCore (`Map.lookup` elaborationGlobals finalElaboration) @@ -565,7 +737,7 @@ prepareExactProposition context statement = unless (scopedCoreType checked == TyProp) (Except.throwError (ExactFormulaExpectedProposition - (locate statement) + location (scopedCoreType checked))) pure (PreparedExactProposition checked) @@ -577,10 +749,11 @@ prepareExactSetExpression prepareExactSetExpression context expression = Except.runExceptT do let initialElaboration = initialElaborationState context - (term, finalElaboration) <- + (compiled, finalElaboration) <- State.runStateT - (compileExpressionAsSet expression) + (compileNamedSetExpression expression) initialElaboration + let CompiledBody term rawConstruction = compiled checked <- either (Except.throwError @@ -595,7 +768,107 @@ prepareExactSetExpression context expression = (ExactExpressionExpectedSet (locate expression) (scopedCoreType checked))) - pure (PreparedExactSetExpression checked) + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` elaborationGlobals finalElaboration) + (binderTypes context)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (preparedSetConstructionTerm checkedConstruction == checked) + (impossible + "exact named construction disagrees with its checked expression")) + construction + pure (PreparedExactSetExpression checked construction) + +checkCompiledNamedSetConstruction + :: (ObjectId -> Maybe CoreType) + -> [CoreType] + -> CompiledNamedSetConstruction + -> Either ExactCompileError PreparedExactSetConstruction +checkCompiledNamedSetConstruction globalType context = \case + CompiledSeparationConstruction bound predicate -> do + checkedBound <- checkAt context TySet bound + checkedPredicate <- checkAt (TySet : context) TyProp predicate + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedSeparationConstruction + globalType checkedBound checkedPredicate) + CompiledFunctionalReplacementConstruction domains value condition -> do + let domainList = NonEmpty.toList domains + fullContext = replicate (length domainList) TySet <> context + checkedDomains <- + traverse + (\(depth, domain) -> + checkAt + (replicate depth TySet <> context) + TySet + domain) + (zip [0..] domainList) + checkedValue <- checkAt fullContext TySet value + checkedCondition <- traverse (checkAt fullContext TyProp) condition + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedUnconditionalSetConstruction) + (checkedFunctionalReplacementConstruction + globalType + (NonEmpty.fromList checkedDomains) + checkedValue + checkedCondition) + CompiledRelationalReplacementConstruction domain relation -> do + checkedDomain <- checkAt context TySet domain + checkedRelation <- checkAt (TySet : TySet : context) TyProp relation + maybe + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType TySet TyProp))) + (Right . PreparedRelationalSetConstruction) + (checkedRelationalReplacementConstruction + globalType checkedDomain checkedRelation) + where + checkAt expectedContext expectedType term = do + checked <- + first + (ExactCoreCheckFailed Nowhere) + (checkScopedCanonicalCore globalType expectedContext term) + unless + (scopedCoreType checked == expectedType) + (Left + (ExactCoreCheckFailed + Nowhere + (ExpectedCoreType + expectedType + (scopedCoreType checked)))) + pure checked + +preparedSetConstructionTerm + :: PreparedExactSetConstruction + -> ScopedCheckedCore ObjectId +preparedSetConstructionTerm = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionTerm construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionTerm construction + +preparedSetConstructionClosedBody + :: PreparedExactSetConstruction + -> FrozenCheckedCore ObjectId +preparedSetConstructionClosedBody = \case + PreparedUnconditionalSetConstruction construction -> + namedSetConstructionClosedBody construction + PreparedRelationalSetConstruction construction -> + relationalSetConstructionClosedBody construction prepareExactLocalFunctionGraph :: Location @@ -786,7 +1059,7 @@ binderIndices :: ExactBinderContext -> Map.Map Raw.VarSymbol Natural binderIndices (ExactBinderContext binders) = Map.fromList [ (variable, fromIntegral index) - | (index, ExactBinder _identity variable _coreType _structure) <- + | (index, ExactBinder _identity (Just variable) _coreType _structure) <- zip [0 :: Int ..] binders ] @@ -809,11 +1082,14 @@ binderTypes (ExactBinderContext binders) = initialElaborationState :: ExactBinderContext -> ElaborationState initialElaborationState context = ElaborationState - (binderIndices context) - (binderStructures context) - mempty - Nothing - mempty + { elaborationBinders = binderIndices context + , elaborationBinderDepth = + fromIntegral (length (binderTypes context)) + , elaborationStructures = binderStructures context + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } annotateBinderContext :: Map.Map Natural ExactStructureAnnotation @@ -849,18 +1125,17 @@ compileHeaderAssumption = \case ] Raw.AsmLetIn variables domain -> do variableTerms <- traverse compileIntroducedVariable variables - domainTerm <- - compileExpressionAsSet domain - >>= structureCarrierCast (locate domain) - pure - [ ( locate variable - , CApp - (CApp (CIntrinsic Member) variableTerm) - domainTerm - ) - | (variable, variableTerm) <- - zip (toList variables) (toList variableTerms) - ] + domainTerm <- compileExpressionAsSet domain + traverse + (\(variable, variableTerm) -> do + proposition <- + compileMembership + (locate domain) + Raw.Positive + variableTerm + domainTerm + pure (locate variable, proposition)) + (zip (toList variables) (toList variableTerms)) Raw.AsmLetEq variable expression -> do variableTerm <- compileIntroducedVariable variable expressionTerm <- compileExpressionAsSet expression @@ -1072,14 +1347,39 @@ prepareExactDeclaration block entries = Just buildBody -> do let initialElaboration = ElaborationState - mempty mempty mempty Nothing mempty - (canonical, finalElaboration) <- + { elaborationBinders = mempty + , elaborationBinderDepth = 0 + , elaborationStructures = mempty + , elaborationGlobals = mempty + , elaborationContextualBinder = Nothing + , elaborationContextualRequirements = mempty + } + (CompiledBody canonical rawConstruction, finalElaboration) <- State.runStateT buildBody initialElaboration + let PreparedHead _semanticKey parameters _coreType = head' + construction <- + Except.liftEither + (traverse + (checkCompiledNamedSetConstruction + (`Map.lookup` + elaborationGlobals finalElaboration) + (replicate (length parameters) TySet)) + rawConstruction) + traverse_ + (\checkedConstruction -> + unless + (frozenCoreTerm + (preparedSetConstructionClosedBody + checkedConstruction) + == canonical) + (impossible + "exact named construction disagrees with its transparent body")) + construction let requirements = elaborationContextualRequirements finalElaboration body | Map.null requirements = - TransparentBody canonical + TransparentBody canonical construction | family == ExactAbbreviation = ContextualTransparentBody requirements @@ -1105,7 +1405,7 @@ prepareExactDeclaration block entries = OpaqueObjectContent theory seed coreType identity = opaqueObjectId theory seed coreType pure (GlobalReference identity, content') - TransparentBody canonical -> do + TransparentBody canonical _construction -> do checked <- either (Except.throwError @@ -1185,6 +1485,11 @@ prepareExactDeclaration block entries = target asserted alias + (case family of + ExactDefinition -> case body of + TransparentBody _canonical construction -> construction + _ -> Nothing + _ -> Nothing) syntax) lowerPreparedExactBinding @@ -1192,29 +1497,114 @@ lowerPreparedExactBinding -> Declaration.LoweringDriver (Either Declaration.DeclarationError - (Declaration.CheckedDeclaration (Maybe ObjectId))) + (Declaration.CheckedDeclaration CheckedExactBindingAuthorization)) lowerPreparedExactBinding prepared = case preparedDefinitionAlias prepared of Nothing -> pure (Right - (checked [] Nothing)) - Just alias -> - fmap - (\spec -> - checked - [ Declaration.checkedCandidate - spec - (Declaration.checkedDefinitionEquationPlanning - identity) - :| [] - ] - (Just identity)) - <$> Declaration.prepareDefinitionEquationSpecLowering - objects identity alias + (checked [] CheckedExactBindingNone)) + Just alias -> case preparedDefinitionConstruction prepared of + Nothing -> + fmap + (\spec -> + checked + [ Declaration.checkedCandidate + spec + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [] + ] + (CheckedExactBindingDefinition identity)) + <$> Declaration.prepareDefinitionEquationSpecLowering + objects identity alias + Just (PreparedUnconditionalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + (extensional, descriptor) <- + Except.lift + (Declaration.prepareNamedSetConstructionSpecLowering + objects identity construction) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + extensional + (Declaration.checkedKernelPlanning + descriptor []) + ] + ] + (CheckedExactBindingConstruction + identity construction)) + Just (PreparedRelationalSetConstruction construction) -> + Except.runExceptT do + equation <- + Except.lift + (Declaration.prepareDefinitionEquationSpecWithEligibilityLowering + objects identity SearchIneligible alias) + >>= Except.liftEither + let functionality = + relationalSetConstructionClosedFunctionality + construction + functionalityScoped = + embedClosedCore [] functionality + functionalitySpec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects functionality SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + functionalityScoped + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt location + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + (extensional, descriptor) <- + Except.lift + (Declaration.prepareRelationalSetConstructionSpecLowering + objects identity construction functionality) + >>= Except.liftEither + pure + (checked + [ Declaration.checkedCandidate + equation + (Declaration.checkedDefinitionEquationPlanning + identity) + :| [ Declaration.checkedCandidate + functionalitySpec + (Declaration.checkedSourceProofPlanning + [Declaration.checkedPlannedVampireRequest + location obligation] + []) + ] + , Declaration.checkedCandidate + extensional + (Declaration.checkedStagedKernelPlanning + descriptor + [Declaration.plannedEarlierCandidate 0 1]) + :| [] + ] + (CheckedExactBindingRelationalConstruction + identity construction obligation)) where identity = preparedExactObjectId prepared objects = maybeToList (preparedExactObject prepared) + location = preparedExactLocation prepared checked stages body = Declaration.checkedCompiledDeclaration (preparedExactSyntaxId prepared) @@ -1227,20 +1617,53 @@ lowerPreparedExactBinding prepared = stages body +data CheckedExactBindingAuthorization + = CheckedExactBindingNone + | CheckedExactBindingDefinition !ObjectId + | CheckedExactBindingConstruction + !ObjectId + !(NamedSetConstruction ObjectId) + | CheckedExactBindingRelationalConstruction + !ObjectId + !(CheckedRelationalSetConstruction ObjectId) + !(Declaration.PreparedVampireObligation Void ()) + authorizeCheckedExactBinding - :: Maybe ObjectId + :: CheckedExactBindingAuthorization -> [NonEmpty Declaration.ReservedCandidate] -> Declaration.Declaration () authorizeCheckedExactBinding body stages = case (body, stages) of - (Nothing, []) -> pure () - (Just identity, [candidate :| []]) -> + (CheckedExactBindingNone, []) -> pure () + (CheckedExactBindingDefinition identity, [candidate :| []]) -> Declaration.authorizeDefinitionEquationCandidate identity candidate + ( CheckedExactBindingConstruction identity construction + , [equation :| [extensional]] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeNamedSetConstructionCandidate + identity construction extensional + ( CheckedExactBindingRelationalConstruction + identity construction obligation + , [equation :| [functionality], extensional :| []] + ) -> do + Declaration.authorizeDefinitionEquationCandidate + identity equation + Declaration.authorizeVampireCandidate + functionality + (Declaration.acceptPreparedVampireObligation obligation) + Declaration.authorizeRelationalSetConstructionCandidate + identity construction functionality extensional _ -> Declaration.failDeclaration (Declaration.CheckedAuthorizationCandidateShapeMismatch - (if isJust body then 1 else 0) + (case body of + CheckedExactBindingNone -> 0 + CheckedExactBindingDefinition{} -> 1 + CheckedExactBindingConstruction{} -> 1 + CheckedExactBindingRelationalConstruction{} -> 2) (length stages)) prepareExactStructure @@ -1534,31 +1957,31 @@ lowerPreparedExactStructure (Declaration.preparePointwiseDefinitionEquationSpecLowering objects predicate alias) >>= Except.liftEither - generatedSpecs <- + generatedCandidates <- traverse (\(PreparedExactStructureFact - _factLocation target factAlias) -> - Except.lift + factLocation target factAlias) -> do + generatedSpec <- Except.lift (Declaration.prepareFrozenCandidateSpecLowering objects target SearchEligible [factAlias]) - >>= Except.liftEither) - generatedFacts - obligations <- - traverse - (\(PreparedExactStructureFact factLocation _target _factAlias, - generatedSpec) -> - Except.lift + >>= Except.liftEither + obligation <- Except.lift (Declaration.prepareStagedCandidateVampireLowering factLocation objects definition generatedSpec) - >>= Except.liftEither) - (zip generatedFacts generatedSpecs) + >>= Except.liftEither + pure + ( Declaration.checkedCandidate generatedSpec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + [ Declaration.plannedEarlierCandidate 0 0 + ]) + , (factLocation, obligation) + )) + generatedFacts let generatedAuthorizations = - zip - [ factLocation - | PreparedExactStructureFact - factLocation _target _factAlias <- generatedFacts - ] - obligations + snd <$> generatedCandidates stages = [ Declaration.checkedCandidate definition (Declaration.checkedDefinitionEquationPlanning predicate) @@ -1566,16 +1989,7 @@ lowerPreparedExactStructure ] <> maybeToList (NonEmpty.nonEmpty - [ Declaration.checkedCandidate generatedSpec - (Declaration.checkedSourceProofPlanning - [ Declaration.checkedPlannedVampireRequest - factLocation obligation - ] - [ Declaration.plannedEarlierCandidate 0 0 - ]) - | (generatedSpec, (factLocation, obligation)) <- - zip generatedSpecs generatedAuthorizations - ]) + (fst <$> generatedCandidates)) body = CheckedExactStructureAuthorization predicate @@ -1665,14 +2079,12 @@ prepareHead (Declaration.LoweringDriver) ( PreparedHead , ExactDeclarationFamily - , Maybe (Elaborate (CanonicalTerm ObjectId)) + , Maybe (Elaborate CompiledBody) ) prepareHead block key = case block of Raw.BlockSig location _title _marker assumptions signature -> do - unless (null assumptions) - (Except.throwError - (ExactUnsupportedDeclarationBody location)) + rejectHeaderAssumptions ExactGuardedOpaqueSignature assumptions head' <- prepareSignature location key signature pure (head', ExactSignature, Nothing) Raw.BlockAbbr location _title _marker abbreviation -> do @@ -1721,39 +2133,39 @@ prepareAbbreviation ExactCompileError (Declaration.LoweringDriver) ( PreparedHead - , Elaborate (CanonicalTerm ObjectId) + , Elaborate CompiledBody ) prepareAbbreviation location key = \case Raw.AbbreviationEq (Raw.SymbolPattern symbol parameters) expression -> do ensureExpressionKey location symbol key makeContextualTransparentHead location key parameters TySet - (compileExpressionAsSet expression) + (ordinaryCompiledBody <$> compileExpressionAsSet expression) Raw.AbbreviationFun (Raw.Fun _ item parameters) term -> do ensureFunctionPhraseKey location item key makeContextualTransparentHead location key parameters TySet - (compileTermAsSet term) + (ordinaryCompiledBody <$> compileTermAsSet term) Raw.AbbreviationAdj subject (Raw.Adj _ item arguments) statement -> do ensureAdjectiveKey location item key makeContextualTransparentHead location key (subject : arguments) TyProp - (compileStatement statement) + (ordinaryCompiledBody <$> compileStatement statement) Raw.AbbreviationVerb subject (Raw.Verb _ item arguments) statement -> do ensureVerbKey location item key makeContextualTransparentHead location key (subject : arguments) TyProp - (compileStatement statement) + (ordinaryCompiledBody <$> compileStatement statement) Raw.AbbreviationNoun subject (Raw.Noun _ item arguments) statement -> do ensureNounKey location item key makeContextualTransparentHead location key (subject : arguments) TyProp - (compileStatement statement) + (ordinaryCompiledBody <$> compileStatement statement) Raw.AbbreviationRel left relation parameters right statement -> do ensureRelationKey location relation key makeContextualTransparentHead location key (parameters <> [left, right]) TyProp - (compileStatement statement) + (ordinaryCompiledBody <$> compileStatement statement) prepareDefinition :: Location @@ -1763,31 +2175,32 @@ prepareDefinition ExactCompileError (Declaration.LoweringDriver) ( PreparedHead - , Elaborate (CanonicalTerm ObjectId) + , Elaborate CompiledBody ) prepareDefinition location key = \case Raw.Defn assumptions head' statement -> do - unless (null assumptions) - (Except.throwError - (ExactUnsupportedDeclarationBody location)) + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions (parameters, resultType) <- definitionHead location key head' makeTransparentHead location key parameters resultType - (compileStatement statement) + (ordinaryCompiledBody <$> compileStatement statement) Raw.DefnFun assumptions (Raw.Fun _ item parameters) symbolic term -> do - unless (null assumptions && isNothing symbolic) + rejectHeaderAssumptions ExactGuardedTransparentDefinition assumptions + traverse_ (Except.throwError - (ExactUnsupportedDeclarationBody location)) + . ExactDefinitionCombinedSymbolicAlias + . locate) + symbolic ensureFunctionPhraseKey location item key makeTransparentHead location key parameters TySet - (compileTermAsSet term) + (compileNamedSetTerm term) Raw.DefnOp (Raw.SymbolPattern symbol parameters) expression -> do ensureExpressionKey location symbol key makeTransparentHead location key parameters TySet - (compileExpressionAsSet expression) + (compileNamedSetExpression expression) definitionHead :: Location @@ -1799,15 +2212,11 @@ definitionHead ([Raw.VarSymbol], CoreType) definitionHead location key = \case Raw.DefnAdj annotation subject (Raw.Adj _ item arguments) -> do - unless (isNothing annotation) - (Except.throwError - (ExactUnsupportedDeclarationBody location)) + validateDefinitionAnnotation annotation ensureAdjectiveKey location item key pure (subject : arguments, TyProp) Raw.DefnVerb annotation subject (Raw.Verb _ item arguments) -> do - unless (isNothing annotation) - (Except.throwError - (ExactUnsupportedDeclarationBody location)) + validateDefinitionAnnotation annotation ensureVerbKey location item key pure (subject : arguments, TyProp) Raw.DefnNoun subject (Raw.Noun _ item arguments) -> do @@ -1829,25 +2238,67 @@ definitionHead location key = \case (Except.throwError (ExactDeclarationHeadMismatch location)) pure (toList parameters, TyProp) +validateDefinitionAnnotation + :: MonadError ExactCompileError monad + => Maybe (Raw.NounPhrase Maybe) + -> monad () +validateDefinitionAnnotation = traverse_ \nounPhrase -> + unless (exactSetNounPhrase nounPhrase) + (throwError + (ExactNonCanonicalSetDefinitionAnnotation + (exactNounPhraseLocation nounPhrase))) + +rejectHeaderAssumptions + :: MonadError ExactCompileError monad + => (Location -> ExactCompileError) + -> [Raw.Asm] + -> monad () +rejectHeaderAssumptions makeError = \case + [] -> pure () + assumption : _ -> + throwError (makeError (exactAssumptionLocation assumption)) + +exactAssumptionLocation :: Raw.Asm -> Location +exactAssumptionLocation = \case + Raw.AsmSuppose statement -> locate statement + Raw.AsmLetNoun variables _nounPhrase -> locate variables + Raw.AsmLetIn variables _expression -> locate variables + Raw.AsmLetThe variable _function -> locate variable + Raw.AsmLetEq variable _expression -> locate variable + Raw.AsmLetStruct variable _structure -> locate variable + +exactNounPhraseLocation :: Raw.NounPhraseOf t argument -> Location +exactNounPhraseLocation + (Raw.NounPhrase _left noun _variables _right _suchThat) = + locate noun + makeTransparentHead :: Location -> SemanticGlobalKey -> [Raw.VarSymbol] -> CoreType - -> Elaborate (CanonicalTerm ObjectId) + -> Elaborate CompiledBody -> ExceptT ExactCompileError (Declaration.LoweringDriver) ( PreparedHead - , Elaborate (CanonicalTerm ObjectId) + , Elaborate CompiledBody ) makeTransparentHead location key parameters resultType body = do (prepared, binders) <- prepareParameters location key parameters resultType let close = do - State.modify' (\state -> state{elaborationBinders = binders}) - body' <- body - pure (foldr (const (CLam TySet)) body' parameters) + State.modify' \state -> + state + { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + } + CompiledBody body' construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + construction) pure (prepared, close) makeContextualTransparentHead @@ -1855,12 +2306,12 @@ makeContextualTransparentHead -> SemanticGlobalKey -> [Raw.VarSymbol] -> CoreType - -> Elaborate (CanonicalTerm ObjectId) + -> Elaborate CompiledBody -> ExceptT ExactCompileError (Declaration.LoweringDriver) ( PreparedHead - , Elaborate (CanonicalTerm ObjectId) + , Elaborate CompiledBody ) makeContextualTransparentHead location key parameters resultType body = do (prepared, binders) <- @@ -1869,11 +2320,16 @@ makeContextualTransparentHead location key parameters resultType body = do State.modify' \state -> state { elaborationBinders = binders + , elaborationBinderDepth = + fromIntegral (length parameters) + 1 , elaborationContextualBinder = Just (fromIntegral (length parameters)) } - body' <- body - pure (foldr (const (CLam TySet)) body' parameters) + CompiledBody body' _construction <- body + pure + (CompiledBody + (foldr (const (CLam TySet)) body' parameters) + Nothing) pure (prepared, close) makePreparedHead @@ -1929,6 +2385,53 @@ compileExpressionAsSet expression = do (ExactExpressionExpectedSet (locate expression) actual)) pure term +-- | Compile one set expression once while retaining the checked-source shape +-- needed only when that expression is subsequently named by a definition. +-- Nested constructions remain ordinary exact terms. +compileNamedSetExpression + :: Raw.Expr + -> Elaborate CompiledBody +compileNamedSetExpression = \case + Raw.ExprSep _location variable bound predicate -> do + (term, bound', predicate') <- + compileSeparation variable bound predicate + pure + (CompiledBody term + (Just + (CompiledSeparationConstruction + bound' predicate'))) + Raw.ExprReplace _location value bounds condition -> do + replacement <- + compileFunctionalReplacement value bounds condition + pure + (CompiledBody + (compiledFunctionalReplacementTerm replacement) + (Just + (CompiledFunctionalReplacementConstruction + (compiledFunctionalReplacementDomains replacement) + (compiledFunctionalReplacementValue replacement) + (compiledFunctionalReplacementCondition replacement)))) + Raw.ExprReplacePred _location range domainVariable bound predicate -> do + (term, domain, relation) <- + compileRelationalReplacement + range domainVariable bound predicate + pure + (CompiledBody term + (Just + (CompiledRelationalReplacementConstruction + domain relation))) + expression -> + (`CompiledBody` Nothing) + <$> compileExpressionAsSet expression + +compileNamedSetTerm :: Raw.Term -> Elaborate CompiledBody +compileNamedSetTerm = \case + Raw.TermExpr expression -> compileNamedSetExpression expression + term -> ordinaryCompiledBody <$> compileTermAsSet term + +ordinaryCompiledBody :: CanonicalTerm ObjectId -> CompiledBody +ordinaryCompiledBody term = CompiledBody term Nothing + compileTermAsSet :: Raw.Term -> Elaborate (CanonicalTerm ObjectId) @@ -1942,11 +2445,73 @@ compileTermAsSet = \case applyResolved location key compiled Raw.TermQuantified _quantifier location _nounPhrase -> Except.throwError - (ExactQuantifiedTermRequiresStatementSubject location) + (ExactQuantifiedTermRequiresPropositionContext location) term -> Except.throwError (ExactUnsupportedDeclarationBody (locate term)) +-- | Compile a source term only at a proposition consumer. Indefinite terms +-- own the continuation, so their noun constraints and quantifier surround +-- exactly the proposition which consumes the resulting set. Function-phrase +-- arguments recurse through the same seam and therefore never masquerade as +-- independently set-valued terms. +compileTermInProposition + :: Raw.Term + -> (CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermInProposition term continuation = + case term of + Raw.TermExpr expression -> + compileExpressionAsSet expression >>= continuation + Raw.TermFun (Raw.Fun location item arguments) -> do + let patterns = Raw.lexicalItemSgPlPattern item + key = + SemanticFunctionPhrase + (Raw.sg patterns) + (Raw.pl patterns) + compileTermsInProposition arguments \compiled -> do + value <- applyResolved location key compiled + continuation value + Raw.TermQuantified quantifier _location nounPhrase -> + compileQuantifiedTermInProposition + quantifier nounPhrase continuation + Raw.TermIota location _variable _statement -> + Except.throwError (ExactUnsupportedDeclarationBody location) + +-- | Compile source-ordered proposition terms. The first source occurrence +-- receives the outermost continuation and therefore the widest scope. +compileTermsInProposition + :: [Raw.Term] + -> ([CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId)) + -> Elaborate (CanonicalTerm ObjectId) +compileTermsInProposition terms continuation = + case terms of + [] -> continuation [] + term : remaining -> + compileTermInProposition term \compiled -> do + compiledDepth <- State.gets elaborationBinderDepth + compileTermsInProposition remaining \rest -> do + compiled' <- + weakenElaboratedTermFrom compiledDepth compiled + continuation (compiled' : rest) + +weakenElaboratedTermFrom + :: Natural + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +weakenElaboratedTermFrom originalDepth term = do + currentDepth <- State.gets elaborationBinderDepth + when (currentDepth < originalDepth) + (impossible + "a proposition-term continuation escaped its binder scope") + pure + (shiftCanonical + (currentDepth - originalDepth) + 0 + term) + compileExpression :: Raw.Expr -> Elaborate (CanonicalTerm ObjectId, CoreType) @@ -1999,22 +2564,16 @@ compileExpression = \case , TySet ) Raw.ExprSep _location variable bound predicate -> do - bound' <- compileExpressionAsSet bound - predicate' <- - withSetBinders (variable :| []) - (compileStatement predicate) - pure - ( CApp - (CApp (CIntrinsic Sep) bound') - (CLam TySet predicate') - , TySet - ) + (term, _bound, _predicate) <- + compileSeparation variable bound predicate + pure (term, TySet) Raw.ExprReplace _location value bounds condition -> do - replacement <- compileReplacement value bounds condition - pure (replacement, TySet) + replacement <- + compileFunctionalReplacement value bounds condition + pure (compiledFunctionalReplacementTerm replacement, TySet) Raw.ExprReplacePred location _value _variable _bound _predicate -> Except.throwError - (ExactUnsupportedDeclarationBody location) + (ExactRelationalReplacementRequiresNamedDefinition location) compileStructureOperation :: Location @@ -2139,12 +2698,113 @@ structureCarrierCast location term = pure (CApp (CGlobal carrier) term) _ -> pure term -compileReplacement +compileMembership + :: Location + -> Raw.Sign + -> CanonicalTerm ObjectId + -> CanonicalTerm ObjectId + -> Elaborate (CanonicalTerm ObjectId) +compileMembership location sign element set = do + checkedSet <- structureCarrierCast location set + let proposition = + CApp + (CApp (CIntrinsic Member) element) + checkedSet + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition + +compileSeparation + :: Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileSeparation variable bound predicate = do + bound' <- compileExpressionAsSet bound + predicate' <- + withSetBinders (variable :| []) + (compileStatement predicate) + pure + ( CApp + (CApp (CIntrinsic Sep) bound') + (CLam TySet predicate') + , bound' + , predicate' + ) + +compileRelationalReplacement + :: Raw.VarSymbol + -> Raw.VarSymbol + -> Raw.Expr + -> Raw.Stmt + -> Elaborate + ( CanonicalTerm ObjectId + , CanonicalTerm ObjectId + , CanonicalTerm ObjectId + ) +compileRelationalReplacement range domainVariable bound predicate = do + domain <- compileExpressionAsSet bound + relation <- + withSetBinders (domainVariable :| [range]) + (compileStatement predicate) + let restrictedDomain = + CApp + (CApp (CIntrinsic Sep) domain) + (CLam TySet (logicalExists relation)) + choiceFunction = + CLam TySet + (CApp (CIntrinsic SetChoose) (CLam TySet relation)) + replacement = + CApp + (CApp (CIntrinsic Repl) restrictedDomain) + choiceFunction + pure (replacement, domain, relation) + +data CompiledFunctionalReplacement = CompiledFunctionalReplacement + !(CanonicalTerm ObjectId) + !(NonEmpty (CanonicalTerm ObjectId)) + !(CanonicalTerm ObjectId) + !(Maybe (CanonicalTerm ObjectId)) + +compiledFunctionalReplacementTerm + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementTerm + (CompiledFunctionalReplacement term _domains _value _condition) = + term + +compiledFunctionalReplacementDomains + :: CompiledFunctionalReplacement + -> NonEmpty (CanonicalTerm ObjectId) +compiledFunctionalReplacementDomains + (CompiledFunctionalReplacement _term domains _value _condition) = + domains + +compiledFunctionalReplacementValue + :: CompiledFunctionalReplacement + -> CanonicalTerm ObjectId +compiledFunctionalReplacementValue + (CompiledFunctionalReplacement _term _domains value _condition) = + value + +compiledFunctionalReplacementCondition + :: CompiledFunctionalReplacement + -> Maybe (CanonicalTerm ObjectId) +compiledFunctionalReplacementCondition + (CompiledFunctionalReplacement _term _domains _value condition) = + condition + +compileFunctionalReplacement :: Raw.Expr -> NonEmpty (Raw.VarSymbol, Raw.Expr) -> Maybe Raw.Stmt - -> Elaborate (CanonicalTerm ObjectId) -compileReplacement value ((variable, domain) :| remaining) condition = do + -> Elaborate CompiledFunctionalReplacement +compileFunctionalReplacement + value ((variable, domain) :| remaining) condition = do domain' <- compileExpressionAsSet domain case remaining of [] -> do @@ -2161,19 +2821,31 @@ compileReplacement value ((variable, domain) :| remaining) condition = do (CApp (CIntrinsic Sep) domain') (CLam TySet predicate) pure - (CApp - (CApp (CIntrinsic Repl) filteredDomain) - (CLam TySet value')) + (CompiledFunctionalReplacement + (CApp + (CApp (CIntrinsic Repl) filteredDomain) + (CLam TySet value')) + (domain' :| []) + value' + condition') next : rest -> do nested <- withSetBinders (variable :| []) - (compileReplacement value (next :| rest) condition) + (compileFunctionalReplacement + value (next :| rest) condition) pure - (CApp - (CIntrinsic FamilyUnion) + (CompiledFunctionalReplacement (CApp - (CApp (CIntrinsic Repl) domain') - (CLam TySet nested))) + (CIntrinsic FamilyUnion) + (CApp + (CApp (CIntrinsic Repl) domain') + (CLam TySet + (compiledFunctionalReplacementTerm nested)))) + (domain' + NonEmpty.<| + compiledFunctionalReplacementDomains nested) + (compiledFunctionalReplacementValue nested) + (compiledFunctionalReplacementCondition nested)) compileStatement :: Raw.Stmt @@ -2181,24 +2853,14 @@ compileStatement compileStatement = \case Raw.StmtFormula formula -> compileFormula formula - Raw.StmtVerbPhrase - (Raw.TermQuantified quantifier _location nounPhrase :| []) - verbPhrase -> - compileQuantifiedTermSubject quantifier nounPhrase - (`compileVerbPhrase` verbPhrase) - Raw.StmtVerbPhrase terms verbPhrase -> do - subjects <- traverse compileTermAsSet terms - logicalConjunction - <$> traverse (`compileVerbPhrase` verbPhrase) subjects - Raw.StmtNoun - (Raw.TermQuantified quantifier _location quantified :| []) - nounPhrase -> - compileQuantifiedTermSubject quantifier quantified - (`compileNounPhraseMaybe` nounPhrase) - Raw.StmtNoun terms nounPhrase -> do - subjects <- traverse compileTermAsSet terms - logicalConjunction - <$> traverse (`compileNounPhraseMaybe` nounPhrase) subjects + Raw.StmtVerbPhrase terms verbPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileVerbPhrase` verbPhrase) subjects + Raw.StmtNoun terms nounPhrase -> + compileTermsInProposition (toList terms) \subjects -> + logicalConjunction + <$> traverse (`compileNounPhraseMaybe` nounPhrase) subjects Raw.StmtExists _location nounPhrase -> compileExistentialNounPhrase nounPhrase Raw.StmtQuantPhrase @@ -2219,30 +2881,30 @@ compileStatement = \case _location quantifier variables bound suchThat statement -> compileSymbolicQuantified quantifier variables bound suchThat (compileStatement statement) - Raw.StmtStruct term rawPhrase -> do - subject <- compileTermAsSet term - annotation <- - resolveStructureAnnotation (locate term) rawPhrase - predicate <- - maybe - (impossible "an assertable structure has no predicate") - pure - (structureAnnotationPredicate annotation) - recordExactGlobal - predicate - (TyArrow TySet TyProp) - pure - (CApp - (CGlobal predicate) - subject) + Raw.StmtStruct term rawPhrase -> + compileTermInProposition term \subject -> do + annotation <- + resolveStructureAnnotation (locate term) rawPhrase + predicate <- + maybe + (impossible "an assertable structure has no predicate") + pure + (structureAnnotationPredicate annotation) + recordExactGlobal + predicate + (TyArrow TySet TyProp) + pure + (CApp + (CGlobal predicate) + subject) -compileQuantifiedTermSubject +compileQuantifiedTermInProposition :: Raw.Quantifier -> Raw.NounPhrase Maybe -> (CanonicalTerm ObjectId -> Elaborate (CanonicalTerm ObjectId)) -> Elaborate (CanonicalTerm ObjectId) -compileQuantifiedTermSubject quantifier +compileQuantifiedTermInProposition quantifier (Raw.NounPhrase left noun named right suchThat) compileBody = case named of @@ -2269,21 +2931,8 @@ compileSymbolicQuantified -> Elaborate (CanonicalTerm ObjectId) compileSymbolicQuantified quantifier variables bound suchThat compileBody = withSetBinders variables do - subjects <- traverse compileIntroducedVariable variables - boundConstraints <- case bound of - Raw.Unbounded -> - pure [] - Raw.Bounded _location sign relation domain -> do - domain' <- compileExpressionAsSet domain - traverse - (\subject -> do - proposition <- - compileAtomicRelationTerms - subject relation domain' - pure case sign of - Raw.Positive -> proposition - Raw.Negative -> logicalNot proposition) - (toList subjects) + boundConstraints <- + compileSymbolicBoundConstraintList variables bound suchThatConstraints <- maybeToList <$> traverse compileStatement suchThat body <- compileBody @@ -2295,6 +2944,25 @@ compileSymbolicQuantified quantifier variables bound suchThat compileBody = (boundConstraints <> suchThatConstraints)) body) +compileSymbolicBoundConstraintList + :: NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Elaborate [CanonicalTerm ObjectId] +compileSymbolicBoundConstraintList variables = \case + Raw.Unbounded -> + pure [] + Raw.Bounded _location sign relation domain -> do + subjects <- traverse compileIntroducedVariable variables + domain' <- compileExpressionAsSet domain + traverse + (\subject -> do + proposition <- + compileAtomicRelationTerms subject relation domain' + pure case sign of + Raw.Positive -> proposition + Raw.Negative -> logicalNot proposition) + (toList subjects) + compileAtomicRelationTerms :: CanonicalTerm ObjectId -> Raw.Relation @@ -2308,16 +2976,18 @@ compileAtomicRelationTerms left relation right = (Raw.relationSymbolToken symbol) (Raw.relationSymbolParameterArity symbol) compiledParameters <- traverse compileExpressionAsSet parameters - checkedRight <- - if symbol == Raw.ElementSymbol && null parameters - then structureCarrierCast location right - else pure right case fixedSemanticMeaning key of Just FixedEquality | null parameters -> pure (CEq TySet left right) Just FixedDisequality | null parameters -> pure (logicalNot (CEq TySet left right)) + Just (FixedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Positive left right + Just (FixedNegatedIntrinsic Member) + | null parameters -> + compileMembership location Raw.Negative left right Just (FixedIntrinsic intrinsic) -> do (term, actual) <- applyTyped @@ -2325,7 +2995,7 @@ compileAtomicRelationTerms left relation right = (CIntrinsic intrinsic) (coreIntrinsicType intrinsic) ((\term -> (term, TySet)) - <$> (compiledParameters <> [left, checkedRight])) + <$> (compiledParameters <> [left, right])) unless (actual == TyProp) (Except.throwError (ExactFormulaExpectedProposition location actual)) @@ -2337,7 +3007,7 @@ compileAtomicRelationTerms left relation right = (CIntrinsic intrinsic) (coreIntrinsicType intrinsic) ((\term -> (term, TySet)) - <$> (compiledParameters <> [left, checkedRight])) + <$> (compiledParameters <> [left, right])) unless (actual == TyProp) (Except.throwError (ExactFormulaExpectedProposition location actual)) @@ -2347,7 +3017,7 @@ compileAtomicRelationTerms left relation right = applyResolvedTyped location key ((\term -> (term, TySet)) - <$> (compiledParameters <> [left, checkedRight])) + <$> (compiledParameters <> [left, right])) unless (actual == TyProp) (Except.throwError (ExactFormulaExpectedProposition location actual)) @@ -2371,53 +3041,67 @@ compileVerbPhrase subject = \case logicalNot . logicalConjunction <$> traverse (compileAdjective subject) adjectives +compilePredicateArguments + :: CanonicalTerm ObjectId + -> [Raw.Term] + -> ( CanonicalTerm ObjectId + -> [CanonicalTerm ObjectId] + -> Elaborate (CanonicalTerm ObjectId) + ) + -> Elaborate (CanonicalTerm ObjectId) +compilePredicateArguments subject arguments continuation = do + subjectDepth <- State.gets elaborationBinderDepth + compileTermsInProposition arguments \compiled -> do + subject' <- weakenElaboratedTermFrom subjectDepth subject + continuation subject' compiled + compileVerb :: CanonicalTerm ObjectId -> Raw.Verb -> Elaborate (CanonicalTerm ObjectId) compileVerb subject (Raw.Verb location item arguments) = do let patterns = Raw.lexicalItemSgPlPattern item - compiled <- traverse compileTermAsSet arguments - applyResolvedPredicate - location - (SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) - (subject : compiled) + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticVerb (Raw.sg patterns) (Raw.pl patterns)) + (subject' : compiled) compileAdjective :: CanonicalTerm ObjectId -> Raw.Adj -> Elaborate (CanonicalTerm ObjectId) -compileAdjective subject (Raw.Adj location item arguments) = do - compiled <- traverse compileTermAsSet arguments - applyResolvedPredicateChoice - location - ( SemanticRightAdjective (Raw.lexicalItemPattern item) - :| [SemanticLeftAdjective (Raw.lexicalItemPattern item)] - ) - (subject : compiled) +compileAdjective subject (Raw.Adj location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicateChoice + location + ( SemanticRightAdjective (Raw.lexicalItemPattern item) + :| [SemanticLeftAdjective (Raw.lexicalItemPattern item)] + ) + (subject' : compiled) compileLeftAdjective :: CanonicalTerm ObjectId -> Raw.AdjL -> Elaborate (CanonicalTerm ObjectId) -compileLeftAdjective subject (Raw.AdjL location item arguments) = do - compiled <- traverse compileTermAsSet arguments - applyResolvedPredicate - location - (SemanticLeftAdjective (Raw.lexicalItemPattern item)) - (subject : compiled) +compileLeftAdjective subject (Raw.AdjL location item arguments) = + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticLeftAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) compileRightAttribute :: CanonicalTerm ObjectId -> Raw.AdjR -> Elaborate (CanonicalTerm ObjectId) compileRightAttribute subject = \case - Raw.AdjR location item arguments -> do - compiled <- traverse compileTermAsSet arguments - applyResolvedPredicate - location - (SemanticRightAdjective (Raw.lexicalItemPattern item)) - (subject : compiled) + Raw.AdjR location item arguments -> + compilePredicateArguments subject arguments \subject' compiled -> + applyResolvedPredicate + location + (SemanticRightAdjective (Raw.lexicalItemPattern item)) + (subject' : compiled) Raw.AttrRThat verbPhrase -> compileVerbPhrase subject verbPhrase @@ -2431,24 +3115,33 @@ compileNoun subject (Raw.Noun location item arguments) | otherwise = do let patterns = Raw.lexicalItemSgPlPattern item key = SemanticNoun (Raw.sg patterns) (Raw.pl patterns) - compiled <- traverse compileTermAsSet arguments - case fixedSemanticMeaning key of - Just (FixedIntrinsic intrinsic) -> do - (term, actual) <- - applyTyped - location - (CIntrinsic intrinsic) - (coreIntrinsicType intrinsic) - ((\argument -> (argument, TySet)) - <$> (subject : compiled)) - unless (actual == TyProp) - (Except.throwError - (ExactFormulaExpectedProposition location actual)) - pure term - Just{} -> - impossible "a fixed noun is not a predicate intrinsic" - Nothing -> - applyResolvedPredicate location key (subject : compiled) + compilePredicateArguments subject arguments \subject' compiled -> + case fixedSemanticMeaning key of + Just (FixedIntrinsic Member) -> + case compiled of + [set] -> + compileMembership + location Raw.Positive subject' set + _ -> + impossible + "the fixed element noun does not have one argument" + Just (FixedIntrinsic intrinsic) -> do + (term, actual) <- + applyTyped + location + (CIntrinsic intrinsic) + (coreIntrinsicType intrinsic) + ((\argument -> (argument, TySet)) + <$> (subject' : compiled)) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + Just{} -> + impossible "a fixed noun is not a predicate intrinsic" + Nothing -> + applyResolvedPredicate + location key (subject' : compiled) compileNounPhraseConstraints :: [CanonicalTerm ObjectId] @@ -2583,11 +3276,13 @@ withAnonymousSetBinder -> Elaborate value withAnonymousSetBinder action = do outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth outerStructures <- State.gets elaborationStructures outerContextual <- State.gets elaborationContextualBinder State.modify' \state -> state { elaborationBinders = (+ 1) <$> outer + , elaborationBinderDepth = outerDepth + 1 , elaborationStructures = Map.mapKeysMonotonic (+ 1) outerStructures , elaborationContextualBinder = (+ 1) <$> outerContextual @@ -2596,6 +3291,7 @@ withAnonymousSetBinder action = do State.modify' \state -> state { elaborationBinders = outer + , elaborationBinderDepth = outerDepth , elaborationStructures = outerStructures , elaborationContextualBinder = outerContextual } @@ -2607,6 +3303,7 @@ withSetBinders -> Elaborate value withSetBinders variables action = do outer <- State.gets elaborationBinders + outerDepth <- State.gets elaborationBinderDepth outerStructures <- State.gets elaborationStructures outerContextual <- State.gets elaborationContextualBinder case firstDuplicate (toList variables) of @@ -2633,6 +3330,7 @@ withSetBinders variables action = do State.modify' \state -> state { elaborationBinders = introduced <> shifted + , elaborationBinderDepth = outerDepth + binderCount , elaborationStructures = Map.mapKeysMonotonic (+ binderCount) outerStructures , elaborationContextualBinder = @@ -2642,6 +3340,7 @@ withSetBinders variables action = do State.modify' \state -> state { elaborationBinders = outer + , elaborationBinderDepth = outerDepth , elaborationStructures = outerStructures , elaborationContextualBinder = outerContextual } @@ -2779,6 +3478,18 @@ compileAtomicRelation left relation right = | otherwise -> Except.throwError (ExactUnsupportedDeclarationBody location) + Just (FixedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Positive left' right' + Just (FixedNegatedIntrinsic Member) + | null parameters -> do + left' <- compileExpressionAsSet leftExpression + right' <- compileExpressionAsSet rightExpression + compileMembership + location Raw.Negative left' right' Just (FixedIntrinsic intrinsic) -> do compiled <- traverse compileExpression (parameters <> [leftExpression, rightExpression]) @@ -2836,10 +3547,7 @@ compileRelationExpression location expression left right = do (SemanticExpressionFunction (Raw.mixfixPattern Raw.PairSymbol)) [left, right] - pure - (CApp - (CApp (CIntrinsic Member) pair) - relation) + compileMembership location Raw.Positive pair relation compileRelationChain :: Raw.Chain @@ -2893,14 +3601,8 @@ applyResolvedPredicate -> SemanticGlobalKey -> [CanonicalTerm ObjectId] -> Elaborate (CanonicalTerm ObjectId) -applyResolvedPredicate location key arguments = do - (term, actual) <- - applyResolvedTyped - location key ((\argument -> (argument, TySet)) <$> arguments) - unless (actual == TyProp) - (Except.throwError - (ExactFormulaExpectedProposition location actual)) - pure term +applyResolvedPredicate location key = + applyResolvedPredicateChoice location (key :| []) applyResolvedPredicateChoice :: Location @@ -2908,28 +3610,41 @@ applyResolvedPredicateChoice -> [CanonicalTerm ObjectId] -> Elaborate (CanonicalTerm ObjectId) applyResolvedPredicateChoice location keys arguments = do - visible <- for (toList keys) \key -> do - found <- - State.lift - (Except.lift - (Declaration.resolveVisibleGlobalLowering key)) - pure ((\target -> (key, target)) <$> found) - case catMaybes visible of - [(key, _target)] -> do - (term, actual) <- - applyResolvedTyped - location key - ((\argument -> (argument, TySet)) <$> arguments) - unless (actual == TyProp) - (Except.throwError - (ExactFormulaExpectedProposition location actual)) - pure term - [] -> - Except.throwError - (ExactGlobalNotVisible location (NonEmpty.head keys)) - _ -> - impossible - "one adjective surface resolves to several exact globals" + case firstFixedMeaning (toList keys) of + Just meaning -> + maybe + (impossible + "a fixed equality predicate has an invalid source arity") + pure + (lowerFixedEqualityPredicate meaning arguments) + Nothing -> do + visible <- for (toList keys) \key -> do + found <- + State.lift + (Except.lift + (Declaration.resolveVisibleGlobalLowering key)) + pure ((\target -> (key, target)) <$> found) + case catMaybes visible of + [(key, _target)] -> do + (term, actual) <- + applyResolvedTyped + location key + ((\argument -> (argument, TySet)) <$> arguments) + unless (actual == TyProp) + (Except.throwError + (ExactFormulaExpectedProposition location actual)) + pure term + [] -> + Except.throwError + (ExactGlobalNotVisible location (NonEmpty.head keys)) + _ -> + impossible + "one adjective surface resolves to several exact globals" + where + firstFixedMeaning = + foldr + (\key found -> fixedSemanticMeaning key <|> found) + Nothing applyResolvedTyped :: Location @@ -3180,7 +3895,7 @@ encodePreparedSyntax putCoreTypeCache coreType case body of OpaqueBody -> putCacheTag 0x00 - TransparentBody canonical -> do + TransparentBody canonical _construction -> do putCacheTag 0x01 putCanonicalTermCache putObjectIdCache canonical ContextualTransparentBody requirements canonical -> do diff --git a/source/Checking/Exact/Datatype.hs b/source/Felix/Checking/Exact/Datatype.hs index 14ee58c..be943cd 100644 --- a/source/Checking/Exact/Datatype.hs +++ b/source/Felix/Checking/Exact/Datatype.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Exact preparation of deterministic datatype declarations. -module Checking.Exact.Datatype +module Felix.Checking.Exact.Datatype ( PreparedExactDatatype , preparedExactDatatypeObjects , preparedExactDatatypeBindings @@ -23,22 +23,22 @@ module Checking.Exact.Datatype ) where import Base hiding (Empty) -import Checking.Authority -import Checking.Core -import Checking.Datatype qualified as Datatype -import Checking.Declaration qualified as Declaration -import Checking.Exact.Global qualified as ExactGlobal -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Datatype qualified as Datatype +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed import Felix.Cache.Codec import Felix.Module -import Meaning qualified -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import Syntax.Internal qualified as Internal +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal import Control.Monad (unless, when) import Control.Monad.Except (ExceptT) diff --git a/source/Checking/Exact/Global.hs b/source/Felix/Checking/Exact/Global.hs index 772a7e2..d4040e6 100644 --- a/source/Checking/Exact/Global.hs +++ b/source/Felix/Checking/Exact/Global.hs @@ -2,19 +2,19 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Exact resolution of source symbols to checked semantic globals. -module Checking.Exact.Global +module Felix.Checking.Exact.Global ( ExactGlobalResolutionError(..) , resolveExactSourceGlobals ) where import Base -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Vocabulary -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed -import Syntax.Internal qualified as Internal +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed +import Felix.Syntax.Internal qualified as Internal import Control.Monad (foldM) import Control.Monad.Except diff --git a/source/Checking/Exact/Inductive.hs b/source/Felix/Checking/Exact/Inductive.hs index ca6fb83..5817b34 100644 --- a/source/Checking/Exact/Inductive.hs +++ b/source/Felix/Checking/Exact/Inductive.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Exact preparation and atomic publication of direct set inductives. -module Checking.Exact.Inductive +module Felix.Checking.Exact.Inductive ( PreparedExactInductive , preparedExactInductiveCarrierId , preparedExactInductiveCarrierType @@ -19,21 +19,21 @@ module Checking.Exact.Inductive ) where import Base hiding (Empty) -import Checking.Authority -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact.Global qualified as ExactGlobal -import Checking.Exact.Vocabulary -import Checking.Foundation -import Checking.Identity -import Checking.Semantic -import Checking.Typed.Inductive qualified as Typed +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact.Global qualified as ExactGlobal +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic +import Felix.Checking.Typed.Inductive qualified as Typed import Felix.Cache.Codec -import Meaning qualified -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import Syntax.Internal qualified as Internal +import Felix.Meaning qualified as Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Internal qualified as Internal import Control.Monad (unless, when) import Control.Monad.Except (ExceptT) @@ -63,6 +63,7 @@ data CheckedExactInductiveAuthorization = !ObjectId !(Typed.PreparedTypedInductive ObjectId) ![SemanticFactOccurrenceFingerprint] + ![(Location, Declaration.PreparedVampireObligation Void ())] preparedExactInductiveCarrierId :: PreparedExactInductive @@ -116,7 +117,9 @@ data ExactInductiveError | ExactInductiveResultShape !Location | ExactInductiveResultMentionsCarrier !Location | ExactInductiveRecursiveTermMentionsCarrier !Location - | ExactInductiveNestedRecursion !Location + | ExactInductiveRecursiveCarrierWrongArguments !Location + | ExactInductiveRecursiveCarrierOutsideMembership !Location + | ExactInductiveUnsupportedRecursiveCarrierContext !Location | ExactInductiveFixedSemanticCollision !Location !SemanticGlobalKey | ExactInductiveGlobalAlreadyVisible !Location !SemanticGlobalKey | ExactInductiveGlobalNotVisible !Location !Internal.Symbol @@ -143,7 +146,9 @@ exactInductiveErrorLocation = \case ExactInductiveResultShape location -> location ExactInductiveResultMentionsCarrier location -> location ExactInductiveRecursiveTermMentionsCarrier location -> location - ExactInductiveNestedRecursion location -> location + ExactInductiveRecursiveCarrierWrongArguments location -> location + ExactInductiveRecursiveCarrierOutsideMembership location -> location + ExactInductiveUnsupportedRecursiveCarrierContext location -> location ExactInductiveFixedSemanticCollision location _key -> location ExactInductiveGlobalAlreadyVisible location _key -> location ExactInductiveGlobalNotVisible location _symbol -> location @@ -182,8 +187,12 @@ renderExactInductiveError failure = "an inductive result term must not mention its carrier" ExactInductiveRecursiveTermMentionsCarrier{} -> "a recursive occurrence must be in the carrier of a membership premise" - ExactInductiveNestedRecursion{} -> - "nested inductive recursion is not supported by the typed checker" + ExactInductiveRecursiveCarrierWrongArguments{} -> + "the inductive carrier occurs with arguments other than its declared parameters" + ExactInductiveRecursiveCarrierOutsideMembership{} -> + "an inductive carrier occurrence must be in the set operand of a membership premise" + ExactInductiveUnsupportedRecursiveCarrierContext{} -> + "this recursive carrier context is outside the supported first-order set-term fragment" ExactInductiveFixedSemanticCollision _location key -> "the inductive carrier collides with fixed semantics for " <> shown key @@ -448,18 +457,28 @@ normalizeCondition carrier parameters formula Left (ExactInductiveRecursiveTermMentionsCarrier (termLocation recursiveTerm)) - | matchesCarrier carrier parameters recursiveCarrier -> + | otherwise -> do + context <- + first recursiveCarrierContextError + (Typed.prepareRecursiveCarrierContext + carrier parameters recursiveCarrier) Right - (Typed.DirectRecursiveCondition recursiveTerm) - | otherwise -> - Left - (ExactInductiveNestedRecursion - (termLocation recursiveCarrier)) + (Typed.DirectRecursiveCondition + recursiveTerm context) _ -> Left - (ExactInductiveNestedRecursion + (ExactInductiveRecursiveCarrierOutsideMembership (termLocation formula)) +recursiveCarrierContextError + :: Typed.RecursiveCarrierContextError + -> ExactInductiveError +recursiveCarrierContextError = \case + Typed.RecursiveCarrierWrongArguments location -> + ExactInductiveRecursiveCarrierWrongArguments location + Typed.RecursiveCarrierUnsupportedContext location -> + ExactInductiveUnsupportedRecursiveCarrierContext location + matchesCarrier :: Internal.FunctionSymbol -> [Internal.VarSymbol] @@ -543,8 +562,9 @@ directSymbols direct = conditionSymbols = \case Typed.DirectSideCondition formula -> Internal.mentionedSymbols formula - Typed.DirectRecursiveCondition term -> + Typed.DirectRecursiveCondition term context -> Internal.mentionedSymbols term + <> Typed.recursiveCarrierContextSymbols context lowerPreparedExactInductive :: PreparedExactInductive @@ -558,24 +578,107 @@ lowerPreparedExactInductive _location key identity asserted alias syntax typed guards) = do let facts = Typed.typedInductiveFacts typed + monotonicities = + Vector.toList + (Typed.typedInductiveMonotonicities typed) objects = maybeToList asserted definition <- Declaration.prepareDefinitionEquationSpecLowering objects identity alias - preparedFacts <- + preparedMonotonicities <- + traverse + (\monotonicity -> Except.runExceptT do + let factLocation = + Typed.typedInductiveMonotonicityLocation + monotonicity + target = + Typed.typedInductiveMonotonicityTarget + monotonicity + spec <- + Except.lift + (Declaration.prepareFrozenCandidateSpecLowering + objects target SearchIneligible []) + >>= Except.liftEither + obligation <- + Except.lift + (Declaration.prepareScopedVampireObligationLowering + Vector.empty + (embedClosedCore [] target) + [] + [] + Declaration.VampireImplicitPremises) + >>= either + (Except.throwError + . Declaration.ProofObligationFailedAt + factLocation + . Declaration.CurrentCandidateVampirePreparationFailed) + pure + pure + ( Declaration.checkedCandidate + spec + (Declaration.checkedSourceProofPlanning + [ Declaration.checkedPlannedVampireRequest + factLocation obligation + ] + []) + , (factLocation, obligation) + )) + monotonicities + preparedCandidates <- traverse - (\fact -> - Declaration.prepareCandidateSpecLowering - objects - (embedClosedCore [] - (Typed.typedInductiveFactTarget fact)) - SearchEligible - [markerAlias - (Typed.typedInductiveFactMarker fact)]) + (\fact -> do + prepared <- + Declaration.prepareCandidateSpecLowering + objects + (embedClosedCore [] + (Typed.typedInductiveFactTarget fact)) + SearchEligible + [markerAlias + (Typed.typedInductiveFactMarker fact)] + let descriptor = + GuardedFoundationRules + (guardedRuleSet + (Typed.typedInductiveFactRules fact)) + planning + | null monotonicities = + Declaration.checkedKernelPlanning + descriptor guards + | otherwise = + Declaration.checkedKernelPlanningWithStaged + descriptor + guards + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then + [ Declaration.plannedEarlierCandidate + 1 index + | (index, _target) <- + zip [0 ..] monotonicities + ] + else []) + pure + (fmap + (\spec -> + Declaration.checkedCandidate spec planning) + prepared)) facts pure do definitionSpec <- definition - factSpecs <- sequence preparedFacts + monotonicityCandidates <- sequence preparedMonotonicities + factCandidates <- sequence preparedCandidates + let stages + | null monotonicityCandidates = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| toList factCandidates + ] + | otherwise = + [ Declaration.checkedCandidate definitionSpec + (Declaration.checkedDefinitionEquationPlanning identity) + :| [] + , NonEmpty.fromList (fst <$> monotonicityCandidates) + , factCandidates + ] pure (Declaration.checkedCompiledDeclaration syntax @@ -583,21 +686,10 @@ lowerPreparedExactInductive [] [semanticGlobalBinding key (GlobalReference identity)] [] - [ Declaration.checkedCandidate definitionSpec - (Declaration.checkedDefinitionEquationPlanning identity) - :| [ Declaration.checkedCandidate factSpec - (Declaration.checkedKernelPlanning - (GuardedFoundationRules - (guardedRuleSet - (Typed.typedInductiveFactRules - fact))) - guards) - | (factSpec, fact) <- - zip (toList factSpecs) (toList facts) - ] - ] + stages (CheckedExactInductiveAuthorization - identity typed guards)) + identity typed guards + (snd <$> monotonicityCandidates))) where markerAlias (Raw.Marker name) = semanticName name @@ -607,8 +699,12 @@ authorizeCheckedExactInductive -> [NonEmpty Declaration.ReservedCandidate] -> Declaration.Declaration () authorizeCheckedExactInductive - (CheckedExactInductiveAuthorization identity typed guards) = \case + (CheckedExactInductiveAuthorization + identity typed guards monotonicityObligations) = \case [definitionCandidate :| candidates] -> do + unless (null monotonicityObligations) + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch 3 1)) Declaration.authorizeDefinitionEquationCandidate identity definitionCandidate let facts = Typed.typedInductiveFacts typed @@ -617,7 +713,7 @@ authorizeCheckedExactInductive | NonEmpty.length factCandidates == NonEmpty.length facts -> sequence_ (NonEmpty.zipWith - authorizeFact + (authorizeFact []) factCandidates facts) _ -> @@ -625,20 +721,60 @@ authorizeCheckedExactInductive (Declaration.CheckedAuthorizationCandidateShapeMismatch (1 + NonEmpty.length facts) (1 + length candidates)) + [ definitionCandidate :| [] + , monotonicityCandidates + , factCandidates + ] + | NonEmpty.length monotonicityCandidates + == length monotonicityObligations + , NonEmpty.length factCandidates + == NonEmpty.length (Typed.typedInductiveFacts typed) -> do + obligations <- + maybe + (Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 0)) + pure + (NonEmpty.nonEmpty monotonicityObligations) + Declaration.authorizeDefinitionEquationCandidate + identity definitionCandidate + Declaration.authorizeVampireCandidateBatch + (NonEmpty.zipWith + (\candidate (factLocation, obligation) -> + (factLocation, candidate, pure obligation)) + monotonicityCandidates + obligations) + sequence_ + (NonEmpty.zipWith + (\candidate fact -> + authorizeFact + (if Typed.typedInductiveFactRequiresMonotonicities + fact + then NonEmpty.toList monotonicityCandidates + else []) + candidate + fact) + factCandidates + (Typed.typedInductiveFacts typed)) stages -> Declaration.failDeclaration (Declaration.CheckedAuthorizationCandidateShapeMismatch - 1 (length stages)) + (if null monotonicityObligations then 1 else 3) + (length stages)) where - authorizeFact candidate fact = + authorizeFact monotonicityCandidates candidate fact = Declaration.authorizeKernelConstructionCandidate (GuardedFoundationRules (guardedRuleSet (Typed.typedInductiveFactRules fact))) candidate do traverse_ Declaration.useAuthorizedFact guards + traverse_ + Declaration.useStagedCandidate + monotonicityCandidates pure (Typed.typedInductiveFactDerivation fact) + encodePreparedInductive :: SemanticGlobalKey -> SemanticName @@ -653,10 +789,21 @@ encodePreparedInductive key alias typed = putCanonicalTermCache putObjectIdCache (frozenCoreTerm (Typed.typedInductiveCarrierBody typed)) + putCacheList putFrozenTerm + (Vector.toList + (Typed.typedInductiveContextInventory typed)) + putCacheList + (putFrozenTerm + . Typed.typedInductiveMonotonicityTarget) + (Vector.toList + (Typed.typedInductiveMonotonicities typed)) putCacheText (semanticNameText alias) putCacheList putFact (toList (Typed.typedInductiveFacts typed)) where + putFrozenTerm = + putCanonicalTermCache putObjectIdCache . frozenCoreTerm + putFact fact = do let Raw.Marker marker = Typed.typedInductiveFactMarker fact diff --git a/source/Felix/Checking/Exact/Proof.hs b/source/Felix/Checking/Exact/Proof.hs new file mode 100644 index 0000000..e2149c4 --- /dev/null +++ b/source/Felix/Checking/Exact/Proof.hs @@ -0,0 +1,2639 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact lowering for the first ordinary theorem/proof fragment. +-- +-- This module is the trusted owner of structural local-proof composition. Its +-- private prepared tree controls when assumptions and proved local claims +-- become available and executes discharges depth-first. The declaration +-- boundary validates typed tasks and authority; it does not reconstruct this +-- derivation. +module Felix.Checking.Exact.Proof + ( PreparedExactProof + , preparedExactProofSyntaxId + , preparedExactProofFirstOmission + , prepareExactProof + , CheckedExactProofAuthorization + , lowerPreparedExactProof + , authorizeCheckedExactProof + , PreparedFinalPreludeFoundationClaim + , prepareFinalPreludeFoundationClaim + , CheckedFinalPreludeFoundationAuthorization + , lowerPreparedFinalPreludeFoundationClaim + , authorizeCheckedFinalPreludeFoundationClaim + , ExactProofError(..) + , exactProofErrorLocation + , renderExactProofError + ) where + +import Base +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Kernel.Derivation (foundationFactDerivation) +import Felix.Checking.Kernel.Proof qualified as KernelProof +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Cache.Codec +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw + +import Control.Monad.Except (ExceptT) +import Control.Monad.Except qualified as Except +import Control.Monad (foldM, unless, when) +import Control.Monad.State.Strict (StateT) +import Control.Monad.State.Strict qualified as State +import Data.ByteString (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Numeric.Natural (Natural) + + +data ExactProofError + = ExactProofUnsupportedClaim !Location + | ExactProofUnsupportedStep !Location + | ExactProofSetInductionVariableRequired !Location + | ExactProofSetInductionVariableNotActive + !Location !Raw.VarSymbol + | ExactProofSetInductionFocusAmbiguous !Location + | ExactProofSetInductionActiveBinderIneligible + !Location !Raw.VarSymbol + | ExactProofSetInductionBinderConflict + !Location !Raw.VarSymbol + | ExactProofSetInductionGoalMismatch !Location + | ExactProofSetExtensionalityGoalMismatch !Location + | ExactProofSetExtensionalityDirectionsUnavailable !Location + | ExactProofExpectedUniversalGoal !Location + | ExactProofExpectedImplicationGoal !Location + | ExactProofGoalStatementMismatch !Location + | ExactProofEmptyCaseSplit !Location + | ExactProofStructuralCompositionFailed + !Location !KernelProof.KernelProofBuildError + | ExactProofLocalFunctionBinderMismatch !Location + | ExactProofLocalFunctionNameConflict !Location + | ExactProofUnknownReference !Location !Raw.Marker + | ExactProofElaborationFailed !Exact.ExactCompileError + | ExactProofObligationPreparationFailed + !Location + !(Declaration.VampireObligationPreparationError + Exact.ExactLocalId) + | ExactProofFoundationLeafRequiresImplicitAuto !Location + | ExactProofFoundationLeafTargetMismatch !Location + | ExactProofFoundationLeafTargetAmbiguous !Location + deriving stock (Show, Eq) + +exactProofErrorLocation :: ExactProofError -> Location +exactProofErrorLocation = \case + ExactProofUnsupportedClaim location -> location + ExactProofUnsupportedStep location -> location + ExactProofSetInductionVariableRequired location -> location + ExactProofSetInductionVariableNotActive location _variable -> + location + ExactProofSetInductionFocusAmbiguous location -> location + ExactProofSetInductionActiveBinderIneligible location _variable -> + location + ExactProofSetInductionBinderConflict location _variable -> + location + ExactProofSetInductionGoalMismatch location -> location + ExactProofSetExtensionalityGoalMismatch location -> location + ExactProofSetExtensionalityDirectionsUnavailable location -> location + ExactProofExpectedUniversalGoal location -> location + ExactProofExpectedImplicationGoal location -> location + ExactProofGoalStatementMismatch location -> location + ExactProofEmptyCaseSplit location -> location + ExactProofStructuralCompositionFailed location _failure -> location + ExactProofLocalFunctionBinderMismatch location -> location + ExactProofLocalFunctionNameConflict location -> location + ExactProofUnknownReference location _marker -> location + ExactProofElaborationFailed failure -> + Exact.exactCompileErrorLocation failure + ExactProofObligationPreparationFailed location _failure -> location + ExactProofFoundationLeafRequiresImplicitAuto location -> location + ExactProofFoundationLeafTargetMismatch location -> location + ExactProofFoundationLeafTargetAmbiguous location -> location + +renderExactProofError :: ExactProofError -> Text +renderExactProofError = \case + ExactProofUnsupportedClaim location -> + at location <> "this claim is not yet supported by the typed checker" + ExactProofUnsupportedStep location -> + at location <> "this proof step is not yet supported by the typed checker" + ExactProofSetInductionVariableRequired location -> + at location <> "exact set induction requires a named set variable" + ExactProofSetInductionVariableNotActive location variable -> + at location <> "the set-induction variable " <> shown variable + <> " is not an eligible exact focus" + ExactProofSetInductionFocusAmbiguous location -> + at location + <> "set induction without an explicit variable has no unique focus" + ExactProofSetInductionActiveBinderIneligible location variable -> + at location <> "the active binder " <> shown variable + <> " is not an eligible set-induction focus" + ExactProofSetInductionBinderConflict location variable -> + at location <> "the leading set-induction binder " <> shown variable + <> " conflicts with an active exact binder" + ExactProofSetInductionGoalMismatch location -> + at location <> "the set-induction variable does not belong to this goal" + ExactProofSetExtensionalityGoalMismatch location -> + at location <> "set extensionality requires a set-equality goal" + ExactProofSetExtensionalityDirectionsUnavailable location -> + at location + <> "set extensionality requires both directions as proved local claims" + ExactProofExpectedUniversalGoal location -> + at location <> "this fix step requires a universal goal" + ExactProofExpectedImplicationGoal location -> + at location <> "this assume step requires an implication goal" + ExactProofGoalStatementMismatch location -> + at location <> "the proof step does not match the current goal" + ExactProofEmptyCaseSplit location -> + at location <> "case analysis requires at least one case" + ExactProofStructuralCompositionFailed location failure -> + at location <> "invalid structural proof composition: " <> shown failure + ExactProofLocalFunctionBinderMismatch location -> + at location <> "the function argument must match its domain binder" + ExactProofLocalFunctionNameConflict location -> + at location <> "the function and argument names must be distinct" + ExactProofUnknownReference location marker -> + at location <> "the cited fact " <> shown marker <> " is not visible" + ExactProofElaborationFailed failure -> + Exact.renderExactCompileError failure + ExactProofObligationPreparationFailed location failure -> + at location <> "the exact proof obligation is invalid: " <> shown failure + ExactProofFoundationLeafRequiresImplicitAuto location -> + at location + <> "a confined foundation claim requires an implicit Auto proof" + ExactProofFoundationLeafTargetMismatch location -> + at location <> "the claim does not exactly match a foundation axiom" + ExactProofFoundationLeafTargetAmbiguous location -> + at location <> "the claim matches more than one foundation axiom" + where + at location = locationToText location <> ": " + shown :: Show value => value -> Text + shown = Text.pack . show + +data ExactLocalOrigin + = ExactAssumption + | ExactDerivedClaim + | ExactLocalDefinition + | ExactLocalConstructionExtensional + | ExactLocalConstructionEquation + deriving stock (Show, Eq, Ord) + +data PreparedLocal = PreparedLocal + !Backend.LocalPremiseOrdinal + !ExactLocalOrigin + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + +data PreparedJustification + = PreparedAuto + | PreparedReferences + !(NonEmpty SemanticFactOccurrenceFingerprint) + | PreparedLocalOnly + +data PreparedDischarge + = PreparedVampireDischarge + !Location + !PreparedJustification + !(ScopedCheckedCore ObjectId) + !(Declaration.PreparedVampireObligation + Exact.ExactLocalId + ExactLocalOrigin) + | PreparedSetExtensionality + !Location + !(ScopedCheckedCore ObjectId) + +data PreparedCalculationLink = PreparedCalculationLink + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +-- The private constructor stores every destination with the discharge derived +-- from its immediately preceding endpoint. Planning and admission can +-- therefore traverse one immutable sequence without re-associating shapes. +data PreparedCalculation = PreparedCheckedCalculation + !CoreType + ![Exact.ExactLocalId] + !(Maybe (ScopedCheckedCore ObjectId)) + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCalculationLink) + !(ScopedCheckedCore ObjectId) + +data PreparedSinceEvidence + = PreparedSinceExisting !PreparedLocal + | PreparedSinceDischarged !PreparedDischarge !PreparedLocal + +data PreparedCase = PreparedCase + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedCaseAnalysis = PreparedCaseAnalysis + !(ScopedCheckedCore ObjectId) + !(NonEmpty PreparedCase) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data InitialSetInductionFocus = InitialSetInductionFocus + !Raw.VarSymbol + !Exact.ExactLocalId + !Natural + +data InitialSetInductionView = InitialSetInductionView + ![InitialSetInductionFocus] + !(Vector (Exact.ExactLocalId, CoreType)) + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(Maybe Raw.VarSymbol) + +data SetInductionBoundary + = InitialClaimInduction !InitialSetInductionView + -- A direct source-statement goal may retain only its leading binder name. + -- Recursive proof transformations deliberately discard this hint. + | SourceStatementInduction !(Maybe Raw.VarSymbol) + | RecursiveProofInduction + +data SelectedSetInductionFocus + = SelectedInitialSetInduction !InitialSetInductionFocus + | SelectedLeadingSetInduction !(Maybe Raw.VarSymbol) + +data PreparedSetInductionFocus + = PreparedInitialSetInductionFocus + !Exact.ExactLocalId + !Natural + | PreparedLeadingSetInductionFocus + !Exact.ExactLocalId + +data PreparedSetInduction = PreparedCheckedSetInduction + !PreparedSetInductionFocus + !(ScopedCheckedCore ObjectId) + ![ScopedCheckedCore ObjectId] + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + +data PreparedProof + = PreparedImplicitAuto !PreparedDischarge + | PreparedQed !PreparedDischarge + | PreparedOmitted + !Location + !(ScopedCheckedCore ObjectId) + | PreparedFix ![Exact.ExactLocalId] !PreparedProof + | PreparedAssume + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedTake + ![Exact.ExactLocalId] + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSetInduction !PreparedSetInduction + | PreparedHave + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSuffices + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedCalculate + !PreparedCalculation + !PreparedProof + | PreparedSince + !(ScopedCheckedCore ObjectId) + !PreparedSinceEvidence + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !PreparedProof + | PreparedSubclaim + !(ScopedCheckedCore ObjectId) + !PreparedProof + !PreparedProof + | PreparedDefine + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineRelational + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + !(NonEmpty (ScopedCheckedCore ObjectId)) + !PreparedProof + | PreparedDefineFunction + !Exact.ExactLocalId + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedByCase !PreparedCaseAnalysis + | PreparedByContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedProof + | PreparedContradiction + !(ScopedCheckedCore ObjectId) + !(ScopedCheckedCore ObjectId) + !PreparedDischarge + +data PreparedExactProof = PreparedExactProof + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !PreparedProof + !ProofSyntaxId + +data PreparedFinalPreludeFoundationClaim = + PreparedFinalPreludeFoundationClaim + !Location + !SemanticName + !(ScopedCheckedCore ObjectId) + !FoundationAxiomTag + !ProofSyntaxId + +preparedExactProofSyntaxId :: PreparedExactProof -> ProofSyntaxId +preparedExactProofSyntaxId + (PreparedExactProof _location _alias _target _proof syntax) = + syntax + +preparedExactProofFirstOmission :: PreparedExactProof -> Maybe Location +preparedExactProofFirstOmission + (PreparedExactProof _location _alias _target proof _syntax) = + preparedProofFirstOmission proof + +data PrepareState = PrepareState + { prepareNextLocal :: !Natural + , prepareNextPremise :: !Natural + } + +type Prepare = + StateT + PrepareState + (ExceptT ExactProofError (Declaration.LoweringDriver)) + +prepareExactProof + :: Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedExactProof) +prepareExactProof block explicitProof = + Except.runExceptT + (State.evalStateT prepare initialState) + where + initialState = PrepareState 0 0 + + prepare = + case block of + Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) -> do + envelope <- + liftDriver + (Exact.prepareExactClaimEnvelope assumptions statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let targetCore = Exact.preparedExactClaimTarget envelope + unless (null (scopedCoreContext targetCore)) + (throwProof + (ExactProofUnsupportedClaim location)) + (context, openedGoal, identities) <- + openEnvelopeVariables + targetCore + (Exact.preparedExactClaimVariables envelope) + (Exact.preparedExactClaimContext envelope) + (locals, bodyGoal, antecedents) <- + openEnvelopeAntecedents + context + openedGoal + (Exact.preparedExactClaimAntecedentCount envelope) + initialInduction <- + prepareInitialSetInductionView + statement + context + (Exact.preparedExactClaimVariables envelope) + identities + antecedents + bodyGoal + bodyProof <- + case explicitProof of + Nothing -> + PreparedImplicitAuto + <$> prepareDischarge + location + context + locals + bodyGoal + Raw.JustificationEmpty + Just sourceProof -> + prepareProof + location + context + locals + (InitialClaimInduction initialInduction) + bodyGoal + sourceProof + let withAssumptions = + foldr PreparedAssume bodyProof antecedents + proof = + case identities of + [] -> withAssumptions + _ -> PreparedFix identities withAssumptions + pure + (PreparedExactProof + location + (semanticName marker) + targetCore + proof + (proofSyntaxId + (encodePreparedProof proof))) + _ -> + throwProof + (ExactProofUnsupportedClaim (locate block)) + +prepareFinalPreludeFoundationClaim + :: CheckedFoundation + -> Raw.Block + -> Maybe Raw.Proof + -> Declaration.LoweringDriver + (Either ExactProofError PreparedFinalPreludeFoundationClaim) +prepareFinalPreludeFoundationClaim foundation block explicitProof = + Except.runExceptT do + case (block, explicitProof) of + ( Raw.BlockClaim + _kind location _title (Raw.Marker marker) + (Raw.Claim assumptions statement) + , Nothing + ) -> do + envelope <- + Except.lift + (Exact.prepareExactClaimEnvelope + assumptions + statement) + >>= either + (Except.throwError + . ExactProofElaborationFailed) + pure + unless + ( null (Exact.preparedExactClaimVariables envelope) + && Exact.preparedExactClaimAntecedentCount envelope + == 0 + ) + (Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto + location)) + let target = Exact.preparedExactClaimTarget envelope + matches = + [ tag + | tag <- [minBound .. maxBound] + , target == foundationTarget tag + ] + tag <- case matches of + [] -> + Except.throwError + (ExactProofFoundationLeafTargetMismatch location) + [only] -> + pure only + _ -> + Except.throwError + (ExactProofFoundationLeafTargetAmbiguous location) + pure + (PreparedFinalPreludeFoundationClaim + location + (semanticName marker) + target + tag + (implicitAutoProofSyntaxId target)) + (Raw.BlockClaim _kind location _title _marker _claim, Just{}) -> + Except.throwError + (ExactProofFoundationLeafRequiresImplicitAuto location) + _ -> + Except.throwError + (ExactProofUnsupportedClaim (locate block)) + where + foundationTarget tag = + embedClosedCore [] + (mapFrozenGlobals + absurd + (foundationAxiomFrozen foundation tag)) + +openEnvelopeVariables + :: ScopedCheckedCore ObjectId + -> [Raw.VarSymbol] + -> Exact.ExactBinderContext + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openEnvelopeVariables target variables preparedContext = + case NonEmpty.nonEmpty variables of + Nothing -> + pure (preparedContext, target, []) + Just nonempty -> do + (_unannotated, opened, identities) <- + openFixedVariables + Exact.emptyExactBinderContext + target + nonempty + let expected = + reverse + (fst <$> toList + (Exact.exactBinderContextSupport preparedContext)) + unless + (identities == expected) + (impossible + "prepared claim annotations do not match opened binders") + pure (preparedContext, opened, identities) + +openEnvelopeAntecedents + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Natural + -> Prepare + ( [PreparedLocal] + , ScopedCheckedCore ObjectId + , [ScopedCheckedCore ObjectId] + ) +openEnvelopeAntecedents context initialGoal initialCount = + go [] [] initialGoal initialCount + where + go locals antecedents goal 0 = + pure (locals, goal, antecedents) + go locals antecedents goal remaining = do + (antecedent, conclusion) <- + maybe + (impossible + "a prepared claim envelope has too few implications") + pure + (openScopedImplication goal) + local <- allocateLocal ExactAssumption context antecedent + go + (locals <> [local]) + (antecedents <> [antecedent]) + conclusion + (remaining - 1) + +prepareInitialSetInductionView + :: Raw.Stmt + -> Exact.ExactBinderContext + -> [Raw.VarSymbol] + -> [Exact.ExactLocalId] + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Prepare InitialSetInductionView +prepareInitialSetInductionView + statement context variables identities antecedents bodyGoal = do + unless (length variables == length identities) + (impossible + "opened claim binders lost their source identity association") + foci <- traverse checkedFocus (zip variables identities) + let property = foldr implyChecked bodyGoal antecedents + support = Exact.exactBinderContextSupport context + unless + ( scopedCoreContext property + == (snd <$> Vector.toList support) + ) + (impossible + "initial set-induction property changed its checked context") + pure + (InitialSetInductionView + foci support property antecedents bodyGoal + (claimLeadingUniversalName statement)) + where + checkedFocus (variable, identity) = do + index <- + maybe + (impossible + "an opened claim binder is absent from its exact context") + pure + (Exact.exactBinderContextIndex variable context) + case Exact.exactBinderContextSupport context + Vector.!? (fromIntegral index) of + Just (actualIdentity, TySet) + | actualIdentity == identity -> + pure + (InitialSetInductionFocus + variable identity index) + _ -> + impossible + "an initial set-induction focus changed identity or type" + + implyChecked antecedent conclusion = + fromMaybe + (impossible + "an exact claim antecedent changed context") + (implyScopedCore antecedent conclusion) + +claimLeadingUniversalName :: Raw.Stmt -> Maybe Raw.VarSymbol +claimLeadingUniversalName = \case + Raw.StmtFormula + (Raw.FormulaQuantified _location Raw.Universally + (variable :| _rest) _bound _formula) -> + Just variable + Raw.SymbolicForall _location (variable :| _rest) + _bound _suchThat _statement -> + Just variable + Raw.StmtQuantPhrase + _location + (Raw.QuantPhrase Raw.Universally + (Raw.NounPhrase _left _noun variables _right _suchThat)) + _statement -> + listToMaybe variables + Raw.StmtVerbPhrase + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _verb -> + variable + Raw.StmtNoun + (Raw.TermQuantified Raw.Universally _location + (Raw.NounPhrase _left _noun variable _right _suchThat) + :| []) + _nounPhrase -> + variable + _statement -> + Nothing + +prepareProof + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareProof fallback context locals inductionBoundary goal = \case + Raw.Omitted location -> + pure (PreparedOmitted location goal) + Raw.Qed maybeLocation justification -> + PreparedQed + <$> prepareDischarge + (fromMaybe fallback maybeLocation) + context + locals + goal + justification + Raw.FixSymbolic location variables bound continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + case bound of + Raw.Unbounded -> + PreparedFix identities + <$> prepareProof + fallback + context' + locals + RecursiveProofInduction + goal' + continuation + _ -> do + constraint <- + prepareSymbolicBoundConstraints + context' variables bound + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.FixSuchThat location variables statement continuation -> do + (context', goal', identities) <- + openFixedVariables context goal variables + constraint <- + Exact.preparedExactPropositionCore + <$> prepareStatement context' statement + prepareGuardedFix + fallback location context' locals goal' + identities constraint continuation + Raw.Assume location statement continuation -> do + supplied <- prepareStatement context statement + when (isNothing (openScopedImplication goal)) + (throwProof (ExactProofExpectedImplicationGoal location)) + (assumption, conclusion) <- + maybe + (throwProof (ExactProofGoalStatementMismatch location)) + pure + (openScopedAssumption + (Exact.preparedExactPropositionCore supplied) + goal) + local <- allocateLocal ExactAssumption context assumption + PreparedAssume assumption + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + Raw.TakeVar location variables bound statement justification continuation -> do + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.TakeNoun location nounPhrase justification continuation -> + prepareNounTake + fallback location context locals goal nounPhrase + justification continuation + Raw.BySetInduction location variable continuation -> + prepareSetInduction + fallback location context locals inductionBoundary goal + variable continuation + Raw.Have location Nothing + (Raw.SymbolicExists _existential variables bound statement) + justification continuation -> + prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation + Raw.Have location Nothing statement justification continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + discharge <- + prepareDischarge + location context locals claim justification + local <- allocateLocal ExactDerivedClaim context claim + PreparedHave claim discharge + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Have location (Just sinceStatement) + statement justification continuation -> do + sinceProposition <- + Exact.preparedExactPropositionCore + <$> prepareStatement context sinceStatement + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + (evidence, sinceLocals) <- + case find (localMatches sinceProposition) locals of + Just existing -> + pure (PreparedSinceExisting existing, locals) + Nothing -> do + discharge <- + prepareDischarge + location + context + locals + sinceProposition + Raw.JustificationLocal + local <- + allocateLocal + ExactDerivedClaim context sinceProposition + pure + ( PreparedSinceDischarged discharge local + , locals <> [local] + ) + claimDischarge <- + prepareDischarge + location context sinceLocals claim justification + claimLocal <- + allocateLocal ExactDerivedClaim context claim + PreparedSince + sinceProposition evidence claim claimDischarge + <$> prepareProof + fallback + context + (sinceLocals <> [claimLocal]) + RecursiveProofInduction + goal + continuation + Raw.Suffices location statement justification continuation -> do + reduction <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + implication <- + maybe + (impossible + "a checked suffices reduction changed lexical context") + pure + (implyScopedCore reduction goal) + discharge <- + prepareDischarge + location context locals implication justification + PreparedSuffices goal reduction implication discharge + <$> prepareProof + fallback + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + reduction + continuation + Raw.Calc location quantifier calculation continuation -> do + prepared <- + prepareCalculation + location context locals quantifier calculation + local <- + allocateLocal + ExactDerivedClaim + context + (preparedCalculationResult prepared) + PreparedCalculate prepared + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Subclaim location statement subproof continuation -> do + claim <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + preparedSubproof <- + prepareProof + location + context + locals + (SourceStatementInduction + (claimLeadingUniversalName statement)) + claim + subproof + local <- allocateLocal ExactDerivedClaim context claim + PreparedSubclaim claim preparedSubproof + <$> prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + goal + continuation + Raw.Define location variable expression continuation -> do + preparedBody <- + liftDriver + (Exact.prepareExactSetExpression context expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + let body = Exact.preparedExactSetExpressionCore preparedBody + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + case Exact.preparedExactSetExpressionConstruction preparedBody of + Nothing -> do + separationCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + SeparationCharacteristic) + definition <- + maybe + (impossible + "an exact set expression did not form a local definition") + pure + (scopedSetDefinition separationCharacteristic body) + local <- + allocateLocal ExactLocalDefinition context' definition + PreparedDefine identity body (definition :| []) + <$> prepareProof + fallback context' (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedUnconditionalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + (extensional, equation) <- + maybe + (impossible + "a checked named construction has no definition views") + pure + (namedSetConstructionLocalViews + characteristics construction) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefine identity body (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Just (Exact.PreparedRelationalSetConstruction construction) -> do + characteristics <- prepareConstructionFoundation + let functionality = + relationalSetConstructionFunctionality construction + discharge <- + prepareDischarge + location context locals functionality + Raw.JustificationEmpty + (extensional, equation) <- + maybe + (impossible + "a checked relational construction has no admitted definition views") + pure + (relationalSetConstructionLocalViews + characteristics construction functionality) + extensionalLocal <- + allocateLocal + ExactLocalConstructionExtensional context' extensional + equationLocal <- + allocateLocal + ExactLocalConstructionEquation context' equation + PreparedDefineRelational + identity body discharge (extensional :| [equation]) + <$> prepareProof + fallback context' + (locals <> [extensionalLocal, equationLocal]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.DefineFunction + location function argument value bound domain continuation -> do + unless (argument == bound) + (throwProof + (ExactProofLocalFunctionBinderMismatch (locate bound))) + when (function == argument) + (throwProof + (ExactProofLocalFunctionNameConflict (locate function))) + argumentIdentity <- allocateLocalIdentity + argumentContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((argumentIdentity, argument) :| []) + context) + graph <- + liftDriver + (Exact.prepareExactLocalFunctionGraph + location context argumentContext domain value) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + functionIdentity <- allocateLocalIdentity + functionContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((functionIdentity, function) :| []) + context) + replacementCharacteristic <- + liftDriver + (Declaration.currentFoundationAxiomLowering + ReplacementCharacteristic) + definition <- + maybe + (impossible + "a checked replacement graph did not form a local definition") + pure + (scopedCharacteristicDefinition + replacementCharacteristic + (Exact.preparedExactLocalFunctionGraphCore graph) + ( Exact.preparedExactLocalFunctionGraphDomain graph + :| [Exact.preparedExactLocalFunctionGraphMap graph] + )) + local <- + allocateLocal ExactLocalDefinition functionContext definition + PreparedDefineFunction + functionIdentity + (Exact.preparedExactLocalFunctionGraphCore graph) + definition + <$> prepareProof + fallback + functionContext + (locals <> [local]) + RecursiveProofInduction + (weakenCheckedScopedCore TySet goal) + continuation + Raw.ByCase location sourceCases -> + prepareByCase + location context locals goal sourceCases + Raw.ByContradiction location continuation -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + negation <- + maybe + (structuralFailure + location + "proof by contradiction requires a proposition goal") + pure + (negateScopedCore goal) + local <- allocateLocal ExactAssumption context negation + prepared <- + prepareProof + location + context + (locals <> [local]) + RecursiveProofInduction + falsum + continuation + validateStructuralComposition + location [goal, negation, falsum] + (\foundation globalType -> + KernelProof.validateDoubleNegationComposition + foundation globalType goal negation falsum) + pure + (PreparedByContradiction + goal negation falsum prepared) + Raw.Contradiction location justification -> do + let falsum = falsumScopedCore (scopedCoreContext goal) + discharge <- + prepareDischarge + location + context + locals + falsum + justification + validateStructuralComposition + location [goal, falsum] + (\foundation globalType -> + KernelProof.validateFalsumEliminationComposition + foundation globalType goal falsum) + pure (PreparedContradiction goal falsum discharge) + proof -> + throwProof + (ExactProofUnsupportedStep + (proofLocation fallback proof)) + where + localMatches proposition + (PreparedLocal _ordinal _origin _support local) = + local == proposition + +prepareSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Raw.Proof + -> Prepare PreparedProof +prepareSetInduction + fallback location context locals boundary goal sourceFocus + continuation = do + selected <- + selectSetInductionFocus + location context boundary goal sourceFocus + case selected of + SelectedInitialSetInduction + (InitialSetInductionFocus _variable identity index) -> do + (foci, expectedSupport, property, antecedents, childTarget) <- + case boundary of + InitialClaimInduction + (InitialSetInductionView + foundFoci support foundProperty + foundAntecedents foundTarget _leadingName) -> + pure + ( foundFoci + , support + , foundProperty + , foundAntecedents + , foundTarget + ) + RecursiveProofInduction -> + impossible + "an initial induction focus escaped its claim boundary" + SourceStatementInduction _leadingName -> + impossible + "an initial induction focus escaped its claim boundary" + unless + ( Exact.exactBinderContextSupport context == expectedSupport + && goal == childTarget + && any (sameInitialFocus identity index) foci + ) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + PreparedSetInduction + <$> prepareCheckedSetInduction + fallback location context locals + (PreparedInitialSetInductionFocus identity index) + index property antecedents childTarget continuation + SelectedLeadingSetInduction sourceName -> do + (binderType, property) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + identity <- allocateLocalIdentity + extendedContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (case sourceName of + Just variable -> + Exact.extendExactBinderContext + ((identity, variable) :| []) + context + Nothing -> + Exact.extendExactAnonymousBinderContext + identity context) + let expectedResult = weakenCheckedScopedCore TySet goal + prepared <- prepareCheckedSetInduction + fallback location extendedContext locals + (PreparedLeadingSetInductionFocus identity) + 0 property [] property continuation + unless + (preparedSetInductionResult prepared == expectedResult) + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure (PreparedSetInduction prepared) + where + sameInitialFocus expectedIdentity expectedIndex + (InitialSetInductionFocus _variable identity index) = + identity == expectedIdentity && index == expectedIndex + +prepareCheckedSetInduction + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> PreparedSetInductionFocus + -> Natural + -> ScopedCheckedCore ObjectId + -> [ScopedCheckedCore ObjectId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedSetInduction +prepareCheckedSetInduction + fallback location context locals focus selected property antecedents + childTarget continuation = do + (_predicate, hypothesis, _step, result) <- + maybe + (throwProof + (ExactProofSetInductionGoalMismatch location)) + pure + (scopedSetInductionInstance selected property) + validateStructuralComposition + location + (property : hypothesis : result : childTarget : antecedents) + (\foundation globalType -> + KernelProof.validateSetInductionComposition + foundation globalType selected property antecedents + childTarget hypothesis result) + local <- allocateLocal ExactAssumption context hypothesis + child <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + childTarget + continuation + pure + (PreparedCheckedSetInduction + focus property antecedents childTarget hypothesis result child) + +preparedSetInductionResult + :: PreparedSetInduction + -> ScopedCheckedCore ObjectId +preparedSetInductionResult + (PreparedCheckedSetInduction + _focus _property _antecedents _target _hypothesis result _child) = + result + +selectSetInductionFocus + :: Location + -> Exact.ExactBinderContext + -> SetInductionBoundary + -> ScopedCheckedCore ObjectId + -> Maybe Raw.Term + -> Prepare SelectedSetInductionFocus +selectSetInductionFocus location context boundary goal sourceFocus = do + explicit <- traverse simpleVariable sourceFocus + let (initialFoci, retainedLeadingName) = + case boundary of + InitialClaimInduction + (InitialSetInductionView + foci _support _property _antecedents _target + leadingName) -> + (foci, leadingName) + SourceStatementInduction leadingName -> + ([], leadingName) + RecursiveProofInduction -> + ([], Nothing) + leadingAvailable = + case openScopedForall goal of + Just (TySet, _body) -> True + _ -> False + case explicit of + Just variable -> + case find (initialNamed variable) initialFoci of + Just focus -> + pure (SelectedInitialSetInduction focus) + Nothing + | leadingAvailable + , isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionBinderConflict + location variable) + | leadingAvailable -> + pure + (SelectedLeadingSetInduction + (Just variable)) + | isJust + (Exact.exactBinderContextIndex variable context) -> + throwProof + (ExactProofSetInductionActiveBinderIneligible + location variable) + | otherwise -> + throwProof + (ExactProofSetInductionVariableNotActive + location variable) + Nothing -> + case + ( (SelectedInitialSetInduction <$> initialFoci) + <> [ SelectedLeadingSetInduction retainedLeadingName + | leadingAvailable + ] + ) of + [only] -> pure only + _ -> + throwProof + (ExactProofSetInductionFocusAmbiguous location) + where + simpleVariable = \case + Raw.TermExpr (Raw.ExprVar variable) -> + pure variable + _term -> + throwProof + (ExactProofSetInductionVariableRequired location) + + initialNamed variable + (InitialSetInductionFocus candidate _identity _index) = + candidate == variable + +prepareByCase + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Raw.Case] + -> Prepare PreparedProof +prepareByCase location context locals goal sourceCases = do + cases <- + maybe + (throwProof (ExactProofEmptyCaseSplit location)) + (traverse prepareCase) + (NonEmpty.nonEmpty sourceCases) + exhaustive <- + foldM disjoin + (preparedCaseAssumption (NonEmpty.head cases)) + (preparedCaseAssumption <$> NonEmpty.tail cases) + discharge <- + prepareDischarge + location context locals exhaustive Raw.JustificationEmpty + validateStructuralComposition + location + (goal : exhaustive : (preparedCaseAssumption <$> toList cases)) + (\foundation globalType -> + KernelProof.validateCaseAnalysisComposition + foundation + globalType + goal + (preparedCaseAssumption <$> cases) + exhaustive) + pure + (PreparedByCase + (PreparedCaseAnalysis goal cases exhaustive discharge)) + where + prepareCase (Raw.Case statement child) = do + assumption <- + Exact.preparedExactPropositionCore + <$> prepareStatement context statement + local <- allocateLocal ExactAssumption context assumption + prepared <- + prepareProof + (locate statement) + context + (locals <> [local]) + RecursiveProofInduction + goal + child + pure (PreparedCase assumption prepared) + + disjoin left right = + maybe + (structuralFailure + location + "case assumptions changed type or lexical context") + pure + (disjoinScopedCore left right) + +preparedCaseAssumption + :: PreparedCase + -> ScopedCheckedCore ObjectId +preparedCaseAssumption (PreparedCase assumption _proof) = + assumption + +preparedCaseProof :: PreparedCase -> PreparedProof +preparedCaseProof (PreparedCase _assumption proof) = + proof + +prepareGuardedFix + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Proof + -> Prepare PreparedProof +prepareGuardedFix + fallback location context locals goal identities constraint continuation = do + (antecedent, conclusion) <- + maybe + (throwProof (ExactProofExpectedImplicationGoal location)) + pure + (openScopedImplication goal) + unless (constraint == antecedent) + (throwProof (ExactProofGoalStatementMismatch location)) + local <- allocateLocal ExactAssumption context constraint + prepared <- + prepareProof + fallback + context + (locals <> [local]) + RecursiveProofInduction + conclusion + continuation + pure (PreparedFix identities (PreparedAssume constraint prepared)) + +prepareCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> Maybe Raw.CalcQuantifier + -> Raw.Calc + -> Prepare PreparedCalculation +prepareCalculation location context locals quantifier calculation = do + (identities, calculationContext, calculationGuard) <- + prepareCalculationScope context quantifier + case calculation of + Raw.Equation first destinations -> do + firstChecked <- prepareSetEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + prepareSetEndpoint calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TySet identities calculationGuard + firstChecked checkedDestinations + Raw.Biconditionals first destinations -> do + firstChecked <- preparePropositionEndpoint calculationContext first + checkedDestinations <- + traverse + (\(destination, justification) -> do + checked <- + preparePropositionEndpoint + calculationContext destination + pure + ( locate destination + , checked + , justification + )) + destinations + finishCalculation + location context locals TyProp identities calculationGuard + firstChecked checkedDestinations + where + prepareSetEndpoint endpointContext expression = + Exact.preparedExactSetExpressionCore + <$> ( liftDriver + (Exact.prepareExactSetExpression + endpointContext expression) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + + preparePropositionEndpoint endpointContext formula = + Exact.preparedExactPropositionCore + <$> prepareStatement endpointContext (Raw.StmtFormula formula) + +prepareCalculationScope + :: Exact.ExactBinderContext + -> Maybe Raw.CalcQuantifier + -> Prepare + ( [Exact.ExactLocalId] + , Exact.ExactBinderContext + , Maybe (ScopedCheckedCore ObjectId) + ) +prepareCalculationScope context = \case + Nothing -> + pure ([], context, Nothing) + Just (Raw.CalcQuantifier variables bound suchThat) -> do + identities <- traverse (const allocateLocalIdentity) variables + calculationContext <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + boundGuard <- + prepareSymbolicBoundConstraints + calculationContext variables bound + suchThatGuard <- + traverse + (fmap Exact.preparedExactPropositionCore + . prepareStatement calculationContext) + suchThat + calculationGuard <- + normalizeCalculationGuard + (boundGuard : maybeToList suchThatGuard) + pure (toList identities, calculationContext, calculationGuard) + +normalizeCalculationGuard + :: [ScopedCheckedCore ObjectId] + -> Prepare (Maybe (ScopedCheckedCore ObjectId)) +normalizeCalculationGuard guards = + foldM add Nothing guards + where + add accumulated constraint + | isScopedTruth constraint = pure accumulated + | otherwise = + case accumulated of + Nothing -> pure (Just constraint) + Just previous -> + Just + <$> maybe + (impossible + "checked calculation guards changed context") + pure + (conjoinScopedCore previous constraint) + + isScopedTruth proposition = + scopedCoreType proposition == TyProp + && scopedCoreTerm proposition == CImp CFalsum CFalsum + +finishCalculation + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> CoreType + -> [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> NonEmpty + ( Location + , ScopedCheckedCore ObjectId + , Raw.Justification + ) + -> Prepare PreparedCalculation +finishCalculation + fallback context locals operandType identities calculationGuard + first destinations = do + links <- prepareCalculationLinks first destinations + let finalEndpoint = preparedCalculationLinkDestination (NonEmpty.last links) + resultOpen <- + calculationEquality first finalEndpoint + result <- + closeCalculationProposition identities calculationGuard resultOpen + pure + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) + where + prepareCalculationLinks previous (destination :| rest) = do + (next, firstLink) <- prepareCalculationLink previous destination + later <- prepareRemainingCalculationLinks next rest + pure (firstLink :| later) + + prepareRemainingCalculationLinks _previous [] = + pure [] + prepareRemainingCalculationLinks previous (destination : rest) = do + (next, link) <- prepareCalculationLink previous destination + (link :) <$> prepareRemainingCalculationLinks next rest + + prepareCalculationLink previous + (destinationLocation, destination, justification) = do + linkOpen <- calculationEquality previous destination + link <- closeCalculationProposition + identities calculationGuard linkOpen + discharge <- + prepareDischarge + (if destinationLocation == Nowhere + then fallback + else destinationLocation) + context + locals + link + justification + pure + ( destination + , PreparedCalculationLink destination discharge + ) + + calculationEquality left right = + maybe + (impossible + "checked calculation endpoints changed type or context") + pure + (equalScopedCore left right) + +closeCalculationProposition + :: [Exact.ExactLocalId] + -> Maybe (ScopedCheckedCore ObjectId) + -> ScopedCheckedCore ObjectId + -> Prepare (ScopedCheckedCore ObjectId) +closeCalculationProposition identities calculationGuard proposition = do + guarded <- + case calculationGuard of + Nothing -> pure proposition + Just constraint -> + maybe + (impossible + "a checked calculation guard changed context") + pure + (implyScopedCore constraint proposition) + pure (closeBinders (length identities) guarded) + where + closeBinders 0 closed = closed + closeBinders remaining open = + closeBinders (remaining - 1) + (fromMaybe + (impossible + "a checked calculation lost a quantified binder") + (closeScopedForall open)) + +preparedCalculationResult + :: PreparedCalculation + -> ScopedCheckedCore ObjectId +preparedCalculationResult + (PreparedCheckedCalculation + _operandType _identities _guard _first _links result) = + result + +preparedCalculationLinkDestination + :: PreparedCalculationLink + -> ScopedCheckedCore ObjectId +preparedCalculationLinkDestination + (PreparedCalculationLink destination _discharge) = + destination + +preparedCalculationLinkDischarge + :: PreparedCalculationLink + -> PreparedDischarge +preparedCalculationLinkDischarge + (PreparedCalculationLink _destination discharge) = + discharge + +preparedDischargeGoal + :: PreparedDischarge + -> ScopedCheckedCore ObjectId +preparedDischargeGoal = \case + PreparedVampireDischarge _location _justification goal _obligation -> + goal + PreparedSetExtensionality _location goal -> + goal + +prepareSymbolicBoundConstraints + :: Exact.ExactBinderContext + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Prepare (ScopedCheckedCore ObjectId) +prepareSymbolicBoundConstraints context variables bound = + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicBoundConstraints + context variables bound) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + +prepareSymbolicTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Raw.Bound + -> Raw.Stmt + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareSymbolicTake + fallback location context locals goal variables bound statement + justification continuation = do + identities <- traverse (const allocateLocalIdentity) variables + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities variables) + context) + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactSymbolicWitnessConstraints + context' variables bound statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + (toList identities) witness justification continuation + +prepareNounTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.NounPhrase [] + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareNounTake + fallback location context locals goal nounPhrase + justification continuation = do + (identities, context') <- + case nounPhrase of + Raw.NounPhrase _left _noun variables _right _suchThat -> + case NonEmpty.nonEmpty variables of + Just binders -> do + identities <- + traverse (const allocateLocalIdentity) binders + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + (NonEmpty.zip identities binders) + context) + pure (toList identities, context') + Nothing -> do + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactAnonymousBinderContext + identity context) + pure ([identity], context') + witness <- + Exact.preparedExactPropositionCore + <$> ( liftDriver + (Exact.prepareExactNounWitnessConstraints + context' nounPhrase) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + ) + prepareTake + fallback location context locals goal context' + identities witness justification continuation + +prepareTake + :: Location + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Exact.ExactBinderContext + -> [Exact.ExactLocalId] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Raw.Proof + -> Prepare PreparedProof +prepareTake + fallback location context locals goal witnessContext + identities witness justification continuation = do + let witnessCount = length identities + existence = closeTakenWitnesses witnessCount witness + goal' = weakenForTakenWitnesses witnessCount goal + discharge <- + prepareDischarge + location context locals existence justification + local <- allocateLocal ExactAssumption witnessContext witness + PreparedTake identities witness discharge + <$> prepareProof + fallback + witnessContext + (locals <> [local]) + RecursiveProofInduction + goal' + continuation + +-- The discharged existential and the opened witness premise are the same +-- checked proposition viewed on opposite sides of existential elimination. +closeTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +closeTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (fromMaybe + (impossible "a taken witness has no checked binder") + (closeScopedExists proposition)) + +weakenForTakenWitnesses + :: Int + -> ScopedCheckedCore ObjectId + -> ScopedCheckedCore ObjectId +weakenForTakenWitnesses binderCount = go binderCount + where + go 0 proposition = proposition + go remaining proposition = + go (remaining - 1) + (weakenCheckedScopedCore TySet proposition) + +openFixedVariables + :: Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> NonEmpty Raw.VarSymbol + -> Prepare + ( Exact.ExactBinderContext + , ScopedCheckedCore ObjectId + , [Exact.ExactLocalId] + ) +openFixedVariables initialContext initialGoal variables = + foldM openOne + (initialContext, initialGoal, []) + (toList variables) + where + openOne (context, goal, identities) variable = do + (binderType, body) <- + maybe + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + pure + (openScopedForall goal) + unless (binderType == TySet) + (throwProof + (ExactProofExpectedUniversalGoal + (locate variable))) + identity <- allocateLocalIdentity + context' <- + either + (throwProof . ExactProofElaborationFailed) + pure + (Exact.extendExactBinderContext + ((identity, variable) :| []) + context) + pure (context', body, identities <> [identity]) + +allocateLocalIdentity :: Prepare Exact.ExactLocalId +allocateLocalIdentity = do + state <- State.get + State.put + state + { prepareNextLocal = prepareNextLocal state + 1 + } + pure (Exact.exactLocalId (prepareNextLocal state)) + +allocateLocal + :: ExactLocalOrigin + -> Exact.ExactBinderContext + -> ScopedCheckedCore ObjectId + -> Prepare PreparedLocal +allocateLocal origin context proposition = do + state <- State.get + State.put + state + { prepareNextPremise = prepareNextPremise state + 1 + } + pure + (PreparedLocal + (Backend.localPremiseOrdinal + (prepareNextPremise state)) + origin + (Exact.exactBinderContextSupport context) + proposition) + +prepareConstructionFoundation + :: Prepare SetConstructionFoundation +prepareConstructionFoundation = do + familyUnion <- foundation FamilyUnionCharacteristic + separation <- foundation SeparationCharacteristic + replacement <- foundation ReplacementCharacteristic + setChoose <- foundation SetChooseWitness + pure + (setConstructionFoundation + familyUnion separation replacement setChoose) + where + foundation tag = + liftDriver + (Declaration.currentFoundationAxiomLowering tag) + +prepareDischarge + :: Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischarge location context locals goal justification = + prepareDischargeWith + (dischargeModeFor goal) + [] Nothing location context locals goal justification + +-- A contradictory-axioms answer can establish falsum, but never an unrelated +-- proposition directly. Derive that distinction from the checked target so +-- every surface proof spelling reaches the same guarded request path. +dischargeModeFor :: ScopedCheckedCore ObjectId -> DischargeMode +dischargeModeFor goal + | scopedCoreType goal == TyProp + , scopedCoreTerm goal == CFalsum = + IndirectContradictionDischarge + | otherwise = + DirectDischarge + +data DischargeMode + = DirectDischarge + | IndirectContradictionDischarge + +prepareDischargeWith + :: DischargeMode + -> [FoundationAxiomTag] + -> Maybe Declaration.VampirePremiseSelection + -> Location + -> Exact.ExactBinderContext + -> [PreparedLocal] + -> ScopedCheckedCore ObjectId + -> Raw.Justification + -> Prepare PreparedDischarge +prepareDischargeWith + dischargeMode auxiliaries selectionOverride + location context locals goal justification = + case justification of + Raw.JustificationSetExt -> do + (leftToRight, rightToLeft) <- + maybe + (throwProof + (ExactProofSetExtensionalityGoalMismatch location)) + pure + (splitScopedSetEquality goal) + unless + ( hasDerivedLocal leftToRight + && hasDerivedLocal rightToLeft + ) + (throwProof + (ExactProofSetExtensionalityDirectionsUnavailable + location)) + pure (PreparedSetExtensionality location goal) + _ -> do + preparedJustification <- + prepareJustification location justification + prepared <- + liftDriver + (prepareObligation + (Exact.exactBinderContextSupport context) + goal + (toScopedPremise <$> locals) + auxiliaries + (fromMaybe + (vampirePremiseSelection preparedJustification) + selectionOverride)) + >>= either + (throwProof + . ExactProofObligationPreparationFailed location) + pure + pure + (PreparedVampireDischarge + location + preparedJustification + goal + prepared) + where + prepareObligation = + case dischargeMode of + DirectDischarge -> + Declaration.prepareScopedVampireObligationLowering + IndirectContradictionDischarge -> + Declaration.prepareScopedContradictionObligationLowering + + hasDerivedLocal proposition = + any + (\case + PreparedLocal + _ordinal ExactDerivedClaim _support local -> + local == proposition + PreparedLocal{} -> + False) + locals + + toScopedPremise + (PreparedLocal ordinal origin support proposition) = + Declaration.scopedVampirePremise + ordinal origin support proposition + +prepareJustification + :: Location + -> Raw.Justification + -> Prepare PreparedJustification +prepareJustification _location Raw.JustificationEmpty = + pure PreparedAuto +prepareJustification location (Raw.JustificationRef markers) = do + resolved <- traverse (resolveReference location) (toList markers) + let unique = stableUnique resolved + case unique of + [] -> + impossible "a nonempty citation list resolved to no facts" + first : rest -> + pure (PreparedReferences (first :| rest)) +prepareJustification _location Raw.JustificationLocal = + pure PreparedLocalOnly +prepareJustification location Raw.JustificationSetExt = + throwProof (ExactProofUnsupportedStep location) + +vampirePremiseSelection + :: PreparedJustification + -> Declaration.VampirePremiseSelection +vampirePremiseSelection = \case + PreparedAuto -> + Declaration.VampireImplicitPremises + PreparedReferences fingerprints -> + Declaration.VampireExplicitPremises fingerprints + PreparedLocalOnly -> + Declaration.VampireLocalPremises + +resolveReference + :: Location + -> Raw.Marker + -> Prepare SemanticFactOccurrenceFingerprint +resolveReference location marker@(Raw.Marker name) = do + resolved <- + liftDriver + (Declaration.resolveVisibleFactAliasLowering + (semanticName name)) + maybe + (throwProof + (ExactProofUnknownReference location marker)) + pure + resolved + +prepareStatement + :: Exact.ExactBinderContext + -> Raw.Stmt + -> Prepare Exact.PreparedExactProposition +prepareStatement context statement = + liftDriver + (Exact.prepareExactProposition context statement) + >>= either + (throwProof . ExactProofElaborationFailed) + pure + +validateStructuralComposition + :: Location + -> [ScopedCheckedCore ObjectId] + -> ( CheckedFoundation + -> (ObjectId -> Maybe CoreType) + -> Either KernelProof.KernelProofBuildError () + ) + -> Prepare () +validateStructuralComposition location propositions validate = do + foundation <- + liftDriver Declaration.currentFoundationLowering + let identities = + Set.toAscList + (Set.unions + ( canonicalTermGlobals . scopedCoreTerm + <$> propositions + )) + types <- + traverse + (\identity -> do + coreType <- + liftDriver + (Declaration.objectTypeLowering identity) + maybe + (impossible + "a checked structural proof lost a global object") + (\availableType -> pure (identity, availableType)) + coreType) + identities + either + (throwProof + . ExactProofStructuralCompositionFailed location) + pure + (validate foundation + (\identity -> Map.lookup identity (Map.fromList types))) + +structuralFailure :: Location -> Text -> Prepare value +structuralFailure location message = + throwProof + (ExactProofStructuralCompositionFailed + location + (KernelProof.ProofStructuralCompositionMismatch message)) + +data CheckedExactProofAuthorization = CheckedExactProofAuthorization + !PreparedProof + !Bool + +lowerPreparedExactProof + :: PreparedExactProof + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration CheckedExactProofAuthorization)) +lowerPreparedExactProof + (PreparedExactProof _location alias target proof syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [Declaration.checkedCandidate spec planning :| []] + (CheckedExactProofAuthorization + proof + (isJust (preparedProofFirstOmission proof))) + where + requests = plannedProofRequests proof + planning + | isJust (preparedProofFirstOmission proof) = + Declaration.checkedOmittedPlanning requests [] + | otherwise = + Declaration.checkedSourceProofPlanning requests [] + +authorizeCheckedExactProof + :: CheckedExactProofAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedExactProof + (CheckedExactProofAuthorization proof hasOmission) = \case + [candidate :| []] + | hasOmission -> + Declaration.authorizeOmittedCandidate + candidate + (executePreparedProof proof) + | otherwise -> + Declaration.authorizeVampireCandidate + candidate + (executePreparedProof proof) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +data CheckedFinalPreludeFoundationAuthorization = + CheckedFinalPreludeFoundationAuthorization !FoundationAxiomTag + +lowerPreparedFinalPreludeFoundationClaim + :: PreparedFinalPreludeFoundationClaim + -> Declaration.LoweringDriver + (Either + Declaration.DeclarationError + (Declaration.CheckedDeclaration + CheckedFinalPreludeFoundationAuthorization)) +lowerPreparedFinalPreludeFoundationClaim + (PreparedFinalPreludeFoundationClaim + _location alias target tag syntax) = + fmap checked + <$> Declaration.prepareCandidateSpecLowering + [] target SearchEligible [alias] + where + checked spec = + Declaration.checkedProofDeclaration + syntax [] [] [] [] + [ Declaration.checkedCandidate spec + (Declaration.checkedKernelPlanning + (Authority.FoundationLeaf tag) []) + :| [] + ] + (CheckedFinalPreludeFoundationAuthorization tag) + +authorizeCheckedFinalPreludeFoundationClaim + :: CheckedFinalPreludeFoundationAuthorization + -> [NonEmpty Declaration.ReservedCandidate] + -> Declaration.Declaration () +authorizeCheckedFinalPreludeFoundationClaim + (CheckedFinalPreludeFoundationAuthorization tag) = \case + [candidate :| []] -> + Declaration.authorizeKernelConstructionCandidate + (Authority.FoundationLeaf tag) + candidate + (pure (foundationFactDerivation tag)) + stages -> + Declaration.failDeclaration + (Declaration.CheckedAuthorizationCandidateShapeMismatch + 1 (length stages)) + +preparedProofFirstOmission :: PreparedProof -> Maybe Location +preparedProofFirstOmission = \case + PreparedImplicitAuto{} -> Nothing + PreparedQed{} -> Nothing + PreparedOmitted location _goal -> Just location + PreparedFix _identities continuation -> + preparedProofFirstOmission continuation + PreparedAssume _antecedent continuation -> + preparedProofFirstOmission continuation + PreparedTake _identities _witness _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + preparedProofFirstOmission child + PreparedHave _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSuffices _goal _reduction _implication _discharge continuation -> + preparedProofFirstOmission continuation + PreparedCalculate _calculation continuation -> + preparedProofFirstOmission continuation + PreparedSince _since _evidence _claim _discharge continuation -> + preparedProofFirstOmission continuation + PreparedSubclaim _claim subproof continuation -> + preparedProofFirstOmission subproof + <|> preparedProofFirstOmission continuation + PreparedDefine _identity _body _definition continuation -> + preparedProofFirstOmission continuation + PreparedDefineRelational + _identity _body _functionality _definitions continuation -> + preparedProofFirstOmission continuation + PreparedDefineFunction _identity _graph _definition continuation -> + preparedProofFirstOmission continuation + PreparedByCase (PreparedCaseAnalysis _goal cases _exhaustive _discharge) -> + foldr + ((<|>) . preparedProofFirstOmission . preparedCaseProof) + Nothing + cases + PreparedByContradiction _goal _negation _falsum child -> + preparedProofFirstOmission child + PreparedContradiction{} -> Nothing + +plannedProofRequests + :: PreparedProof + -> [Declaration.CheckedPlannedVampireRequest] +plannedProofRequests = \case + PreparedImplicitAuto discharge -> plannedDischargeRequests discharge + PreparedQed discharge -> plannedDischargeRequests discharge + PreparedOmitted{} -> [] + PreparedFix _identities continuation -> + plannedProofRequests continuation + PreparedAssume _antecedent continuation -> + plannedProofRequests continuation + PreparedTake _identities _witness discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + plannedProofRequests child + PreparedHave _claim discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedSuffices _goal _reduction _implication discharge continuation -> + plannedDischargeRequests discharge <> plannedProofRequests continuation + PreparedCalculate calculation continuation -> + plannedCalculationRequests calculation + <> plannedProofRequests continuation + PreparedSince _since evidence _claim discharge continuation -> + plannedSinceEvidenceRequests evidence + <> plannedDischargeRequests discharge + <> plannedProofRequests continuation + PreparedSubclaim _claim subproof continuation -> + plannedProofRequests subproof <> plannedProofRequests continuation + PreparedDefine _identity _body _definition continuation -> + plannedProofRequests continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> + plannedDischargeRequests functionality + <> plannedProofRequests continuation + PreparedDefineFunction _identity _graph _definition continuation -> + plannedProofRequests continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> + concatMap + (plannedProofRequests . preparedCaseProof) + (toList cases) + <> plannedDischargeRequests discharge + PreparedByContradiction _goal _negation _falsum child -> + plannedProofRequests child + PreparedContradiction _goal _falsum discharge -> + plannedDischargeRequests discharge + +plannedDischargeRequests + :: PreparedDischarge + -> [Declaration.CheckedPlannedVampireRequest] +plannedDischargeRequests = \case + PreparedVampireDischarge location _justification _goal obligation -> + [Declaration.checkedPlannedVampireRequest location obligation] + PreparedSetExtensionality{} -> [] + +plannedCalculationRequests + :: PreparedCalculation + -> [Declaration.CheckedPlannedVampireRequest] +plannedCalculationRequests + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + concatMap + (plannedDischargeRequests . preparedCalculationLinkDischarge) + (toList links) + +plannedSinceEvidenceRequests + :: PreparedSinceEvidence + -> [Declaration.CheckedPlannedVampireRequest] +plannedSinceEvidenceRequests = \case + PreparedSinceExisting{} -> [] + PreparedSinceDischarged discharge _local -> + plannedDischargeRequests discharge + +executePreparedProof + :: PreparedProof + -> Declaration.CandidateProof () +executePreparedProof = \case + PreparedImplicitAuto discharge -> + executeDischarge discharge + PreparedQed discharge -> + executeDischarge discharge + PreparedOmitted _location _goal -> + Declaration.recordOmittedUse + PreparedFix _identities continuation -> + executePreparedProof continuation + PreparedAssume _antecedent continuation -> + executePreparedProof continuation + PreparedTake _identities _witness discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + _focus _property _antecedents _target + _hypothesis _result child) -> + executePreparedProof child + PreparedHave _claim discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + executeDischarge discharge + executePreparedProof continuation + unless + (implyScopedCore reduction goal == Just implication) + (impossible "a prepared suffices implication diverged") + PreparedCalculate calculation continuation -> do + executePreparedCalculation calculation + executePreparedProof continuation + PreparedSince sinceProposition evidence _claim discharge continuation -> do + executeSinceEvidence sinceProposition evidence + executeDischarge discharge + executePreparedProof continuation + PreparedSubclaim _claim subproof continuation -> do + executePreparedProof subproof + executePreparedProof continuation + PreparedDefine _identity _body _definition continuation -> + executePreparedProof continuation + PreparedDefineRelational + _identity _body functionality _definitions continuation -> do + executeDischarge functionality + executePreparedProof continuation + PreparedDefineFunction _identity _graph _definition continuation -> + executePreparedProof continuation + PreparedByCase + (PreparedCaseAnalysis _goal cases _exhaustive discharge) -> do + traverse_ (executePreparedProof . preparedCaseProof) cases + executeDischarge discharge + PreparedByContradiction _goal _negation _falsum child -> + executePreparedProof child + PreparedContradiction _goal _falsum discharge -> + executeDischarge discharge + +executeDischarge + :: PreparedDischarge + -> Declaration.CandidateProof () +executeDischarge + (PreparedVampireDischarge + location _justification _goal obligation) = + Declaration.locateProofObligation location + (Declaration.acceptPreparedVampireObligation obligation) +executeDischarge PreparedSetExtensionality{} = + pure () + +executePreparedCalculation + :: PreparedCalculation + -> Declaration.CandidateProof () +executePreparedCalculation + (PreparedCheckedCalculation + _operandType _identities _guard _first links _result) = + traverse_ + (executeDischarge . preparedCalculationLinkDischarge) + links + +executeSinceEvidence + :: ScopedCheckedCore ObjectId + -> PreparedSinceEvidence + -> Declaration.CandidateProof () +executeSinceEvidence proposition = \case + PreparedSinceExisting local -> + unless (preparedLocalProposition local == proposition) + (impossible "a structural since premise diverged") + PreparedSinceDischarged discharge local -> do + executeDischarge discharge + unless + ( preparedDischargeGoal discharge == proposition + && preparedLocalProposition local == proposition + ) + (impossible "a discharged since premise diverged") + +preparedLocalProposition + :: PreparedLocal + -> ScopedCheckedCore ObjectId +preparedLocalProposition + (PreparedLocal _ordinal _origin _support proposition) = + proposition + +encodePreparedProof :: PreparedProof -> ByteString +encodePreparedProof = + encodeCache . putPreparedProof + +putPreparedProof :: PreparedProof -> CachePut +putPreparedProof = \case + PreparedImplicitAuto discharge -> do + putCacheTag 0x00 + putPreparedDischarge discharge + PreparedQed discharge -> do + putCacheTag 0x01 + putPreparedDischarge discharge + PreparedOmitted _location goal -> do + putCacheTag 0x06 + putScopedProposition goal + PreparedFix identities continuation -> do + putCacheTag 0x02 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putPreparedProof continuation + PreparedAssume antecedent continuation -> do + putCacheTag 0x03 + putScopedProposition antecedent + putPreparedProof continuation + PreparedTake identities witness discharge continuation -> do + putCacheTag 0x08 + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putScopedProposition witness + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSetInduction + (PreparedCheckedSetInduction + focus property antecedents target hypothesis result child) -> do + putCacheTag 0x07 + putPreparedSetInductionFocus focus + putScopedProposition property + putCacheList putScopedProposition antecedents + putScopedProposition target + putScopedProposition hypothesis + putScopedProposition result + putPreparedProof child + PreparedHave claim discharge continuation -> do + putCacheTag 0x04 + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSuffices goal reduction implication discharge continuation -> do + putCacheTag 0x0c + putScopedProposition goal + putScopedProposition reduction + putScopedProposition implication + putPreparedDischarge discharge + putPreparedProof continuation + PreparedCalculate calculation continuation -> do + putCacheTag 0x0d + putPreparedCalculation calculation + putPreparedProof continuation + PreparedSince sinceProposition evidence claim discharge continuation -> do + putCacheTag 0x0e + putScopedProposition sinceProposition + putPreparedSinceEvidence evidence + putScopedProposition claim + putPreparedDischarge discharge + putPreparedProof continuation + PreparedSubclaim claim subproof continuation -> do + putCacheTag 0x05 + putScopedProposition claim + putPreparedProof subproof + putPreparedProof continuation + PreparedDefine identity body definitions continuation -> do + putCacheTag 0x09 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedDefineRelational + identity body functionality definitions continuation -> do + putCacheTag 0x11 + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm body + putPreparedDischarge functionality + putCacheList putScopedProposition (toList definitions) + putPreparedProof continuation + PreparedByCase caseAnalysis -> do + putCacheTag 0x0f + putPreparedCaseAnalysis caseAnalysis + PreparedByContradiction goal negation falsum child -> do + putCacheTag 0x10 + putScopedProposition goal + putScopedProposition negation + putScopedProposition falsum + putPreparedProof child + PreparedContradiction goal falsum discharge -> do + putCacheTag 0x0a + putScopedProposition goal + putScopedProposition falsum + putPreparedDischarge discharge + PreparedDefineFunction identity graph definition continuation -> do + putCacheTag 0x0b + putCacheNatural (Exact.exactLocalIdValue identity) + putScopedTerm graph + putScopedProposition definition + putPreparedProof continuation + +putPreparedSetInductionFocus + :: PreparedSetInductionFocus + -> CachePut +putPreparedSetInductionFocus = \case + PreparedInitialSetInductionFocus identity index -> do + putCacheTag 0x00 + putCacheNatural (Exact.exactLocalIdValue identity) + putCacheNatural index + PreparedLeadingSetInductionFocus identity -> do + putCacheTag 0x01 + putCacheNatural (Exact.exactLocalIdValue identity) + +putPreparedDischarge :: PreparedDischarge -> CachePut +putPreparedDischarge + (PreparedVampireDischarge + _location justification goal _obligation) = do + putPreparedDischargeSyntax justification goal +putPreparedDischarge + (PreparedSetExtensionality _location goal) = do + putCacheTag 0x03 + putScopedProposition goal + +putPreparedDischargeSyntax + :: PreparedJustification + -> ScopedCheckedCore ObjectId + -> CachePut +putPreparedDischargeSyntax justification goal = do + putPreparedJustification justification + putScopedProposition goal + +putPreparedCalculation :: PreparedCalculation -> CachePut +putPreparedCalculation + (PreparedCheckedCalculation + operandType identities calculationGuard first links result) = do + putCoreTypeCache operandType + putCacheList + (putCacheNatural . Exact.exactLocalIdValue) + identities + putCacheMaybe putScopedProposition calculationGuard + putCacheList putScopedTerm + (first : (preparedCalculationLinkDestination <$> toList links)) + putCacheList putPreparedDischarge + (preparedCalculationLinkDischarge <$> toList links) + putScopedProposition result + +putPreparedSinceEvidence :: PreparedSinceEvidence -> CachePut +putPreparedSinceEvidence = \case + PreparedSinceExisting local -> do + putCacheTag 0x00 + putPreparedLocalEvidence local + PreparedSinceDischarged discharge local -> do + putCacheTag 0x01 + putPreparedDischarge discharge + putPreparedLocalEvidence local + +putPreparedCaseAnalysis :: PreparedCaseAnalysis -> CachePut +putPreparedCaseAnalysis + (PreparedCaseAnalysis goal cases exhaustive discharge) = do + putScopedProposition goal + putCacheList putPreparedCase (toList cases) + putScopedProposition exhaustive + putPreparedDischarge discharge + +putPreparedCase :: PreparedCase -> CachePut +putPreparedCase (PreparedCase assumption proof) = do + putScopedProposition assumption + putPreparedProof proof + +putPreparedLocalEvidence :: PreparedLocal -> CachePut +putPreparedLocalEvidence + (PreparedLocal ordinal _origin support proposition) = do + putCacheNatural (Backend.localPremiseOrdinalValue ordinal) + putCacheList + (\(identity, coreType) -> do + putCacheNatural (Exact.exactLocalIdValue identity) + putCoreTypeCache coreType) + (Vector.toList support) + putScopedProposition proposition + +implicitAutoProofSyntaxId + :: ScopedCheckedCore ObjectId + -> ProofSyntaxId +implicitAutoProofSyntaxId goal = + proofSyntaxId + (encodeCache do + putCacheTag 0x00 + putPreparedDischargeSyntax PreparedAuto goal) + +putPreparedJustification :: PreparedJustification -> CachePut +putPreparedJustification = \case + PreparedAuto -> + putCacheTag 0x00 + PreparedReferences fingerprints -> do + putCacheTag 0x01 + putCacheList + putSemanticFactOccurrenceFingerprintCache + (toList fingerprints) + PreparedLocalOnly -> + putCacheTag 0x02 + +putScopedProposition + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedProposition proposition = do + putCacheList putCoreTypeCache + (scopedCoreContext proposition) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm proposition) + +putScopedTerm + :: ScopedCheckedCore ObjectId + -> CachePut +putScopedTerm term = do + putCacheList putCoreTypeCache + (scopedCoreContext term) + putCoreTypeCache (scopedCoreType term) + putCanonicalTermCache putObjectIdCache + (scopedCoreTerm term) + +proofLocation :: Location -> Raw.Proof -> Location +proofLocation fallback = \case + Raw.Omitted location -> location + Raw.Qed maybeLocation _justification -> + fromMaybe fallback maybeLocation + Raw.Contradiction location _justification -> location + Raw.ByCase location _cases -> location + Raw.ByContradiction location _proof -> location + Raw.BySetInduction location _term _proof -> location + Raw.ByOrdInduction location _proof -> location + Raw.Assume location _statement _proof -> location + Raw.FixSymbolic location _variables _bound _proof -> location + Raw.FixSuchThat location _variables _statement _proof -> location + Raw.Calc location _quantifier _calculation _proof -> location + Raw.TakeVar location _variables _bound _statement _justification _proof -> + location + Raw.TakeNoun location _noun _justification _proof -> location + Raw.Have location _since _statement _justification _proof -> location + Raw.Suffices location _statement _justification _proof -> location + Raw.Subclaim location _statement _subproof _proof -> location + Raw.Define location _variable _expression _proof -> location + Raw.DefineFunction location _function _argument _value _bound _domain _proof -> + location + Raw.DefineFunctionLocal + location _function _argument _value _bound _target _rules _proof -> + location + +throwProof :: ExactProofError -> Prepare value +throwProof = + State.lift . Except.throwError + +liftDriver + :: Declaration.LoweringDriver value + -> Prepare value +liftDriver = + State.lift . Except.lift + +stableUnique :: Ord value => [value] -> [value] +stableUnique = + reverse . snd + . foldl' + (\(seen, reversed) value -> + if value `Set.member` seen + then (seen, reversed) + else + ( Set.insert value seen + , value : reversed + )) + (Set.empty, []) diff --git a/source/Checking/Exact/Vocabulary.hs b/source/Felix/Checking/Exact/Vocabulary.hs index 5701f64..a712bf1 100644 --- a/source/Checking/Exact/Vocabulary.hs +++ b/source/Felix/Checking/Exact/Vocabulary.hs @@ -2,9 +2,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Semantic classification shared by the exact source compilers. -module Checking.Exact.Vocabulary +module Felix.Checking.Exact.Vocabulary ( FixedSemanticMeaning(..) , fixedSemanticMeaning + , lowerFixedEqualityPredicate , ExactSymbolClass(..) , classifyExactSymbol , FixedSetTermDispatch(..) @@ -12,11 +13,11 @@ module Checking.Exact.Vocabulary ) where import Base hiding (Empty) -import Checking.Core -import Checking.Semantic -import Syntax.Abstract qualified as Raw -import Syntax.Internal qualified as Internal -import Syntax.Lexicon qualified as Lexicon +import Felix.Checking.Core +import Felix.Checking.Semantic +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map @@ -43,6 +44,14 @@ fixedSemanticVocabulary = [ ( relationKey Raw.EqSymbol , FixedEquality ) + , ( SemanticRightAdjective + (Raw.lexicalItemPattern + Lexicon.builtinEqualityRightAdjective) + , FixedEquality + ) + , ( verbKey Lexicon.builtinEqualityVerb + , FixedEquality + ) , ( relationKey Raw.ElementSymbol , FixedIntrinsic Member ) @@ -59,7 +68,7 @@ fixedSemanticVocabulary = (Raw.TokenCons (Raw.Command "emptyset") Raw.End) , FixedIntrinsic Empty ) - , ( expressionKey (unaryCommandPattern "unions") + , ( expressionKey (Raw.mixfixPattern Raw.UnionsSymbol) , FixedIntrinsic FamilyUnion ) , ( expressionKey (unaryCommandPattern "pow") @@ -80,8 +89,27 @@ fixedSemanticVocabulary = nounKey item = let patterns = Raw.lexicalItemSgPlPattern item in SemanticNoun (Raw.sg patterns) (Raw.pl patterns) + verbKey item = + let patterns = Raw.lexicalItemSgPlPattern item + in SemanticVerb (Raw.sg patterns) (Raw.pl patterns) expressionKey = SemanticExpressionFunction +-- | Lower the fixed proposition meanings shared by raw exact elaboration and +-- the reusable internal-formula path. Membership deliberately retains its +-- carrier-aware source lowering and is not handled here. +lowerFixedEqualityPredicate + :: FixedSemanticMeaning + -> [CanonicalTerm global] + -> Maybe (CanonicalTerm global) +lowerFixedEqualityPredicate meaning arguments = + case (meaning, arguments) of + (FixedEquality, [left, right]) -> + Just (CEq TySet left right) + (FixedDisequality, [left, right]) -> + Just (CImp (CEq TySet left right) CFalsum) + _ -> + Nothing + unaryCommandPattern :: Text -> Raw.Pattern unaryCommandPattern command = Raw.TokenCons (Raw.Command command) diff --git a/source/Checking/FinalPrelude.hs b/source/Felix/Checking/FinalPrelude.hs index 5951acc..9cc43f4 100644 --- a/source/Checking/FinalPrelude.hs +++ b/source/Felix/Checking/FinalPrelude.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} -- | Authority-confined construction of the inert final-prelude candidate. -module Checking.FinalPrelude +module Felix.Checking.FinalPrelude ( FinalPreludeCandidate , finalPreludeParsed , finalPreludeSyntax @@ -19,26 +19,29 @@ module Checking.FinalPrelude , FinalPreludeBuildResult(..) , buildFinalPreludeCandidate , buildParsedFinalPreludeCandidate + , validateOmegaFactInventory ) where import Base hiding (Empty) -import Checking.Authority qualified as Authority -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Exact.Proof qualified as ExactProof -import Checking.Foundation -import Checking.Identity -import Checking.Semantic -import Checking.Semantic qualified as Semantic +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.SetConstruction +import Felix.Checking.Semantic +import Felix.Checking.Semantic qualified as Semantic import Felix.Module +import Felix.Cache.Codec (CacheDigest) import Felix.Parse import Felix.Prelude qualified as Prelude import Felix.Source (ImportRef) -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import Syntax.Lexicon qualified as Lexicon +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon qualified as Lexicon import Control.Monad (unless) import Data.Bifunctor (first) @@ -164,7 +167,8 @@ data FinalPreludeBuildResult data PlannedPreludeDeclaration = PlannedPreludeBinding - !(Declaration.PlannedDeclaration (Maybe ObjectId)) + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) | PlannedPreludeFoundation !(Declaration.PlannedDeclaration ExactProof.CheckedFinalPreludeFoundationAuthorization) @@ -540,6 +544,19 @@ resolveAndValidatePublicRoles foundation objects declarations = do omegaBody let omegaId = definitionViewObject omega + omegaConstruction <- + expectedOmegaConstruction objects omegaBody + omegaDerived <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (namedSetConstructionObjectFact + (checkedFoundationSetConstruction foundation) + omegaId + omegaConstruction) + naturals <- expectDefinition foundation objects declarations @@ -557,12 +574,14 @@ resolveAndValidatePublicRoles foundation objects declarations = do (infinity, infinityTarget) <- expectClaim declarations "prelude_infinity" validateInfinityTarget objects inductiveId infinityTarget + omegaDeclaration <- findDeclaration "prelude_omega" declarations omegaEquation <- - fst - <$> expectFactTarget - declarations - "prelude_omega" - (CEq TySet (CGlobal omegaId) omegaBody) + validateOmegaDeclaration + objects + omegaId + omegaBody + omegaDerived + omegaDeclaration let inductiveOmega = CApp (CGlobal inductiveId) (CGlobal omegaId) minimalOmega = expectedMinimality inductiveId omegaId @@ -606,6 +625,159 @@ resolveAndValidatePublicRoles foundation objects declarations = do PreludeInfinityTheorem)) pure roles +expectedOmegaConstruction + :: CheckedObjectClosure + -> CanonicalTerm ObjectId + -> Either + FinalPreludeValidationError + (NamedSetConstruction ObjectId) +expectedOmegaConstruction objects = \case + CApp (CApp (CIntrinsic Sep) bound) (CLam TySet predicate) -> do + checkedBound <- checked [] bound + checkedPredicate <- checked [TySet] predicate + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + Right + (checkedSeparationConstruction + (`lookupCheckedObjectType` objects) + checkedBound + checkedPredicate) + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + where + checked context term = + first + (const + (FinalPreludeFactContentMismatch + "prelude_omega")) + (checkScopedCanonicalCore + (`lookupCheckedObjectType` objects) + context + term) + +validateOmegaDeclaration + :: CheckedObjectClosure + -> ObjectId + -> CanonicalTerm ObjectId + -> NamedSetConstructionFact + -> PreludeDeclaration + -> Either FinalPreludeValidationError TheoremRef +validateOmegaDeclaration objects omegaId omegaBody derived declaration = do + let batch = declarationBatch declaration + delta = Declaration.committedBatchDelta batch + omegaContent <- case lookupCheckedObjectContent omegaId objects of + Just content@TransparentObjectContent{} -> pure content + _ -> + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + unless + ( declarationDeltaObjects delta == [omegaId] + && case Declaration.committedBatchObjects batch of + [asserted] -> + assertedObjectId asserted == omegaId + && assertedObjectContent asserted == omegaContent + _ -> False + && null (Declaration.committedBatchProofValidations batch) + ) + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + certificates <- + maybe + (Left + (FinalPreludeFactContentMismatch + "prelude_omega")) + (Right . declarationValidationRecordCertificates) + (Declaration.committedBatchDeclarationValidation batch) + validateOmegaFactInventory + omegaId + omegaBody + (namedSetConstructionFactProposition derived) + (namedSetConstructionFactDescriptor derived) + (declarationDeltaFacts delta) + (declarationDeltaAliases delta) + (Declaration.committedBatchPropositions batch) + certificates + +-- | Purpose-specific audit of the distinguished Omega definition. It is +-- deliberately not a general declaration manifest: the confined prelude has +-- exactly one declaration whose public role requires this two-fact shape. +-- The explicit arguments also provide a narrow pure seam for corruption +-- regression tests. +validateOmegaFactInventory + :: ObjectId + -> CanonicalTerm ObjectId + -> FrozenCheckedCore ObjectId + -> CacheDigest + -> [SemanticFactOccurrence] + -> [SemanticAlias] + -> [CheckedPropositionContent] + -> [Authority.ValidationCertificate] + -> Either FinalPreludeValidationError TheoremRef +validateOmegaFactInventory + omegaId omegaBody expectedExtensional expectedDescriptor + facts aliases propositions certificates = do + (equationOccurrence, extensionalOccurrence) <- + case facts of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + (equationCertificate, extensionalCertificate) <- + case certificates of + [equation, extensional] -> Right (equation, extensional) + _ -> mismatch + case aliases of + [alias] + | semanticAliasName alias == semanticName "prelude_omega" + , semanticAliasTarget alias + == semanticFactFingerprint equationOccurrence -> + pure () + _ -> mismatch + equation <- propositionFor equationOccurrence + extensional <- propositionFor extensionalOccurrence + unless + ( length propositions == 2 + && semanticFactSearchEligibility equationOccurrence + == SearchIneligible + && frozenCoreTerm (checkedPropositionTerm equation) + == CEq TySet (CGlobal omegaId) omegaBody + && Authority.validationTarget equationCertificate + == semanticFactAuthority equationOccurrence + && Authority.validationDirectAuthorization equationCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedDefinitionEquation omegaId) + && semanticFactSearchEligibility extensionalOccurrence + == SearchEligible + && checkedPropositionTerm extensional == expectedExtensional + && Authority.validationTarget extensionalCertificate + == semanticFactAuthority extensionalOccurrence + && Authority.validationDirectAuthorization extensionalCertificate + == Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + omegaId expectedDescriptor) + ) + mismatch + pure + (Authority.factAuthorityTheorem + (semanticFactAuthority equationOccurrence)) + where + mismatch = + Left + (FinalPreludeFactContentMismatch + "prelude_omega") + + propositionFor occurrence = + case List.filter + ((== semanticFactProposition occurrence) + . checkedPropositionId) + propositions of + [proposition] -> Right proposition + _ -> mismatch + validatePackagedPreludeInput :: Prelude.ReservedParsedPrelude -> ModuleSyntaxInterface @@ -805,6 +977,16 @@ validateDeclarationAuthority foundation objects declaration = do (Left (FinalPreludeAuthorityMismatch slot)) _ -> Left (FinalPreludeAuthorityMismatch slot) + Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + identity _descriptor) -> + case lookupCheckedObjectContent identity objects of + Just TransparentObjectContent{} + | semanticFactSearchEligibility occurrence + == SearchEligible -> + pure () + _ -> + Left (FinalPreludeAuthorityMismatch slot) Authority.CheckedSourceProof requests -> unless ( not (null requests) @@ -900,17 +1082,34 @@ expectFact (TheoremRef, CanonicalTerm ObjectId) expectFact declarations marker = do declaration <- findDeclaration marker declarations + unless + (length + (declarationDeltaFacts + (Declaration.committedBatchDelta + (declarationBatch declaration))) == 1) + (Left (FinalPreludeFactContentMismatch marker)) + expectAliasedFact declaration marker + +expectAliasedFact + :: PreludeDeclaration + -> Text + -> Either + FinalPreludeValidationError + (TheoremRef, CanonicalTerm ObjectId) +expectAliasedFact declaration marker = do let batch = declarationBatch declaration delta = Declaration.committedBatchDelta batch expectedAlias = semanticName marker - occurrence <- case declarationDeltaFacts delta of + fingerprint <- case declarationDeltaAliases delta of + [alias] + | semanticAliasName alias == expectedAlias -> + Right (semanticAliasTarget alias) + _ -> Left (FinalPreludeFactContentMismatch marker) + occurrence <- case List.filter + ((== fingerprint) . semanticFactFingerprint) + (declarationDeltaFacts delta) of [single] -> Right single _ -> Left (FinalPreludeFactContentMismatch marker) - unless - (declarationDeltaAliases delta - == [semanticAlias expectedAlias - (semanticFactFingerprint occurrence)]) - (Left (FinalPreludeFactContentMismatch marker)) proposition <- maybe (Left (FinalPreludeFactContentMismatch marker)) @@ -925,20 +1124,6 @@ expectFact declarations marker = do , frozenCoreTerm (checkedPropositionTerm proposition) ) -expectFactTarget - :: [PreludeDeclaration] - -> Text - -> CanonicalTerm ObjectId - -> Either - FinalPreludeValidationError - (TheoremRef, CanonicalTerm ObjectId) -expectFactTarget declarations marker expected = do - result@(_theorem, actual) <- expectFact declarations marker - unless - (actual == expected) - (Left (FinalPreludeFactContentMismatch marker)) - pure result - validateInfinityTarget :: CheckedObjectClosure -> ObjectId diff --git a/source/Checking/Foundation.hs b/source/Felix/Checking/Foundation.hs index 317d1b5..5852901 100644 --- a/source/Checking/Foundation.hs +++ b/source/Felix/Checking/Foundation.hs @@ -6,7 +6,7 @@ -- Constructing 'CheckedFoundation' requires exact manifest coverage, closed -- well-typed schemas, and structural backend classification. This gate -- certifies manifest conformance only; it is not a consistency proof. -module Checking.Foundation +module Felix.Checking.Foundation ( FoundationAxiomTag(..) , KernelRuleTag(..) , KernelRuleSignature(..) @@ -32,7 +32,7 @@ module Checking.Foundation ) where import Base hiding (Empty) -import Checking.Core +import Felix.Checking.Core import Control.Monad (unless) import Data.List qualified as List diff --git a/source/Checking/Identity.hs b/source/Felix/Checking/Identity.hs index fe846dc..67347a3 100644 --- a/source/Checking/Identity.hs +++ b/source/Felix/Checking/Identity.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Content-addressed identities for checked mathematical content. -module Checking.Identity +module Felix.Checking.Identity ( TheoryId , theoryId , theoryIdDigest @@ -67,8 +67,8 @@ module Checking.Identity ) where import Base -import Checking.Core -import Checking.Foundation +import Felix.Checking.Core +import Felix.Checking.Foundation import Felix.Cache.Codec import Felix.Math.Codec import Felix.Module diff --git a/source/Checking/Kernel/Derivation.hs b/source/Felix/Checking/Kernel/Derivation.hs index 65bcc25..e83b376 100644 --- a/source/Checking/Kernel/Derivation.hs +++ b/source/Felix/Checking/Kernel/Derivation.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Private in-memory proof trees and independent kernel replay. -module Checking.Kernel.Derivation +module Felix.Checking.Kernel.Derivation ( ImportIx , importIx , importIxValue @@ -53,10 +53,10 @@ module Checking.Kernel.Derivation ) where import Base -import Checking.Core -import Checking.Foundation -import Checking.Kernel.Semantics qualified as Semantics -import Checking.Kernel.SetLfp qualified as SetLfp +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp import Control.Monad (unless) import Data.Bifunctor (first) diff --git a/source/Checking/Kernel/Proof.hs b/source/Felix/Checking/Kernel/Proof.hs index 42324d1..d4ccedc 100644 --- a/source/Checking/Kernel/Proof.hs +++ b/source/Felix/Checking/Kernel/Proof.hs @@ -3,7 +3,7 @@ -- | Small proof-producing natural-deduction combinators. Every resulting tree -- is still replayed independently before it can authorize a fact. -module Checking.Kernel.Proof +module Felix.Checking.Kernel.Proof ( ProofContext , rootProofContext , proofContextTypes @@ -33,6 +33,10 @@ module Checking.Kernel.Proof , disjunctionLeftProof , disjunctionRightProof , disjunctionEliminationProof + , validateCaseAnalysisComposition + , validateDoubleNegationComposition + , validateFalsumEliminationComposition + , validateSetInductionComposition , existentialTerm , existentialIntroductionProof , existentialEliminationProof @@ -43,16 +47,18 @@ module Checking.Kernel.Proof ) where import Base -import Checking.Core -import Checking.Foundation -import Checking.Kernel.Derivation -import Checking.Kernel.Semantics qualified as Semantics -import Checking.Kernel.SetLfp qualified as SetLfp +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp import Control.Monad (unless) import Data.Bifunctor (first) import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text +import Numeric.Natural (Natural) data ProofContext global = ProofContext @@ -108,6 +114,7 @@ data KernelProofBuildError | ProofExpectedUnaryBinder | ProofSetLfpRuleFailed !Text | ProofConversionPlanFailed !Text + | ProofStructuralCompositionMismatch !Text deriving stock (Show, Eq) scopedTerm @@ -881,6 +888,276 @@ disjunctionEliminationProof result doubleNegation +-- | Validate the one structural rule used by exact source case analysis. +-- The branch proofs and the exhaustive disjunction are represented here by +-- exact hypotheses; the kernel combinators must derive the owned goal from +-- precisely those propositions. No derived proof escapes this check. +validateCaseAnalysisComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateCaseAnalysisComposition + foundation globalType goal cases exhaustive = do + validatePropositionContext "case goal" lexicalContext goal + traverse_ + (validatePropositionContext "case assumption" lexicalContext) + cases + validatePropositionContext + "case exhaustiveness target" lexicalContext exhaustive + let expectedExhaustive = + foldl1 + (\left right -> + CImp + (CImp left CFalsum) + right) + (scopedCoreTerm <$> cases) + unless (scopedCoreTerm exhaustive == expectedExhaustive) + (Left + (ProofStructuralCompositionMismatch + "case exhaustiveness is not the source-ordered disjunction")) + branchImplications <- + traverse + (checkedImplication lexicalContext goal) + cases + let context = + ProofContext + foundation + globalType + lexicalContext + (exhaustive : toList branchImplications) + exhaustiveProof <- hypothesisProof context exhaustive + result <- + eliminateCases + context goal cases exhaustiveProof + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "case elimination did not derive the owned goal")) + where + lexicalContext = scopedCoreContext goal + + checkedImplication expectedContext conclusion antecedent = + case implyScopedCore antecedent conclusion of + Just implication + | scopedCoreContext implication == expectedContext -> + pure implication + _ -> + Left + (ProofStructuralCompositionMismatch + "case branch implication changed context") + + eliminateCases context result (only :| []) caseProof = do + branchImplication <- + scopedTerm context + (CImp + (scopedCoreTerm only) + (scopedCoreTerm result)) + >>= hypothesisProof context + implicationEliminationProof context branchImplication caseProof + eliminateCases context result (firstCase :| rest) disjunctionProof = do + let allCases = firstCase :| rest + leftCases = NonEmpty.fromList (NonEmpty.init allCases) + rightCase = NonEmpty.last allCases + leftTerm = + foldl1 disjunctionTerm + (scopedCoreTerm <$> leftCases) + disjunctionEliminationProof + context + leftTerm + (scopedCoreTerm rightCase) + disjunctionProof + result + (\extended leftProof -> + eliminateCases extended result leftCases leftProof) + (\extended rightProof -> do + branchImplication <- + scopedTerm extended + (CImp + (scopedCoreTerm rightCase) + (scopedCoreTerm result)) + >>= hypothesisProof extended + implicationEliminationProof + extended branchImplication rightProof) + +-- | Validate the exact classical closing step for a proof by contradiction. +-- The only classical input is the confined 'DoubleNegationElim' foundation +-- row already consumed by 'doubleNegationEliminationProof'. +validateDoubleNegationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateDoubleNegationComposition + foundation globalType goal negation falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext + "contradiction negation" lexicalContext negation + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not target falsum")) + expectedNegation <- + checkedNegation lexicalContext goal + unless (negation == expectedNegation) + (Left + (ProofStructuralCompositionMismatch + "proof by contradiction did not own the exact negated goal")) + doubleNegation <- + checkedNegation lexicalContext negation + let context = + ProofContext + foundation globalType lexicalContext [doubleNegation] + hypothesis <- hypothesisProof context doubleNegation + result <- doubleNegationEliminationProof context goal hypothesis + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "double-negation elimination did not derive the owned goal")) + +-- | Validate the exact ex-falso closing step used after a terminal indirect +-- contradiction discharge. +validateFalsumEliminationComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateFalsumEliminationComposition foundation globalType goal falsum = do + let lexicalContext = scopedCoreContext goal + validatePropositionContext "contradiction goal" lexicalContext goal + validatePropositionContext "contradiction falsum" lexicalContext falsum + unless (scopedCoreTerm falsum == CFalsum) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not receive falsum")) + let context = + ProofContext foundation globalType lexicalContext [falsum] + hypothesis <- hypothesisProof context falsum + result <- falsumEliminationProof context hypothesis goal + unless (builtProofStatement result == goal) + (Left + (ProofStructuralCompositionMismatch + "falsum elimination did not derive the owned goal")) + +-- | Validate the exact structural instance used by source set induction. +-- The admitted child is represented by its generalized step proposition; +-- the checked foundation row must specialize to that exact premise and the +-- owned binder-level result. No induction principle becomes an ATP premise. +validateSetInductionComposition + :: Eq global + => CheckedFoundation + -> (global -> Maybe CoreType) + -> Natural + -> ScopedCheckedCore global + -> [ScopedCheckedCore global] + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validateSetInductionComposition + foundation globalType selected property antecedents childTarget + hypothesis result = do + let lexicalContext = scopedCoreContext property + traverse_ + (validatePropositionContext + "set-induction antecedent" lexicalContext) + antecedents + validatePropositionContext + "set-induction property" lexicalContext property + validatePropositionContext + "set-induction child target" lexicalContext childTarget + validatePropositionContext + "set-induction hypothesis" lexicalContext hypothesis + validatePropositionContext + "set-induction result" lexicalContext result + expectedProperty <- + foldrM implyChecked childTarget antecedents + unless (property == expectedProperty) + (Left + (ProofStructuralCompositionMismatch + "set-induction property does not own the child target and guards")) + (predicate, expectedHypothesis, step, expectedResult) <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction focus is not a set-valued ambient binder")) + pure + (scopedSetInductionInstance selected property) + unless (hypothesis == expectedHypothesis) + (Left + (ProofStructuralCompositionMismatch + "set-induction hypothesis does not match the owned property")) + unless (result == expectedResult) + (Left + (ProofStructuralCompositionMismatch + "set-induction result does not close the owned property")) + let context = + ProofContext foundation globalType lexicalContext [step] + stepProof <- hypothesisProof context step + axiom <- foundationProof context SetInduction + instanceProof <- forallEliminationProof context axiom predicate + expectedInstance <- + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction instance changed lexical context")) + pure + (implyScopedCore step result) + convertedInstance <- + conversionProof context instanceProof expectedInstance + resultProof <- + implicationEliminationProof context convertedInstance stepProof + unless (builtProofStatement resultProof == result) + (Left + (ProofStructuralCompositionMismatch + "set-induction foundation instance did not derive the owned result")) + where + implyChecked antecedent conclusion = + maybe + (Left + (ProofStructuralCompositionMismatch + "set-induction guard changed lexical context")) + pure + (implyScopedCore antecedent conclusion) + +validatePropositionContext + :: Text + -> [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError () +validatePropositionContext label expected proposition = + unless + ( scopedCoreType proposition == TyProp + && scopedCoreContext proposition == expected + ) + (Left + (ProofStructuralCompositionMismatch + (label <> " has the wrong type or lexical context"))) + +checkedNegation + :: [CoreType] + -> ScopedCheckedCore global + -> Either KernelProofBuildError (ScopedCheckedCore global) +checkedNegation expectedContext proposition = + case negateScopedCore proposition of + Just negation + | scopedCoreContext negation == expectedContext -> + pure negation + _ -> + Left + (ProofStructuralCompositionMismatch + "classical negation changed context") + existentialTerm :: CoreType -> CanonicalTerm global diff --git a/source/Checking/Kernel/Semantics.hs b/source/Felix/Checking/Kernel/Semantics.hs index 3306b09..f9cfcfa 100644 --- a/source/Checking/Kernel/Semantics.hs +++ b/source/Felix/Checking/Kernel/Semantics.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Checked logical inference over scoped canonical HOL terms. -module Checking.Kernel.Semantics +module Felix.Checking.Kernel.Semantics ( implicationElimination , implicationIntroduction , forallElimination @@ -17,7 +17,7 @@ module Checking.Kernel.Semantics ) where import Base -import Checking.Core +import Felix.Checking.Core import Control.Monad (unless) import Data.Bifunctor (first) diff --git a/source/Checking/Kernel/SetLfp.hs b/source/Felix/Checking/Kernel/SetLfp.hs index e3fa175..19f6714 100644 --- a/source/Checking/Kernel/SetLfp.hs +++ b/source/Felix/Checking/Kernel/SetLfp.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | The four checked rules for the bounded set-valued least fixed point. -module Checking.Kernel.SetLfp +module Felix.Checking.Kernel.SetLfp ( setLfpBound , setLfpLeast , setLfpFixed @@ -16,8 +16,8 @@ module Checking.Kernel.SetLfp ) where import Base -import Checking.Core -import Checking.Foundation +import Felix.Checking.Core +import Felix.Checking.Foundation import Data.Bifunctor (first) import Numeric.Natural (Natural) diff --git a/source/Checking/Materialization.hs b/source/Felix/Checking/Materialization.hs index 6dcf1f0..51944a5 100644 --- a/source/Checking/Materialization.hs +++ b/source/Felix/Checking/Materialization.hs @@ -5,7 +5,7 @@ -- -- Successful checks are inert. Fresh completion and validated loading or -- sealing own the runtime authority that may publish a fact. -module Checking.Materialization +module Felix.Checking.Materialization ( CandidateValidation , candidateProofValidation , candidateDeclarationValidation @@ -17,9 +17,9 @@ module Checking.Materialization ) where import Base -import Checking.Authority -import Checking.Identity -import Checking.Semantic +import Felix.Checking.Authority +import Felix.Checking.Identity +import Felix.Checking.Semantic import Control.Monad (unless) import Numeric.Natural (Natural) diff --git a/source/Checking/Module.hs b/source/Felix/Checking/Module.hs index 453059a..88c8fef 100644 --- a/source/Checking/Module.hs +++ b/source/Felix/Checking/Module.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} -- | Explicit inputs and sealed outputs for the typed module driver. -module Checking.Module +module Felix.Checking.Module ( LiveModuleBinding(..) , IdentifiedModuleInput , identifiedPhysicalModule @@ -55,23 +55,23 @@ module Checking.Module ) where import Base -import Checking.Declaration qualified as Declaration -import Checking.Exact qualified as Exact -import Checking.Exact.Datatype qualified as ExactDatatype -import Checking.Exact.Inductive qualified as ExactInductive -import Checking.Exact.Proof qualified as ExactProof -import Checking.FinalPrelude qualified as FinalPrelude -import Checking.Foundation -import Checking.Identity -import Checking.Semantic +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Checking.Semantic import Felix.Module import Felix.Parse import Felix.Prelude qualified as Prelude import Felix.Source import Felix.Store qualified as Store -import Report.Location -import Syntax.Interface -import Syntax.Abstract qualified as Raw +import Felix.Report.Location +import Felix.Syntax.Interface +import Felix.Syntax.Abstract qualified as Raw import Control.Monad (unless) import Data.Bifunctor (first) @@ -678,7 +678,8 @@ data TypedModuleResult data PlannedTypedDeclaration = PlannedBinding - !(Declaration.PlannedDeclaration (Maybe ObjectId)) + !(Declaration.PlannedDeclaration + Exact.CheckedExactBindingAuthorization) | PlannedSourceAxiom !(Declaration.PlannedDeclaration ()) | PlannedInductive diff --git a/source/Checking/Semantic.hs b/source/Felix/Checking/Semantic.hs index 7a05f39..c9442f3 100644 --- a/source/Checking/Semantic.hs +++ b/source/Felix/Checking/Semantic.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Canonical semantic declaration, prefix, interface, and validation keys. -module Checking.Semantic +module Felix.Checking.Semantic ( DeclarationSlot , declarationSlot , declarationSlotModule @@ -150,16 +150,16 @@ module Checking.Semantic ) where import Base -import Checking.Authority -import Checking.Core -import Checking.Identity +import Felix.Checking.Authority +import Felix.Checking.Core +import Felix.Checking.Identity import Felix.Cache.Codec import Felix.Math.Codec import Felix.Module import Felix.Parsed.Identity import Felix.Source -import Syntax.Interface -import Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Abstract import Control.DeepSeq (NFData) import Control.Monad (unless, when) diff --git a/source/Felix/Checking/SetConstruction.hs b/source/Felix/Checking/SetConstruction.hs new file mode 100644 index 0000000..a5e1d80 --- /dev/null +++ b/source/Felix/Checking/SetConstruction.hs @@ -0,0 +1,1191 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Checked source semantics for named separation and functional replacement. +-- +-- A value of 'NamedSetConstruction' is the sole transient owner of the +-- source decomposition. Its smart constructors validate the complete +-- telescope and derive one canonical term. Local views, transparent content, +-- direct extensional facts, and cache-scoped descriptors all consume that +-- same checked value. +module Felix.Checking.SetConstruction + ( NamedSetConstruction + , checkedSeparationConstruction + , checkedFunctionalReplacementConstruction + , namedSetConstructionTerm + , namedSetConstructionLocalViews + , namedSetConstructionClosedBody + , SetConstructionFoundation + , setConstructionFoundation + , checkedFoundationSetConstruction + , NamedSetConstructionFact + , namedSetConstructionFactProposition + , namedSetConstructionFactDescriptor + , namedSetConstructionObjectFact + , CheckedRelationalSetConstruction + , checkedRelationalReplacementConstruction + , relationalSetConstructionTerm + , relationalSetConstructionFunctionality + , relationalSetConstructionClosedFunctionality + , relationalSetConstructionLocalViews + , relationalSetConstructionClosedBody + , RelationalSetConstructionFact + , relationalSetConstructionFactProposition + , relationalSetConstructionFactDescriptor + , relationalSetConstructionObjectFact + ) where + +import Base hiding (Empty) +import Felix.Checking.Core +import Felix.Checking.Foundation +import Felix.Checking.Identity +import Felix.Cache.Codec + ( CacheDigest + , encodeCache + , hashCacheFields + , putCanonicalTermCache + , putCoreTypeCache + ) + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Numeric.Natural (Natural) + + +-- | The exact fixed rows used by the narrow derived extensionality schema. +-- Proof-local construction obtains these rows through the confined foundation +-- lookup; declaration authorization obtains them from 'CheckedFoundation'. +data SetConstructionFoundation = SetConstructionFoundation + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + !(FrozenCheckedCore Void) + +setConstructionFoundation + :: FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> FrozenCheckedCore Void + -> SetConstructionFoundation +setConstructionFoundation = + SetConstructionFoundation + +checkedFoundationSetConstruction + :: CheckedFoundation + -> SetConstructionFoundation +checkedFoundationSetConstruction foundation = + SetConstructionFoundation + (foundationAxiomFrozen foundation FamilyUnionCharacteristic) + (foundationAxiomFrozen foundation SeparationCharacteristic) + (foundationAxiomFrozen foundation ReplacementCharacteristic) + (foundationAxiomFrozen foundation SetChooseWitness) + +data NamedSetConstruction global = NamedSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(NamedSetConstructionShape global) + !(BuiltSetConstruction global) + deriving stock (Eq) + +data NamedSetConstructionShape global + = SeparationShape + !(CanonicalTerm global) + !(CanonicalTerm global) + | FunctionalReplacementShape + !(NonEmpty (CanonicalTerm global)) + !(CanonicalTerm global) + !(Maybe (CanonicalTerm global)) + deriving stock (Eq) + +-- | The one canonical build result retained by the checked construction. +-- Characteristic applications describe the exact primitive rows used by the +-- derived theorem schema; the flattened body is the deterministic composition +-- of those rows for the source telescope. +data BuiltSetConstruction global = BuiltSetConstruction + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +data CheckedCharacteristicApplication global = + CheckedCharacteristicApplication + !CoreIntrinsicTag + ![CoreType] + !(CanonicalTerm global) + !(NonEmpty (CoreType, CanonicalTerm global)) + !(CanonicalTerm global) + deriving stock (Eq) + +-- | One checked relational replacement. Unlike the unconditional named +-- constructions above, its flattened membership theorem is available only +-- after the separately checked functionality proposition has authority. +-- This value owns the source telescope, the one canonical choice/replacement +-- term, and the exact primitive characteristic applications used by that +-- narrow derived schema. +data CheckedRelationalSetConstruction global = + CheckedRelationalSetConstruction + ![CoreType] + !(Map.Map global CoreType) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + !(CanonicalTerm global) + ![CheckedCharacteristicApplication global] + deriving stock (Eq) + +-- | Validate one source relational replacement. The relation is checked in +-- the nearest-first context @[range, domain] <> outer@, matching the source +-- binder order @y x A P@ without retaining source syntax. +checkedRelationalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (CheckedRelationalSetConstruction global) +checkedRelationalReplacementConstruction globalType domain relation = do + guard (scopedCoreType domain == TySet) + guard (scopedCoreType relation == TyProp) + let context = scopedCoreContext domain + guard (scopedCoreContext relation == TySet : TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm domain, scopedCoreTerm relation] + let domainTerm = scopedCoreTerm domain + relationTerm = scopedCoreTerm relation + domainPredicate = CLam TySet (logicalExists relationTerm) + restrictedDomain = applyIntrinsic2 Sep domainTerm domainPredicate + choiceFunction = + CLam TySet + (applyIntrinsic SetChoose (CLam TySet relationTerm)) + replacement = applyIntrinsic2 Repl restrictedDomain choiceFunction + functionality = relationalFunctionality domainTerm relationTerm + membership = relationalMembership domainTerm relationTerm + applications = + [ characteristicApplication + Sep context restrictedDomain + [ (TySet, domainTerm) + , (TyArrow TySet TyProp, domainPredicate) + ] + , characteristicApplication + Repl context replacement + [ (TySet, restrictedDomain) + , (TyArrow TySet TySet, choiceFunction) + ] + ] + construction = + CheckedRelationalSetConstruction + context globals domainTerm relationTerm replacement + functionality membership applications + _ <- checkedRelationalDerived construction context TySet replacement + _ <- checkedRelationalDerived construction context TyProp functionality + _ <- checkedRelationalDerived + construction (TySet : context) TyProp membership + pure construction + +-- | Check one source separation. The callback supplies the exact visible +-- type of every global used by its already checked components. +checkedSeparationConstruction + :: Ord global + => (global -> Maybe CoreType) + -> ScopedCheckedCore global + -> ScopedCheckedCore global + -> Maybe (NamedSetConstruction global) +checkedSeparationConstruction globalType bound predicate = do + guard (scopedCoreType bound == TySet) + guard (scopedCoreType predicate == TyProp) + let context = scopedCoreContext bound + guard (scopedCoreContext predicate == TySet : context) + globals <- + captureGlobalTypes globalType + [scopedCoreTerm bound, scopedCoreTerm predicate] + finishConstruction + context + globals + (SeparationShape + (scopedCoreTerm bound) + (scopedCoreTerm predicate)) + +-- | Check source-ordered functional replacement once. Domain @i@ is checked +-- beneath exactly the preceding @i - 1@ source binders; the value and optional +-- condition are checked beneath the complete telescope. +checkedFunctionalReplacementConstruction + :: Ord global + => (global -> Maybe CoreType) + -> NonEmpty (ScopedCheckedCore global) + -> ScopedCheckedCore global + -> Maybe (ScopedCheckedCore global) + -> Maybe (NamedSetConstruction global) +checkedFunctionalReplacementConstruction globalType domains value condition = do + let domainList = NonEmpty.toList domains + firstDomain = NonEmpty.head domains + guard (scopedCoreType firstDomain == TySet) + let context = scopedCoreContext firstDomain + expectedDomainContexts = + [ replicate index TySet <> context + | index <- [0 .. length domainList - 1] + ] + valueContext = replicate (length domainList) TySet <> context + guard + (and + (zipWith + (\domain expected -> + scopedCoreType domain == TySet + && scopedCoreContext domain == expected) + domainList + expectedDomainContexts)) + guard + (scopedCoreType value == TySet + && scopedCoreContext value == valueContext) + traverse_ + (\predicate -> + guard + (scopedCoreType predicate == TyProp + && scopedCoreContext predicate == valueContext)) + condition + globals <- + captureGlobalTypes globalType + ( (scopedCoreTerm <$> domainList) + <> [scopedCoreTerm value] + <> maybeToList (scopedCoreTerm <$> condition) + ) + finishConstruction + context + globals + (FunctionalReplacementShape + (scopedCoreTerm <$> domains) + (scopedCoreTerm value) + (scopedCoreTerm <$> condition)) + +namedSetConstructionTerm + :: Ord global + => NamedSetConstruction global + -> ScopedCheckedCore global +namedSetConstructionTerm construction = + fromMaybe + (impossible "a checked construction lost its canonical term") + (checkedDerived + construction + (constructionContext construction) + TySet + (constructionCanonicalTerm construction)) + +-- | Introduce a fresh named set and return adjacent FOF extensional and exact +-- equation locals. Weakening is internal so construction-local binders and +-- source-domain order cannot drift at a caller. +namedSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +namedSetConstructionLocalViews foundation construction = do + weakened <- weakenConstruction TySet construction + let context = TySet : constructionContext construction + target = CBound 0 + extensional <- extensionalView foundation target weakened + equation <- checkedDerived weakened context TyProp + (CEq TySet target (constructionCanonicalTerm weakened)) + pure (extensional, equation) + +-- | Closed transparent content derived from the sole canonical construction +-- term. This retains the pre-existing object-content identity exactly. +namedSetConstructionClosedBody + :: Ord global + => NamedSetConstruction global + -> FrozenCheckedCore global +namedSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked construction did not close") + (freezeDerived construction closedType closedTerm) + where + context = constructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl (flip CLam) (constructionCanonicalTerm construction) context + +data NamedSetConstructionFact = NamedSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +namedSetConstructionFactProposition + :: NamedSetConstructionFact + -> FrozenCheckedCore ObjectId +namedSetConstructionFactProposition + (NamedSetConstructionFact proposition _descriptor) = + proposition + +namedSetConstructionFactDescriptor + :: NamedSetConstructionFact + -> CacheDigest +namedSetConstructionFactDescriptor + (NamedSetConstructionFact _proposition descriptor) = + descriptor + +-- | Derive the only proposition authorized by +-- @CheckedSetConstructionExtensionality@. This is a deliberately small +-- trusted theorem schema over the fixed foundation: every primitive +-- characteristic specialization is checked against its exact membership +-- formula before the source telescope is composed. The caller cannot supply +-- either the resulting proposition or its cache descriptor. +namedSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> NamedSetConstruction ObjectId + -> Maybe NamedSetConstructionFact +namedSetConstructionObjectFact foundation object construction = do + let context = constructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType object objectType (constructionGlobals construction) + let withObject = replaceConstructionGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + view <- extensionalView foundation target withObject + proposition <- freezeDerived withObject TyProp + (foldl + (flip CForall) + (scopedCoreTerm view) + context) + selfView <- extensionalView + foundation + (constructionCanonicalTerm construction) + construction + closedSelf <- freezeDerived construction TyProp + (foldl + (flip CForall) + (scopedCoreTerm selfView) + context) + let closedBody = namedSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (NamedSetConstructionFact proposition descriptor) + +relationalSetConstructionTerm + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionTerm construction = + fromMaybe + (impossible "a checked relational construction lost its canonical term") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TySet + (relationalConstructionCanonicalTerm construction)) + +-- | The exact source functionality obligation, still scoped by the outer +-- definition parameters. It is discharged independently before the derived +-- extensional theorem can be authorized. +relationalSetConstructionFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> ScopedCheckedCore global +relationalSetConstructionFunctionality construction = + fromMaybe + (impossible "a checked relational construction lost functionality") + (checkedRelationalDerived + construction + (relationalConstructionContext construction) + TyProp + (relationalConstructionFunctionalityTerm construction)) + +relationalSetConstructionClosedFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedFunctionality = + closeRelationalFunctionality + +-- | Introduce a fresh named set. Assuming the exact checked functionality +-- proposition, derive its two local views; no arbitrary proposition can +-- unlock the extensional view. The enclosing proof transaction owns the +-- corresponding authority. +relationalSetConstructionLocalViews + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> ScopedCheckedCore global + -> Maybe + ( ScopedCheckedCore global + , ScopedCheckedCore global + ) +relationalSetConstructionLocalViews foundation construction functionality = do + guard + (functionality + == relationalSetConstructionFunctionality construction) + validateRelationalSchema foundation construction + let context = TySet : relationalConstructionContext construction + target = CBound 0 + extensional <- checkedRelationalDerived construction context TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (CBound 1)) + (shiftCanonical 1 1 + (relationalConstructionMembershipTerm construction)))) + equation <- checkedRelationalDerived construction context TyProp + (CEq TySet + target + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + pure (extensional, equation) + +relationalSetConstructionClosedBody + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +relationalSetConstructionClosedBody construction = + fromMaybe + (impossible "a checked relational construction did not close") + (freezeRelationalDerived construction closedType closedTerm) + where + context = relationalConstructionContext construction + closedType = foldr TyArrow TySet (reverse context) + closedTerm = + foldl + (flip CLam) + (relationalConstructionCanonicalTerm construction) + context + +data RelationalSetConstructionFact = RelationalSetConstructionFact + !(FrozenCheckedCore ObjectId) + !CacheDigest + +relationalSetConstructionFactProposition + :: RelationalSetConstructionFact + -> FrozenCheckedCore ObjectId +relationalSetConstructionFactProposition + (RelationalSetConstructionFact proposition _descriptor) = + proposition + +relationalSetConstructionFactDescriptor + :: RelationalSetConstructionFact + -> CacheDigest +relationalSetConstructionFactDescriptor + (RelationalSetConstructionFact _proposition descriptor) = + descriptor + +-- | The direct relational schema is a deterministic theorem over the fixed +-- separation, choice-witness, and replacement rows. The functionality fact +-- is a real strictly-earlier candidate: its exact proposition is checked here +-- and its authority safety is consumed separately by declaration admission. +relationalSetConstructionObjectFact + :: SetConstructionFoundation + -> ObjectId + -> CheckedRelationalSetConstruction ObjectId + -> FrozenCheckedCore ObjectId + -> Maybe RelationalSetConstructionFact +relationalSetConstructionObjectFact + foundation object construction functionality = do + let expectedFunctionality = + closeRelationalFunctionality construction + guard (functionality == expectedFunctionality) + validateRelationalSchema foundation construction + let context = relationalConstructionContext construction + objectType = foldr TyArrow TySet (reverse context) + globals <- insertGlobalType + object objectType (relationalConstructionGlobals construction) + let withObject = replaceRelationalGlobals globals construction + target = + foldl + CApp + (CGlobal object) + [ CBound (fromIntegral index) + | index <- reverse [0 .. length context - 1] + ] + membership = relationalConstructionMembershipTerm withObject + proposition <- freezeRelationalDerived withObject TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + membership)) + context) + closedSelf <- freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (CForall TySet + (CEq TyProp + (member + (CBound 0) + (shiftCanonical 1 0 + (relationalConstructionCanonicalTerm construction))) + (relationalConstructionMembershipTerm construction))) + context) + let closedBody = relationalSetConstructionClosedBody construction + descriptor = + hashCacheFields + "felix-checked-named-relational-set-construction-v1" + [ encodeCache do + putCoreTypeCache (frozenCoreType closedBody) + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedBody) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm expectedFunctionality) + , encodeCache do + putCanonicalTermCache putObjectIdCache + (frozenCoreTerm closedSelf) + ] + pure (RelationalSetConstructionFact proposition descriptor) + +finishConstruction + :: Ord global + => [CoreType] + -> Map.Map global CoreType + -> NamedSetConstructionShape global + -> Maybe (NamedSetConstruction global) +finishConstruction context globals shape = do + let built = buildConstruction context shape + construction = NamedSetConstruction context globals shape built + _ <- checkedDerived construction context TySet + (builtConstructionTerm built) + _ <- checkedDerived construction (TySet : context) TyProp + (builtConstructionMembership built) + pure construction + +buildConstruction + :: Eq global + => [CoreType] + -> NamedSetConstructionShape global + -> BuiltSetConstruction global +buildConstruction context = \case + SeparationShape bound predicate -> + let function = CLam TySet predicate + term = applyIntrinsic2 Sep bound function + membership = + logicalAnd + (member (CBound 0) (shiftCanonical 1 0 bound)) + predicate + application = + characteristicApplication + Sep context term + [ (TySet, bound) + , (TyArrow TySet TyProp, function) + ] + in BuiltSetConstruction term membership [application] + FunctionalReplacementShape domains value condition -> + let (term, applications) = + buildFunctionalReplacement + context + domains + value + condition + domainList = NonEmpty.toList domains + binderCount = length domainList + terminal = + logicalConjunction + ( maybeToList + (shiftCanonical 1 (fromIntegral binderCount) + <$> condition) + <> [ CEq TySet + (CBound (fromIntegral binderCount)) + (shiftCanonical 1 + (fromIntegral binderCount) + value) + ] + ) + membership = + foldr + (\(depth, domain) rest -> + logicalExists + (logicalAnd + (member + (CBound 0) + (shiftCanonical 1 0 + (shiftCanonical 1 depth domain))) + rest)) + terminal + (zip [0 :: Natural ..] domainList) + in BuiltSetConstruction term membership applications + +-- The only functional-replacement term builder. Its result is reused by the +-- transparent body, exact-content matching, characteristic validation, local +-- views, and descriptor derivation. +buildFunctionalReplacement + :: [CoreType] + -> NonEmpty (CanonicalTerm global) + -> CanonicalTerm global + -> Maybe (CanonicalTerm global) + -> (CanonicalTerm global, [CheckedCharacteristicApplication global]) +buildFunctionalReplacement context (domain :| remaining) value condition = + case remaining of + [] -> + let predicate = CLam TySet <$> condition + filtered = maybe domain + (applyIntrinsic2 Sep domain) + predicate + function = CLam TySet value + replacement = applyIntrinsic2 Repl filtered function + separationApplications = case predicate of + Nothing -> [] + Just checkedPredicate -> + [ characteristicApplication + Sep context filtered + [ (TySet, domain) + , (TyArrow TySet TyProp, checkedPredicate) + ] + ] + replacementApplication = + characteristicApplication + Repl context replacement + [ (TySet, filtered) + , (TyArrow TySet TySet, function) + ] + in + ( replacement + , separationApplications <> [replacementApplication] + ) + next : rest -> + let (nested, nestedApplications) = + buildFunctionalReplacement + (TySet : context) + (next :| rest) + value + condition + function = CLam TySet nested + replacement = applyIntrinsic2 Repl domain function + union = applyIntrinsic FamilyUnion replacement + in + ( union + , characteristicApplication + Repl context replacement + [ (TySet, domain) + , (TyArrow TySet TySet, function) + ] + : characteristicApplication + FamilyUnion context union + [(TySet, replacement)] + : nestedApplications + ) + +characteristicApplication + :: CoreIntrinsicTag + -> [CoreType] + -> CanonicalTerm global + -> [(CoreType, CanonicalTerm global)] + -> CheckedCharacteristicApplication global +characteristicApplication intrinsic context target arguments = + CheckedCharacteristicApplication + intrinsic + context + target + (NonEmpty.fromList arguments) + (expectedCharacteristicBody intrinsic arguments) + +expectedCharacteristicBody + :: CoreIntrinsicTag + -> [(CoreType, CanonicalTerm global)] + -> CanonicalTerm global +expectedCharacteristicBody intrinsic arguments = + case (intrinsic, arguments) of + (Sep, [(_boundType, bound), (_predicateType, CLam TySet predicate)]) -> + logicalAnd + (member (CBound 0) (shiftCanonical 2 0 bound)) + (shiftCanonical 1 1 predicate) + (Repl, [(_domainType, domain), (_functionType, CLam TySet value)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 domain)) + (CEq TySet + (CBound 1) + (shiftCanonical 2 1 value))) + (FamilyUnion, [(_familyType, family)]) -> + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 3 0 family)) + (member (CBound 1) (CBound 0))) + _ -> + impossible "invalid checked set-construction characteristic" + +extensionalView + :: Ord global + => SetConstructionFoundation + -> CanonicalTerm global + -> NamedSetConstruction global + -> Maybe (ScopedCheckedCore global) +extensionalView foundation target construction = do + traverse_ + (validateCharacteristic foundation construction) + (constructionApplications construction) + checkedDerived construction (constructionContext construction) TyProp + (CForall TySet + (CEq TyProp + (member (CBound 0) (shiftCanonical 1 0 target)) + (constructionMembership construction))) + +-- Each primitive step is specialized from the actual fixed row, and the +-- complete normalized membership body is checked. The final flattened view +-- is then the deterministic composition of these exact primitive schemas. +validateCharacteristic + :: Ord global + => SetConstructionFoundation + -> NamedSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet + (CEq TyProp actualMembership actualBody) + | actualMembership + == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +characteristicRow + :: SetConstructionFoundation + -> CoreIntrinsicTag + -> Maybe (FrozenCheckedCore Void) +characteristicRow + (SetConstructionFoundation + familyUnion separation replacement _setChoose) = + \case + FamilyUnion -> Just familyUnion + Sep -> Just separation + Repl -> Just replacement + _ -> Nothing + +validateRelationalSchema + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateRelationalSchema foundation construction = do + traverse_ + (validateRelationalCharacteristic foundation construction) + (relationalConstructionApplications construction) + validateChoiceWitness foundation construction + +validateRelationalCharacteristic + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> CheckedCharacteristicApplication global + -> Maybe () +validateRelationalCharacteristic foundation construction + (CheckedCharacteristicApplication + intrinsic context targetTerm argumentTerms expectedBody) = do + row <- characteristicRow foundation intrinsic + target <- checkedRelationalDerived construction context TySet targetTerm + arguments <- traverse + (\(coreType, term) -> + checkedRelationalDerived construction context coreType term) + argumentTerms + specialized <- scopedCharacteristicDefinition row target arguments + case scopedCoreTerm specialized of + CForall TySet (CEq TyProp actualMembership actualBody) + | actualMembership == member (CBound 0) (CBound 1) + , scopedCoreContext specialized + == TySet : scopedCoreContext target + , actualBody == expectedBody -> + pure () + _ -> Nothing + +validateChoiceWitness + :: Ord global + => SetConstructionFoundation + -> CheckedRelationalSetConstruction global + -> Maybe () +validateChoiceWitness + (SetConstructionFoundation + _familyUnion _separation _replacement setChoose) + construction = do + let context = relationalConstructionContext construction + relation = relationalConstructionRelation construction + predicate = CLam TySet relation + choice = applyIntrinsic SetChoose predicate + witnessContext = TySet : TySet : context + target <- checkedRelationalDerived construction witnessContext TySet + (shiftCanonical 1 0 choice) + checkedPredicate <- + checkedRelationalDerived construction witnessContext + (TyArrow TySet TyProp) + (shiftCanonical 1 0 predicate) + witness <- checkedRelationalDerived construction witnessContext TySet + (CBound 0) + specialized <- + scopedCharacteristicDefinition + setChoose target (checkedPredicate :| [witness]) + guard + (scopedCoreContext specialized + == TySet : TySet : TySet : context) + guard + (scopedCoreTerm specialized + == CImp + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + +relationalFunctionality + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalFunctionality domain relation = + CForall TySet + (CImp + (member (CBound 0) (shiftCanonical 1 0 domain)) + (CForall TySet + (CForall TySet + (CImp + (logicalAnd + (shiftCanonical 1 0 relation) + (shiftCanonical 1 1 relation)) + (CEq TySet (CBound 1) (CBound 0)))))) + +relationalMembership + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +relationalMembership domain relation = + logicalExists + (logicalAnd + (member (CBound 0) (shiftCanonical 2 0 domain)) + (applyRelation + (shiftCanonical 2 0 + (CLam TySet (CLam TySet relation))) + (CBound 0) + (CBound 1))) + where + applyRelation function domainValue rangeValue = + case function of + CLam TySet domainBody -> + case instantiateCanonical domainValue domainBody of + CLam TySet rangeBody -> + instantiateCanonical rangeValue rangeBody + _ -> impossible "a checked relation lost its range binder" + _ -> impossible "a checked relation lost its domain binder" + +weakenConstruction + :: Ord global + => CoreType + -> NamedSetConstruction global + -> Maybe (NamedSetConstruction global) +weakenConstruction binderType construction = + finishConstruction + (binderType : constructionContext construction) + (constructionGlobals construction) + (case constructionShape construction of + SeparationShape bound predicate -> + SeparationShape + (shiftCanonical 1 0 bound) + (shiftCanonical 1 1 predicate) + FunctionalReplacementShape domains value condition -> + let domainList = NonEmpty.toList domains + weakenedDomains = + zipWith + (\depth domain -> shiftCanonical 1 depth domain) + [0..] + domainList + binderDepth = fromIntegral (length domainList) + in FunctionalReplacementShape + (NonEmpty.fromList weakenedDomains) + (shiftCanonical 1 binderDepth value) + (shiftCanonical 1 binderDepth <$> condition)) + +captureGlobalTypes + :: Ord global + => (global -> Maybe CoreType) + -> [CanonicalTerm global] + -> Maybe (Map.Map global CoreType) +captureGlobalTypes globalType terms = + Map.fromList <$> traverse capture + (Set.toAscList (foldMap canonicalTermGlobals terms)) + where + capture global = do + coreType <- globalType global + pure (global, coreType) + +insertGlobalType + :: Ord global + => global + -> CoreType + -> Map.Map global CoreType + -> Maybe (Map.Map global CoreType) +insertGlobalType global coreType globals = + case Map.lookup global globals of + Nothing -> Just (Map.insert global coreType globals) + Just existing + | existing == coreType -> Just globals + | otherwise -> Nothing + +checkedDerived + :: Ord global + => NamedSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` constructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeDerived + :: Ord global + => NamedSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeDerived construction expected term = do + checked <- checkedDerived construction [] expected term + closeScopedCore checked + +checkedRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> [CoreType] + -> CoreType + -> CanonicalTerm global + -> Maybe (ScopedCheckedCore global) +checkedRelationalDerived construction context expected term = do + checked <- either (const Nothing) Just + (checkScopedCanonicalCore + (`Map.lookup` relationalConstructionGlobals construction) + context + term) + guard (scopedCoreType checked == expected) + pure checked + +freezeRelationalDerived + :: Ord global + => CheckedRelationalSetConstruction global + -> CoreType + -> CanonicalTerm global + -> Maybe (FrozenCheckedCore global) +freezeRelationalDerived construction expected term = do + checked <- checkedRelationalDerived construction [] expected term + closeScopedCore checked + +closeRelationalFunctionality + :: Ord global + => CheckedRelationalSetConstruction global + -> FrozenCheckedCore global +closeRelationalFunctionality construction = + fromMaybe + (impossible "a relational functionality proposition did not close") + (freezeRelationalDerived construction TyProp + (foldl + (flip CForall) + (relationalConstructionFunctionalityTerm construction) + (relationalConstructionContext construction))) + +replaceRelationalGlobals + :: Map.Map global CoreType + -> CheckedRelationalSetConstruction global + -> CheckedRelationalSetConstruction global +replaceRelationalGlobals globals + (CheckedRelationalSetConstruction + context _oldGlobals domain relation term functionality + membership applications) = + CheckedRelationalSetConstruction + context globals domain relation term functionality membership applications + +relationalConstructionContext + :: CheckedRelationalSetConstruction global + -> [CoreType] +relationalConstructionContext + (CheckedRelationalSetConstruction + context _globals _domain _relation _term _functionality + _membership _applications) = + context + +relationalConstructionGlobals + :: CheckedRelationalSetConstruction global + -> Map.Map global CoreType +relationalConstructionGlobals + (CheckedRelationalSetConstruction + _context globals _domain _relation _term _functionality + _membership _applications) = + globals + +relationalConstructionRelation + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionRelation + (CheckedRelationalSetConstruction + _context _globals _domain relation _term _functionality + _membership _applications) = + relation + +relationalConstructionCanonicalTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionCanonicalTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation term _functionality + _membership _applications) = + term + +relationalConstructionFunctionalityTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionFunctionalityTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term functionality + _membership _applications) = + functionality + +relationalConstructionMembershipTerm + :: CheckedRelationalSetConstruction global + -> CanonicalTerm global +relationalConstructionMembershipTerm + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + membership _applications) = + membership + +relationalConstructionApplications + :: CheckedRelationalSetConstruction global + -> [CheckedCharacteristicApplication global] +relationalConstructionApplications + (CheckedRelationalSetConstruction + _context _globals _domain _relation _term _functionality + _membership applications) = + applications + +replaceConstructionGlobals + :: Map.Map global CoreType + -> NamedSetConstruction global + -> NamedSetConstruction global +replaceConstructionGlobals globals + (NamedSetConstruction context _oldGlobals shape built) = + NamedSetConstruction context globals shape built + +constructionContext :: NamedSetConstruction global -> [CoreType] +constructionContext (NamedSetConstruction context _globals _shape _built) = + context + +constructionGlobals + :: NamedSetConstruction global + -> Map.Map global CoreType +constructionGlobals (NamedSetConstruction _context globals _shape _built) = + globals + +constructionShape + :: NamedSetConstruction global + -> NamedSetConstructionShape global +constructionShape (NamedSetConstruction _context _globals shape _built) = + shape + +constructionCanonicalTerm + :: NamedSetConstruction global + -> CanonicalTerm global +constructionCanonicalTerm + (NamedSetConstruction _context _globals _shape built) = + builtConstructionTerm built + +constructionMembership + :: NamedSetConstruction global + -> CanonicalTerm global +constructionMembership + (NamedSetConstruction _context _globals _shape built) = + builtConstructionMembership built + +constructionApplications + :: NamedSetConstruction global + -> [CheckedCharacteristicApplication global] +constructionApplications + (NamedSetConstruction _context _globals _shape built) = + builtConstructionApplications built + +builtConstructionTerm + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionTerm (BuiltSetConstruction term _membership _applications) = + term + +builtConstructionMembership + :: BuiltSetConstruction global + -> CanonicalTerm global +builtConstructionMembership + (BuiltSetConstruction _term membership _applications) = + membership + +builtConstructionApplications + :: BuiltSetConstruction global + -> [CheckedCharacteristicApplication global] +builtConstructionApplications + (BuiltSetConstruction _term _membership applications) = + applications + +applyIntrinsic + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic intrinsic argument = + CApp (CIntrinsic intrinsic) argument + +applyIntrinsic2 + :: CoreIntrinsicTag + -> CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +applyIntrinsic2 intrinsic first second = + CApp (CApp (CIntrinsic intrinsic) first) second + +member + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +member = applyIntrinsic2 Member + +logicalNot :: CanonicalTerm global -> CanonicalTerm global +logicalNot proposition = CImp proposition CFalsum + +logicalAnd + :: CanonicalTerm global + -> CanonicalTerm global + -> CanonicalTerm global +logicalAnd left right = + logicalNot (CImp left (logicalNot right)) + +logicalTruth :: CanonicalTerm global +logicalTruth = CImp CFalsum CFalsum + +logicalConjunction + :: Eq global + => [CanonicalTerm global] + -> CanonicalTerm global +logicalConjunction = + foldr combine logicalTruth + where + combine proposition remaining + | proposition == logicalTruth = remaining + | remaining == logicalTruth = proposition + | otherwise = logicalAnd proposition remaining + +logicalExists :: CanonicalTerm global -> CanonicalTerm global +logicalExists body = + logicalNot (CForall TySet (logicalNot body)) diff --git a/source/Checking/Typed/Inductive.hs b/source/Felix/Checking/Typed/Inductive.hs index 7a895c6..4094083 100644 --- a/source/Checking/Typed/Inductive.hs +++ b/source/Felix/Checking/Typed/Inductive.hs @@ -4,20 +4,31 @@ -- | Direct checked lowering of the current one-carrier set-valued inductive -- declaration. -module Checking.Typed.Inductive +module Felix.Checking.Typed.Inductive ( DirectInductive(..) , DirectInductiveClause(..) , DirectInductiveCondition(..) + , RecursiveCarrierContext + , RecursiveCarrierContextError(..) + , prepareRecursiveCarrierContext + , directRecursiveCarrierContext + , recursiveCarrierContextSymbols , SourceGlobal(..) , PreparedTypedInductive , typedInductiveCarrierType , typedInductiveCarrierBody , typedInductiveGuardTargets + , PreparedTypedInductiveMonotonicity + , typedInductiveMonotonicities + , typedInductiveMonotonicityLocation + , typedInductiveMonotonicityTarget + , typedInductiveContextInventory , PreparedTypedInductiveFact , typedInductiveFacts , typedInductiveFactMarker , typedInductiveFactTarget , typedInductiveFactRules + , typedInductiveFactRequiresMonotonicities , typedInductiveFactDerivation , prepareTypedClosedTerm , prepareTypedClosedFormula @@ -26,12 +37,13 @@ module Checking.Typed.Inductive ) where import Base hiding (Empty) -import Checking.Core -import Checking.Exact.Vocabulary -import Checking.Foundation -import Checking.Kernel.Derivation -import Checking.Kernel.Proof -import Syntax.Internal +import Felix.Checking.Core +import Felix.Checking.Exact.Vocabulary +import Felix.Checking.Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Proof +import Felix.Report.Location (Location) +import Felix.Syntax.Internal import Control.Monad ((<=<), foldM) import Data.Bifunctor (first) @@ -63,7 +75,73 @@ data DirectInductiveClause = DirectInductiveClause data DirectInductiveCondition = DirectSideCondition !Formula - | DirectRecursiveCondition !Term + | DirectRecursiveCondition !Term !RecursiveCarrierContext + +data RecursiveCarrierVariable + = RecursiveCarrierHole + | RecursiveCarrierSourceVariable !VarSymbol + deriving stock (Show, Eq, Ord) + +-- | A validated, capture-free one-hole carrier context in the same +-- first-order set-term fragment lowered by this module. The source carrier +-- application itself has been replaced, so the inductive symbol cannot +-- survive inside this value. +data RecursiveCarrierContext = RecursiveCarrierContext + !Location + !(ExprOf RecursiveCarrierVariable) + deriving stock (Show, Eq, Ord) + +data RecursiveCarrierContextError + = RecursiveCarrierWrongArguments !Location + | RecursiveCarrierUnsupportedContext !Location + deriving stock (Show, Eq) + +prepareRecursiveCarrierContext + :: FunctionSymbol + -> [VarSymbol] + -> Term + -> Either RecursiveCarrierContextError RecursiveCarrierContext +prepareRecursiveCarrierContext carrier parameters source = + RecursiveCarrierContext (exprLocation source) <$> go source + where + carrierSymbol = SymbolMixfix carrier + + go = \case + TermVar variable -> + pure + (TermVar + (RecursiveCarrierSourceVariable variable)) + TermSymbol location symbol arguments + | symbol == carrierSymbol -> + if sameCarrierArguments arguments parameters + then pure (TermVar RecursiveCarrierHole) + else Left (RecursiveCarrierWrongArguments location) + | otherwise -> + TermSymbol location symbol <$> traverse go arguments + unsupported -> + Left + (RecursiveCarrierUnsupportedContext + (exprLocation unsupported)) + + sameCarrierArguments arguments variables = + length arguments == length variables + && and + (zipWith + (\argument variable -> + argument == TermVar variable) + arguments + variables) + +recursiveCarrierContextSymbols + :: RecursiveCarrierContext + -> Set Symbol +recursiveCarrierContextSymbols + (RecursiveCarrierContext _location source) = + mentionedSymbols source + +directRecursiveCarrierContext :: Location -> RecursiveCarrierContext +directRecursiveCarrierContext location = + RecursiveCarrierContext location (TermVar RecursiveCarrierHole) data SourceGlobal global = SourceGlobal !global @@ -93,8 +171,80 @@ data PreparedTypedInductive global = PreparedTypedInductive !CoreType !(FrozenCheckedCore global) !(Vector (FrozenCheckedCore global)) + !(Vector (PreparedTypedInductiveMonotonicity global)) + !(Vector (FrozenCheckedCore global)) !(NonEmpty (PreparedTypedInductiveFact global)) +data PreparedTypedInductiveMonotonicity global = + PreparedTypedInductiveMonotonicity + !Location + !(FrozenCheckedCore global) + +typedInductiveMonotonicities + :: PreparedTypedInductive global + -> Vector (PreparedTypedInductiveMonotonicity global) +typedInductiveMonotonicities + (PreparedTypedInductive + _carrierType + _body + _guards + monotonicities + _contexts + _facts) = + monotonicities + +typedInductiveMonotonicityLocation + :: PreparedTypedInductiveMonotonicity global + -> Location +typedInductiveMonotonicityLocation + (PreparedTypedInductiveMonotonicity location _target) = + location + +typedInductiveMonotonicityTarget + :: PreparedTypedInductiveMonotonicity global + -> FrozenCheckedCore global +typedInductiveMonotonicityTarget + (PreparedTypedInductiveMonotonicity _location target) = + target + +typedInductiveContextInventory + :: PreparedTypedInductive global + -> Vector (FrozenCheckedCore global) +typedInductiveContextInventory + (PreparedTypedInductive + _carrierType _body _guards _monotonicities contexts _facts) = + contexts + +data CheckedRecursiveCarrierContext global = + CheckedRecursiveCarrierContext + ![VarSymbol] + !(FrozenCheckedCore global) + +data PreparedInductiveSource global = PreparedInductiveSource + { preparedInductiveParams :: ![VarSymbol] + , preparedInductiveDomain :: !Term + , preparedInductiveClauses + :: !(NonEmpty (PreparedInductiveClause global)) + } + +data PreparedInductiveClause global = PreparedInductiveClause + { preparedClauseVariables :: ![VarSymbol] + , preparedClauseConditions + :: ![PreparedInductiveCondition global] + , preparedClauseResult :: !Term + } + +data PreparedInductiveCondition global + = PreparedSideCondition !Formula + | PreparedDirectRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + | PreparedNestedRecursiveCondition + !Term + !(CheckedRecursiveCarrierContext global) + !ImportIx + !(FrozenCheckedCore global) + data PreparedInductiveGuard global = PreparedFoundationGuard !FoundationAxiomTag | PreparedImportedGuard @@ -109,6 +259,8 @@ typedInductiveCarrierType carrierType _body _guards + _monotonicities + _contexts _facts) = carrierType @@ -120,6 +272,8 @@ typedInductiveCarrierBody _carrierType body _guards + _monotonicities + _contexts _facts) = body @@ -131,6 +285,8 @@ typedInductiveGuardTargets _carrierType _body guards + _monotonicities + _contexts _facts) = guards @@ -139,6 +295,7 @@ newtype PreparedTypedInductiveFact global = ( Marker , FrozenCheckedCore global , NonEmpty KernelRuleTag + , Bool , KernelDerivation global ) @@ -150,6 +307,8 @@ typedInductiveFacts _carrierType _body _guards + _monotonicities + _contexts facts) = facts @@ -158,7 +317,7 @@ typedInductiveFactMarker -> Marker typedInductiveFactMarker (PreparedTypedInductiveFact - (marker, _target, _rule, _derivation)) = + (marker, _target, _rule, _monotonicities, _derivation)) = marker typedInductiveFactTarget @@ -166,7 +325,7 @@ typedInductiveFactTarget -> FrozenCheckedCore global typedInductiveFactTarget (PreparedTypedInductiveFact - (_marker, target, _rule, _derivation)) = + (_marker, target, _rule, _monotonicities, _derivation)) = target typedInductiveFactRules @@ -174,15 +333,23 @@ typedInductiveFactRules -> NonEmpty KernelRuleTag typedInductiveFactRules (PreparedTypedInductiveFact - (_marker, _target, rules, _derivation)) = + (_marker, _target, rules, _monotonicities, _derivation)) = rules +typedInductiveFactRequiresMonotonicities + :: PreparedTypedInductiveFact global + -> Bool +typedInductiveFactRequiresMonotonicities + (PreparedTypedInductiveFact + (_marker, _target, _rules, required, _derivation)) = + required + typedInductiveFactDerivation :: PreparedTypedInductiveFact global -> KernelDerivation global typedInductiveFactDerivation (PreparedTypedInductiveFact - (_marker, _target, _rule, derivation)) = + (_marker, _target, _rule, _monotonicities, derivation)) = derivation -- | Lower one closed source formula through the exact primitive/global @@ -326,13 +493,9 @@ prepareTypedInductiveInternal resolveGlobal marker inductive = do - carrierBody <- - prepareCarrierBody - resolveGlobal - inductive guards <- traverse - (prepareGuardTarget + (prepareDirectGuardTarget resolveGlobal inductive) (directInductiveClauses @@ -340,12 +503,27 @@ prepareTypedInductiveInternal let preparedGuards = assignGuardSources foundation (NonEmpty.toList guards) + nextImport = + fromIntegral + (length + [ () + | PreparedImportedGuard{} <- preparedGuards + ]) + (preparedSource, monotonicities, contexts) <- + prepareInductiveSource + resolveGlobal + nextImport + inductive + carrierBody <- + prepareCarrierBody + resolveGlobal + preparedSource facts <- prepareFacts foundation resolveGlobal marker - inductive + preparedSource (case preparedGuards of firstGuard : remainingGuards -> firstGuard :| remainingGuards @@ -361,6 +539,8 @@ prepareTypedInductiveInternal | PreparedImportedGuard _index target <- preparedGuards ]) + (Vector.fromList monotonicities) + (Vector.fromList contexts) facts) where carrierType = @@ -385,34 +565,264 @@ mapPreparedTypedInductive -> PreparedTypedInductive left -> PreparedTypedInductive right mapPreparedTypedInductive transform - (PreparedTypedInductive carrierType body guards facts) = + (PreparedTypedInductive + carrierType body guards monotonicities contexts facts) = PreparedTypedInductive carrierType (mapFrozenGlobals transform body) (mapFrozenGlobals transform <$> guards) + (mapMonotonicity transform <$> monotonicities) + (mapFrozenGlobals transform <$> contexts) (mapPreparedFact transform <$> facts) where + mapMonotonicity mapGlobal + (PreparedTypedInductiveMonotonicity location target) = + PreparedTypedInductiveMonotonicity + location + (mapFrozenGlobals mapGlobal target) + mapPreparedFact mapGlobal (PreparedTypedInductiveFact - (marker, target, rule, derivation)) = + (marker, target, rule, requiresMonotonicities, derivation)) = PreparedTypedInductiveFact ( marker , mapFrozenGlobals mapGlobal target , rule + , requiresMonotonicities , mapKernelDerivationGlobals mapGlobal derivation ) -prepareCarrierBody +data MonotonicityInventory global = MonotonicityInventory + ![(FrozenCheckedCore global, ImportIx)] + !Natural + ![PreparedTypedInductiveMonotonicity global] + ![FrozenCheckedCore global] + +prepareInductiveSource :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Natural -> DirectInductive -> Either TypedInductiveError + ( PreparedInductiveSource (InductiveGlobal global) + , [PreparedTypedInductiveMonotonicity (InductiveGlobal global)] + , [FrozenCheckedCore (InductiveGlobal global)] + ) +prepareInductiveSource resolveGlobal firstImport inductive = do + (final, clauses) <- + prepareClauses + (MonotonicityInventory [] firstImport [] []) + (NonEmpty.toList (directInductiveClauses inductive)) + let MonotonicityInventory + _targets _next monotonicities contexts = final + pure + ( PreparedInductiveSource + (directInductiveParams inductive) + (directInductiveDomain inductive) + (NonEmpty.fromList clauses) + , reverse monotonicities + , reverse contexts + ) + where + variablesFor clause = + directInductiveParams inductive + <> directClauseVariables clause + + prepareClauses inventory = \case + [] -> pure (inventory, []) + clause : remaining -> do + (afterClause, preparedClause) <- + prepareClause inventory clause + (final, preparedRemaining) <- + prepareClauses afterClause remaining + pure (final, preparedClause : preparedRemaining) + + prepareClause inventory clause = do + (next, conditions) <- + prepareConditions inventory clause + (directClauseConditions clause) + pure + ( next + , PreparedInductiveClause + (directClauseVariables clause) + conditions + (directClauseResult clause) + ) + + prepareConditions inventory _clause [] = + pure (inventory, []) + prepareConditions inventory clause (condition : remaining) = do + (next, prepared) <- + prepareCondition inventory clause condition + (final, preparedRemaining) <- + prepareConditions next clause remaining + pure (final, prepared : preparedRemaining) + + prepareCondition inventory _clause (DirectSideCondition formula) = + pure (inventory, PreparedSideCondition formula) + prepareCondition + (MonotonicityInventory targets next facts contexts) + clause + (DirectRecursiveCondition recursiveTerm sourceContext) = do + checkedContext <- + prepareRecursiveCarrierTemplate + resolveGlobal + (variablesFor clause) + sourceContext + let template = checkedRecursiveCarrierTemplate checkedContext + withContext currentFacts = + MonotonicityInventory + targets next currentFacts (template : contexts) + if recursiveCarrierContextIsDirect sourceContext + then pure + ( withContext facts + , PreparedDirectRecursiveCondition + recursiveTerm checkedContext + ) + else do + target <- + prepareRecursiveCarrierMonotonicityTarget + checkedContext + let RecursiveCarrierContext location _source = sourceContext + case List.lookup target targets of + Just index -> + pure + ( MonotonicityInventory + targets next facts (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + Nothing -> + let index = importIx next + in pure + ( MonotonicityInventory + ((target, index) : targets) + (next + 1) + (PreparedTypedInductiveMonotonicity + location target : facts) + (template : contexts) + , PreparedNestedRecursiveCondition + recursiveTerm checkedContext index target + ) + +checkedRecursiveCarrierTemplate + :: CheckedRecursiveCarrierContext global + -> FrozenCheckedCore global +checkedRecursiveCarrierTemplate + (CheckedRecursiveCarrierContext _variables template) = + template + +recursiveCarrierContextIsDirect :: RecursiveCarrierContext -> Bool +recursiveCarrierContextIsDirect + (RecursiveCarrierContext _location source) = + source == TermVar RecursiveCarrierHole + +prepareRecursiveCarrierTemplate + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> [VarSymbol] + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CheckedRecursiveCarrierContext (InductiveGlobal global)) +prepareRecursiveCarrierTemplate resolveGlobal variables context = do + body <- + buildUnderVariables emptyEnvironment variables \environment -> do + underHole <- shiftEnvironment environment + lowerRecursiveCarrierContext + resolveGlobal underHole (CBound 0) context + checked <- + first TypedInductiveCoreError + (checkCanonicalCore + (Just . inductiveGlobalType) + -- Transparent expansion may leave beta redexes. Freeze one + -- normalized template so routing, generated laws, and kernel + -- transport all see the same first-order shape. + (betaNormalizeCanonical + (closeLambdas (length variables + 1) body))) + pure (CheckedRecursiveCarrierContext variables checked) + +prepareRecursiveCarrierMonotonicityTarget + :: CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (FrozenCheckedCore (InductiveGlobal global)) +prepareRecursiveCarrierMonotonicityTarget + context@(CheckedRecursiveCarrierContext variables _template) = do + target <- + buildUnderVariables emptyEnvironment variables \environment -> do + underSets <- shiftEnvironment =<< shiftEnvironment environment + left <- + instantiateRecursiveCarrier + underSets (CBound 1) context + right <- + instantiateRecursiveCarrier + underSets (CBound 0) context + pure + (CImp + (subsetTerm (CBound 1) (CBound 0)) + (subsetTerm left right)) + freezeClosedTarget + (closeForalls (length variables + 2) target) + +instantiateRecursiveCarrier + :: InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> CheckedRecursiveCarrierContext (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +instantiateRecursiveCarrier environment replacement + context@(CheckedRecursiveCarrierContext variables _template) = do + arguments <- traverse (`lookupEnvironment` environment) variables + foldM instantiateLambda + (frozenCoreTerm (checkedRecursiveCarrierTemplate context)) + (arguments <> [replacement]) + where + instantiateLambda term argument = + case term of + CLam TySet body -> + pure (instantiateCanonical argument body) + _ -> + Left + (TypedInductiveUnsupportedExpression + "a checked recursive carrier context lost its set telescope") + +lowerRecursiveCarrierContext + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> RecursiveCarrierContext + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerRecursiveCarrierContext resolveGlobal environment replacement + (RecursiveCarrierContext _location source) = + go source + where + go = \case + TermVar RecursiveCarrierHole -> + pure replacement + TermVar (RecursiveCarrierSourceVariable variable) -> + lookupEnvironment variable environment + TermSymbol _location symbol arguments -> do + lowered <- traverse go arguments + lowerApplicationTerms resolveGlobal symbol lowered + _ -> + Left + (TypedInductiveUnsupportedExpression + "a validated recursive carrier context left the supported set-term fragment") + +prepareCarrierBody + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> PreparedInductiveSource (InductiveGlobal global) + -> Either + TypedInductiveError (FrozenCheckedCore (InductiveGlobal global)) prepareCarrierBody resolveGlobal inductive = do body <- buildUnderVariables emptyEnvironment - (directInductiveParams + (preparedInductiveParams inductive) (\env -> fixedPointTerm resolveGlobal @@ -420,8 +830,8 @@ prepareCarrierBody resolveGlobal inductive = do env) let closed = closeLambdas - (length - (directInductiveParams + (length + (preparedInductiveParams inductive)) body checked <- @@ -431,14 +841,14 @@ prepareCarrierBody resolveGlobal inductive = do closed) pure checked -prepareGuardTarget +prepareDirectGuardTarget :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> DirectInductive -> DirectInductiveClause -> Either TypedInductiveError (FrozenCheckedCore (InductiveGlobal global)) -prepareGuardTarget +prepareDirectGuardTarget resolveGlobal inductive clause = do @@ -456,7 +866,7 @@ prepareGuardTarget inductive) conditions <- traverse - (conditionTerm + (directConditionTerm resolveGlobal environment domain) @@ -515,7 +925,7 @@ prepareFacts :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> Marker - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> NonEmpty (PreparedInductiveGuard (InductiveGlobal global)) -> Either TypedInductiveError @@ -545,7 +955,7 @@ prepareFacts (0 :| [1 ..]) (NonEmpty.zip guards - (directInductiveClauses + (preparedInductiveClauses inductive))) domainSubset <- first @@ -583,9 +993,9 @@ prepareIntroductionFact :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> Marker - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> Natural - -> (PreparedInductiveGuard (InductiveGlobal global), DirectInductiveClause) + -> (PreparedInductiveGuard (InductiveGlobal global), PreparedInductiveClause (InductiveGlobal global)) -> Either TypedInductiveError (PreparedTypedInductiveFact (InductiveGlobal global)) @@ -602,15 +1012,15 @@ prepareIntroductionFact foundation (Just . inductiveGlobalType)) emptyEnvironment - (directInductiveParams inductive - <> directClauseVariables clause) + (preparedInductiveParams inductive + <> preparedClauseVariables clause) (\context environment -> do domain <- checkedTerm context =<< lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- checkedTerm context @@ -646,14 +1056,14 @@ prepareIntroductionFact environment (scopedCoreTerm fixedPoint)) - (directClauseConditions + (preparedClauseConditions clause) result <- checkedTerm context =<< lowerTerm resolveGlobal environment - (directClauseResult + (preparedClauseResult clause) let conditionTerms = scopedCoreTerm <$> conditions @@ -675,18 +1085,18 @@ prepareIntroductionFact (eliminateWrittenForalls context environment - (directInductiveParams + (preparedInductiveParams inductive - <> directClauseVariables + <> preparedClauseVariables clause) guardProof) guardPremiseProofs <- sequence [ case condition of - DirectSideCondition _formula -> + PreparedSideCondition _formula -> pure premiseProof - DirectRecursiveCondition - recursiveTerm -> do + PreparedDirectRecursiveCondition + recursiveTerm _context -> do bound <- first TypedInductiveProofError @@ -713,9 +1123,32 @@ prepareIntroductionFact context implication premiseProof) + nested@PreparedNestedRecursiveCondition{} -> do + bound <- + first TypedInductiveProofError + (setLfpBoundProof + context + domain + operator) + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm + nested) + transportNestedRecursiveMembership + context + environment + nested + fixedPoint + domain + recursiveElement + bound + premiseProof | (condition, premiseProof) <- zip - (directClauseConditions + (preparedClauseConditions clause) premiseProofs ] @@ -841,14 +1274,16 @@ prepareIntroductionFact marker (clauseIndex + 1)) (if any isRecursiveCondition - (directClauseConditions clause) + (preparedClauseConditions clause) then SetLfpBound :| [SetLfpFixed] else SetLfpFixed :| []) + True proof where isRecursiveCondition = \case - DirectRecursiveCondition{} -> True - DirectSideCondition{} -> False + PreparedDirectRecursiveCondition{} -> True + PreparedNestedRecursiveCondition{} -> True + PreparedSideCondition{} -> False preparedGuardProof :: ProofContext (InductiveGlobal global) @@ -868,7 +1303,7 @@ prepareDomainSubsetFact :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> Marker - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> Either TypedInductiveError (PreparedTypedInductiveFact (InductiveGlobal global)) @@ -883,7 +1318,7 @@ prepareDomainSubsetFact foundation (Just . inductiveGlobalType)) emptyEnvironment - (directInductiveParams + (preparedInductiveParams inductive) (\context environment -> do domain <- @@ -891,7 +1326,7 @@ prepareDomainSubsetFact =<< lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- checkedTerm context @@ -907,13 +1342,14 @@ prepareDomainSubsetFact preparedFact (derivedMarker marker "dom_subset") (SetLfpBound :| []) + False proof prepareCasesFact :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> Marker - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> Either TypedInductiveError (PreparedTypedInductiveFact (InductiveGlobal global)) @@ -928,7 +1364,7 @@ prepareCasesFact foundation (Just . inductiveGlobalType)) emptyEnvironment - (directInductiveParams + (preparedInductiveParams inductive) (\parameterContext parameterEnvironment -> forallIntroductionTyped @@ -943,7 +1379,7 @@ prepareCasesFact =<< lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- checkedTerm context @@ -1058,13 +1494,14 @@ prepareCasesFact preparedFact (derivedMarker marker "cases") (SetLfpFixed :| []) + True proof prepareInductionFact :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> Marker - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> Either TypedInductiveError (PreparedTypedInductiveFact (InductiveGlobal global)) @@ -1079,7 +1516,7 @@ prepareInductionFact foundation (Just . inductiveGlobalType)) emptyEnvironment - (directInductiveParams + (preparedInductiveParams inductive) (\parameterContext parameterEnvironment -> forallIntroductionTyped @@ -1123,7 +1560,7 @@ prepareInductionFact =<< lowerTerm resolveGlobal elementEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- checkedTerm elementContext @@ -1201,6 +1638,7 @@ prepareInductionFact preparedFact (derivedMarker marker "induct") (SetLfpInduct :| []) + True proof proveUnderVariables @@ -1248,11 +1686,12 @@ checkedTerm context = preparedFact :: Marker -> NonEmpty KernelRuleTag + -> Bool -> BuiltProof (InductiveGlobal global) -> Either TypedInductiveError (PreparedTypedInductiveFact (InductiveGlobal global)) -preparedFact marker rules proof = do +preparedFact marker rules requiresMonotonicities proof = do target <- maybe (Left TypedInductiveProofRemainedOpen) @@ -1264,6 +1703,7 @@ preparedFact marker rules proof = do ( marker , target , canonicalRules rules + , requiresMonotonicities , builtProofDerivation proof )) where @@ -1407,8 +1847,8 @@ projectConjunctionList context terms proof = do introduceClauseWitnesses :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive - -> DirectInductiveClause + -> PreparedInductiveSource (InductiveGlobal global) + -> PreparedInductiveClause (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -1427,7 +1867,7 @@ introduceClauseWitnesses result bodyProof = introduce - (directClauseVariables clause) + (preparedClauseVariables clause) where introduce [] = pure bodyProof @@ -1477,7 +1917,7 @@ introduceClauseWitnesses clauseFormulaWithBinders :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> CanonicalTerm (InductiveGlobal global) @@ -1498,13 +1938,13 @@ clauseFormulaWithBinders resolveGlobal environment candidate) - (directClauseConditions + (preparedClauseConditions clause) clauseResult <- lowerTerm resolveGlobal environment - (directClauseResult clause) + (preparedClauseResult clause) pure (fromMaybe (CEq TySet result clauseResult) @@ -1608,7 +2048,7 @@ injectDisjunction context index alternatives proof = closureTerms :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> Either @@ -1621,18 +2061,18 @@ closureTerms subset = traverse closureFor (NonEmpty.toList - (directInductiveClauses + (preparedInductiveClauses inductive)) where closureFor clause = do clauseEnvironment <- extendVariables environment - (directClauseVariables clause) + (preparedClauseVariables clause) let binderCount = fromIntegral (length - (directClauseVariables + (preparedClauseVariables clause)) subset' = shiftCanonicalTerm @@ -1645,17 +2085,17 @@ closureTerms resolveGlobal clauseEnvironment subset') - (directClauseConditions + (preparedClauseConditions clause) result <- lowerTerm resolveGlobal clauseEnvironment - (directClauseResult clause) + (preparedClauseResult clause) pure (closeForalls (length - (directClauseVariables + (preparedClauseVariables clause)) (impliesIfNeeded (conjunctionList conditions) @@ -1666,7 +2106,7 @@ closureTerms proveBoundedMonotonicity :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> Either @@ -1683,7 +2123,7 @@ proveBoundedMonotonicity =<< lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- checkedTerm context @@ -1712,7 +2152,7 @@ proveBoundedMonotonicity =<< lowerTerm resolveGlobal elementEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) predicate <- checkedTerm elementContext @@ -1787,7 +2227,7 @@ proveBoundedMonotonicity =<< lowerTerm resolveGlobal xyEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) relation <- checkedTerm xyContext @@ -1843,7 +2283,7 @@ proveBoundedMonotonicity =<< lowerTerm resolveGlobal elementEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) predicateX <- checkedTerm @@ -2021,7 +2461,7 @@ proveBoundedMonotonicity transformPredicateProof :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -2067,7 +2507,7 @@ transformPredicateProof (atNatural clauseIndex (NonEmpty.toList - (directInductiveClauses + (preparedInductiveClauses inductive))) first (TypedInductivePreparationContext @@ -2141,7 +2581,7 @@ transformPredicateProof transformClauseBody :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -2168,13 +2608,13 @@ transformClauseBody resolveGlobal environment candidateX) - (directClauseConditions + (preparedClauseConditions clause) clauseResult <- lowerTerm resolveGlobal environment - (directClauseResult clause) + (preparedClauseResult clause) let equality = CEq TySet result clauseResult bodyTermsX = @@ -2191,9 +2631,10 @@ transformClauseBody transformedConditions <- sequence [ case condition of - DirectSideCondition _formula -> + PreparedSideCondition _formula -> pure conditionProof - DirectRecursiveCondition recursiveTerm -> do + PreparedDirectRecursiveCondition + recursiveTerm _context -> do recursiveElement <- checkedTerm context =<< lowerTerm @@ -2217,9 +2658,33 @@ transformClauseBody context implication conditionProof) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + subsetProof <- + subsetRelationHypothesis + context + candidateX + candidateY + domain + left <- checkedTerm context candidateX + right <- checkedTerm context candidateY + transportNestedRecursiveMembership + context + environment + nested + left + right + recursiveElement + subsetProof + conditionProof | (condition, conditionProof) <- zip - (directClauseConditions clause) + (preparedClauseConditions clause) conditionProofs ] equalityProof <- @@ -2270,9 +2735,163 @@ subsetRelationHypothesis rightSubsetDomain relationProof) +preparedRecursiveTerm + :: PreparedInductiveCondition global + -> Term +preparedRecursiveTerm = \case + PreparedDirectRecursiveCondition term _context -> term + PreparedNestedRecursiveCondition term _context _index _target -> term + PreparedSideCondition{} -> + impossible "a side condition has no recursive element" + +transportNestedRecursiveMembership + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +transportNestedRecursiveMembership + context + environment + condition + left + right + element + subsetProof + membership = do + monotonicity <- + nestedRecursiveMonotonicityProof + context environment condition left right subsetProof + implication <- + first TypedInductiveProofError + (forallEliminationProof + context monotonicity element) + first TypedInductiveProofError + (implicationEliminationProof + context implication membership) + +nestedRecursiveMonotonicityProof + :: ProofContext (InductiveGlobal global) + -> InductiveEnvironment + -> PreparedInductiveCondition (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> BuiltProof (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +nestedRecursiveMonotonicityProof + context + environment + (PreparedNestedRecursiveCondition + _term + (CheckedRecursiveCarrierContext variables _template) + index + target) + left + right + subsetProof = do + theorem <- + first TypedInductiveProofError + (importedProof context index target) + specialized <- + eliminateWrittenForalls + context environment variables theorem + atLeft <- + first TypedInductiveProofError + (forallEliminationProof context specialized left) + atRight <- + first TypedInductiveProofError + (forallEliminationProof context atLeft right) + first TypedInductiveProofError + (implicationEliminationProof + context atRight subsetProof) +nestedRecursiveMonotonicityProof + _context _environment _condition _left _right _subsetProof = + Left + (TypedInductiveUnsupportedExpression + "nested carrier transport requires a monotonicity import") + +proveInductionCandidateSubset + :: ProofContext (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> ScopedCheckedCore (InductiveGlobal global) + -> Either + TypedInductiveError + (BuiltProof (InductiveGlobal global)) +proveInductionCandidateSubset + context fixedPoint predicate candidate subset = + proveSubset + context candidate subset + (\elementContext element membership -> do + fixedPointAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + fixedPoint) + predicateAtElement <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + predicate) + explicitMembership <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (apply2 + (CIntrinsic Sep) + (scopedCoreTerm fixedPointAtElement) + (scopedCoreTerm predicateAtElement))) + membership' <- + first TypedInductiveProofError + (conversionProof + elementContext membership explicitMembership) + characteristic <- + separationForward + elementContext + fixedPointAtElement + predicateAtElement + element + membership' + satisfies <- + first TypedInductiveProofError + (conjunctionRightProof + elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm fixedPointAtElement)) + (CApp + (scopedCoreTerm predicateAtElement) + (scopedCoreTerm element)) + characteristic) + expected <- + first TypedInductiveCoreError + (weakenScopedCore + (Just . inductiveGlobalType) + TySet + subset) + target <- + checkedTerm elementContext + (memberTerm + (scopedCoreTerm element) + (scopedCoreTerm expected)) + first TypedInductiveProofError + (conversionProof + elementContext satisfies target)) + eliminateClauseWitnesses :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -2310,7 +2929,7 @@ eliminateClauseWitnesses initialResult initialProof initialTarget - (directClauseVariables clause) + (preparedClauseVariables clause) where go depth context environment candidate result proof target = \case [] -> @@ -2442,7 +3061,7 @@ eliminateDisjunctionAlternatives proveInductionClosure :: CheckedFoundation -> (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> ScopedCheckedCore (InductiveGlobal global) @@ -2521,7 +3140,7 @@ proveInductionClosure =<< lowerTerm resolveGlobal elementEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) operatorPredicate <- checkedTerm withMember @@ -2620,7 +3239,7 @@ proveInductionClosure (atNatural clauseIndex (NonEmpty.toList - (directInductiveClauses + (preparedInductiveClauses inductive))) first (TypedInductivePreparationContext @@ -2688,9 +3307,9 @@ proveInductionClosure proveInductionClause :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> Natural - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> ProofContext (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -2724,13 +3343,13 @@ proveInductionClause (CIntrinsic Sep) fixedPoint predicate)) - (directClauseConditions + (preparedClauseConditions clause) clauseResult <- lowerTerm resolveGlobal environment - (directClauseResult clause) + (preparedClauseResult clause) let equality = CEq TySet result clauseResult bodyTerms = @@ -2750,9 +3369,10 @@ proveInductionClause closureConditionProofs <- sequence [ case condition of - DirectSideCondition _formula -> + PreparedSideCondition _formula -> pure conditionProof - DirectRecursiveCondition recursiveTerm -> do + PreparedDirectRecursiveCondition + recursiveTerm _context -> do recursiveElement <- checkedTerm context =<< lowerTerm @@ -2794,9 +3414,41 @@ proveInductionClause context predicateMembership expected) + nested@PreparedNestedRecursiveCondition{} -> do + recursiveElement <- + checkedTerm context + =<< lowerTerm + resolveGlobal + environment + (preparedRecursiveTerm nested) + fixedPoint' <- checkedTerm context fixedPoint + predicate' <- checkedTerm context predicate + candidate <- + checkedTerm context + (apply2 + (CIntrinsic Sep) + fixedPoint + predicate) + subset' <- checkedTerm context subset + candidateSubset <- + proveInductionCandidateSubset + context + fixedPoint' + predicate' + candidate + subset' + transportNestedRecursiveMembership + context + environment + nested + candidate + subset' + recursiveElement + candidateSubset + conditionProof | (condition, conditionProof) <- zip - (directClauseConditions clause) + (preparedClauseConditions clause) conditionProofs ] closureConjunction <- @@ -2840,7 +3492,7 @@ proveInductionClause (eliminateWrittenForalls context environment - (directClauseVariables clause) + (preparedClauseVariables clause) selectedClosure) resultMembership <- case closureConditionProofs of @@ -2951,7 +3603,7 @@ transportElementMembership predicateAt :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> CanonicalTerm (InductiveGlobal global) @@ -2974,7 +3626,7 @@ predicateAt clauseFormulaTerms :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> CanonicalTerm (InductiveGlobal global) @@ -2994,7 +3646,7 @@ clauseFormulaTerms candidate result) (NonEmpty.toList - (directInductiveClauses + (preparedInductiveClauses inductive)) clauseFormulaAt @@ -3002,7 +3654,7 @@ clauseFormulaAt -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> CanonicalTerm (InductiveGlobal global) - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> Either TypedInductiveError (CanonicalTerm (InductiveGlobal global)) @@ -3015,11 +3667,11 @@ clauseFormulaAt clauseEnvironment <- extendVariables environment - (directClauseVariables clause) + (preparedClauseVariables clause) let binderCount = fromIntegral (length - (directClauseVariables + (preparedClauseVariables clause)) candidate' = shiftCanonicalTerm binderCount 0 candidate @@ -3031,17 +3683,17 @@ clauseFormulaAt resolveGlobal clauseEnvironment candidate') - (directClauseConditions + (preparedClauseConditions clause) clauseResult <- lowerTerm resolveGlobal clauseEnvironment - (directClauseResult clause) + (preparedClauseResult clause) pure (closeExistentials (length - (directClauseVariables + (preparedClauseVariables clause)) (fromMaybe (CEq TySet result' clauseResult) @@ -3101,7 +3753,7 @@ membershipPredicate context set = do operatorPredicateAt :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> Either @@ -3128,7 +3780,7 @@ operatorPredicateAt separationSetAt :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) -> Either @@ -3143,7 +3795,7 @@ separationSetAt lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) predicate <- operatorPredicateAt @@ -3472,7 +4124,7 @@ buildUnderVariables fixedPointTerm :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> Either TypedInductiveError @@ -3482,7 +4134,7 @@ fixedPointTerm resolveGlobal inductive environment = do lowerTerm resolveGlobal environment - (directInductiveDomain + (preparedInductiveDomain inductive) operator <- operatorTerm @@ -3498,7 +4150,7 @@ fixedPointTerm resolveGlobal inductive environment = do operatorTerm :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) - -> DirectInductive + -> PreparedInductiveSource (InductiveGlobal global) -> InductiveEnvironment -> Either TypedInductiveError @@ -3510,7 +4162,7 @@ operatorTerm resolveGlobal inductive parameterEnvironment = do lowerTerm resolveGlobal candidateEnvironment - (directInductiveDomain + (preparedInductiveDomain inductive) resultEnvironment <- shiftEnvironment candidateEnvironment @@ -3519,7 +4171,7 @@ operatorTerm resolveGlobal inductive parameterEnvironment = do (clausePredicateTerm resolveGlobal resultEnvironment) - (directInductiveClauses + (preparedInductiveClauses inductive) pure (CLam TySet @@ -3535,7 +4187,7 @@ operatorTerm resolveGlobal inductive parameterEnvironment = do clausePredicateTerm :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> InductiveEnvironment - -> DirectInductiveClause + -> PreparedInductiveClause (InductiveGlobal global) -> Either TypedInductiveError (CanonicalTerm (InductiveGlobal global)) @@ -3546,11 +4198,11 @@ clausePredicateTerm clauseEnvironment <- extendVariables resultEnvironment - (directClauseVariables clause) + (preparedClauseVariables clause) let variableCount = fromIntegral (length - (directClauseVariables + (preparedClauseVariables clause)) resultVariable = CBound variableCount @@ -3562,18 +4214,18 @@ clausePredicateTerm resolveGlobal clauseEnvironment candidate) - (directClauseConditions + (preparedClauseConditions clause) result <- lowerTerm resolveGlobal clauseEnvironment - (directClauseResult + (preparedClauseResult clause) pure (closeExistentials (length - (directClauseVariables clause)) + (preparedClauseVariables clause)) (fromMaybe (CEq TySet @@ -3586,7 +4238,7 @@ clausePredicateTerm resultVariable result])))) -conditionTerm +directConditionTerm :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) -> InductiveEnvironment -> CanonicalTerm (InductiveGlobal global) @@ -3594,19 +4246,47 @@ conditionTerm -> Either TypedInductiveError (CanonicalTerm (InductiveGlobal global)) -conditionTerm resolveGlobal environment candidate = \case +directConditionTerm resolveGlobal environment candidate = \case DirectSideCondition formula -> + lowerFormula resolveGlobal environment formula + DirectRecursiveCondition term context -> do + carrier <- + betaNormalizeCanonical + <$> lowerRecursiveCarrierContext + resolveGlobal environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier + +conditionTerm + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> CanonicalTerm (InductiveGlobal global) + -> PreparedInductiveCondition (InductiveGlobal global) + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +conditionTerm resolveGlobal environment candidate = \case + PreparedSideCondition formula -> lowerFormula resolveGlobal environment formula - DirectRecursiveCondition term -> + PreparedDirectRecursiveCondition term context -> do + carrier <- + instantiateRecursiveCarrier environment candidate context memberTerm <$> lowerTerm resolveGlobal environment term - <*> pure candidate + <*> pure carrier + PreparedNestedRecursiveCondition term context _index _target -> do + carrier <- + instantiateRecursiveCarrier environment candidate context + memberTerm + <$> lowerTerm resolveGlobal environment term + <*> pure carrier shiftEnvironment :: InductiveEnvironment @@ -3708,7 +4388,7 @@ lowerFormulaWith allowQuantified resolveGlobal environment = \case <*> lowerFormulaWith allowQuantified resolveGlobal environment right Atomic _location predicate arguments -> - lowerApplication + lowerPredicateApplication resolveGlobal environment (SymbolPredicate predicate) @@ -3783,6 +4463,40 @@ lowerApplication resolveGlobal environment symbol arguments = do resolveGlobal environment) arguments + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerPredicateApplication + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> InductiveEnvironment + -> Symbol + -> [Expr] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerPredicateApplication resolveGlobal environment symbol arguments = do + arguments' <- + traverse + (lowerTerm + resolveGlobal + environment) + arguments + case classifyExactSymbol symbol of + ExactFixedPrimitive meaning -> + maybe + (lowerApplicationTerms resolveGlobal symbol arguments') + Right + (lowerFixedEqualityPredicate meaning arguments') + _ -> + lowerApplicationTerms resolveGlobal symbol arguments' + +lowerApplicationTerms + :: (Symbol -> Maybe (SourceGlobal (InductiveGlobal global))) + -> Symbol + -> [CanonicalTerm (InductiveGlobal global)] + -> Either + TypedInductiveError + (CanonicalTerm (InductiveGlobal global)) +lowerApplicationTerms resolveGlobal symbol arguments' = case dispatchFixedSetTerm symbol arguments' of LoweredFixedSetTerm term -> pure term diff --git a/source/Felix/CommandLine.hs b/source/Felix/CommandLine.hs new file mode 100644 index 0000000..448d698 --- /dev/null +++ b/source/Felix/CommandLine.hs @@ -0,0 +1,911 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.CommandLine + ( runCommandLine + , Input(..) + , VerificationOptions(..) + , Command(..) + , CommandOutcome(..) + , VerifiedOutputFailure(..) + , parseCommandArguments + , verificationCommandOutcome + , commandOutcomeExitCode + , renderCommandOutcome + ) where + +import Base +import Felix.OutputPlan qualified as Output +import Felix.Parse (ParseWorkspaceError) +import Felix.Parse qualified as Parse +import Felix.Provers qualified as Provers +import Felix.RequestDump qualified as RequestDump +import Felix.Source (SafeRelativePath) +import Felix.Source.Graph qualified as SourceGraph +import Felix.Store qualified as Store +import Felix.Verification qualified as Verification +import Felix.Version qualified as Version +import Felix.Workspace qualified as Workspace +import Felix.Render.Html.Export qualified as HtmlExport +import Felix.Render.Html.Layout qualified as HtmlLayout +import Felix.Render.Html.Output qualified as HtmlOutput +import Felix.Report.Location + +import Control.Monad (unless, when) +import Data.Maybe (catMaybes) +import Data.Text qualified as StrictText +import Data.Text.IO qualified as Text +import GHC.Conc qualified +import Numeric (showFFloat) +import Options.Applicative hiding (renderFailure) +import System.Environment (getArgs, lookupEnv) +import System.Exit (ExitCode(..), exitWith) +import System.IO (stderr) +import Text.Read (readMaybe) + + +newtype Input = Input + { inputFilePath :: FilePath + } + deriving stock (Show, Eq) + +data VerificationOptions = VerificationOptions + { verificationStoreSelection :: !Store.StoreSelection + , verificationTimeLimit :: !Provers.TimeLimit + , verificationMemoryLimit :: !Provers.MemoryLimit + , verificationJobsOverride :: !(Maybe Provers.EffectiveJobs) + , verificationDumpDestination :: !(Maybe FilePath) + , verificationHtmlRequested :: !Bool + } + deriving stock (Show, Eq) + +data Command + = Version + | ParseOnly !Input + | Verify !Input !VerificationOptions + deriving stock (Show, Eq) + +data CommandOutcome + = CommandCompleted + | VerificationSucceeded + !Verification.VerificationReport + !Provers.SlowAtpReport + | VerificationCompletedWithGaps + !Verification.VerificationReport + !Provers.SlowAtpReport + | VerificationRejected + !Verification.VerificationReport + !Verification.FailedVerification + !Provers.SlowAtpReport + | VerificationCheckingRejected + !Verification.VerificationReport + !Verification.VerificationDriverError + !Provers.SlowAtpReport + | SourcePlanningFailed !ParseWorkspaceError + | ParseOnlyFailed !Workspace.AuthorityFreeParseError + | VerificationDriverFailed !Verification.VerificationDriverError + | VerificationSessionFailed + !Store.StorePath + !Verification.VerificationSessionError + | StorePlanningFailed !Store.StorePlanningError + | StoreIncompatible !Store.StorePath !Store.StoreIncompatibility + | StoreFailed !Store.StorePath !Store.StoreLifecycleError + | OutputPlanningFailed !Output.OutputPlanError + | HtmlLayoutFailed !HtmlLayout.HtmlLayoutError + | DumpObservationFailed !RequestDump.DumpObservationError + | VerifiedOutputFailed + !Verification.VerificationReport + !VerifiedOutputFailure + !Provers.SlowAtpReport + deriving stock (Show) + +data VerifiedOutputFailure + = VerifiedHtmlExportFailed !HtmlExport.HtmlExportError + | VerifiedHtmlOutputPlanningFailed !HtmlOutput.HtmlOutputError + | VerifiedHtmlPublicationFailed !HtmlOutput.HtmlPublicationError + | VerifiedHtmlLayoutUnavailable + deriving stock (Show) + +data HtmlPreflight = HtmlPreflight + !Workspace.WorkspaceEnvironment + !SourceGraph.ResolvedSourceGraph + !HtmlLayout.HtmlLayout + ![SafeRelativePath] + + +runCommandLine :: IO () +runCommandLine = do + arguments <- getArgs + selected <- handleParseResult (parseCommandArguments arguments) + outcome <- runCommand selected + renderCommandOutcome outcome + exitWith (commandOutcomeExitCode outcome) + +rawCommandParserInfo :: ParserInfo RawCommand +rawCommandParserInfo = + info + (helper <*> rawCommandParser) + (fullDesc <> header "Felix") + +runCommand :: Command -> IO CommandOutcome +runCommand = \case + Version -> do + Text.putStrLn Version.info + pure CommandCompleted + ParseOnly (Input input) -> + Workspace.parseWorkspace input >>= \case + Left failure -> + pure (ParseOnlyFailed failure) + Right _blocks -> + pure CommandCompleted + Verify input options -> + runVerification input options + +runVerification + :: Input + -> VerificationOptions + -> IO CommandOutcome +runVerification input options = do + plannedStore <- + Store.planStore + (verificationStoreSelection options) + case plannedStore of + Left failure -> + pure (StorePlanningFailed failure) + Right storePlan -> do + htmlResult <- discoverHtmlDestinations input options + case htmlResult of + Left failure -> + pure failure + Right htmlPreflight -> + Store.withStoreLease storePlan \lease -> do + outputResult <- + Output.planVerificationOutputs + (Store.storeLeasePath lease) + (verificationDumpDestination options) + (fmap + (\(HtmlPreflight + _environment _graph _layout destinations) -> + ("html", destinations)) + htmlPreflight) + case outputResult of + Left failure -> + pure (OutputPlanningFailed failure) + Right outputPlan -> + openVerificationSession + input + options + lease + outputPlan + htmlPreflight + +discoverHtmlDestinations + :: Input + -> VerificationOptions + -> IO (Either CommandOutcome (Maybe HtmlPreflight)) +discoverHtmlDestinations input options + | not (verificationHtmlRequested options) = + pure (Right Nothing) + | otherwise = do + prepared <- prepareInputSourceGraph input + pure case prepared of + Left failure -> Left (SourcePlanningFailed failure) + Right (environment, graph) -> + case planHtmlDestinations environment graph of + Left failure -> Left (HtmlLayoutFailed failure) + Right (layout, destinations) -> + Right + (Just + (HtmlPreflight + environment graph layout destinations)) + +planHtmlDestinations + :: Workspace.WorkspaceEnvironment + -> SourceGraph.ResolvedSourceGraph + -> Either + HtmlLayout.HtmlLayoutError + (HtmlLayout.HtmlLayout, [SafeRelativePath]) +planHtmlDestinations environment graph = do + layout <- + HtmlLayout.layoutHtmlSourceGraph + (Workspace.workspaceHtmlMountPrefixes environment) + graph + pure + ( layout + , [ HtmlLayout.routeDestination route + | (_source, route) <- + HtmlLayout.htmlPageRoutes layout + ] + <> [HtmlLayout.routeDestination + (HtmlLayout.htmlSupportScriptRoute layout)] + ) + +prepareInputSourceGraph + :: Input + -> IO + (Either + ParseWorkspaceError + (Workspace.WorkspaceEnvironment, SourceGraph.ResolvedSourceGraph)) +prepareInputSourceGraph input = do + preparedEnvironment <- Workspace.prepareDefaultWorkspaceEnvironment + case preparedEnvironment of + Left failure -> pure (Left failure) + Right environment -> do + preparedRoot <- Workspace.prepareWorkspaceRoot + environment + (inputFilePath input) + case preparedRoot of + Left failure -> pure (Left failure) + Right root -> + fmap (fmap (\graph -> (environment, graph))) + (Workspace.prepareSourceGraph environment root) + +openVerificationSession + :: Input + -> VerificationOptions + -> Store.StoreLease + -> Output.VerificationOutputPlan + -> Maybe HtmlPreflight + -> IO CommandOutcome +openVerificationSession input options lease outputPlan htmlPreflight = do + opened <- Verification.withVerificationSession lease + (\session -> + runOpenVerification + input + options + outputPlan + htmlPreflight + session) + pure case opened of + Left + (Verification.VerificationSessionStoreError + (Store.StoreLifecycleOpenFailed + (Store.IncompatibleStore incompatibility))) -> + StoreIncompatible + (Store.storeLeasePath lease) + incompatibility + Left (Verification.VerificationSessionStoreError failure) -> + StoreFailed (Store.storeLeasePath lease) failure + Left failure -> + VerificationSessionFailed (Store.storeLeasePath lease) failure + Right outcome -> outcome + +runOpenVerification + :: Input + -> VerificationOptions + -> Output.VerificationOutputPlan + -> Maybe HtmlPreflight + -> Verification.VerificationSession + -> IO CommandOutcome +runOpenVerification input options outputPlan htmlPreflight session = do + observerResult <- + RequestDump.prepareRequestObserver + (Output.verificationDumpOutput outputPlan) + case observerResult of + Left failure -> + pure (DumpObservationFailed failure) + Right observer -> do + (preparedGraph, htmlOutputPreparation) <- case htmlPreflight of + Just (HtmlPreflight + environment graph layout _destinations) -> + pure + ( Right graph + , Just + ( Workspace.workspaceRendererSearchRoots environment + , layout + ) + ) + Nothing -> do + graphResult <- fmap snd <$> prepareInputSourceGraph input + pure (graphResult, Nothing) + case preparedGraph of + Left failure -> pure (SourcePlanningFailed failure) + Right graph -> do + vampirePath <- getVampireExecutable + jobs <- Provers.selectEffectiveJobs + (verificationJobsOverride options) + GHC.Conc.getNumProcessors + let vampire = + Provers.vampire + vampirePath + (verificationTimeLimit options) + (verificationMemoryLimit options) + validationMode = + case verificationStoreSelection options of + Store.FreshTemporaryStore -> + Verification.FreshStoreValidation + Store.DefaultStore -> + Verification.WarmStoreValidation + Store.ExplicitStore{} -> + Verification.WarmStoreValidation + request = Verification.CheckRequest + { Verification.checkSourceGraph = graph + , Verification.checkStoreValidationMode = + validationMode + , Verification.checkEffectiveJobs = jobs + , Verification.checkVampire = vampire + , Verification.checkRequestObserver = observer + } + observed <- RequestDump.captureDumpFailure + (Verification.checkWorkspace session request) + case observed of + Left failure -> pure (DumpObservationFailed failure) + Right (Left failure) -> + pure (VerificationDriverFailed failure) + Right (Right outcome) -> + finishVerification + outputPlan + htmlOutputPreparation + outcome + +finishVerification + :: Output.VerificationOutputPlan + -> Maybe ([FilePath], HtmlLayout.HtmlLayout) + -> Verification.CheckOutcome + -> IO CommandOutcome +finishVerification outputPlan selectedLayout outcome = + case result of + Verification.VerificationFailure{} -> + pure (verificationCommandOutcome result slowReport) + Verification.VerificationCheckingFailure{} -> + pure (verificationCommandOutcome result slowReport) + Verification.VerificationCompleted report presentation -> + publishHtmlIfRequested + outputPlan + selectedLayout + report + presentation + (VerificationSucceeded report slowReport) + slowReport + Verification.CompletedWithExplicitGaps report presentation -> + publishHtmlIfRequested + outputPlan + selectedLayout + report + presentation + (VerificationCompletedWithGaps report slowReport) + slowReport + where + result = Verification.checkVerificationResult outcome + slowReport = Verification.checkSlowAtpReport outcome + +publishHtmlIfRequested + :: Output.VerificationOutputPlan + -> Maybe ([FilePath], HtmlLayout.HtmlLayout) + -> Verification.VerificationReport + -> Verification.VerificationPresentation + -> CommandOutcome + -> Provers.SlowAtpReport + -> IO CommandOutcome +publishHtmlIfRequested + outputPlan selectedLayout report presentation successOutcome slowReport = + case Output.verificationHtmlRoutes outputPlan of + Nothing -> + pure successOutcome + Just routes -> do + case selectedLayout of + Nothing -> + pure + (VerifiedOutputFailed + report + VerifiedHtmlLayoutUnavailable + slowReport) + Just (rendererRoots, layout) -> do + prepared <- + HtmlExport.prepareHtmlExportWithLayoutFromRendererRoots + rendererRoots + layout + (Verification.verificationHtmlPresentation presentation) + case prepared of + Left failure -> + pure + (VerifiedOutputFailed + report + (VerifiedHtmlExportFailed failure) + slowReport) + Right artifacts -> + case HtmlOutput.planHtmlOutputAgainst routes artifacts of + Left failure -> + pure + (VerifiedOutputFailed + report + (VerifiedHtmlOutputPlanningFailed failure) + slowReport) + Right plan -> + HtmlOutput.writeHtmlOutput plan >>= \case + Left failure -> + pure + (VerifiedOutputFailed + report + (VerifiedHtmlPublicationFailed + failure) + slowReport) + Right () -> + pure successOutcome + +verificationCommandOutcome + :: Verification.VerificationResult + -> Provers.SlowAtpReport + -> CommandOutcome +verificationCommandOutcome result slowReport = case result of + Verification.VerificationCompleted report _presentation -> + VerificationSucceeded report slowReport + Verification.CompletedWithExplicitGaps report _presentation -> + VerificationCompletedWithGaps report slowReport + Verification.VerificationFailure report failure -> + VerificationRejected report failure slowReport + Verification.VerificationCheckingFailure report failure -> + VerificationCheckingRejected report failure slowReport + +commandOutcomeExitCode :: CommandOutcome -> ExitCode +commandOutcomeExitCode = \case + CommandCompleted -> + ExitSuccess + VerificationSucceeded{} -> + ExitSuccess + VerificationCompletedWithGaps{} -> + ExitSuccess + VerificationRejected _report failed _slow -> + case Verification.failedVerificationReason failed of + Verification.CountermodelFailure{} -> ExitFailure 1 + Verification.ContradictoryInputFailure{} -> ExitFailure 1 + Verification.IndeterminateFailure{} -> ExitFailure 2 + Verification.ProtocolFailure{} -> ExitFailure 2 + Verification.TransportFailure{} -> ExitFailure 2 + VerificationCheckingRejected _report failure _slow -> + case Verification.verificationDriverErrorKind failure of + Verification.VerificationSourceFailure -> ExitFailure 1 + Verification.VerificationInfrastructureFailure -> ExitFailure 2 + SourcePlanningFailed{} -> + ExitFailure 1 + ParseOnlyFailed{} -> + ExitFailure 1 + VerificationDriverFailed failure -> + case Verification.verificationDriverErrorKind failure of + Verification.VerificationSourceFailure -> ExitFailure 1 + Verification.VerificationInfrastructureFailure -> ExitFailure 2 + VerificationSessionFailed{} -> + ExitFailure 2 + StorePlanningFailed{} -> + ExitFailure 2 + StoreIncompatible{} -> + ExitFailure 2 + StoreFailed{} -> + ExitFailure 2 + OutputPlanningFailed{} -> + ExitFailure 2 + HtmlLayoutFailed{} -> + ExitFailure 2 + DumpObservationFailed{} -> + ExitFailure 2 + VerifiedOutputFailed{} -> + ExitFailure 2 + +renderCommandOutcome :: CommandOutcome -> IO () +renderCommandOutcome = \case + CommandCompleted -> + pure () + VerificationSucceeded report slowReport -> do + Text.hPutStrLn stderr "Verification successful." + renderVerificationReport report + renderSlowAtpReport slowReport + VerificationCompletedWithGaps report slowReport -> do + Text.hPutStrLn stderr + "Verification completed with explicit proof gaps." + renderVerificationReport report + renderSlowAtpReport slowReport + VerificationRejected report failure slowReport -> do + renderFailedVerification failure + renderVerificationReport report + renderSlowAtpReport slowReport + VerificationCheckingRejected report failure slowReport -> do + renderVerificationDriverFailure failure + renderVerificationReport report + renderSlowAtpReport slowReport + SourcePlanningFailed failure -> + renderFailure + ("Source planning failed: " + <> Parse.renderParseWorkspaceError failure) + ParseOnlyFailed failure -> + renderFailure + ("Parsing failed: " + <> Workspace.renderAuthorityFreeParseError failure) + VerificationDriverFailed failure -> + renderVerificationDriverFailure failure + VerificationSessionFailed path failure -> + renderFailure case failure of + Verification.VerificationSessionFoundationError{} -> + "The fixed foundation manifest is invalid." + Verification.VerificationSessionStoreError storeFailure -> + "Store failure at " + <> quotePath (Store.storePathFilePath path) + <> ": " + <> Store.renderStoreLifecycleError storeFailure + Verification.VerificationSessionTheoryMismatch expected actual -> + "Store theory mismatch at " + <> quotePath (Store.storePathFilePath path) + <> ": expected " + <> StrictText.pack (show expected) + <> ", found " + <> StrictText.pack (show actual) + StorePlanningFailed failure -> + renderFailure + ("Store path planning failed: " + <> Store.renderStorePlanningError failure) + StoreIncompatible path failure -> + renderFailure + ("Disposable store " + <> quotePath (Store.storePathFilePath path) + <> " is incompatible: " + <> Store.renderStoreIncompatibility failure + <> ". Use --fresh, choose another --store path, or remove the disposable store.") + StoreFailed path failure -> + renderFailure + ("Store failure at " + <> quotePath (Store.storePathFilePath path) + <> ": " <> Store.renderStoreLifecycleError failure) + OutputPlanningFailed failure -> + renderFailure + ("Verification output preflight failed: " + <> Output.renderOutputPlanError failure) + HtmlLayoutFailed failure -> + renderFailure + ("HTML route planning failed: " + <> HtmlLayout.renderHtmlLayoutError failure) + DumpObservationFailed failure -> + renderFailure (RequestDump.renderDumpObservationError failure) + VerifiedOutputFailed report failure slowReport -> do + renderVerifiedOutputFailure failure + renderVerificationReport report + renderSlowAtpReport slowReport + +renderFailure :: Text -> IO () +renderFailure = + Text.hPutStrLn stderr + +renderVerificationDriverFailure + :: Verification.VerificationDriverError + -> IO () +renderVerificationDriverFailure = + renderFailure . Verification.renderVerificationDriverError + +quotePath :: FilePath -> Text +quotePath = StrictText.pack . show + +renderFailedVerification :: Verification.FailedVerification -> IO () +renderFailedVerification failed = + case Verification.failedVerificationReason failed of + Verification.CountermodelFailure tptp -> do + renderFailedTask tptp + Text.hPutStrLn stderr + ("Verification failed: prover found countermodel at " + <> locationToText location) + Text.hPutStrLn stderr + "This often happens when an explicit justification with \\cref{...} is missing some references." + Verification.ContradictoryInputFailure tptp -> do + renderFailedTask tptp + Text.hPutStrLn stderr + ("Verification failed: contradictory axioms at " + <> locationToText location) + Text.hPutStrLn stderr + "This is usually caused by an incorrect axiom or a theorem that has its proof omitted." + Verification.IndeterminateFailure tptp -> do + renderFailedTask tptp + Text.hPutStrLn stderr + ("Verification failed: prover returned an indeterminate result at " + <> locationToText location) + Verification.ProtocolFailure label message -> do + Text.hPutStrLn stderr + ("Prover error at " <> locationToText location <> ":") + Text.hPutStrLn stderr ("Task: " <> label) + Text.hPutStrLn stderr ("Error: " <> message) + Verification.TransportFailure processError -> do + Text.hPutStrLn stderr + ("Prover process error at " <> locationToText location <> ":") + Text.hPutStrLn stderr (StrictText.pack (show processError)) + where + location = Verification.failedVerificationLocation failed + +renderVerifiedOutputFailure :: VerifiedOutputFailure -> IO () +renderVerifiedOutputFailure = \case + VerifiedHtmlExportFailed failure -> + renderFailure + ("Verification succeeded, but HTML preparation failed: " + <> HtmlExport.renderHtmlExportError failure) + VerifiedHtmlOutputPlanningFailed failure -> + renderFailure + ("Verification succeeded, but prepared HTML did not match the reserved routes: " + <> HtmlOutput.renderHtmlOutputError failure) + VerifiedHtmlPublicationFailed failure -> do + renderFailure + "Verification succeeded, but HTML publication did not complete." + traverse_ + renderFailure + (HtmlOutput.renderHtmlPublicationError failure) + VerifiedHtmlLayoutUnavailable -> + renderFailure + "Verification succeeded, but the preflight HTML layout was unavailable." + +renderFailedTask :: Text -> IO () +renderFailedTask tptp = do + Text.hPutStrLn stderr "(Failed TPTP task follows.)" + Text.hPutStrLn stderr tptp + +renderVerificationReport :: Verification.VerificationReport -> IO () +renderVerificationReport report = do + Text.hPutStrLn stderr + ( "Direct source authorization summary: " + <> renderCount + sourceAxiomCount + "source axiom" + <> ", " + <> renderCount + omittedCount + "explicit proof gap" + <> "." + ) + for_ + (Verification.verificationDirectEscapes report) + \escape -> + Text.hPutStrLn stderr case Verification.reportedEscapeKind escape of + Verification.ReportedSourceAxiom -> + "Source axiom at " + <> locationToText + (Verification.reportedEscapeLocation escape) + Verification.ReportedOmitted -> + "Explicit proof gap at " + <> locationToText + (Verification.reportedEscapeLocation escape) + where + sourceAxiomCount = + length + [ () + | escape <- Verification.verificationDirectEscapes report + , Verification.reportedEscapeKind escape + == Verification.ReportedSourceAxiom + ] + omittedCount = + length + [ () + | escape <- Verification.verificationDirectEscapes report + , Verification.reportedEscapeKind escape + == Verification.ReportedOmitted + ] + renderCount amount noun = + StrictText.pack (show amount) + <> " " + <> noun + <> if amount == 1 then "" else "s" + +renderSlowAtpReport :: Provers.SlowAtpReport -> IO () +renderSlowAtpReport report = + unless (null (Provers.slowAtpTasks report)) do + Text.hPutStrLn stderr + "Slow Vampire tasks (executor wall time; run-local performance note):" + traverse_ renderTask (Provers.slowAtpTasks report) + let omitted = Provers.slowAtpOmittedTaskCount report + when (omitted > 0) + (Text.hPutStrLn stderr + ( StrictText.pack + (show (length (Provers.slowAtpTasks report))) + <> " slowest shown; " + <> StrictText.pack (show omitted) + <> " additional tasks took at least 5.0 seconds." + )) + where + renderTask task = + Text.hPutStrLn stderr + ( " " + <> renderAtpDuration (Provers.slowAtpDuration task) + <> " " + <> renderSlowAtpOutcome (Provers.slowAtpOutcome task) + <> " at " + <> locationToText (Provers.slowAtpLocation task) + <> " (module " + <> renderNatural + (Provers.workPositionModuleOrdinal + (Provers.slowAtpPosition task)) + <> ", request " + <> renderNatural + (Provers.workPositionLocalRequestOrdinal + (Provers.slowAtpPosition task)) + <> ", id " + <> StrictText.pack (show (Provers.slowAtpRequestId task)) + <> ")" + ) + + renderNatural = StrictText.pack . show + +renderAtpDuration :: Provers.AtpDuration -> Text +renderAtpDuration duration = + StrictText.pack + (showFFloat + (Just 2) + (fromIntegral (Provers.atpDurationNanoseconds duration) + / (1000000000 :: Double)) + "s") + +renderSlowAtpOutcome :: Provers.SlowAtpOutcome -> Text +renderSlowAtpOutcome = \case + Provers.SlowAtpAccepted -> "accepted" + Provers.SlowAtpRejected rejection -> + "rejected (" <> StrictText.pack (show rejection) <> ")" + Provers.SlowAtpProtocolFailed -> "protocol failure" + Provers.SlowAtpProcessFailed -> "process failure" + +getVampireExecutable :: IO FilePath +getVampireExecutable = + fromMaybe "vampire" <$> lookupEnv "FELIX_VAMPIRE" + + +data RawCommand + = RawVersion + | RawFile !RawFileCommand + +data RawFileCommand = RawFileCommand + { rawInput :: !Input + , rawParseOnly :: !Bool + , rawStore :: !(Maybe FilePath) + , rawFresh :: !Bool + , rawTimeLimit :: !(Maybe Provers.TimeLimit) + , rawMemoryLimit :: !(Maybe Provers.MemoryLimit) + , rawJobs :: !(Maybe Provers.EffectiveJobs) + , rawDump :: !(Maybe FilePath) + , rawHtml :: !Bool + } + +rawCommandParser :: Parser RawCommand +rawCommandParser = + versionParser + <|> (RawFile <$> rawFileCommandParser) + +versionParser :: Parser RawCommand +versionParser = + flag' + RawVersion + (long "version" <> help "Show the Felix version.") + +inputParser :: Parser Input +inputParser = + Input + <$> strArgument + (help "Source file" <> metavar "FILE") + +rawFileCommandParser :: Parser RawFileCommand +rawFileCommandParser = + RawFileCommand + <$> inputParser + <*> switch + (long "parseonly" + <> help "Resolve and parse source without verification.") + <*> optional + (strOption + (long "store" + <> metavar "PATH" + <> help "Use the disposable SQLite store at PATH.")) + <*> switch + (long "fresh" + <> help "Use a fresh temporary disposable store.") + <*> optional timeLimitParser + <*> optional memoryLimitParser + <*> optional jobsParser + <*> optional + (strOption + (long "dump" + <> metavar "DUMPDIR" + <> help "Dump exact Vampire requests as they execute.")) + <*> switch + (long "html" + <> help "Publish verified HTML under ./html.") + +parseCommandArguments :: [String] -> ParserResult Command +parseCommandArguments arguments = + case execParserPure + defaultPrefs + rawCommandParserInfo + arguments of + Success raw -> + case validateRawCommand raw of + Left message -> + Failure + (parserFailure + defaultPrefs + rawCommandParserInfo + (ErrorMsg message) + []) + Right selected -> + Success selected + Failure failure -> + Failure failure + CompletionInvoked completion -> + CompletionInvoked completion + +validateRawCommand :: RawCommand -> Either String Command +validateRawCommand = \case + RawVersion -> + Right Version + RawFile raw + | rawParseOnly raw + , not (null verificationOnlyOptions) -> + Left + ("--parseonly cannot be combined with verification options: " + <> unwords verificationOnlyOptions) + | rawParseOnly raw -> + Right (ParseOnly (rawInput raw)) + | isJust (rawStore raw) && rawFresh raw -> + Left "--store and --fresh are mutually exclusive" + | otherwise -> + Right + (Verify + (rawInput raw) + VerificationOptions + { verificationStoreSelection = + case rawStore raw of + Just path -> + Store.ExplicitStore path + Nothing + | rawFresh raw -> + Store.FreshTemporaryStore + | otherwise -> + Store.DefaultStore + , verificationTimeLimit = + fromMaybe + Provers.defaultTimeLimit + (rawTimeLimit raw) + , verificationMemoryLimit = + fromMaybe + Provers.defaultMemoryLimit + (rawMemoryLimit raw) + , verificationJobsOverride = rawJobs raw + , verificationDumpDestination = + rawDump raw + , verificationHtmlRequested = + rawHtml raw + }) + where + verificationOnlyOptions = + catMaybes + [ "--store" <$ rawStore raw + , if rawFresh raw then Just "--fresh" else Nothing + , "--timelimit" <$ rawTimeLimit raw + , "--memlimit" <$ rawMemoryLimit raw + , "--jobs" <$ rawJobs raw + , "--dump" <$ rawDump raw + , if rawHtml raw then Just "--html" else Nothing + ] + +timeLimitParser :: Parser Provers.TimeLimit +timeLimitParser = + Provers.Seconds + <$> option auto + ( long "timelimit" + <> short 't' + <> metavar "SECONDS" + <> help "Time limit for each Vampire request." + ) + +memoryLimitParser :: Parser Provers.MemoryLimit +memoryLimitParser = + Provers.Megabytes + <$> option auto + ( long "memlimit" + <> short 'm' + <> metavar "MB" + <> help "Memory limit for each Vampire process." + ) + +jobsParser :: Parser Provers.EffectiveJobs +jobsParser = + option + (eitherReader parseJobs) + ( long "jobs" + <> short 'j' + <> metavar "JOBS" + <> help + "Run at most JOBS module checkers and Vampire invocations." + ) + where + parseJobs raw = + case readMaybe raw >>= Provers.effectiveJobs of + Just jobs -> Right jobs + Nothing -> Left "JOBS must be a positive integer" diff --git a/source/Felix/Math/Codec.hs b/source/Felix/Math/Codec.hs index 4a5c7b1..a551f53 100644 --- a/source/Felix/Math/Codec.hs +++ b/source/Felix/Math/Codec.hs @@ -24,7 +24,7 @@ module Felix.Math.Codec ) where import Base hiding (Empty) -import Checking.Core +import Felix.Checking.Core import Control.DeepSeq (NFData) import Crypto.Hash qualified as Crypto diff --git a/source/Meaning.hs b/source/Felix/Meaning.hs index 04979ce..268a1a6 100644 --- a/source/Meaning.hs +++ b/source/Felix/Meaning.hs @@ -5,16 +5,16 @@ {-# LANGUAGE TupleSections #-} -module Meaning where +module Felix.Meaning where import Base -import Syntax.Abstract (Sign(..)) -import Syntax.Abstract qualified as Raw -import Syntax.Internal (VarSymbol(..), pattern FreshVar) -import Syntax.Internal qualified as Sem -import Syntax.LexicalPhrase (unsafeReadPhrase) -import Report.Location +import Felix.Syntax.Abstract (Sign(..)) +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal (VarSymbol(..), pattern FreshVar) +import Felix.Syntax.Internal qualified as Sem +import Felix.Syntax.LexicalPhrase (unsafeReadPhrase) +import Felix.Report.Location import Bound import Control.Monad.Except @@ -503,9 +503,7 @@ glossExpr = \case pure ((binder, domain') : laterBounds') Raw.ExprFiniteSet loc es -> do es' <- glossExpr `each` es - pure (foldr cons (Sem.EmptySet loc) es') - where - cons x y = Sem.TermSymbol loc (Sem.SymbolMixfix Raw.ConsSymbol) [x, y] + pure (Sem.finiteSet loc es') glossFormula :: Raw.Formula -> Gloss (Sem.ExprOf VarSymbol) diff --git a/source/Felix/Output/Atomic.hs b/source/Felix/Output/Atomic.hs new file mode 100644 index 0000000..39ea9c8 --- /dev/null +++ b/source/Felix/Output/Atomic.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Sibling-temporary replacement for generated byte artifacts. +module Felix.Output.Atomic (writeBytesAtomically) where + +import Base + +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix + +writeBytesAtomically :: FilePath -> ByteString -> IO () +writeBytesAtomically destination bytes = do + let directory = Posix.takeDirectory destination + template = Posix.takeFileName destination <> ".tmp" + bracketOnError + (openBinaryTempFileWithDefaultPermissions directory template) + cleanupTemporary + \(temporary, handle) -> do + ByteString.hPut handle bytes + hFlush handle + hClose handle + Directory.renameFile temporary destination + +cleanupTemporary :: (FilePath, Handle) -> IO () +cleanupTemporary (temporary, handle) = do + void (tryIOError (hClose handle)) + void (tryIOError (Directory.removeFile temporary)) diff --git a/source/Felix/OutputPlan.hs b/source/Felix/OutputPlan.hs index 58314db..78d7e7a 100644 --- a/source/Felix/OutputPlan.hs +++ b/source/Felix/OutputPlan.hs @@ -18,7 +18,7 @@ module Felix.OutputPlan import Base import Felix.Source import Felix.Store -import Render.Html.Output qualified as Html +import Felix.Render.Html.Output qualified as Html import Control.Exception (displayException) import Data.List qualified as List diff --git a/source/Felix/Parse.hs b/source/Felix/Parse.hs index 751f09c..0a46d82 100644 --- a/source/Felix/Parse.hs +++ b/source/Felix/Parse.hs @@ -71,32 +71,14 @@ module Felix.Parse , parsedWorkspaceModules , parsedWorkspaceImportedBeforeImporter , importedBeforeImporterBlocks - , parseSourceWorkspace - , ParseMeasurements - , parseMeasurementResolutionNanoseconds - , parseMeasurementTokenizationNanoseconds - , parseMeasurementScanningNanoseconds - , parseMeasurementSyntaxInterfaceNanoseconds - , parseMeasurementParsingNanoseconds - , parseMeasurementParsedHitCount - , parseMeasurementParsedMissCount - , parseMeasurementParserTableMaterializationCount - , parseMeasurementModuleCount - , parseMeasurementImportOccurrenceCount - , parseMeasurementChunkCount - , parseMeasurementSourceByteCount - , parseMeasurementCandidateProbeCount - , parseMeasurementCanonicalizationCount - , parseMeasurementTargetInspectionCount - , parseSourceWorkspaceMeasured - , parseSourceWorkspaceMeasuredWithSyntaxInputs - , parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation - , parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs - , parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation - , parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback - , parseSourceWorkspaceWith + , parseSourceWorkspaceWithSyntaxInputs + , parseSourceWorkspaceWithSyntaxInputsAndGraphValidation + , parseSourceWorkspaceWithStoreAndSyntaxInputs + , parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation + , parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback , parseResolvedSourceGraph , parseResolvedSourceGraphWith + , parseResolvedSourceGraphWithStoreAndSyntaxInputsAndGraphValidation ) where import Base @@ -108,9 +90,9 @@ import Felix.Source import Felix.Source.Content qualified as Content import Felix.Source.Graph import Felix.Store qualified as Store -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Adapt +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt ( LexicalScanError(..) , ScannedLexicalItem , SyntaxMaterializationError(..) @@ -119,11 +101,11 @@ import Syntax.Adapt , scanChunk , scannedItemMarker ) -import Syntax.Concrete (grammar) -import Syntax.Interface -import Syntax.Lexicon (Lexicon) -import Syntax.Pragma -import Syntax.Token +import Felix.Syntax.Concrete (grammar) +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon (Lexicon) +import Felix.Syntax.Pragma +import Felix.Syntax.Token import Control.DeepSeq (NFData, force) import Control.Exception (Exception, evaluate) @@ -1096,154 +1078,88 @@ data ModuleSyntaxContext = ModuleSyntaxContext , syntaxContextImportedEntries :: !SyntaxEntryInventory } --- | Invocation-local parser work. A module is one strictly read source file. -data ParseMeasurements = ParseMeasurements - { parseMeasurementResolutionNanoseconds :: !Word64 - , parseMeasurementTokenizationNanoseconds :: !Word64 - , parseMeasurementScanningNanoseconds :: !Word64 - , parseMeasurementSyntaxInterfaceNanoseconds :: !Word64 - , parseMeasurementParsingNanoseconds :: !Word64 - , parseMeasurementParsedHitCount :: !Int - , parseMeasurementParsedMissCount :: !Int - , parseMeasurementParserTableMaterializationCount :: !Int - , parseMeasurementModuleCount :: !Int - , parseMeasurementImportOccurrenceCount :: !Int - , parseMeasurementChunkCount :: !Int - , parseMeasurementSourceByteCount :: !Word64 - , parseMeasurementCandidateProbeCount :: !Int - , parseMeasurementCanonicalizationCount :: !Int - , parseMeasurementTargetInspectionCount :: !Int - } - deriving stock (Show, Eq) - --- | Resolve, strictly load, and parse one source closure without callbacks. --- --- Mounts and the root request are explicit. Resolution, loading, and location --- registration perform filesystem and process-local registry I/O. This entry --- point does not initialize checking, provers, logging, or rendering. -parseSourceWorkspace - :: SourceMounts - -> RootRequest - -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) -parseSourceWorkspace mounts request = - parseSourceWorkspaceWith mounts request (\_source _block -> pure ()) - -parseSourceWorkspaceMeasured - :: SourceMounts - -> RootRequest - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasured mounts request = - parseSourceWorkspaceMeasuredWithSyntaxInputsAndCallback - mounts - request - (const []) - (\_source _block -> pure ()) - -parseSourceWorkspaceMeasuredWithSyntaxInputs +parseSourceWorkspaceWithSyntaxInputs :: SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) + -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) -- Implicit syntax inputs must be self-contained module interfaces. -parseSourceWorkspaceMeasuredWithSyntaxInputs mounts request syntaxInputs = - parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation +parseSourceWorkspaceWithSyntaxInputs mounts request syntaxInputs = + parseSourceWorkspaceWithSyntaxInputsAndGraphValidation mounts request syntaxInputs (const (Right ())) -parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation +parseSourceWorkspaceWithSyntaxInputsAndGraphValidation :: SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSourceGraph -> Either SourceError ()) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation + -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) +parseSourceWorkspaceWithSyntaxInputsAndGraphValidation mounts request syntaxInputs validateGraph = - parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback + parseSourceWorkspaceWithSyntaxInputsAndGraphValidationAndCallback mounts request syntaxInputs validateGraph (\_source _block -> pure ()) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs +parseSourceWorkspaceWithStoreAndSyntaxInputs :: Store.Store -> SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) - -> IO - (Either - ParseExecutionError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseSourceWorkspaceWithStoreAndSyntaxInputs store mounts request syntaxInputs = - parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation + parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation store mounts request syntaxInputs (const (Right ())) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation +parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation :: Store.Store -> SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSourceGraph -> Either SourceError ()) - -> IO - (Either - ParseExecutionError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation store mounts request syntaxInputs validateGraph = - parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback + parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidationAndCallback store mounts request syntaxInputs validateGraph (\_source _block -> pure ()) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback +parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback :: Store.Store -> SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseExecutionError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback store mounts request syntaxInputs emitBlock = do - parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback + parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidationAndCallback store mounts request syntaxInputs (const (Right ())) emitBlock -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback +parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidationAndCallback :: Store.Store -> SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSourceGraph -> Either SourceError ()) -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseExecutionError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidationAndCallback store mounts request syntaxInputs validateGraph emitBlock = do - resolutionStart <- getMonotonicTimeNSec - graphResult <- buildResolvedSourceGraphMeasured mounts request - resolutionEnd <- getMonotonicTimeNSec + graphResult <- buildResolvedSourceGraph mounts request case graphResult of Left err -> pure (Left (ParseExecutionWorkspaceError (SourceWorkspaceError err))) - Right (graph, selectionMeasurements) -> + Right graph -> case validateGraph graph of Left err -> pure @@ -1251,108 +1167,34 @@ parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallbac (ParseExecutionWorkspaceError (SourceWorkspaceError err))) Right () -> - fmap - (fmap - (\(workspace, measurements) -> - ( workspace - , withResolutionMeasurements - measurements - (resolutionEnd - resolutionStart) - selectionMeasurements - ))) - (parseResolvedSourceGraphMeasuredWithArtifacts - (PersistentParsedArtifacts store) - graph - syntaxInputs - emitBlock) - --- | Resolve, strictly load, and parse one source closure with a block --- callback. --- --- The callback may perform arbitrary I/O. It runs in deterministic source and --- chunk order, and callbacks for earlier blocks may have completed when a --- later parse fails. Callback exceptions propagate to the caller. -parseSourceWorkspaceWith - :: SourceMounts - -> RootRequest - -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) -parseSourceWorkspaceWith mounts request emitBlock = do - fmap (fmap fst) - (parseSourceWorkspaceMeasuredWith - mounts - request - emitBlock) + parseResolvedSourceGraphWithArtifacts + (PersistentParsedArtifacts store) + graph + syntaxInputs + emitBlock -parseSourceWorkspaceMeasuredWith - :: SourceMounts - -> RootRequest - -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWith mounts request emitBlock = do - parseSourceWorkspaceMeasuredWithSyntaxInputsAndCallback - mounts - request - (const []) - emitBlock - -parseSourceWorkspaceMeasuredWithSyntaxInputsAndCallback - :: SourceMounts - -> RootRequest - -> (ResolvedSource -> [ModuleSyntaxInterface]) - -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithSyntaxInputsAndCallback - mounts request syntaxInputs emitBlock = do - parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback - mounts request syntaxInputs (const (Right ())) emitBlock - -parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback +parseSourceWorkspaceWithSyntaxInputsAndGraphValidationAndCallback :: SourceMounts -> RootRequest -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSourceGraph -> Either SourceError ()) -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback + -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) +parseSourceWorkspaceWithSyntaxInputsAndGraphValidationAndCallback mounts request syntaxInputs validateGraph emitBlock = do - resolutionStart <- getMonotonicTimeNSec - graphResult <- buildResolvedSourceGraphMeasured mounts request - resolutionEnd <- getMonotonicTimeNSec + graphResult <- buildResolvedSourceGraph mounts request case graphResult of Left err -> pure (Left (SourceWorkspaceError err)) - Right (graph, selectionMeasurements) -> + Right graph -> case validateGraph graph of Left err -> pure (Left (SourceWorkspaceError err)) Right () -> - fmap - (fmap - (\(workspace, measurements) -> - let - -- Resolution includes source loading and - -- import scanning for graph construction. - measured = - withResolutionMeasurements - measurements - (resolutionEnd - resolutionStart) - selectionMeasurements - in - (workspace, measured))) - (parseResolvedSourceGraphMeasuredWith - graph - syntaxInputs - emitBlock) + parseResolvedSourceGraphWithSyntaxInputs + graph + syntaxInputs + emitBlock parseResolvedSourceGraph :: ResolvedSourceGraph @@ -1372,23 +1214,40 @@ parseResolvedSourceGraphWith -> (ResolvedSource -> Raw.Block -> IO ()) -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) parseResolvedSourceGraphWith graph emitBlock = - fmap (fmap fst) - (parseResolvedSourceGraphMeasuredWith - graph - (const []) - emitBlock) + parseResolvedSourceGraphWithSyntaxInputs + graph + (const []) + emitBlock -parseResolvedSourceGraphMeasuredWith +parseResolvedSourceGraphWithStoreAndSyntaxInputsAndGraphValidation + :: Store.Store + -> ResolvedSourceGraph + -> (ResolvedSource -> [ModuleSyntaxInterface]) + -> (ResolvedSourceGraph -> Either SourceError ()) + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseResolvedSourceGraphWithStoreAndSyntaxInputsAndGraphValidation + store graph syntaxInputs validateGraph = + case validateGraph graph of + Left err -> + pure + (Left + (ParseExecutionWorkspaceError + (SourceWorkspaceError err))) + Right () -> + parseResolvedSourceGraphWithArtifacts + (PersistentParsedArtifacts store) + graph + syntaxInputs + (\_source _block -> pure ()) + +parseResolvedSourceGraphWithSyntaxInputs :: ResolvedSourceGraph -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseWorkspaceError - (ParsedSourceWorkspace, ParseMeasurements)) -parseResolvedSourceGraphMeasuredWith graph syntaxInputs emitBlock = + -> IO (Either ParseWorkspaceError ParsedSourceWorkspace) +parseResolvedSourceGraphWithSyntaxInputs graph syntaxInputs emitBlock = fmap unwrapUncachedExecution - (parseResolvedSourceGraphMeasuredWithArtifacts + (parseResolvedSourceGraphWithArtifacts UncachedParsedArtifacts graph syntaxInputs @@ -1411,16 +1270,13 @@ unwrapUncachedExecution = \case Right value -> Right value -parseResolvedSourceGraphMeasuredWithArtifacts +parseResolvedSourceGraphWithArtifacts :: ParsedArtifactAccess -> ResolvedSourceGraph -> (ResolvedSource -> [ModuleSyntaxInterface]) -> (ResolvedSource -> Raw.Block -> IO ()) - -> IO - (Either - ParseExecutionError - (ParsedSourceWorkspace, ParseMeasurements)) -parseResolvedSourceGraphMeasuredWithArtifacts + -> IO (Either ParseExecutionError ParsedSourceWorkspace) +parseResolvedSourceGraphWithArtifacts artifactAccess graph syntaxInputs emitBlock = runExceptT do let orderedNodes = @@ -1449,61 +1305,17 @@ parseResolvedSourceGraphMeasuredWithArtifacts (SourceWorkspaceError (SourceGraphInvariantViolation "source graph produced no parsed modules"))) - let measurements = - ParseMeasurements - { parseMeasurementResolutionNanoseconds = - 0 - , parseMeasurementTokenizationNanoseconds = - moduleParseTokenizationNanoseconds completed - , parseMeasurementScanningNanoseconds = - moduleParseScanningNanoseconds completed - , parseMeasurementSyntaxInterfaceNanoseconds = - moduleParseSyntaxNanoseconds completed - , parseMeasurementParsingNanoseconds = - moduleParseParsingNanoseconds completed - , parseMeasurementParsedHitCount = - moduleParseHitCount completed - , parseMeasurementParsedMissCount = - moduleParseMissCount completed - , parseMeasurementParserTableMaterializationCount = - moduleParseParserTableCount completed - , parseMeasurementModuleCount = - NonEmpty.length orderedNodes - , parseMeasurementImportOccurrenceCount = - length (sourceGraphImportEdges graph) - , parseMeasurementChunkCount = - moduleParseChunkCount completed - , parseMeasurementSourceByteCount = - sum - (loadedByteCount - . sourceNodeLoaded - <$> NonEmpty.toList orderedNodes) - , parseMeasurementCandidateProbeCount = 0 - , parseMeasurementCanonicalizationCount = 0 - , parseMeasurementTargetInspectionCount = 0 - } - pure - ( ParsedSourceWorkspace parsedModules - , measurements - ) + pure (ParsedSourceWorkspace parsedModules) data ModuleParseState = ModuleParseState { moduleParsePrepared :: !(Map ResolvedSourceAddress PreparedSyntaxModule) , moduleParseReversed :: ![ParsedModule] - , moduleParseTokenizationNanoseconds :: !Word64 - , moduleParseScanningNanoseconds :: !Word64 - , moduleParseSyntaxNanoseconds :: !Word64 - , moduleParseParsingNanoseconds :: !Word64 - , moduleParseChunkCount :: !Int - , moduleParseHitCount :: !Int - , moduleParseMissCount :: !Int - , moduleParseParserTableCount :: !Int } emptyModuleParseState :: ModuleParseState emptyModuleParseState = - ModuleParseState Map.empty [] 0 0 0 0 0 0 0 0 + ModuleParseState Map.empty [] parseOneModule :: ParsedArtifactAccess @@ -1568,25 +1380,17 @@ parseAndPublishFreshModule -> ExceptT ParseExecutionError IO ModuleParseState parseAndPublishFreshModule artifactAccess emitBlock moduleIndex node imports context expectedKey state = do - tokenizationStart <- liftIO getMonotonicTimeNSec tokenized <- withExceptT ParseExecutionWorkspaceError (ExceptT (tokenizeModule node imports)) - tokenizationEnd <- liftIO getMonotonicTimeNSec - scanningStart <- liftIO getMonotonicTimeNSec scanned <- withExceptT ParseExecutionWorkspaceError (scanTokenizedModule tokenized) - scanningEnd <- liftIO getMonotonicTimeNSec - syntaxStart <- liftIO getMonotonicTimeNSec runtime <- liftWorkspaceEither (prepareFreshRuntimeSyntaxModule moduleIndex context scanned) - syntaxEnd <- liftIO getMonotonicTimeNSec - parsingStart <- liftIO getMonotonicTimeNSec parsed <- withExceptT ParseExecutionWorkspaceError (parseScannedModule emitBlock runtime scanned) - parsingEnd <- liftIO getMonotonicTimeNSec unless (parsedModuleKey parsed == expectedKey) (throwE @@ -1635,25 +1439,6 @@ parseAndPublishFreshModule artifactAccess emitBlock moduleIndex node imports Map.insert address prepared (moduleParsePrepared state) , moduleParseReversed = parsed : moduleParseReversed state - , moduleParseTokenizationNanoseconds = - moduleParseTokenizationNanoseconds state - + tokenizationEnd - tokenizationStart - , moduleParseScanningNanoseconds = - moduleParseScanningNanoseconds state - + scanningEnd - scanningStart - , moduleParseSyntaxNanoseconds = - moduleParseSyntaxNanoseconds state - + syntaxEnd - syntaxStart - , moduleParseParsingNanoseconds = - moduleParseParsingNanoseconds state - + parsingEnd - parsingStart - , moduleParseChunkCount = - moduleParseChunkCount state - + tokenizedModuleChunkCount tokenized - , moduleParseMissCount = - moduleParseMissCount state + 1 - , moduleParseParserTableCount = - moduleParseParserTableCount state + 1 } liftWorkspaceEither @@ -1674,7 +1459,6 @@ installCachedModule -> ExceptT ParseExecutionError IO ModuleParseState installCachedModule emitBlock moduleIndex node imports context key artifact state = do - syntaxStart <- liftIO getMonotonicTimeNSec let source = sourceNodeResolved node loaded = sourceNodeLoaded node payload = Parsed.parsedArtifactPayload artifact @@ -1726,7 +1510,6 @@ installCachedModule emitBlock moduleIndex node imports context key artifact (Parsed.parsedArtifactId artifact) parsed = ParsedModule loaded imports identified forced <- liftIO (evaluate (force parsed)) - syntaxEnd <- liftIO getMonotonicTimeNSec liftIO (forM_ (parsedModuleBlocks forced) @@ -1745,14 +1528,6 @@ installCachedModule emitBlock moduleIndex node imports context key artifact Map.insert address prepared (moduleParsePrepared state) , moduleParseReversed = forced : moduleParseReversed state - , moduleParseSyntaxNanoseconds = - moduleParseSyntaxNanoseconds state - + syntaxEnd - syntaxStart - , moduleParseChunkCount = - moduleParseChunkCount state - + length (Parsed.decodedParsedBlocks decoded) - , moduleParseHitCount = - moduleParseHitCount state + 1 } throwIntegrity @@ -1933,33 +1708,6 @@ classifyCachedSyntaxItem importedEntries importedIndex site entry = _ -> Right (EmitSyntaxEntry entry) -withResolutionMeasurements - :: ParseMeasurements - -> Word64 - -> SourceSelectionMeasurements - -> ParseMeasurements -withResolutionMeasurements - measurements - resolution - selectionMeasurements = - measurements - { parseMeasurementResolutionNanoseconds = - resolution - , parseMeasurementCandidateProbeCount = - sourceSelectionCandidateProbeCount selectionMeasurements - , parseMeasurementCanonicalizationCount = - sourceSelectionCanonicalizationCount - selectionMeasurements - , parseMeasurementTargetInspectionCount = - sourceSelectionTargetInspectionCount - selectionMeasurements - } - -tokenizedModuleChunkCount :: TokenizedModule -> Int -tokenizedModuleChunkCount - (TokenizedModule _node _imports _pragmas chunks) = - length chunks - tokenizeModule :: SourceNode -> [ParsedModuleImport] diff --git a/source/Felix/Parsed/Identity.hs b/source/Felix/Parsed/Identity.hs index e11b2c7..b76c26e 100644 --- a/source/Felix/Parsed/Identity.hs +++ b/source/Felix/Parsed/Identity.hs @@ -20,7 +20,7 @@ module Felix.Parsed.Identity import Base import Felix.Cache.Codec import Felix.Source.Content -import Syntax.Interface +import Felix.Syntax.Interface import Control.DeepSeq (NFData) import Data.ByteString (ByteString) diff --git a/source/Felix/Parsed/Payload.hs b/source/Felix/Parsed/Payload.hs index 2506973..5e63c70 100644 --- a/source/Felix/Parsed/Payload.hs +++ b/source/Felix/Parsed/Payload.hs @@ -30,11 +30,11 @@ import Base import Felix.Cache.Codec import Felix.Parsed.Identity qualified as Identity import Felix.Source -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface -import Syntax.LexicalPhrase qualified as Phrase -import Syntax.Token qualified as Token +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface +import Felix.Syntax.LexicalPhrase qualified as Phrase +import Felix.Syntax.Token qualified as Token import Control.DeepSeq (NFData) import Control.Monad (unless) diff --git a/source/Felix/Prelude.hs b/source/Felix/Prelude.hs index 28ad961..ccd5623 100644 --- a/source/Felix/Prelude.hs +++ b/source/Felix/Prelude.hs @@ -30,10 +30,10 @@ import Felix.Parse import Felix.Parsed.Identity qualified as Parsed import Felix.Source import Felix.Source.Graph -import Report.Location -import Syntax.Adapt (SyntaxMaterializationError) -import Syntax.Interface -import Syntax.Pragma +import Felix.Report.Location +import Felix.Syntax.Adapt (SyntaxMaterializationError) +import Felix.Syntax.Interface +import Felix.Syntax.Pragma import Control.Exception (IOException, displayException, try) import Data.ByteString (ByteString) diff --git a/source/Provers.hs b/source/Felix/Provers.hs index 7a22e12..16ef655 100644 --- a/source/Provers.hs +++ b/source/Felix/Provers.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Provers +module Felix.Provers ( Vampire , vampire , VampireTaskMode(..) @@ -45,7 +45,6 @@ module Provers , EffectiveJobs , effectiveJobs , effectiveJobsValue - , JobsSelection(..) , selectEffectiveJobs , WorkPosition , workPosition @@ -53,26 +52,36 @@ module Provers , workPositionLocalRequestOrdinal , VampireExecutor , VampireExecutorFault - , VampireExecutorObservation(..) , VampireRequestOwner , VampireHandle , VampireTerminal(..) , renderVampireTerminalDiagnostic - , VampireCompletion(..) + , VampireCompletion + , vampireCompletionRequestId + , vampireCompletionTerminal + , AtpDuration + , atpDurationNanoseconds + , atpDurationFromNanoseconds + , SlowAtpOutcome(..) + , SlowAtpTask(..) + , SlowAtpReport(..) + , slowAtpOmittedTaskCount + , slowAtpReportFromTasks , withVampireExecutor + , withVampireExecutorUsingClock , withVampireRequestOwner , submitVampireRequest , awaitVampireRequest , awaitPreparedVampireRequest , cancelVampireRequest , runPreparedTypedProverWithExecutor - , vampireExecutorObservation + , vampireExecutorSlowAtpReport ) where import Base -import Checking.Authority qualified as Authority -import Checking.Backend.Problem -import Checking.Backend.Tptp +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem +import Felix.Checking.Backend.Tptp import Control.Concurrent.STM ( STM @@ -105,7 +114,6 @@ import Control.Exception ) import Control.Exception qualified as Exception import Control.Monad (replicateM, unless, when) -import Control.Monad.Logger import Data.ByteString qualified as ByteString import Data.IntMap.Strict qualified as IntMap import Data.IORef @@ -116,11 +124,13 @@ import Data.IORef , writeIORef ) import Data.Set qualified as Set +import Data.Map.Strict qualified as Map +import Data.Ord (Down(..)) import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding import Data.Text.Encoding.Error qualified as TextEncodingError -import Data.Time import Numeric.Natural (Natural) +import Felix.Report.Location (Location) import System.Exit (ExitCode(..)) import System.Posix.Signals (sigKILL, signalProcessGroup) import System.Posix.Types (ProcessGroupID) @@ -136,7 +146,6 @@ import System.Process import System.Timeout qualified as Timeout import Text.Megaparsec import Text.Megaparsec.Char qualified as Char -import TextBuilder import UnliftIO.Async ( async , cancel @@ -186,30 +195,16 @@ effectiveJobs amount effectiveJobsValue :: EffectiveJobs -> Int effectiveJobsValue (EffectiveJobs amount) = amount --- | The effective worker policy selected for one invocation. Processor --- discovery is operational evidence only and enters no durable identity. -data JobsSelection = JobsSelection - { jobsSelectionDetectedProcessors :: !(Maybe Int) - , jobsSelectionEffectiveJobs :: !EffectiveJobs - , jobsSelectionWasOverridden :: !Bool - } - deriving (Show, Eq) - -- | Select the worker bound, with processor discovery injected for focused -- testing. Asynchronous cancellation is never mistaken for failed discovery. selectEffectiveJobs :: Maybe EffectiveJobs -> IO Int - -> IO JobsSelection + -> IO EffectiveJobs selectEffectiveJobs override detectProcessors = case override of Just selected -> - pure - JobsSelection - { jobsSelectionDetectedProcessors = Nothing - , jobsSelectionEffectiveJobs = selected - , jobsSelectionWasOverridden = True - } + pure selected Nothing -> do detectedResult <- Exception.try detectProcessors case detectedResult of @@ -225,22 +220,9 @@ selectEffectiveJobs override detectProcessors = -- Two portfolio workers plus one module pipeline -- nominally consume about three logical CPUs. automaticJobs = max 1 ((detected + 1) `div` 3) - in pure - JobsSelection - { jobsSelectionDetectedProcessors = - Just detected - , jobsSelectionEffectiveJobs = - EffectiveJobs automaticJobs - , jobsSelectionWasOverridden = False - } + in pure (EffectiveJobs automaticJobs) where - fallback = - pure - JobsSelection - { jobsSelectionDetectedProcessors = Nothing - , jobsSelectionEffectiveJobs = EffectiveJobs 1 - , jobsSelectionWasOverridden = False - } + fallback = pure (EffectiveJobs 1) -- | Stable runtime diagnostic position. It is deliberately separate from -- request, validation, cache, and mathematical identities. @@ -476,7 +458,6 @@ data PreparedTypedProverTask ref local origin global = PreparedTypedProverTask !(TypedProblem ref local origin global) !PreparedVerificationRequest - !Text prepareTypedProverTask :: (Ord local, Ord global) @@ -514,8 +495,7 @@ prepareTypedProverTask mode problem = do pure (PreparedTypedProverTask problem - preparedRequest - (preparedTypedTptpConjectureText prepared)) + preparedRequest) preparedTypedProverLogicalProblem :: PreparedTypedProverTask ref local origin global @@ -523,8 +503,7 @@ preparedTypedProverLogicalProblem preparedTypedProverLogicalProblem (PreparedTypedProverTask problem - _request - _conjecture) = + _request) = problem preparedTypedProverRequest @@ -533,8 +512,7 @@ preparedTypedProverRequest preparedTypedProverRequest (PreparedTypedProverTask _problem - request - _conjecture) = + request) = request data AcceptedVampireRun = AcceptedVampireRun @@ -648,10 +626,9 @@ captureChunkSize = 32 * 1024 runPreparedTypedProver - :: (MonadIO io, MonadLogger io) - => Vampire + :: Vampire -> PreparedTypedProverTask ref local origin global - -> io (Either ProverProcessError ProverAnswer) + -> IO (Either ProverProcessError ProverAnswer) runPreparedTypedProver vampireCommand = runPreparedTypedProverWithObserver @@ -659,47 +636,25 @@ runPreparedTypedProver vampireCommand runPreparedTypedProverWithObserver - :: (MonadIO io, MonadLogger io) - => (PreparedVerificationRequest -> IO ()) + :: (PreparedVerificationRequest -> IO ()) -> Vampire -> PreparedTypedProverTask ref local origin global - -> io (Either ProverProcessError ProverAnswer) + -> IO (Either ProverProcessError ProverAnswer) runPreparedTypedProverWithObserver observer vampireCommand (PreparedTypedProverTask _problem - preparedRequest - conjecture) = do - startTime <- liftIO getCurrentTime - terminal <- liftIO - (runPreparedVerificationTerminal - observer - vampireCommand - preparedRequest) - answer <- liftIO - (completionProverResult - preparedRequest - (VampireCompletion terminal)) - endTime <- liftIO getCurrentTime - let duration = - timeDifferenceToText - startTime - endTime - dialect = - case preparedVerificationDialect preparedRequest of - VerificationFof -> - "FOF" - VerificationTh0 -> - "TH0" - logInfoN - (duration - <> " " - <> conjecture - <> " [typed " - <> dialect - <> "]") - pure answer + preparedRequest) = do + terminal <- runPreparedVerificationTerminal + observer + vampireCommand + preparedRequest + completionProverResult + preparedRequest + (VampireCompletion + (preparedVerificationRequestId preparedRequest) + terminal) -- | Invocation-local bounded owner of Vampire subprocesses. The finite queue -- carries only immutable prepared bytes plus runtime diagnostic position; @@ -711,11 +666,13 @@ data VampireExecutor = VampireExecutor , executorCommand :: !Vampire , executorRequestObserver :: !(WorkPosition -> PreparedVerificationRequest -> IO ()) - , executorRuntime :: !(TVar VampireExecutorRuntime) + , executorMonotonicClock :: !(IO Word64) + , executorSlowAtpAccumulator :: !(TVar SlowAtpAccumulator) } data ExecutorJob = ExecutorJob { executorJobPosition :: !WorkPosition + , executorJobLocation :: !Location , executorJobRequest :: !PreparedVerificationRequest , executorJobCancelled :: !(TVar Bool) , executorJobStarted :: !(TVar Bool) @@ -749,26 +706,120 @@ data VampireRequestOwnerState data VampireHandle = VampireHandle { vampireHandleOrdinal :: !Int , vampireHandleOwner :: !VampireRequestOwner + , vampireHandleRequestId :: !Authority.PreparedRequestId , vampireHandleCancelled :: !(TVar Bool) , vampireHandleStarted :: !(TVar Bool) , vampireHandleCompletion :: !(TMVar VampireCompletion) } data VampireTerminal - = VampireAccepted !Authority.PreparedRequestId + = VampireAccepted | VampireRejected !CanonicalAtpRejection !BoundedDiagnostic | VampireProtocolFailed !BoundedDiagnostic | VampireProcessFailed !ProverProcessError | VampireCancelled deriving (Show, Eq) -newtype VampireCompletion = VampireCompletion - { vampireCompletionTerminal :: VampireTerminal } +data VampireCompletion = VampireCompletion + { vampireCompletionRequestId :: !Authority.PreparedRequestId + , vampireCompletionTerminal :: !VampireTerminal + } + deriving (Show, Eq) + +-- | Monotonic executor wall time in nanoseconds. +newtype AtpDuration = AtpDuration Word64 + deriving (Show, Eq, Ord) + +atpDurationNanoseconds :: AtpDuration -> Word64 +atpDurationNanoseconds (AtpDuration nanoseconds) = nanoseconds + +atpDurationFromNanoseconds :: Word64 -> AtpDuration +atpDurationFromNanoseconds = AtpDuration + +data SlowAtpOutcome + = SlowAtpAccepted + | SlowAtpRejected !CanonicalAtpRejection + | SlowAtpProtocolFailed + | SlowAtpProcessFailed deriving (Show, Eq) +data SlowAtpTask = SlowAtpTask + { slowAtpDuration :: !AtpDuration + , slowAtpOutcome :: !SlowAtpOutcome + , slowAtpPosition :: !WorkPosition + , slowAtpLocation :: !Location + , slowAtpRequestId :: !Authority.PreparedRequestId + } + deriving (Show, Eq) + +data SlowAtpReport = SlowAtpReport + { slowAtpQualifyingTaskCount :: !Int + , slowAtpTasks :: ![SlowAtpTask] + } + deriving (Show, Eq) + +slowAtpOmittedTaskCount :: SlowAtpReport -> Int +slowAtpOmittedTaskCount report = + slowAtpQualifyingTaskCount report - length (slowAtpTasks report) + +data SlowAtpRank = SlowAtpRank + !AtpDuration + !(Down WorkPosition) + deriving (Eq, Ord) + +data SlowAtpAccumulator = SlowAtpAccumulator + { slowAtpAccumulatorQualifyingTaskCount :: !Int + , slowAtpAccumulatorRetained :: !(Map.Map SlowAtpRank SlowAtpTask) + } + +slowAtpThreshold :: AtpDuration +slowAtpThreshold = AtpDuration 5000000000 + +slowAtpRetainedLimit :: Int +slowAtpRetainedLimit = 12 + +emptySlowAtpAccumulator :: SlowAtpAccumulator +emptySlowAtpAccumulator = SlowAtpAccumulator 0 Map.empty + +recordSlowAtpTask + :: SlowAtpTask + -> SlowAtpAccumulator + -> SlowAtpAccumulator +recordSlowAtpTask task accumulator + | slowAtpDuration task < slowAtpThreshold = accumulator + | otherwise = + accumulator + { slowAtpAccumulatorQualifyingTaskCount = + slowAtpAccumulatorQualifyingTaskCount accumulator + 1 + , slowAtpAccumulatorRetained = bounded + } + where + rank = SlowAtpRank + (slowAtpDuration task) + (Down (slowAtpPosition task)) + inserted = Map.insert rank task (slowAtpAccumulatorRetained accumulator) + bounded + | Map.size inserted > slowAtpRetainedLimit = Map.deleteMin inserted + | otherwise = inserted + +finalizeSlowAtpReport :: SlowAtpAccumulator -> SlowAtpReport +finalizeSlowAtpReport accumulator = + SlowAtpReport + { slowAtpQualifyingTaskCount = + slowAtpAccumulatorQualifyingTaskCount accumulator + , slowAtpTasks = + snd <$> Map.toDescList (slowAtpAccumulatorRetained accumulator) + } + +-- | Pure report construction used by policy tests and the executor. +slowAtpReportFromTasks :: [SlowAtpTask] -> SlowAtpReport +slowAtpReportFromTasks = + finalizeSlowAtpReport + . foldl' (flip recordSlowAtpTask) emptySlowAtpAccumulator + renderVampireTerminalDiagnostic :: VampireTerminal -> Maybe Text renderVampireTerminalDiagnostic = \case - VampireAccepted{} -> Nothing + VampireAccepted -> Nothing VampireRejected _rejection diagnostic -> Just (renderBoundedDiagnostic diagnostic) VampireProtocolFailed diagnostic -> @@ -777,30 +828,6 @@ renderVampireTerminalDiagnostic = \case Just (Text.pack (show processFailure)) VampireCancelled -> Nothing -data VampireExecutorRuntime = VampireExecutorRuntime - { runtimeSubmittedCount :: !Int - , runtimeRunCount :: !Int - , runtimeLiveCount :: !Int - , runtimeMaximumLiveCount :: !Int - , runtimeFirstStartNanoseconds :: !(Maybe Word64) - , runtimeFinalSubmissionNanoseconds :: !(Maybe Word64) - , runtimeFinalCompletionNanoseconds :: !(Maybe Word64) - , runtimeExecutionNanoseconds :: !Word64 - , runtimeLongestExecutionNanoseconds :: !Word64 - } - -data VampireExecutorObservation = VampireExecutorObservation - { vampireExecutorSubmittedCount :: !Int - , vampireExecutorRunCount :: !Int - , vampireExecutorMaximumLiveCount :: !Int - , vampireExecutorFirstStartNanoseconds :: !(Maybe Word64) - , vampireExecutorFinalSubmissionNanoseconds :: !(Maybe Word64) - , vampireExecutorFinalCompletionNanoseconds :: !(Maybe Word64) - , vampireExecutorExecutionNanoseconds :: !Word64 - , vampireExecutorLongestExecutionNanoseconds :: !Word64 - } - deriving (Show, Eq) - data VampireExecutorClosed = VampireExecutorClosed deriving (Show) @@ -819,20 +846,6 @@ instance Show RequestObserverFailure where instance Exception.Exception RequestObserverFailure -initialVampireExecutorRuntime :: VampireExecutorRuntime -initialVampireExecutorRuntime = - VampireExecutorRuntime - { runtimeSubmittedCount = 0 - , runtimeRunCount = 0 - , runtimeLiveCount = 0 - , runtimeMaximumLiveCount = 0 - , runtimeFirstStartNanoseconds = Nothing - , runtimeFinalSubmissionNanoseconds = Nothing - , runtimeFinalCompletionNanoseconds = Nothing - , runtimeExecutionNanoseconds = 0 - , runtimeLongestExecutionNanoseconds = 0 - } - -- | Bracket exactly the selected number of workers. Cancelling the bracket -- cancels each worker; a worker owning a subprocess in turn terminates and -- reaps that process group through the ordinary supervisor boundary. @@ -843,6 +856,23 @@ withVampireExecutor -> (VampireExecutor -> IO value) -> IO value withVampireExecutor selected command observer action = + withVampireExecutorUsingClock + getMonotonicTimeNSec + selected + command + observer + action + +-- | Executor constructor with an injected monotonic clock for focused timing +-- policy tests. Production callers use 'withVampireExecutor'. +withVampireExecutorUsingClock + :: IO Word64 + -> EffectiveJobs + -> Vampire + -> (WorkPosition -> PreparedVerificationRequest -> IO ()) + -> (VampireExecutor -> IO value) + -> IO value +withVampireExecutorUsingClock clock selected command observer action = Exception.bracket acquire release (action . fst) where workerCount = effectiveJobsValue selected @@ -852,7 +882,7 @@ withVampireExecutor selected command observer action = (fromIntegral workerCount * 2) state <- newTVarIO ExecutorRunning nextHandle <- newTVarIO 0 - runtime <- newTVarIO initialVampireExecutorRuntime + slowTasks <- newTVarIO emptySlowAtpAccumulator let executor = VampireExecutor { executorQueue = queue @@ -860,7 +890,8 @@ withVampireExecutor selected command observer action = , executorNextHandle = nextHandle , executorCommand = command , executorRequestObserver = observer - , executorRuntime = runtime + , executorMonotonicClock = clock + , executorSlowAtpAccumulator = slowTasks } workers <- replicateM workerCount (async (superviseExecutorWorker executor)) @@ -907,68 +938,34 @@ withVampireRequestOwner executor = traverse_ deregisterVampireHandle handles runPreparedTypedProverWithExecutor - :: (MonadIO io, MonadLogger io) - => VampireRequestOwner + :: VampireRequestOwner -> WorkPosition + -> Location -> PreparedTypedProverTask ref local origin global - -> io (Either ProverProcessError ProverAnswer) + -> IO (Either ProverProcessError ProverAnswer) runPreparedTypedProverWithExecutor owner position + location (PreparedTypedProverTask _problem - preparedRequest - conjecture) = do - startTime <- liftIO getCurrentTime - answer <- liftIO do - handle <- submitVampireRequest owner position preparedRequest - completion <- - awaitVampireRequest handle - `Exception.onException` cancelVampireRequest handle - completionProverResult preparedRequest completion - endTime <- liftIO getCurrentTime - let dialect = - case preparedVerificationDialect preparedRequest of - VerificationFof -> "FOF" - VerificationTh0 -> "TH0" - logInfoN - (timeDifferenceToText startTime endTime - <> " " - <> conjecture - <> " [typed " - <> dialect - <> "]") - pure answer - -vampireExecutorObservation - :: VampireExecutor - -> IO VampireExecutorObservation -vampireExecutorObservation executor = do - runtime <- readTVarIO (executorRuntime executor) - pure - VampireExecutorObservation - { vampireExecutorSubmittedCount = runtimeSubmittedCount runtime - , vampireExecutorRunCount = runtimeRunCount runtime - , vampireExecutorMaximumLiveCount = - runtimeMaximumLiveCount runtime - , vampireExecutorFirstStartNanoseconds = - runtimeFirstStartNanoseconds runtime - , vampireExecutorFinalSubmissionNanoseconds = - runtimeFinalSubmissionNanoseconds runtime - , vampireExecutorFinalCompletionNanoseconds = - runtimeFinalCompletionNanoseconds runtime - , vampireExecutorExecutionNanoseconds = - runtimeExecutionNanoseconds runtime - , vampireExecutorLongestExecutionNanoseconds = - runtimeLongestExecutionNanoseconds runtime - } + preparedRequest) = do + handle <- submitVampireRequest owner position location preparedRequest + awaitPreparedVampireRequest preparedRequest handle + `Exception.onException` cancelVampireRequest handle + +vampireExecutorSlowAtpReport :: VampireExecutor -> IO SlowAtpReport +vampireExecutorSlowAtpReport executor = + finalizeSlowAtpReport + <$> readTVarIO (executorSlowAtpAccumulator executor) submitVampireRequest :: VampireRequestOwner -> WorkPosition + -> Location -> PreparedVerificationRequest -> IO VampireHandle -submitVampireRequest owner position request = do +submitVampireRequest owner position location request = do -- Force the compact queue payload before masked ownership acquisition. _ <- Exception.evaluate (preparedVerificationByteCount request) _ <- Exception.evaluate (preparedVerificationRequestId request) @@ -993,6 +990,8 @@ submitVampireRequest owner position request = do VampireHandle { vampireHandleOrdinal = ordinal , vampireHandleOwner = owner + , vampireHandleRequestId = + preparedVerificationRequestId request , vampireHandleCancelled = cancelled , vampireHandleStarted = started , vampireHandleCompletion = completion @@ -1000,6 +999,7 @@ submitVampireRequest owner position request = do job = ExecutorJob { executorJobPosition = position + , executorJobLocation = location , executorJobRequest = request , executorJobCancelled = cancelled , executorJobStarted = started @@ -1009,27 +1009,7 @@ submitVampireRequest owner position request = do writeTVar (requestOwnerState owner) (RequestOwnerOpen (IntMap.insert ordinal acquired owned)) - modifyTVar' - (executorRuntime executor) - (\runtime -> - runtime - { runtimeSubmittedCount = - runtimeSubmittedCount runtime + 1 - }) pure acquired - submitted <- getMonotonicTimeNSec - atomically - (modifyTVar' - (executorRuntime executor) - (\runtime -> - runtime - { runtimeFinalSubmissionNanoseconds = - Just - (maybe submitted - (max submitted) - (runtimeFinalSubmissionNanoseconds - runtime)) - })) pure handle awaitVampireRequest :: VampireHandle -> IO VampireCompletion @@ -1047,8 +1027,8 @@ awaitVampireRequest handle = Exception.mask \restore -> do pure completion -- | Await one already submitted request and recover the ordinary typed --- prover result. The supplied immutable request is checked against an --- accepting terminal before any caller may treat the result as evidence. +-- prover result. The supplied immutable request is checked against every +-- completion before any caller may interpret its terminal outcome. awaitPreparedVampireRequest :: PreparedVerificationRequest -> VampireHandle @@ -1064,19 +1044,18 @@ cancelVampireRequest handle = Exception.mask_ do signalVampireCancellation :: VampireHandle -> IO () signalVampireCancellation handle = do - let executor = requestOwnerExecutor (vampireHandleOwner handle) - completion = VampireCompletion VampireCancelled + let completion = + VampireCompletion + (vampireHandleRequestId handle) + VampireCancelled _ <- Exception.evaluate completion - published <- getMonotonicTimeNSec atomically do writeTVar (vampireHandleCancelled handle) True started <- readTVar (vampireHandleStarted handle) unless started (void (publishVampireTerminalSTM - executor (vampireHandleCompletion handle) - published completion)) awaitVampireCancellation :: VampireHandle -> IO () @@ -1192,14 +1171,16 @@ executeJob executor job = Left workerFailure -> Exception.throwIO workerFailure Right terminal -> publishVampireTerminal - executor + (preparedVerificationRequestId + (executorJobRequest job)) (executorJobCompletion job) terminal JobCancelled -> do cancel running void (waitCatch running) publishVampireTerminal - executor + (preparedVerificationRequestId + (executorJobRequest job)) (executorJobCompletion job) VampireCancelled JobExecutorStopped -> do @@ -1211,79 +1192,51 @@ timedExecutorRun -> ExecutorJob -> IO VampireTerminal timedExecutorRun executor job = Exception.mask \restore -> do - started <- getMonotonicTimeNSec - atomically - (modifyTVar' - (executorRuntime executor) - (\runtime -> - let live = runtimeLiveCount runtime + 1 - in runtime - { runtimeRunCount = runtimeRunCount runtime + 1 - , runtimeLiveCount = live - , runtimeMaximumLiveCount = - max live (runtimeMaximumLiveCount runtime) - , runtimeFirstStartNanoseconds = - runtimeFirstStartNanoseconds runtime <|> Just started - })) + started <- executorMonotonicClock executor terminal <- restore (runPreparedVerificationTerminal (executorRequestObserver executor (executorJobPosition job)) (executorCommand executor) (executorJobRequest job)) - `Exception.onException` finishExecutorRun executor started - finishExecutorRun executor started - pure terminal - -finishExecutorRun :: VampireExecutor -> Word64 -> IO () -finishExecutorRun executor started = do - finished <- getMonotonicTimeNSec - let elapsed = finished - started + finished <- executorMonotonicClock executor + let task = SlowAtpTask + { slowAtpDuration = AtpDuration (finished - started) + , slowAtpOutcome = slowAtpOutcomeFromTerminal terminal + , slowAtpPosition = executorJobPosition job + , slowAtpLocation = executorJobLocation job + , slowAtpRequestId = + preparedVerificationRequestId (executorJobRequest job) + } atomically (modifyTVar' - (executorRuntime executor) - (\runtime -> - runtime - { runtimeLiveCount = runtimeLiveCount runtime - 1 - , runtimeExecutionNanoseconds = - runtimeExecutionNanoseconds runtime + elapsed - , runtimeLongestExecutionNanoseconds = - max elapsed (runtimeLongestExecutionNanoseconds runtime) - })) + (executorSlowAtpAccumulator executor) + (recordSlowAtpTask task)) + pure terminal + +slowAtpOutcomeFromTerminal :: VampireTerminal -> SlowAtpOutcome +slowAtpOutcomeFromTerminal = \case + VampireAccepted -> SlowAtpAccepted + VampireRejected rejection _diagnostic -> SlowAtpRejected rejection + VampireProtocolFailed{} -> SlowAtpProtocolFailed + VampireProcessFailed{} -> SlowAtpProcessFailed + VampireCancelled -> + impossible "cancelled Vampire task was recorded as completed" publishVampireTerminal - :: VampireExecutor + :: Authority.PreparedRequestId -> TMVar VampireCompletion -> VampireTerminal -> IO () -publishVampireTerminal executor completionCell terminal = do - let completion = VampireCompletion terminal +publishVampireTerminal requestId completionCell terminal = do + let completion = VampireCompletion requestId terminal _ <- Exception.evaluate completion - published <- getMonotonicTimeNSec - void - (atomically - (publishVampireTerminalSTM - executor completionCell published completion)) + void (atomically (publishVampireTerminalSTM completionCell completion)) publishVampireTerminalSTM - :: VampireExecutor - -> TMVar VampireCompletion - -> Word64 + :: TMVar VampireCompletion -> VampireCompletion -> STM Bool -publishVampireTerminalSTM executor completionCell published completion = do - inserted <- tryPutTMVar completionCell completion - when inserted - (modifyTVar' - (executorRuntime executor) - (\runtime -> - runtime - { runtimeFinalCompletionNanoseconds = - Just - (maybe published - (max published) - (runtimeFinalCompletionNanoseconds runtime)) - })) - pure inserted +publishVampireTerminalSTM = tryPutTMVar runPreparedVerificationTerminal :: (PreparedVerificationRequest -> IO ()) @@ -1306,7 +1259,7 @@ runPreparedVerificationTerminal observer command request = do (Text.pack (show protocolFailure)) transcript) Right Proved -> - VampireAccepted (preparedVerificationRequestId request) + VampireAccepted Right Counterexample -> VampireRejected RejectedCounterexample @@ -1330,18 +1283,17 @@ completionProverResult :: PreparedVerificationRequest -> VampireCompletion -> IO (Either ProverProcessError ProverAnswer) -completionProverResult request completion = +completionProverResult request completion = do + unless (actualId == expectedId) + (Exception.throwIO + (VampireExecutorFault + "Vampire completion has the wrong request id")) case vampireCompletionTerminal completion of - VampireAccepted acceptedId - | acceptedId == preparedVerificationRequestId request -> - pure - (Right - (ProvedAnswer - (AcceptedVampireRun acceptedId))) - | otherwise -> - Exception.throwIO - (VampireExecutorFault - "accepted Vampire result has the wrong request id") + VampireAccepted -> + pure + (Right + (ProvedAnswer + (AcceptedVampireRun actualId))) VampireRejected rejection _diagnostic -> pure (Right @@ -1365,6 +1317,8 @@ completionProverResult request completion = (VampireExecutorFault "active admission encountered a cancelled Vampire request") where + expectedId = preparedVerificationRequestId request + actualId = vampireCompletionRequestId completion task = preparedVerificationText request runPreparedVampireProcessWithObserver @@ -1904,37 +1858,3 @@ vampireStatusParser = do (\character -> character /= ' ' && character /= '\t') _ <- takeRest pure (vampireStatusFromText status) - -nominalDiffTimeToText :: NominalDiffTime -> Text -nominalDiffTimeToText delta = - toText (nominalDiffTimeToTextBuilder delta) - -nominalDiffTimeToTextBuilder :: NominalDiffTime -> TextBuilder -nominalDiffTimeToTextBuilder delta = - case hours of - 0 -> - padded minutes - <> ":" - <> padded restSeconds - <> "." - <> padded restCentis - _ -> - padded hours - <> ":" - <> padded restMinutes - <> ":" - <> padded restSeconds - where - padded n = - if n < 10 - then char '0' <> decimal n - else decimal n - centiseconds = - truncate (100 * nominalDiffTimeToSeconds delta) :: Int - (seconds, restCentis) = divMod centiseconds 100 - (minutes, restSeconds) = divMod seconds 60 - (hours, restMinutes) = divMod minutes 60 - -timeDifferenceToText :: UTCTime -> UTCTime -> Text -timeDifferenceToText startTime endTime = - nominalDiffTimeToText (diffUTCTime endTime startTime) diff --git a/source/Render/Html.hs b/source/Felix/Render/Html.hs index c37a278..7081e52 100644 --- a/source/Render/Html.hs +++ b/source/Felix/Render/Html.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Render.Html +module Felix.Render.Html ( HtmlRenderIndex , HtmlPagePresentation , buildRenderIndex @@ -12,14 +12,14 @@ module Render.Html , supportScriptAssetContents ) where -import Syntax.Abstract +import Felix.Syntax.Abstract import Base import Felix.Source (ResolvedSource) import Lucid hiding (Term, for_) import Lucid.Base (makeAttributes) import Lucid.Math -import Render.Html.Context +import Felix.Render.Html.Context ( HtmlRenderContext , HtmlRenderContextError , htmlCurrentPageLabel @@ -29,7 +29,9 @@ import Render.Html.Context , htmlSourcePageHref , htmlSupportScriptHref ) -import Render.Html.Layout (renderUrlFragment) +import Felix.Render.Html.Layout (renderUrlFragment) +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Token (VariableDisplay(..), VariableSuffix(..), displayVariable, tokToText) import Control.Monad (unless, when) import Data.Char (digitToInt, isAlphaNum, isDigit, isSpace, toUpper) @@ -39,8 +41,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Lazy qualified as LazyText -import Report.Location (Location, pattern Nowhere) -import Syntax.Token (VariableDisplay(..), VariableSuffix(..), displayVariable, tokToText) + data HintCategory diff --git a/source/Render/Html/Context.hs b/source/Felix/Render/Html/Context.hs index 151edd5..469d986 100644 --- a/source/Render/Html/Context.hs +++ b/source/Felix/Render/Html/Context.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Browser-facing routing authority for one rendered HTML page. -module Render.Html.Context +module Felix.Render.Html.Context ( HtmlRenderEnvironment , htmlRenderEnvironment , HtmlRenderContext @@ -23,7 +23,7 @@ module Render.Html.Context import Base import Felix.Source -import Render.Html.Layout +import Felix.Render.Html.Layout import Control.Exception (Exception) import Data.Map.Strict qualified as Map diff --git a/source/Render/Html/Export.hs b/source/Felix/Render/Html/Export.hs index 8b62f7d..a3f0e39 100644 --- a/source/Render/Html/Export.hs +++ b/source/Felix/Render/Html/Export.hs @@ -3,28 +3,35 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Prepare a complete HTML export from retained parsed presentation. -module Render.Html.Export +module Felix.Render.Html.Export ( HtmlPresentation , htmlPresentationFromParsedWorkspace , HtmlExportError(..) , renderHtmlExportError , prepareHtmlExport + , prepareHtmlExportWithLayout + , prepareHtmlExportWithLayoutFromRendererRoots ) where import Base import Felix.Parse import Felix.Source -import Render.Html qualified as Html -import Render.Html.Context -import Render.Html.Layout -import Render.Html.Output -import Syntax.Abstract (Block) +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Render.Html.Output +import Felix.Syntax.Abstract (Block) -import Control.Exception (Exception) +import Control.Exception (Exception, IOException, displayException) +import Control.Exception qualified as Exception import Data.Bifunctor (first) import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding +import Data.Text.Encoding.Error (UnicodeException) +import Data.Text.IO qualified as TextIO +import System.Directory (doesFileExist) +import System.FilePath.Posix ((</>)) -- | The strict, invocation-local subset of parsed presentation needed by the @@ -123,6 +130,80 @@ prepareHtmlExport sourceOf (HtmlSourcePresentation source _blocks) = source +prepareHtmlExportWithLayout + :: HtmlLayout + -> HtmlPresentation + -> Text + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareHtmlExportWithLayout + layout + (HtmlPresentation presentation) + hints = + prepareRenderedExport hints layout presentation + +prepareHtmlExportWithLayoutFromRendererRoots + :: [FilePath] + -> HtmlLayout + -> HtmlPresentation + -> IO (Either HtmlExportError [PreparedHtmlArtifact]) +prepareHtmlExportWithLayoutFromRendererRoots roots layout presentation = do + hintsResult <- findAndReadRendererFile roots "lexicon.tsv" + pure do + hints <- hintsResult + prepareHtmlExportWithLayout layout presentation hints + +-- Renderer data follows the established current-directory, +-- configured-library, and debug-directory lookup policy. +findAndReadRendererFile + :: [FilePath] + -> FilePath + -> IO (Either HtmlExportError Text) +findAndReadRendererFile roots path = + selectRendererData path ((</> path) <$> roots) >>= \case + Left failure -> pure (Left failure) + Right selectedPath -> do + readResult <- tryRendererRead (TextIO.readFile selectedPath) + pure case readResult of + Left reason -> + Left (HtmlRendererDataReadFailed selectedPath reason) + Right contents -> Right contents + +selectRendererData + :: FilePath + -> [FilePath] + -> IO (Either HtmlExportError FilePath) +selectRendererData requested candidates = go candidates + where + go = \case + [] -> pure (Left (HtmlRendererDataNotFound requested candidates)) + candidate : remaining -> + tryRendererIO (doesFileExist candidate) >>= \case + Left failure -> + pure + (Left + (HtmlRendererDataLookupFailed + candidate + (Text.pack (displayException failure)))) + Right True -> pure (Right candidate) + Right False -> go remaining + +tryRendererIO :: IO value -> IO (Either IOException value) +tryRendererIO = Exception.try + +tryRendererRead :: IO value -> IO (Either Text value) +tryRendererRead action = + Exception.catch + (Exception.catch (Right <$> action) renderIOException) + renderUnicodeException + where + renderIOException :: IOException -> IO (Either Text value) + renderIOException = pure . Left . Text.pack . displayException + + renderUnicodeException + :: UnicodeException + -> IO (Either Text value) + renderUnicodeException = pure . Left . Text.pack . displayException + prepareRenderedExport :: Text -> HtmlLayout diff --git a/source/Render/Html/Layout.hs b/source/Felix/Render/Html/Layout.hs index c26b6b5..7e5bfcf 100644 --- a/source/Render/Html/Layout.hs +++ b/source/Felix/Render/Html/Layout.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | Pure browser and destination routing for a resolved source graph. -module Render.Html.Layout +module Felix.Render.Html.Layout ( UrlSegment , UrlSegmentError(..) , urlSegment diff --git a/source/Render/Html/Output.hs b/source/Felix/Render/Html/Output.hs index a8b4d93..8e36f97 100644 --- a/source/Render/Html/Output.hs +++ b/source/Felix/Render/Html/Output.hs @@ -8,7 +8,7 @@ -- accepted only when they resolve inside the canonical root. Final-target -- symlinks are rejected without following them; regular generated files may be -- replaced. This policy prevents stable-tree escapes, not TOCTOU attacks. -module Render.Html.Output +module Felix.Render.Html.Output ( PreparedHtmlArtifact , preparedHtmlArtifact , preparedHtmlArtifactDestination @@ -26,6 +26,7 @@ module Render.Html.Output ) where import Base +import Felix.Output.Atomic (writeBytesAtomically) import Felix.Source ( SafeRelativePath , safeRelativePathFilePath @@ -36,7 +37,6 @@ import Control.Exception qualified as Exception import Control.Monad (unless, when) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.ByteString (ByteString) -import Data.ByteString qualified as ByteString import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -330,16 +330,7 @@ stageAndReplace stageAndReplace destination bytes = do let directory = Posix.takeDirectory destination Directory.createDirectoryIfMissing True directory - bracketOnError - (openBinaryTempFileWithDefaultPermissions - directory - (Posix.takeFileName destination <> ".tmp")) - cleanupTemporary - \(temporary, handle) -> do - ByteString.hPut handle bytes - hFlush handle - hClose handle - Directory.renameFile temporary destination + writeBytesAtomically destination bytes publicationError :: [SafeRelativePath] @@ -354,11 +345,6 @@ publicationError committed failed err = Text.pack (displayException err) } -cleanupTemporary :: (FilePath, Handle) -> IO () -cleanupTemporary (temporary, handle) = do - void (tryIOError (hClose handle)) - void (tryIOError (Directory.removeFile temporary)) - tryIOException :: IO a -> IO (Either IOException a) tryIOException = Exception.try diff --git a/source/Report/Location.hs b/source/Felix/Report/Location.hs index 4495360..36b8997 100644 --- a/source/Report/Location.hs +++ b/source/Felix/Report/Location.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -module Report.Location where +module Felix.Report.Location where import Base import Text.Megaparsec.Pos (SourcePos (sourceColumn, sourceLine), unPos) diff --git a/source/Felix/RequestDump.hs b/source/Felix/RequestDump.hs new file mode 100644 index 0000000..312e1da --- /dev/null +++ b/source/Felix/RequestDump.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Exact prepared-request dump publication. +module Felix.RequestDump + ( DumpObservationError(..) + , prepareRequestObserver + , captureDumpFailure + , renderDumpObservationError + ) where + +import Base +import Felix.Output.Atomic (writeBytesAtomically) +import Felix.OutputPlan qualified as Output +import Felix.Verification + ( VerificationRequestObserver + , verificationRequestObserver + ) +import Felix.Provers + +import Control.Exception (displayException) +import Control.Exception qualified as Exception +import Data.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix + +data DumpObservationError + = DumpDirectoryCreationFailed !FilePath !Text + | DumpRequestWriteFailed !WorkPosition !FilePath !Text + deriving stock (Show, Eq) + +instance Exception.Exception DumpObservationError + +prepareRequestObserver + :: Maybe Output.DumpOutputPlan + -> IO (Either DumpObservationError VerificationRequestObserver) +prepareRequestObserver = \case + Nothing -> + pure + (Right + (verificationRequestObserver + (\_position _request -> pure ()))) + Just dumpPlan -> do + let root = Output.dumpOutputPath dumpPlan + created <- tryIOError + (Directory.createDirectoryIfMissing True root) + pure case created of + Left failure -> + Left + (DumpDirectoryCreationFailed + root + (Text.pack (displayException failure))) + Right () -> + Right (verificationRequestObserver (writeDumpRequest root)) + +writeDumpRequest + :: FilePath + -> WorkPosition + -> PreparedVerificationRequest + -> IO () +writeDumpRequest root position request = do + let destination = + root + Posix.</> ( show (workPositionModuleOrdinal position) + <> "-" + <> show (workPositionLocalRequestOrdinal position) + ) + Posix.<.> "p" + tryIOError + (writeBytesAtomically + destination + (preparedVerificationBytes request)) >>= \case + Left failure -> + Exception.throwIO + (DumpRequestWriteFailed + position + destination + (Text.pack (displayException failure))) + Right () -> pure () + +captureDumpFailure + :: IO value + -> IO (Either DumpObservationError value) +captureDumpFailure = Exception.try + +renderDumpObservationError :: DumpObservationError -> Text +renderDumpObservationError = \case + DumpDirectoryCreationFailed path message -> + "Could not create dump directory " + <> Text.pack (show path) + <> ": " + <> message + DumpRequestWriteFailed _position path message -> + "Could not write request dump " + <> Text.pack (show path) + <> ": " + <> message diff --git a/source/Felix/Source.hs b/source/Felix/Source.hs index 64a88cd..68d596c 100644 --- a/source/Felix/Source.hs +++ b/source/Felix/Source.hs @@ -54,9 +54,6 @@ module Felix.Source , attributeCanonicalSource , resolveRoot , resolveImport - , SourceSelectionMeasurements(..) - , resolveRootMeasured - , resolveImportMeasured , loadResolvedSource , resolveAndLoadRoot , resolveAndLoadImport @@ -83,7 +80,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Encoding -import Report.Location +import Felix.Report.Location ( Location , LocationRegistrationError(..) , locationToText @@ -816,55 +813,11 @@ resolveRoot :: SourceMounts -> RootRequest -> IO (Either SourceError ResolvedSource) -resolveRoot mounts request = - fmap fst <$> resolveRootMeasured mounts request - --- | High-level operations used to select successful searched sources. --- These are resolver operations, not operating-system syscall counts. -data SourceSelectionMeasurements = - SourceSelectionMeasurements - { sourceSelectionCandidateProbeCount :: !Int - , sourceSelectionCanonicalizationCount :: !Int - , sourceSelectionTargetInspectionCount :: !Int - } - deriving stock (Show, Eq) - -instance Semigroup SourceSelectionMeasurements where - left <> right = - SourceSelectionMeasurements - { sourceSelectionCandidateProbeCount = - sourceSelectionCandidateProbeCount left - + sourceSelectionCandidateProbeCount right - , sourceSelectionCanonicalizationCount = - sourceSelectionCanonicalizationCount left - + sourceSelectionCanonicalizationCount right - , sourceSelectionTargetInspectionCount = - sourceSelectionTargetInspectionCount left - + sourceSelectionTargetInspectionCount right - } - -instance Monoid SourceSelectionMeasurements where - mempty = - SourceSelectionMeasurements - { sourceSelectionCandidateProbeCount = 0 - , sourceSelectionCanonicalizationCount = 0 - , sourceSelectionTargetInspectionCount = 0 - } - -resolveRootMeasured - :: SourceMounts - -> RootRequest - -> IO - (Either - SourceError - (ResolvedSource, SourceSelectionMeasurements)) -resolveRootMeasured mounts = \case +resolveRoot mounts = \case SearchedRoot path -> - resolveSearchedMeasured mounts (SearchedRootLookup path) path + resolveSearched mounts (SearchedRootLookup path) path ExistingRoot canonical spelling -> - pure - ((\source -> (source, mempty)) - <$> attributeSelectedSource spelling mounts canonical) + pure (attributeSelectedSource spelling mounts canonical) resolveImport :: SourceMounts @@ -872,47 +825,31 @@ resolveImport -> ImportRef -> IO (Either SourceError ResolvedSource) resolveImport mounts importer reference = - fmap fst - <$> resolveImportMeasured mounts importer reference - -resolveImportMeasured - :: SourceMounts - -> ResolvedSource - -> ImportRef - -> IO - (Either - SourceError - (ResolvedSource, SourceSelectionMeasurements)) -resolveImportMeasured mounts importer reference = - resolveSearchedMeasured + resolveSearched mounts (ImportedSourceLookup importer reference) (importPath reference) -resolveSearchedMeasured +resolveSearched :: SourceMounts -> SourceLookup -> SafeRelativePath - -> IO - (Either - SourceError - (ResolvedSource, SourceSelectionMeasurements)) -resolveSearchedMeasured mounts lookupKind relative = - choose 0 (sourceCandidates mounts relative) + -> IO (Either SourceError ResolvedSource) +resolveSearched mounts lookupKind relative = + choose (sourceCandidates mounts relative) where candidates = sourceCandidates mounts relative - choose _probeCount [] = + choose [] = pure (Left (SourceNotFound lookupKind candidates)) - choose previousProbeCount (candidate : rest) = do + choose (candidate : rest) = do let path = sourceCandidatePath candidate - probeCount = previousProbeCount + 1 statusResult <- try (PosixFiles.getSymbolicLinkStatus path) :: IO (Either IOException PosixFiles.FileStatus) case statusResult of Left err | isDoesNotExistError err -> - choose probeCount rest + choose rest | otherwise -> pure (Left @@ -921,19 +858,7 @@ resolveSearchedMeasured mounts lookupKind relative = path (Text.pack (displayException err)))) Right _status -> - fmap - (\source -> - ( source - , SourceSelectionMeasurements - { sourceSelectionCandidateProbeCount = - probeCount - , sourceSelectionCanonicalizationCount = - 1 - , sourceSelectionTargetInspectionCount = - 1 - } - )) - <$> resolveCandidate mounts lookupKind candidate + resolveCandidate mounts lookupKind candidate resolveCandidate :: SourceMounts diff --git a/source/Felix/Source/Graph.hs b/source/Felix/Source/Graph.hs index 4697f77..9c8753d 100644 --- a/source/Felix/Source/Graph.hs +++ b/source/Felix/Source/Graph.hs @@ -21,16 +21,15 @@ module Felix.Source.Graph , sourceGraphImportEdges , sourceGraphImportedBeforeImporter , buildResolvedSourceGraph - , buildResolvedSourceGraphMeasured ) where import Base import Felix.Source -import Report.Location +import Felix.Report.Location ( FileId , registerFilePathWithDisplay ) -import Syntax.Token (Located(..), gatherImports) +import Felix.Syntax.Token (Located(..), gatherImports) import Control.Monad (unless) import Control.Monad.State.Strict @@ -132,41 +131,27 @@ data GraphBuildState = GraphBuildState { buildNodes :: !(Map CanonicalPath BuildNode) , buildEdgesReversed :: ![SourceImportEdge] , buildOrderReversed :: ![SourceNode] - , buildSelectionMeasurements :: !SourceSelectionMeasurements } type GraphBuilder = ExceptT SourceError (StateT GraphBuildState IO) -initialGraphBuildState - :: SourceSelectionMeasurements - -> GraphBuildState -initialGraphBuildState selectionMeasurements = GraphBuildState +initialGraphBuildState :: GraphBuildState +initialGraphBuildState = GraphBuildState { buildNodes = mempty , buildEdgesReversed = [] , buildOrderReversed = [] - , buildSelectionMeasurements = selectionMeasurements } buildResolvedSourceGraph :: SourceMounts -> RootRequest -> IO (Either SourceError ResolvedSourceGraph) -buildResolvedSourceGraph mounts request = - fmap fst <$> buildResolvedSourceGraphMeasured mounts request - -buildResolvedSourceGraphMeasured - :: SourceMounts - -> RootRequest - -> IO - (Either - SourceError - (ResolvedSourceGraph, SourceSelectionMeasurements)) -buildResolvedSourceGraphMeasured mounts request = do - resolvedRoot <- resolveRootMeasured mounts request +buildResolvedSourceGraph mounts request = do + resolvedRoot <- resolveRoot mounts request case resolvedRoot of Left err -> pure (Left err) - Right (rootSource, rootMeasurements) -> do + Right rootSource -> do loadedRoot <- loadResolvedSource rootSource case loadedRoot of Left err -> @@ -179,7 +164,7 @@ buildResolvedSourceGraphMeasured mounts request = do mounts (sourceNodeCanonicalPath rootNode) []) - (initialGraphBuildState rootMeasurements) + initialGraphBuildState pure case result of Left err -> Left err @@ -192,13 +177,11 @@ buildResolvedSourceGraphMeasured mounts request = do "source graph has no root node") Just order -> Right - ( ResolvedSourceGraph + (ResolvedSourceGraph order (reverse (buildEdgesReversed finalState)) - , buildSelectionMeasurements - finalState ) insertFreshNode :: LoadedSource -> GraphBuilder SourceNode @@ -307,15 +290,7 @@ visitImport visitImport mounts importerNode path reference = do let importer = sourceNodeResolved importerNode importerCanonical = sourceNodeCanonicalPath importerNode - (imported, selectionMeasurements) <- - liftEitherIO - (resolveImportMeasured mounts importer reference) - modify' \state -> - state - { buildSelectionMeasurements = - buildSelectionMeasurements state - <> selectionMeasurements - } + imported <- liftEitherIO (resolveImport mounts importer reference) let importedCanonical = resolvedSourceCanonicalPath imported existing <- gets (Map.lookup importedCanonical . buildNodes) case existing of diff --git a/source/Felix/Store.hs b/source/Felix/Store.hs index bf84f6e..fb12670 100644 --- a/source/Felix/Store.hs +++ b/source/Felix/Store.hs @@ -4,6 +4,7 @@ -- | Coordinator-owned access to the disposable SQLite store. module Felix.Store ( Store + , storeTheoryId , StoreSelection(..) , StorePlan , StorePath @@ -53,16 +54,16 @@ module Felix.Store ) where import Base -import Checking.Core -import Checking.Declaration qualified as Declaration -import Checking.Identity -import Checking.Materialization qualified as Materialization -import Checking.Semantic +import Felix.Checking.Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Identity +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic import Felix.Cache.Codec import Felix.Module (ModuleName) import Felix.Parsed.Identity qualified as Parsed import Felix.Parsed.Payload qualified as ParsedPayload -import Syntax.Interface qualified as Syntax +import Felix.Syntax.Interface qualified as Syntax import Control.Concurrent.MVar ( MVar @@ -92,6 +93,9 @@ data Store = Store !TheoryId !SQLite.Connection +storeTheoryId :: Store -> TheoryId +storeTheoryId (Store _path theory _connection) = theory + -- | The single invocation-local gateway for a store connection and its -- ordinary 'IORef'-backed validation memo. Module checkers may run in -- parallel, but every SQLite and memo operation remains coordinator-owned. diff --git a/source/Syntax/Abstract.hs b/source/Felix/Syntax/Abstract.hs index f589283..b18612a 100644 --- a/source/Syntax/Abstract.hs +++ b/source/Felix/Syntax/Abstract.hs @@ -9,17 +9,17 @@ -- | Data types for the abstract syntax tree and helper functions -- for constructing the lexicon. -- -module Syntax.Abstract - ( module Syntax.Abstract - , module Syntax.LexicalPhrase - , module Syntax.Token +module Felix.Syntax.Abstract + ( module Felix.Syntax.Abstract + , module Felix.Syntax.LexicalPhrase + , module Felix.Syntax.Token ) where import Base -import Syntax.LexicalPhrase (LexicalPhrase, SgPl(..), unsafeReadPhraseSgPl, unsafeReadPhrase) -import Syntax.Token (Token(..), Located(..)) -import Report.Location +import Felix.Syntax.LexicalPhrase (LexicalPhrase, SgPl(..), unsafeReadPhraseSgPl, unsafeReadPhrase) +import Felix.Syntax.Token (Token(..), Located(..)) +import Felix.Report.Location import Control.DeepSeq (NFData) import Text.Earley.Mixfix (Holey) @@ -168,7 +168,9 @@ pattern NeqSymbol = pattern SubseteqSymbol = RelationSymbol (Command "subseteq") (ParameterArity 0) "subseteq" --- | The predefined @cons@ function symbol used for desugaring finite set expressions. +-- | The ordinary source-level @cons@ function symbol. +-- +-- Finite-set notation is intrinsic and does not desugar through this symbol. pattern ConsSymbol :: FunctionSymbol pattern ConsSymbol = MixfixItem @@ -220,6 +222,17 @@ pattern UpairSymbol = "upair" NonAssoc +-- | The fixed family-union function symbol. +pattern UnionsSymbol :: FunctionSymbol +pattern UnionsSymbol = + MixfixItem + (TokenCons (Command "unions") + (TokenCons InvisibleBraceL + (HoleCons + (TokenCons InvisibleBraceR End)))) + "unions" + NonAssoc + -- | Function application /@f(x)@/ desugars to /@\apply{f}{x}@/. pattern ApplySymbol :: FunctionSymbol pattern ApplySymbol = diff --git a/source/Syntax/Adapt.hs b/source/Felix/Syntax/Adapt.hs index f496ead..eb0cb6c 100644 --- a/source/Syntax/Adapt.hs +++ b/source/Felix/Syntax/Adapt.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-} -module Syntax.Adapt +module Felix.Syntax.Adapt ( FunctionPatternError(..) , LexicalScanError(..) , ScannedLexicalItem(..) @@ -14,10 +14,10 @@ module Syntax.Adapt ) where import Base -import Syntax.Abstract -import Syntax.Interface -import Syntax.Lexicon -import Report.Location +import Felix.Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon +import Felix.Report.Location import Control.Monad (foldM) import Data.Bifunctor qualified as Bifunctor diff --git a/source/Syntax/Concrete.hs b/source/Felix/Syntax/Concrete.hs index a2eb2dc..8be8ab6 100644 --- a/source/Syntax/Concrete.hs +++ b/source/Felix/Syntax/Concrete.hs @@ -3,25 +3,25 @@ {-# LANGUAGE RecursiveDo #-} -- | Concrete syntax of the surface language. -module Syntax.Concrete where +module Felix.Syntax.Concrete where import Base -import Syntax.Abstract -import Syntax.Concrete.Keywords -import Syntax.Lexicon +import Felix.Syntax.Abstract +import Felix.Syntax.Concrete.Keywords +import Felix.Syntax.Lexicon ( Lexicon(..) , SignatureHeadForm(..) , concreteSignatureHeadForms , lexiconAdjs , splitOnVariableSlot ) -import Syntax.Token -import Report.Location +import Felix.Syntax.Token +import Felix.Report.Location import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Text.Earley (Grammar, Prod, (<?>), rule, satisfy, terminal) -import Syntax.Mixfix +import Felix.Syntax.Mixfix grammar :: Lexicon -> Grammar r (Prod r Text (Located Token) Block) @@ -382,7 +382,6 @@ grammar lexicon@Lexicon{..} = mdo defnFun <- rule $ DefnFun <$> asms <*> (optional _the *> funVar) <*> optional defnFunSymb <* _is <*> term <* _dot symbolicPatternEqTerm <- rule do - asms -- NB assumptions are currently ignored! pat <- beginMath *> symbolicPattern <* _eq e <- expr <* endMath <* _dot pure (pat, e) diff --git a/source/Syntax/Concrete/Keywords.hs b/source/Felix/Syntax/Concrete/Keywords.hs index a7ac169..eb6d09c 100644 --- a/source/Syntax/Concrete/Keywords.hs +++ b/source/Felix/Syntax/Concrete/Keywords.hs @@ -18,12 +18,12 @@ The names are chosen using the following criteria: This module also defines symbols that have special uses (such as @_colon@ for its use in type signatures). -} -module Syntax.Concrete.Keywords where +module Felix.Syntax.Concrete.Keywords where import Base -import Syntax.Token -import Report.Location +import Felix.Syntax.Token +import Felix.Report.Location import Text.Earley (Prod, (<?>), terminal) diff --git a/source/Syntax/Interface.hs b/source/Felix/Syntax/Interface.hs index 4b84cec..1820705 100644 --- a/source/Syntax/Interface.hs +++ b/source/Felix/Syntax/Interface.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Syntax.Interface +module Felix.Syntax.Interface ( MixfixLevel , mixfixLevel , mixfixLevelValue @@ -56,9 +56,9 @@ module Syntax.Interface import Base import Felix.Cache.Codec -import Syntax.Abstract -import Syntax.Lexicon -import Syntax.Pragma +import Felix.Syntax.Abstract +import Felix.Syntax.Lexicon +import Felix.Syntax.Pragma import Control.DeepSeq (NFData) import Control.Monad (unless) diff --git a/source/Syntax/Internal.hs b/source/Felix/Syntax/Internal.hs index d769afe..d129947 100644 --- a/source/Syntax/Internal.hs +++ b/source/Felix/Syntax/Internal.hs @@ -6,21 +6,25 @@ {-# LANGUAGE ViewPatterns #-} -- | Data types for the internal (semantic) syntax tree. -module Syntax.Internal - ( module Syntax.Internal - , module Syntax.Abstract - , module Syntax.LexicalPhrase - , module Syntax.Token +module Felix.Syntax.Internal + ( module Felix.Syntax.Internal + , module Felix.Syntax.Abstract + , module Felix.Syntax.LexicalPhrase + , module Felix.Syntax.Token ) where import Base -import Syntax.Lexicon (pattern PairSymbol, pattern ConsSymbol) -import Syntax.LexicalPhrase (unsafeReadPhrase, unsafeReadPhraseSgPl) -import Syntax.Token (Token(..)) -import Report.Location +import Felix.Syntax.Lexicon + ( pattern PairSymbol + , pattern UnionsSymbol + , pattern UpairSymbol + ) +import Felix.Syntax.LexicalPhrase (unsafeReadPhrase, unsafeReadPhraseSgPl) +import Felix.Syntax.Token (Token(..)) +import Felix.Report.Location -import Syntax.Abstract +import Felix.Syntax.Abstract ( Chain(..) , Associativity(..) , Connective(..) @@ -536,10 +540,21 @@ makeXor = \case [] -> Bottom es -> List.foldl1' Xor es -finiteSet :: NonEmpty (ExprOf a) -> ExprOf a -finiteSet = foldr cons (EmptySet Nowhere) +-- | Source-ordered HOTG finite-set adjunction. +-- +-- This deliberately uses only fixed operations. In particular, finite-set +-- notation is independent of the ordinary source-owned 'ConsSymbol'. +finiteSet :: Location -> NonEmpty (ExprOf a) -> ExprOf a +finiteSet location = foldr insert (EmptySet location) where - cons x y = TermSymbol Nowhere (SymbolMixfix ConsSymbol) [x, y] + insert element set = + TermSymbol location (SymbolMixfix UnionsSymbol) + [ TermSymbol location (SymbolMixfix UpairSymbol) + [ TermSymbol location (SymbolMixfix UpairSymbol) + [element, element] + , set + ] + ] isPositive :: ExprOf a -> Bool isPositive = \case diff --git a/source/Syntax/LexicalPhrase.hs b/source/Felix/Syntax/LexicalPhrase.hs index a0e0f19..5eb5b18 100644 --- a/source/Syntax/LexicalPhrase.hs +++ b/source/Felix/Syntax/LexicalPhrase.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NoImplicitPrelude #-} -module Syntax.LexicalPhrase where +module Felix.Syntax.LexicalPhrase where import Base -import Syntax.Token (Token(..)) +import Felix.Syntax.Token (Token(..)) import Control.DeepSeq (NFData) import Data.Char (isAlpha) diff --git a/source/Syntax/Lexicon.hs b/source/Felix/Syntax/Lexicon.hs index 7ee44ae..c3332c7 100644 --- a/source/Syntax/Lexicon.hs +++ b/source/Felix/Syntax/Lexicon.hs @@ -9,11 +9,12 @@ -- extension easier. -- -module Syntax.Lexicon - ( module Syntax.Lexicon +module Felix.Syntax.Lexicon + ( module Felix.Syntax.Lexicon , pattern ConsSymbol , pattern PairSymbol , pattern UpairSymbol + , pattern UnionsSymbol , pattern CarrierSymbol , pattern ApplySymbol , pattern DomSymbol @@ -21,14 +22,14 @@ module Syntax.Lexicon import Base -import Syntax.Abstract +import Felix.Syntax.Abstract import Data.List qualified as List import Data.Sequence qualified as Seq import Data.Set qualified as Set import Data.Map.Strict qualified as Map import Data.Text qualified as Text -import Syntax.Mixfix (Holey) +import Felix.Syntax.Mixfix (Holey) data SignatureHeadForm @@ -121,7 +122,7 @@ prefixOps :: [MixfixItem] prefixOps = [ mkMixfixItem [Just (Command "rfrac"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "rfrac" NonAssoc , mkMixfixItem [Just (Command "exp"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "exp" NonAssoc - , mkMixfixItem [Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "unions" NonAssoc + , UnionsSymbol , mkMixfixItem [Just (Command "cumul"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "cumul" NonAssoc , mkMixfixItem [Just (Command "fst"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "fst" NonAssoc , mkMixfixItem [Just (Command "snd"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] "snd" NonAssoc @@ -179,14 +180,22 @@ binOp' tok assoc = ([Nothing, Just tok, Nothing], assoc) builtinAdjRs :: [LexicalItem] builtinAdjRs = - [ mkLexicalItem (unsafeReadPhrase "equal to ?") "eq" + [ builtinEqualityRightAdjective ] +builtinEqualityRightAdjective :: LexicalItem +builtinEqualityRightAdjective = + mkLexicalItem (unsafeReadPhrase "equal to ?") "eq" + builtinVerbs :: [LexicalItemSgPl] builtinVerbs = - [ mkLexicalItemSgPl (unsafeReadPhraseSgPl "equal[s/] ?") "eq" + [ builtinEqualityVerb ] +builtinEqualityVerb :: LexicalItemSgPl +builtinEqualityVerb = + mkLexicalItemSgPl (unsafeReadPhraseSgPl "equal[s/] ?") "eq" + -- Some of these do/should correspond to mathlib structures, -- e.g.: lattice, complete lattice, ring, etc. diff --git a/source/Syntax/Mixfix.hs b/source/Felix/Syntax/Mixfix.hs index 6489d46..a3ce4bb 100644 --- a/source/Syntax/Mixfix.hs +++ b/source/Felix/Syntax/Mixfix.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecursiveDo #-} -module Syntax.Mixfix where +module Felix.Syntax.Mixfix where {- Original code Copyright (c) 2014-2019, Olle Fredriksson @@ -39,7 +39,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import Base import Text.Earley import Data.Either -import Syntax.Abstract +import Felix.Syntax.Abstract replicateA :: Applicative f => Int -> f a -> f [a] diff --git a/source/Syntax/Pragma.hs b/source/Felix/Syntax/Pragma.hs index 94c0d46..97d1482 100644 --- a/source/Syntax/Pragma.hs +++ b/source/Felix/Syntax/Pragma.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Syntax.Pragma +module Felix.Syntax.Pragma ( SourceMixfixLevel , sourceMixfixLevelValue , SyntaxPragma(..) @@ -14,8 +14,8 @@ module Syntax.Pragma import Base -import Report.Location -import Syntax.Abstract (Associativity(..)) +import Felix.Report.Location +import Felix.Syntax.Abstract (Associativity(..)) import Control.DeepSeq (NFData) import Control.Monad (unless, when) diff --git a/source/Syntax/Token.hs b/source/Felix/Syntax/Token.hs index b16379b..31d1d19 100644 --- a/source/Syntax/Token.hs +++ b/source/Felix/Syntax/Token.hs @@ -13,7 +13,7 @@ -- (α, β, γ, ..., 𝔸, 𝔹, ℂ, ...). Similarly, @\\begin{...}@ and @\\end{...}@ commands -- are each parsed as single tokens. -- -module Syntax.Token +module Felix.Syntax.Token ( Token(..) , VariableDisplay(..) , VariableSuffix(..) @@ -30,7 +30,7 @@ module Syntax.Token import Base hiding (many) -import Report.Location +import Felix.Report.Location import Control.DeepSeq (NFData) import Control.Monad.Combinators diff --git a/source/Test/All.hs b/source/Felix/Test/All.hs index 7fb5bd3..7cdc49c 100644 --- a/source/Test/All.hs +++ b/source/Felix/Test/All.hs @@ -1,9 +1,9 @@ -module Test.All where +module Felix.Test.All where import Base -import Test.Golden -import Test.Unit +import Felix.Test.Golden +import Felix.Test.Unit import Test.Tasty diff --git a/source/Test/Golden.hs b/source/Felix/Test/Golden.hs index e230c26..905ff73 100644 --- a/source/Test/Golden.hs +++ b/source/Felix/Test/Golden.hs @@ -1,11 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} -module Test.Golden where +module Felix.Test.Golden where -import Api qualified import Base +import Felix.Workspace qualified as Workspace import Data.Text.Lazy.IO qualified as LazyTextIO import System.Directory @@ -69,16 +69,18 @@ makeGoldenTest stage action = do tokenizing :: MonadUnliftIO io => io TestTree tokenizing = makeGoldenTest "tokenizing" $ \Triple{..} -> do - tokenStream <- Api.tokenize input - liftIO (LazyTextIO.writeFile output (pShowNoColor (Api.simpleStream tokenStream))) + tokenStream <- liftIO (Workspace.tokenize input) + liftIO + (LazyTextIO.writeFile output + (pShowNoColor (Workspace.simpleStream tokenStream))) scanning :: MonadUnliftIO io => io TestTree scanning = makeGoldenTest "scanning" $ \Triple{..} -> do - lexicalItems <- Api.scan input + lexicalItems <- liftIO (Workspace.scan input) liftIO (LazyTextIO.writeFile output (pShowNoColor lexicalItems)) parsing :: MonadUnliftIO io => io TestTree parsing = makeGoldenTest "parsing" $ \Triple{..} -> do - parseResult <- Api.parse input + parseResult <- liftIO (Workspace.parse input) liftIO (LazyTextIO.writeFile output (pShowNoColor parseResult)) diff --git a/source/Felix/Test/Unit.hs b/source/Felix/Test/Unit.hs new file mode 100644 index 0000000..f11d21f --- /dev/null +++ b/source/Felix/Test/Unit.hs @@ -0,0 +1,52 @@ +module Felix.Test.Unit where + + +import Felix.Test.Unit.Abstract qualified as Abstract +import Felix.Test.Unit.Backend qualified as Backend +import Felix.Test.Unit.CommandLine qualified as CommandLine +import Felix.Test.Unit.Concrete qualified as Concrete +import Felix.Test.Unit.Core qualified as Core +import Felix.Test.Unit.Declaration qualified as Declaration +import Felix.Test.Unit.Foundation qualified as Foundation +import Felix.Test.Unit.Html qualified as Html +import Felix.Test.Unit.HtmlLayout qualified as HtmlLayout +import Felix.Test.Unit.HtmlOutput qualified as HtmlOutput +import Felix.Test.Unit.Identity qualified as Identity +import Felix.Test.Unit.Kernel qualified as Kernel +import Felix.Test.Unit.Lexicon qualified as Lexicon +import Felix.Test.Unit.Materialization qualified as Materialization +import Felix.Test.Unit.Meaning qualified as Meaning +import Felix.Test.Unit.Module qualified as Module +import Felix.Test.Unit.OutputPlan qualified as OutputPlan +import Felix.Test.Unit.Provers qualified as Provers +import Felix.Test.Unit.Semantic qualified as Semantic +import Felix.Test.Unit.Source qualified as Source +import Felix.Test.Unit.Store qualified as Store +import Felix.Test.Unit.Token qualified as Token +import Test.Tasty + +unitTests :: TestTree +unitTests = testGroup "unit tests" + [ Abstract.unitTests + , Backend.unitTests + , CommandLine.unitTests + , Concrete.unitTests + , Core.unitTests + , Declaration.unitTests + , Foundation.unitTests + , Identity.unitTests + , Html.unitTests + , HtmlLayout.unitTests + , HtmlOutput.unitTests + , Kernel.unitTests + , Lexicon.unitTests + , Meaning.unitTests + , Materialization.unitTests + , Module.unitTests + , OutputPlan.unitTests + , Provers.unitTests + , Semantic.unitTests + , Source.unitTests + , Store.unitTests + , Token.unitTests + ] diff --git a/source/Test/Unit/Abstract.hs b/source/Felix/Test/Unit/Abstract.hs index 61118bd..c487c2a 100644 --- a/source/Test/Unit/Abstract.hs +++ b/source/Felix/Test/Unit/Abstract.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Abstract (unitTests) where +module Felix.Test.Unit.Abstract (unitTests) where import Base -import Report.Location -import Syntax.Abstract +import Felix.Report.Location +import Felix.Syntax.Abstract import Hedgehog import Hedgehog.Gen qualified as Gen diff --git a/source/Test/Unit/Backend.hs b/source/Felix/Test/Unit/Backend.hs index 11c36b8..384d21b 100644 --- a/source/Test/Unit/Backend.hs +++ b/source/Felix/Test/Unit/Backend.hs @@ -1,14 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Backend (unitTests) where +module Felix.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 Provers +import Felix.Checking.Backend.Problem +import Felix.Checking.Backend.Tptp +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Provers import Tptp.UnsortedFirstOrder qualified as Tptp import Data.Map.Strict qualified as Map @@ -52,6 +52,9 @@ unitTests = "routes implicit, explicit, and local-only problems" routesCompleteProblems , testCase + "admits only checked implicit set constructions" + admitsImplicitSetConstructions + , testCase "renders checked FOF and TH0 problems" rendersCheckedProblems ] @@ -166,8 +169,8 @@ routesCompleteProblems = do claim [higherOrderLocal, firstOrderLocal] [] - ImplicitFofPremises FirstOrderLocals + ImplicitConstructionJustification assertEqual "implicit route" RouteFof (typedProblemRoute implicit) assertEqual "implicit FOF globals" [0] @@ -186,23 +189,33 @@ routesCompleteProblems = do planned fofFacts claim - [firstOrderLocal] + [higherOrderLocal, firstOrderLocal] [] - ExplicitGlobalPremises 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 - [firstOrderLocal] + [higherOrderLocal, firstOrderLocal] [] - ExplicitGlobalPremises - FirstOrderLocals + 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 @@ -210,8 +223,8 @@ routesCompleteProblems = do claim [higherOrderLocal, firstOrderLocal] [] - NoGlobalPremises - AllLocals + CompleteLocals + ExplicitHigherOrderJustification assertEqual "local-only TH0 route" RouteTh0 (typedProblemRoute localOnly) assertEqual "local order restored" [0, 1] @@ -235,8 +248,8 @@ routesCompleteProblems = do claim [firstOrderLocal, firstOrderLocal] [] - NoGlobalPremises - AllLocals of + CompleteLocals + ExplicitHigherOrderJustification of Left (TypedProblemDuplicateLocalPremiseOrdinal duplicateOrdinal) -> @@ -260,8 +273,8 @@ routesCompleteProblems = do higherOrderClaimProposition [] [] - ImplicitFofPremises - FirstOrderLocals of + FirstOrderLocals + ImplicitConstructionJustification of Left TypedProblemExplicitHigherOrderJustificationRequired{} -> pure () @@ -282,8 +295,8 @@ routesCompleteProblems = do [typedFoundationAuxiliaryInput checkedFoundationValue Foundation.SeparationCharacteristic] - ImplicitFofPremises - FirstOrderLocals of + FirstOrderLocals + ImplicitConstructionJustification of Left TypedProblemExplicitHigherOrderJustificationRequired{} -> pure () @@ -314,8 +327,7 @@ routesCompleteProblems = do assertFailure "unused ambient local entered exact support" where - planned selectedFacts claim locals auxiliaries - globalPolicy localPolicy = + planned selectedFacts claim locals auxiliaries localPolicy higherOrderPolicy = either (assertFailure . show) pure @@ -325,8 +337,8 @@ routesCompleteProblems = do claim locals auxiliaries - globalPolicy - localPolicy) + localPolicy + higherOrderPolicy) showProblemResult = \case Left err -> @@ -334,6 +346,205 @@ routesCompleteProblems = do 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 <- @@ -355,14 +566,14 @@ rendersCheckedProblems = do planned (Vector.singleton fofFact) claim - ImplicitFofPremises FirstOrderLocals + ImplicitConstructionJustification th0Problem <- planned (Vector.singleton th0Fact) claim - ExplicitGlobalPremises - FirstOrderLocals + CompleteLocals + ExplicitHigherOrderJustification preparedFof <- either (assertFailure . show) @@ -385,7 +596,7 @@ rendersCheckedProblems = do assertEqual "FOF route" RouteFof (preparedTypedTptpRoute preparedFof) assertBool "FOF formulas" - ("fof(zf_h0,axiom," + ("fof(tg_h0,axiom," `Text.isInfixOf` preparedTypedTptpText preparedFof) @@ -408,9 +619,9 @@ rendersCheckedProblems = do (preparedTypedProverRequest proverTask)) for_ - [ "thf(zf_h0,axiom," + [ "thf(tg_h0,axiom," , "^ [V0:$i]" - , "thf(zf_q0,conjecture," + , "thf(tg_q0,conjecture," ] \fragment -> assertBool @@ -430,7 +641,7 @@ rendersCheckedProblems = do then Tptp.isProperVariable target else Tptp.isProperAtomicWord target) where - planned selectedFacts claim globalPolicy localPolicy = + planned selectedFacts claim localPolicy higherOrderPolicy = either (assertFailure . show) pure @@ -440,8 +651,8 @@ rendersCheckedProblems = do claim [] [] - globalPolicy - localPolicy) + localPolicy + higherOrderPolicy) firstOrderClaim :: CanonicalTerm TestGlobal firstOrderClaim = diff --git a/source/Test/Unit/CommandLine.hs b/source/Felix/Test/Unit/CommandLine.hs index 9f567f1..f2a4a10 100644 --- a/source/Test/Unit/CommandLine.hs +++ b/source/Felix/Test/Unit/CommandLine.hs @@ -1,21 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.CommandLine (unitTests) where +module Felix.Test.Unit.CommandLine (unitTests) where import Base -import Api (VerificationReport(..)) -import CommandLine +import Felix.CommandLine +import Felix.Output.Atomic qualified as Atomic import Felix.Source (safeRelativePath) import Felix.Store qualified as Store -import Provers qualified -import Render.Html.Output qualified as HtmlOutput -import Report.Location (pattern Nowhere) +import Felix.Verification qualified as Verification +import Felix.Provers qualified as Provers +import Felix.Render.Html.Output qualified as HtmlOutput +import Felix.Report.Location (pattern Nowhere) import Control.Exception (IOException, bracket) import Control.Exception qualified as Exception import Data.ByteString qualified as ByteString import Data.List qualified as List import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding import Options.Applicative (ParserResult(..)) import Options.Applicative qualified as Options import System.Directory qualified as Directory @@ -201,7 +203,7 @@ showParserResult = \case Success selected -> show selected Failure failure -> - fst (Options.renderFailure failure "zf") + fst (Options.renderFailure failure "felix") CompletionInvoked _completion -> "completion invoked" @@ -311,7 +313,9 @@ removesFailedDumpTemporary = let destination = root </> "1.p" Directory.createDirectory destination result <- Exception.try - (publishDumpFile destination "complete request") + (Atomic.writeBytesAtomically + destination + (TextEncoding.encodeUtf8 "complete request")) :: IO (Either IOException ()) case result of Left _failure -> @@ -533,22 +537,41 @@ htmlFailureRetainsAuthorizationReport = outcomeCases :: [(CommandOutcome, ExitCode)] outcomeCases = [ (CommandCompleted, ExitSuccess) - , (VerificationSucceeded emptyReport, ExitSuccess) - , (VerificationCompletedWithGaps emptyReport, ExitSuccess) - , ( VerificationRejected emptyReport Nowhere (CountermodelFound "") + , (VerificationSucceeded emptyReport emptySlowReport, ExitSuccess) + , (VerificationCompletedWithGaps emptyReport emptySlowReport, ExitSuccess) + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.CountermodelFailure "")) + emptySlowReport , ExitFailure 1 ) - , ( ProverFailed emptyReport Nowhere (ProverIndeterminate "") + , ( VerificationRejected + emptyReport + (Verification.FailedVerification + Nowhere + (Verification.IndeterminateFailure "")) + emptySlowReport + , ExitFailure 2 + ) + , ( VerificationCheckingRejected + emptyReport + (Verification.VerificationModuleSchedulerInvariant "test") + emptySlowReport , ExitFailure 2 ) ] -emptyReport :: VerificationReport +emptyReport :: Verification.VerificationReport emptyReport = - VerificationReport - { verificationDirectEscapes = [] + Verification.VerificationReport + { Verification.verificationDirectEscapes = [] } +emptySlowReport :: Provers.SlowAtpReport +emptySlowReport = Provers.SlowAtpReport 0 [] + runCliWithFakeVampire :: [String] -> IO (ExitCode, String, String) @@ -587,7 +610,7 @@ withCliFixture -> IO value withCliFixture source action = withTemporaryDirectory "felix-cli" \temp -> do - zfExecutable <- requireZfExecutable + felixExecutable <- requireFelixExecutable repositoryRoot <- Directory.getCurrentDirectory let sourcePath = temp </> "input.tex" vampirePath = temp </> "vampire" @@ -608,7 +631,7 @@ withCliFixture source action = "XDG_CACHE_HOME" cacheRoot (setEnvironmentVariable - "NAPROCHE_ZF_VAMPIRE" + "FELIX_VAMPIRE" vampirePath (setEnvironmentVariable "NAPROCHE_LIB" @@ -617,7 +640,7 @@ withCliFixture source action = action CliFixture { cliFixtureRoot = temp - , cliFixtureExecutable = zfExecutable + , cliFixtureExecutable = felixExecutable , cliFixtureVampire = vampirePath , cliFixtureCacheRoot = cacheRoot , cliFixtureEnvironment = processEnvironment @@ -681,15 +704,16 @@ writeNonExecutableFile path = do else pure () writeFile path "not executable" -requireZfExecutable :: IO FilePath -requireZfExecutable = do - executable <- Directory.findExecutable "zf" +requireFelixExecutable :: IO FilePath +requireFelixExecutable :: IO FilePath + = do + executable <- Directory.findExecutable "felix" case executable of Just path -> pure path Nothing -> do - assertFailure "zf build tool is not available on PATH" - pure "zf" + assertFailure "felix build tool is not available on PATH" + pure "felix" setEnvironmentVariable :: String diff --git a/source/Test/Unit/Concrete.hs b/source/Felix/Test/Unit/Concrete.hs index 7776552..7eac7df 100644 --- a/source/Test/Unit/Concrete.hs +++ b/source/Felix/Test/Unit/Concrete.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Concrete (unitTests) where +module Felix.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 Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Concrete (grammar) +import Felix.Syntax.Lexicon (builtins) +import Felix.Syntax.Token (runLexer) import Data.Text qualified as Text import Test.Tasty diff --git a/source/Test/Unit/Core.hs b/source/Felix/Test/Unit/Core.hs index e1ba10d..0388c7f 100644 --- a/source/Test/Unit/Core.hs +++ b/source/Felix/Test/Unit/Core.hs @@ -1,15 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Core (unitTests) where +module Felix.Test.Unit.Core (unitTests) where import Base hiding (Empty) -import Checking.Core -import Checking.Foundation qualified as Foundation +import Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.SetConstruction import Control.DeepSeq (NFData(..), force) import Hedgehog import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range +import Data.Set qualified as Set import Test.Tasty import Test.Tasty.HUnit hiding (assert) import Test.Tasty.Hedgehog (testPropertyNamed) @@ -58,6 +60,9 @@ unitTests = "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 @@ -268,6 +273,14 @@ checksScopedCanonicalOperations = do buildsSetInductionHypotheses :: Assertion buildsSetInductionHypotheses = do + let propertyTerm = + CImp + (CEq TySet + (CBound 0) + (CIntrinsic Empty)) + (CEq TySet + (CBound 0) + (CBound 0)) claimProperty <- either (assertFailure . show) @@ -275,35 +288,46 @@ buildsSetInductionHypotheses = do (checkScopedCanonicalCore testGlobalType [TySet] - (CImp - (CEq TySet - (CBound 0) - (CIntrinsic Empty)) - (CEq TySet - (CBound 0) - (CBound 0)))) - hypothesis <- + propertyTerm) + (predicate, hypothesis, step, result) <- maybe - (assertFailure "set-induction hypothesis was not constructed") + (assertFailure "set-induction instance was not constructed") pure - (scopedSetInductionHypothesis 0 claimProperty) + (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" - (CForall TySet - (CImp - (CApp - (CApp - (CIntrinsic Member) - (CBound 0)) - (CBound 1)) - (CImp - (CEq TySet - (CBound 0) - (CIntrinsic Empty)) - (CEq TySet - (CBound 0) - (CBound 0))))) + 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 @@ -404,6 +428,144 @@ specializesCheckedReplacementCharacteristic = do 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 diff --git a/source/Test/Unit/Declaration.hs b/source/Felix/Test/Unit/Declaration.hs index 26261f3..f3d9be7 100644 --- a/source/Test/Unit/Declaration.hs +++ b/source/Felix/Test/Unit/Declaration.hs @@ -1,36 +1,43 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Declaration (unitTests) where +module Felix.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.Identity qualified as Identity -import Checking.Kernel.Derivation qualified as Kernel -import Checking.Semantic qualified as Semantic +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Vocabulary qualified as Vocabulary +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Kernel.Derivation qualified as Kernel +import Felix.Checking.SetConstruction qualified as SetConstruction +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as Typed import Felix.Math.Codec import Felix.Module import Felix.Source import Felix.Store qualified as Store -import Provers qualified -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Interface qualified as Syntax -import Syntax.Lexicon qualified as Lexicon +import Felix.Meaning qualified as Meaning +import Felix.Provers qualified as Provers +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon import Data.List.NonEmpty qualified as NonEmpty import Data.IORef qualified as IORef +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding import Data.Vector qualified as Vector import Numeric.Natural (Natural) import Control.Exception (bracket) import Control.Exception qualified as Exception -import Control.Monad.Logger (runNoLoggingT) +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 @@ -62,6 +69,10 @@ unitTests = 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" @@ -1166,8 +1177,8 @@ makePreparedObligationWithPremise fixture fingerprint = do claim [] [] - Backend.ExplicitGlobalPremises - Backend.FirstOrderLocals) + Backend.FirstOrderLocals + Backend.ExplicitHigherOrderJustification) expectRight (Provers.prepareTypedProverTask Provers.DirectTask @@ -1199,8 +1210,8 @@ makePreparedObligation fixture tag = do [Backend.typedFoundationAuxiliaryInput (fixtureFoundation fixture) tag] - Backend.NoGlobalPremises - Backend.AllLocals) + Backend.CompleteLocals + Backend.ExplicitHigherOrderJustification) expectRight (Provers.prepareTypedProverTask Provers.DirectTask @@ -1219,13 +1230,12 @@ resolveAccepted Provers.ProverProcessError Provers.ProverAnswer) resolveAccepted executable prepared = - runNoLoggingT - (Provers.runPreparedTypedProver - (Provers.vampire - executable - Provers.defaultTimeLimit - Provers.defaultMemoryLimit) - prepared) + Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared writeAcceptedVampire :: FilePath -> IO () writeAcceptedVampire executable = do @@ -1887,6 +1897,442 @@ elaboratesScopedExactPropositions = do 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" @@ -2139,6 +2585,13 @@ lowersExactReplacementTelescopes = do (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 = @@ -2170,6 +2623,9 @@ lowersExactReplacementTelescopes = do , Either Exact.ExactCompileError Exact.PreparedExactProposition + , Either + Exact.ExactCompileError + Exact.PreparedExactSetExpression ) action = Declaration.runProspectiveLoweringDriver do @@ -2182,12 +2638,24 @@ lowersExactReplacementTelescopes = do predicateReplacement <- Exact.prepareExactProposition Exact.emptyExactBinderContext predicateReplacementStatement - pure (valid, invalid, predicateReplacement) + 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" @@ -2200,27 +2668,139 @@ lowersExactReplacementTelescopes = do failure assertEqual "predicate replacement remains unsupported at its location" - (Exact.ExactUnsupportedDeclarationBody + (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 -> + (Left validFailure, _, _, _) _interface _prefix _closure -> assertFailure ("valid replacement failed: " <> Text.unpack (Exact.renderExactCompileError validFailure)) Declaration.DriverSucceeded - (_, Right{}, _) _interface _prefix _closure -> + (_, Right{}, _, _) _interface _prefix _closure -> assertFailure "invalid replacement was accepted" Declaration.DriverSucceeded - (_, _, Right{}) _interface _prefix _closure -> + (_, _, 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 @@ -2277,6 +2857,44 @@ lowersExactFiniteSets = do (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 -> diff --git a/source/Test/Unit/Foundation.hs b/source/Felix/Test/Unit/Foundation.hs index 17ff526..18ead04 100644 --- a/source/Test/Unit/Foundation.hs +++ b/source/Felix/Test/Unit/Foundation.hs @@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Foundation (unitTests) where +module Felix.Test.Unit.Foundation (unitTests) where import Base -import Checking.Core -import Checking.Foundation +import Felix.Checking.Core +import Felix.Checking.Foundation import Data.List qualified as List import Data.Set qualified as Set diff --git a/source/Test/Unit/Html.hs b/source/Felix/Test/Unit/Html.hs index 14ecdc3..c8395ec 100644 --- a/source/Test/Unit/Html.hs +++ b/source/Felix/Test/Unit/Html.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Html (unitTests) where +module Felix.Test.Unit.Html (unitTests) where import Base -import Api qualified import Felix.Parse qualified as Parse import Felix.Source import Felix.Source.Graph -import Render.Html qualified as Html -import Render.Html.Context -import Render.Html.Layout -import Report.Location (Location, pattern Nowhere) -import Syntax.Abstract +import Felix.Workspace qualified as Workspace +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Context +import Felix.Render.Html.Layout +import Felix.Report.Location (Location, pattern Nowhere) +import Felix.Syntax.Abstract import Data.Text qualified as Text import Data.Text.IO qualified as TextIO @@ -29,9 +29,10 @@ unitTests = testGroup "HTML renderer" referencePreviews :: Assertion referencePreviews = do + environment <- expectRight =<< Workspace.prepareDefaultWorkspaceEnvironment graph <- expectRight =<< - Api.prepareDefaultSourceGraph + Workspace.prepareDefaultSourceGraph "test/html-fixtures/root-preview.tex" workspace <- expectRight =<< Parse.parseResolvedSourceGraph graph @@ -39,7 +40,7 @@ referencePreviews = do layout <- expectRight (layoutHtmlSourceGraph - Api.defaultHtmlMountPrefixes + (Workspace.workspaceHtmlMountPrefixes environment) graph) let nodes = Parse.parsedWorkspaceImportedBeforeImporter workspace sourceBlocks = diff --git a/source/Test/Unit/HtmlLayout.hs b/source/Felix/Test/Unit/HtmlLayout.hs index a248f3b..a3d701f 100644 --- a/source/Test/Unit/HtmlLayout.hs +++ b/source/Felix/Test/Unit/HtmlLayout.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.HtmlLayout (unitTests) where +module Felix.Test.Unit.HtmlLayout (unitTests) where import Base import Felix.Source import Felix.Source.Graph -import Render.Html.Layout +import Felix.Render.Html.Layout import Control.Exception (bracket) import Data.List qualified as List diff --git a/source/Test/Unit/HtmlOutput.hs b/source/Felix/Test/Unit/HtmlOutput.hs index 0087f82..34fe2e7 100644 --- a/source/Test/Unit/HtmlOutput.hs +++ b/source/Felix/Test/Unit/HtmlOutput.hs @@ -1,15 +1,15 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.HtmlOutput (unitTests) where +module Felix.Test.Unit.HtmlOutput (unitTests) where import Base import Felix.Parse qualified as Parse import Felix.Source import Felix.Source.Graph qualified as SourceGraph -import Render.Html qualified as Html -import Render.Html.Export -import Render.Html.Output +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Export +import Felix.Render.Html.Output import Control.Exception (bracket) import Data.ByteString qualified as ByteString diff --git a/source/Test/Unit/Identity.hs b/source/Felix/Test/Unit/Identity.hs index b91d2b3..7e1e73f 100644 --- a/source/Test/Unit/Identity.hs +++ b/source/Felix/Test/Unit/Identity.hs @@ -1,12 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Identity (unitTests) where +module Felix.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.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity import Felix.Cache.Codec import Felix.Math.Codec import Felix.Module @@ -547,6 +547,11 @@ validatesCompactFactAuthority = do , Authority.CheckedKernelConstruction (Authority.CheckedDefinitionEquation (fixtureIntrinsic fixture)) + , Authority.CheckedKernelConstruction + (Authority.CheckedSetConstructionExtensionality + (fixtureIntrinsic fixture) + (hashCacheFields + "test-named-construction" ["checked"])) , Authority.CheckedSourceProof requests , Authority.TrustedCompilation (Authority.DatatypeCompilation diff --git a/source/Test/Unit/Kernel.hs b/source/Felix/Test/Unit/Kernel.hs index c24debf..7762a7e 100644 --- a/source/Test/Unit/Kernel.hs +++ b/source/Felix/Test/Unit/Kernel.hs @@ -1,17 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternSynonyms #-} -module Test.Unit.Kernel (unitTests) where +module Felix.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 Felix.Checking.Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Kernel.Derivation +import Felix.Checking.Kernel.Semantics qualified as Semantics +import Felix.Checking.Kernel.SetLfp qualified as SetLfp +import Felix.Checking.Typed.Inductive qualified as Inductive +import Felix.Report.Location (pattern Nowhere) +import Felix.Syntax.Internal qualified as Internal import Data.Set qualified as Set import Data.Vector qualified as Vector @@ -430,7 +430,8 @@ replaysDirectInductiveFacts = do :| [ Inductive.DirectInductiveClause [x] [Inductive.DirectRecursiveCondition - (Internal.TermVar x)] + (Internal.TermVar x) + (Inductive.directRecursiveCarrierContext Nowhere)] (Internal.TermVar x) ] ) diff --git a/source/Test/Unit/Lexicon.hs b/source/Felix/Test/Unit/Lexicon.hs index 54b4bd4..4b7f9e7 100644 --- a/source/Test/Unit/Lexicon.hs +++ b/source/Felix/Test/Unit/Lexicon.hs @@ -1,12 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Lexicon (unitTests) where +module Felix.Test.Unit.Lexicon (unitTests) where import Base import Felix.Cache.Codec -import Syntax.Abstract -import Syntax.Interface -import Syntax.Lexicon +import Felix.Syntax.Abstract +import Felix.Syntax.Interface +import Felix.Syntax.Lexicon import Data.Set qualified as Set import Test.Tasty diff --git a/source/Test/Unit/Materialization.hs b/source/Felix/Test/Unit/Materialization.hs index fcad7b5..9c4f54f 100644 --- a/source/Test/Unit/Materialization.hs +++ b/source/Felix/Test/Unit/Materialization.hs @@ -1,14 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Materialization (unitTests) where +module Felix.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.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Materialization qualified as Materialization +import Felix.Checking.Semantic qualified as Semantic import Felix.Math.Codec import Felix.Module import Felix.Source diff --git a/source/Test/Unit/Meaning.hs b/source/Felix/Test/Unit/Meaning.hs index 8954aa7..3093a84 100644 --- a/source/Test/Unit/Meaning.hs +++ b/source/Felix/Test/Unit/Meaning.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Meaning (unitTests) where +module Felix.Test.Unit.Meaning (unitTests) where import Base -import Meaning -import Report.Location -import Syntax.Abstract qualified as Raw -import Syntax.Internal qualified as Sem -import Syntax.LexicalPhrase +import Felix.Meaning +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Internal qualified as Sem +import Felix.Syntax.LexicalPhrase ( unsafeReadPhrase , unsafeReadPhraseSgPl ) diff --git a/source/Test/Unit/Module.hs b/source/Felix/Test/Unit/Module.hs index 267a9ad..44f0ccb 100644 --- a/source/Test/Unit/Module.hs +++ b/source/Felix/Test/Unit/Module.hs @@ -1,38 +1,40 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Module (unitTests) where +module Felix.Test.Unit.Module (unitTests) where import Base -import Api qualified -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 CommandLine qualified -import Felix.Module +import Felix.Checking.Authority qualified as Authority +import Felix.Checking.Backend.Problem qualified as Backend +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Exact qualified as Exact +import Felix.Checking.Exact.Datatype qualified as ExactDatatype +import Felix.Checking.Exact.Inductive qualified as ExactInductive +import Felix.Checking.Exact.Proof qualified as ExactProof +import Felix.Checking.FinalPrelude qualified as FinalPrelude +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Module +import Felix.Checking.Semantic qualified as Semantic +import Felix.Checking.Typed.Inductive qualified as TypedInductive +import Felix.CommandLine qualified as CommandLine import Felix.Math.Codec +import Felix.Module import Felix.Parse qualified as Parse import Felix.Prelude qualified as Prelude +import Felix.Provers qualified as Provers +import Felix.Report.Location import Felix.Source import Felix.Source.Content qualified as Content import Felix.Store qualified as Store -import Report.Location -import Provers qualified +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Internal qualified as Internal +import Felix.Syntax.Lexicon qualified as Lexicon +import Felix.Syntax.Pragma qualified as Pragma +import Felix.Verification qualified as Verification +import Felix.Workspace qualified as Workspace import Paths_felix qualified as Paths -import Syntax.Abstract qualified as Raw -import Syntax.Internal qualified as Internal -import Syntax.Interface qualified as Syntax -import Syntax.Pragma qualified as Pragma import Control.Concurrent (threadDelay) import Control.Concurrent.STM @@ -51,11 +53,11 @@ import Control.Concurrent.STM , 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 Control.Monad.Logger (runNoLoggingT) import Data.IORef ( IORef , atomicModifyIORef' @@ -67,6 +69,7 @@ import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Vector qualified as Vector +import Numeric.Natural (Natural) import System.Directory ( createDirectoryIfMissing , doesFileExist @@ -106,6 +109,8 @@ unitTests = 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" @@ -118,20 +123,30 @@ unitTests = compilesExactRelationExpressions , testCase "resolves source-owned set application" resolvesSourceOwnedApplication - , testCase "confines quantified terms to exact statement subjects" + , 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 "confines terminal exact contradiction" + , 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" @@ -142,8 +157,12 @@ unitTests = compilesAndReusesExactDatatypes , testCase "prepares exact direct inductives" preparesExactDirectInductives - , testCase "rejects nested exact inductive recursion" - rejectsNestedExactInductiveRecursion + , 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" @@ -156,8 +175,8 @@ unitTests = doesNotTreatMarkerOnlyNounAsSet , testCase "rejects proof-local generalization" rejectsProofLocalGeneralization - , testCase "rejects nested exact set induction" - rejectsNestedExactSetInduction + , testCase "restores checked set induction" + restoresCheckedSetInduction , testCase "compiles exact omitted proofs" compilesExactOmittedProofs , testCase "propagates and reuses exact escape authority" @@ -339,8 +358,8 @@ rendersPackagedPreludeFailures = do assertEqual "authority-free API presentation" ("packaged final prelude parsing failed: " <> "<felix-prelude>: syntax pragma location is out of range at 7:3") - (Api.renderAuthorityFreeParseError - (Api.AuthorityFreePreludeParseFailed parseFailure)) + (Workspace.renderAuthorityFreeParseError + (Workspace.AuthorityFreePreludeParseFailed parseFailure)) where parseFailure = Prelude.PreludeSyntaxPragmaFailed @@ -563,6 +582,7 @@ buildsConfinedFinalPrelude = do candidate "pow_iff" Foundation.PowerSetCharacteristic + assertRejectsAdditionalOmegaFact candidate FinalPrelude.FinalPreludeBuildFailed failure prefix -> assertFailure ("final prelude failed after " @@ -578,6 +598,92 @@ buildsConfinedFinalPrelude = do 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 @@ -720,32 +826,6 @@ checkedPropositionTermByAlias sealed name = do ] pure (Identity.checkedPropositionTerm proposition) -assertCleanFactAlias - :: Module.SealedTypedModule - -> Text - -> Assertion -assertCleanFactAlias sealed name = do - delta <- localDeltaByAlias sealed name - alias <- sole - ("semantic alias " <> StrictText.unpack name) - [ candidate - | candidate <- Semantic.declarationDeltaAliases delta - , Semantic.semanticAliasName candidate - == Semantic.semanticName name - ] - fact <- sole - ("semantic fact " <> StrictText.unpack name) - [ candidate - | candidate <- Semantic.declarationDeltaFacts delta - , Semantic.semanticFactFingerprint candidate - == Semantic.semanticAliasTarget alias - ] - assertEqual - ("clean authority for " <> StrictText.unpack name) - Authority.cleanAuthoritySafety - (Authority.factAuthoritySafety - (Semantic.semanticFactAuthority fact)) - batchByAlias :: Declaration.PendingModulePrefix -> Text @@ -889,9 +969,9 @@ coalescesSharedDirectSyntax = do request <- expectRight (searchedRoot "test/phase3/typed-shared-root.tex") - (workspace, _measurements) <- + workspace <- expectRight - =<< Parse.parseSourceWorkspaceMeasuredWithSyntaxInputs + =<< Parse.parseSourceWorkspaceWithSyntaxInputs mounts request syntaxInputs @@ -960,8 +1040,7 @@ coalescesSharedDirectSyntax = do rejectsUnsupportedTypedSource :: Assertion rejectsUnsupportedTypedSource = do result <- - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh (Provers.vampire "vampire" Provers.defaultTimeLimit @@ -969,42 +1048,81 @@ rejectsUnsupportedTypedSource = do "test/phase3/typed-unsupported.tex") case result of Right - ( Api.VerificationCheckingFailure _report - (failure@(Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (failure@(Verification.VerificationTypedModuleError source (Module.TypedActionFailed (Module.TypedExactCompileFailed - (Exact.ExactUnsupportedDeclarationBody location))) + (Exact.ExactGuardedOpaqueSignature location))) prefix)) - , _measurements + , _slowReport ) -> do assertEqual "failed source" "test/phase3/typed-unsupported.tex" (safeRelativePathFilePath (resolvedSourceRelativePath source)) assertEqual "unsupported source location line" - 1 + 2 (locLine location) assertEqual "failure retains the initial module prefix" 0 (length (Declaration.pendingModulePrefixBatches prefix)) let diagnostic = - CommandLine.verificationDriverFailureMessage failure + 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 1:1" + ("typed-unsupported.tex 2:14" `StrictText.isInfixOf` diagnostic) assertBool "diagnostic explains the typed failure" - ("not yet supported by exact elaboration" + ("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) <- @@ -1324,6 +1442,29 @@ compilesExactStructures = do (Semantic.semanticStructureOperationObject parentOperation `Set.member` operationGlobals) + let assertEquivalentClaim surface explicit = do + surfaceTerm <- + checkedPropositionTermByAlias parent surface + explicitTerm <- + checkedPropositionTermByAlias parent explicit + assertEqual + (StrictText.unpack surface + <> " uses the inherited carrier") + explicitTerm + surfaceTerm + assertEquivalentClaim + "pointed_self_member" + "pointed_self_member_explicit" + assertEquivalentClaim + "pointed_self_not_member" + "pointed_self_not_member_explicit" + assertEquivalentClaim + "pointed_self_element" + "pointed_self_element_explicit" + assertEquivalentClaim + "pointed_header_member" + "pointed_header_member_explicit" + childBatch <- sole "child structure batch" childBatches childDelta <- sole "child structure delta" childDeltas childDescriptor <- sole "child structure descriptor" @@ -1754,8 +1895,7 @@ compilesExactRelationExpressions = do | premise <- Vector.toList locals ] ]) - runNoLoggingT - (Provers.runPreparedTypedProver prover prepared) + (Provers.runPreparedTypedProver prover prepared) void (compileParsedWorkspaceWithResolver foundation bootstrap resolver workspace) @@ -1766,21 +1906,20 @@ compilesExactRelationExpressions = do missingPair <- withAcceptedFixtureVampire "felix-exact-relation-expression-missing-pair" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover "test/phase5/exact-relation-expression-missing-pair.tex") case missingPair of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofElaborationFailed (Exact.ExactGlobalNotVisible location key)))) prefix) - , _measurements + , _slowReport ) -> do assertEqual "missing ordered-pair provider line" 2 @@ -1806,7 +1945,7 @@ resolvesSourceOwnedApplication = do Temp.withSystemTempDirectory "felix-exact-application" \directory -> do let storePath = directory Posix.</> "store.sqlite" resolver = Declaration.vampireResolver - (runNoLoggingT . Provers.runPreparedTypedProver prover) + (Provers.runPreparedTypedProver prover) bracket (snd <$> (Store.openStore storePath (Identity.theoryId foundation) >>= expectRight)) @@ -1845,21 +1984,20 @@ resolvesSourceOwnedApplication = do missing <- withAcceptedFixtureVampire "felix-exact-application-missing" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover "test/phase5/exact-application-missing.tex") case missing of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofElaborationFailed (Exact.ExactGlobalNotVisible location key)))) prefix) - , _measurements + , _slowReport ) -> do assertEqual "unresolved application line" 2 (locLine location) assertEqual "unresolved application key" @@ -1883,7 +2021,7 @@ confinesExactQuantifiedTerms = do Temp.withSystemTempDirectory "felix-quantified-subject" \directory -> do let storePath = directory Posix.</> "store.sqlite" resolver = Declaration.vampireResolver - (runNoLoggingT . Provers.runPreparedTypedProver prover) + (Provers.runPreparedTypedProver prover) bracket (snd <$> (Store.openStore storePath (Identity.theoryId foundation) >>= expectRight)) @@ -1913,36 +2051,438 @@ confinesExactQuantifiedTerms = do 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-subject-nested" + withAcceptedFixtureVampire "felix-exact-quantified-term-valued" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover - "test/phase5/exact-quantified-subject-nested.tex") + "test/phase5/exact-quantified-term-valued.tex") case negative of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError _source (Module.TypedActionFailed - (Module.TypedExactProofFailed - (ExactProof.ExactProofElaborationFailed - (Exact.ExactQuantifiedTermRequiresStatementSubject - location)))) + (Module.TypedExactCompileFailed + (Exact.ExactQuantifiedTermRequiresPropositionContext + location))) prefix) - , _measurements + , _slowReport ) -> do - assertEqual "nested quantified term line" 8 (locLine location) - assertEqual "earlier exact definition remains committed" - 1 - (length (Declaration.pendingModulePrefixBatches prefix)) + 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 nested quantified-term failure: " + ("unexpected term-valued quantified-term failure: " <> show failure) Right{} -> - assertFailure "nested quantified exact term was admitted" + 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 @@ -1991,8 +2531,7 @@ compilesExactOrdinaryProofs = ] ) ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2084,6 +2623,911 @@ compilesExactOrdinaryProofs = element) set +restoresExactBinderAndWitnessProofForms :: Assertion +restoresExactBinderAndWitnessProofForms = + Temp.withSystemTempDirectory "felix-exact-proof-parity" \root -> do + repository <- getCurrentDirectory + foundation <- expectRight Foundation.checkedFoundation + bootstrap <- + expectRight + =<< Module.buildBootstrapPreludeFixture + foundation + unusedResolver + mounts <- exactFixtureMounts repository + workspace <- parseExactWorkspace + bootstrap mounts "test/phase5/exact-proof-parity.tex" + parsed <- sole "parsed proof-parity module" + (toList (Parse.parsedWorkspaceImportedBeforeImporter workspace)) + let blocks = + Parse.identifiedParsedModuleBlocks + (Parse.parsedModuleIdentified parsed) + claims = [claim | claim@Raw.BlockClaim{} <- blocks] + proofs = + [ proof + | Raw.BlockProof _location proof _end <- blocks + ] + omittedClaim <- + case reverse claims of + claim : _ -> pure claim + [] -> assertFailure "missing omitted witness claim" + >> fail "unreachable" + omittedProof <- + case reverse proofs of + proof : _ -> pure proof + [] -> assertFailure "missing omitted witness proof" + >> fail "unreachable" + Declaration.runModuleDriver + foundation + preludeModuleName + [] + unusedResolver + Declaration.FreshValidation do + Declaration.runProspectiveLoweringDriver + (ExactProof.prepareExactProof + omittedClaim (Just omittedProof)) + >>= either Declaration.failModuleDriver pure + >>= \case + Right (Declaration.DriverSucceeded + prepared _semantic _prefix _closure) -> + case ExactProof.preparedExactProofFirstOmission prepared of + Just location -> + assertEqual "nested Take retains first omission" + 106 (locLine location) + Nothing -> + assertFailure "nested Take lost its omission" + Right Declaration.DriverFailed{} -> + assertFailure "omitted witness preparation failed" + Right Declaration.DriverSealFailed{} -> + assertFailure "omitted witness preparation did not seal" + Left failure -> + assertFailure + ("omitted witness preparation did not open: " + <> show failure) + let executable = root Posix.</> "vampire" + storePath = root Posix.</> "store.sqlite" + writeFile executable + (unlines + [ "#!/bin/sh" + , "cat >/dev/null" + , "printf '%s\\n' '% SZS status Theorem for exact-proof-parity'" + ]) + permissions <- getPermissions executable + setPermissions executable + (setOwnerExecutable True permissions) + observations <- newIORef [] + fresh <- + sole "proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (observingAcceptedResolver executable observations) + Declaration.FreshValidation + workspace + observed <- readIORef observations + assertEqual "restored proof request count" 17 (length observed) + assertEqual + "restored proof declarations preserve discharge order" + [1, 1, 1, 1, 1, 1, 3, 2, 2, 3, 1] + (proofRequestCounts fresh) + case observed of + first : second : third : fourth : _rest -> do + assertGuardRequest "single bounded fix" 2 first + assertGuardRequest "multiple bounded fix" 3 second + assertGuardRequest "negative bounded fix" 2 third + assertGuardRequest "fix such that" 2 fourth + _ -> assertFailure "missing bounded-fix requests" + case drop 4 observed of + leftFirst : rightFirst : _ -> do + assertSequentialAssumptions "left conjunct first" leftFirst + assertSequentialAssumptions "right conjunct first" rightFirst + _ -> assertFailure "missing conjunction-assumption requests" + assertTakeSequence "bounded TakeVar" (drop 6 observed) + assertTakeSequence "existential Have" (drop 13 observed) + case drop 9 observed of + namedDischarge : _namedFinal : anonymousDischarge : _ -> do + assertExactDischarge "named noun" namedDischarge + assertEqual "named noun opens two witness binders" + 2 + (leadingExistentials + (observedClaimTerm namedDischarge)) + assertExactDischarge "anonymous noun" anonymousDischarge + assertEqual "anonymous noun opens one unnameable binder" + 1 + (leadingExistentials + (observedClaimTerm anonymousDischarge)) + _ -> assertFailure "missing noun-witness requests" + lastBatch <- + case reverse + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)) of + batch : _ -> pure batch + [] -> assertFailure "missing restored-proof batches" + >> fail "unreachable" + lastFact <- sole "omitted witness fact" + (Semantic.declarationDeltaFacts + (Declaration.committedBatchDelta lastBatch)) + assertEqual "omitted continuation remains escape-backed" + (Authority.authoritySafety + (Authority.singletonEscapeKind Authority.Omitted)) + (Authority.factAuthoritySafety + (Semantic.semanticFactAuthority lastFact)) + assertBool "proof-local witnesses publish no objects" + (all + (null . Declaration.committedBatchObjects) + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh))) + + bracket + (snd <$> (Store.openStore storePath + (Identity.theoryId foundation) >>= expectRight)) + Store.closeStore + \store -> do + expectRightIO + (Store.writePendingModulePrefix store + (Module.sealedTypedModulePrefix fresh)) + let validation = + Declaration.WarmValidation + (Declaration.validationLookup + (expectRightIO + . Store.loadProofValidation store) + (expectRightIO + . Store.loadDeclarationValidation store)) + warmRuns <- newIORef (0 :: Int) + warm <- + sole "warm proof-parity module" + =<< compileParsedWorkspaceWithValidation + foundation + bootstrap + (countingAcceptedResolver executable warmRuns) + validation + workspace + assertEqual "warm restored proofs skip Vampire" + 0 =<< readIORef warmRuns + assertEqual + "fresh and warm proof validation keys and authority" + (proofValidationRecords fresh) + (proofValidationRecords warm) + assertEqual + "fresh and warm checked proposition identities" + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix fresh)))) + (map Identity.checkedPropositionId + (concatMap Declaration.committedBatchPropositions + (Declaration.pendingModulePrefixBatches + (Module.sealedTypedModulePrefix warm)))) + + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-fix-shape.tex" + (\case + ExactProof.ExactProofExpectedUniversalGoal location -> + locLine location == 6 + _ -> False) + assertProofParityFailure + foundation bootstrap mounts + "test/phase5/exact-proof-parity-invalid-assume.tex" + (\case + ExactProof.ExactProofGoalStatementMismatch location -> + locLine location == 6 + _ -> False) + where + observingAcceptedResolver executable observations = + Declaration.vampireResolver \prepared -> do + let problem = Provers.preparedTypedProverLogicalProblem prepared + claim = Backend.typedProblemClaim problem + locals = Backend.typedProblemLocalPremises problem + observation = + ProofParityObservation + (snd <$> Vector.toList + (Backend.supportedPropositionSupport claim)) + (Backend.supportedPropositionTerm claim) + [ ( Backend.localPremiseOrdinalValue + (Backend.typedLocalPremiseOrdinal premise) + , snd <$> Vector.toList + (Backend.supportedPropositionSupport + (Backend.typedLocalPremiseProposition + premise)) + , Backend.supportedPropositionTerm + (Backend.typedLocalPremiseProposition premise) + ) + | premise <- Vector.toList locals + ] + modifyIORef' observations (<> [observation]) + (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 @@ -2112,15 +3556,31 @@ compilesExactSeparationComprehensions = 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 ) ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2130,12 +3590,43 @@ compilesExactSeparationComprehensions = foundation bootstrap resolver workspace sealed <- sole "exact separation module" modules assertExactSeparationModule "fresh" sealed - assertEqual - "separation proof uses its checked characteristic on TH0" - [( Backend.RouteTh0 - , [Foundation.SeparationCharacteristic] - )] - =<< readIORef observations + 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 @@ -2222,12 +3713,13 @@ compilesAndReusesProofLocalSetDefinitions = premises modifyIORef' observations (<> [ ( Backend.typedProblemRoute problem - , Vector.length premises + , Backend.localPremiseOrdinalValue + . Backend.typedLocalPremiseOrdinal + <$> Vector.toList premises , fmap localDefinitionShape definition ) ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2242,9 +3734,9 @@ compilesAndReusesProofLocalSetDefinitions = workspace assertEqual "fresh local-definition discharge count" 2 =<< readIORef freshRuns - assertEqual "local definitions remain on the FOF route" - [ (Backend.RouteFof, 2, Just expectedLocalDefinitionShape) - , (Backend.RouteFof, 2, Just expectedLocalDefinitionShape) + 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 @@ -2410,8 +3902,7 @@ compilesAndReusesProofLocalFunctionGraphs = Backend.typedLocalPremiseProposition premise ] modifyIORef' observations (<> premises) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2581,15 +4072,18 @@ compilesAndReusesProofLocalFunctionGraphs = confinesTerminalExactContradiction :: Assertion confinesTerminalExactContradiction = Temp.withSystemTempDirectory "felix-exact-contradiction" \directory -> do - let executable = directory Posix.</> "vampire" - writeFile executable + 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 executable - setPermissions executable + permissions <- getPermissions contradictoryExecutable + setPermissions contradictoryExecutable (setOwnerExecutable True permissions) foundation <- expectRight Foundation.checkedFoundation bootstrap <- @@ -2598,48 +4092,294 @@ confinesTerminalExactContradiction = foundation unusedResolver mounts <- exactFixtureMounts =<< getCurrentDirectory workspace <- parseExactWorkspace bootstrap mounts - "test/phase5/exact-contradiction.tex" - runs <- newIORef (0 :: Int) - modules <- - compileParsedWorkspaceWithResolver - foundation - bootstrap - (countingAcceptedResolver executable runs) - workspace - accepted <- sole "terminal contradiction module" modules - assertEqual "one indirect contradiction obligation" - 1 =<< readIORef runs - assertCleanFactAlias accepted "phase5_contradiction" - - invalidWorkspace <- parseExactWorkspace bootstrap mounts - "test/phase5/exact-contradiction-goal.tex" - invalidParsed <- - sole "invalid contradiction module" - (toList - (Parse.parsedWorkspaceImportedBeforeImporter - invalidWorkspace)) - invalidInput <- expectRight + "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) - unusedResolver + (Declaration.vampireResolver + (runWith contradictoryExecutable)) Declaration.FreshValidation - invalidParsed + directParsed []) - Module.runTypedModule invalidInput >>= \case + Module.runTypedModule directInput >>= \case Module.TypedModuleFailed - (Module.TypedActionFailed - (Module.TypedExactProofFailed - (ExactProof.ExactProofContradictionGoalMismatch - location))) - prefix -> do - assertEqual "invalid contradiction line" - 6 (locLine location) - assertBool "invalid contradiction publishes no declaration" - (null - (Declaration.pendingModulePrefixBatches prefix)) + (Module.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + _location + Declaration.VampireObligationRejected{})) + prefix -> + assertBool + "direct contradictory input publishes no theorem" + (null (Declaration.pendingModulePrefixBatches prefix)) _result -> - assertFailure "unexpected invalid contradiction 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 = @@ -2675,8 +4415,7 @@ compilesExactReplacementComprehensions = (Backend.typedProblemAuxiliaries problem) ) ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2712,21 +4451,57 @@ assertExactReplacementModule sealed = assertEqual "replacement definition body" expectedBody body + assertEqual "replacement definition foundation helpers" + (Set.fromList + [ Foundation.FamilyUnionCharacteristic + , Foundation.SeparationCharacteristic + , Foundation.ReplacementCharacteristic + ]) + (Foundation.foundationAxiomDependencies body) content -> assertFailure ("unexpected replacement object " <> show content) + 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.declarationDeltaFacts - (Declaration.committedBatchDelta definitionBatch))) + (length (Semantic.declarationDeltaAliases definitionDelta)) assertEqual "replacement definition proposition count" - 1 + 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" [] @@ -2776,6 +4551,232 @@ assertExactReplacementModule sealed = (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 @@ -2813,8 +4814,7 @@ compilesAndReusesExactFiniteSets = (Backend.typedProblemAuxiliaries problem) ) ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -2875,6 +4875,7 @@ compilesAndReusesExactFiniteSets = preparesExactDirectInductives :: Assertion preparesExactDirectInductives = do + foundation <- expectRight Foundation.checkedFoundation prepared <- expectRight =<< prepareExactInductiveFixture @@ -2918,9 +4919,52 @@ preparesExactDirectInductives = do 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 @@ -3025,8 +5069,7 @@ preparesExactDatatypes = do (Core.CImp (member (Core.CBound 0) - (apply1 Core.FamilyUnion - (Core.CIntrinsic Core.Empty))) + singletonEmpty) (member (Core.CApp (Core.CGlobal atomId) @@ -3053,8 +5096,7 @@ preparesExactDatatypes = do (Core.CImp (member (Core.CBound 0) - (apply1 Core.FamilyUnion - (Core.CIntrinsic Core.Empty))) + singletonEmpty) (member (Core.CApp (Core.CGlobal atomId) @@ -3095,8 +5137,10 @@ preparesExactDatatypes = do (ExactDatatype.preparedExactDatatypeFactReference <$> facts)) (ExactDatatype.preparedExactDatatypeDescriptor prepared) where - apply1 intrinsic argument = - Core.CApp (Core.CIntrinsic intrinsic) argument + singletonEmpty = + Core.canonicalSetInsert + (Core.CIntrinsic Core.Empty) + (Core.CIntrinsic Core.Empty) member element set = Core.CApp @@ -3228,21 +5272,705 @@ compilesAndReusesExactDatatypes = _result -> assertFailure "unexpected nested datatype result" -rejectsNestedExactInductiveRecursion :: Assertion -rejectsNestedExactInductiveRecursion = do - result <- - prepareExactInductiveFixture - "test/phase5/exact-inductive-nested.tex" - case result of - Left (ExactInductive.ExactInductiveNestedRecursion location) -> - assertEqual "nested recursive occurrence line" - 6 - (locLine location) - Left failure -> - assertFailure - ("unexpected exact inductive failure: " <> show failure) - Right{} -> - assertFailure "nested inductive recursion was accepted" +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 = @@ -3311,37 +6039,6 @@ compilesAndReusesExactInductives = freshArtifact =<< artifact warm - mounts <- exactFixtureMounts =<< getCurrentDirectory - nestedWorkspace <- - parseExactWorkspace bootstrap mounts - "test/phase5/exact-inductive-nested.tex" - nestedParsed <- - sole "nested exact inductive 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.TypedExactInductiveFailed - (ExactInductive.ExactInductiveNestedRecursion - location))) - prefix -> do - assertEqual "nested failure line" 6 (locLine location) - assertBool "nested declaration publishes no prefix" - (null (Declaration.pendingModulePrefixBatches prefix)) - _result -> - assertFailure "unexpected nested inductive result" - authorizesRecursiveExactInductives :: Assertion authorizesRecursiveExactInductives = Temp.withSystemTempDirectory "felix-recursive-inductive" \directory -> do @@ -3733,13 +6430,20 @@ assertExactSeparationModule label sealed = do 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.declarationDeltaFacts - (Declaration.committedBatchDelta definitionBatch))) + (length (Semantic.declarationDeltaAliases definitionDelta)) assertEqual (label <> " definition proposition count") - 1 + 2 (length (Declaration.committedBatchPropositions definitionBatch)) assertEqual (label <> " definition proof validations") @@ -3753,19 +6457,22 @@ assertExactSeparationModule label sealed = do pure (Declaration.committedBatchDeclarationValidation definitionBatch) - definitionCertificate <- sole - (label <> " definition certificate") - (Semantic.declarationValidationRecordCertificates - definitionValidation) case Authority.validationDirectAuthorization - definitionCertificate of - Authority.CheckedKernelConstruction - (Authority.CheckedDefinitionEquation _target) -> - pure () - authorization -> + <$> 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 authority " - <> show authorization) + (label <> ": unexpected definition authorities " + <> show authorizations) assertEqual (label <> " theorem adds no object") [] @@ -3821,19 +6528,75 @@ reusesExactSeparationValidation = unusedResolver mounts <- exactFixtureMounts root workspace <- parseExactWorkspace bootstrap mounts relative - freshRuns <- newIORef (0 :: Int) + freshRequests <- newIORef [] + let freshResolver = Declaration.vampireResolver \prepared -> do + modifyIORef' freshRequests + (<> [Provers.preparedTypedProverRequest prepared]) + (Provers.runPreparedTypedProver + (Provers.vampire + executable + Provers.defaultTimeLimit + Provers.defaultMemoryLimit) + prepared) freshModules <- compileParsedWorkspaceWithValidation foundation bootstrap - (countingAcceptedResolver executable freshRuns) + freshResolver Declaration.FreshValidation workspace assertEqual "fresh separation proof runs Vampire once" 1 - =<< readIORef freshRuns + . length + =<< readIORef freshRequests fresh <- sole "fresh exact separation module" freshModules assertExactSeparationModule "fresh cached" fresh + 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)) @@ -3862,6 +6625,12 @@ reusesExactSeparationValidation = =<< readIORef warmRuns warm <- sole "warm exact separation module" warmModules assertExactSeparationModule "warm cached" warm + warmAcceptedRequest <- + acceptedRequestId "warm separation" warm + assertEqual + "warm validation retains the fresh request-byte identity" + freshAcceptedRequest + warmAcceptedRequest assertEqual "warm separation semantic interface" (Module.sealedTypedModuleSemantic fresh) (Module.sealedTypedModuleSemantic warm) @@ -3890,6 +6659,64 @@ reusesExactSeparationValidation = 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 = @@ -4069,8 +6896,7 @@ doesNotTreatMarkerOnlyNounAsSet = do | premise <- Vector.toList locals ] ]) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -4124,8 +6950,7 @@ compilesExactOmittedProofs = calls <- newIORef (0 :: Int) let resolver = Declaration.vampireResolver \prepared -> do modifyIORef' calls (+ 1) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -4285,8 +7110,7 @@ reusesExactEscapeAuthority = acceptedResolver executable runs = Declaration.vampireResolver \prepared -> do modifyIORef' runs (+ 1) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -4464,8 +7288,7 @@ rejectsAfterExactOmittedSubclaim = modifyIORef' calls (+ 1) if runCount < 4 then - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -4802,7 +7625,7 @@ loadsCachedExactProducerForFreshImporter = do (_startup, store) <- Store.openStore path (Identity.theoryId foundation) >>= expectRight - let observer = Api.verificationRequestObserver \_ordinal _request -> + let observer = Verification.verificationRequestObserver \_ordinal _request -> pure () prover = Provers.vampire @@ -4810,15 +7633,14 @@ loadsCachedExactProducerForFreshImporter = do Provers.defaultTimeLimit Provers.defaultMemoryLimit verify mode source = - runNoLoggingT - (Api.verifyWithObserverAndStoreMode + (checkResultWithStore store mode observer prover source) >>= expectRight producer <- - verify Api.FreshStoreValidation + verify Verification.FreshStoreValidation "test/phase5/exact-producer.tex" importer <- - verify Api.WarmStoreValidation + verify Verification.WarmStoreValidation "test/phase5/exact-importer.tex" assertTypedSuccess "fresh producer" producer assertTypedSuccess "warm producer/fresh importer" importer @@ -4958,32 +7780,32 @@ selectsConcurrentModuleFailureDeterministically = do Provers.defaultTimeLimit Provers.defaultMemoryLimit ignored = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\_position _request -> pure ()) select amount = Provers.selectEffectiveJobs (Provers.effectiveJobs amount) (fail "explicit jobs unexpectedly detected processors") reportEntry escape = - ( Api.reportedEscapeKind escape - , locFile (Api.reportedEscapeLocation escape) - , locLine (Api.reportedEscapeLocation escape) + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) ) inspect label expectedPositions - (result, measurements, positions) = do + (result, _slowReport, positions) = do case result of - Api.VerificationFailure report failed -> do + Verification.VerificationFailure report failed -> do assertEqual (label <> " selected earlier failure") "test/phase7/concurrent-earlier.tex" - (locFile (Api.failedVerificationLocation failed)) + (locFile (Verification.failedVerificationLocation failed)) assertEqual (label <> " admitted source prefix") - [ ( Api.ReportedSourceAxiom + [ ( Verification.ReportedSourceAxiom , "test/phase7/concurrent-earlier.tex" , 1 ) ] (reportEntry - <$> Api.verificationDirectEscapes report) + <$> Verification.verificationDirectEscapes report) other -> assertFailure (label <> " did not reject deterministically: " @@ -4996,7 +7818,6 @@ selectsConcurrentModuleFailureDeterministically = do ) | position <- positions ]) - pure measurements runCase label jobsAmount = do let storePath = root Posix.</> (label <> ".sqlite") processLock = root Posix.</> (label <> ".process-lock") @@ -5010,10 +7831,10 @@ selectsConcurrentModuleFailureDeterministically = do -- Seed only the final prelude. The unsupported ordinary -- module cannot publish a root. void - (runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + ( + (checkFileWithStore openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation ignored prover "test/phase3/typed-unsupported.tex") @@ -5034,7 +7855,7 @@ selectsConcurrentModuleFailureDeterministically = do (setOwnerExecutable True permissions) positionsRef <- newIORef [] let observer = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\position _request -> do atomicModifyIORef' positionsRef (\positions -> @@ -5047,36 +7868,21 @@ selectsConcurrentModuleFailureDeterministically = do "later module process" processStarted)) jobs <- select jobsAmount - (result, measurements) <- - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + (result, slowReport) <- + (checkFileWithStoreAndJobs openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation jobs observer prover source) >>= expectRight positions <- readIORef positionsRef - pure (result, measurements, positions) - parallel <- - runCase "parallel" 2 + pure (result, slowReport, positions) + void $ runCase "parallel" 2 >>= inspect "parallel" [(1, 1), (2, 1)] - sequential <- - runCase "sequential" 1 + void $ runCase "sequential" 1 >>= inspect "sequential" [(1, 1)] - assertEqual "parallel module checker bound" - 2 - (Api.verificationMaximumLiveModuleCheckers parallel) - assertEqual "parallel Vampire bound" - 2 - (Api.verificationMaximumLiveVampireProcesses parallel) - assertEqual "sequential module checker reference" - 1 - (Api.verificationMaximumLiveModuleCheckers sequential) - assertEqual "sequential Vampire reference" - 1 - (Api.verificationMaximumLiveVampireProcesses sequential) waitForFileSignal :: String -> FilePath -> Assertion waitForFileSignal label path = do @@ -5113,30 +7919,29 @@ batchesStructureObligationsAtomically = do (Provers.effectiveJobs amount) (fail "explicit jobs unexpectedly detected processors") run openStore jobs observer vampireCommand = - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + (checkFileWithStoreAndJobs openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation jobs observer vampireCommand source) >>= expectRight - inspectFailure label positions (result, measurements) = do + inspectFailure label positions (result, _slowReport) = do case result of - Api.VerificationFailure report failed -> do + Verification.VerificationFailure report failed -> do assertEqual (label <> " selects first consequence") (source, 12) - ( locFile (Api.failedVerificationLocation failed) - , locLine (Api.failedVerificationLocation failed) + ( locFile (Verification.failedVerificationLocation failed) + , locLine (Verification.failedVerificationLocation failed) ) assertEqual (label <> " retains preceding prefix") - [(Api.ReportedSourceAxiom, source, 1)] - [ ( Api.reportedEscapeKind escape - , locFile (Api.reportedEscapeLocation escape) - , locLine (Api.reportedEscapeLocation escape) + [(Verification.ReportedSourceAxiom, source, 1)] + [ ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) ) - | escape <- Api.verificationDirectEscapes report + | escape <- Verification.verificationDirectEscapes report ] other -> assertFailure @@ -5145,28 +7950,21 @@ batchesStructureObligationsAtomically = do assertEqual (label <> " assigns consecutive positions") [(1, 1), (1, 2)] (sort positions) - assertEqual (label <> " observes one two-member batch") - (1, 2, 2) - ( Api.verificationObligationBatchCount measurements - , Api.verificationPreparedObligationCount measurements - , Api.verificationMaximumObligationBatchSize measurements - ) - pure measurements writeAcceptedFixtureVampire executable (_startup, store) <- Store.openStore storePath (Identity.theoryId foundation) >>= expectRight bracket (pure store) Store.closeStore \openStore -> do let ignored = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\_position _request -> pure ()) -- Seed only the confined prelude so this fixture observes exactly -- the ordinary structure module's ready batch. void - (runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + ( + (checkFileWithStore openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation ignored (prover executable) "test/phase3/typed-unsupported.tex") @@ -5179,7 +7977,7 @@ batchesStructureObligationsAtomically = do let laterCompleted = root Posix.</> "later-completed" writeLaterAcceptingVampire executable laterCompleted let parallelObserver = - Api.verificationRequestObserver \position _request -> do + Verification.verificationRequestObserver \position _request -> do let ordinal = Provers.workPositionLocalRequestOrdinal position atomicModifyIORef' parallelPositions @@ -5218,20 +8016,14 @@ batchesStructureObligationsAtomically = do atomically (putTMVar releaseFirst ()) parallelResult <- wait verification positions <- readIORef parallelPositions - parallelMeasurements <- - inspectFailure "parallel" - positions parallelResult - assertEqual "parallel obligations overlap" - 2 - (Api.verificationMaximumLiveVampireProcesses - parallelMeasurements) + inspectFailure "parallel" positions parallelResult sequentialJobs <- select 1 sequentialPositions <- newIORef [] let sequentialCompleted = root Posix.</> "sequential-completed" writeRejectingVampire executable sequentialCompleted let sequentialObserver = - Api.verificationRequestObserver \position _request -> + Verification.verificationRequestObserver \position _request -> atomicModifyIORef' sequentialPositions (\positions -> ( ( Provers.workPositionModuleOrdinal position @@ -5244,13 +8036,8 @@ batchesStructureObligationsAtomically = do run openStore sequentialJobs sequentialObserver (prover executable) sequentialObserved <- readIORef sequentialPositions - sequentialMeasurements <- - inspectFailure "sequential" - sequentialObserved sequentialResult - assertEqual "sequential batch is the semantic reference" - 1 - (Api.verificationMaximumLiveVampireProcesses - sequentialMeasurements) + inspectFailure "sequential" + sequentialObserved sequentialResult -- A rejected sibling wrote neither validation nor a module root: -- the complete batch executes again, while the earlier source @@ -5259,18 +8046,18 @@ batchesStructureObligationsAtomically = do writeAcceptedFixtureVampire executable acceptedPositions <- newIORef [] let acceptedObserver = - Api.verificationRequestObserver \position _request -> + Verification.verificationRequestObserver \position _request -> modifyIORef' acceptedPositions (position :) - (accepted, acceptedMeasurements) <- + (accepted, _acceptedSlowReport) <- run openStore parallelJobs acceptedObserver (prover executable) case accepted of - Api.VerificationCompleted report _presentation -> + Verification.VerificationCompleted report _presentation -> assertEqual "successful retry retains only source axiom" - [Api.ReportedSourceAxiom] - (Api.reportedEscapeKind - <$> Api.verificationDirectEscapes report) + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) other -> assertFailure ("successful structure retry failed: " <> show other) @@ -5278,30 +8065,19 @@ batchesStructureObligationsAtomically = do assertEqual "successful retry executes the complete batch" 2 (length acceptedObserved) - assertEqual "failed declaration published no root" - (1, 1) - ( Api.verificationModuleRootHitCount acceptedMeasurements - , Api.verificationModuleRootMissCount acceptedMeasurements - ) let forbiddenObserver = - Api.verificationRequestObserver \position _request -> + Verification.verificationRequestObserver \position _request -> assertFailure ("warm structure batch invoked Vampire at " <> show position) - (warm, warmMeasurements) <- + (warm, _warmSlowReport) <- run openStore parallelJobs forbiddenObserver (prover unavailable) case warm of - Api.VerificationCompleted{} -> pure () + Verification.VerificationCompleted{} -> pure () other -> assertFailure ("warm structure batch did not install: " <> show other) - assertEqual "warm module hit executes no batch" - (2, 0, 0) - ( Api.verificationModuleRootHitCount warmMeasurements - , Api.verificationModuleRootMissCount warmMeasurements - , Api.verificationVampireRunCount warmMeasurements - ) where awaitSignal label action = do result <- Timeout.timeout 10000000 action @@ -5354,7 +8130,7 @@ speculatesDependentProofObligationsWithoutAdmittingAhead = do Provers.defaultTimeLimit Provers.defaultMemoryLimit ignored = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\_position _request -> pure ()) writeAcceptedFixtureVampire executable (_startup, store) <- @@ -5364,10 +8140,10 @@ speculatesDependentProofObligationsWithoutAdmittingAhead = do -- Seed only the final prelude so the observed work belongs to the -- ordinary proof module. void - (runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + ( + (checkFileWithStore openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation ignored (prover executable) "test/phase3/typed-unsupported.tex") @@ -5381,7 +8157,7 @@ speculatesDependentProofObligationsWithoutAdmittingAhead = do releaseFirst <- newEmptyTMVarIO positionsRef <- newIORef [] let observer = - Api.verificationRequestObserver \position _request -> do + Verification.verificationRequestObserver \position _request -> do let ordinal = Provers.workPositionLocalRequestOrdinal position atomicModifyIORef' positionsRef @@ -5401,10 +8177,10 @@ speculatesDependentProofObligationsWithoutAdmittingAhead = do ("unexpected dependent proof request: " <> show ordinal) withAsync - (runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + ( + (checkFileWithStoreAndJobs openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation jobs observer (prover executable) @@ -5421,49 +8197,41 @@ speculatesDependentProofObligationsWithoutAdmittingAhead = do (awaitSignal "dependent continuation request" (atomically (takeTMVar secondStarted))) atomically (putTMVar releaseFirst ()) - (result, measurements) <- wait checking + (result, _slowReport) <- wait checking case result of - Api.VerificationCompleted report _presentation -> + Verification.VerificationCompleted report _presentation -> assertEqual "only the preceding axiom is reported" - [Api.ReportedSourceAxiom] - (Api.reportedEscapeKind - <$> Api.verificationDirectEscapes report) + [Verification.ReportedSourceAxiom] + (Verification.reportedEscapeKind + <$> Verification.verificationDirectEscapes report) other -> assertFailure ("dependent proof module did not seal: " <> show other) - assertEqual "dependent proof obligations overlap" - 2 - (Api.verificationMaximumLiveVampireProcesses - measurements) positions <- readIORef positionsRef assertEqual "dependent requests retain source positions" [(1, 1), (1, 2)] (sort positions) let forbiddenObserver = - Api.verificationRequestObserver \position _request -> + Verification.verificationRequestObserver \position _request -> assertFailure ("warm dependent proof invoked Vampire at " <> show position) - (warm, warmMeasurements) <- - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + (warm, _warmSlowReport) <- + (checkFileWithStoreAndJobs openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation jobs forbiddenObserver (prover unavailable) source) >>= expectRight case warm of - Api.VerificationCompleted{} -> pure () + Verification.VerificationCompleted{} -> pure () other -> assertFailure ("warm dependent proof did not install: " <> show other) - assertEqual "warm plan executes no live request" - 0 - (Api.verificationVampireRunCount warmMeasurements) where awaitSignal label action = do result <- Timeout.timeout 10000000 action @@ -5487,7 +8255,7 @@ schedulesDiamondAfterSealedImports = do Provers.defaultTimeLimit Provers.defaultMemoryLimit ignored = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\_position _request -> pure ()) writeAcceptedFixtureVampire executable (_startup, store) <- @@ -5496,10 +8264,10 @@ schedulesDiamondAfterSealedImports = do bracket (pure store) Store.closeStore \openStore -> do -- Acquire the final prelude before introducing scheduler gates. void - (runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + ( + (checkFileWithStore openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation ignored (prover executable) "test/phase3/typed-unsupported.tex") @@ -5515,7 +8283,7 @@ schedulesDiamondAfterSealedImports = do let awaitRelease released = atomically (readTVar released >>= check) observer = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\position _request -> case Provers.workPositionModuleOrdinal position of 1 -> do @@ -5534,10 +8302,9 @@ schedulesDiamondAfterSealedImports = do _ -> pure ()) verify vampireCommand requestObserver = - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreModeAndJobs + (checkFileWithStoreAndJobs openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation jobs requestObserver vampireCommand @@ -5574,38 +8341,25 @@ schedulesDiamondAfterSealedImports = do "diamond root started before both branch seals" atomically (writeTVar releaseBranches True) void (await "diamond root" (atomically (takeTMVar rootStarted))) - (coldResult, coldMeasurements) <- wait verification + (coldResult, _coldSlowReport) <- wait verification case coldResult of - Api.VerificationCompleted{} -> pure () + Verification.VerificationCompleted{} -> pure () other -> assertFailure ("cold diamond did not complete: " <> show other) - assertEqual "cold diamond module misses plus prelude hit" - (1, 4) - ( Api.verificationModuleRootHitCount coldMeasurements - , Api.verificationModuleRootMissCount coldMeasurements - ) let forbiddenObserver = - Api.verificationRequestObserver + Verification.verificationRequestObserver (\position _request -> assertFailure ("warm diamond invoked Vampire at " <> show position)) - (warmResult, warmMeasurements) <- + (warmResult, _warmSlowReport) <- verify (prover unavailable) forbiddenObserver case warmResult of - Api.VerificationCompleted{} -> pure () + Verification.VerificationCompleted{} -> pure () other -> assertFailure ("warm diamond did not install: " <> show other) - assertEqual "warm diamond installs each distinct root" - (5, 0) - ( Api.verificationModuleRootHitCount warmMeasurements - , Api.verificationModuleRootMissCount warmMeasurements - ) - assertEqual "warm diamond runs no prover" - 0 - (Api.verificationVampireRunCount warmMeasurements) reportsAdmittedSourceEscapes :: Assertion reportsAdmittedSourceEscapes = do @@ -5615,7 +8369,7 @@ reportsAdmittedSourceEscapes = do executable = root Posix.</> "vampire" unavailable = root Posix.</> "must-not-run-vampire" observer = - Api.verificationRequestObserver \_ordinal _request -> pure () + Verification.verificationRequestObserver \_ordinal _request -> pure () prover path = Provers.vampire path @@ -5627,8 +8381,7 @@ reportsAdmittedSourceEscapes = do >>= expectRight bracket (pure store) Store.closeStore \openStore -> do let verify mode vampirePath source = - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + (checkFileWithStore openStore mode observer @@ -5638,32 +8391,32 @@ reportsAdmittedSourceEscapes = do reportEntries = fmap (\escape -> - ( Api.reportedEscapeKind escape - , locFile (Api.reportedEscapeLocation escape) - , locLine (Api.reportedEscapeLocation escape) + ( Verification.reportedEscapeKind escape + , locFile (Verification.reportedEscapeLocation escape) + , locLine (Verification.reportedEscapeLocation escape) )) - . Api.verificationDirectEscapes + . Verification.verificationDirectEscapes expectedConsumer = - [ ( Api.ReportedSourceAxiom + [ ( Verification.ReportedSourceAxiom , "test/phase5/exact-escape-producer.tex" , 1 ) - , ( Api.ReportedOmitted + , ( Verification.ReportedOmitted , "test/phase5/exact-escape-producer.tex" , 9 ) - , ( Api.ReportedOmitted + , ( Verification.ReportedOmitted , "test/phase5/exact-escape-consumer.tex" , 35 ) ] - (freshResult, freshMeasurements) <- + (freshResult, _freshSlowReport) <- verify - Api.FreshStoreValidation + Verification.FreshStoreValidation executable "test/phase5/exact-escape-consumer.tex" freshReport <- case freshResult of - Api.CompletedWithExplicitGaps report _presentation -> pure report + Verification.CompletedWithExplicitGaps report _presentation -> pure report other -> assertFailure ("fresh escape report did not complete with gaps: " @@ -5672,19 +8425,13 @@ reportsAdmittedSourceEscapes = do assertEqual "fresh direct escapes" expectedConsumer (reportEntries freshReport) - assertEqual "cold acquisition includes prelude and two modules" - (0, 3) - ( Api.verificationModuleRootHitCount freshMeasurements - , Api.verificationModuleRootMissCount freshMeasurements - ) - - (warmResult, warmMeasurements) <- + (warmResult, _warmSlowReport) <- verify - Api.WarmStoreValidation + Verification.WarmStoreValidation unavailable "test/phase5/exact-escape-consumer.tex" warmReport <- case warmResult of - Api.CompletedWithExplicitGaps report _presentation -> pure report + Verification.CompletedWithExplicitGaps report _presentation -> pure report other -> assertFailure ("warm escape report did not complete with gaps: " @@ -5692,27 +8439,19 @@ reportsAdmittedSourceEscapes = do >> fail "unreachable" assertEqual "warm report uses rebound current locations" freshReport warmReport - assertEqual "warm acquisition includes prelude and two modules" - (3, 0) - ( Api.verificationModuleRootHitCount warmMeasurements - , Api.verificationModuleRootMissCount warmMeasurements - ) - assertEqual "warm root hit invokes no Vampire process" - 0 - (Api.verificationVampireRunCount warmMeasurements) void (verify - Api.FreshStoreValidation + Verification.FreshStoreValidation executable "test/phase5/exact-source-axiom.tex") - (failedResult, failedMeasurements) <- + (failedResult, _failedSlowReport) <- verify - Api.WarmStoreValidation + Verification.WarmStoreValidation unavailable "test/phase6/admitted-prefix-failure.tex" failedReport <- case failedResult of - Api.VerificationCheckingFailure report _failure -> pure report + Verification.VerificationCheckingFailure report _failure -> pure report other -> assertFailure ("typed suffix failure was not report-bearing: " @@ -5720,20 +8459,12 @@ reportsAdmittedSourceEscapes = do >> fail "unreachable" assertEqual "failure report retains only admitted source prefix" (take 2 expectedConsumer - <> [ ( Api.ReportedOmitted + <> [ ( Verification.ReportedOmitted , "test/phase6/admitted-prefix-failure.tex" , 7 ) ]) (reportEntries failedReport) - assertEqual "failed root is not counted as acquired" - (2, 0) - ( Api.verificationModuleRootHitCount failedMeasurements - , Api.verificationModuleRootMissCount failedMeasurements - ) - assertEqual "cached prefix failure invokes no Vampire process" - 0 - (Api.verificationVampireRunCount failedMeasurements) classifiesTypedVampireFailures :: Assertion classifiesTypedVampireFailures = do @@ -5742,7 +8473,7 @@ classifiesTypedVampireFailures = do let storePath = root Posix.</> "store.sqlite" executable = root Posix.</> "vampire" observer = - Api.verificationRequestObserver \_ordinal _request -> pure () + Verification.verificationRequestObserver \_ordinal _request -> pure () prover = Provers.vampire executable @@ -5754,10 +8485,9 @@ classifiesTypedVampireFailures = do >>= expectRight bracket (pure store) Store.closeStore \openStore -> do let verify source = - runNoLoggingT - (Api.verifyMeasuredWithObserverAndStoreMode + (checkFileWithStore openStore - Api.WarmStoreValidation + Verification.WarmStoreValidation observer prover source) @@ -5769,20 +8499,21 @@ classifiesTypedVampireFailures = do setPermissions executable (setOwnerExecutable True permissions) expectTypedFailure classify = do - (result, _measurements) <- + (result, slowReport) <- verify "test/phase5/exact-runtime-failure.tex" case result of - Api.VerificationFailure report failed -> do + Verification.VerificationFailure report failed -> do assertEqual "typed failure has no direct escapes" [] - (Api.verificationDirectEscapes report) + (Verification.verificationDirectEscapes report) assertEqual "typed failure retains source location" "test/phase5/exact-runtime-failure.tex" (locFile - (Api.failedVerificationLocation failed)) + (Verification.failedVerificationLocation failed)) classify - (Api.failedVerificationReason failed) - (CommandLine.verificationCommandOutcome result) + (Verification.failedVerificationReason failed) + (CommandLine.verificationCommandOutcome + result slowReport) other -> assertFailure ("typed prover outcome was misclassified: " @@ -5790,7 +8521,7 @@ classifiesTypedVampireFailures = do -- Populate only the confined prelude. The selected ordinary -- module then remains a miss for each classified live failure. - (_preludeResult, _preludeMeasurements) <- + (_preludeResult, _preludeSlowReport) <- verify "test/phase3/typed-unsupported.tex" writeProtocol @@ -5799,7 +8530,7 @@ classifiesTypedVampireFailures = do ] expectTypedFailure \reason outcome -> do case reason of - Api.CountermodelFailure{} -> pure () + Verification.CountermodelFailure{} -> pure () other -> assertFailure ("expected countermodel: " <> show other) case outcome of CommandLine.VerificationRejected{} -> pure () @@ -5811,12 +8542,10 @@ classifiesTypedVampireFailures = do ] expectTypedFailure \reason outcome -> do case reason of - Api.IndeterminateFailure{} -> pure () + Verification.IndeterminateFailure{} -> pure () other -> assertFailure ("expected indeterminate result: " <> show other) case outcome of - CommandLine.ProverFailed - _report _location CommandLine.ProverIndeterminate{} -> - pure () + CommandLine.VerificationRejected{} -> pure () other -> assertFailure ("expected prover failure: " <> show other) writeProtocol @@ -5825,12 +8554,10 @@ classifiesTypedVampireFailures = do ] expectTypedFailure \reason outcome -> do case reason of - Api.ProtocolFailure{} -> pure () + Verification.ProtocolFailure{} -> pure () other -> assertFailure ("expected protocol failure: " <> show other) case outcome of - CommandLine.ProverFailed - _report _location CommandLine.ProverProtocolFailure{} -> - pure () + CommandLine.VerificationRejected{} -> pure () other -> assertFailure ("expected prover failure: " <> show other) writeFile executable "not executable" @@ -5839,38 +8566,35 @@ classifiesTypedVampireFailures = do (setOwnerExecutable False permissions) expectTypedFailure \reason outcome -> do case reason of - Api.TransportFailure{} -> pure () + Verification.TransportFailure{} -> pure () other -> assertFailure ("expected transport failure: " <> show other) case outcome of - CommandLine.ProverFailed - _report _location CommandLine.ProverTransportFailure{} -> - pure () + CommandLine.VerificationRejected{} -> pure () other -> assertFailure ("expected prover failure: " <> show other) retainsExactPrefixBeforeFailure :: Assertion retainsExactPrefixBeforeFailure = do result <- withAcceptedFixtureVampire "felix-exact-failure" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover "test/phase5/exact-failure.tex") case result of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError source (Module.TypedActionFailed (Module.TypedExactCompileFailed - (Exact.ExactUnsupportedDeclarationBody location))) + (Exact.ExactGuardedOpaqueSignature location))) prefix) - , _measurements + , _slowReport ) -> do assertEqual "failed exact source" "test/phase5/exact-failure.tex" (safeRelativePathFilePath (resolvedSourceRelativePath source)) - assertEqual "unsupported declaration line" 5 (locLine location) + assertEqual "unsupported declaration line" 6 (locLine location) assertEqual "earlier exact declaration remains committed" 1 (length (Declaration.pendingModulePrefixBatches prefix)) @@ -5881,21 +8605,20 @@ retainsExactPrefixBeforeFailure = do proofFailure <- withAcceptedFixtureVampire "felix-exact-proof-failure" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover "test/phase5/exact-proof-failure.tex") case proofFailure of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedExactProofFailed (ExactProof.ExactProofGoalStatementMismatch location))) prefix) - , _measurements + , _slowReport ) -> do assertEqual "mismatched assumption line" 10 (locLine location) assertEqual "failed proof publishes no theorem" @@ -5909,19 +8632,18 @@ retainsExactPrefixBeforeFailure = do unmatched <- withAcceptedFixtureVampire "felix-unmatched-proof" \prover -> - runNoLoggingT - (Api.verifyMeasured + (checkFileFresh prover "test/phase5/unmatched-proof.tex") case unmatched of Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError + ( Verification.VerificationCheckingFailure _report + (Verification.VerificationTypedModuleError _source (Module.TypedActionFailed (Module.TypedUnmatchedProof location)) prefix) - , _measurements + , _slowReport ) -> do assertEqual "unmatched proof line" 1 (locLine location) assertEqual "unmatched proof publishes no declaration" @@ -5961,8 +8683,7 @@ retainsExactPrefixBeforeFailure = do modifyIORef' runs (+ 1) if runNumber == 0 then - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -6002,34 +8723,282 @@ retainsExactPrefixBeforeFailure = do _result -> assertFailure "unexpected runtime proof failure" -rejectsNestedExactSetInduction :: Assertion -rejectsNestedExactSetInduction = do - result <- - withAcceptedFixtureVampire "felix-nested-set-induction" \prover -> - runNoLoggingT - (Api.verifyMeasured - prover - "test/phase5/exact-induction-nested.tex") - case result of - Right - ( Api.VerificationCheckingFailure _report - (Api.VerificationTypedModuleError - _source - (Module.TypedActionFailed - (Module.TypedExactProofFailed - (ExactProof.ExactProofSetInductionNotOutermost - location))) - prefix) - , _measurements - ) -> do - assertEqual "nested induction line" 7 (locLine location) - assertBool "failed proof publishes no theorem" - (null (Declaration.pendingModulePrefixBatches prefix)) - Left err -> - assertFailure - ("unexpected nested-induction failure: " <> show err) - Right{} -> - assertFailure "nested exact set induction was admitted" +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 = @@ -6059,8 +9028,8 @@ routesProductionVerification = where verifyFixture executable path = fst - <$> (runNoLoggingT - (Api.verifyMeasured + <$> ( + (checkFileFresh (Provers.vampire executable Provers.defaultTimeLimit @@ -6181,12 +9150,11 @@ installsNonemptyImplicitPreludeEvidence = do request <- expectRight (searchedRoot "test/phase3/typed-producer.tex") workspace <- - fst - <$> (expectRight - =<< Parse.parseSourceWorkspaceMeasuredWithSyntaxInputs - mounts - request - (const [preludeSyntax])) + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) let parsed = Parse.parsedWorkspaceRootModule workspace input <- expectRight (Module.typedModuleInput @@ -6274,8 +9242,7 @@ withAcceptedFixtureVampire label action = finalPreludeResolver :: Declaration.VampireResolver finalPreludeResolver = Declaration.vampireResolver \prepared -> - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire "vampire" Provers.defaultTimeLimit @@ -6289,8 +9256,7 @@ countingAcceptedResolver countingAcceptedResolver executable runs = Declaration.vampireResolver \prepared -> do modifyIORef' runs (+ 1) - runNoLoggingT - (Provers.runPreparedTypedProver + (Provers.runPreparedTypedProver (Provers.vampire executable Provers.defaultTimeLimit @@ -6320,14 +9286,18 @@ prepareExactInductiveFixture relative = do let identified = Module.identifiedPhysicalModule parsed owner = Module.identifiedModuleOwner identified parsedModule = Module.identifiedModuleParsed identified - block <- + (blockIndex, block) <- sole "exact inductive block" - (Parse.identifiedParsedModuleBlocks parsedModule) + [ (index, candidate) + | (index, candidate@Raw.BlockInductive{}) <- + zip [0..] + (Parse.identifiedParsedModuleBlocks parsedModule) + ] let entries = [ Parse.parsedSyntaxOccurrenceEntry occurrence | occurrence <- Parse.identifiedParsedModuleSyntaxOccurrences parsedModule - , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == 0 + , Parse.parsedSyntaxOccurrenceBlockIndex occurrence == blockIndex ] action :: Declaration.ModuleDriver Void @@ -6514,12 +9484,11 @@ parseExactWorkspaceWithPrelude prelude mounts relative = do let preludeSyntax = Module.sealedTypedModuleSyntax prelude - fst - <$> (expectRight - =<< Parse.parseSourceWorkspaceMeasuredWithSyntaxInputs - mounts - request - (const [preludeSyntax])) + expectRight + =<< Parse.parseSourceWorkspaceWithSyntaxInputs + mounts + request + (const [preludeSyntax]) compileParsedWorkspace :: Foundation.CheckedFoundation @@ -6630,15 +9599,133 @@ compileParsedWorkspaceWithReadiness , ordered <> [sealed] ) -assertTypedSuccess :: String -> Api.VerificationResult -> Assertion +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 - Api.VerificationCompleted _report _presentation -> + Verification.VerificationCompleted _report _presentation -> pure () - Api.CompletedWithExplicitGaps _report _presentation -> + Verification.CompletedWithExplicitGaps _report _presentation -> assertFailure (label <> " completed with gaps") - Api.VerificationFailure _report failure -> + Verification.VerificationFailure _report failure -> assertFailure (label <> " failed: " <> show failure) - Api.VerificationCheckingFailure _report failure -> + Verification.VerificationCheckingFailure _report failure -> assertFailure (label <> " failed: " <> show failure) sole :: String -> [value] -> IO value diff --git a/source/Test/Unit/OutputPlan.hs b/source/Felix/Test/Unit/OutputPlan.hs index 45658bf..803b7da 100644 --- a/source/Test/Unit/OutputPlan.hs +++ b/source/Felix/Test/Unit/OutputPlan.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.OutputPlan (unitTests) where +module Felix.Test.Unit.OutputPlan (unitTests) where import Base import Felix.OutputPlan qualified as Output diff --git a/source/Test/Unit/Provers.hs b/source/Felix/Test/Unit/Provers.hs index 1caa97b..f1e3cc1 100644 --- a/source/Test/Unit/Provers.hs +++ b/source/Felix/Test/Unit/Provers.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Provers (unitTests) where +module Felix.Test.Unit.Provers (unitTests) where import Base hiding (Empty) -import Checking.Backend.Problem -import Checking.Core -import Provers +import Felix.Checking.Backend.Problem +import Felix.Checking.Core +import Felix.Provers import Control.Concurrent ( newEmptyMVar @@ -16,9 +16,9 @@ import Control.Concurrent import Control.Exception (bracket) import Control.Exception qualified as Exception import Control.Monad (when) -import Control.Monad.Logger (runNoLoggingT) import Data.IORef - ( newIORef + ( atomicModifyIORef' + , newIORef , readIORef , writeIORef ) @@ -26,6 +26,7 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.Vector qualified as Vector +import Felix.Report.Location (Location(..)) import System.Directory qualified as Directory import System.Exit (ExitCode(..)) import System.FilePath.Posix ((</>)) @@ -49,6 +50,7 @@ unitTests = [ vampireStatusParserTests , vampireClassifierTests , jobsSelectionTests + , slowAtpReportTests , vampireExecutorTests , vampireProcessTests ] @@ -61,37 +63,142 @@ jobsSelectionTests = selected <- selectEffectiveJobs (effectiveJobs 3) (writeIORef detectorCalled True >> pure 99) - jobsSelectionEffectiveJobs selected - `shouldBe` positiveJobs 3 - jobsSelectionDetectedProcessors selected `shouldBe` Nothing - jobsSelectionWasOverridden selected `shouldBe` True + 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) - jobsSelectionEffectiveJobs selected - `shouldBe` positiveJobs expected - jobsSelectionDetectedProcessors selected - `shouldBe` Just detected - jobsSelectionWasOverridden selected `shouldBe` False + selected `shouldBe` positiveJobs expected , testCase "falls back to one after bad detection" do nonPositive <- selectEffectiveJobs Nothing (pure 0) - jobsSelectionEffectiveJobs nonPositive - `shouldBe` positiveJobs 1 - jobsSelectionDetectedProcessors nonPositive `shouldBe` Just 1 + nonPositive `shouldBe` positiveJobs 1 failed <- selectEffectiveJobs Nothing (Exception.throwIO (userError "processor detection failed")) - jobsSelectionEffectiveJobs failed - `shouldBe` positiveJobs 1 - jobsSelectionDetectedProcessors failed `shouldBe` Nothing + 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 "opaque handles complete out of submission order" do + [ 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 @@ -111,18 +218,53 @@ vampireExecutorTests = 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 "bounds live two-worker Vampire invocations" do + , 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=''" @@ -147,17 +289,13 @@ vampireExecutorTests = \executor -> withVampireRequestOwner executor \owner -> do answers <- mapConcurrently (\ordinal -> - runNoLoggingT - (runPreparedTypedProverWithExecutor - owner - (workPosition 1 ordinal) - prepared)) + runPreparedTypedProverWithExecutor + owner + (workPosition 1 ordinal) + testLocation + prepared) [1..4] traverse_ assertProved answers - observed <- vampireExecutorObservation executor - vampireExecutorRunCount observed `shouldBe` 4 - vampireExecutorMaximumLiveCount observed - `shouldBe` 2 , testCase "propagates observer failure to the submitter" do prepared <- preparedTypedTask 0 withFakeVampire @@ -173,11 +311,11 @@ vampireExecutorTests = (userError "observer failed")) \executor -> withVampireRequestOwner executor \owner -> do result <- Exception.try - (runNoLoggingT - (runPreparedTypedProverWithExecutor - owner - (workPosition 1 1) - prepared)) + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) case result of Left (failure :: VampireExecutorFault) -> assertBool @@ -201,29 +339,29 @@ vampireExecutorTests = (\_position _request -> pure ()) \executor -> withVampireRequestOwner executor \owner -> withAsync - (runNoLoggingT - (runPreparedTypedProverWithExecutor - owner - (workPosition 1 1) - prepared)) + (runPreparedTypedProverWithExecutor + owner + (workPosition 1 1) + testLocation + prepared) \running -> do processIds <- waitForProcessIds pidFile + queuedSubmitted <- newEmptyMVar withAsync - (runNoLoggingT - (runPreparedTypedProverWithExecutor + (do + handle <- submitVampireRequest owner (workPosition 2 1) - prepared)) + testLocation + (preparedTypedProverRequest prepared) + putMVar queuedSubmitted () + awaitPreparedVampireRequest + (preparedTypedProverRequest prepared) + handle) \queued -> do - waitForSubmittedCount executor 2 + takeMVar queuedSubmitted cancel queued cancel running - observed <- vampireExecutorObservation - executor - vampireExecutorSubmittedCount observed - `shouldBe` 2 - vampireExecutorRunCount observed - `shouldBe` 1 assertProcessesGone processIds , testCase "explicit cancellation completes queued and running handles" do prepared <- preparedTypedTask 0 @@ -239,22 +377,20 @@ vampireExecutorTests = 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 - afterQueued <- vampireExecutorObservation executor - assertBool - "queued terminal updates final completion" - (isJust - (vampireExecutorFinalCompletionNanoseconds - afterQueued)) + awaitVampireRequest queued + >>= assertCancelled prepared cancelVampireRequest running - awaitVampireRequest running >>= assertCancelled + awaitVampireRequest running + >>= assertCancelled prepared assertProcessesGone processIds , testCase "structured shutdown wakes waiter and full-queue submitter" do prepared <- preparedTypedTask 0 @@ -272,15 +408,18 @@ vampireExecutorTests = 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) @@ -290,12 +429,13 @@ vampireExecutorTests = submitVampireRequest owner (workPosition 1 4) + testLocation (preparedTypedProverRequest prepared) takeMVar submitStarted - waitForSubmittedCount executor 3 pure (waiter, blockedSubmit, processIds) Async.waitCatch waiter >>= \case - Right completion -> assertCancelled completion + Right completion -> + assertCancelled prepared completion Left failure -> assertFailure ("shutdown waiter failed: " <> show failure) @@ -333,23 +473,26 @@ vampireExecutorTests = 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 - waitForSubmittedCount executor 3 putMVar failObserver () awaitFault (awaitVampireRequest first) Async.waitCatch blockedSubmit >>= \case @@ -372,8 +515,10 @@ vampireExecutorTests = handle <- submitVampireRequest owner (workPosition 1 1) + testLocation (preparedTypedProverRequest prepared) completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion case vampireCompletionTerminal completion of VampireProcessFailed ProverLaunchFailed{} -> pure () terminal -> @@ -395,8 +540,10 @@ vampireExecutorTests = handle <- submitVampireRequest owner (workPosition 1 1) + testLocation (preparedTypedProverRequest prepared) completion <- awaitVampireRequest handle + assertCompletionRequest prepared completion case vampireCompletionTerminal completion of VampireProtocolFailed{} -> pure () terminal -> @@ -431,6 +578,7 @@ vampireExecutorTests = handle <- submitVampireRequest owner (workPosition 1 1) + testLocation (preparedTypedProverRequest prepared) completion <- awaitVampireRequest handle case renderVampireTerminalDiagnostic @@ -466,6 +614,17 @@ positiveJobs amount = (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" @@ -593,8 +752,7 @@ vampireProcessTests = , "sleep 1" ] \vampireCommand -> - runNoLoggingT - (runPreparedTypedProver vampireCommand prepared) + runPreparedTypedProver vampireCommand prepared case result of Left (ProverCommunicationFailed _ ProverStdin _) -> pure () @@ -617,10 +775,7 @@ vampireProcessTests = , "exit 0" ] \vampireCommand -> do - runNoLoggingT - (runPreparedTypedProver - vampireCommand - prepared)) + runPreparedTypedProver vampireCommand prepared) case guardedAnswer of Nothing -> assertFailure "prover communication did not finish" @@ -632,8 +787,7 @@ vampireProcessTests = [ "kill -TERM $$" ] \vampireCommand -> - runNoLoggingT - (runPreparedTypedProver vampireCommand prepared) + runPreparedTypedProver vampireCommand prepared case result of Left (ProverTerminatedBySignal @@ -655,10 +809,7 @@ vampireProcessTests = [] \pidFile vampireCommand -> do result <- - runNoLoggingT - (runPreparedTypedProver - vampireCommand - prepared) + runPreparedTypedProver vampireCommand prepared assertTimedOut result processIds <- readProcessIds pidFile assertProcessesGone processIds @@ -670,10 +821,7 @@ vampireProcessTests = ] \pidFile vampireCommand -> do result <- - runNoLoggingT - (runPreparedTypedProver - vampireCommand - prepared) + runPreparedTypedProver vampireCommand prepared case result of Left (ProverOutputLimitExceeded @@ -694,10 +842,7 @@ vampireProcessTests = [] \pidFile vampireCommand -> withAsync - (runNoLoggingT - (runPreparedTypedProver - vampireCommand - prepared)) + (runPreparedTypedProver vampireCommand prepared) \worker -> do processIds <- waitForProcessIds pidFile cancel worker @@ -765,18 +910,29 @@ assertAcceptedRequest :: PreparedTypedProverTask ref local origin global -> VampireCompletion -> Assertion -assertAcceptedRequest prepared completion = +assertAcceptedRequest prepared completion = do + assertCompletionRequest prepared completion case vampireCompletionTerminal completion of - VampireAccepted requestId -> - requestId - `shouldBe` - preparedVerificationRequestId - (preparedTypedProverRequest prepared) + VampireAccepted -> pure () terminal -> assertFailure ("expected an accepted terminal, got " <> show terminal) -assertCancelled :: VampireCompletion -> Assertion -assertCancelled completion = +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 @@ -874,24 +1030,6 @@ waitForProcessIds path = do threadDelay 10000 loop -waitForSubmittedCount :: VampireExecutor -> Int -> Assertion -waitForSubmittedCount executor expected = do - guarded <- Timeout.timeout 10000000 loop - case guarded of - Just () -> - pure () - Nothing -> - assertFailure - ("executor did not submit " <> show expected <> " requests") - where - loop = do - observed <- vampireExecutorObservation executor - if vampireExecutorSubmittedCount observed >= expected - then pure () - else do - threadDelay 10000 - loop - assertProcessesGone :: [ProcessID] -> Assertion assertProcessesGone processIds = do guarded <- Timeout.timeout 10000000 loop @@ -927,8 +1065,7 @@ runFakeVampire scriptLines = (["cat >/dev/null"] <> scriptLines) \vampireCommand -> do prepared <- preparedTypedTask 0 - runNoLoggingT - (runPreparedTypedProver vampireCommand prepared) + runPreparedTypedProver vampireCommand prepared withFakeVampire :: [String] @@ -1005,8 +1142,8 @@ preparedTypedTask factCount = do proposition [] [] - ExplicitGlobalPremises - FirstOrderLocals) + FirstOrderLocals + ExplicitHigherOrderJustification) expectRight (prepareTypedProverTask DirectTask problem) where propositionTerm = diff --git a/source/Test/Unit/Semantic.hs b/source/Felix/Test/Unit/Semantic.hs index 160735c..f62a003 100644 --- a/source/Test/Unit/Semantic.hs +++ b/source/Felix/Test/Unit/Semantic.hs @@ -1,21 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Semantic (unitTests) where +module Felix.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.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic import Felix.Cache.Codec import Felix.Math.Codec import Felix.Module import Felix.Parsed.Identity import Felix.Source import Felix.Source.Content -import Syntax.Interface qualified as Syntax -import Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax +import Felix.Syntax.Abstract qualified as Raw import Data.ByteString (ByteString) import Data.List qualified as List diff --git a/source/Test/Unit/Source.hs b/source/Felix/Test/Unit/Source.hs index 73eaef5..6216381 100644 --- a/source/Test/Unit/Source.hs +++ b/source/Felix/Test/Unit/Source.hs @@ -2,12 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -module Test.Unit.Source (unitTests) where +module Felix.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.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Semantic qualified as Semantic import Felix.Cache.Codec qualified as Cache import Felix.Module qualified as Module import Felix.Parse qualified as Parse @@ -18,7 +18,7 @@ import Felix.Source import Felix.Source.Content qualified as Content import Felix.Source.Graph import Felix.Store qualified as Store -import Report.Location +import Felix.Report.Location ( FileId(..) , FileIdAllocator(..) , Location(..) @@ -30,10 +30,10 @@ import Report.Location , 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 Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt qualified as Adapt +import Felix.Syntax.Interface qualified as Interface +import Felix.Syntax.Token (runLexer) import Control.Exception (bracket, evaluate) import Data.ByteString qualified as ByteString @@ -139,6 +139,8 @@ unitTests = testGroup "Source resolution" , 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 @@ -251,7 +253,7 @@ rejectsPackagedPreludeAsOrdinarySource = do request <- expectRight (searchedRoot (Posix.takeFileName path)) let validate = Prelude.rejectOrdinaryPreludeSourceGraph packaged syntaxInputs = const [] - Parse.parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation + Parse.parseSourceWorkspaceWithSyntaxInputsAndGraphValidation mounts request syntaxInputs validate >>= \case Left (Parse.SourceWorkspaceError @@ -268,7 +270,7 @@ rejectsPackagedPreludeAsOrdinarySource = do store <- openTestStore (temp Posix.</> "store.sqlite") (Identity.theoryId foundation) - Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndGraphValidation store mounts request syntaxInputs validate >>= \case Left (Parse.ParseExecutionWorkspaceError @@ -823,43 +825,23 @@ reusesExactParsedSyntax = (Identity.theoryId foundation) coldCallbacks <- newIORef (0 :: Int) cold <- expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback store mounts request (const []) (\_source _block -> modifyIORef' coldCallbacks (+ 1)) warmCallbacks <- newIORef (0 :: Int) warm <- expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback store mounts request (const []) (\_source _block -> modifyIORef' warmCallbacks (+ 1)) - let coldRoot = Parse.parsedWorkspaceRootModule (fst cold) - warmRoot = Parse.parsedWorkspaceRootModule (fst warm) - coldMeasurements = snd cold - warmMeasurements = snd warm - assertEqual "cold parsed misses" 1 - (Parse.parseMeasurementParsedMissCount coldMeasurements) - assertEqual "cold parser tables" 1 - (Parse.parseMeasurementParserTableMaterializationCount - coldMeasurements) - assertEqual "warm parsed hits" 1 - (Parse.parseMeasurementParsedHitCount warmMeasurements) - assertEqual "warm parsed misses" 0 - (Parse.parseMeasurementParsedMissCount warmMeasurements) - assertEqual "warm tokenization" 0 - (Parse.parseMeasurementTokenizationNanoseconds warmMeasurements) - assertEqual "warm scanning" 0 - (Parse.parseMeasurementScanningNanoseconds warmMeasurements) - assertEqual "warm parsing" 0 - (Parse.parseMeasurementParsingNanoseconds warmMeasurements) - assertEqual "warm parser tables" 0 - (Parse.parseMeasurementParserTableMaterializationCount - warmMeasurements) + let coldRoot = Parse.parsedWorkspaceRootModule cold + warmRoot = Parse.parsedWorkspaceRootModule warm let expectedChunkCount = length (Parse.parsedModuleBlocks warmRoot) assertBool "fixture has source chunks" (expectedChunkCount > 0) - assertEqual "cold structural chunks" expectedChunkCount - (Parse.parseMeasurementChunkCount coldMeasurements) - assertEqual "warm structural chunks" expectedChunkCount - (Parse.parseMeasurementChunkCount warmMeasurements) + assertEqual "cold callbacks" expectedChunkCount + =<< readIORef coldCallbacks + assertEqual "warm callbacks" expectedChunkCount + =<< readIORef warmCallbacks assertEqual "warm blocks" (Parse.parsedModuleBlocks coldRoot) (Parse.parsedModuleBlocks warmRoot) assertEqual "warm occurrences" @@ -939,17 +921,10 @@ invalidatesExactParsedInputs = (Identity.theoryId foundation) let parse = expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs store mounts request (const []) - (coldWorkspace, coldMeasurements) <- parse - (warmWorkspace, warmMeasurements) <- parse - assertEqual "cold graph misses" 2 - (Parse.parseMeasurementParsedMissCount coldMeasurements) - assertEqual "unchanged graph hits" 2 - (Parse.parseMeasurementParsedHitCount warmMeasurements) - assertEqual "unchanged graph builds no parser table" 0 - (Parse.parseMeasurementParserTableMaterializationCount - warmMeasurements) + coldWorkspace <- parse + warmWorkspace <- parse coldNotation <- findParsedModule "notation.tex" coldWorkspace warmNotation <- findParsedModule "notation.tex" warmWorkspace let coldRoot = Parse.parsedWorkspaceRootModule coldWorkspace @@ -962,16 +937,9 @@ invalidatesExactParsedInputs = (Parse.parsedModuleId warmRoot) writeFile entryPath (entry "% formatting-only edit\n") - (editedWorkspace, editedMeasurements) <- parse + editedWorkspace <- parse editedNotation <- findParsedModule "notation.tex" editedWorkspace let editedRoot = Parse.parsedWorkspaceRootModule editedWorkspace - assertEqual "unchanged import hits" 1 - (Parse.parseMeasurementParsedHitCount editedMeasurements) - assertEqual "edited importer misses" 1 - (Parse.parseMeasurementParsedMissCount editedMeasurements) - assertEqual "edited importer builds one parser table" 1 - (Parse.parseMeasurementParserTableMaterializationCount - editedMeasurements) assertEqual "cached import retains identity" (Parse.parsedModuleId warmNotation) (Parse.parsedModuleId editedNotation) @@ -983,16 +951,9 @@ invalidatesExactParsedInputs = (Parse.parsedModulePayload editedRoot) writeFile notationPath (notation "infixr" (2 :: Int)) - (syntaxWorkspace, syntaxMeasurements) <- parse + syntaxWorkspace <- parse syntaxNotation <- findParsedModule "notation.tex" syntaxWorkspace let syntaxRoot = Parse.parsedWorkspaceRootModule syntaxWorkspace - assertEqual "syntax edit invalidates both modules" 0 - (Parse.parseMeasurementParsedHitCount syntaxMeasurements) - assertEqual "syntax edit reparses both modules" 2 - (Parse.parseMeasurementParsedMissCount syntaxMeasurements) - assertEqual "syntax edit builds both parser tables" 2 - (Parse.parseMeasurementParserTableMaterializationCount - syntaxMeasurements) assertBool "local syntax identity changes" ( Interface.moduleSyntaxAssertedId (Parse.parsedModuleSyntaxInterface editedNotation) @@ -1023,23 +984,16 @@ rebindsRelocatedParsedArtifacts = foundation <- expectRight Foundation.checkedFoundation let theory = Identity.theoryId foundation store <- openTestStore (temp Posix.</> "store.sqlite") theory - (firstWorkspace, firstMeasurements) <- expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs + firstWorkspace <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs store firstMounts request (const []) - (secondWorkspace, secondMeasurements) <- expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs + 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 "first owner misses" 1 - (Parse.parseMeasurementParsedMissCount firstMeasurements) - assertEqual "relocated owner hits" 1 - (Parse.parseMeasurementParsedHitCount secondMeasurements) - assertEqual "relocated owner builds no parser table" 0 - (Parse.parseMeasurementParserTableMaterializationCount - secondMeasurements) assertEqual "relocation retains parsed identity" (Parse.parsedModuleId first) (Parse.parsedModuleId second) @@ -1087,8 +1041,8 @@ rejectsCorruptedCachedDeclarationAnchor = let storePath = temp Posix.</> "store.sqlite" theory = Identity.theoryId foundation store <- openTestStore storePath theory - (cold, _measurements) <- expectParseExecution - =<< Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs + cold <- expectParseExecution + =<< Parse.parseSourceWorkspaceWithStoreAndSyntaxInputs store mounts request (const []) let parsed = Parse.parsedWorkspaceRootModule cold key = Parse.parsedModuleKey parsed @@ -1135,7 +1089,7 @@ rejectsCorruptedCachedDeclarationAnchor = SQLite.close connection current <- openTestStore storePath theory callbacks <- newIORef (0 :: Int) - Parse.parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback + Parse.parseSourceWorkspaceWithStoreAndSyntaxInputsAndCallback current mounts request (const []) (\_source _block -> modifyIORef' callbacks (+ 1)) >>= \case Left @@ -2298,6 +2252,49 @@ returnsSourceParseFailures = 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 diff --git a/source/Test/Unit/Store.hs b/source/Felix/Test/Unit/Store.hs index e2896c3..423204c 100644 --- a/source/Test/Unit/Store.hs +++ b/source/Felix/Test/Unit/Store.hs @@ -1,15 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Test.Unit.Store (unitTests) where +module Felix.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.Checking.Authority qualified as Authority +import Felix.Checking.Core qualified as Core +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Typed +import Felix.Checking.Semantic qualified as Semantic import Felix.Cache.Codec qualified as Cache import Felix.Math.Codec import Felix.Module @@ -18,8 +18,8 @@ import Felix.Parsed.Payload qualified as ParsedPayload import Felix.Source.Content qualified as Content import Felix.Source import Felix.Store qualified as Store -import Provers qualified -import Syntax.Interface qualified as Syntax +import Felix.Provers qualified as Provers +import Felix.Syntax.Interface qualified as Syntax import Control.Concurrent (threadDelay) import Control.Exception qualified as Exception diff --git a/source/Test/Unit/Token.hs b/source/Felix/Test/Unit/Token.hs index d399e2a..00c6755 100644 --- a/source/Test/Unit/Token.hs +++ b/source/Felix/Test/Unit/Token.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Unit.Token (unitTests) where +module Felix.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 Felix.Report.Location +import Felix.Syntax.Adapt +import Felix.Syntax.Abstract (Associativity(..)) +import Felix.Syntax.Interface +import Felix.Syntax.Pragma +import Felix.Syntax.Token import Data.Text qualified as Text import Test.Tasty diff --git a/source/Felix/Verification.hs b/source/Felix/Verification.hs new file mode 100644 index 0000000..716beea --- /dev/null +++ b/source/Felix/Verification.hs @@ -0,0 +1,1157 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} + +module Felix.Verification + ( VerificationSession + , VerificationSessionError(..) + , withVerificationSession + , withVerificationSessionUsingStore + , CheckRequest(..) + , CheckOutcome(..) + , checkWorkspace + , StoreValidationMode(..) + , WorkPosition + , workPosition + , workPositionModuleOrdinal + , workPositionLocalRequestOrdinal + , VerificationRequestObserver + , verificationRequestObserver + , PreparedVerificationRequest + , SlowAtpOutcome(..) + , SlowAtpTask(..) + , SlowAtpReport(..) + , slowAtpOmittedTaskCount + , ProverAnswer + ( CounterSatisfiable + , ContradictoryAxioms + , Uncertain + , Error + ) + , pattern Yes + , VerificationResult(..) + , VerificationPresentation + , verificationHtmlPresentation + , ReportedEscapeKind(..) + , ReportedEscape(..) + , VerificationReport(..) + , VerificationDriverError(..) + , VerificationDriverErrorKind(..) + , verificationDriverErrorKind + , renderVerificationDriverError + , FailedVerification(..) + , VerificationFailureReason(..) + ) where + + +import Base +import Felix.Checking.Declaration qualified as Declaration +import Felix.Checking.Foundation qualified as Foundation +import Felix.Checking.Identity qualified as Identity +import Felix.Checking.Module qualified as Typed +import Felix.Checking.Semantic qualified as Semantic +import Felix.Module (localDeclarationOrdinal) +import Felix.Parse (ParseWorkspaceError(..), ParsedSourceWorkspace) +import Felix.Parse qualified as Felix +import Felix.Prelude qualified as Prelude +import Felix.Provers +import Felix.Source +import Felix.Source.Graph (ResolvedSourceGraph) +import Felix.Store qualified as Store +import Felix.Render.Html.Export qualified as HtmlExport +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Interface qualified as Syntax + +import Control.Exception qualified as Exception +import Control.Monad (unless) +import Data.Bifunctor (first) +import Data.IORef (atomicModifyIORef', newIORef) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Numeric.Natural (Natural) +import UnliftIO.Async qualified as Async + +data VerificationResult + = VerificationCompleted + !VerificationReport + !VerificationPresentation + | CompletedWithExplicitGaps + !VerificationReport + !VerificationPresentation + | VerificationFailure !VerificationReport !FailedVerification + | VerificationCheckingFailure + !VerificationReport + !VerificationDriverError + deriving (Show) + +-- | Strict owner-independent source presentation retained only after the +-- complete typed workspace succeeds. +data VerificationPresentation = VerificationPresentation + !HtmlExport.HtmlPresentation + +instance Show VerificationPresentation where + show _presentation = + "VerificationPresentation <HTML presentation>" + +verificationHtmlPresentation + :: VerificationPresentation + -> HtmlExport.HtmlPresentation +verificationHtmlPresentation (VerificationPresentation presentation) = + presentation + +data ReportedEscapeKind + = ReportedSourceAxiom + | ReportedOmitted + deriving (Show, Eq) + +data ReportedEscape = ReportedEscape + { reportedEscapeKind :: !ReportedEscapeKind + , reportedEscapeLocation :: !Location + } + deriving (Show, Eq) + +data VerificationReport = VerificationReport + { verificationDirectEscapes :: ![ReportedEscape] + } + deriving (Show, Eq) + +newtype VerificationRequestObserver = VerificationRequestObserver + { observeVerificationRequest + :: WorkPosition + -> PreparedVerificationRequest + -> IO () + } + +verificationRequestObserver + :: (WorkPosition + -> PreparedVerificationRequest + -> IO ()) + -> VerificationRequestObserver +verificationRequestObserver = + VerificationRequestObserver + +data FailedVerification = FailedVerification + { failedVerificationLocation :: !Location + , failedVerificationReason :: !VerificationFailureReason + } + deriving (Show) + +data VerificationFailureReason + = CountermodelFailure !Text + | ContradictoryInputFailure !Text + | IndeterminateFailure !Text + | ProtocolFailure !Text !Text + | TransportFailure !ProverProcessError + deriving (Show) + +verificationFailureReason + :: Either ProverProcessError ProverAnswer + -> Maybe VerificationFailureReason +verificationFailureReason = \case + Left processError -> + Just (TransportFailure processError) + Right Yes -> + Nothing + Right (CounterSatisfiable tptp) -> + Just (CountermodelFailure tptp) + Right (ContradictoryAxioms tptp) -> + Just (ContradictoryInputFailure tptp) + Right (Uncertain tptp) -> + Just (IndeterminateFailure tptp) + Right (Error taskLabel message) -> + Just (ProtocolFailure taskLabel message) + +data VerificationDriverError + = VerificationWorkspaceError + !ParseWorkspaceError + | VerificationMissingImportedModule + !ResolvedSourceAddress + | VerificationMissingRootModule + !ResolvedSourceAddress + | VerificationFinalPreludeReadinessError + !Typed.FinalPreludeReadinessError + | VerificationTypedInputError + !ResolvedSource + !Typed.TypedModuleInputError + | VerificationTypedOpenError + !ResolvedSource + !Declaration.DriverOpenError + | VerificationTypedCachedModuleError + !ResolvedSource + !Typed.CachedTypedModuleError + | VerificationTypedModuleError + !ResolvedSource + !Typed.TypedModuleFailure + !Declaration.PendingModulePrefix + | VerificationValidationIntegrityError + !ResolvedSource + !Declaration.ValidationIntegrityError + | VerificationAdmittedViewError + !ResolvedSource + !AdmittedViewError + | VerificationParsedArtifactIntegrityError + !ResolvedSource + !Felix.ParsedArtifactIntegrityError + | VerificationStoreFailure !Store.StoreFailure + | VerificationModuleArtifactKeyError !Semantic.ModuleArtifactKeyError + | VerificationModuleSchedulerInvariant !Text + deriving (Show) + +instance Exception.Exception VerificationDriverError + +data VerificationDriverErrorKind + = VerificationSourceFailure + | VerificationInfrastructureFailure + deriving (Show, Eq) + +verificationDriverErrorKind + :: VerificationDriverError + -> VerificationDriverErrorKind +verificationDriverErrorKind = \case + VerificationWorkspaceError{} -> VerificationSourceFailure + VerificationTypedInputError{} -> VerificationSourceFailure + VerificationTypedModuleError _source failure _prefix -> + case failure of + Typed.TypedActionFailed{} -> VerificationSourceFailure + _ -> VerificationInfrastructureFailure + VerificationMissingImportedModule{} -> VerificationInfrastructureFailure + VerificationMissingRootModule{} -> VerificationInfrastructureFailure + VerificationFinalPreludeReadinessError{} -> + VerificationInfrastructureFailure + VerificationTypedOpenError{} -> VerificationInfrastructureFailure + VerificationTypedCachedModuleError{} -> VerificationInfrastructureFailure + VerificationValidationIntegrityError{} -> + VerificationInfrastructureFailure + VerificationAdmittedViewError{} -> VerificationInfrastructureFailure + VerificationParsedArtifactIntegrityError{} -> + VerificationInfrastructureFailure + VerificationStoreFailure{} -> VerificationInfrastructureFailure + VerificationModuleArtifactKeyError{} -> + VerificationInfrastructureFailure + VerificationModuleSchedulerInvariant{} -> + VerificationInfrastructureFailure + +renderVerificationDriverError :: VerificationDriverError -> Text +renderVerificationDriverError = \case + VerificationWorkspaceError failure -> + "Verification input failed: " + <> Felix.renderParseWorkspaceError failure + VerificationTypedInputError source failure -> + "Typed module input failed in " + <> resolvedSourceDisplay source + <> ": " <> Typed.renderTypedModuleInputError failure + VerificationTypedOpenError source failure -> + "Typed module startup failed in " + <> resolvedSourceDisplay source + <> ": " <> Declaration.renderDriverOpenError failure + VerificationTypedCachedModuleError source failure -> + "Cached typed module is invalid in " + <> resolvedSourceDisplay source + <> ": " <> Typed.renderCachedTypedModuleError failure + VerificationTypedModuleError source failure _prefix -> + "Typed module checking failed in " + <> resolvedSourceDisplay source + <> ": " <> Typed.renderTypedModuleFailure failure + VerificationValidationIntegrityError source failure -> + "Typed module validation store is inconsistent in " + <> resolvedSourceDisplay source + <> ": " <> Declaration.renderValidationIntegrityError failure + VerificationAdmittedViewError source failure -> + "Typed admitted-source association is inconsistent in " + <> resolvedSourceDisplay source + <> ": " <> Text.pack (show failure) + VerificationParsedArtifactIntegrityError source failure -> + "Parsed artifact is inconsistent in " + <> resolvedSourceDisplay source + <> ": " <> Text.pack (show failure) + VerificationStoreFailure failure -> + "Verification store failed: " <> Store.renderStoreFailure failure + VerificationModuleArtifactKeyError{} -> + "Typed module artifact inputs are inconsistent." + VerificationModuleSchedulerInvariant message -> + "Typed module scheduler invariant failed: " <> message + VerificationMissingImportedModule address -> + "Verification could not find checked imported module " + <> Text.pack (show address) <> "." + VerificationMissingRootModule address -> + "Verification could not find checked root module " + <> Text.pack (show address) <> "." + VerificationFinalPreludeReadinessError{} -> + "The packaged final prelude failed." + +resolvedSourceDisplay :: ResolvedSource -> Text +resolvedSourceDisplay source = + sourceMountIdText (resolvedSourceMount source) + <> ":" + <> Text.pack (resolvedSourceLocationPath source) + +data TypedWorkspaceOutcome + = TypedWorkspaceSucceeded + !AdmittedTypedWorkspace + | TypedWorkspaceRejected + !AdmittedTypedWorkspace + !TypedWorkspaceFailure + +data TypedWorkspaceFailure + = TypedWorkspaceCheckingRejected !VerificationDriverError + | TypedWorkspaceProverRejected !FailedVerification + +data ModuleTask = ModuleTask + { moduleTaskOrdinal :: !Natural + , moduleTaskParsed :: !Felix.ParsedModule + , moduleTaskDirectAddresses :: ![ResolvedSourceAddress] + } + +data ModuleCheckResult + = ModuleCheckSucceeded + !ResolvedSourceAddress + !Typed.SealedTypedModule + !AdmittedTypedModule + | ModuleCheckRejected + !AdmittedTypedModule + !TypedWorkspaceFailure + +data ModuleFailureCandidate = ModuleFailureCandidate + !Natural + !AdmittedTypedModule + !TypedWorkspaceFailure + +data AdmittedTypedDeclaration = AdmittedTypedDeclaration + !Semantic.DeclarationSlot + !Typed.TypedSourceDeclaration + +newtype AdmittedTypedModule = AdmittedTypedModule + [AdmittedTypedDeclaration] + +newtype AdmittedTypedWorkspace = AdmittedTypedWorkspace + [AdmittedTypedModule] + +data AdmittedViewError + = AdmittedDeclarationCountMismatch + !Int + !Int + | AdmittedDeclarationSlotMismatch + ![Semantic.DeclarationSlot] + ![Semantic.DeclarationSlot] + deriving (Show, Eq) + +completeAdmittedModule + :: Typed.IdentifiedModuleInput + -> AdmittedTypedModule +completeAdmittedModule input = + AdmittedTypedModule + (uncurry AdmittedTypedDeclaration <$> expectedDeclarations input) + +checkedAdmittedModule + :: Bool + -> Typed.IdentifiedModuleInput + -> Declaration.PendingModulePrefix + -> Either AdmittedViewError AdmittedTypedModule +checkedAdmittedModule requireComplete input prefix = do + let expected = expectedDeclarations input + expectedSlots = fst <$> expected + actualSlots = + Declaration.committedBatchSlot + <$> Declaration.pendingModulePrefixBatches prefix + admittedCount = length actualSlots + if requireComplete + then unless + (admittedCount == length expected) + (Left + (AdmittedDeclarationCountMismatch + (length expected) + admittedCount)) + else unless + (admittedCount <= length expected) + (Left + (AdmittedDeclarationCountMismatch + (length expected) + admittedCount)) + unless + (actualSlots == take admittedCount expectedSlots) + (Left + (AdmittedDeclarationSlotMismatch + (take admittedCount expectedSlots) + actualSlots)) + pure + (AdmittedTypedModule + [ AdmittedTypedDeclaration slot declaration + | (slot, declaration) <- take admittedCount expected + ]) + +expectedDeclarations + :: Typed.IdentifiedModuleInput + -> [(Semantic.DeclarationSlot, Typed.TypedSourceDeclaration)] +expectedDeclarations input = + zipWith + (\ordinal declaration -> + ( Semantic.declarationSlot + (Typed.identifiedModuleOwner input) + (localDeclarationOrdinal ordinal) + , declaration + )) + [0..] + (Typed.typedSourceDeclarations + (Typed.identifiedModuleParsed input)) + +data StoreValidationMode + = FreshStoreValidation + | WarmStoreValidation + deriving (Show, Eq) + +data VerificationSession = VerificationSession + !Foundation.CheckedFoundation + !Store.Store + +data VerificationSessionError + = VerificationSessionFoundationError + !(NonEmpty Foundation.FoundationManifestError) + | VerificationSessionStoreError !Store.StoreLifecycleError + | VerificationSessionTheoryMismatch !Identity.TheoryId !Identity.TheoryId + deriving (Show) + +withVerificationSession + :: Store.StoreLease + -> (VerificationSession -> IO value) + -> IO (Either VerificationSessionError value) +withVerificationSession lease action = + case Foundation.checkedFoundation of + Left failure -> + pure (Left (VerificationSessionFoundationError failure)) + Right foundation -> do + opened <- Store.withOpenStore + lease + (Identity.theoryId foundation) + (\_startup store -> + action (VerificationSession foundation store)) + pure (first VerificationSessionStoreError opened) + +-- | Borrow an already-open store while preserving the session's +-- foundation/store identity invariant. The caller retains ownership of the +-- store lifetime; ordinary hosts should prefer 'withVerificationSession'. +withVerificationSessionUsingStore + :: Store.Store + -> (VerificationSession -> IO value) + -> IO (Either VerificationSessionError value) +withVerificationSessionUsingStore store action = + case Foundation.checkedFoundation of + Left failure -> + pure (Left (VerificationSessionFoundationError failure)) + Right foundation -> + let expected = Identity.theoryId foundation + actual = Store.storeTheoryId store + in if expected == actual + then Right <$> action (VerificationSession foundation store) + else pure + (Left + (VerificationSessionTheoryMismatch expected actual)) + +data CheckRequest = CheckRequest + { checkSourceGraph :: !ResolvedSourceGraph + , checkStoreValidationMode :: !StoreValidationMode + , checkEffectiveJobs :: !EffectiveJobs + , checkVampire :: !Vampire + , checkRequestObserver :: !VerificationRequestObserver + } + +data CheckOutcome = CheckOutcome + { checkVerificationResult :: !VerificationResult + , checkSlowAtpReport :: !SlowAtpReport + } + deriving (Show) + +checkWorkspace + :: VerificationSession + -> CheckRequest + -> IO (Either VerificationDriverError CheckOutcome) +checkWorkspace session request = + Exception.try (checkWorkspaceThrowing session request) + +checkWorkspaceThrowing + :: VerificationSession + -> CheckRequest + -> IO CheckOutcome +checkWorkspaceThrowing + (VerificationSession foundation store) + request = do + memo <- Store.newStoreMemo store + storeCoordinator <- Store.newStoreCoordinator + withVampireExecutor + (checkEffectiveJobs request) + (checkVampire request) + (observeVerificationRequest (checkRequestObserver request)) + \executor -> do + prelude <- withVampireRequestOwner executor \owner -> do + preludeResolver <- typedVampireResolver owner 0 + Typed.acquireFinalPreludeSession + memo store foundation preludeResolver + >>= either + (throwIO . VerificationFinalPreludeReadinessError) + pure + let preludeSyntax = + Typed.sealedTypedModuleSyntax + (Typed.finalPreludeModule prelude) + syntaxInputs _source = [preludeSyntax] + parsed <- + Felix.parseResolvedSourceGraphWithStoreAndSyntaxInputsAndGraphValidation + store + (checkSourceGraph request) + syntaxInputs + (Prelude.rejectOrdinaryPreludeSourceGraph + (Typed.finalPreludeSource prelude)) + >>= either throwParseExecutionError pure + admittedResult <- + checkTypedWorkspace + memo + storeCoordinator + foundation + prelude + executor + (checkEffectiveJobs request) + (checkStoreValidationMode request) + parsed + store + slowReport <- vampireExecutorSlowAtpReport executor + let result = + case admittedResult of + TypedWorkspaceRejected admitted failure -> + let report = admittedWorkspaceReport admitted + in case failure of + TypedWorkspaceCheckingRejected checkingFailure -> + VerificationCheckingFailure + report checkingFailure + TypedWorkspaceProverRejected proverFailure -> + VerificationFailure report proverFailure + TypedWorkspaceSucceeded admitted -> + completedResult + (admittedWorkspaceReport admitted) + (VerificationPresentation + (HtmlExport.htmlPresentationFromParsedWorkspace + parsed)) + pure (CheckOutcome result slowReport) + where + throwParseExecutionError = \case + Felix.ParseExecutionWorkspaceError failure -> + throwIO (VerificationWorkspaceError failure) + Felix.ParseExecutionStoreFailure failure -> + throwIO (VerificationStoreFailure failure) + Felix.ParseExecutionArtifactIntegrityFailure source failure -> + throwIO + (VerificationParsedArtifactIntegrityError source failure) + +checkTypedWorkspace + :: Store.StoreMemo + -> Store.StoreCoordinator + -> Foundation.CheckedFoundation + -> Typed.FinalPreludeSession + -> VampireExecutor + -> EffectiveJobs + -> StoreValidationMode + -> ParsedSourceWorkspace + -> Store.Store + -> IO TypedWorkspaceOutcome +checkTypedWorkspace + memo + storeCoordinator + foundation + prelude + executor + selectedJobs + validationMode + workspace + store = do + let modules = + zipWith + makeTask + [1..] + (toList + (Felix.parsedWorkspaceImportedBeforeImporter workspace)) + rootAddress = + Felix.parsedModuleAddress + (Felix.parsedWorkspaceRootModule workspace) + scheduleModules + rootAddress + modules + Map.empty + Map.empty + Map.empty + Nothing + where + workerBound = effectiveJobsValue selectedJobs + + makeTask ordinal parsed = + ModuleTask + { moduleTaskOrdinal = ordinal + , moduleTaskParsed = parsed + , moduleTaskDirectAddresses = + nubOrd + (Felix.parsedImportedAddress + <$> Felix.parsedModuleImports parsed) + } + + scheduleModules + rootAddress + pending + running + sealedByAddress + admittedByOrdinal + candidate = do + (pending', running') <- + startReadyModules + pending + running + sealedByAddress + candidate + Exception.onException + (if Map.null running' + then case candidate of + Just selected + | any + (\task -> + moduleTaskOrdinal task + < candidateOrdinal selected) + pending' -> + throwIO + (VerificationModuleSchedulerInvariant + "an earlier module is not terminal") + | otherwise -> + pure + (TypedWorkspaceRejected + (admittedWorkspaceThrough + admittedByOrdinal + selected) + (candidateFailure selected)) + Nothing + | null pending' -> do + unless + (Map.member rootAddress sealedByAddress) + (throwIO + (VerificationMissingRootModule + rootAddress)) + pure + (TypedWorkspaceSucceeded + (completeAdmittedWorkspace + admittedByOrdinal)) + | otherwise -> + throwIO + (VerificationModuleSchedulerInvariant + "no ready module and no running module") + else do + (_completedAsync, (ordinal, completed)) <- + Async.waitAny (Map.elems running') + let runningWithoutCompleted = + Map.delete ordinal running' + case completed of + Left fatal -> do + cancelModuleCheckers runningWithoutCompleted + Exception.throwIO fatal + Right (ModuleCheckSucceeded + address sealed admittedModule) -> + scheduleModules + rootAddress + pending' + runningWithoutCompleted + (Map.insert address sealed sealedByAddress) + (Map.insert + ordinal + admittedModule + admittedByOrdinal) + candidate + Right (ModuleCheckRejected + admittedModule failure) -> do + let selected = + chooseEarlierFailure + candidate + (ModuleFailureCandidate + ordinal + admittedModule + failure) + cutoff = candidateOrdinal selected + (later, retained) = + Map.partitionWithKey + (\runningOrdinal _async -> + runningOrdinal > cutoff) + runningWithoutCompleted + cancelModuleCheckers later + scheduleModules + rootAddress + pending' + retained + sealedByAddress + admittedByOrdinal + (Just selected) + ) + (cancelModuleCheckers running') + + startReadyModules + pending + running + sealedByAddress + candidate + | Map.size running >= workerBound = + pure (pending, running) + | otherwise = + case extractFirstReady candidate sealedByAddress pending of + Nothing -> + pure (pending, running) + Just (task, remaining) -> do + checker <- Async.async do + completed <- + (Exception.try + (checkModule task sealedByAddress) + :: IO + (Either + Exception.SomeException + ModuleCheckResult)) + pure (moduleTaskOrdinal task, completed) + startReadyModules + remaining + (Map.insert + (moduleTaskOrdinal task) + checker + running) + sealedByAddress + candidate + + checkModule task sealedByAddress = + withVampireRequestOwner executor \requestOwner -> do + let parsed = moduleTaskParsed task + source = Felix.parsedModuleResolved parsed + address = Felix.parsedModuleAddress parsed + direct <- + traverse + (\directAddress -> + maybe + (throwIO + (VerificationMissingImportedModule + directAddress)) + pure + (Map.lookup directAddress sealedByAddress)) + (moduleTaskDirectAddresses task) + resolver <- + typedVampireResolver + requestOwner + (moduleTaskOrdinal task) + input <- + either + (throwIO . VerificationTypedInputError source) + pure + (Typed.typedModuleInput + foundation + (Typed.finalPreludeReadiness prelude) + resolver + validationRun + parsed + direct) + loadCachedModule parsed direct >>= \case + Just sealed -> do + pure + (ModuleCheckSucceeded + address + sealed + (completeAdmittedModule + (Typed.identifiedPhysicalModule parsed))) + Nothing -> do + typedResult <- + Exception.catch + (Typed.runTypedModule input) + (\failure -> + throwIO + (VerificationValidationIntegrityError + source + failure)) + case typedResult of + Typed.TypedModuleOpenFailed err -> + throwIO (VerificationTypedOpenError source err) + Typed.TypedModuleFailed err prefix -> do + let driverFailure = + VerificationTypedModuleError + source err prefix + case classifyTypedModuleFailure err of + TypedIntegrityFailure -> + throwIO driverFailure + TypedCheckingRejection -> + reportFailure + parsed + prefix + (TypedWorkspaceCheckingRejected + driverFailure) + TypedVerificationRejection failed -> + reportFailure + parsed + prefix + (TypedWorkspaceProverRejected failed) + TypedProverFailure failed -> + reportFailure + parsed + prefix + (TypedWorkspaceProverRejected failed) + Typed.TypedModuleSucceeded sealed -> do + admittedModule <- + either + (throwIO + . VerificationAdmittedViewError source) + pure + (checkedAdmittedModule + True + (Typed.identifiedPhysicalModule parsed) + (Typed.sealedTypedModulePrefix sealed)) + persistSealed + (Typed.identifiedPhysicalModule parsed) + sealed + pure + (ModuleCheckSucceeded + address sealed admittedModule) + + reportFailure parsed prefix failure = do + let source = Felix.parsedModuleResolved parsed + admittedModule <- + either + (throwIO . VerificationAdmittedViewError source) + pure + (checkedAdmittedModule + False + (Typed.identifiedPhysicalModule parsed) + prefix) + Store.withStoreCoordinator storeCoordinator + (Store.writePendingModulePrefix store prefix) + >>= either + (throwIO . VerificationStoreFailure) + pure + pure (ModuleCheckRejected admittedModule failure) + + storeValidationLookup lookupStore = + Declaration.validationLookup + (\key -> + Store.withStoreCoordinator storeCoordinator + (Store.loadProofValidation lookupStore key) + >>= either + (throwIO . VerificationStoreFailure) + pure) + (\key -> + Store.withStoreCoordinator storeCoordinator + (Store.loadDeclarationValidation lookupStore key) + >>= either + (throwIO . VerificationStoreFailure) + pure) + + validationRun = + case validationMode of + FreshStoreValidation -> + Declaration.FreshValidation + WarmStoreValidation -> + Declaration.WarmValidation + (storeValidationLookup store) + + persistSealed input sealed = do + artifactKey <- + either + (throwIO . VerificationModuleArtifactKeyError) + pure + (Semantic.moduleArtifactKey + (Typed.identifiedModuleOwner input) + (Felix.identifiedParsedModuleId + (Typed.identifiedModuleParsed input)) + (Semantic.semanticInterfaceDirectInputs + (Typed.sealedTypedModuleSemantic sealed)) + (Identity.theoryId foundation)) + let artifact = + Semantic.moduleArtifactResult + artifactKey + (Syntax.moduleSyntaxAssertedId + (Typed.sealedTypedModuleSyntax sealed)) + (Semantic.semanticInterfaceAssertedId + (Typed.sealedTypedModuleSemantic sealed)) + acknowledged <- + Store.withStoreCoordinator storeCoordinator + (Store.writeSealedModule + store + (Typed.sealedTypedModulePrefix sealed) + [Typed.sealedTypedModuleSyntax sealed] + [Typed.sealedTypedModuleSemantic sealed] + artifact) + >>= either + (throwIO . VerificationStoreFailure) + pure + unless + (acknowledged == artifact) + (throwIO + (VerificationStoreFailure + Store.StoreModuleArtifactIdMismatch)) + + loadCachedModule parsed direct = + case validationMode of + WarmStoreValidation -> do + let owner = + Typed.identifiedModuleOwner + (Typed.identifiedPhysicalModule parsed) + directSemantic = + Semantic.semanticInterfaceAssertedId + (Typed.sealedTypedModuleSemantic + (Typed.finalPreludeModule prelude)) + : ( Semantic.semanticInterfaceAssertedId + . Typed.sealedTypedModuleSemantic + <$> direct + ) + artifactKey <- + either + (throwIO . VerificationModuleArtifactKeyError) + pure + (Semantic.moduleArtifactKey + owner + (Felix.identifiedParsedModuleId + (Typed.identifiedModuleParsed + (Typed.identifiedPhysicalModule parsed))) + directSemantic + (Identity.theoryId foundation)) + loaded <- + Store.withStoreCoordinator storeCoordinator + (Store.loadCachedModuleInstallation + memo + store + artifactKey + (Syntax.moduleSyntaxAssertedId + (Felix.parsedModuleSyntaxInterface parsed))) + case loaded of + Left failure -> + throwIO (VerificationStoreFailure failure) + Right Nothing -> + pure Nothing + Right (Just installation) -> + either + (throwIO + . VerificationTypedCachedModuleError + (Felix.parsedModuleResolved parsed)) + (pure . Just) + (Typed.cachedSealedTypedModule + foundation + (Typed.finalPreludeModule prelude : direct) + installation) + FreshStoreValidation -> + pure Nothing + + taskMayStart candidate sealedByAddress task = + maybe True + (moduleTaskOrdinal task <) + (candidateOrdinal <$> candidate) + && all + (`Map.member` sealedByAddress) + (moduleTaskDirectAddresses task) + + extractFirstReady candidate sealedByAddress = go [] + where + go _before [] = Nothing + go before (task : after) + | taskMayStart candidate sealedByAddress task = + Just (task, reverse before <> after) + | otherwise = + go (task : before) after + + chooseEarlierFailure Nothing incoming = incoming + chooseEarlierFailure (Just current) incoming + | candidateOrdinal incoming < candidateOrdinal current = incoming + | otherwise = current + + candidateOrdinal (ModuleFailureCandidate ordinal _admitted _failure) = + ordinal + + candidateFailure (ModuleFailureCandidate _ordinal _admitted failure) = + failure + + candidateAdmitted (ModuleFailureCandidate _ordinal admitted _failure) = + admitted + + completeAdmittedWorkspace admittedByOrdinal = + AdmittedTypedWorkspace + ( completeAdmittedModule (Typed.finalPreludeInput prelude) + : fmap snd (Map.toAscList admittedByOrdinal) + ) + + admittedWorkspaceThrough admittedByOrdinal selected = + let cutoff = candidateOrdinal selected + earlier = Map.filterWithKey + (\ordinal _admitted -> ordinal < cutoff) + admittedByOrdinal + in AdmittedTypedWorkspace + ( completeAdmittedModule (Typed.finalPreludeInput prelude) + : ( fmap snd (Map.toAscList earlier) + <> [candidateAdmitted selected] + ) + ) + + cancelModuleCheckers running = do + traverse_ Async.cancel (Map.elems running) + traverse_ Async.waitCatch (Map.elems running) + +data TypedFailureClassification + = TypedCheckingRejection + | TypedVerificationRejection !FailedVerification + | TypedProverFailure !FailedVerification + | TypedIntegrityFailure + +-- | Classify failures at the typed checking boundary conservatively. +-- +-- Only source elaboration and recognized prover outcomes may retain an +-- admitted source report. Every declaration/sealing invariant, including a +-- future constructor not explicitly recognized below, remains fatal. +classifyTypedModuleFailure + :: Typed.TypedModuleFailure + -> TypedFailureClassification +classifyTypedModuleFailure = \case + Typed.TypedActionFailed{} -> + TypedCheckingRejection + Typed.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + (Declaration.VampireProcessFailed processError)) -> + classifyTypedProverResult location (Left processError) + Typed.TypedDeclarationFailed + (Declaration.ProofObligationFailedAt + location + (Declaration.VampireObligationRejected answer)) -> + classifyTypedProverResult location (Right answer) + _failure -> + TypedIntegrityFailure + +classifyTypedProverResult + :: Location + -> Either ProverProcessError ProverAnswer + -> TypedFailureClassification +classifyTypedProverResult location result = + case verificationFailureReason result of + Nothing -> + TypedIntegrityFailure + Just reason -> + let failed = FailedVerification location reason + in case reason of + CountermodelFailure{} -> + TypedVerificationRejection failed + ContradictoryInputFailure{} -> + TypedVerificationRejection failed + IndeterminateFailure{} -> + TypedProverFailure failed + ProtocolFailure{} -> + TypedProverFailure failed + TransportFailure{} -> + TypedProverFailure failed + +typedVampireResolver + :: VampireRequestOwner + -> Natural + -> IO Declaration.VampireResolver +typedVampireResolver + requestOwner moduleOrdinal = do + localOrdinalRef <- newIORef 1 + let reserve requests = do + let batchSize = NonEmpty.length requests + ordinalCount = fromIntegral batchSize + firstOrdinal <- atomicModifyIORef' localOrdinalRef + (\current -> (current + ordinalCount, current)) + let positions = + NonEmpty.fromList + [ workPosition moduleOrdinal ordinal + | ordinal <- + [firstOrdinal .. firstOrdinal + ordinalCount - 1] + ] + pure positions + submit requests = do + positions <- reserve requests + traverse + (\(position, Declaration.VampireSubmission location request) -> + submitVampireRequest + requestOwner position location request) + (NonEmpty.zip positions requests) + pure (Declaration.vampireSubmissionResolver submit) + +admittedWorkspaceReport + :: AdmittedTypedWorkspace + -> VerificationReport +admittedWorkspaceReport (AdmittedTypedWorkspace modules) = + VerificationReport + { verificationDirectEscapes = + concatMap admittedModuleEscapes modules + } + +admittedModuleEscapes + :: AdmittedTypedModule + -> [ReportedEscape] +admittedModuleEscapes (AdmittedTypedModule declarations) = + concatMap admittedDeclarationEscapes declarations + +admittedDeclarationEscapes + :: AdmittedTypedDeclaration + -> [ReportedEscape] +admittedDeclarationEscapes + (AdmittedTypedDeclaration _slot declaration) = + axiomEscape <> proofEscapes + where + axiomEscape = + case Typed.typedSourceDeclarationHead declaration of + Raw.BlockAxiom location _title _marker _axiom -> + [ReportedEscape ReportedSourceAxiom location] + _ -> + [] + proofEscapes = + maybe [] omittedProofEscapes + (Typed.typedSourceDeclarationProof declaration) + +omittedProofEscapes :: Raw.Proof -> [ReportedEscape] +omittedProofEscapes = \case + Raw.Omitted location -> + [ReportedEscape ReportedOmitted location] + Raw.Qed{} -> + [] + Raw.Contradiction{} -> + [] + Raw.ByCase _location cases -> + concatMap (omittedProofEscapes . Raw.caseProof) cases + Raw.ByContradiction _location proof -> + omittedProofEscapes proof + Raw.BySetInduction _location _term proof -> + omittedProofEscapes proof + Raw.ByOrdInduction _location proof -> + omittedProofEscapes proof + Raw.Assume _location _statement proof -> + omittedProofEscapes proof + Raw.FixSymbolic _location _variables _bound proof -> + omittedProofEscapes proof + Raw.FixSuchThat _location _variables _statement proof -> + omittedProofEscapes proof + Raw.Calc _location _quantifier _calculation proof -> + omittedProofEscapes proof + Raw.TakeVar _location _variables _bound _statement _justification proof -> + omittedProofEscapes proof + Raw.TakeNoun _location _noun _justification proof -> + omittedProofEscapes proof + Raw.Have _location _condition _statement _justification proof -> + omittedProofEscapes proof + Raw.Suffices _location _statement _justification proof -> + omittedProofEscapes proof + Raw.Subclaim _location _statement subproof continuation -> + omittedProofEscapes subproof <> omittedProofEscapes continuation + Raw.Define _location _variable _expression proof -> + omittedProofEscapes proof + Raw.DefineFunction + _location _function _argument _value _domainVariable _domain + proof -> + omittedProofEscapes proof + Raw.DefineFunctionLocal + _location _function _argument _domain _target _ruleVariable + _rules proof -> + omittedProofEscapes proof + +completedResult + :: VerificationReport + -> VerificationPresentation + -> VerificationResult +completedResult report presentation + | any ((== ReportedOmitted) . reportedEscapeKind) + (verificationDirectEscapes report) = + CompletedWithExplicitGaps report presentation + | otherwise = + VerificationCompleted report presentation diff --git a/source/Version.hs b/source/Felix/Version.hs index bc0fe1f..c9c6829 100644 --- a/source/Version.hs +++ b/source/Felix/Version.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Version (info, infoBuilder) where +module Felix.Version (info, infoBuilder) where import Data.Functor import Data.Semigroup diff --git a/source/Felix/Workspace.hs b/source/Felix/Workspace.hs new file mode 100644 index 0000000..b9034c5 --- /dev/null +++ b/source/Felix/Workspace.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Stable source-mount policy and authority-free workspace preparation. +module Felix.Workspace + ( WorkspaceEnvironment + , prepareDefaultWorkspaceEnvironment + , workspaceSourceMounts + , workspaceHtmlMountPrefixes + , workspaceRendererSearchRoots + , prepareWorkspaceRoot + , prepareSourceGraph + , prepareDefaultSourceGraph + , AuthorityFreeParseError(..) + , renderAuthorityFreeParseError + , parseWorkspace + , parse + , tokenize + , scan + , simpleStream + , TokStream + , ParseException(..) + , builtins + ) where + +import Base +import Felix.Parse (ParseException(..), ParseWorkspaceError(..)) +import Felix.Parse qualified as Parse +import Felix.Prelude qualified as Prelude +import Felix.Source +import Felix.Source.Graph (ResolvedSourceGraph) +import Felix.Source.Graph qualified as SourceGraph +import Felix.Report.Location +import Felix.Syntax.Abstract qualified as Raw +import Felix.Syntax.Adapt (ScannedLexicalItem, scanChunk) +import Felix.Syntax.Lexicon (builtins) +import Felix.Syntax.Token + +import Control.Exception qualified as Exception +import Data.Bifunctor (first) +import System.Directory (getCurrentDirectory) +import System.Environment (lookupEnv) +import System.FilePath.Posix ((</>), isAbsolute) +import Text.Megaparsec (errorBundlePretty) + +data WorkspaceEnvironment = WorkspaceEnvironment + !SourceMounts + ![(SourceMountId, [Text])] + ![FilePath] + +workspaceSourceMounts :: WorkspaceEnvironment -> SourceMounts +workspaceSourceMounts (WorkspaceEnvironment mounts _prefixes _rendererRoots) = + mounts + +workspaceHtmlMountPrefixes + :: WorkspaceEnvironment + -> [(SourceMountId, [Text])] +workspaceHtmlMountPrefixes + (WorkspaceEnvironment _mounts prefixes _rendererRoots) = + prefixes + +workspaceRendererSearchRoots :: WorkspaceEnvironment -> [FilePath] +workspaceRendererSearchRoots + (WorkspaceEnvironment _mounts _prefixes rendererRoots) = + rendererRoots + +prepareDefaultWorkspaceEnvironment + :: IO (Either ParseWorkspaceError WorkspaceEnvironment) +prepareDefaultWorkspaceEnvironment = do + currentDir <- getCurrentDirectory + configuredLibrary <- lookupEnv "NAPROCHE_LIB" + let libraryDir = fromMaybe (currentDir </> "library") configuredLibrary + debugDir = currentDir </> "debug" + rendererRoots = [currentDir, libraryDir, debugDir] + prefixes = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + , (sourceMountId "debug", ["debug"]) + ] + fmap (first SourceWorkspaceError) + (fmap + (\mounts -> + WorkspaceEnvironment mounts prefixes rendererRoots) + <$> prepareSourceMounts + [ (sourceMountId "project", currentDir) + , (sourceMountId "library", libraryDir) + , (sourceMountId "debug", debugDir) + ]) + +prepareWorkspaceRoot + :: WorkspaceEnvironment + -> FilePath + -> IO (Either ParseWorkspaceError RootRequest) +prepareWorkspaceRoot _environment file = + first SourceWorkspaceError <$> classifyRootRequest file + +prepareSourceGraph + :: WorkspaceEnvironment + -> RootRequest + -> IO (Either ParseWorkspaceError ResolvedSourceGraph) +prepareSourceGraph environment request = + first SourceWorkspaceError + <$> SourceGraph.buildResolvedSourceGraph + (workspaceSourceMounts environment) + request + +prepareDefaultSourceGraph + :: FilePath + -> IO (Either ParseWorkspaceError ResolvedSourceGraph) +prepareDefaultSourceGraph file = do + preparedEnvironment <- prepareDefaultWorkspaceEnvironment + case preparedEnvironment of + Left failure -> pure (Left failure) + Right environment -> do + preparedRoot <- prepareWorkspaceRoot environment file + case preparedRoot of + Left failure -> pure (Left failure) + Right request -> prepareSourceGraph environment request + +classifyRootRequest :: FilePath -> IO (Either SourceError RootRequest) +classifyRootRequest file + | isAbsolute file = existingRoot file + | otherwise = pure (searchedRoot file) + +data AuthorityFreeParseError + = AuthorityFreePreludeLoadFailed !Prelude.PreludeLoadError + | AuthorityFreePreludeParseFailed !Prelude.PreludeParseError + | AuthorityFreeWorkspaceFailed !ParseWorkspaceError + deriving (Show) + +instance Exception.Exception AuthorityFreeParseError + +renderAuthorityFreeParseError :: AuthorityFreeParseError -> Text +renderAuthorityFreeParseError = \case + AuthorityFreePreludeLoadFailed failure -> + "packaged final prelude loading failed: " + <> Prelude.renderPreludeLoadError failure + AuthorityFreePreludeParseFailed failure -> + "packaged final prelude parsing failed: " + <> Prelude.renderPreludeParseError failure + AuthorityFreeWorkspaceFailed failure -> + Parse.renderParseWorkspaceError failure + +parseWorkspace + :: FilePath + -> IO (Either AuthorityFreeParseError [Raw.Block]) +parseWorkspace file = + fmap Parse.importedBeforeImporterBlocks + <$> parseDefaultWorkspaceWithPrelude file + +parse :: FilePath -> IO [Raw.Block] +parse file = parseWorkspace file >>= either Exception.throwIO pure + +parseDefaultWorkspaceWithPrelude + :: FilePath + -> IO (Either AuthorityFreeParseError Parse.ParsedSourceWorkspace) +parseDefaultWorkspaceWithPrelude file = + Prelude.loadReservedPreludeSourceInput >>= \case + Left failure -> + pure (Left (AuthorityFreePreludeLoadFailed failure)) + Right source -> + Prelude.parseReservedPreludeSource source >>= \case + Left failure -> + pure (Left (AuthorityFreePreludeParseFailed failure)) + Right prelude -> do + preparedEnvironment <- prepareDefaultWorkspaceEnvironment + case preparedEnvironment of + Left failure -> + pure (Left (AuthorityFreeWorkspaceFailed failure)) + Right environment -> do + preparedRoot <- prepareWorkspaceRoot environment file + case preparedRoot of + Left failure -> + pure + (Left + (AuthorityFreeWorkspaceFailed + failure)) + Right request -> do + let syntax = + Parse.identifiedParsedModuleSyntaxInterface + (Prelude.reservedParsedPreludeModule + prelude) + first AuthorityFreeWorkspaceFailed + <$> Parse.parseSourceWorkspaceWithSyntaxInputsAndGraphValidation + (workspaceSourceMounts environment) + request + (const [syntax]) + (Prelude.rejectOrdinaryPreludeSourceGraph + source) + +lexFile :: FilePath -> IO (Text, [[Located Token]]) +lexFile file = do + environment <- prepareDefaultWorkspaceEnvironment + >>= either throwWorkspaceError pure + request <- prepareWorkspaceRoot environment file + >>= either throwWorkspaceError pure + loaded <- resolveAndLoadRoot (workspaceSourceMounts environment) request + >>= either Exception.throwIO pure + let source = loadedSource loaded + raw = loadedText loaded + locationPath = resolvedSourceLocationPath source + canonicalPath = + canonicalPathFilePath (resolvedSourceCanonicalPath source) + registration <- registerFilePathWithDisplay canonicalPath locationPath + fileId <- either + (Exception.throwIO . SourceLocationRegistrationFailed source) + pure + registration + case runLexer fileId locationPath raw of + Left tokenError -> + Exception.throwIO (TokenError (errorBundlePretty tokenError)) + Right (_imports, chunks) -> + pure (raw, chunks) + +tokenize :: FilePath -> IO TokStream +tokenize file = do + (raw, chunks) <- lexFile file + pure (TokStream raw chunks) + +scan :: FilePath -> IO [ScannedLexicalItem] +scan input = do + tokenStream <- tokenize input + concatMap (fmap unLocated) + <$> traverse + (either + (Exception.throwIO . LexicalScanFailure) + pure + . scanChunk) + (unTokStream tokenStream) + +simpleStream :: TokStream -> [[Token]] +simpleStream TokStream{unTokStream = chunks} = + [unLocated <$> chunk | chunk <- chunks] + +throwWorkspaceError :: ParseWorkspaceError -> IO value +throwWorkspaceError = \case + SourceWorkspaceError err -> Exception.throwIO err + err@SourceLexiconCollision{} -> Exception.throwIO err + err@SourceSyntaxPragmaError{} -> Exception.throwIO err + err@SourceSyntaxDeclarationError{} -> Exception.throwIO err + err@SourceSyntaxMaterializationError{} -> Exception.throwIO err + err@SourceParsedModuleKeyError{} -> Exception.throwIO err + SourceParseError _source err -> Exception.throwIO err diff --git a/source/Test/Unit.hs b/source/Test/Unit.hs deleted file mode 100644 index 3e5817c..0000000 --- a/source/Test/Unit.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Test.Unit where - - -import Test.Tasty -import Test.Unit.Abstract qualified as Abstract -import Test.Unit.Backend qualified as Backend -import Test.Unit.CommandLine qualified as CommandLine -import Test.Unit.Concrete qualified as Concrete -import Test.Unit.Core qualified as Core -import Test.Unit.Declaration qualified as Declaration -import Test.Unit.Foundation qualified as Foundation -import Test.Unit.Identity qualified as Identity -import Test.Unit.Html qualified as Html -import Test.Unit.HtmlLayout qualified as HtmlLayout -import Test.Unit.HtmlOutput qualified as HtmlOutput -import Test.Unit.Kernel qualified as Kernel -import Test.Unit.Lexicon qualified as Lexicon -import Test.Unit.Meaning qualified as Meaning -import Test.Unit.Materialization qualified as Materialization -import Test.Unit.Module qualified as Module -import Test.Unit.OutputPlan qualified as OutputPlan -import Test.Unit.Provers qualified as Provers -import Test.Unit.Semantic qualified as Semantic -import Test.Unit.Source qualified as Source -import Test.Unit.Store qualified as Store -import Test.Unit.Token qualified as Token - -unitTests :: TestTree -unitTests = testGroup "unit tests" - [ Abstract.unitTests - , Backend.unitTests - , CommandLine.unitTests - , Concrete.unitTests - , Core.unitTests - , Declaration.unitTests - , Foundation.unitTests - , Identity.unitTests - , Html.unitTests - , HtmlLayout.unitTests - , HtmlOutput.unitTests - , Kernel.unitTests - , Lexicon.unitTests - , Meaning.unitTests - , Materialization.unitTests - , Module.unitTests - , OutputPlan.unitTests - , Provers.unitTests - , Semantic.unitTests - , Source.unitTests - , Store.unitTests - , Token.unitTests - ] |