{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.Blaze
   Copyright   : Copyright (C) 2021-2022 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 :: Bool -> Doc Text -> MarkupM b -> Doc Text
go wrap :: Bool
wrap attrs :: Doc Text
attrs (Parent _ open :: StaticString
open close :: StaticString
close content :: 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 '>'
            Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> (case Text
open' of
                  "<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
                  t :: Text
t | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "<pre" Bool -> Bool -> Bool
||
                      Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "<style" Bool -> Bool -> Bool
||
                      Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "<script" Bool -> Bool -> Bool
||
                      Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "<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 wrap :: Bool
wrap attrs :: Doc Text
attrs (CustomParent tag :: ChoiceString
tag content :: MarkupM b
content) =
        Char -> Doc Text
forall a. HasChars a => Char -> Doc a
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 '>'
            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 "</"
            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 '>'
    go _wrap :: Bool
_wrap attrs :: Doc Text
attrs (Leaf _ begin :: StaticString
begin end :: StaticString
end _) =
        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 wrap :: Bool
wrap attrs :: Doc Text
attrs (CustomLeaf tag :: ChoiceString
tag close :: Bool
close _) =
        Char -> Doc Text
forall a. HasChars a => Char -> Doc a
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 " />" else Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char '>')
    go wrap :: Bool
wrap attrs :: Doc Text
attrs (AddAttribute rawkey :: StaticString
rawkey _ value :: ChoiceString
value h :: 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 '='
            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 wrap :: Bool
wrap attrs :: Doc Text
attrs (AddCustomAttribute key :: ChoiceString
key value :: ChoiceString
value h :: 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 '='
            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 wrap :: Bool
wrap _ (Content content :: ChoiceString
content _) = Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
content
    go wrap :: Bool
wrap _ (Comment comment :: ChoiceString
comment _) =
        Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal "<!--"
            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
<> "-->"
    go wrap :: Bool
wrap attrs :: Doc Text
attrs (Append h1 :: MarkupM b
h1 h2 :: 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 _ _ (Empty _) = Doc Text
forall a. Monoid a => a
mempty
    space' :: Bool -> Doc a
space' wrap :: 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 ' '


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

withWrap :: Bool -> Text -> Doc Text
withWrap :: Bool -> Text -> Doc Text
withWrap wrap :: 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 t :: a
t
     | a
t a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== " " = Doc a
forall a. Doc a
space
     | a
t a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== "\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 c :: Char
c d :: Char
d =
     (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
&& Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Bool -> Bool -> Bool
||
     (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
&& Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') Bool -> Bool -> Bool
||
     (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ' Bool -> Bool -> Bool
&& Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n' Bool -> Bool -> Bool
&& Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\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 '<'  = "&lt;"
    escape '>'  = "&gt;"
    escape '&'  = "&amp;"
    escape '"'  = "&quot;"
    escape '\'' = "&#39;"
    escape x :: Char
x    = Char -> Text
T.singleton Char
x