1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Text.Blaze.Utils where
6 import Blaze.ByteString.Builder (Builder)
7 import Control.Applicative (Applicative(..))
8 import Control.Monad (Monad(..))
10 import Data.Char (Char)
11 import Data.Eq (Eq(..))
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 Prelude (Num(..), undefined)
24 import Text.Blaze as B
25 import Text.Blaze.Internal as B hiding (null)
26 import Text.Show (Show(..))
27 import qualified Blaze.ByteString.Builder as BS
28 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
29 import qualified Control.Monad.Trans.State as S
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.Lazy as TL
35 import qualified Data.Text.Encoding as BS
36 import qualified Text.Blaze.Html5 as H
37 import qualified Text.Blaze.Renderer.Utf8 as BS
39 -- | 'Attribute' in 'Maybe'.
41 (!??) :: Attributable h => h -> Maybe Attribute -> h
42 (!??) h = maybe h (h !)
44 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
45 whenMarkup Empty{} _b = return ()
48 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
49 whenJust Nothing _f = pure ()
50 whenJust (Just a) f = f a
52 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
53 whenSome x _f | null x = pure ()
56 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
57 whenText "" _f = pure ()
60 instance Semigroup H.AttributeValue where
65 attrify :: a -> H.AttributeValue
66 instance Attrify Char where
67 attrify = fromString . pure
68 instance Attrify Text where
69 attrify = fromString . Text.unpack
70 instance Attrify TL.Text where
71 attrify = fromString . TL.unpack
72 instance Attrify Int where
73 attrify = fromString . show
74 instance Attrify [Char] where
79 mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
80 instance MayAttr a => MayAttr (Maybe a) where
81 mayAttr a t = t >>= mayAttr a
82 instance MayAttr Text where
83 mayAttr _ "" = Nothing
84 mayAttr a t = Just (a $ fromString $ Text.unpack t)
85 instance MayAttr Int where
86 mayAttr a t = Just (a $ fromString $ show t)
87 instance MayAttr [Char] where
88 mayAttr _ "" = Nothing
89 mayAttr a t = Just (a $ fromString t)
90 instance MayAttr AttributeValue where
93 -- * Type 'StateMarkup'
94 -- | Composing state and markups.
95 type StateMarkup st = Compose (S.State st) B.MarkupM
96 instance Monad (StateMarkup st) where
98 Compose sma >>= a2csmb =
99 Compose $ sma >>= \ma ->
100 case ma >>= B.Empty . a2csmb of
101 B.Append _ma (B.Empty csmb) ->
102 B.Append ma <$> getCompose csmb
104 instance IsString (StateMarkup st ()) where
105 fromString = Compose . return . fromString
107 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
108 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
109 ($$) f m = Compose $ f <$> getCompose m
112 liftStateMarkup :: S.State st a -> StateMarkup st a
113 liftStateMarkup = Compose . (return <$>)
115 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
116 runStateMarkup st = (`S.runState` st) . getCompose
118 -- * Type 'IndentTag'
125 -- | Render some 'Markup' to a 'Builder'.
127 -- An 'IndentTag' is queried on each tag
128 -- to indent tags differently according to their names.
129 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
130 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
134 bs_Attrs i ind t_tag attrs =
135 case {-List.reverse-} attrs of
139 let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
142 IndentTagChildren -> ind<>ind_key
143 IndentTagPreserve -> mempty
144 IndentTagText -> mempty in
145 a0 <> foldMap (ind_attr <>) as
146 go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
147 go i ind attrs (Parent tag open close content) =
148 let i' = indentTag (getText tag) in
149 (if i==IndentTagChildren then ind else mempty)
150 <> BS.copyByteString (getUtf8ByteString open)
151 <> bs_Attrs i ind (getText tag) attrs
153 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
154 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
155 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
156 <> BS.copyByteString (getUtf8ByteString close)
157 go i ind attrs (CustomParent tag content) =
158 let i' = indentTag (t_ChoiceString tag) in
159 let t_tag = t_ChoiceString tag in
160 (if i==IndentTagChildren then ind else mempty)
163 <> bs_Attrs i ind t_tag attrs
165 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
166 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
167 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
168 <> BS.fromByteString "</"
169 <> bs_ChoiceString tag
171 go i ind attrs (Leaf tag begin end _) =
172 (if i==IndentTagChildren then ind else mempty)
173 <> BS.copyByteString (getUtf8ByteString begin)
174 <> bs_Attrs i ind (getText tag) attrs
175 <> BS.copyByteString (getUtf8ByteString end)
176 go i ind attrs (CustomLeaf tag close _) =
177 let t_tag = t_ChoiceString tag in
178 (if i==IndentTagChildren then ind else mempty)
181 <> bs_Attrs i ind t_tag attrs
182 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
183 go i ind attrs (AddAttribute _ key value m) =
185 ( BS.copyByteString (getUtf8ByteString key)
186 <> bs_ChoiceString value
189 go i ind attrs (AddCustomAttribute key value m) =
192 <> bs_ChoiceString key
193 <> BS.fromByteString "=\""
194 <> bs_ChoiceString value
197 go i ind _attrs (Content content _) =
198 if i/=IndentTagPreserve
199 then indentChoiceString ind content
200 else bs_ChoiceString content
201 go i ind _attrs (Comment comment _) =
202 (if i==IndentTagChildren then ind else mempty)
203 <> BS.fromByteString "<!--"
204 <> (if i==IndentTagChildren
205 then indentChoiceString ind
208 <> BS.fromByteString "-->"
209 go i ind attrs (Append m1 m2) =
212 go _i _ind _attrs (Empty _) = mempty
215 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
216 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
217 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
219 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
220 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
222 bs_ChoiceString :: ChoiceString -> Builder
223 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
225 t_ChoiceString :: ChoiceString -> Text
226 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
228 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
229 indentText :: Builder -> Text -> Builder
232 List.intersperse ind .
233 (BS.fromHtmlEscapedText <$>) .
236 -- | Render an indented 'ChoiceString'.
237 indentChoiceString :: Builder -> ChoiceString -> Builder
238 indentChoiceString ind (Static s) = indentText ind $ getText s
239 indentChoiceString ind (String s) = indentText ind $ Text.pack s
240 indentChoiceString ind (Text s) = indentText ind s
241 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
242 indentChoiceString ind (PreEscaped x) = case x of
243 String s -> indentText ind $ Text.pack s
244 Text s -> indentText ind s
245 s -> indentChoiceString ind s
246 indentChoiceString ind (External x) = case x of
247 -- Check that the sequence "</" is *not* in the external data.
248 String s -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
249 Text s -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
250 ByteString s -> if "</" `BS.isInfixOf` s then mempty else BS.fromByteString s
251 s -> indentChoiceString ind s
252 indentChoiceString ind (AppendChoiceString x y) =
253 indentChoiceString ind x <>
254 indentChoiceString ind y
255 indentChoiceString ind EmptyChoiceString = indentText ind mempty
256 {-# INLINE indentChoiceString #-}