{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.Blaze
   Copyright   : Copyright (C) 2021-2023 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 = forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
True 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 forall a. HasChars a => a -> Doc a
literal Text
open'
            forall a. Semigroup a => a -> a -> a
<> Doc Text
attrs
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'>'
            forall a. Semigroup a => a -> a -> a
<> (case Text
open' of
                  Text
"<code" -> forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
False forall a. Monoid a => a
mempty MarkupM b
content
                  Text
t | Text
t forall a. Eq a => a -> a -> Bool
== Text
"<pre" Bool -> Bool -> Bool
||
                      Text
t forall a. Eq a => a -> a -> Bool
== Text
"<style" Bool -> Bool -> Bool
||
                      Text
t forall a. Eq a => a -> a -> Bool
== Text
"<script" Bool -> Bool -> Bool
||
                      Text
t forall a. Eq a => a -> a -> Bool
== Text
"<textarea" -> forall a. Doc a -> Doc a
flush forall a b. (a -> b) -> a -> b
$ forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
False forall a. Monoid a => a
mempty MarkupM b
content
                    | Bool
otherwise -> forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap forall a. Monoid a => a
mempty MarkupM b
content)
            forall a. Semigroup a => a -> a -> a
<> 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) =
        forall a. HasChars a => Char -> Doc a
char Char
'<'
            forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
tag
            forall a. Semigroup a => a -> a -> a
<> Doc Text
attrs
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'>'
            forall a. Semigroup a => a -> a -> a
<> forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap forall a. Monoid a => a
mempty MarkupM b
content
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
"</"
            forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
tag
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'>'
    go Bool
_wrap Doc Text
attrs (Leaf StaticString
_ StaticString
begin StaticString
end b
_) =
        forall a. HasChars a => a -> Doc a
literal (StaticString -> Text
getText StaticString
begin)
            forall a. Semigroup a => a -> a -> a
<> Doc Text
attrs
            forall a. Semigroup a => a -> a -> a
<> 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
_) =
        forall a. HasChars a => Char -> Doc a
char Char
'<'
            forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
tag
            forall a. Semigroup a => a -> a -> a
<> Doc Text
attrs
            forall a. Semigroup a => a -> a -> a
<> (if Bool
close then forall a. HasChars a => a -> Doc a
literal Text
" />" else forall a. HasChars a => Char -> Doc a
char Char
'>')
    go Bool
wrap Doc Text
attrs (AddAttribute StaticString
rawkey StaticString
_ ChoiceString
value MarkupM b
h) =
        forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap
          (forall {a}. HasChars a => Bool -> Doc a
space' Bool
wrap
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal (StaticString -> Text
getText StaticString
rawkey)
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'='
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Doc a -> Doc a
doubleQuotes (Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
False ChoiceString
value)
            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) =
        forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap
          (forall {a}. HasChars a => Bool -> Doc a
space' Bool
wrap
            forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
key
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'='
            forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Doc a -> Doc a
doubleQuotes (Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
False ChoiceString
value)
            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
_) =
        forall a. HasChars a => a -> Doc a
literal Text
"<!--"
            forall a. Semigroup a => a -> a -> a
<> forall {a}. HasChars a => Bool -> Doc a
space' Bool
wrap
            forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
False ChoiceString
comment
            forall a. Semigroup a => a -> a -> a
<> forall {a}. HasChars a => Bool -> Doc a
space' Bool
wrap
            forall a. Semigroup a => a -> a -> a
<> Doc Text
"-->"
    go Bool
wrap Doc Text
attrs (Append MarkupM b
h1 MarkupM b
h2) = forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap Doc Text
attrs MarkupM b
h1 forall a. Semigroup a => a -> a -> a
<> forall b. Bool -> Doc Text -> MarkupM b -> Doc Text
go Bool
wrap Doc Text
attrs MarkupM b
h2
    go Bool
_ Doc Text
_ (Empty b
_) = forall a. Monoid a => a
mempty
    space' :: Bool -> Doc a
space' Bool
wrap = if Bool
wrap then forall a. Doc a
space else 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 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 forall a b. (a -> b) -> a -> b
$
                                         Text -> Text
escapeMarkupEntities 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 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 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 -> forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s
    Text   Text
s -> 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]
"</" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
s then 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 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 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 forall a. Semigroup a => a -> a -> a
<> Bool -> ChoiceString -> Doc Text
fromChoiceString Bool
wrap ChoiceString
y
fromChoiceString Bool
_ ChoiceString
EmptyChoiceString = forall a. Monoid a => a
mempty

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

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