{-# 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"