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