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.Eq (Eq(..))
13 import Data.Foldable (Foldable(..))
14 import Data.Function ((.), ($))
15 import Data.Functor ((<$>))
16 import Data.Functor.Compose (Compose(..))
18 import Data.Maybe (Maybe(..), maybe)
19 import Data.Monoid (Monoid(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.String (IsString(..))
22 import Data.Text (Text)
23 import GHC.Exts (IsList(..))
24 import Prelude (Num(..), undefined)
26 import Text.Blaze as B
27 import Text.Blaze.Internal as B hiding (null)
28 import Text.Show (Show(..))
29 import qualified Blaze.ByteString.Builder as BS
30 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
31 import qualified Control.Monad.Trans.State as S
32 import qualified Data.ByteString as BS
33 import qualified Data.ByteString.Lazy as BSL
34 import qualified Data.List as List
35 import qualified Data.Text as Text
36 import qualified Data.Text.Lazy as TL
37 import qualified Data.Text.Encoding as BS
38 import qualified Text.Blaze.Html5 as H
39 import qualified Text.Blaze.Renderer.Utf8 as BS
41 -- | 'Attribute' in 'Maybe'.
43 (!??) :: Attributable h => h -> Maybe Attribute -> h
44 (!??) h = maybe h (h !)
46 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
47 whenMarkup Empty{} _b = return ()
50 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
51 whenJust Nothing _f = pure ()
52 whenJust (Just a) f = f a
54 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
55 whenSome x _f | null x = pure ()
58 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
59 whenText "" _f = pure ()
63 instance Semigroup H.AttributeValue where
66 instance IsList H.AttributeValue where
67 type Item AttributeValue = AttributeValue
68 fromList = mconcat . List.intersperse " "
73 attrify :: a -> H.AttributeValue
74 instance Attrify Char where
75 attrify = fromString . pure
76 instance Attrify Text where
77 attrify = fromString . Text.unpack
78 instance Attrify TL.Text where
79 attrify = fromString . TL.unpack
80 instance Attrify Int where
81 attrify = fromString . show
82 instance Attrify [Char] where
87 mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
88 instance MayAttr a => MayAttr (Maybe a) where
89 mayAttr a t = t >>= mayAttr a
90 instance MayAttr Text where
91 mayAttr _ "" = Nothing
92 mayAttr a t = Just (a $ fromString $ Text.unpack t)
93 instance MayAttr Int where
94 mayAttr a t = Just (a $ fromString $ show t)
95 instance MayAttr [Char] where
96 mayAttr _ "" = Nothing
97 mayAttr a t = Just (a $ fromString t)
98 instance MayAttr AttributeValue where
101 -- * Type 'StateMarkup'
102 -- | Composing state and markups.
103 type StateMarkup st = Compose (S.State st) B.MarkupM
104 instance Semigroup (StateMarkup st a) where
106 instance Monoid (StateMarkup st ()) where
109 instance Monad (StateMarkup st) where
111 Compose sma >>= a2csmb =
112 Compose $ sma >>= \ma ->
113 case ma >>= B.Empty . a2csmb of
114 B.Append _ma (B.Empty csmb) ->
115 B.Append ma <$> getCompose csmb
116 _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
117 {- NOTE: the 'st' may need to use the 'String', so no such instance.
118 instance IsString (StateMarkup st ()) where
119 fromString = Compose . return . fromString
122 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
123 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
124 ($$) f m = Compose $ f <$> getCompose m
127 liftStateMarkup :: S.State st a -> StateMarkup st a
128 liftStateMarkup = Compose . (return <$>)
130 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
131 runStateMarkup st = (`S.runState` st) . getCompose
133 -- * Type 'IndentTag'
140 -- | Render some 'Markup' to a 'Builder'.
142 -- An 'IndentTag' is queried on each tag
143 -- to indent tags differently according to their names.
144 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
145 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
149 bs_Attrs i ind t_tag attrs =
150 case {-List.reverse-} attrs of
154 let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
157 IndentTagChildren -> ind<>ind_key
158 IndentTagPreserve -> mempty
159 IndentTagText -> mempty in
160 a0 <> foldMap (ind_attr <>) as
161 go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
162 go i ind attrs (Parent tag open close content) =
163 let i' = indentTag (getText tag) in
164 (if i==IndentTagChildren then ind else mempty)
165 <> BS.copyByteString (getUtf8ByteString open)
166 <> bs_Attrs i ind (getText tag) attrs
168 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
169 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
170 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
171 <> BS.copyByteString (getUtf8ByteString close)
172 go i ind attrs (CustomParent tag content) =
173 let i' = indentTag (t_ChoiceString tag) in
174 let t_tag = t_ChoiceString tag in
175 (if i==IndentTagChildren then ind else mempty)
178 <> bs_Attrs i ind t_tag attrs
180 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
181 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
182 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
183 <> BS.fromByteString "</"
184 <> bs_ChoiceString tag
186 go i ind attrs (Leaf tag begin end _) =
187 (if i==IndentTagChildren then ind else mempty)
188 <> BS.copyByteString (getUtf8ByteString begin)
189 <> bs_Attrs i ind (getText tag) attrs
190 <> BS.copyByteString (getUtf8ByteString end)
191 go i ind attrs (CustomLeaf tag close _) =
192 let t_tag = t_ChoiceString tag in
193 (if i==IndentTagChildren then ind else mempty)
196 <> bs_Attrs i ind t_tag attrs
197 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
198 go i ind attrs (AddAttribute _ key value m) =
200 ( BS.copyByteString (getUtf8ByteString key)
201 <> bs_ChoiceString value
204 go i ind attrs (AddCustomAttribute key value m) =
207 <> bs_ChoiceString key
208 <> BS.fromByteString "=\""
209 <> bs_ChoiceString value
212 go i ind _attrs (Content content _) =
213 if i/=IndentTagPreserve
214 then indentChoiceString ind content
215 else bs_ChoiceString content
216 go i ind _attrs (Comment comment _) =
217 (if i==IndentTagChildren then ind else mempty)
218 <> BS.fromByteString "<!--"
219 <> (if i==IndentTagChildren
220 then indentChoiceString ind
223 <> BS.fromByteString "-->"
224 go i ind attrs (Append m1 m2) =
227 go _i _ind _attrs (Empty _) = mempty
230 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
231 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
232 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
234 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
235 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
237 bs_ChoiceString :: ChoiceString -> Builder
238 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
240 t_ChoiceString :: ChoiceString -> Text
241 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
243 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
244 indentText :: Builder -> Text -> Builder
247 List.intersperse ind .
248 (BS.fromHtmlEscapedText <$>) .
251 -- | Render an indented 'ChoiceString'.
252 indentChoiceString :: Builder -> ChoiceString -> Builder
253 indentChoiceString ind (Static s) = indentText ind $ getText s
254 indentChoiceString ind (String s) = indentText ind $ Text.pack s
255 indentChoiceString ind (Text s) = indentText ind s
256 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
257 indentChoiceString ind (PreEscaped x) = case x of
258 String s -> indentText ind $ Text.pack s
259 Text s -> indentText ind s
260 s -> indentChoiceString ind s
261 indentChoiceString ind (External x) = case x of
262 -- Check that the sequence "</" is *not* in the external data.
263 String s -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
264 Text s -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
265 ByteString s -> if "</" `BS.isInfixOf` s then mempty else BS.fromByteString s
266 s -> indentChoiceString ind s
267 indentChoiceString ind (AppendChoiceString x y) =
268 indentChoiceString ind x <>
269 indentChoiceString ind y
270 indentChoiceString ind EmptyChoiceString = indentText ind mempty
271 {-# INLINE indentChoiceString #-}