diff options
Diffstat (limited to 'source/Render/Html.hs')
| -rw-r--r-- | source/Render/Html.hs | 169 |
1 files changed, 128 insertions, 41 deletions
diff --git a/source/Render/Html.hs b/source/Render/Html.hs index 20ac33b..c37a278 100644 --- a/source/Render/Html.hs +++ b/source/Render/Html.hs @@ -4,7 +4,11 @@ {-# LANGUAGE RecordWildCards #-} module Render.Html - ( renderDocument + ( HtmlRenderIndex + , HtmlPagePresentation + , buildRenderIndex + , htmlPagePresentationSource + , renderDocument , supportScriptAssetContents ) where @@ -61,6 +65,21 @@ type AnchorMap = Map Marker Text type BlockRenderInfo = (Int, Block, Text) type PreviewMap = Map Marker PreviewEntry +data HtmlRenderIndex = HtmlRenderIndex + !(Map Marker IndexedReferenceTarget) + +data HtmlPagePresentation = HtmlPagePresentation + { htmlPagePresentationSource :: !ResolvedSource + , pagePresentationBlockInfos :: ![BlockRenderInfo] + , pagePresentationAnchors :: !AnchorMap + , pagePresentationReferencedMarkers :: !(Set Marker) + } + +data IndexedReferenceTarget = IndexedReferenceTarget + !Int + !ResolvedSource + !ReferenceTarget + data ReferenceContext = ReferenceContext { referenceAnchors :: AnchorMap , referencePreviews :: PreviewMap @@ -112,36 +131,36 @@ referenceGroupThreshold = 5 renderDocument :: HtmlRenderContext -> Text - -> [Block] - -> [(ResolvedSource, [Block])] + -> HtmlRenderIndex + -> HtmlPagePresentation -> Either HtmlRenderContextError Text -renderDocument context hintsSource blocks sourceBlocks = do - let indexedBlocks = zip [1 :: Int ..] blocks - blockInfos = - [ (index, block, blockAnchorId index block) - | (index, block) <- indexedBlocks - ] - rootTargets = - concatMap referenceTargetsOfBlockRenderInfo blockInfos - anchors = Map.fromList - [ (targetMarker, targetAnchorId) - | ReferenceTarget{targetMarker, targetAnchorId} <- - rootTargets - ] - referencedMarkers = collectReferencedMarkers blocks +renderDocument + context + hintsSource + renderIndex + HtmlPagePresentation + { pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = anchors + , pagePresentationReferencedMarkers = referencedMarkers + } = do previews <- buildPreviewMap context referencedMarkers anchors - sourceBlocks + renderIndex let result = case formatMissingHintWarning missingHints of Nothing -> rendered Just warningText -> trace (Text.unpack warningText) rendered hints = parseHints hintsSource - missingHints = collectMissingHints hints blocks + missingHints = + collectMissingHints + hints + [ block + | (_index, block, _blockId) <- blockInfos + ] rendered = LazyText.toStrict (renderText (renderPage hints)) pageLabel = htmlCurrentPageLabel context tocBlocks = [(index, blockId, block) | (index, block, blockId) <- blockInfos, includeInToc block] @@ -182,6 +201,73 @@ renderDocument context hintsSource blocks sourceBlocks = do ("" :: Text) Right result +-- | Index every block target and every page's referenced markers once in +-- deterministic source order. Rendering a page subsequently performs only +-- marker lookups in the shared index. +buildRenderIndex + :: NonEmpty (ResolvedSource, [Block]) + -> (HtmlRenderIndex, NonEmpty HtmlPagePresentation) +buildRenderIndex sourceBlocks = + ( HtmlRenderIndex + (Map.fromList + [ ( targetMarker target + , IndexedReferenceTarget ordinal source target + ) + | (ordinal, (source, target)) <- + zip [1 :: Int ..] orderedTargets + ]) + , pages + ) + where + analysedPages = + uncurry analysePage <$> sourceBlocks + pages = + fst <$> analysedPages + orderedTargets = + [ (htmlPagePresentationSource page, target) + | (page, targets) <- NonEmpty.toList analysedPages + , target <- targets + ] + + analysePage source blocks = + ( HtmlPagePresentation + { htmlPagePresentationSource = source + , pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = + Map.fromList + [ (targetMarker, targetAnchorId) + | ReferenceTarget + { targetMarker + , targetAnchorId + } <- targets + ] + , pagePresentationReferencedMarkers = + foldMap + (\(_blockInfo, _targets, references) -> references) + analysedBlocks + } + , targets + ) + where + analysedBlocks = + [ ( blockInfo + , referenceTargetsOfBlockRenderInfo blockInfo + , collectReferencedMarkersOfBlock block + ) + | (index, block) <- zip [1 :: Int ..] blocks + , let blockInfo = + (index, block, blockAnchorId index block) + ] + blockInfos = + [ blockInfo + | (blockInfo, _targets, _references) <- analysedBlocks + ] + targets = + concat + [ blockTargets + | (_blockInfo, blockTargets, _references) <- analysedBlocks + ] + pageStyles :: Text pageStyles = Text.unlines @@ -955,10 +1041,10 @@ referencePreviewScript = Text.unlines , "})();" ] -collectReferencedMarkers :: [Block] -> Set Marker -collectReferencedMarkers = - foldMap collectBlock - where +collectReferencedMarkersOfBlock :: Block -> Set Marker +collectReferencedMarkersOfBlock = + collectBlock + where collectBlock :: Block -> Set Marker collectBlock = \case BlockProof _start proof _end -> @@ -2376,29 +2462,30 @@ buildPreviewMap :: HtmlRenderContext -> Set Marker -> AnchorMap - -> [(ResolvedSource, [Block])] + -> HtmlRenderIndex -> Either HtmlRenderContextError PreviewMap -buildPreviewMap context referencedMarkers anchors sourceBlocks = +buildPreviewMap + context + referencedMarkers + anchors + (HtmlRenderIndex targetIndex) = Map.fromList <$> traverse makePreviewEntry indexedTargets where targets = - [ (source, target) - | (source, blocks) <- sourceBlocks - , let indexedBlocks = zip [1 :: Int ..] blocks - , let blockInfos = - [ (index, block, blockAnchorId index block) - | (index, block) <- indexedBlocks - ] - , target <- - concatMap - referenceTargetsOfBlockRenderInfo - blockInfos - , targetMarker target `Set.member` referencedMarkers - , targetMarker target `Map.notMember` anchors - , source /= htmlCurrentSource context - ] + List.sortOn targetOrdinal + [ indexed + | marker <- Set.toList referencedMarkers + , marker `Map.notMember` anchors + , Just indexed@(IndexedReferenceTarget _ source _target) <- + [Map.lookup marker targetIndex] + , source /= htmlCurrentSource context + ] + targetOrdinal (IndexedReferenceTarget ordinal _source _target) = + ordinal + sourceTarget (IndexedReferenceTarget _ordinal source target) = + (source, target) indexedTargets = - zip [1 :: Int ..] targets + zip [1 :: Int ..] (sourceTarget <$> targets) makePreviewEntry (index, (source, target)) = do previewSourceLabel <- |