1 {-# LANGUAGE OverloadedStrings #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module Text.Blaze.Utils where
5 -- import Data.Ord (Ord(..))
6 import Blaze.ByteString.Builder (Builder)
7 import Control.Monad (return)
9 import Data.Eq (Eq(..))
10 import Data.Foldable (Foldable(..))
11 import Data.Function ((.), ($))
12 import Data.Functor ((<$>))
14 import Data.Maybe (Maybe(..), maybe)
15 import Data.Monoid (Monoid(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.String (IsString(..))
18 import Data.Text (Text)
19 import Prelude (Num(..))
21 import Text.Blaze as B
22 import Text.Blaze.Internal as B hiding (null)
23 import Text.Show (Show(..))
24 import qualified Blaze.ByteString.Builder as BS
25 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
26 import qualified Data.ByteString as BS
27 import qualified Data.ByteString.Lazy as BSL
28 import qualified Data.List as List
29 import qualified Data.Text as Text
30 import qualified Data.Text.Encoding as BS
31 import qualified Data.Text.Lazy as TL
32 import qualified Text.Blaze.Html5 as H
33 import qualified Text.Blaze.Renderer.Utf8 as BS
35 -- | 'Attribute' in 'Maybe'.
37 (!??) :: Attributable h => h -> (Maybe a, a -> Attribute) -> h
38 (!??) h (m,a) = maybe h (\x -> h ! a x) m
40 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
41 whenMarkup Empty{} _b = return ()
44 instance Semigroup H.AttributeValue where
47 -- * Class 'Attributable'
48 class AttrValue a where
49 attrValue :: a -> H.AttributeValue
50 instance AttrValue Text where
51 attrValue = fromString . Text.unpack
52 instance AttrValue TL.Text where
53 attrValue = fromString . TL.unpack
54 instance AttrValue Int where
55 attrValue = fromString . show
64 -- | Render some 'Markup' to a 'Builder'.
66 -- An 'IndentTag' is queried on each tag
67 -- to indent tags differently according to their names.
68 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
69 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
73 bs_Attrs i ind t_tag attrs =
74 case List.reverse attrs of
78 let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
81 IndentTagChildren -> ind<>ind_key
82 IndentTagPreserve -> mempty
83 IndentTagText -> mempty in
84 a0 <> foldMap (ind_attr <>) as
85 go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
86 go i ind attrs (Parent tag open close content) =
87 let i' = indentTag (getText tag) in
88 (if i==IndentTagChildren then ind else mempty)
89 <> BS.copyByteString (getUtf8ByteString open)
90 <> bs_Attrs i ind (getText tag) attrs
92 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
93 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
94 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
95 <> BS.copyByteString (getUtf8ByteString close)
96 go i ind attrs (CustomParent tag content) =
97 let i' = indentTag (t_ChoiceString tag) in
98 let t_tag = t_ChoiceString tag in
99 (if i==IndentTagChildren then ind else mempty)
102 <> bs_Attrs i ind t_tag attrs
104 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
105 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
106 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
107 <> BS.fromByteString "</"
108 <> bs_ChoiceString tag
110 go i ind attrs (Leaf tag begin end _) =
111 (if i==IndentTagChildren then ind else mempty)
112 <> BS.copyByteString (getUtf8ByteString begin)
113 <> bs_Attrs i ind (getText tag) attrs
114 <> BS.copyByteString (getUtf8ByteString end)
115 go i ind attrs (CustomLeaf tag close _) =
116 let t_tag = t_ChoiceString tag in
117 (if i==IndentTagChildren then ind else mempty)
120 <> bs_Attrs i ind t_tag attrs
121 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
122 go i ind attrs (AddAttribute _ key value m) =
124 ( BS.copyByteString (getUtf8ByteString key)
125 <> bs_ChoiceString value
128 go i ind attrs (AddCustomAttribute key value m) =
131 <> bs_ChoiceString key
132 <> BS.fromByteString "=\""
133 <> bs_ChoiceString value
136 go i ind _attrs (Content content _) =
137 if i/=IndentTagPreserve
138 then indentChoiceString ind content
139 else bs_ChoiceString content
140 go i ind _attrs (Comment comment _) =
141 (if i==IndentTagChildren then ind else mempty)
142 <> BS.fromByteString "<!--"
143 <> (if i==IndentTagChildren
144 then indentChoiceString ind
147 <> BS.fromByteString "-->"
148 go i ind attrs (Append m1 m2) =
151 go _i _ind _attrs (Empty _) = mempty
154 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
155 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
156 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
158 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
159 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
161 bs_ChoiceString :: ChoiceString -> Builder
162 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
164 t_ChoiceString :: ChoiceString -> Text
165 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
167 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
168 indentText :: Builder -> Text -> Builder
171 List.intersperse ind .
172 (BS.fromHtmlEscapedText <$>) .
175 -- | Render an indented 'ChoiceString'.
176 indentChoiceString :: Builder -> ChoiceString -> Builder
177 indentChoiceString ind (Static s) = indentText ind $ getText s
178 indentChoiceString ind (String s) = indentText ind $ Text.pack s
179 indentChoiceString ind (Text s) = indentText ind s
180 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
181 indentChoiceString ind (PreEscaped x) = case x of
182 String s -> indentText ind $ Text.pack s
183 Text s -> indentText ind s
184 s -> indentChoiceString ind s
185 indentChoiceString ind (External x) = case x of
186 -- Check that the sequence "</" is *not* in the external data.
187 String s -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
188 Text s -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
189 ByteString s -> if "</" `BS.isInfixOf` s then mempty else BS.fromByteString s
190 s -> indentChoiceString ind s
191 indentChoiceString ind (AppendChoiceString x y) =
192 indentChoiceString ind x <>
193 indentChoiceString ind y
194 indentChoiceString ind EmptyChoiceString = indentText ind mempty
195 {-# INLINE indentChoiceString #-}