Parse source graphs module by module

1 files changed, 148 insertions, 131 deletions

diff --git a/source/Felix/Parse.hs b/source/Felix/Parse.hs
index 913d944..d3b291b 100644
--- a/source/Felix/Parse.hs
+++ b/source/Felix/Parse.hs
@@ -113,7 +113,7 @@ import Syntax.Token
 
 import Control.DeepSeq (NFData, force)
 import Control.Exception (Exception, evaluate)
-import Control.Monad (foldM, unless)
+import Control.Monad (foldM, unless, when)
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
 import Data.Bifunctor qualified as Bifunctor
 import Data.List (intercalate)
@@ -821,13 +821,17 @@ data ClassifiedSyntaxItem = ClassifiedSyntaxItem
     !SyntaxItemDisposition
     !Bool
 
-data RuntimeSyntaxModule = RuntimeSyntaxModule
-    { runtimeAddress :: !ResolvedSourceAddress
-    , runtimeInterface :: !ModuleSyntaxInterface
-    , runtimeSyntaxDirectAddresses :: ![ResolvedSourceAddress]
-    , runtimeLocalEntries :: !SyntaxEntryInventory
-    , runtimeLexicon :: !Lexicon
-    , runtimePreparedOccurrences :: ![[PreparedSyntaxOccurrence]]
+data PreparedSyntaxModule = PreparedSyntaxModule
+    { preparedAddress :: !ResolvedSourceAddress
+    , preparedInterface :: !ModuleSyntaxInterface
+    , preparedSyntaxDirectAddresses :: ![ResolvedSourceAddress]
+    , preparedLocalEntries :: !SyntaxEntryInventory
+    }
+
+data FreshRuntimeSyntax = FreshRuntimeSyntax
+    { freshRuntimePrepared :: !PreparedSyntaxModule
+    , freshRuntimeLexicon :: !Lexicon
+    , freshRuntimeOccurrences :: ![[PreparedSyntaxOccurrence]]
     }
 
 -- | Invocation-local parser work. A module is one strictly read source file.
@@ -1003,48 +1007,37 @@ parseResolvedSourceGraphMeasuredWith graph syntaxInputs emitBlock =
                       )
                     | node <- NonEmpty.toList orderedNodes
                     ]
-        tokenizationStart <- liftIO getMonotonicTimeNSec
-        orderedTokenized <- traverse
-            (ExceptT . tokenizeModule graph addresses)
-            orderedNodes
-        tokenizationEnd <- liftIO getMonotonicTimeNSec
-        scanningStart <- liftIO getMonotonicTimeNSec
-        orderedScanned <- traverse
-            scanTokenizedModule
-            orderedTokenized
-        scanningEnd <- liftIO getMonotonicTimeNSec
-        syntaxInterfaceStart <- liftIO getMonotonicTimeNSec
-        -- Runtime syntax construction materializes one lexicon per module.
-        orderedRuntime <-
-            buildRuntimeSyntaxModules syntaxInputs orderedScanned
-        syntaxInterfaceEnd <- liftIO getMonotonicTimeNSec
-        parsingStart <- liftIO getMonotonicTimeNSec
-        parsedModules <- sequence
-            (NonEmpty.zipWith
-                (parseScannedModule emitBlock)
-                orderedRuntime
-                orderedScanned)
-        parsingEnd <- liftIO getMonotonicTimeNSec
+        completed <- foldM
+            (parseOneModule graph addresses syntaxInputs emitBlock)
+            emptyModuleParseState
+            (zip [0 ..] (NonEmpty.toList orderedNodes))
+        parsedModules <- case NonEmpty.nonEmpty
+                (reverse (moduleParseReversed completed)) of
+            Just modules ->
+                pure modules
+            Nothing ->
+                throwE
+                    (SourceWorkspaceError
+                        (SourceGraphInvariantViolation
+                            "source graph produced no parsed modules"))
         let measurements =
                 ParseMeasurements
                     { parseMeasurementResolutionNanoseconds =
                         0
                     , parseMeasurementTokenizationNanoseconds =
-                        tokenizationEnd - tokenizationStart
+                        moduleParseTokenizationNanoseconds completed
                     , parseMeasurementScanningNanoseconds =
-                        scanningEnd - scanningStart
+                        moduleParseScanningNanoseconds completed
                     , parseMeasurementSyntaxInterfaceNanoseconds =
-                        syntaxInterfaceEnd - syntaxInterfaceStart
+                        moduleParseSyntaxNanoseconds completed
                     , parseMeasurementParsingNanoseconds =
-                        parsingEnd - parsingStart
+                        moduleParseParsingNanoseconds completed
                     , parseMeasurementModuleCount =
                         NonEmpty.length orderedNodes
                     , parseMeasurementImportOccurrenceCount =
                         length (sourceGraphImportEdges graph)
                     , parseMeasurementChunkCount =
-                        sum
-                            (tokenizedModuleChunkCount
-                                <$> NonEmpty.toList orderedTokenized)
+                        moduleParseChunkCount completed
                     , parseMeasurementSourceByteCount =
                         sum
                             (loadedByteCount
@@ -1059,6 +1052,79 @@ parseResolvedSourceGraphMeasuredWith graph syntaxInputs emitBlock =
             , measurements
             )
 
+data ModuleParseState = ModuleParseState
+    { moduleParsePrepared
+        :: !(Map ResolvedSourceAddress PreparedSyntaxModule)
+    , moduleParseReversed :: ![ParsedModule]
+    , moduleParseTokenizationNanoseconds :: !Word64
+    , moduleParseScanningNanoseconds :: !Word64
+    , moduleParseSyntaxNanoseconds :: !Word64
+    , moduleParseParsingNanoseconds :: !Word64
+    , moduleParseChunkCount :: !Int
+    }
+
+emptyModuleParseState :: ModuleParseState
+emptyModuleParseState =
+    ModuleParseState Map.empty [] 0 0 0 0 0
+
+parseOneModule
+    :: ResolvedSourceGraph
+    -> Map CanonicalPath ResolvedSourceAddress
+    -> (ResolvedSource -> [ModuleSyntaxInterface])
+    -> (ResolvedSource -> Raw.Block -> IO ())
+    -> ModuleParseState
+    -> (Int, SourceNode)
+    -> ExceptT ParseWorkspaceError IO ModuleParseState
+parseOneModule graph addresses syntaxInputs emitBlock state
+        (moduleIndex, node) = do
+    tokenizationStart <- liftIO getMonotonicTimeNSec
+    tokenized <- ExceptT (tokenizeModule graph addresses node)
+    tokenizationEnd <- liftIO getMonotonicTimeNSec
+    scanningStart <- liftIO getMonotonicTimeNSec
+    scanned <- scanTokenizedModule tokenized
+    scanningEnd <- liftIO getMonotonicTimeNSec
+    syntaxStart <- liftIO getMonotonicTimeNSec
+    runtime <- either throwE pure
+        (prepareFreshRuntimeSyntaxModule
+            moduleIndex
+            (moduleParsePrepared state)
+            (syntaxInputs (sourceNodeResolved node))
+            scanned)
+    syntaxEnd <- liftIO getMonotonicTimeNSec
+    parsingStart <- liftIO getMonotonicTimeNSec
+    parsed <- parseScannedModule emitBlock runtime scanned
+    parsingEnd <- liftIO getMonotonicTimeNSec
+    let prepared = freshRuntimePrepared runtime
+        address = preparedAddress prepared
+    when
+        (Map.member address (moduleParsePrepared state))
+        (throwE
+            (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
+            }
+
 withResolutionMeasurements
     :: ParseMeasurements
     -> Word64
@@ -1231,61 +1297,13 @@ pragmaWithinChunk pragma = \case
     [] ->
         False
 
-buildRuntimeSyntaxModules
-    :: (ResolvedSource -> [ModuleSyntaxInterface])
-    -> NonEmpty ScannedModule
-    -> ExceptT
-        ParseWorkspaceError
-        IO
-        (NonEmpty RuntimeSyntaxModule)
-buildRuntimeSyntaxModules syntaxInputs modules = do
-    (_runtimeByAddress, reversed) <-
-        foldM buildOne
-            (Map.empty, [])
-            (zip [0 ..] (NonEmpty.toList modules))
-    case NonEmpty.nonEmpty (reverse reversed) of
-        Just runtime ->
-            pure runtime
-        Nothing ->
-            throwE
-                (SourceWorkspaceError
-                    (SourceGraphInvariantViolation
-                        "source graph produced no runtime syntax modules"))
-  where
-    buildOne
-            (runtimeByAddress, reversed)
-            (moduleIndex, scanned) = do
-        runtime <- either throwE pure
-            (prepareRuntimeSyntaxModule
-                moduleIndex
-                runtimeByAddress
-                (syntaxInputs
-                    (sourceNodeResolved
-                        (scannedModuleNode scanned)))
-                scanned)
-        let address = runtimeAddress runtime
-        if Map.member address runtimeByAddress
-            then
-                throwE
-                    (SourceWorkspaceError
-                        (SourceGraphInvariantViolation
-                            "runtime syntax module address is duplicated"))
-            else
-                pure
-                    ( Map.insert
-                        address
-                        runtime
-                        runtimeByAddress
-                    , runtime : reversed
-                    )
-
-prepareRuntimeSyntaxModule
+prepareFreshRuntimeSyntaxModule
     :: Int
-    -> Map ResolvedSourceAddress RuntimeSyntaxModule
+    -> Map ResolvedSourceAddress PreparedSyntaxModule
     -> [ModuleSyntaxInterface]
     -> ScannedModule
-    -> Either ParseWorkspaceError RuntimeSyntaxModule
-prepareRuntimeSyntaxModule moduleIndex runtimeByAddress implicitSyntax
+    -> Either ParseWorkspaceError FreshRuntimeSyntax
+prepareFreshRuntimeSyntaxModule moduleIndex preparedByAddress implicitSyntax
         (ScannedModule node imports chunks) = do
     unless
         (all
@@ -1300,15 +1318,15 @@ prepareRuntimeSyntaxModule moduleIndex runtimeByAddress implicitSyntax
                 (SourceGraphInvariantViolation
                     "Phase 3 implicit syntax input is not self-contained and empty")))
     directModules <- traverse
-        (lookupRuntimeModule runtimeByAddress)
+        (lookupPreparedSyntaxModule preparedByAddress)
         directAddresses
     let syntaxDirects =
-            distinctSyntaxInterfaces directModules
+            distinctPreparedSyntaxInterfaces directModules
         syntaxDirectAddresses =
-            runtimeAddress <$> syntaxDirects
+            preparedAddress <$> syntaxDirects
     importedEntries <-
         foldImportedSyntax
-            runtimeByAddress
+            preparedByAddress
             syntaxDirectAddresses
     (localEntries, preparedOccurrences) <-
         prepareLocalSyntax
@@ -1327,7 +1345,7 @@ prepareRuntimeSyntaxModule moduleIndex runtimeByAddress implicitSyntax
             (moduleSyntaxInterface
                 ( (moduleSyntaxAssertedId <$> implicitSyntax)
                     <> ( moduleSyntaxAssertedId
-                            . runtimeInterface
+                            . preparedInterface
                             <$> syntaxDirects
                        )
                 )
@@ -1343,16 +1361,18 @@ prepareRuntimeSyntaxModule moduleIndex runtimeByAddress implicitSyntax
         Bifunctor.first
             SourceSyntaxMaterializationError
             (materializeSyntaxDelta effectiveDelta)
+    let prepared =
+            PreparedSyntaxModule
+                { preparedAddress = address
+                , preparedInterface = interface
+                , preparedSyntaxDirectAddresses = syntaxDirectAddresses
+                , preparedLocalEntries = localEntries
+                }
     pure
-        RuntimeSyntaxModule
-            { runtimeAddress = address
-            , runtimeInterface = interface
-            , runtimeSyntaxDirectAddresses =
-                syntaxDirectAddresses
-            , runtimeLocalEntries = localEntries
-            , runtimeLexicon = lexicon
-            , runtimePreparedOccurrences =
-                preparedOccurrences
+        FreshRuntimeSyntax
+            { freshRuntimePrepared = prepared
+            , freshRuntimeLexicon = lexicon
+            , freshRuntimeOccurrences = preparedOccurrences
             }
   where
     source = sourceNodeResolved node
@@ -1361,54 +1381,50 @@ prepareRuntimeSyntaxModule moduleIndex runtimeByAddress implicitSyntax
         nubOrd
             (parsedImportedAddress <$> imports)
 
-scannedModuleNode :: ScannedModule -> SourceNode
-scannedModuleNode (ScannedModule node _imports _chunks) =
-    node
-
-lookupRuntimeModule
-    :: Map ResolvedSourceAddress RuntimeSyntaxModule
+lookupPreparedSyntaxModule
+    :: Map ResolvedSourceAddress PreparedSyntaxModule
     -> ResolvedSourceAddress
-    -> Either ParseWorkspaceError RuntimeSyntaxModule
-lookupRuntimeModule runtimeByAddress address =
+    -> Either ParseWorkspaceError PreparedSyntaxModule
+lookupPreparedSyntaxModule preparedByAddress address =
     maybe
         (Left
             (SourceWorkspaceError
                 (SourceGraphInvariantViolation
                     "syntax import refers to an unprepared module")))
         Right
-        (Map.lookup address runtimeByAddress)
+        (Map.lookup address preparedByAddress)
 
-distinctSyntaxInterfaces
-    :: [RuntimeSyntaxModule]
-    -> [RuntimeSyntaxModule]
-distinctSyntaxInterfaces =
+distinctPreparedSyntaxInterfaces
+    :: [PreparedSyntaxModule]
+    -> [PreparedSyntaxModule]
+distinctPreparedSyntaxInterfaces =
     reverse . snd . foldl' insert (Set.empty, [])
   where
-    insert (seen, reversed) runtime =
+    insert (seen, reversed) prepared =
         let identity =
                 moduleSyntaxAssertedId
-                    (runtimeInterface runtime)
+                    (preparedInterface prepared)
         in
             if identity `Set.member` seen
                 then
                     (seen, reversed)
                 else
                     ( Set.insert identity seen
-                    , runtime : reversed
+                    , prepared : reversed
                     )
 
 foldImportedSyntax
-    :: Map ResolvedSourceAddress RuntimeSyntaxModule
+    :: Map ResolvedSourceAddress PreparedSyntaxModule
     -> [ResolvedSourceAddress]
     -> Either ParseWorkspaceError SyntaxEntryInventory
-foldImportedSyntax runtimeByAddress addresses =
+foldImportedSyntax preparedByAddress addresses =
     snd <$> foldM visit (Set.empty, Map.empty) addresses
   where
     visit state address = do
-        runtime <- lookupRuntimeModule runtimeByAddress address
+        prepared <- lookupPreparedSyntaxModule preparedByAddress address
         let identity =
                 moduleSyntaxAssertedId
-                    (runtimeInterface runtime)
+                    (preparedInterface prepared)
         if identity `Set.member` fst state
             then
                 Right state
@@ -1418,13 +1434,13 @@ foldImportedSyntax runtimeByAddress addresses =
                 afterImports <- foldM
                     visit
                     marked
-                    (runtimeSyntaxDirectAddresses runtime)
+                    (preparedSyntaxDirectAddresses prepared)
                 Right
                     ( fst afterImports
                     , Map.unionWith
                         Set.union
                         (snd afterImports)
-                        (runtimeLocalEntries runtime)
+                        (preparedLocalEntries prepared)
                     )
 
 prepareLocalSyntax
@@ -2103,15 +2119,16 @@ rawBlockMarker = \case
 
 parseScannedModule
     :: (ResolvedSource -> Raw.Block -> IO ())
-    -> RuntimeSyntaxModule
+    -> FreshRuntimeSyntax
     -> ScannedModule
     -> ExceptT ParseWorkspaceError IO ParsedModule
 parseScannedModule
         emitBlock
         runtime
         (ScannedModule node imports chunks) = do
+    let preparedRuntime = freshRuntimePrepared runtime
     unless
-        (runtimeAddress runtime
+        (preparedAddress preparedRuntime
             == resolvedSourceAddress source)
         (throwE
             (SourceWorkspaceError
@@ -2119,7 +2136,7 @@ parseScannedModule
                     "runtime syntax was paired with the wrong source module")))
     unless
         (length chunks
-            == length (runtimePreparedOccurrences runtime))
+            == length (freshRuntimeOccurrences runtime))
         (throwE
             (SourceWorkspaceError
                 (SourceGraphInvariantViolation
@@ -2141,7 +2158,7 @@ parseScannedModule
                 (loadedBytes loaded)
                 (loadedText loaded)
                 (parsedImportReference <$> imports)
-                (runtimeInterface runtime))
+                (preparedInterface preparedRuntime))
     (reversedBlocks, reversedOccurrences) <-
         foldM
             parsePreparedChunk
@@ -2149,7 +2166,7 @@ parseScannedModule
             (zip3
                 [0 ..]
                 chunks
-                (runtimePreparedOccurrences runtime))
+                (freshRuntimeOccurrences runtime))
     let blocks = reverse reversedBlocks
         occurrences = reverse reversedOccurrences
     fresh <-
@@ -2171,7 +2188,7 @@ parseScannedModule
     moduleParser
         :: Parser Text [Located Token] Raw.Block
     moduleParser =
-        parser (grammar (runtimeLexicon runtime))
+        parser (grammar (freshRuntimeLexicon runtime))
 
     parsePreparedChunk
             (currentBlocks, currentOccurrences)