diff options
Diffstat (limited to 'source/Render/Html/Export.hs')
| -rw-r--r-- | source/Render/Html/Export.hs | 213 |
1 files changed, 108 insertions, 105 deletions
diff --git a/source/Render/Html/Export.hs b/source/Render/Html/Export.hs index 3faf506..8b62f7d 100644 --- a/source/Render/Html/Export.hs +++ b/source/Render/Html/Export.hs @@ -1,11 +1,11 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Prepare a complete HTML export from one fresh resolved source graph. +-- | Prepare a complete HTML export from retained parsed presentation. module Render.Html.Export - ( PreparedHtmlExport - , preparedHtmlRootDocument - , preparedHtmlOutputBundle + ( HtmlPresentation + , htmlPresentationFromParsedWorkspace , HtmlExportError(..) , renderHtmlExportError , prepareHtmlExport @@ -14,12 +14,11 @@ module Render.Html.Export import Base import Felix.Parse import Felix.Source -import Felix.Source.Graph import Render.Html qualified as Html import Render.Html.Context import Render.Html.Layout import Render.Html.Output -import Syntax.Abstract qualified as Raw +import Syntax.Abstract (Block) import Control.Exception (Exception) import Data.Bifunctor (first) @@ -28,31 +27,51 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding -data PreparedHtmlExport = PreparedHtmlExport - !Text - !PreparedHtmlBundle +-- | The strict, invocation-local subset of parsed presentation needed by the +-- renderer. Construction forces the complete module sequence and every page +-- shell, severing references to parser payloads, syntax interfaces, and +-- canonical cache payloads. +data HtmlPresentation = HtmlPresentation + !(NonEmpty HtmlSourcePresentation) -preparedHtmlRootDocument :: PreparedHtmlExport -> Text -preparedHtmlRootDocument - (PreparedHtmlExport rootDocument _bundle) = - rootDocument +data HtmlSourcePresentation = HtmlSourcePresentation + !ResolvedSource + ![Block] -preparedHtmlOutputBundle - :: PreparedHtmlExport - -> PreparedHtmlBundle -preparedHtmlOutputBundle - (PreparedHtmlExport _rootDocument bundle) = - bundle +htmlPresentationFromParsedWorkspace + :: ParsedSourceWorkspace + -> HtmlPresentation +htmlPresentationFromParsedWorkspace workspace = + HtmlPresentation + (strictMapNonEmpty project parsedModules) + where + parsedModules = + parsedWorkspaceImportedBeforeImporter workspace + project parsedModule = + HtmlSourcePresentation + (parsedModuleResolved parsedModule) + (parsedModuleBlocks parsedModule) + +strictMapNonEmpty :: (a -> b) -> NonEmpty a -> NonEmpty b +strictMapNonEmpty f (value :| values) = + let !firstPage = f value + !rest = strictMapList f values + in firstPage :| rest + +strictMapList :: (a -> b) -> [a] -> [b] +strictMapList _ [] = + [] +strictMapList f (value : values) = + let !next = f value + !rest = strictMapList f values + in next : rest data HtmlExportError = HtmlRendererDataNotFound !FilePath ![FilePath] | HtmlRendererDataLookupFailed !FilePath !Text | HtmlRendererDataReadFailed !FilePath !Text - | HtmlExportSourceError !SourceError - | HtmlExportParseError !ParseWorkspaceError | HtmlExportLayoutError !HtmlLayoutError | HtmlExportContextError !HtmlRenderContextError - | HtmlExportOutputError !HtmlOutputError deriving stock (Show) instance Exception HtmlExportError @@ -66,10 +85,6 @@ renderHtmlExportError = \case "could not locate renderer data " <> quotePath path <> ": " <> reason HtmlRendererDataReadFailed path reason -> "could not read renderer data " <> quotePath path <> ": " <> reason - HtmlExportSourceError failure -> - renderSourceError failure - HtmlExportParseError failure -> - renderParseWorkspaceError failure HtmlExportLayoutError failure -> renderHtmlLayoutError failure HtmlExportContextError failure -> @@ -78,8 +93,6 @@ renderHtmlExportError = \case "current source has no HTML route: " <> sourceLabel source HtmlReferencedSourceNotRouted source -> "referenced source has no HTML route: " <> sourceLabel source - HtmlExportOutputError failure -> - renderHtmlOutputError failure where sourceLabel source = sourceMountIdText (resolvedSourceMount source) @@ -92,89 +105,76 @@ renderHtmlExportError = \case prepareHtmlExport :: [(SourceMountId, [Text])] - -> SourceMounts - -> RootRequest + -> HtmlPresentation -> Text - -> IO (Either HtmlExportError PreparedHtmlExport) -prepareHtmlExport mountPrefixes mounts request hints = do - graphResult <- - buildResolvedSourceGraph mounts request - case graphResult of - Left err -> - pure (Left (HtmlExportSourceError err)) - Right graph -> - case - first - HtmlExportLayoutError - (layoutHtmlSourceGraph mountPrefixes graph) of - Left err -> - pure (Left err) - Right layout -> do - workspaceResult <- - parseResolvedSourceGraph graph - pure do - workspace <- - first - HtmlExportParseError - workspaceResult - prepareRenderedExport - hints - layout - workspace + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareHtmlExport + mountPrefixes + (HtmlPresentation presentation) + hints = do + let sources = + sourceOf <$> NonEmpty.toList presentation + layout <- + first + HtmlExportLayoutError + (layoutHtmlSources mountPrefixes sources) + prepareRenderedExport hints layout presentation + where + sourceOf (HtmlSourcePresentation source _blocks) = + source prepareRenderedExport :: Text -> HtmlLayout - -> ParsedSourceWorkspace - -> Either HtmlExportError PreparedHtmlExport -prepareRenderedExport hints layout workspace = do - let orderedNodes = - parsedWorkspaceImportedBeforeImporter workspace - sourceBlocks = - [ (parsedModuleResolved node, parsedModuleBlocks node) - | node <- NonEmpty.toList orderedNodes - ] - renderedPages <- + -> NonEmpty HtmlSourcePresentation + -> Either HtmlExportError [PreparedHtmlArtifact] +prepareRenderedExport hints layout presentation = do + let sourceBlocks = + (\(HtmlSourcePresentation source blocks) -> + (source, blocks)) + <$> presentation + (unforcedRenderIndex, pages) = + Html.buildRenderIndex sourceBlocks + !renderIndex = unforcedRenderIndex + renderEnvironment = + htmlRenderEnvironment layout + pageArtifacts <- traverse - (renderSourcePage hints layout sourceBlocks) - orderedNodes - let (_rootSource, _rootRoute, rootDocument) = - NonEmpty.last renderedPages - pageArtifacts = - [ ( routeDestination route - , TextEncoding.encodeUtf8 document - ) - | (_source, route, document) <- - NonEmpty.toList renderedPages - ] - supportRoute = + (prepareSourceArtifact + renderEnvironment + layout + hints + renderIndex) + pages + let supportRoute = htmlSupportScriptRoute layout supportArtifact = - ( routeDestination supportRoute - , TextEncoding.encodeUtf8 - Html.supportScriptAssetContents - ) - bundle <- - first - HtmlExportOutputError - (preparedHtmlBundle - (pageArtifacts <> [supportArtifact])) - Right (PreparedHtmlExport rootDocument bundle) + preparedHtmlArtifact + (routeDestination supportRoute) + (Right + (TextEncoding.encodeUtf8 + Html.supportScriptAssetContents)) + -- Page artifacts retain imported-before-importer source order. The + -- singleton support asset is published deterministically afterward. + Right (NonEmpty.toList pageArtifacts <> [supportArtifact]) -renderSourcePage - :: Text +prepareSourceArtifact + :: HtmlRenderEnvironment -> HtmlLayout - -> [(ResolvedSource, [Raw.Block])] - -> ParsedModule + -> Text + -> Html.HtmlRenderIndex + -> Html.HtmlPagePresentation -> Either HtmlExportError - (ResolvedSource, HtmlRoute, Text) -renderSourcePage hints layout sourceBlocks node = do - let source = parsedModuleResolved node + PreparedHtmlArtifact +prepareSourceArtifact renderEnvironment layout hints renderIndex page = do + let source = Html.htmlPagePresentationSource page context <- first HtmlExportContextError - (htmlRenderContext layout source) + (htmlRenderContextFromEnvironment + renderEnvironment + source) route <- maybe (Left @@ -182,12 +182,15 @@ renderSourcePage hints layout sourceBlocks node = do (HtmlCurrentSourceNotRouted source))) Right (htmlPageRoute layout source) - document <- - first - HtmlExportContextError - (Html.renderDocument - context - hints - (parsedModuleBlocks node) - sourceBlocks) - Right (source, route, document) + Right + (preparedHtmlArtifact + (routeDestination route) + (first renderHtmlExportError + (TextEncoding.encodeUtf8 + <$> first + HtmlExportContextError + (Html.renderDocument + context + hints + renderIndex + page)))) |