{-# LANGUAGE OverloadedStrings   #-}
{- |
   Module      : Text.Pandoc.Writers.ChunkedHTML
   Copyright   : Copyright (C) 2023 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to "chunked" HTML (a folder of
linked HTML documents, split by sections.
-}
module Text.Pandoc.Writers.ChunkedHTML (
  writeChunkedHTML
  ) where
import Text.Pandoc.Definition
import Text.Pandoc.Options (WriterOptions(..))
import Text.Pandoc.Shared (stringify, tshow)
import Text.Pandoc.Class (PandocMonad, getPOSIXTime, runPure,
                          fetchItem, insertMedia, getMediaBag)
import Text.Pandoc.MediaBag (mediaItems)
import qualified Data.ByteString.Lazy as BL
import Text.Pandoc.Chunks (splitIntoChunks, Chunk(..), ChunkedDoc(..),
                           SecInfo(..), tocToList)
import Text.Pandoc.URI (isURI)
import Data.Text (Text)
import Data.Tree
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Text.Pandoc.Writers.HTML (writeHtml5String)
import Codec.Archive.Zip (Entry, addEntryToArchive, emptyArchive, toEntry,
                          fromArchive)
import qualified Data.Map as M
import Text.DocTemplates (Context(..), Val(..))
import Text.DocLayout (literal)
import Text.Pandoc.Writers.Shared (defField)
import Data.Aeson (toJSON, encode)
import System.FilePath (isRelative, normalise)
import Data.List (isInfixOf)
import Text.Pandoc.Walk (walkM)
import Text.Pandoc.Builder (setMeta)
import Text.Pandoc.Templates (compileTemplate, WithDefaultPartials(..))
import Control.Monad.Except (throwError)
import Text.Pandoc.Error

-- | Splits document into HTML chunks, dividing them by section,
-- and returns a zip archive of a folder of files.
writeChunkedHTML :: PandocMonad m
                 => WriterOptions -> Pandoc -> m BL.ByteString
writeChunkedHTML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m ByteString
writeChunkedHTML WriterOptions
opts (Pandoc Meta
meta [Block]
blocks) = do
  forall a b (m :: * -> *).
(Walkable a b, Monad m, Applicative m, Functor m) =>
(a -> m a) -> b -> m b
walkM forall (m :: * -> *). PandocMonad m => Inline -> m Inline
addMedia (Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
blocks)
  Integer
epochtime <- forall a b. (RealFrac a, Integral b) => a -> b
floor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => m POSIXTime
getPOSIXTime
  let toMediaEntry :: (FilePath, b, ByteString) -> Entry
toMediaEntry (FilePath
fp, b
_mt, ByteString
bs) = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
fp Integer
epochtime ByteString
bs
  [Entry]
mediaEntries <- forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (FilePath, b, ByteString) -> Entry
toMediaEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaBag -> [(FilePath, Text, ByteString)]
mediaItems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
  let chunkedDoc :: ChunkedDoc
chunkedDoc = PathTemplate -> Bool -> Maybe Int -> Int -> Pandoc -> ChunkedDoc
splitIntoChunks (WriterOptions -> PathTemplate
writerChunkTemplate WriterOptions
opts)
                     Bool
True
                     (forall a. a -> Maybe a
Just Int
1)
                     (WriterOptions -> Int
writerSplitLevel WriterOptions
opts)
                     (Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
blocks)
  let topChunk :: Chunk
topChunk =
        Chunk
          { chunkHeading :: [Inline]
chunkHeading = Meta -> [Inline]
docTitle Meta
meta
          , chunkId :: Text
chunkId = Text
"top"
          , chunkLevel :: Int
chunkLevel = Int
0
          , chunkNumber :: Int
chunkNumber = Int
0
          , chunkSectionNumber :: Maybe Text
chunkSectionNumber = forall a. Maybe a
Nothing
          , chunkPath :: FilePath
chunkPath = FilePath
"index.html"
          , chunkUp :: Maybe Chunk
chunkUp = forall a. Maybe a
Nothing
          , chunkPrev :: Maybe Chunk
chunkPrev = forall a. Maybe a
Nothing
          , chunkNext :: Maybe Chunk
chunkNext = case ChunkedDoc -> [Chunk]
chunkedChunks ChunkedDoc
chunkedDoc of
                          [] -> forall a. Maybe a
Nothing
                          (Chunk
x:[Chunk]
_) -> forall a. a -> Maybe a
Just Chunk
x
          , chunkUnlisted :: Bool
chunkUnlisted = Bool
True
          , chunkContents :: [Block]
chunkContents = forall a. Monoid a => a
mempty
          }

  let chunks :: [Chunk]
chunks = forall a b. (a -> b) -> [a] -> [b]
map (\Chunk
x -> case Chunk -> Maybe Chunk
chunkUp Chunk
x of
                             Maybe Chunk
Nothing -> Chunk
x{ chunkUp :: Maybe Chunk
chunkUp = forall a. a -> Maybe a
Just Chunk
topChunk }
                             Maybe Chunk
_ -> Chunk
x)
               forall a b. (a -> b) -> a -> b
$ case ChunkedDoc -> [Chunk]
chunkedChunks ChunkedDoc
chunkedDoc of
                   [] -> []
                   (Chunk
x:[Chunk]
xs) -> Chunk
x{ chunkPrev :: Maybe Chunk
chunkPrev = forall a. a -> Maybe a
Just Chunk
topChunk } forall a. a -> [a] -> [a]
: [Chunk]
xs

  let Node SecInfo
secinfo [Tree SecInfo]
secs = ChunkedDoc -> Tree SecInfo
chunkedTOC ChunkedDoc
chunkedDoc
  let tocTree :: Tree SecInfo
tocTree = forall a. a -> [Tree a] -> Tree a
Node SecInfo
secinfo{ secTitle :: [Inline]
secTitle = Meta -> [Inline]
docTitle Meta
meta,
                              secPath :: Text
secPath = Text
"index.html" } [Tree SecInfo]
secs
  let tree :: Block
tree = WriterOptions -> Tree SecInfo -> Block
buildTOC WriterOptions
opts Tree SecInfo
tocTree
  Text
renderedTOC <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
opts{ writerTemplate :: Maybe (Template Text)
writerTemplate = forall a. Maybe a
Nothing }
                    (Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [Block
tree])
  -- see #8915 -- we need to set the math variable in the top chunk:
  Either FilePath (Template Text)
res <- forall (m :: * -> *) a. WithDefaultPartials m a -> m a
runWithDefaultPartials forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
FilePath -> Text -> m (Either FilePath (Template a))
compileTemplate FilePath
"mathvar" Text
"$math$"
  Template Text
mathVar <- case Either FilePath (Template Text)
res of
    Left FilePath
e   -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocTemplateError (FilePath -> Text
T.pack FilePath
e)
    Right Template Text
t  -> forall (m :: * -> *) a. Monad m => a -> m a
return Template Text
t
  Text
tocMathVariable <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
opts{ writerTemplate :: Maybe (Template Text)
writerTemplate = forall a. a -> Maybe a
Just Template Text
mathVar }
                    (Meta -> [Block] -> Pandoc
Pandoc Meta
meta (Block
treeforall a. a -> [a] -> [a]
:[Block]
blocks))
  let opts' :: WriterOptions
opts' = WriterOptions
opts{ writerVariables :: Context Text
writerVariables =
                        forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"table-of-contents" Text
renderedTOC
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"math" Text
tocMathVariable
                      forall a b. (a -> b) -> a -> b
$ WriterOptions -> Context Text
writerVariables WriterOptions
opts }
  [Entry]
entries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Meta -> Chunk -> Chunk -> m Entry
chunkToEntry WriterOptions
opts' Meta
meta Chunk
topChunk) (Chunk
topChunk forall a. a -> [a] -> [a]
: [Chunk]
chunks)
  let sitemap :: Entry
sitemap = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"sitemap.json" Integer
epochtime
                  (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Tree SecInfo -> Context Text
tocTreeToContext Tree SecInfo
tocTree)
  let archive :: Archive
archive = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive
                 (Entry
sitemap forall a. a -> [a] -> [a]
: [Entry]
entries forall a. [a] -> [a] -> [a]
++ [Entry]
mediaEntries)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
archive


-- We include in the zip only local media that is in the working directory
-- or below.
addMedia :: PandocMonad m => Inline -> m Inline
addMedia :: forall (m :: * -> *). PandocMonad m => Inline -> m Inline
addMedia il :: Inline
il@(Image Attr
_ [Inline]
_ (Text
src,Text
_))
  | Bool -> Bool
not (Text -> Bool
isURI Text
src)
  , FilePath
fp <- FilePath -> FilePath
normalise (Text -> FilePath
T.unpack Text
src)
  , FilePath -> Bool
isRelative FilePath
fp
  , Bool -> Bool
not (FilePath
".." forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
fp) = do
  (ByteString
bs, Maybe Text
mbMime) <- forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
fetchItem (FilePath -> Text
T.pack FilePath
fp)
  forall (m :: * -> *).
PandocMonad m =>
FilePath -> Maybe Text -> ByteString -> m ()
insertMedia FilePath
fp Maybe Text
mbMime (ByteString -> ByteString
BL.fromStrict ByteString
bs)
  forall (m :: * -> *) a. Monad m => a -> m a
return Inline
il
addMedia Inline
il = forall (m :: * -> *) a. Monad m => a -> m a
return Inline
il

buildTOC :: WriterOptions -> Tree SecInfo -> Block
buildTOC :: WriterOptions -> Tree SecInfo -> Block
buildTOC WriterOptions
opts = Bool -> Int -> Tree SecInfo -> Block
tocToList (WriterOptions -> Bool
writerNumberSections WriterOptions
opts) (WriterOptions -> Int
writerTOCDepth WriterOptions
opts)

chunkToEntry :: PandocMonad m
             => WriterOptions -> Meta -> Chunk -> Chunk -> m Entry
chunkToEntry :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Meta -> Chunk -> Chunk -> m Entry
chunkToEntry WriterOptions
opts Meta
meta Chunk
topChunk Chunk
chunk = do
  Text
html <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
opts' (Meta -> [Block] -> Pandoc
Pandoc Meta
meta' [Block]
blocks)
  Integer
epochtime <- forall a b. (RealFrac a, Integral b) => a -> b
floor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => m POSIXTime
getPOSIXTime
  let htmlLBS :: ByteString
htmlLBS = ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
html
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Integer -> ByteString -> Entry
toEntry (Chunk -> FilePath
chunkPath Chunk
chunk) Integer
epochtime ByteString
htmlLBS
 where
  opts' :: WriterOptions
opts' = WriterOptions
opts{ writerVariables :: Context Text
writerVariables =
                  WriterOptions -> Chunk -> Chunk -> Context Text -> Context Text
addContextVars WriterOptions
opts' Chunk
topChunk Chunk
chunk forall a b. (a -> b) -> a -> b
$ WriterOptions -> Context Text
writerVariables WriterOptions
opts }
  meta' :: Meta
meta' = forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta Text
"pagetitle" (Text -> MetaValue
MetaString (forall a. Walkable Inline a => a -> Text
stringify forall a b. (a -> b) -> a -> b
$ Chunk -> [Inline]
chunkHeading Chunk
chunk)) Meta
meta
  blocks :: [Block]
blocks = Chunk -> [Block]
chunkContents Chunk
chunk

tocTreeToContext :: Tree SecInfo -> Context Text
tocTreeToContext :: Tree SecInfo -> Context Text
tocTreeToContext (Node SecInfo
secinfo [Tree SecInfo]
subs) =
  forall a. Map Text (Val a) -> Context a
Context forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"section", forall a. Context a -> Val a
MapVal forall a b. (a -> b) -> a -> b
$ SecInfo -> Context Text
secInfoToContext SecInfo
secinfo)
  , (Text
"subsections", forall a. [Val a] -> Val a
ListVal forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Context a -> Val a
MapVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree SecInfo -> Context Text
tocTreeToContext) [Tree SecInfo]
subs)
  ]

secInfoToContext :: SecInfo -> Context Text
secInfoToContext :: SecInfo -> Context Text
secInfoToContext SecInfo
sec =
  forall a. Map Text (Val a) -> Context a
Context forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"title", forall a. Doc a -> Val a
SimpleVal forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify forall a b. (a -> b) -> a -> b
$ SecInfo -> [Inline]
secTitle SecInfo
sec)
  , (Text
"number", forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Val a
NullVal (forall a. Doc a -> Val a
SimpleVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal) (SecInfo -> Maybe Text
secNumber SecInfo
sec))
  , (Text
"id", forall a. Doc a -> Val a
SimpleVal forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ SecInfo -> Text
secId SecInfo
sec)
  , (Text
"path", forall a. Doc a -> Val a
SimpleVal forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ SecInfo -> Text
secPath SecInfo
sec)
  , (Text
"level", forall a. Doc a -> Val a
SimpleVal forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ SecInfo -> Int
secLevel SecInfo
sec)
  ]

addContextVars
  :: WriterOptions -> Chunk -> Chunk -> Context Text -> Context Text
addContextVars :: WriterOptions -> Chunk -> Chunk -> Context Text -> Context Text
addContextVars WriterOptions
opts Chunk
topChunk Chunk
chunk Context Text
context =
     forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"next" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> Val Text
navlinks) (Chunk -> Maybe Chunk
chunkNext Chunk
chunk)
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"previous" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> Val Text
navlinks) (Chunk -> Maybe Chunk
chunkPrev Chunk
chunk)
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"up" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> Val Text
navlinks) (Chunk -> Maybe Chunk
chunkUp Chunk
chunk)
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"top" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> Val Text
navlinks) (if Chunk
chunk forall a. Eq a => a -> a -> Bool
== Chunk
topChunk
                                              then forall a. Maybe a
Nothing
                                              else forall a. a -> Maybe a
Just Chunk
topChunk)
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"toc" (Chunk
chunk forall a. Eq a => a -> a -> Bool
== Chunk
topChunk Bool -> Bool -> Bool
&& WriterOptions -> Bool
writerTableOfContents WriterOptions
opts)
    forall a b. (a -> b) -> a -> b
$ Context Text
context
 where
  navlinks :: Chunk -> Val Text
navlinks Chunk
ch = forall {a}. [(Text, Val a)] -> Val a
toMapVal [(Text
"url", Chunk -> Val Text
formatPath Chunk
ch), (Text
"title", Chunk -> Val Text
formatHeading Chunk
ch)]
  toMapVal :: [(Text, Val a)] -> Val a
toMapVal = forall a. Context a -> Val a
MapVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Map Text (Val a) -> Context a
Context forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  formatPath :: Chunk -> Val Text
formatPath = forall a. Doc a -> Val a
SimpleVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> FilePath
chunkPath
  formatHeading :: Chunk -> Val Text
formatHeading Chunk
ch = forall a. Doc a -> Val a
SimpleVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Text
"") forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PandocPure a -> Either PandocError a
runPure forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
opts{ writerTemplate :: Maybe (Template Text)
writerTemplate = forall a. Maybe a
Nothing }
      (Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [[Inline] -> Block
Plain forall a b. (a -> b) -> a -> b
$ Chunk -> [Inline]
chunkHeading Chunk
ch])