{-# LANGUAGE OverloadedStrings #-}
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
-> ChoiceString
-> Doc Text
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) =
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
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')
escapeMarkupEntities :: Text
-> Text
escapeMarkupEntities :: Text -> Text
escapeMarkupEntities = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escape
where
escape :: Char -> Text
escape :: Char -> Text
escape '<' = "<"
escape '>' = ">"
escape '&' = "&"
escape '"' = """
escape '\'' = "'"
escape x :: Char
x = Char -> Text
T.singleton Char
x