Migrate to `Felix` namespaceHEADhotg

1 files changed, 277 insertions, 0 deletions

diff --git a/source/Felix/Render/Html/Export.hs b/source/Felix/Render/Html/Export.hs
new file mode 100644
index 0000000..a3f0e39
--- /dev/null
+++ b/source/Felix/Render/Html/Export.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Prepare a complete HTML export from retained parsed presentation.
+module Felix.Render.Html.Export
+    ( HtmlPresentation
+    , htmlPresentationFromParsedWorkspace
+    , HtmlExportError(..)
+    , renderHtmlExportError
+    , prepareHtmlExport
+    , prepareHtmlExportWithLayout
+    , prepareHtmlExportWithLayoutFromRendererRoots
+    ) where
+
+import Base
+import Felix.Parse
+import Felix.Source
+import Felix.Render.Html qualified as Html
+import Felix.Render.Html.Context
+import Felix.Render.Html.Layout
+import Felix.Render.Html.Output
+import Felix.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))))