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

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

    Render blaze-html Html to DocLayout document (so it can be wrapped).
    -}
    module Text.Pandoc.Writers.Blaze ( layoutMarkup )
    where
    import Text.Blaze
    import qualified Data.ByteString as S
    import Data.List (isInfixOf)
    import Data.Text.Encoding (decodeUtf8)
    import qualified Data.Text as T
    import Data.Text (Text)
    import Text.DocLayout hiding (Text, Empty)
    import Text.Blaze.Internal (ChoiceString(..), getText, MarkupM(..))

    layoutMarkup :: Markup -> Doc T.Text
    layoutMarkup :: Markup -> Doc Text
    layoutMarkup = Bool -> Doc Text -> Markup -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    True Doc Text
    forall a. Monoid a => a
    mempty
      where
        go :: Bool -> Doc T.Text -> MarkupM b -> Doc T.Text
        go :: forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap Doc Text
    attrs (Parent StaticString
    _ StaticString
    open StaticString
    close MarkupM b
    content) =
          let open' :: Text
    open' = StaticString -> Text
    getText StaticString
    open
           in Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal Text
    open'
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '>'
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> (case Text
    open' of
                      Text
    "<code" -> Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    False Doc Text
    forall a. Monoid a => a
    mempty MarkupM b
    content
                      Text
    t | Text
    t Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "<pre" Bool -> Bool -> Bool
    ||
                          Text
    t Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "<style" Bool -> Bool -> Bool
    ||
                          Text
    t Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "<script" Bool -> Bool -> Bool
    ||
                          Text
    t Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "<textarea" -> Doc Text -> Doc Text
    forall a. Doc a -> Doc a
    flush (Doc Text -> Doc Text) -> Doc Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $ Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    False Doc Text
    forall a. Monoid a => a
    mempty MarkupM b
    content
                        | Bool
    otherwise -> Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap Doc Text
    forall a. Monoid a => a
    mempty MarkupM b
    content)
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal (StaticString -> Text
    getText StaticString
    close)
        go Bool
    wrap Doc Text
    attrs (CustomParent ChoiceString
    tag MarkupM b
    content) =
            Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '<'
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    tag
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '>'
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap Doc Text
    forall a. Monoid a => a
    mempty MarkupM b
    content
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal Text
    "</"
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    tag
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '>'
        go Bool
    _wrap Doc Text
    attrs (Leaf StaticString
    _ StaticString
    begin StaticString
    end b
    _) =
            Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal (StaticString -> Text
    getText StaticString
    begin)
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal (StaticString -> Text
    getText StaticString
    end)
        go Bool
    wrap Doc Text
    attrs (CustomLeaf ChoiceString
    tag Bool
    close b
    _) =
            Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '<'
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    tag
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> (if Bool
    close then Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal Text
    " />" else Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '>')
        go Bool
    wrap Doc Text
    attrs (AddAttribute StaticString
    rawkey StaticString
    _ ChoiceString
    value MarkupM b
    h) =
            Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap
              (Bool -> Doc Text
    forall {a}. HasChars a => Bool -> Doc a
    space' Bool
    wrap
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal (StaticString -> Text
    getText StaticString
    rawkey)
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '='
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text -> Doc Text
    forall a. HasChars a => Doc a -> Doc a
    doubleQuotes (Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    False ChoiceString
    value)
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs) MarkupM b
    h
        go Bool
    wrap Doc Text
    attrs (AddCustomAttribute ChoiceString
    key ChoiceString
    value MarkupM b
    h) =
            Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap
              (Bool -> Doc Text
    forall {a}. HasChars a => Bool -> Doc a
    space' Bool
    wrap
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    key
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Char -> Doc Text
    forall a. HasChars a => Char -> Doc a
    char Char
    '='
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text -> Doc Text
    forall a. HasChars a => Doc a -> Doc a
    doubleQuotes (Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    False ChoiceString
    value)
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    attrs) MarkupM b
    h
        go Bool
    wrap Doc Text
    _ (Content ChoiceString
    content b
    _) = Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    content
        go Bool
    wrap Doc Text
    _ (Comment ChoiceString
    comment b
    _) =
            Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal Text
    "<!--"
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> Doc Text
    forall {a}. HasChars a => Bool -> Doc a
    space' Bool
    wrap
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    False ChoiceString
    comment
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> Doc Text
    forall {a}. HasChars a => Bool -> Doc a
    space' Bool
    wrap
                Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Doc Text
    "-->"
        go Bool
    wrap Doc Text
    attrs (Append MarkupM b
    h1 MarkupM b
    h2) = Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap Doc Text
    attrs MarkupM b
    h1 Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> Doc Text -> MarkupM b -> Doc Text
    forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
    go Bool
    wrap Doc Text
    attrs MarkupM b
    h2
        go Bool
    _ Doc Text
    _ (Empty b
    _) = Doc Text
    forall a. Monoid a => a
    mempty
        space' :: Bool -> Doc a
    space' Bool
    wrap = if Bool
    wrap then Doc a
    forall a. Doc a
    space else Char -> Doc a
    forall a. HasChars a => Char -> Doc a
    char Char
    ' '

    fromChoiceString :: Bool                  -- ^ Allow wrapping
                     -> ChoiceString          -- ^ String to render
                     -> Doc Text              -- ^ Resulting builder
    fromChoiceString :: Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap (Static StaticString
    s)     = Bool -> Text -> Doc Text
    withWrap Bool
    wrap (Text -> Doc Text) -> Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $ StaticString -> Text
    getText StaticString
    s
    fromChoiceString Bool
    wrap (String [Char]
    s)     = Bool -> Text -> Doc Text
    withWrap Bool
    wrap (Text -> Doc Text) -> Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $
                                             Text -> Text
    escapeMarkupEntities (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Text
    T.pack [Char]
    s
    fromChoiceString Bool
    wrap (Text Text
    s)       = Bool -> Text -> Doc Text
    withWrap Bool
    wrap (Text -> Doc Text) -> Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $ Text -> Text
    escapeMarkupEntities Text
    s
    fromChoiceString Bool
    wrap (ByteString ByteString
    s) = Bool -> Text -> Doc Text
    withWrap Bool
    wrap (Text -> Doc Text) -> Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Text
    decodeUtf8 ByteString
    s
    fromChoiceString Bool
    _wrap (PreEscaped ChoiceString
    x) = -- don't wrap!
      case ChoiceString
    x of
        String [Char]
    s -> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal (Text -> Doc Text) -> Text -> Doc Text
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Text
    T.pack [Char]
    s
        Text   Text
    s -> Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal Text
    s
        ChoiceString
    s        -> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    False ChoiceString
    s
    fromChoiceString Bool
    wrap (External ChoiceString
    x) = case ChoiceString
    x of
        -- Check that the sequence "</" is *not* in the external data.
        String [Char]
    s     -> if [Char]
    "</" [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` [Char]
    s then Doc Text
    forall a. Monoid a => a
    mempty else Bool -> Text -> Doc Text
    withWrap Bool
    wrap ([Char] -> Text
    T.pack [Char]
    s)
        Text   Text
    s     -> if Text
    "</" Text -> Text -> Bool
    `T.isInfixOf` Text
    s then Doc Text
    forall a. Monoid a => a
    mempty else Bool -> Text -> Doc Text
    withWrap Bool
    wrap Text
    s
        ByteString ByteString
    s -> if ByteString
    "</" ByteString -> ByteString -> Bool
    `S.isInfixOf` ByteString
    s then Doc Text
    forall a. Monoid a => a
    mempty else Bool -> Text -> Doc Text
    withWrap Bool
    wrap (ByteString -> Text
    decodeUtf8 ByteString
    s)
        ChoiceString
    s            -> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    s
    fromChoiceString Bool
    wrap (AppendChoiceString ChoiceString
    x ChoiceString
    y) =
        Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    x Doc Text -> Doc Text -> Doc Text
    forall a. Semigroup a => a -> a -> a
    <> Bool -> ChoiceString -> Doc Text
    fromChoiceString Bool
    wrap ChoiceString
    y
    fromChoiceString Bool
    _ ChoiceString
    EmptyChoiceString = Doc Text
    forall a. Monoid a => a
    mempty

    withWrap :: Bool -> Text -> Doc Text
    withWrap :: Bool -> Text -> Doc Text
    withWrap Bool
    wrap
      | Bool
    wrap = [Doc Text] -> Doc Text
    forall a. Monoid a => [a] -> a
    mconcat ([Doc Text] -> Doc Text)
    -> (Text -> [Doc Text]) -> Text -> Doc Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> [Doc Text]
    toChunks
      | Bool
    otherwise = Text -> Doc Text
    forall a. HasChars a => a -> Doc a
    literal

    toChunks :: Text -> [Doc Text]
    toChunks :: Text -> [Doc Text]
    toChunks = (Text -> Doc Text) -> [Text] -> [Doc Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Text -> Doc Text
    forall {a}. (Eq a, HasChars a) => a -> Doc a
    toDoc ([Text] -> [Doc Text]) -> (Text -> [Text]) -> Text -> [Doc Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Char -> Bool) -> Text -> [Text]
    T.groupBy Char -> Char -> Bool
    sameStatus
      where
       toDoc :: a -> Doc a
    toDoc a
    t
         | a
    t a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    " " = Doc a
    forall a. Doc a
    space
         | a
    t a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    "\n" = Doc a
    forall a. Doc a
    cr
         | Bool
    otherwise         = a -> Doc a
    forall a. HasChars a => a -> Doc a
    literal a
    t
       sameStatus :: Char -> Char -> Bool
    sameStatus Char
    c Char
    d =
         (Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ' Bool -> Bool -> Bool
    && Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ') Bool -> Bool -> Bool
    ||
         (Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n' Bool -> Bool -> Bool
    && Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n') Bool -> Bool -> Bool
    ||
         (Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    ' ' Bool -> Bool -> Bool
    && Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    ' ' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n' Bool -> Bool -> Bool
    && Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n')

    -- | Escape predefined XML entities in a text value
    --
    escapeMarkupEntities :: Text     -- ^ Text to escape
                         -> Text -- ^ Resulting Doc
    escapeMarkupEntities :: Text -> Text
    escapeMarkupEntities = (Char -> Text) -> Text -> Text
    T.concatMap Char -> Text
    escape
      where
        escape :: Char -> Text
        escape :: Char -> Text
    escape Char
    '<'  = Text
    "&lt;"
        escape Char
    '>'  = Text
    "&gt;"
        escape Char
    '&'  = Text
    "&amp;"
        escape Char
    '"'  = Text
    "&quot;"
        escape Char
    '\'' = Text
    "&#39;"
        escape Char
    x    = Char -> Text
    T.singleton Char
    x