src/Text/Pandoc/Writers/Blaze.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138

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

   Maintainer  : John MacFarlane <[email protected]>
   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 = go True mempty
  where
    go :: Bool -> Doc T.Text -> MarkupM b -> Doc T.Text
    go wrap attrs (Parent _ open close content) =
      let open' = getText open
       in literal open'
            <> attrs
            <> char '>'
            <> (case open' of
                  "<code" -> go False mempty content
                  t | t == "<pre" ||
                      t == "<style" ||
                      t == "<script" ||
                      t == "<textarea" -> flush $ go False mempty content
                    | otherwise -> go wrap mempty content)
            <> literal (getText close)
    go wrap attrs (CustomParent tag content) =
        char '<'
            <> fromChoiceString wrap tag
            <> attrs
            <> char '>'
            <> go wrap mempty content
            <> literal "</"
            <> fromChoiceString wrap tag
            <> char '>'
    go _wrap attrs (Leaf _ begin end _) =
        literal (getText begin)
            <> attrs
            <> literal (getText end)
    go wrap attrs (CustomLeaf tag close _) =
        char '<'
            <> fromChoiceString wrap tag
            <> attrs
            <> (if close then literal " />" else char '>')
    go wrap attrs (AddAttribute rawkey _ value h) =
        go wrap
          (space' wrap
            <> literal (getText rawkey)
            <> char '='
            <> doubleQuotes (fromChoiceString False value)
            <> attrs) h
    go wrap attrs (AddCustomAttribute key value h) =
        go wrap
          (space' wrap
            <> fromChoiceString wrap key
            <> char '='
            <> doubleQuotes (fromChoiceString False value)
            <> attrs) h
    go wrap _ (Content content _) = fromChoiceString wrap content
    go wrap _ (Comment comment _) =
        literal "<!--"
            <> space' wrap
            <> fromChoiceString False comment
            <> space' wrap
            <> "-->"
    go wrap attrs (Append h1 h2) = go wrap attrs h1 <> go wrap attrs h2
    go _ _ (Empty _) = mempty
    space' wrap = if wrap then space else char ' '


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

withWrap :: Bool -> Text -> Doc Text
withWrap wrap
  | wrap = mconcat . toChunks
  | otherwise = literal

toChunks :: Text -> [Doc Text]
toChunks = map toDoc . T.groupBy sameStatus
  where
   toDoc t
     | t == " " = space
     | t == "\n" = cr
     | otherwise         = literal t
   sameStatus c d =
     (c == ' ' && d == ' ') ||
     (c == '\n' && d == '\n') ||
     (c /= ' ' && d /= ' ' && c /= '\n' && d /= '\n')


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