path: root/source/Felix/Render/Html/Export.hs

{-# 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))))