diff options
Diffstat (limited to 'source/Render/Html/Export.hs')
| -rw-r--r-- | source/Render/Html/Export.hs | 277 |
1 files changed, 0 insertions, 277 deletions
diff --git a/source/Render/Html/Export.hs b/source/Render/Html/Export.hs deleted file mode 100644 index 2c747d8..0000000 --- a/source/Render/Html/Export.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Prepare a complete HTML export from retained parsed presentation. -module Render.Html.Export - ( HtmlPresentation - , htmlPresentationFromParsedWorkspace - , HtmlExportError(..) - , renderHtmlExportError - , prepareHtmlExport - , prepareHtmlExportWithLayout - , prepareHtmlExportWithLayoutFromRendererRoots - ) where - -import Base -import Felix.Parse -import Felix.Source -import Render.Html qualified as Html -import Render.Html.Context -import Render.Html.Layout -import Render.Html.Output -import Syntax.Abstract (Block) - -import Control.Exception (Exception, IOException, displayException) -import Control.Exception qualified as Exception -import Data.Bifunctor (first) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Text qualified as Text -import Data.Text.Encoding qualified as TextEncoding -import Data.Text.Encoding.Error (UnicodeException) -import Data.Text.IO qualified as TextIO -import System.Directory (doesFileExist) -import System.FilePath.Posix ((</>)) - - --- | 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) - -data HtmlSourcePresentation = HtmlSourcePresentation - !ResolvedSource - ![Block] - -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 - | HtmlExportLayoutError !HtmlLayoutError - | HtmlExportContextError !HtmlRenderContextError - deriving stock (Show) - -instance Exception HtmlExportError - -renderHtmlExportError :: HtmlExportError -> Text -renderHtmlExportError = \case - HtmlRendererDataNotFound requested searched -> - "renderer data " <> quotePath requested <> " was not found; searched " - <> Text.intercalate ", " (quotePath <$> searched) - HtmlRendererDataLookupFailed path reason -> - "could not locate renderer data " <> quotePath path <> ": " <> reason - HtmlRendererDataReadFailed path reason -> - "could not read renderer data " <> quotePath path <> ": " <> reason - HtmlExportLayoutError failure -> - renderHtmlLayoutError failure - HtmlExportContextError failure -> - case failure of - HtmlCurrentSourceNotRouted source -> - "current source has no HTML route: " <> sourceLabel source - HtmlReferencedSourceNotRouted source -> - "referenced source has no HTML route: " <> sourceLabel source - where - sourceLabel source = - sourceMountIdText (resolvedSourceMount source) - <> ":" - <> Text.pack - (safeRelativePathFilePath - (resolvedSourceRelativePath source)) - - quotePath = Text.pack . show - -prepareHtmlExport - :: [(SourceMountId, [Text])] - -> HtmlPresentation - -> Text - -> 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 - -prepareHtmlExportWithLayout - :: HtmlLayout - -> HtmlPresentation - -> Text - -> Either HtmlExportError [PreparedHtmlArtifact] -prepareHtmlExportWithLayout - layout - (HtmlPresentation presentation) - hints = - prepareRenderedExport hints layout presentation - -prepareHtmlExportWithLayoutFromRendererRoots - :: [FilePath] - -> HtmlLayout - -> HtmlPresentation - -> IO (Either HtmlExportError [PreparedHtmlArtifact]) -prepareHtmlExportWithLayoutFromRendererRoots roots layout presentation = do - hintsResult <- findAndReadRendererFile roots "lexicon.tsv" - pure do - hints <- hintsResult - prepareHtmlExportWithLayout layout presentation hints - --- Renderer data follows the established current-directory, --- configured-library, and debug-directory lookup policy. -findAndReadRendererFile - :: [FilePath] - -> FilePath - -> IO (Either HtmlExportError Text) -findAndReadRendererFile roots path = - selectRendererData path ((</> path) <$> roots) >>= \case - Left failure -> pure (Left failure) - Right selectedPath -> do - readResult <- tryRendererRead (TextIO.readFile selectedPath) - pure case readResult of - Left reason -> - Left (HtmlRendererDataReadFailed selectedPath reason) - Right contents -> Right contents - -selectRendererData - :: FilePath - -> [FilePath] - -> IO (Either HtmlExportError FilePath) -selectRendererData requested candidates = go candidates - where - go = \case - [] -> pure (Left (HtmlRendererDataNotFound requested candidates)) - candidate : remaining -> - tryRendererIO (doesFileExist candidate) >>= \case - Left failure -> - pure - (Left - (HtmlRendererDataLookupFailed - candidate - (Text.pack (displayException failure)))) - Right True -> pure (Right candidate) - Right False -> go remaining - -tryRendererIO :: IO value -> IO (Either IOException value) -tryRendererIO = Exception.try - -tryRendererRead :: IO value -> IO (Either Text value) -tryRendererRead action = - Exception.catch - (Exception.catch (Right <$> action) renderIOException) - renderUnicodeException - where - renderIOException :: IOException -> IO (Either Text value) - renderIOException = pure . Left . Text.pack . displayException - - renderUnicodeException - :: UnicodeException - -> IO (Either Text value) - renderUnicodeException = pure . Left . Text.pack . displayException - -prepareRenderedExport - :: Text - -> HtmlLayout - -> 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 - (prepareSourceArtifact - renderEnvironment - layout - hints - renderIndex) - pages - let supportRoute = - htmlSupportScriptRoute layout - supportArtifact = - 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]) - -prepareSourceArtifact - :: HtmlRenderEnvironment - -> HtmlLayout - -> Text - -> Html.HtmlRenderIndex - -> Html.HtmlPagePresentation - -> Either - HtmlExportError - PreparedHtmlArtifact -prepareSourceArtifact renderEnvironment layout hints renderIndex page = do - let source = Html.htmlPagePresentationSource page - context <- - first - HtmlExportContextError - (htmlRenderContextFromEnvironment - renderEnvironment - source) - route <- - maybe - (Left - (HtmlExportContextError - (HtmlCurrentSourceNotRouted source))) - Right - (htmlPageRoute layout source) - Right - (preparedHtmlArtifact - (routeDestination route) - (first renderHtmlExportError - (TextEncoding.encodeUtf8 - <$> first - HtmlExportContextError - (Html.renderDocument - context - hints - renderIndex - page)))) |