1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Text.Blaze.Utils where
7 import Blaze.ByteString.Builder (Builder)
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..))
11 import Data.Char (Char)
12 import Data.Foldable (Foldable(..))
13 import Data.Function ((.), ($))
14 import Data.Functor ((<$>))
15 import Data.Functor.Compose (Compose(..))
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)
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
40 -- | 'Attribute' in 'Maybe'.
42 (!??) :: Attributable h => h -> Maybe Attribute -> h
43 (!??) h = maybe h (h !)
45 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
46 whenMarkup Empty{} _b = return ()
49 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
50 whenJust Nothing _f = pure ()
51 whenJust (Just a) f = f a
53 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
54 whenSome x _f | null x = pure ()
57 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
58 whenText "" _f = pure ()
62 instance Semigroup H.AttributeValue where
65 instance IsList H.AttributeValue where
66 type Item AttributeValue = AttributeValue
67 fromList = mconcat . List.intersperse " "
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
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
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
108 instance Monoid (StateMarkup st ()) where
111 instance Monad (StateMarkup st) where
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
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
129 liftStateMarkup :: S.State st a -> StateMarkup st a
130 liftStateMarkup = Compose . (return <$>)
132 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
133 runStateMarkup st = (`S.runState` st) . getCompose
135 -- | Render some 'Markup' to a 'Builder'.
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
144 noIndent :: Text -> MarkupM b -> Bool
145 noIndent e children =
146 isInlinedElement e ||
147 allInlined children && not (allComment children)
149 allInlined :: MarkupM b -> Bool
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
161 allComment :: MarkupM b -> Bool
163 Append x y -> allComment x && allComment y
164 AddAttribute _ _key _value m -> allComment m
165 AddCustomAttribute _key _value m -> allComment m
169 goAttrs :: Bool -> Builder -> Text -> [Builder] -> Builder
170 goAttrs noInd ind t_tag attrs =
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
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)
195 <> goAttrs noInd ind t_tag attrs
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
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)
212 <> goAttrs noInd ind t_tag attrs
213 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
214 AddAttribute _ key value m ->
216 ( BS.copyByteString (getUtf8ByteString key)
217 <> bs_ChoiceString value
220 AddCustomAttribute key value m ->
223 <> bs_ChoiceString key
224 <> BS.fromByteString "=\""
225 <> bs_ChoiceString value
228 Content content _ -> bs_ChoiceString content
230 (if noInd then mempty else ind)
231 <> BS.fromByteString "<!--"
232 <> indentChoiceString (ind <> " ") comment
233 <> (if noInd then mempty else ind)
234 <> BS.fromByteString "-->"
236 go noInd ind attrs m1 <>
237 go noInd ind attrs m2
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
244 prettyMarkupIO :: (Text -> Bool) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
245 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
247 bs_ChoiceString :: ChoiceString -> Builder
248 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
250 t_ChoiceString :: ChoiceString -> Text
251 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
253 -- | @indentText ind txt@ indent 'txt' with 'ind' at newlines.
254 indentText :: Builder -> Text -> Builder
257 List.intersperse ind .
258 (BS.fromHtmlEscapedText <$>) .
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 #-}