Text/Blaze/Utils.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Text.Blaze.Utils where
   5
   6 import Blaze.ByteString.Builder (Builder)
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad (return)
   9 import Data.Bool
  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.Int (Int)
  16 import Data.Maybe (Maybe(..), maybe)
  17 import Data.Monoid (Monoid(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (IsString(..))
  20 import Data.Text (Text)
  21 import Prelude (Num(..))
  22 import System.IO (IO)
  23 import Text.Blaze as B
  24 import Text.Blaze.Internal as B hiding (null)
  25 import Text.Show (Show(..))
  26 import qualified Blaze.ByteString.Builder as BS
  27 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
  28 import qualified Data.ByteString as BS
  29 import qualified Data.ByteString.Lazy as BSL
  30 import qualified Data.List as List
  31 import qualified Data.Text as Text
  32 import qualified Data.Text.Encoding as BS
  33 import qualified Text.Blaze.Html5 as H
  34 import qualified Text.Blaze.Renderer.Utf8 as BS
  35
  36 -- | 'Attribute' in 'Maybe'.
  37 infixl 1 !??
  38 (!??) :: Attributable h => h -> (Maybe a, a -> Attribute) -> h
  39 (!??) h (m,a) = maybe h (\x -> h ! a x) m
  40
  41 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
  42 whenMarkup Empty{} _b = return ()
  43 whenMarkup _a b = b
  44
  45 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
  46 whenJust Nothing _f = pure ()
  47 whenJust (Just a) f = f a
  48
  49 instance Semigroup H.AttributeValue where
  50         (<>) = mappend
  51
  52 -- * Class 'Attributable'
  53 class AttrValue a where
  54         attrValue :: a -> H.AttributeValue
  55 instance AttrValue Text where
  56         attrValue = fromString . Text.unpack
  57 instance AttrValue Int where
  58         attrValue = fromString . show
  59 instance AttrValue [Char] where
  60         attrValue = fromString
  61
  62 -- * Type 'IndentTag'
  63 data IndentTag
  64  =   IndentTagChildren
  65  |   IndentTagText
  66  |   IndentTagPreserve
  67  deriving (Eq,Show)
  68
  69 -- | Render some 'Markup' to a 'Builder'.
  70 --
  71 -- An 'IndentTag' is queried on each tag
  72 -- to indent tags differently according to their names.
  73 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
  74 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
  75         where
  76         inc :: Builder
  77         inc = "  "
  78         bs_Attrs i ind t_tag attrs =
  79                 case List.reverse attrs of
  80                  [] -> mempty
  81                  [a] -> a
  82                  a0:as ->
  83                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
  84                         let ind_attr =
  85                                 case i of
  86                                  IndentTagChildren -> ind<>ind_key
  87                                  IndentTagPreserve -> mempty
  88                                  IndentTagText -> mempty in
  89                         a0 <> foldMap (ind_attr <>) as
  90         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
  91         go i ind attrs (Parent tag open close content) =
  92                 let i' = indentTag (getText tag) in
  93                 (if i==IndentTagChildren then ind else mempty)
  94                  <> BS.copyByteString (getUtf8ByteString open)
  95                  <> bs_Attrs i ind (getText tag) attrs
  96                  <> BS.fromChar '>'
  97                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
  98                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
  99                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 100                  <> BS.copyByteString (getUtf8ByteString close)
 101         go i ind attrs (CustomParent tag content) =
 102                 let i' = indentTag (t_ChoiceString tag) in
 103                 let t_tag = t_ChoiceString tag in
 104                 (if i==IndentTagChildren then ind else mempty)
 105                  <> BS.fromChar '<'
 106                  <> BS.fromText t_tag
 107                  <> bs_Attrs i ind t_tag attrs
 108                  <> BS.fromChar '>'
 109                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 110                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 111                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 112                  <> BS.fromByteString "</"
 113                  <> bs_ChoiceString tag
 114                  <> BS.fromChar '>'
 115         go i ind attrs (Leaf tag begin end _) =
 116                 (if i==IndentTagChildren then ind else mempty)
 117                  <> BS.copyByteString (getUtf8ByteString begin)
 118                  <> bs_Attrs i ind (getText tag) attrs
 119                  <> BS.copyByteString (getUtf8ByteString end)
 120         go i ind attrs (CustomLeaf tag close _) =
 121                 let t_tag = t_ChoiceString tag in
 122                 (if i==IndentTagChildren then ind else mempty)
 123                  <> BS.fromChar '<'
 124                  <> BS.fromText t_tag
 125                  <> bs_Attrs i ind t_tag attrs
 126                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 127         go i ind attrs (AddAttribute _ key value m) =
 128                 go i ind
 129                  (  BS.copyByteString (getUtf8ByteString key)
 130                  <> bs_ChoiceString value
 131                  <> BS.fromChar '"'
 132                  : attrs ) m
 133         go i ind attrs (AddCustomAttribute key value m) =
 134                 go i ind
 135                  (  BS.fromChar ' '
 136                  <> bs_ChoiceString key
 137                  <> BS.fromByteString "=\""
 138                  <> bs_ChoiceString value
 139                  <> BS.fromChar '"'
 140                  : attrs ) m
 141         go i ind _attrs (Content content _) =
 142                 if i/=IndentTagPreserve
 143                 then indentChoiceString ind content
 144                 else bs_ChoiceString content
 145         go i ind _attrs (Comment comment _) =
 146                 (if i==IndentTagChildren then ind else mempty)
 147                  <> BS.fromByteString "<!--"
 148                  <> (if i==IndentTagChildren
 149                         then indentChoiceString ind
 150                         else bs_ChoiceString
 151                  ) comment
 152                  <> BS.fromByteString "-->"
 153         go i ind attrs (Append m1 m2) =
 154                 go i ind attrs m1 <>
 155                 go i ind attrs m2
 156         go _i _ind _attrs (Empty _) = mempty
 157         {-# NOINLINE go #-}
 158
 159 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 160 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 161 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 162
 163 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 164 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 165
 166 bs_ChoiceString :: ChoiceString -> Builder
 167 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 168
 169 t_ChoiceString :: ChoiceString -> Text
 170 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 171
 172 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 173 indentText :: Builder -> Text -> Builder
 174 indentText ind =
 175         mconcat .
 176         List.intersperse ind .
 177         (BS.fromHtmlEscapedText <$>) .
 178         Text.splitOn "\n"
 179
 180 -- | Render an indented 'ChoiceString'.
 181 indentChoiceString :: Builder -> ChoiceString -> Builder
 182 indentChoiceString ind (Static s)     = indentText ind $ getText s
 183 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 184 indentChoiceString ind (Text s)       = indentText ind s
 185 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 186 indentChoiceString ind (PreEscaped x) = case x of
 187          String s -> indentText ind $ Text.pack s
 188          Text   s -> indentText ind s
 189          s        -> indentChoiceString ind s
 190 indentChoiceString ind (External x) = case x of
 191          -- Check that the sequence "</" is *not* in the external data.
 192          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 193          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 194          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 195          s            -> indentChoiceString ind s
 196 indentChoiceString ind (AppendChoiceString x y) =
 197         indentChoiceString ind x <>
 198         indentChoiceString ind y
 199 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 200 {-# INLINE indentChoiceString #-}