path: root/source/Felix/Parse.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}

-- | Parsing over an already resolved physical source graph.
module Felix.Parse
    ( ParseException(..)
    , ParseWorkspaceError(..)
    , renderParseWorkspaceError
    , renderSyntaxMaterializationError
    , ParseExecutionError(..)
    , ParsedArtifactIntegrityError(..)
    , SyntaxDeclarationError(..)
    , LexiconCollision
    , LexiconCollisionOrigin(..)
    , lexiconCollisionPattern
    , lexiconCollisionOrigins
    , lexiconCollisionDeclarations
    , lexiconCollisionFirstDeclaration
    , lexiconCollisionSecondDeclaration
    , LexicalScanError(..)
    , ParsedModuleImport
    , parsedImportReference
    , parsedImportedAddress
    , FreshSourceBinding(..)
    , FreshModuleInput
    , FreshModuleInputError(..)
    , ReservedModuleParseError(..)
    , freshModuleInput
    , freshModuleInputOwner
    , freshModuleInputBinding
    , freshModuleInputFileId
    , freshModuleInputLocationPath
    , freshModuleInputBytes
    , freshModuleInputText
    , freshModuleInputImports
    , freshModuleInputSyntaxInterface
    , identifyParsedModule
    , parseReservedFreshModule
    , parsePreparedTokenChunk
    , IdentifiedParsedModule
    , identifiedParsedModuleBlocks
    , identifiedParsedModuleSyntaxInterface
    , identifiedParsedModuleSourceContentId
    , identifiedParsedModuleKey
    , identifiedParsedModulePayload
    , identifiedParsedModuleId
    , identifiedParsedModuleSyntaxOccurrences
    , ParsedModule
    , parsedModuleLoaded
    , parsedModuleIdentified
    , parsedModuleResolved
    , parsedModuleAddress
    , parsedModuleImports
    , parsedModuleBlocks
    , parsedModuleSyntaxInterface
    , parsedModuleSourceContentId
    , parsedModuleKey
    , parsedModulePayload
    , parsedModuleId
    , ParsedSyntaxOccurrence
    , parsedSyntaxOccurrenceBlockIndex
    , parsedSyntaxOccurrenceLocation
    , parsedSyntaxOccurrenceMarker
    , parsedSyntaxOccurrenceEntry
    , parsedModuleSyntaxOccurrences
    , ParsedSourceWorkspace
    , parsedWorkspaceRoot
    , parsedWorkspaceRootModule
    , 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
    , parseResolvedSourceGraph
    , parseResolvedSourceGraphWith
    ) where

import Base
import Felix.Cache.Codec (CacheDecodeError)
import Felix.Parsed.Identity qualified as Parsed
import Felix.Parsed.Payload qualified as Parsed
import Felix.Module
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
    ( LexicalScanError(..)
    , ScannedLexicalItem
    , SyntaxMaterializationError(..)
    , canonicalScannedItem
    , materializeSyntaxDelta
    , scanChunk
    , scannedItemMarker
    )
import Syntax.Concrete (grammar)
import Syntax.Interface
import Syntax.Lexicon (Lexicon)
import Syntax.Pragma
import Syntax.Token

import Control.DeepSeq (NFData, force)
import Control.Exception (Exception, evaluate)
import Control.Monad (foldM, unless, when)
import Control.Monad.Trans.Except
    ( ExceptT(..)
    , runExceptT
    , throwE
    , withExceptT
    )
import Data.Bifunctor qualified as Bifunctor
import Data.List (intercalate)
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.ByteString (ByteString)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Text.Earley (Parser, Report(..), fullParses, parser)
import Text.Megaparsec (errorBundlePretty)


data ParseException
    = UnconsumedTokens [Text] (NonEmpty (Located Token))
    | AmbiguousParse [Raw.Block]
    | EmptyParse
    | TokenError String
    | LexicalScanFailure !LexicalScanError

instance Show ParseException where
    show = \case
        UnconsumedTokens expectations (locatedToken :| locatedTokens) ->
            let token = unLocated locatedToken
                tokens = unLocated <$> locatedTokens
            in
                "unconsumed " <> describeToken token <> " at "
                    <> prettyLocation (startPos locatedToken) <> "\n"
                    <> "  " <> unwords (tokToString <$> (token : take 4 tokens)) <> "\n"
                    <> "  " <> replicate (length (tokToString token)) '^' <> "\n"
                    <> case expectations of
                        [] ->
                            "while expecting nothing"
                        _ ->
                            "while expecting one of the following:\n"
                                <> intercalate ", "
                                    (Text.unpack <$> nubOrd expectations)
        AmbiguousParse blocks ->
            "ambiguous parse: " <> show blocks
        EmptyParse ->
            "empty parse"
        TokenError err ->
            err
        LexicalScanFailure err ->
            show err

instance Exception ParseException


data ParseWorkspaceError
    = SourceWorkspaceError !SourceError
    | SourceLexiconCollision !LexiconCollision
    | SourceSyntaxPragmaError !ResolvedSource !SyntaxPragmaError
    | SourceSyntaxDeclarationError
        !ResolvedSource
        !SyntaxDeclarationError
    | SourceSyntaxMaterializationError
        !SyntaxMaterializationError
    | SourceParsedModuleKeyError
        !ResolvedSource
        !Parsed.ParsedModuleKeyError
    | SourceParseError !ResolvedSource !ParseException

instance Exception ParseWorkspaceError

instance Show ParseWorkspaceError where
    show = Text.unpack . renderParseWorkspaceError

renderParseWorkspaceError :: ParseWorkspaceError -> Text
renderParseWorkspaceError = \case
    SourceWorkspaceError err ->
        renderSourceError err
    SourceLexiconCollision collision ->
        Text.pack (show collision)
    SourceSyntaxPragmaError source err ->
        resolvedSourceLabel source <> ": " <> renderSyntaxPragmaError err
    SourceSyntaxDeclarationError source err ->
        resolvedSourceLabel source <> ": " <> Text.pack (show err)
    SourceSyntaxMaterializationError err ->
        renderSyntaxMaterializationError err
    SourceParsedModuleKeyError source err ->
        resolvedSourceLabel source
            <> ": parsed module has duplicate direct syntax input "
            <> case err of
                Parsed.DuplicateParsedDirectSyntaxInput duplicate ->
                    Text.pack (show duplicate)
    SourceParseError source err ->
        resolvedSourceLabel source <> ": " <> Text.pack (show err)

data ParsedArtifactIntegrityError
    = ParsedArtifactPayloadDecodeFailure !CacheDecodeError
    | ParsedArtifactImportMismatch ![ImportRef] ![ImportRef]
    | ParsedArtifactOccurrenceFailure !Text
    | ParsedArtifactAssociationFailure !SyntaxDeclarationError
    | ParsedArtifactSyntaxFailure !ParseWorkspaceError
    | ParsedArtifactSyntaxInterfaceMismatch
        !SyntaxInterfaceId !SyntaxInterfaceId
    deriving stock (Show)

data ParseExecutionError
    = ParseExecutionWorkspaceError !ParseWorkspaceError
    | ParseExecutionStoreFailure !Store.StoreFailure
    | ParseExecutionArtifactIntegrityFailure
        !ResolvedSource
        !ParsedArtifactIntegrityError
    deriving stock (Show)

renderSyntaxMaterializationError :: SyntaxMaterializationError -> Text
renderSyntaxMaterializationError = \case
    MaterializedSyntaxCollision collision ->
        "effective syntax has conflicting entries for pattern "
            <> Text.pack (show (canonicalCollisionPattern collision))
            <> ": "
            <> Text.pack
                (show (toList (canonicalCollisionEntries collision)))
    PrefixPredicateArityOutOfRange arity ->
        "prefix predicate arity is outside the supported range: "
            <> Text.pack (show arity)

resolvedSourceLabel :: ResolvedSource -> Text
resolvedSourceLabel source =
    sourceMountIdText (resolvedSourceMount source)
        <> ":"
        <> Text.pack
            (safeRelativePathFilePath
                (resolvedSourceRelativePath source))

data SyntaxDeclarationError
    = SyntaxPragmaOutsideDeclaration !Location
    | DuplicateSyntaxPragma !Location !Location
    | IrrelevantSyntaxPragma !Location !Location
    | MissingSyntaxPragma !Location !Raw.Pattern
    | AmbiguousSyntaxPragmaTarget
        !Location
        !(NonEmpty Raw.Pattern)
    | MultipleNewSyntaxPatternsWithoutPragma
        !Location
        !(NonEmpty Raw.Pattern)
    | SyntaxPragmaOnFixedReuse !Location !Raw.Pattern
    | SyntaxPragmaOnImportedReuse !Location !Raw.Pattern
    | SyntaxOccurrenceMarkerMismatch
        !Location
        !Raw.Marker
        !Raw.Marker
    | SyntaxOccurrenceMissingBlockMarker
        !Location
        !Raw.Marker
    deriving stock (Eq)

instance Show SyntaxDeclarationError where
    show = \case
        SyntaxPragmaOutsideDeclaration location ->
            "syntax pragma at "
                <> prettyLocation location
                <> " is outside a syntax-producing declaration"
        DuplicateSyntaxPragma first second ->
            "duplicate syntax pragma at "
                <> prettyLocation second
                <> "; the first pragma is at "
                <> prettyLocation first
        IrrelevantSyntaxPragma pragma declaration ->
            "syntax pragma at "
                <> prettyLocation pragma
                <> " does not apply to the declaration at "
                <> prettyLocation declaration
        MissingSyntaxPragma location pat ->
            "expression pattern "
                <> show pat
                <> " at "
                <> prettyLocation location
                <> " requires a syntax pragma"
        AmbiguousSyntaxPragmaTarget location patterns ->
            "syntax pragma at "
                <> prettyLocation location
                <> " has several eligible patterns: "
                <> intercalate ", " (show <$> toList patterns)
        MultipleNewSyntaxPatternsWithoutPragma location patterns ->
            "syntax declaration at "
                <> prettyLocation location
                <> " has several new eligible patterns that V1 cannot select between: "
                <> intercalate ", " (show <$> toList patterns)
                <> "; make the declaration unambiguous"
        SyntaxPragmaOnFixedReuse location pat ->
            "syntax pragma at "
                <> prettyLocation location
                <> " cannot override fixed-base pattern "
                <> show pat
        SyntaxPragmaOnImportedReuse location pat ->
            "syntax pragma at "
                <> prettyLocation location
                <> " cannot override imported pattern "
                <> show pat
        SyntaxOccurrenceMarkerMismatch
                location
                scannerMarker
                actual ->
            "syntax declaration at "
                <> prettyLocation location
                <> " has scanner marker "
                <> show scannerMarker
                <> " but parsed block marker "
                <> show actual
        SyntaxOccurrenceMissingBlockMarker location scannerMarker ->
            "syntax declaration at "
                <> prettyLocation location
                <> " with scanner marker "
                <> show scannerMarker
                <> " is associated with a block without a marker"

data LexiconCollisionOrigin
    = FixedLexiconOrigin !CanonicalLexicalEntry
    | ImportedLexiconOrigin
        !CanonicalLexicalEntry
        !SyntaxInterfaceId
    | SourceLexiconOrigin
        !CanonicalLexicalEntry
        !ResolvedSource
        !Location
    | ReservedLexiconOrigin
        !CanonicalLexicalEntry
        !FilePath
        !Location
    deriving stock (Show, Eq, Ord)

data LexiconCollision = LexiconCollision
    !Raw.Pattern
    !LexiconCollisionOrigin
    !LexiconCollisionOrigin
    ![LexiconCollisionOrigin]
    deriving stock (Eq)

lexiconCollisionPattern :: LexiconCollision -> Raw.Pattern
lexiconCollisionPattern
        (LexiconCollision pat _first _second _rest) =
    pat

lexiconCollisionOrigins
    :: LexiconCollision
    -> NonEmpty LexiconCollisionOrigin
lexiconCollisionOrigins
        (LexiconCollision _pat first second rest) =
    first :| (second : rest)

lexiconCollisionDeclarations :: LexiconCollision -> [Location]
lexiconCollisionDeclarations collision =
    [ location
    | Just location <-
        originLocation
            <$> toList
                (lexiconCollisionOrigins collision)
    ]

lexiconCollisionFirstDeclaration
    :: LexiconCollision
    -> Maybe Location
lexiconCollisionFirstDeclaration =
    listToMaybe . lexiconCollisionDeclarations

lexiconCollisionSecondDeclaration
    :: LexiconCollision
    -> Maybe Location
lexiconCollisionSecondDeclaration collision =
    listToMaybe
        (drop 1 (lexiconCollisionDeclarations collision))

originLocation :: LexiconCollisionOrigin -> Maybe Location
originLocation = \case
    FixedLexiconOrigin _entry ->
        Nothing
    ImportedLexiconOrigin _entry _interface ->
        Nothing
    SourceLexiconOrigin _entry _source location ->
        Just location
    ReservedLexiconOrigin _entry _label location ->
        Just location

instance Show LexiconCollision where
    show collision =
        "lexical pattern "
            <> show (lexiconCollisionPattern collision)
            <> " has conflicting providers:\n"
            <> unlines
                [ "  " <> renderOrigin origin
                | origin <- toList (lexiconCollisionOrigins collision)
                ]
      where
        origins =
            toList (lexiconCollisionOrigins collision)

        renderOrigin = \case
            FixedLexiconOrigin entry ->
                "fixed base entry " <> show entry
            ImportedLexiconOrigin entry interface ->
                "implicit syntax interface "
                    <> show interface
                    <> " provides "
                    <> show entry
            SourceLexiconOrigin entry source location ->
                "source declaration at "
                    <> renderSourceLocation origins source location
                    <> " provides "
                    <> show entry
            ReservedLexiconOrigin entry label location ->
                "reserved declaration at "
                    <> prettyLocation location
                    <> " ("
                    <> show label
                    <> ") provides "
                    <> show entry

renderSourceLocation
    :: [LexiconCollisionOrigin]
    -> ResolvedSource
    -> Location
    -> String
renderSourceLocation origins source location
    | any sameDisplayDifferentSource origins =
        prettyLocation location
            <> " (canonical "
            <> show
                (canonicalPathFilePath
                    (resolvedSourceCanonicalPath source))
            <> ")"
    | otherwise =
        prettyLocation location
  where
    sameDisplayDifferentSource = \case
        FixedLexiconOrigin _entry ->
            False
        ImportedLexiconOrigin _entry _interface ->
            False
        SourceLexiconOrigin _entry other otherLocation ->
            locFile otherLocation == locFile location
                && resolvedSourceCanonicalPath other
                    /= resolvedSourceCanonicalPath source
        ReservedLexiconOrigin{} ->
            False


data ParsedModuleImport = ParsedModuleImport
    !ImportRef
    !ResolvedSourceAddress
    deriving stock (Show, Eq, Generic)
    deriving anyclass (NFData)

parsedImportReference :: ParsedModuleImport -> ImportRef
parsedImportReference (ParsedModuleImport reference _imported) =
    reference

parsedImportedAddress :: ParsedModuleImport -> ResolvedSourceAddress
parsedImportedAddress (ParsedModuleImport _reference imported) =
    imported


data FreshSourceBinding
    = FreshPhysicalSource !ResolvedSource
    | FreshReservedSource
    deriving stock (Show, Eq)

data FreshModuleInput = FreshModuleInput
    !ModuleName
    !FreshSourceBinding
    !FileId
    !FilePath
    !ByteString
    !Text
    ![ImportRef]
    !ModuleSyntaxInterface

data FreshModuleInputError
    = FreshModuleTextDoesNotMatchBytes
    | FreshPhysicalOwnerMismatch !ModuleName !ModuleName
    | FreshPhysicalLocationPathMismatch !FilePath !FilePath
    deriving stock (Show, Eq)

data ReservedModuleParseError
    = ReservedModuleSyntaxPragmaError !SyntaxPragmaError
    | ReservedModuleImportError ![FilePath]
    | ReservedModuleLexicalScanError !LexicalScanError
    | ReservedModuleSyntaxDeclarationError !SyntaxDeclarationError
    | ReservedModuleLexiconCollision !LexiconCollision
    | ReservedModuleSyntaxInterfaceError !SyntaxInterfaceError
    | ReservedModuleSyntaxMaterializationError !SyntaxMaterializationError
    | ReservedModuleParseException !ParseException
    | ReservedModuleFreshInputError !FreshModuleInputError
    | ReservedModuleParsedKeyError !Parsed.ParsedModuleKeyError
    | ReservedModuleInvariantError !Text
    deriving stock (Show)

freshModuleInput
    :: ModuleName
    -> FreshSourceBinding
    -> FileId
    -> FilePath
    -> ByteString
    -> Text
    -> [ImportRef]
    -> ModuleSyntaxInterface
    -> Either FreshModuleInputError FreshModuleInput
freshModuleInput owner binding fileId locationPath bytes sourceText imports syntax
    | Text.encodeUtf8 sourceText /= bytes =
        Left FreshModuleTextDoesNotMatchBytes
    | Just expectedOwner <- physicalOwner
    , expectedOwner /= owner =
        Left (FreshPhysicalOwnerMismatch expectedOwner owner)
    | Just expectedPath <- physicalLocationPath
    , expectedPath /= locationPath =
        Left
            (FreshPhysicalLocationPathMismatch
                expectedPath
                locationPath)
    | otherwise =
        Right
            (FreshModuleInput
                owner
                binding
                fileId
                locationPath
                bytes
                sourceText
                imports
                syntax)
  where
    physicalOwner = case binding of
        FreshPhysicalSource source ->
            Just (moduleName (resolvedSourceAddress source))
        FreshReservedSource ->
            Nothing
    physicalLocationPath = case binding of
        FreshPhysicalSource source ->
            Just (resolvedSourceLocationPath source)
        FreshReservedSource ->
            Nothing

freshModuleInputOwner :: FreshModuleInput -> ModuleName
freshModuleInputOwner
        (FreshModuleInput owner _binding _fileId _locationPath _bytes _text
            _imports _syntax) =
    owner

freshModuleInputBinding
    :: FreshModuleInput
    -> FreshSourceBinding
freshModuleInputBinding
        (FreshModuleInput _owner binding _fileId _locationPath _bytes _text
            _imports _syntax) =
    binding

freshModuleInputFileId :: FreshModuleInput -> FileId
freshModuleInputFileId
        (FreshModuleInput _owner _binding fileId _locationPath _bytes _text
            _imports _syntax) =
    fileId

freshModuleInputLocationPath :: FreshModuleInput -> FilePath
freshModuleInputLocationPath
        (FreshModuleInput _owner _binding _fileId locationPath _bytes _text
            _imports _syntax) =
    locationPath

freshModuleInputBytes :: FreshModuleInput -> ByteString
freshModuleInputBytes
        (FreshModuleInput _owner _binding _fileId _locationPath bytes _text
            _imports _syntax) =
    bytes

freshModuleInputText :: FreshModuleInput -> Text
freshModuleInputText
        (FreshModuleInput _owner _binding _fileId _locationPath _bytes sourceText
            _imports _syntax) =
    sourceText

freshModuleInputImports :: FreshModuleInput -> [ImportRef]
freshModuleInputImports
        (FreshModuleInput _owner _binding _fileId _locationPath _bytes _text
            imports _syntax) =
    imports

freshModuleInputSyntaxInterface
    :: FreshModuleInput
    -> ModuleSyntaxInterface
freshModuleInputSyntaxInterface
        (FreshModuleInput _owner _binding _fileId _locationPath _bytes _text
            _imports syntax) =
    syntax


data IdentifiedParsedModule = IdentifiedParsedModule
    ![Raw.Block]
    !ModuleSyntaxInterface
    ![ParsedSyntaxOccurrence]
    !Content.SourceContentId
    !Parsed.ParsedModuleKey
    !Parsed.CanonicalParsedPayload
    !Parsed.ParsedModuleId
    deriving stock (Show, Generic)
    deriving anyclass (NFData)

identifiedParsedModuleBlocks :: IdentifiedParsedModule -> [Raw.Block]
identifiedParsedModuleBlocks
        (IdentifiedParsedModule blocks _interface _occurrences
            _content _key _payload _identity) =
    blocks

identifiedParsedModuleSyntaxInterface
    :: IdentifiedParsedModule
    -> ModuleSyntaxInterface
identifiedParsedModuleSyntaxInterface
        (IdentifiedParsedModule _blocks interface _occurrences
            _content _key _payload _identity) =
    interface

identifiedParsedModuleSourceContentId
    :: IdentifiedParsedModule
    -> Content.SourceContentId
identifiedParsedModuleSourceContentId
        (IdentifiedParsedModule _blocks _interface _occurrences
            content _key _payload _identity) =
    content

identifiedParsedModuleKey
    :: IdentifiedParsedModule
    -> Parsed.ParsedModuleKey
identifiedParsedModuleKey
        (IdentifiedParsedModule _blocks _interface _occurrences
            _content key _payload _identity) =
    key

identifiedParsedModulePayload
    :: IdentifiedParsedModule
    -> Parsed.CanonicalParsedPayload
identifiedParsedModulePayload
        (IdentifiedParsedModule _blocks _interface _occurrences
            _content _key payload _identity) =
    payload

identifiedParsedModuleId
    :: IdentifiedParsedModule
    -> Parsed.ParsedModuleId
identifiedParsedModuleId
        (IdentifiedParsedModule _blocks _interface _occurrences
            _content _key _payload identity) =
    identity

identifiedParsedModuleSyntaxOccurrences
    :: IdentifiedParsedModule
    -> [ParsedSyntaxOccurrence]
identifiedParsedModuleSyntaxOccurrences
        (IdentifiedParsedModule _blocks _interface occurrences
            _content _key _payload _identity) =
    occurrences

identifyParsedModule
    :: FreshModuleInput
    -> [Raw.Block]
    -> [ParsedSyntaxOccurrence]
    -> Either Parsed.ParsedModuleKeyError IdentifiedParsedModule
identifyParsedModule input blocks occurrences = do
    key <-
        Parsed.parsedModuleKey
            sourceContent
            (moduleSyntaxBase syntax)
            (moduleSyntaxDirectInputs syntax)
    let payload =
            Parsed.canonicalParsedPayload
                (freshModuleInputImports input)
                blocks
                [ ( parsedSyntaxOccurrenceBlockIndex occurrence
                  , parsedSyntaxOccurrenceLocation occurrence
                  , parsedSyntaxOccurrenceMarker occurrence
                  , parsedSyntaxOccurrenceEntry occurrence
                  )
                | occurrence <- occurrences
                ]
                (moduleSyntaxAssertedId syntax)
        identity =
            Parsed.parsedModuleId
                key
                (Parsed.canonicalParsedPayloadBytes payload)
    pure
        (IdentifiedParsedModule
            blocks
            syntax
            occurrences
            sourceContent
            key
            payload
            identity)
  where
    sourceContent =
        Content.sourceContentIdBytes
            (freshModuleInputBytes input)
    syntax = freshModuleInputSyntaxInterface input

-- | Parse one reserved, import-free module through the ordinary fresh-source
-- scanner, syntax, grammar, and occurrence-association stages.
parseReservedFreshModule
    :: ModuleName
    -> FileId
    -> FilePath
    -> ByteString
    -> Text
    -> Either
        ReservedModuleParseError
        (FreshModuleInput, IdentifiedParsedModule)
parseReservedFreshModule owner fileId label bytes sourceText = do
    pragmas <-
        Bifunctor.first ReservedModuleSyntaxPragmaError
            (extractSyntaxPragmas fileId label sourceText)
    (imports, tokenChunks) <-
        Bifunctor.first
            (ReservedModuleParseException
                . TokenError
                . errorBundlePretty)
            (runLexer fileId label sourceText)
    unless (null imports)
        (Left (ReservedModuleImportError imports))
    associated <-
        Bifunctor.first ReservedModuleSyntaxDeclarationError
            (associateSyntaxPragmas tokenChunks pragmas)
    chunks <- traverse scanReservedChunk (zip tokenChunks associated)
    (localEntries, preparedOccurrences) <-
        Bifunctor.first reservedLocalSyntaxError
            (prepareLocalSyntax
                0
                (ReservedSyntaxSite label)
                Map.empty
                chunks)
    delta <-
        Bifunctor.first reservedLocalSyntaxError
            (validateSyntaxInventory localEntries)
    syntax <-
        Bifunctor.first ReservedModuleSyntaxInterfaceError
            (moduleSyntaxInterface [] delta)
    lexicon <-
        Bifunctor.first ReservedModuleSyntaxMaterializationError
            (materializeSyntaxDelta delta)
    input <-
        Bifunctor.first ReservedModuleFreshInputError
            (freshModuleInput
                owner
                FreshReservedSource
                fileId
                label
                bytes
                sourceText
                []
                syntax)
    let moduleParser
            :: Parser Text [Located Token] Raw.Block
        moduleParser = parser (grammar lexicon)
    (blocks, occurrences) <-
        parseReservedChunks moduleParser chunks preparedOccurrences
    identified <-
        Bifunctor.first ReservedModuleParsedKeyError
            (identifyParsedModule input blocks occurrences)
    pure (input, identified)
  where
    scanReservedChunk (tokens, chunkPragmas) = do
        declarations <-
            Bifunctor.first ReservedModuleLexicalScanError
                (scanChunk tokens)
        pure (ScannedChunk tokens chunkPragmas declarations)

    reservedLocalSyntaxError = \case
        LocalSyntaxDeclarationError failure ->
            ReservedModuleSyntaxDeclarationError failure
        LocalSyntaxCollision collision ->
            ReservedModuleLexiconCollision collision

    parseReservedChunks
        :: Parser Text [Located Token] Raw.Block
        -> [ScannedChunk]
        -> [[PreparedSyntaxOccurrence]]
        -> Either
            ReservedModuleParseError
            ([Raw.Block], [ParsedSyntaxOccurrence])
    parseReservedChunks moduleParser chunks occurrences
        | length chunks /= length occurrences =
            Left
                (ReservedModuleInvariantError
                    "reserved syntax occurrence groups do not match source chunks")
        | otherwise = do
            parsed <- traverse
                (parseReservedChunk moduleParser)
                (zip3 [0 ..] chunks occurrences)
            pure
                ( fst <$> parsed
                , concatMap snd parsed
                )

    parseReservedChunk
        :: Parser Text [Located Token] Raw.Block
        -> (Int, ScannedChunk, [PreparedSyntaxOccurrence])
        -> Either
            ReservedModuleParseError
            (Raw.Block, [ParsedSyntaxOccurrence])
    parseReservedChunk moduleParser
            (blockIndex, ScannedChunk tokens _pragmas _items, prepared) = do
        block <-
            Bifunctor.first ReservedModuleParseException
                (parsePreparedTokenChunk moduleParser tokens)
        Bifunctor.first reservedAssociationError
            (validateOccurrenceAssociation
                (ReservedSyntaxSite label)
                blockIndex
                block
                prepared)
        pure
            ( block
            , [ ParsedSyntaxOccurrence
                    blockIndex
                    (syntaxSiteLocation (preparedSyntaxSite occurrence))
                    (syntaxSiteMarker (preparedSyntaxSite occurrence))
                    (preparedSyntaxEntry occurrence)
              | occurrence <- prepared
              ]
            )
    reservedAssociationError = \case
        OccurrenceAssociationDeclarationError failure ->
            ReservedModuleSyntaxDeclarationError failure
        OccurrenceAssociationInvariantError message ->
            ReservedModuleInvariantError message

data ParsedModule = ParsedModule
    !LoadedSource
    ![ParsedModuleImport]
    !IdentifiedParsedModule
    deriving stock (Show, Generic)
    deriving anyclass (NFData)

parsedModuleLoaded :: ParsedModule -> LoadedSource
parsedModuleLoaded (ParsedModule loaded _imports _identified) =
    loaded

parsedModuleIdentified :: ParsedModule -> IdentifiedParsedModule
parsedModuleIdentified (ParsedModule _loaded _imports identified) =
    identified

parsedModuleResolved :: ParsedModule -> ResolvedSource
parsedModuleResolved = loadedSource . parsedModuleLoaded

parsedModuleAddress :: ParsedModule -> ResolvedSourceAddress
parsedModuleAddress = resolvedSourceAddress . parsedModuleResolved

parsedModuleImports :: ParsedModule -> [ParsedModuleImport]
parsedModuleImports (ParsedModule _loaded imports _identified) =
    imports

parsedModuleBlocks :: ParsedModule -> [Raw.Block]
parsedModuleBlocks (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleBlocks identified

parsedModuleSyntaxInterface
    :: ParsedModule
    -> ModuleSyntaxInterface
parsedModuleSyntaxInterface (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleSyntaxInterface identified

parsedModuleSourceContentId
    :: ParsedModule
    -> Content.SourceContentId
parsedModuleSourceContentId (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleSourceContentId identified

parsedModuleKey :: ParsedModule -> Parsed.ParsedModuleKey
parsedModuleKey (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleKey identified

parsedModulePayload
    :: ParsedModule
    -> Parsed.CanonicalParsedPayload
parsedModulePayload (ParsedModule _loaded _imports identified) =
    identifiedParsedModulePayload identified

parsedModuleId :: ParsedModule -> Parsed.ParsedModuleId
parsedModuleId (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleId identified

data ParsedSyntaxOccurrence = ParsedSyntaxOccurrence
    !Int
    !Location
    !Raw.Marker
    !CanonicalLexicalEntry
    deriving stock (Show, Eq, Generic)
    deriving anyclass (NFData)

parsedSyntaxOccurrenceBlockIndex
    :: ParsedSyntaxOccurrence
    -> Int
parsedSyntaxOccurrenceBlockIndex
        (ParsedSyntaxOccurrence blockIndex _location _marker _entry) =
    blockIndex

parsedSyntaxOccurrenceLocation
    :: ParsedSyntaxOccurrence
    -> Location
parsedSyntaxOccurrenceLocation
        (ParsedSyntaxOccurrence _blockIndex location _marker _entry) =
    location

parsedSyntaxOccurrenceMarker
    :: ParsedSyntaxOccurrence
    -> Raw.Marker
parsedSyntaxOccurrenceMarker
        (ParsedSyntaxOccurrence _blockIndex _location marker _entry) =
    marker

parsedSyntaxOccurrenceEntry
    :: ParsedSyntaxOccurrence
    -> CanonicalLexicalEntry
parsedSyntaxOccurrenceEntry
        (ParsedSyntaxOccurrence _blockIndex _location _marker entry) =
    entry

parsedModuleSyntaxOccurrences
    :: ParsedModule
    -> [ParsedSyntaxOccurrence]
parsedModuleSyntaxOccurrences (ParsedModule _loaded _imports identified) =
    identifiedParsedModuleSyntaxOccurrences identified


data ParsedSourceWorkspace = ParsedSourceWorkspace
    !(NonEmpty ParsedModule)
    deriving stock (Show)

parsedWorkspaceRoot :: ParsedSourceWorkspace -> ResolvedSource
parsedWorkspaceRoot = parsedModuleResolved . parsedWorkspaceRootModule

parsedWorkspaceRootModule :: ParsedSourceWorkspace -> ParsedModule
parsedWorkspaceRootModule (ParsedSourceWorkspace modules) =
    NonEmpty.last modules

parsedWorkspaceModules :: ParsedSourceWorkspace -> [ParsedModule]
parsedWorkspaceModules (ParsedSourceWorkspace modules) =
    NonEmpty.toList modules

parsedWorkspaceImportedBeforeImporter
    :: ParsedSourceWorkspace
    -> NonEmpty ParsedModule
parsedWorkspaceImportedBeforeImporter
    (ParsedSourceWorkspace modules) =
        modules

-- | Flatten source-local blocks in deterministic imported-before-importer
-- order.
importedBeforeImporterBlocks :: ParsedSourceWorkspace -> [Raw.Block]
importedBeforeImporterBlocks =
    concatMap parsedModuleBlocks . parsedWorkspaceImportedBeforeImporter


data TokenizedModule = TokenizedModule
    !SourceNode
    ![ParsedModuleImport]
    ![SyntaxPragma]
    ![[Located Token]]

data ScannedChunk = ScannedChunk
    ![Located Token]
    ![SyntaxPragma]
    ![Located ScannedLexicalItem]

data ScannedModule = ScannedModule
    !SourceNode
    ![ParsedModuleImport]
    ![ScannedChunk]

data SyntaxSiteSource
    = PhysicalSyntaxSite !ResolvedSource
    | ReservedSyntaxSite !FilePath
    deriving stock (Show, Eq, Ord)

data SyntaxDeclarationSite = SyntaxDeclarationSite
    { syntaxSiteModuleIndex :: !Int
    , syntaxSiteBlockIndex :: !Int
    , syntaxSiteItemIndex :: !Int
    , syntaxSiteSource :: !SyntaxSiteSource
    , syntaxSiteLocation :: !Location
    , syntaxSiteMarker :: !Raw.Marker
    }
    deriving stock (Show, Eq, Ord)

data SyntaxEntryProvider
    = DeclarationSyntaxProvider !SyntaxDeclarationSite
    | ImplicitSyntaxProvider !SyntaxInterfaceId
    deriving stock (Show, Eq, Ord)

type SyntaxEntryInventory =
    Map CanonicalLexicalEntry (Set SyntaxEntryProvider)

data LocalSyntaxError
    = LocalSyntaxDeclarationError !SyntaxDeclarationError
    | LocalSyntaxCollision !LexiconCollision

localSyntaxWorkspaceError
    :: ResolvedSource
    -> LocalSyntaxError
    -> ParseWorkspaceError
localSyntaxWorkspaceError source = \case
    LocalSyntaxDeclarationError failure ->
        SourceSyntaxDeclarationError source failure
    LocalSyntaxCollision collision ->
        SourceLexiconCollision collision

localSyntaxCollisionWorkspaceError
    :: LocalSyntaxError
    -> ParseWorkspaceError
localSyntaxCollisionWorkspaceError = \case
    LocalSyntaxCollision collision ->
        SourceLexiconCollision collision
    LocalSyntaxDeclarationError{} ->
        impossible
            "canonical syntax validation produced a declaration error"

data OccurrenceAssociationError
    = OccurrenceAssociationDeclarationError !SyntaxDeclarationError
    | OccurrenceAssociationInvariantError !Text

occurrenceWorkspaceError
    :: ResolvedSource
    -> OccurrenceAssociationError
    -> ParseWorkspaceError
occurrenceWorkspaceError source = \case
    OccurrenceAssociationDeclarationError failure ->
        SourceSyntaxDeclarationError source failure
    OccurrenceAssociationInvariantError message ->
        SourceWorkspaceError (SourceGraphInvariantViolation message)

data PreparedSyntaxOccurrence = PreparedSyntaxOccurrence
    { preparedSyntaxSite :: !SyntaxDeclarationSite
    , preparedSyntaxEntry :: !CanonicalLexicalEntry
    }

data SyntaxItemDisposition
    = EmitSyntaxEntry !CanonicalLexicalEntry
    | ReuseFixedSyntax !CanonicalLexicalEntry
    | ReuseImportedSyntax !CanonicalLexicalEntry

data ClassifiedSyntaxItem = ClassifiedSyntaxItem
    !SyntaxDeclarationSite
    !SyntaxItemDisposition
    !Bool

data PreparedSyntaxModule = PreparedSyntaxModule
    { preparedAddress :: !ResolvedSourceAddress
    , preparedInterface :: !ModuleSyntaxInterface
    , preparedSyntaxDirectAddresses :: ![ResolvedSourceAddress]
    , preparedLocalEntries :: !SyntaxEntryInventory
    }

data FreshRuntimeSyntax = FreshRuntimeSyntax
    { freshRuntimePrepared :: !PreparedSyntaxModule
    , freshRuntimeLexicon :: !Lexicon
    , freshRuntimeOccurrences :: ![[PreparedSyntaxOccurrence]]
    }

data ModuleSyntaxContext = ModuleSyntaxContext
    { syntaxContextDirectIds :: ![SyntaxInterfaceId]
    , syntaxContextDirectAddresses :: ![ResolvedSourceAddress]
    , 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
    :: SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> IO
        (Either
            ParseWorkspaceError
            (ParsedSourceWorkspace, ParseMeasurements))
-- Implicit syntax inputs must be self-contained module interfaces.
parseSourceWorkspaceMeasuredWithSyntaxInputs mounts request syntaxInputs =
    parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation
        mounts
        request
        syntaxInputs
        (const (Right ()))

parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation
    :: SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSourceGraph -> Either SourceError ())
    -> IO
        (Either
            ParseWorkspaceError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidation
        mounts request syntaxInputs validateGraph =
    parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback
        mounts
        request
        syntaxInputs
        validateGraph
        (\_source _block -> pure ())

parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs
    :: Store.Store
    -> SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> IO
        (Either
            ParseExecutionError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputs
        store mounts request syntaxInputs =
    parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation
        store mounts request syntaxInputs (const (Right ()))

parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation
    :: Store.Store
    -> SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSourceGraph -> Either SourceError ())
    -> IO
        (Either
            ParseExecutionError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidation
        store mounts request syntaxInputs validateGraph =
    parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback
        store mounts request syntaxInputs validateGraph
        (\_source _block -> pure ())

parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback
    :: Store.Store
    -> SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO
        (Either
            ParseExecutionError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndCallback
        store mounts request syntaxInputs emitBlock = do
    parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback
        store mounts request syntaxInputs (const (Right ())) emitBlock

parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback
    :: Store.Store
    -> SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSourceGraph -> Either SourceError ())
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO
        (Either
            ParseExecutionError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithStoreAndSyntaxInputsAndGraphValidationAndCallback
        store mounts request syntaxInputs validateGraph emitBlock = do
    resolutionStart <- getMonotonicTimeNSec
    graphResult <- buildResolvedSourceGraphMeasured mounts request
    resolutionEnd <- getMonotonicTimeNSec
    case graphResult of
        Left err ->
            pure
                (Left
                    (ParseExecutionWorkspaceError
                        (SourceWorkspaceError err)))
        Right (graph, selectionMeasurements) ->
            case validateGraph graph of
                Left err ->
                    pure
                        (Left
                            (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)

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
    :: SourceMounts
    -> RootRequest
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSourceGraph -> Either SourceError ())
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO
        (Either
            ParseWorkspaceError
            (ParsedSourceWorkspace, ParseMeasurements))
parseSourceWorkspaceMeasuredWithSyntaxInputsAndGraphValidationAndCallback
        mounts request syntaxInputs validateGraph emitBlock = do
    resolutionStart <- getMonotonicTimeNSec
    graphResult <- buildResolvedSourceGraphMeasured mounts request
    resolutionEnd <- getMonotonicTimeNSec
    case graphResult of
        Left err ->
            pure (Left (SourceWorkspaceError err))
        Right (graph, selectionMeasurements) ->
            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)

parseResolvedSourceGraph
    :: ResolvedSourceGraph
    -> IO (Either ParseWorkspaceError ParsedSourceWorkspace)
parseResolvedSourceGraph graph =
    parseResolvedSourceGraphWith graph (\_source _block -> pure ())

-- | Parse in the graph's deterministic imported-before-importer order.
--
-- Graph construction errors occur before this order exists.
--
-- Every source is tokenized from its already loaded text, so this function
-- performs no source resolution or file reads. The callback may perform
-- arbitrary I/O and may have completed for earlier blocks when parsing fails.
parseResolvedSourceGraphWith
    :: ResolvedSourceGraph
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO (Either ParseWorkspaceError ParsedSourceWorkspace)
parseResolvedSourceGraphWith graph emitBlock =
    fmap (fmap fst)
        (parseResolvedSourceGraphMeasuredWith
            graph
            (const [])
            emitBlock)

parseResolvedSourceGraphMeasuredWith
    :: ResolvedSourceGraph
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO
        (Either
            ParseWorkspaceError
            (ParsedSourceWorkspace, ParseMeasurements))
parseResolvedSourceGraphMeasuredWith graph syntaxInputs emitBlock =
    fmap unwrapUncachedExecution
        (parseResolvedSourceGraphMeasuredWithArtifacts
            UncachedParsedArtifacts
            graph
            syntaxInputs
            emitBlock)

data ParsedArtifactAccess
    = UncachedParsedArtifacts
    | PersistentParsedArtifacts !Store.Store

unwrapUncachedExecution
    :: Either ParseExecutionError value
    -> Either ParseWorkspaceError value
unwrapUncachedExecution = \case
    Left (ParseExecutionWorkspaceError failure) ->
        Left failure
    Left ParseExecutionStoreFailure{} ->
        impossible "uncached parsing attempted a store operation"
    Left ParseExecutionArtifactIntegrityFailure{} ->
        impossible "uncached parsing installed a parsed artifact"
    Right value ->
        Right value

parseResolvedSourceGraphMeasuredWithArtifacts
    :: ParsedArtifactAccess
    -> ResolvedSourceGraph
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> IO
        (Either
            ParseExecutionError
            (ParsedSourceWorkspace, ParseMeasurements))
parseResolvedSourceGraphMeasuredWithArtifacts
        artifactAccess graph syntaxInputs emitBlock =
    runExceptT do
        let orderedNodes =
                sourceGraphImportedBeforeImporter graph
            addresses =
                Map.fromList
                    [ ( resolvedSourceCanonicalPath
                            (sourceNodeResolved node)
                      , resolvedSourceAddress
                            (sourceNodeResolved node)
                      )
                    | node <- NonEmpty.toList orderedNodes
                    ]
        completed <- foldM
            (parseOneModule
                artifactAccess graph addresses syntaxInputs emitBlock)
            emptyModuleParseState
            (zip [0 ..] (NonEmpty.toList orderedNodes))
        parsedModules <- case NonEmpty.nonEmpty
                (reverse (moduleParseReversed completed)) of
            Just modules ->
                pure modules
            Nothing ->
                throwE
                    (ParseExecutionWorkspaceError
                        (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
            )

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

parseOneModule
    :: ParsedArtifactAccess
    -> ResolvedSourceGraph
    -> Map CanonicalPath ResolvedSourceAddress
    -> (ResolvedSource -> [ModuleSyntaxInterface])
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> ModuleParseState
    -> (Int, SourceNode)
    -> ExceptT ParseExecutionError IO ModuleParseState
parseOneModule artifactAccess graph addresses syntaxInputs emitBlock state
        (moduleIndex, node) = do
    imports <- liftWorkspaceEither
        (resolveParsedModuleImports graph addresses node)
    context <- liftWorkspaceEither
        (prepareModuleSyntaxContext
            (moduleParsePrepared state)
            (syntaxInputs (sourceNodeResolved node))
            imports)
    key <- liftWorkspaceEither
        (moduleParsedKey node context)
    selected <- case artifactAccess of
        UncachedParsedArtifacts ->
            pure Nothing
        PersistentParsedArtifacts store ->
            liftIO (Store.loadParsedArtifact store key) >>= \case
                Left failure ->
                    throwE (ParseExecutionStoreFailure failure)
                Right found ->
                    pure found
    case selected of
        Just artifact ->
            installCachedModule
                emitBlock
                moduleIndex
                node
                imports
                context
                key
                artifact
                state
        Nothing ->
            parseAndPublishFreshModule
                artifactAccess
                emitBlock
                moduleIndex
                node
                imports
                context
                key
                state

parseAndPublishFreshModule
    :: ParsedArtifactAccess
    -> (ResolvedSource -> Raw.Block -> IO ())
    -> Int
    -> SourceNode
    -> [ParsedModuleImport]
    -> ModuleSyntaxContext
    -> Parsed.ParsedModuleKey
    -> ModuleParseState
    -> 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
            (ParseExecutionWorkspaceError
                (SourceWorkspaceError
                    (SourceGraphInvariantViolation
                        "fresh parsed module key disagrees with its syntax context"))))
    case artifactAccess of
        UncachedParsedArtifacts ->
            pure ()
        PersistentParsedArtifacts store -> do
            let artifact =
                    Parsed.parsedArtifact
                        expectedKey
                        (parsedModulePayload parsed)
            unless
                (Parsed.parsedArtifactId artifact == parsedModuleId parsed)
                (throwE
                    (ParseExecutionWorkspaceError
                        (SourceWorkspaceError
                            (SourceGraphInvariantViolation
                                "fresh parsed artifact identity disagrees with its module"))))
            liftIO
                (Store.writeParsedArtifact store expectedKey artifact)
                >>= \case
                    Left failure ->
                        throwE (ParseExecutionStoreFailure failure)
                    Right acknowledged ->
                        unless
                            (acknowledged == artifact)
                            (throwE
                                (ParseExecutionStoreFailure
                                    Store.StoreParsedArtifactIdMismatch))
    let prepared = freshRuntimePrepared runtime
        address = preparedAddress prepared
    when
        (Map.member address (moduleParsePrepared state))
        (throwE
            (ParseExecutionWorkspaceError
                (SourceWorkspaceError
                    (SourceGraphInvariantViolation
                        "prepared syntax module address is duplicated"))))
    pure
        state
            { moduleParsePrepared =
                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
    :: Either ParseWorkspaceError value
    -> ExceptT ParseExecutionError IO value
liftWorkspaceEither =
    either (throwE . ParseExecutionWorkspaceError) pure

installCachedModule
    :: (ResolvedSource -> Raw.Block -> IO ())
    -> Int
    -> SourceNode
    -> [ParsedModuleImport]
    -> ModuleSyntaxContext
    -> Parsed.ParsedModuleKey
    -> Parsed.ParsedArtifact
    -> ModuleParseState
    -> 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
    decoded <-
        either
            (throwIntegrity source . ParsedArtifactPayloadDecodeFailure)
            pure
            (Parsed.decodeCanonicalParsedPayload
                (sourceNodeFileId node)
                payload)
    let expectedImports = parsedImportReference <$> imports
        storedImports = Parsed.decodedParsedImports decoded
    unless
        (storedImports == expectedImports)
        (throwIntegrity source
            (ParsedArtifactImportMismatch expectedImports storedImports))
    (localEntries, occurrences) <-
        either (throwIntegrity source) pure
            (prepareCachedOccurrences
                moduleIndex
                node
                context
                (Parsed.decodedParsedBlocks decoded)
                (Parsed.decodedParsedOccurrences decoded))
    (prepared, _effectiveDelta) <-
        either
            (throwIntegrity source . ParsedArtifactSyntaxFailure)
            pure
            (prepareSyntaxModule
                (resolvedSourceAddress source)
                context
                localEntries)
    let actualSyntax = moduleSyntaxAssertedId (preparedInterface prepared)
        assertedSyntax = Parsed.decodedParsedSyntaxInterface decoded
    unless
        (actualSyntax == assertedSyntax)
        (throwIntegrity source
            (ParsedArtifactSyntaxInterfaceMismatch
                assertedSyntax actualSyntax))
    let content = Content.sourceContentIdBytes (loadedBytes loaded)
        identified =
            IdentifiedParsedModule
                (Parsed.decodedParsedBlocks decoded)
                (preparedInterface prepared)
                occurrences
                content
                key
                payload
                (Parsed.parsedArtifactId artifact)
        parsed = ParsedModule loaded imports identified
    forced <- liftIO (evaluate (force parsed))
    syntaxEnd <- liftIO getMonotonicTimeNSec
    liftIO
        (forM_
            (parsedModuleBlocks forced)
            (emitBlock source))
    let address = preparedAddress prepared
    when
        (Map.member address (moduleParsePrepared state))
        (throwE
            (ParseExecutionWorkspaceError
                (SourceWorkspaceError
                    (SourceGraphInvariantViolation
                        "prepared syntax module address is duplicated"))))
    pure
        state
            { moduleParsePrepared =
                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
    :: ResolvedSource
    -> ParsedArtifactIntegrityError
    -> ExceptT ParseExecutionError IO value
throwIntegrity source =
    throwE . ParseExecutionArtifactIntegrityFailure source

prepareCachedOccurrences
    :: Int
    -> SourceNode
    -> ModuleSyntaxContext
    -> [Raw.Block]
    -> [(Int, Location, Raw.Marker, CanonicalLexicalEntry)]
    -> Either
        ParsedArtifactIntegrityError
        ( SyntaxEntryInventory
        , [ParsedSyntaxOccurrence]
        )
prepareCachedOccurrences moduleIndex node context blocks supplied = do
    (localEntries, groups, _previous) <-
        foldM insertOccurrence
            (Map.empty, Map.empty, Nothing)
            supplied
    forM_
        (zip [0 ..] blocks)
        \(blockIndex, block) ->
            case validateOccurrenceAssociation
                    (PhysicalSyntaxSite source)
                    blockIndex
                    block
                    (reverse
                        (Map.findWithDefault [] blockIndex groups)) of
                Left (OccurrenceAssociationDeclarationError failure) ->
                    Left (ParsedArtifactAssociationFailure failure)
                Left (OccurrenceAssociationInvariantError message) ->
                    Left
                        (ParsedArtifactOccurrenceFailure
                            message)
                Right () ->
                    Right ()
    pure
        ( localEntries
        , [ ParsedSyntaxOccurrence blockIndex location marker entry
          | (blockIndex, location, marker, entry) <- supplied
          ]
        )
  where
    source = sourceNodeResolved node
    expectedFileId = sourceNodeFileId node
    importedEntries = syntaxContextImportedEntries context
    importedIndex = syntaxSurfaceIndex importedEntries
    blockBounds = Map.fromAscList (indexBlockBounds 0 blocks)

    indexBlockBounds _index [] =
        []
    indexBlockBounds index [block] =
        [(index, (locate block, Nothing))]
    indexBlockBounds index (block : rest@(next : _)) =
        (index, (locate block, Just (locate next)))
            : indexBlockBounds (index + 1) rest

    insertOccurrence (entries, groups, previous)
            (blockIndex, location, marker, entry) = do
        unless
            (locFileId location == Just expectedFileId)
            (Left
                (ParsedArtifactOccurrenceFailure
                    "syntax occurrence has an invalid source location"))
        (blockStart, nextStart) <-
            maybe
                (Left
                    (ParsedArtifactOccurrenceFailure
                        "syntax occurrence has an invalid block index"))
                Right
                (Map.lookup blockIndex blockBounds)
        let orderedLocation =
                ( blockIndex
                , locLine location
                , locColumn location
                )
        unless
            (location >= blockStart
                && maybe True (location <) nextStart)
            (Left
                (ParsedArtifactOccurrenceFailure
                    "syntax occurrence lies outside its decoded block"))
        case previous of
            Just prior
                | orderedLocation < prior ->
                    Left
                        (ParsedArtifactOccurrenceFailure
                            "syntax occurrences are not in source order")
            _ ->
                Right ()
        let itemIndex =
                length (Map.findWithDefault [] blockIndex groups)
            site =
                SyntaxDeclarationSite
                    { syntaxSiteModuleIndex = moduleIndex
                    , syntaxSiteBlockIndex = blockIndex
                    , syntaxSiteItemIndex = itemIndex
                    , syntaxSiteSource = PhysicalSyntaxSite source
                    , syntaxSiteLocation = location
                    , syntaxSiteMarker = marker
                    }
        disposition <-
            Bifunctor.first ParsedArtifactSyntaxFailure
                (classifyCachedSyntaxItem
                    importedEntries importedIndex site entry)
        let entries' = case disposition of
                EmitSyntaxEntry emitted ->
                    Map.insertWith
                        Set.union
                        emitted
                        (Set.singleton
                            (DeclarationSyntaxProvider site))
                        entries
                ReuseFixedSyntax _fixed ->
                    entries
                ReuseImportedSyntax _imported ->
                    entries
            prepared = PreparedSyntaxOccurrence site entry
        pure
            ( entries'
            , Map.insertWith (++) blockIndex [prepared] groups
            , Just orderedLocation
            )

classifyCachedSyntaxItem
    :: SyntaxEntryInventory
    -> Map Raw.Pattern (Set CanonicalLexicalEntry)
    -> SyntaxDeclarationSite
    -> CanonicalLexicalEntry
    -> Either ParseWorkspaceError SyntaxItemDisposition
classifyCachedSyntaxItem importedEntries importedIndex site entry =
    case Set.toAscList
            (entriesForSurfaces fixedBaseSurfaceIndex entry) of
        [] ->
            classifyImported
        [fixedEntry]
            | entry == fixedEntry ->
                Right (ReuseFixedSyntax fixedEntry)
            | otherwise ->
                Left
                    (SourceLexiconCollision
                        (makeLexiconCollision
                            (sharedSurface entry fixedEntry)
                            [ FixedLexiconOrigin fixedEntry
                            , sourceCollisionOrigin entry site
                            ]))
        _ ->
            impossible
                "fixed base has several entries for one parser surface"
  where
    classifyImported = case entry of
        CanonicalExpressionFunction localPattern marker _fixity ->
            case Set.toAscList
                    (entriesForSurfaces importedIndex entry) of
                [] ->
                    Right (EmitSyntaxEntry entry)
                [importedEntry@(CanonicalExpressionFunction
                        importedPattern importedMarker _importedFixity)]
                    | localPattern == importedPattern
                        && marker == importedMarker
                        && entry == importedEntry ->
                        Right (ReuseImportedSyntax importedEntry)
                entries ->
                    Left
                        (SourceLexiconCollision
                            (makeLexiconCollision
                                (firstSharedSurface entry entries)
                                ( importedCollisionOrigins
                                    importedEntries entries
                                  <> [sourceCollisionOrigin entry site]
                                )))
        _ ->
            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]
    -> IO (Either ParseWorkspaceError TokenizedModule)
tokenizeModule node imports = do
    let loaded = sourceNodeLoaded node
        source = loadedSource loaded
        locationPath = resolvedSourceLocationPath source
    pure do
        pragmas <-
            Bifunctor.first
                (SourceSyntaxPragmaError source)
                (extractSyntaxPragmas
                    (sourceNodeFileId node)
                    locationPath
                    (loadedText loaded))
        case runLexer
            (sourceNodeFileId node)
            locationPath
            (loadedText loaded) of
            Left err ->
                Left
                    (SourceParseError
                        source
                        (TokenError (errorBundlePretty err)))
            Right (_imports, chunks) ->
                Right
                    (TokenizedModule
                        node
                        imports
                        pragmas
                        chunks)

resolveParsedModuleImports
    :: ResolvedSourceGraph
    -> Map CanonicalPath ResolvedSourceAddress
    -> SourceNode
    -> Either ParseWorkspaceError [ParsedModuleImport]
resolveParsedModuleImports graph addresses node =
    traverse
        (parsedImport addresses)
        [ edge
        | edge <- sourceGraphImportEdges graph
        , sourceImportingNode edge
            == resolvedSourceCanonicalPath source
        ]
  where
    source = sourceNodeResolved node

parsedImport
    :: Map CanonicalPath ResolvedSourceAddress
    -> SourceImportEdge
    -> Either ParseWorkspaceError ParsedModuleImport
parsedImport addresses edge =
    case Map.lookup (sourceImportedNode edge) addresses of
        Nothing ->
            Left
                (SourceWorkspaceError
                    (SourceGraphInvariantViolation
                        "logical import refers to an unknown source node"))
        Just imported ->
            Right
                (ParsedModuleImport
                    (sourceImportReference edge)
                    imported)

scanTokenizedModule
    :: TokenizedModule
    -> ExceptT
        ParseWorkspaceError
        IO
        ScannedModule
scanTokenizedModule
        (TokenizedModule node imports pragmas chunks) = do
    associated <- either
        (throwE . SourceSyntaxDeclarationError source)
        pure
        (associateSyntaxPragmas chunks pragmas)
    scannedChunks <- traverse scanOne
        (zip chunks associated)
    pure (ScannedModule node imports scannedChunks)
  where
    source = sourceNodeResolved node

    scanOne (tokens, chunkPragmas) =
        case scanChunk tokens of
            Left err ->
                throwE
                    (SourceParseError
                        source
                        (LexicalScanFailure err))
            Right declarations ->
                pure
                    (ScannedChunk
                        tokens
                        chunkPragmas
                        declarations)

associateSyntaxPragmas
    :: [[Located Token]]
    -> [SyntaxPragma]
    -> Either SyntaxDeclarationError [[SyntaxPragma]]
associateSyntaxPragmas chunks =
    foldM associate (replicate (length chunks) [])
  where
    associate groups pragma =
        case
            [ index
            | (index, chunk) <- zip [0 :: Int ..] chunks
            , pragmaWithinChunk pragma chunk
            ] of
            [] ->
                Left
                    (SyntaxPragmaOutsideDeclaration
                        (syntaxPragmaLocation pragma))
            [selected] ->
                Right
                    [ if index == selected
                        then group <> [pragma]
                        else group
                    | (index, group) <- zip [0 :: Int ..] groups
                    ]
            _ ->
                impossible
                    "one syntax pragma belongs to overlapping top-level chunks"

pragmaWithinChunk
    :: SyntaxPragma
    -> [Located Token]
    -> Bool
pragmaWithinChunk pragma = \case
    firstToken : rest ->
        case reverse rest of
            finalToken : _ ->
                let pragmaLocation =
                        syntaxPragmaLocation pragma
                    firstLocation =
                        startPos firstToken
                    finalLocation =
                        startPos finalToken
                in
                    locFileId pragmaLocation
                        == locFileId firstLocation
                        && locLine firstLocation
                            < locLine pragmaLocation
                        && locLine pragmaLocation
                            < locLine finalLocation
            [] ->
                False
    [] ->
        False

prepareFreshRuntimeSyntaxModule
    :: Int
    -> ModuleSyntaxContext
    -> ScannedModule
    -> Either ParseWorkspaceError FreshRuntimeSyntax
prepareFreshRuntimeSyntaxModule moduleIndex context
        (ScannedModule node _imports chunks) = do
    (localEntries, preparedOccurrences) <-
        Bifunctor.first
            (localSyntaxWorkspaceError source)
            (prepareLocalSyntax
                moduleIndex
                (PhysicalSyntaxSite source)
                (syntaxContextImportedEntries context)
                chunks)
    (prepared, effectiveDelta) <-
        prepareSyntaxModule address context localEntries
    lexicon <-
        Bifunctor.first
            SourceSyntaxMaterializationError
            (materializeSyntaxDelta effectiveDelta)
    pure
        FreshRuntimeSyntax
            { freshRuntimePrepared = prepared
            , freshRuntimeLexicon = lexicon
            , freshRuntimeOccurrences = preparedOccurrences
            }
  where
    source = sourceNodeResolved node
    address = resolvedSourceAddress source

prepareSyntaxModule
    :: ResolvedSourceAddress
    -> ModuleSyntaxContext
    -> SyntaxEntryInventory
    -> Either
        ParseWorkspaceError
        (PreparedSyntaxModule, CanonicalSyntaxDelta)
prepareSyntaxModule address context localEntries = do
    localDelta <-
        Bifunctor.first
            localSyntaxCollisionWorkspaceError
            (validateSyntaxInventory localEntries)
    interface <-
        Bifunctor.first
            (const
                (SourceWorkspaceError
                    (SourceGraphInvariantViolation
                        "module syntax interface rejected distinct direct inputs")))
            (moduleSyntaxInterface
                (syntaxContextDirectIds context)
                localDelta)
    let effectiveEntries =
            Map.unionWith
                Set.union
                (syntaxContextImportedEntries context)
                localEntries
    effectiveDelta <-
        Bifunctor.first
            localSyntaxCollisionWorkspaceError
            (validateSyntaxInventory effectiveEntries)
    pure
        ( PreparedSyntaxModule
            { preparedAddress = address
            , preparedInterface = interface
            , preparedSyntaxDirectAddresses =
                syntaxContextDirectAddresses context
            , preparedLocalEntries = localEntries
            }
        , effectiveDelta
        )

prepareModuleSyntaxContext
    :: Map ResolvedSourceAddress PreparedSyntaxModule
    -> [ModuleSyntaxInterface]
    -> [ParsedModuleImport]
    -> Either ParseWorkspaceError ModuleSyntaxContext
prepareModuleSyntaxContext preparedByAddress implicitSyntax imports = do
    unless
        (all (null . moduleSyntaxDirectInputs) implicitSyntax)
        (Left
            (SourceWorkspaceError
                (SourceGraphInvariantViolation
                    "implicit syntax input is not self-contained")))
    directModules <- traverse
        (lookupPreparedSyntaxModule preparedByAddress)
        (nubOrd (parsedImportedAddress <$> imports))
    let (seenImplicit, implicitReversed) =
            foldl' insertImplicit (Set.empty, []) implicitSyntax
        (_seenAll, directReversed) =
            foldl' insertDirect (seenImplicit, []) directModules
        implicitSelected = reverse implicitReversed
        directSelected = reverse directReversed
        directAddresses = preparedAddress <$> directSelected
        directIds =
            (moduleSyntaxAssertedId <$> implicitSelected)
                <> ( moduleSyntaxAssertedId . preparedInterface
                        <$> directSelected
                   )
    directEntries <-
        foldImportedSyntax preparedByAddress directAddresses
    let importedEntries =
            foldl'
                (Map.unionWith Set.union)
                directEntries
                (implicitSyntaxInventory <$> implicitSelected)
    pure
        ModuleSyntaxContext
            { syntaxContextDirectIds = directIds
            , syntaxContextDirectAddresses = directAddresses
            , syntaxContextImportedEntries = importedEntries
            }
  where
    insertImplicit (seen, reversed) interface =
        let identity = moduleSyntaxAssertedId interface
        in
            if identity `Set.member` seen
                then (seen, reversed)
                else
                    (Set.insert identity seen, interface : reversed)

    insertDirect (seen, reversed) prepared =
        let identity =
                moduleSyntaxAssertedId (preparedInterface prepared)
        in
            if identity `Set.member` seen
                then (seen, reversed)
                else
                    (Set.insert identity seen, prepared : reversed)

    implicitSyntaxInventory interface =
        Map.fromList
            [ ( entry
              , Set.singleton
                    (ImplicitSyntaxProvider
                        (moduleSyntaxAssertedId interface))
              )
            | entry <-
                canonicalSyntaxDeltaEntries
                    (moduleSyntaxLocalDelta interface)
            ]

moduleParsedKey
    :: SourceNode
    -> ModuleSyntaxContext
    -> Either ParseWorkspaceError Parsed.ParsedModuleKey
moduleParsedKey node context =
    Bifunctor.first
        (SourceParsedModuleKeyError source)
        (Parsed.parsedModuleKey
            (Content.sourceContentIdBytes
                (loadedBytes (sourceNodeLoaded node)))
            baseSyntaxInterfaceId
            (syntaxContextDirectIds context))
  where
    source = sourceNodeResolved node

lookupPreparedSyntaxModule
    :: Map ResolvedSourceAddress PreparedSyntaxModule
    -> ResolvedSourceAddress
    -> Either ParseWorkspaceError PreparedSyntaxModule
lookupPreparedSyntaxModule preparedByAddress address =
    maybe
        (Left
            (SourceWorkspaceError
                (SourceGraphInvariantViolation
                    "syntax import refers to an unprepared module")))
        Right
        (Map.lookup address preparedByAddress)

foldImportedSyntax
    :: Map ResolvedSourceAddress PreparedSyntaxModule
    -> [ResolvedSourceAddress]
    -> Either ParseWorkspaceError SyntaxEntryInventory
foldImportedSyntax preparedByAddress addresses =
    snd <$> foldM visit (Set.empty, Map.empty) addresses
  where
    visit state address = do
        prepared <- lookupPreparedSyntaxModule preparedByAddress address
        let identity =
                moduleSyntaxAssertedId
                    (preparedInterface prepared)
        if identity `Set.member` fst state
            then
                Right state
            else do
                let marked =
                        (Set.insert identity (fst state), snd state)
                afterImports <- foldM
                    visit
                    marked
                    (preparedSyntaxDirectAddresses prepared)
                Right
                    ( fst afterImports
                    , Map.unionWith
                        Set.union
                        (snd afterImports)
                        (preparedLocalEntries prepared)
                    )

prepareLocalSyntax
    :: Int
    -> SyntaxSiteSource
    -> SyntaxEntryInventory
    -> [ScannedChunk]
    -> Either
        LocalSyntaxError
        ( SyntaxEntryInventory
        , [[PreparedSyntaxOccurrence]]
        )
prepareLocalSyntax
        moduleIndex
        source
        importedEntries
        chunks = do
    (localEntries, reversedOccurrences) <-
        foldM
            prepareOne
            (Map.empty, [])
            (zip [0 ..] chunks)
    pure
        ( localEntries
        , reverse reversedOccurrences
        )
  where
    importedIndex =
        syntaxSurfaceIndex importedEntries

    prepareOne
            (localEntries, reversedOccurrences)
            (blockIndex, chunk) = do
        classified <-
            prepareSyntaxChunk
                moduleIndex
                source
                blockIndex
                importedEntries
                importedIndex
                chunk
        (localEntries', reversedPrepared) <-
            foldM
                insertClassified
                (localEntries, [])
                classified
        pure
            ( localEntries'
            , reverse reversedPrepared : reversedOccurrences
            )

    insertClassified
            (entries, reversed)
            (ClassifiedSyntaxItem site disposition _eligible) =
        case disposition of
            EmitSyntaxEntry entry ->
                Right
                    ( Map.insertWith
                        Set.union
                        entry
                        (Set.singleton
                            (DeclarationSyntaxProvider site))
                        entries
                    , PreparedSyntaxOccurrence
                        site
                        entry
                        : reversed
                    )
            ReuseImportedSyntax entry ->
                Right
                    ( entries
                    , PreparedSyntaxOccurrence
                        site
                        entry
                        : reversed
                    )
            ReuseFixedSyntax entry ->
                Right
                    ( entries
                    , PreparedSyntaxOccurrence
                        site
                        entry
                        : reversed
                    )

prepareSyntaxChunk
    :: Int
    -> SyntaxSiteSource
    -> Int
    -> SyntaxEntryInventory
    -> Map Raw.Pattern (Set CanonicalLexicalEntry)
    -> ScannedChunk
    -> Either LocalSyntaxError [ClassifiedSyntaxItem]
prepareSyntaxChunk
        moduleIndex
        source
        blockIndex
        importedEntries
        importedIndex
        (ScannedChunk tokens pragmas declarations) = do
    classified <- traverse classify
        (zip [0 ..] declarations)
    case (classified, pragmas) of
        ([], pragma : _) ->
            Left
                (LocalSyntaxDeclarationError
                    (SyntaxPragmaOutsideDeclaration
                        (syntaxPragmaLocation pragma)))
        (_, firstPragma : secondPragma : _) ->
            Left
                (LocalSyntaxDeclarationError
                    (DuplicateSyntaxPragma
                        (syntaxPragmaLocation firstPragma)
                        (syntaxPragmaLocation secondPragma)))
        (_, [pragma]) ->
            applyOnePragma pragma classified
        (_, []) ->
            requireNewFixities classified
  where
    declarationLocation =
        case tokens of
            token : _ ->
                startPos token
            [] ->
                Nowhere

    classify (itemIndex, locatedItem) = do
        let item = unLocated locatedItem
            location = startPos locatedItem
            site =
                SyntaxDeclarationSite
                    { syntaxSiteModuleIndex = moduleIndex
                    , syntaxSiteBlockIndex = blockIndex
                    , syntaxSiteItemIndex = itemIndex
                    , syntaxSiteSource = source
                    , syntaxSiteLocation = location
                    , syntaxSiteMarker = scannedItemMarker item
                    }
            localEntry =
                canonicalScannedItem
                    defaultSourceFixity
                    item
            eligible =
                case localEntry of
                    CanonicalExpressionFunction pat _marker _fixity ->
                        eligibleExpressionPattern pat
                    _ ->
                        False
            fixedMatches =
                entriesForSurfaces
                    fixedBaseSurfaceIndex
                    localEntry
        disposition <- case Set.toAscList fixedMatches of
            [] ->
                classifyImported
                    site
                    localEntry
            [fixedEntry]
                | sameFixedSyntaxShape localEntry fixedEntry ->
                    Right (ReuseFixedSyntax fixedEntry)
                | otherwise ->
                    Left
                        (LocalSyntaxCollision
                            (makeLexiconCollision
                                (sharedSurface
                                    localEntry
                                    fixedEntry)
                                [ FixedLexiconOrigin fixedEntry
                                , sourceCollisionOrigin
                                    localEntry
                                    site
                                ]))
            _ ->
                impossible
                    "fixed base has several entries for one parser surface"
        Right
            (ClassifiedSyntaxItem
                site
                disposition
                eligible)

    classifyImported site localEntry =
        let importedMatches =
                entriesForSurfaces importedIndex localEntry
        in
            case localEntry of
                CanonicalExpressionFunction
                        localPattern
                        localMarker
                        _localFixity ->
                    case Set.toAscList importedMatches of
                        [] ->
                            Right (EmitSyntaxEntry localEntry)
                        [ importedEntry@(CanonicalExpressionFunction
                                importedPattern
                                importedMarker
                                _importedFixity)
                          ]
                            | localPattern == importedPattern
                                && localMarker == importedMarker ->
                                Right
                                    (ReuseImportedSyntax importedEntry)
                        entries ->
                            Left
                                (LocalSyntaxCollision
                                    (makeLexiconCollision
                                        (firstSharedSurface
                                            localEntry
                                            entries)
                                        (importedCollisionOrigins
                                            importedEntries
                                            entries
                                            <> [ sourceCollisionOrigin
                                                localEntry
                                                site
                                               ])))
                _ ->
                    Right (EmitSyntaxEntry localEntry)

    applyOnePragma pragma classified =
        case List.filter classifiedItemEligible classified of
            [] ->
                Left
                    (LocalSyntaxDeclarationError
                        (IrrelevantSyntaxPragma
                            (syntaxPragmaLocation pragma)
                            declarationLocation))
            [only] ->
                case classifiedDisposition only of
                    ReuseFixedSyntax entry ->
                        Left
                            (LocalSyntaxDeclarationError
                                (SyntaxPragmaOnFixedReuse
                                    (syntaxPragmaLocation pragma)
                                    (entryPrimarySurface entry)))
                    ReuseImportedSyntax entry ->
                        Left
                            (LocalSyntaxDeclarationError
                                (SyntaxPragmaOnImportedReuse
                                    (syntaxPragmaLocation pragma)
                                    (entryPrimarySurface entry)))
                    EmitSyntaxEntry entry ->
                        Right
                            [ replaceClassifiedEntry
                                only
                                (setExpressionFixity
                                    (sourcePragmaFixity pragma)
                                    entry)
                                current
                            | current <- classified
                            ]
            several ->
                Left
                    (LocalSyntaxDeclarationError
                        (AmbiguousSyntaxPragmaTarget
                            (syntaxPragmaLocation pragma)
                            (eligiblePatterns several)))

    requireNewFixities classified =
        case
            [ item
            | item <- classified
            , classifiedItemEligible item
            , case classifiedDisposition item of
                EmitSyntaxEntry _entry ->
                    True
                _ ->
                    False
            ] of
            [] ->
                Right classified
            [only] ->
                Left
                    (LocalSyntaxDeclarationError
                        (MissingSyntaxPragma
                            (classifiedLocation only)
                            (classifiedPattern only)))
            several@(firstItem : _) ->
                Left
                    (LocalSyntaxDeclarationError
                        (MultipleNewSyntaxPatternsWithoutPragma
                            (classifiedLocation firstItem)
                            (eligiblePatterns several)))

defaultSourceFixity :: Fixity
defaultSourceFixity =
    Fixity
        Raw.NonAssoc
        (case mixfixLevel 9 of
            Right level ->
                level
            Left err ->
                impossible
                    ("source default fixity is invalid: "
                        <> show err))

fixedBaseSurfaceIndex
    :: Map Raw.Pattern (Set CanonicalLexicalEntry)
fixedBaseSurfaceIndex =
    entrySurfaceIndex fixedBaseSyntaxEntries

syntaxSurfaceIndex
    :: SyntaxEntryInventory
    -> Map Raw.Pattern (Set CanonicalLexicalEntry)
syntaxSurfaceIndex =
    entrySurfaceIndex . Map.keys

entrySurfaceIndex
    :: [CanonicalLexicalEntry]
    -> Map Raw.Pattern (Set CanonicalLexicalEntry)
entrySurfaceIndex =
    foldl' insertEntry Map.empty
  where
    insertEntry index entry =
        foldl'
            (\current pat ->
                Map.insertWith
                    Set.union
                    pat
                    (Set.singleton entry)
                    current)
            index
            (canonicalLexicalSurfacePatterns entry)

entriesForSurfaces
    :: Map Raw.Pattern (Set CanonicalLexicalEntry)
    -> CanonicalLexicalEntry
    -> Set CanonicalLexicalEntry
entriesForSurfaces index entry =
    Set.unions
        [ Map.findWithDefault Set.empty pat index
        | pat <- toList
            (canonicalLexicalSurfacePatterns entry)
        ]

sameFixedSyntaxShape
    :: CanonicalLexicalEntry
    -> CanonicalLexicalEntry
    -> Bool
sameFixedSyntaxShape left right =
    case (left, right) of
        ( CanonicalLeftAdjective leftPattern _leftMarker
          , CanonicalLeftAdjective rightPattern _rightMarker
          ) ->
            leftPattern == rightPattern
        ( CanonicalRightAdjective leftPattern _leftMarker
          , CanonicalRightAdjective rightPattern _rightMarker
          ) ->
            leftPattern == rightPattern
        ( CanonicalFunctionPhrase leftSingular leftPlural _leftMarker
          , CanonicalFunctionPhrase rightSingular rightPlural _rightMarker
          ) ->
            (leftSingular, leftPlural)
                == (rightSingular, rightPlural)
        ( CanonicalNoun leftSingular leftPlural _leftMarker
          , CanonicalNoun rightSingular rightPlural _rightMarker
          ) ->
            (leftSingular, leftPlural)
                == (rightSingular, rightPlural)
        ( CanonicalStructureNoun leftSingular leftPlural _leftMarker
          , CanonicalStructureNoun rightSingular rightPlural _rightMarker
          ) ->
            (leftSingular, leftPlural)
                == (rightSingular, rightPlural)
        ( CanonicalVerb leftSingular leftPlural _leftMarker
          , CanonicalVerb rightSingular rightPlural _rightMarker
          ) ->
            (leftSingular, leftPlural)
                == (rightSingular, rightPlural)
        ( CanonicalRelation leftToken leftArity _leftMarker
          , CanonicalRelation rightToken rightArity _rightMarker
          ) ->
            (leftToken, leftArity)
                == (rightToken, rightArity)
        ( CanonicalExpressionFunction
                leftPattern
                _leftMarker
                _leftFixity
          , CanonicalExpressionFunction
                rightPattern
                _rightMarker
                _rightFixity
          ) ->
            leftPattern == rightPattern
        ( CanonicalPrefixPredicate
                leftCommand
                leftArity
                _leftMarker
          , CanonicalPrefixPredicate
                rightCommand
                rightArity
                _rightMarker
          ) ->
            (leftCommand, leftArity)
                == (rightCommand, rightArity)
        ( CanonicalStructureOperation leftCommand
          , CanonicalStructureOperation rightCommand
          ) ->
            leftCommand == rightCommand
        _ ->
            False

sharedSurface
    :: CanonicalLexicalEntry
    -> CanonicalLexicalEntry
    -> Raw.Pattern
sharedSurface left right =
    case Set.lookupMin
            (Set.intersection
                (entrySurfaces left)
                (entrySurfaces right)) of
        Just pat ->
            pat
        Nothing ->
            impossible
                "colliding syntax entries have no shared parser surface"

firstSharedSurface
    :: CanonicalLexicalEntry
    -> [CanonicalLexicalEntry]
    -> Raw.Pattern
firstSharedSurface localEntry entries =
    case Set.lookupMin
            (Set.unions
                [ Set.intersection
                    (entrySurfaces localEntry)
                    (entrySurfaces entry)
                | entry <- entries
                ]) of
        Just pat ->
            pat
        Nothing ->
            impossible
                "imported syntax collision has no shared parser surface"

entryPrimarySurface :: CanonicalLexicalEntry -> Raw.Pattern
entryPrimarySurface entry =
    NonEmpty.head (canonicalLexicalSurfacePatterns entry)

entrySurfaces :: CanonicalLexicalEntry -> Set Raw.Pattern
entrySurfaces =
    Set.fromList
        . toList
        . canonicalLexicalSurfacePatterns

classifiedItemEligible :: ClassifiedSyntaxItem -> Bool
classifiedItemEligible
        (ClassifiedSyntaxItem _site _disposition eligible) =
    eligible

classifiedDisposition
    :: ClassifiedSyntaxItem
    -> SyntaxItemDisposition
classifiedDisposition
        (ClassifiedSyntaxItem _site disposition _eligible) =
    disposition

classifiedLocation :: ClassifiedSyntaxItem -> Location
classifiedLocation
        (ClassifiedSyntaxItem site _disposition _eligible) =
    syntaxSiteLocation site

classifiedPattern :: ClassifiedSyntaxItem -> Raw.Pattern
classifiedPattern =
    entryPrimarySurface . dispositionEntry . classifiedDisposition

dispositionEntry :: SyntaxItemDisposition -> CanonicalLexicalEntry
dispositionEntry = \case
    EmitSyntaxEntry entry ->
        entry
    ReuseFixedSyntax entry ->
        entry
    ReuseImportedSyntax entry ->
        entry

eligiblePatterns
    :: [ClassifiedSyntaxItem]
    -> NonEmpty Raw.Pattern
eligiblePatterns = \case
    [] ->
        impossible
            "an ambiguous pragma target has no eligible patterns"
    item : rest ->
        classifiedPattern item
            :| (classifiedPattern <$> rest)

replaceClassifiedEntry
    :: ClassifiedSyntaxItem
    -> CanonicalLexicalEntry
    -> ClassifiedSyntaxItem
    -> ClassifiedSyntaxItem
replaceClassifiedEntry
        (ClassifiedSyntaxItem targetSite _targetDisposition _targetEligible)
        replacement
        current@(ClassifiedSyntaxItem site _disposition eligible)
    | site == targetSite =
        ClassifiedSyntaxItem
            site
            (EmitSyntaxEntry replacement)
            eligible
    | otherwise =
        current

setExpressionFixity
    :: Fixity
    -> CanonicalLexicalEntry
    -> CanonicalLexicalEntry
setExpressionFixity fixity = \case
    CanonicalExpressionFunction pat marker _oldFixity ->
        CanonicalExpressionFunction pat marker fixity
    entry ->
        impossible
            ("a pragma targeted a non-expression entry: "
                <> show entry)

validateSyntaxInventory
    :: SyntaxEntryInventory
    -> Either LocalSyntaxError CanonicalSyntaxDelta
validateSyntaxInventory inventory =
    case canonicalSyntaxDelta (Map.keys inventory) of
        Right delta ->
            Right delta
        Left collision ->
            Left
                (LocalSyntaxCollision
                    (inventoryCollision inventory collision))

inventoryCollision
    :: SyntaxEntryInventory
    -> CanonicalSyntaxCollision
    -> LexiconCollision
inventoryCollision inventory collision =
    makeLexiconCollision
        (canonicalCollisionPattern collision)
        (syntaxCollisionOrigins
            inventory
            (toList (canonicalCollisionEntries collision)))

importedCollisionOrigins
    :: SyntaxEntryInventory
    -> [CanonicalLexicalEntry]
    -> [LexiconCollisionOrigin]
importedCollisionOrigins inventory entries =
    syntaxCollisionOrigins inventory entries

syntaxCollisionOrigins
    :: SyntaxEntryInventory
    -> [CanonicalLexicalEntry]
    -> [LexiconCollisionOrigin]
syntaxCollisionOrigins inventory entries =
    [ providerCollisionOrigin entry provider
    | (provider, entry) <-
        List.sortOn fst
            [ (provider, entry)
            | entry <- entries
            , provider <-
                Set.toList
                    (Map.findWithDefault
                        Set.empty
                        entry
                        inventory)
            ]
    ]

providerCollisionOrigin
    :: CanonicalLexicalEntry
    -> SyntaxEntryProvider
    -> LexiconCollisionOrigin
providerCollisionOrigin entry = \case
    DeclarationSyntaxProvider site ->
        sourceCollisionOrigin entry site
    ImplicitSyntaxProvider interface ->
        ImportedLexiconOrigin entry interface

sourceCollisionOrigin
    :: CanonicalLexicalEntry
    -> SyntaxDeclarationSite
    -> LexiconCollisionOrigin
sourceCollisionOrigin entry site =
    case syntaxSiteSource site of
        PhysicalSyntaxSite source ->
            SourceLexiconOrigin
                entry
                source
                (syntaxSiteLocation site)
        ReservedSyntaxSite label ->
            ReservedLexiconOrigin
                entry
                label
                (syntaxSiteLocation site)

makeLexiconCollision
    :: Raw.Pattern
    -> [LexiconCollisionOrigin]
    -> LexiconCollision
makeLexiconCollision pat origins =
    case origins of
        firstOrigin : secondOrigin : rest ->
            LexiconCollision
                pat
                firstOrigin
                secondOrigin
                rest
        _ ->
            impossible
                "a lexical collision has fewer than two providers"

-- V1 associates scanner items with one parsed declaration. The block-head
-- marker anchors the declaration; additional datatype and structure items
-- retain scanner order and are not matched to individual AST nodes here.
validateOccurrenceAssociation
    :: SyntaxSiteSource
    -> Int
    -> Raw.Block
    -> [PreparedSyntaxOccurrence]
    -> Either OccurrenceAssociationError ()
validateOccurrenceAssociation _source _blockIndex _block [] =
    Right ()
validateOccurrenceAssociation source blockIndex block prepared = do
    forM_ prepared
        \occurrence -> do
            let site =
                    preparedSyntaxSite occurrence
            unless
                (syntaxSiteSource site == source)
                (Left
                    (OccurrenceAssociationInvariantError
                        "syntax occurrence belongs to a different source"))
            unless
                (syntaxSiteBlockIndex site == blockIndex)
                (Left
                    (OccurrenceAssociationInvariantError
                        "syntax occurrence belongs to a different block"))
    validateHeadMarker
  where
    validateHeadMarker = case prepared of
        occurrence : _rest -> do
            let site =
                    preparedSyntaxSite occurrence
                location =
                    syntaxSiteLocation site
                expectedMarker =
                    syntaxSiteMarker site
            case rawBlockMarker block of
                Nothing ->
                    Left
                        (OccurrenceAssociationDeclarationError
                            (SyntaxOccurrenceMissingBlockMarker
                                location
                                expectedMarker))
                Just actual ->
                    unless
                        (actual == expectedMarker)
                        (Left
                            (OccurrenceAssociationDeclarationError
                                (SyntaxOccurrenceMarkerMismatch
                                    location
                                    expectedMarker
                                    actual)))

rawBlockMarker :: Raw.Block -> Maybe Raw.Marker
rawBlockMarker = \case
    Raw.BlockAxiom _location _title marker _axiom ->
        Just marker
    Raw.BlockClaim _kind _location _title marker _claim ->
        Just marker
    Raw.BlockProof{} ->
        Nothing
    Raw.BlockDefn _location _title marker _definition ->
        Just marker
    Raw.BlockAbbr _location _title marker _abbreviation ->
        Just marker
    Raw.BlockData _location _title marker _datatype ->
        Just marker
    Raw.BlockInductive _location _title marker _inductive ->
        Just marker
    Raw.BlockSig _location _title marker _assumptions _signature ->
        Just marker
    Raw.BlockStruct _location _title marker _structure ->
        Just marker

parseScannedModule
    :: (ResolvedSource -> Raw.Block -> IO ())
    -> FreshRuntimeSyntax
    -> ScannedModule
    -> ExceptT ParseWorkspaceError IO ParsedModule
parseScannedModule
        emitBlock
        runtime
        (ScannedModule node imports chunks) = do
    let preparedRuntime = freshRuntimePrepared runtime
    unless
        (preparedAddress preparedRuntime
            == resolvedSourceAddress source)
        (throwE
            (SourceWorkspaceError
                (SourceGraphInvariantViolation
                    "runtime syntax was paired with the wrong source module")))
    unless
        (length chunks
            == length (freshRuntimeOccurrences runtime))
        (throwE
            (SourceWorkspaceError
                (SourceGraphInvariantViolation
                    "runtime syntax occurrence groups do not match source chunks")))
    let loaded = sourceNodeLoaded node
    input <-
        either
            (const
                (throwE
                    (SourceWorkspaceError
                        (SourceGraphInvariantViolation
                            "validated source text does not match its exact bytes"))))
            pure
            (freshModuleInput
                (moduleName (resolvedSourceAddress source))
                (FreshPhysicalSource source)
                (sourceNodeFileId node)
                (resolvedSourceLocationPath source)
                (loadedBytes loaded)
                (loadedText loaded)
                (parsedImportReference <$> imports)
                (preparedInterface preparedRuntime))
    (reversedBlocks, reversedOccurrences) <-
        foldM
            parsePreparedChunk
            ([], [])
            (zip3
                [0 ..]
                chunks
                (freshRuntimeOccurrences runtime))
    let blocks = reverse reversedBlocks
        occurrences = reverse reversedOccurrences
    fresh <-
        either
            (throwE . SourceParsedModuleKeyError source)
            pure
            (identifyParsedModule input blocks occurrences)
    let
        parsedModule =
            ParsedModule
                loaded
                imports
                fresh
    -- Force each module before it leaves the parser producer.
    liftIO (evaluate (force parsedModule))
  where
    source = sourceNodeResolved node
    -- Reuse one immutable parser for every chunk in this module.
    moduleParser
        :: Parser Text [Located Token] Raw.Block
    moduleParser =
        parser (grammar (freshRuntimeLexicon runtime))

    parsePreparedChunk
            (currentBlocks, currentOccurrences)
            (blockIndex, ScannedChunk tokens _pragmas _items, prepared) =
        case parsePreparedTokenChunk moduleParser tokens of
            Left err ->
                throwE (SourceParseError source err)
            Right parsedBlock -> do
                block <- liftIO (evaluate (force parsedBlock))
                either
                    (throwE . occurrenceWorkspaceError source)
                    pure
                    (validateOccurrenceAssociation
                        (PhysicalSyntaxSite source)
                        blockIndex
                        block
                        prepared)
                liftIO (emitBlock source block)
                pure
                    ( block : currentBlocks
                    , foldl'
                        (flip (:))
                        currentOccurrences
                        [ ParsedSyntaxOccurrence
                            blockIndex
                            (syntaxSiteLocation
                                (preparedSyntaxSite occurrence))
                            (syntaxSiteMarker
                                (preparedSyntaxSite occurrence))
                            (preparedSyntaxEntry occurrence)
                        | occurrence <- prepared
                        ]
                    )

parseChunkResult
    :: ([Raw.Block], Report Text [Located Token])
    -> Either ParseException [Raw.Block]
parseChunkResult = \case
    (_, Report _ expectations (token : tokens)) ->
        Left (UnconsumedTokens expectations (token :| tokens))
    ([], _) ->
        Left EmptyParse
    (ambiguous@(_ : _ : _), _) ->
        case nubOrd ambiguous of
            [block] ->
                Right [block]
            distinct ->
                Left (AmbiguousParse distinct)
    ([block], _) ->
        Right [block]

parsePreparedTokenChunk
    :: Parser Text [Located Token] Raw.Block
    -> [Located Token]
    -> Either ParseException Raw.Block
parsePreparedTokenChunk prepared tokens = do
    parsed <- parseChunkResult (fullParses prepared tokens)
    case parsed of
        [block] -> Right block
        _ ->
            impossible
                "one token chunk parsed into multiple blocks"


describeToken :: Token -> String
describeToken = \case
    Word _ -> "word"
    Variable _ -> "variable"
    Symbol _ -> "symbol"
    Integer _ -> "integer"
    Command _ -> "command"
    BeginEnv _ -> "begin of environment"
    EndEnv _ -> "end of environment"
    _ -> "delimiter"