]> Git — Sourcephile - doclang.git/blob - Text/Blaze/Utils.hs
Update to megaparsec-7 and new symantic-xml
[doclang.git] / Text / Blaze / Utils.hs
1 {-# language OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Text.Blaze.Utils where
6
7 import Blaze.ByteString.Builder (Builder)
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..))
10 import Data.Bool
11 import Data.Char (Char)
12 import Data.Foldable (Foldable(..))
13 import Data.Function ((.), ($))
14 import Data.Functor ((<$>))
15 import Data.Functor.Compose (Compose(..))
16 import Data.Int (Int)
17 import Data.Maybe (Maybe(..), maybe)
18 import Data.Monoid (Monoid(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.String (IsString(..))
21 import Data.Text (Text)
22 import GHC.Exts (IsList(..))
23 import Prelude (Num(..), undefined)
24 import System.IO (IO)
25 import Text.Blaze as B
26 import Text.Blaze.Internal as B hiding (null)
27 import Text.Show (Show(..))
28 import qualified Blaze.ByteString.Builder as BS
29 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
30 import qualified Data.ByteString as BS
31 import qualified Data.ByteString.Lazy as BSL
32 import qualified Data.List as List
33 import qualified Data.Text as Text
34 import qualified Data.Text.Encoding as BS
35 import qualified Data.Text.Lazy as TL
36 import qualified Text.Blaze.Html5 as H
37 import qualified Text.Blaze.Renderer.Utf8 as BS
38 import qualified Text.Megaparsec as P
39
40 import Control.Monad.Utils
41
42 -- | 'Attribute' in 'Maybe'.
43 infixl 1 !??
44 (!??) :: Attributable h => h -> Maybe Attribute -> h
45 (!??) h = maybe h (h !)
46
47 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
48 whenMarkup Empty{} _b = return ()
49 whenMarkup _a b = b
50
51 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
52 whenJust Nothing _f = pure ()
53 whenJust (Just a) f = f a
54
55 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
56 whenSome x _f | null x = pure ()
57 whenSome x f = f x
58
59 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
60 whenText "" _f = pure ()
61 whenText t f = f t
62
63 {-
64 instance Semigroup H.AttributeValue where
65 (<>) = mappend
66 -}
67 instance IsList H.AttributeValue where
68 type Item AttributeValue = AttributeValue
69 fromList = mconcat . List.intersperse " "
70 toList = pure
71
72 -- * Class 'Attrify'
73 class Attrify a where
74 attrify :: a -> H.AttributeValue
75 instance Attrify Char where
76 attrify = fromString . pure
77 instance Attrify Text where
78 attrify = fromString . Text.unpack
79 instance Attrify TL.Text where
80 attrify = fromString . TL.unpack
81 instance Attrify Int where
82 attrify = fromString . show
83 instance Attrify P.Pos where
84 attrify = fromString . show . P.unPos
85 instance Attrify [Char] where
86 attrify = fromString
87
88 -- * Class 'MayAttr'
89 class MayAttr a where
90 mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
91 instance MayAttr a => MayAttr (Maybe a) where
92 mayAttr a t = t >>= mayAttr a
93 instance MayAttr Text where
94 mayAttr _ "" = Nothing
95 mayAttr a t = Just (a $ fromString $ Text.unpack t)
96 instance MayAttr TL.Text where
97 mayAttr _ "" = Nothing
98 mayAttr a t = Just (a $ fromString $ TL.unpack t)
99 instance MayAttr Int where
100 mayAttr a t = Just (a $ fromString $ show t)
101 instance MayAttr [Char] where
102 mayAttr _ "" = Nothing
103 mayAttr a t = Just (a $ fromString t)
104 instance MayAttr AttributeValue where
105 mayAttr a = Just . a
106
107 -- * Type 'ComposeState'
108 instance Semigroup (ComposeState st B.MarkupM a) where
109 (<>) = (>>)
110 instance Monoid (ComposeState st B.MarkupM ()) where
111 mempty = pure ()
112 mappend = (<>)
113 instance Monad (ComposeState st B.MarkupM) where
114 return = pure
115 Compose sma >>= a2csmb =
116 Compose $ sma >>= \ma ->
117 case ma >>= B.Empty . a2csmb of
118 B.Append _ma (B.Empty csmb) ->
119 B.Append ma <$> getCompose csmb
120 _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
121
122 -- * Type 'ComposeRWS'
123 instance Monoid w => Semigroup (ComposeRWS r w s B.MarkupM a) where
124 (<>) = (>>)
125 instance Monoid w => Monoid (ComposeRWS r w s B.MarkupM ()) where
126 mempty = pure ()
127 mappend = (<>)
128 instance Monoid w => Monad (ComposeRWS r w s B.MarkupM) where
129 return = pure
130 Compose sma >>= a2csmb =
131 Compose $ sma >>= \ma ->
132 case ma >>= B.Empty . a2csmb of
133 B.Append _ma (B.Empty csmb) ->
134 B.Append ma <$> getCompose csmb
135 _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
136
137 -- | Render some 'Markup' to a 'Builder'.
138 --
139 -- An 'IndentTag' is queried on each tag
140 -- to indent tags differently according to their names.
141 prettyMarkupBuilder :: (Text -> Bool) -> Markup -> Builder
142 prettyMarkupBuilder isInlinedElement ms = go (noIndent "" ms) "\n" mempty ms
143 where
144 inc :: Builder
145 inc = " "
146 noIndent :: Text -> MarkupM b -> Bool
147 noIndent e children =
148 isInlinedElement e ||
149 allInlined children && not (allComment children)
150 where
151 allInlined :: MarkupM b -> Bool
152 allInlined = \case
153 Append x y -> allInlined x && allInlined y
154 CustomParent tag _m -> isInlinedElement $ t_ChoiceString tag
155 CustomLeaf tag _close _ -> isInlinedElement $ t_ChoiceString tag
156 Parent tag _open _close _m -> isInlinedElement $ getText tag
157 Leaf tag _begin _end _ -> isInlinedElement $ getText tag
158 AddAttribute _ _key _value m -> allInlined m
159 AddCustomAttribute _key _value m -> allInlined m
160 Comment{} -> True
161 Content{} -> True
162 Empty{} -> True
163 allComment :: MarkupM b -> Bool
164 allComment = \case
165 Append x y -> allComment x && allComment y
166 AddAttribute _ _key _value m -> allComment m
167 AddCustomAttribute _key _value m -> allComment m
168 Comment{} -> True
169 Empty{} -> True
170 _ -> False
171 goAttrs :: Bool -> Builder -> Text -> [Builder] -> Builder
172 goAttrs noInd ind t_tag attrs =
173 case attrs of
174 [] -> mempty
175 [a] -> a
176 a0:as ->
177 let ind_key = BS.fromString $ List.replicate (Text.length t_tag + 1) ' ' in
178 let ind_attr = if noInd then mempty else ind<>ind_key in
179 a0 <> foldMap (ind_attr <>) as
180 go :: Bool -> Builder -> [Builder] -> MarkupM b -> Builder
181 go noInd ind attrs = \case
182 Parent tag open close content ->
183 let noInd' = noIndent (getText tag) content in
184 (if noInd then mempty else ind)
185 <> BS.copyByteString (getUtf8ByteString open)
186 <> goAttrs noInd ind (getText tag) attrs
187 <> BS.fromChar '>'
188 <> go noInd' (if noInd then ind else ind<>inc) mempty content
189 <> (if noInd' then mempty else ind)
190 <> BS.copyByteString (getUtf8ByteString close)
191 CustomParent tag content ->
192 let t_tag = t_ChoiceString tag in
193 let noInd' = noIndent t_tag content in
194 (if noInd then mempty else ind)
195 <> BS.fromChar '<'
196 <> BS.fromText t_tag
197 <> goAttrs noInd ind t_tag attrs
198 <> BS.fromChar '>'
199 <> go noInd' (if noInd' then ind else ind<>inc) mempty content
200 <> (if noInd' then mempty else ind)
201 <> BS.fromByteString "</"
202 <> bs_ChoiceString tag
203 <> BS.fromChar '>'
204 Leaf tag begin end _ ->
205 (if noInd then mempty else ind)
206 <> BS.copyByteString (getUtf8ByteString begin)
207 <> goAttrs noInd ind (getText tag) attrs
208 <> BS.copyByteString (getUtf8ByteString end)
209 CustomLeaf tag close _ ->
210 let t_tag = t_ChoiceString tag in
211 (if noInd then mempty else ind)
212 <> BS.fromChar '<'
213 <> BS.fromText t_tag
214 <> goAttrs noInd ind t_tag attrs
215 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
216 AddAttribute _ key value m ->
217 go noInd ind
218 ( BS.copyByteString (getUtf8ByteString key)
219 <> bs_ChoiceString value
220 <> BS.fromChar '"'
221 : attrs ) m
222 AddCustomAttribute key value m ->
223 go noInd ind
224 ( BS.fromChar ' '
225 <> bs_ChoiceString key
226 <> BS.fromByteString "=\""
227 <> bs_ChoiceString value
228 <> BS.fromChar '"'
229 : attrs ) m
230 Content c _ -> bs_ChoiceString c
231 Comment comment _ ->
232 (if noInd then mempty else ind)
233 <> BS.fromByteString "<!--"
234 <> indentChoiceString (ind <> " ") comment
235 <> (if noInd then mempty else ind)
236 <> BS.fromByteString "-->"
237 Append m1 m2 ->
238 go noInd ind attrs m1 <>
239 go noInd ind attrs m2
240 Empty _ -> mempty
241
242 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
243 prettyMarkup :: (Text -> Bool) -> Markup -> BSL.ByteString
244 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
245
246 prettyMarkupIO :: (Text -> Bool) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
247 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
248
249 bs_ChoiceString :: ChoiceString -> Builder
250 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
251
252 t_ChoiceString :: ChoiceString -> Text
253 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
254
255 -- | @indentText ind txt@ indent 'txt' with 'ind' at newlines.
256 indentText :: Builder -> Text -> Builder
257 indentText ind =
258 mconcat .
259 List.intersperse ind .
260 (BS.fromHtmlEscapedText <$>) .
261 Text.splitOn "\n"
262
263 -- | Render an indented 'ChoiceString'.
264 indentChoiceString :: Builder -> ChoiceString -> Builder
265 indentChoiceString ind (Static s) = indentText ind $ getText s
266 indentChoiceString ind (String s) = indentText ind $ Text.pack s
267 indentChoiceString ind (Text s) = indentText ind s
268 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
269 indentChoiceString ind (PreEscaped x) = case x of
270 String s -> indentText ind $ Text.pack s
271 Text s -> indentText ind s
272 s -> indentChoiceString ind s
273 indentChoiceString ind (External x) = case x of
274 -- Check that the sequence "</" is *not* in the external data.
275 String s -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
276 Text s -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
277 ByteString s -> if "</" `BS.isInfixOf` s then mempty else BS.fromByteString s
278 s -> indentChoiceString ind s
279 indentChoiceString ind (AppendChoiceString x y) =
280 indentChoiceString ind x <>
281 indentChoiceString ind y
282 indentChoiceString ind EmptyChoiceString = indentText ind mempty
283 {-# INLINE indentChoiceString #-}