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 ()
62 instance Semigroup H.AttributeValue where
64 instance IsList H.AttributeValue where
65 type Item AttributeValue = AttributeValue
66 fromList = mconcat . List.intersperse " "
71 attrify :: a -> H.AttributeValue
72 instance Attrify Char where
73 attrify = fromString . pure
74 instance Attrify Text where
75 attrify = fromString . Text.unpack
76 instance Attrify TL.Text where
77 attrify = fromString . TL.unpack
78 instance Attrify Int where
79 attrify = fromString . show
80 instance Attrify [Char] where
85 mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
86 instance MayAttr a => MayAttr (Maybe a) where
87 mayAttr a t = t >>= mayAttr a
88 instance MayAttr Text where
89 mayAttr _ "" = Nothing
90 mayAttr a t = Just (a $ fromString $ Text.unpack t)
91 instance MayAttr Int where
92 mayAttr a t = Just (a $ fromString $ show t)
93 instance MayAttr [Char] where
94 mayAttr _ "" = Nothing
95 mayAttr a t = Just (a $ fromString t)
96 instance MayAttr AttributeValue where
99 -- * Type 'StateMarkup'
100 -- | Composing state and markups.
101 type StateMarkup st = Compose (S.State st) B.MarkupM
102 instance Semigroup (StateMarkup st a) where
104 instance Monoid (StateMarkup st ()) where
107 instance Monad (StateMarkup st) where
109 Compose sma >>= a2csmb =
110 Compose $ sma >>= \ma ->
111 case ma >>= B.Empty . a2csmb of
112 B.Append _ma (B.Empty csmb) ->
113 B.Append ma <$> getCompose csmb
115 instance IsString (StateMarkup st ()) where
116 fromString = Compose . return . fromString
118 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
119 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
120 ($$) f m = Compose $ f <$> getCompose m
123 liftStateMarkup :: S.State st a -> StateMarkup st a
124 liftStateMarkup = Compose . (return <$>)
126 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
127 runStateMarkup st = (`S.runState` st) . getCompose
129 -- * Type 'IndentTag'
136 -- | Render some 'Markup' to a 'Builder'.
138 -- An 'IndentTag' is queried on each tag
139 -- to indent tags differently according to their names.
140 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
141 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
145 bs_Attrs i ind t_tag attrs =
146 case {-List.reverse-} attrs of
150 let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
153 IndentTagChildren -> ind<>ind_key
154 IndentTagPreserve -> mempty
155 IndentTagText -> mempty in
156 a0 <> foldMap (ind_attr <>) as
157 go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
158 go i ind attrs (Parent tag open close content) =
159 let i' = indentTag (getText tag) in
160 (if i==IndentTagChildren then ind else mempty)
161 <> BS.copyByteString (getUtf8ByteString open)
162 <> bs_Attrs i ind (getText tag) attrs
164 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
165 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
166 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
167 <> BS.copyByteString (getUtf8ByteString close)
168 go i ind attrs (CustomParent tag content) =
169 let i' = indentTag (t_ChoiceString tag) in
170 let t_tag = t_ChoiceString tag in
171 (if i==IndentTagChildren then ind else mempty)
174 <> bs_Attrs i ind t_tag attrs
176 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
177 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
178 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
179 <> BS.fromByteString "</"
180 <> bs_ChoiceString tag
182 go i ind attrs (Leaf tag begin end _) =
183 (if i==IndentTagChildren then ind else mempty)
184 <> BS.copyByteString (getUtf8ByteString begin)
185 <> bs_Attrs i ind (getText tag) attrs
186 <> BS.copyByteString (getUtf8ByteString end)
187 go i ind attrs (CustomLeaf tag close _) =
188 let t_tag = t_ChoiceString tag in
189 (if i==IndentTagChildren then ind else mempty)
192 <> bs_Attrs i ind t_tag attrs
193 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
194 go i ind attrs (AddAttribute _ key value m) =
196 ( BS.copyByteString (getUtf8ByteString key)
197 <> bs_ChoiceString value
200 go i ind attrs (AddCustomAttribute key value m) =
203 <> bs_ChoiceString key
204 <> BS.fromByteString "=\""
205 <> bs_ChoiceString value
208 go i ind _attrs (Content content _) =
209 if i/=IndentTagPreserve
210 then indentChoiceString ind content
211 else bs_ChoiceString content
212 go i ind _attrs (Comment comment _) =
213 (if i==IndentTagChildren then ind else mempty)
214 <> BS.fromByteString "<!--"
215 <> (if i==IndentTagChildren
216 then indentChoiceString ind
219 <> BS.fromByteString "-->"
220 go i ind attrs (Append m1 m2) =
223 go _i _ind _attrs (Empty _) = mempty
226 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
227 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
228 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
230 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
231 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
233 bs_ChoiceString :: ChoiceString -> Builder
234 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
236 t_ChoiceString :: ChoiceString -> Text
237 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
239 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
240 indentText :: Builder -> Text -> Builder
243 List.intersperse ind .
244 (BS.fromHtmlEscapedText <$>) .
247 -- | Render an indented 'ChoiceString'.
248 indentChoiceString :: Builder -> ChoiceString -> Builder
249 indentChoiceString ind (Static s) = indentText ind $ getText s
250 indentChoiceString ind (String s) = indentText ind $ Text.pack s
251 indentChoiceString ind (Text s) = indentText ind s
252 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
253 indentChoiceString ind (PreEscaped x) = case x of
254 String s -> indentText ind $ Text.pack s
255 Text s -> indentText ind s
256 s -> indentChoiceString ind s
257 indentChoiceString ind (External x) = case x of
258 -- Check that the sequence "</" is *not* in the external data.
259 String s -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
260 Text s -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
261 ByteString s -> if "</" `BS.isInfixOf` s then mempty else BS.fromByteString s
262 s -> indentChoiceString ind s
263 indentChoiceString ind (AppendChoiceString x y) =
264 indentChoiceString ind x <>
265 indentChoiceString ind y
266 indentChoiceString ind EmptyChoiceString = indentText ind mempty
267 {-# INLINE indentChoiceString #-}