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.Monad (return)
   8 import Data.Bool
   9 import Data.Char (Char)
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function ((.), ($))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Maybe (Maybe(..), maybe)
  16 import Data.Monoid (Monoid(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (IsString(..))
  19 import Data.Text (Text)
  20 import Prelude (Num(..))
  21 import System.IO (IO)
  22 import Text.Blaze as B
  23 import Text.Blaze.Internal as B hiding (null)
  24 import Text.Show (Show(..))
  25 import qualified Blaze.ByteString.Builder as BS
  26 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
  27 import qualified Data.ByteString as BS
  28 import qualified Data.ByteString.Lazy as BSL
  29 import qualified Data.List as List
  30 import qualified Data.Text as Text
  31 import qualified Data.Text.Encoding as BS
  32 import qualified Text.Blaze.Html5 as H
  33 import qualified Text.Blaze.Renderer.Utf8 as BS
  34
  35 -- | 'Attribute' in 'Maybe'.
  36 infixl 1 !??
  37 (!??) :: Attributable h => h -> (Maybe a, a -> Attribute) -> h
  38 (!??) h (m,a) = maybe h (\x -> h ! a x) m
  39
  40 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
  41 whenMarkup Empty{} _b = return ()
  42 whenMarkup _a b = b
  43
  44 instance Semigroup H.AttributeValue where
  45         (<>) = mappend
  46
  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 Int where
  53         attrValue = fromString . show
  54 instance AttrValue [Char] where
  55         attrValue = fromString
  56
  57 -- * Type 'IndentTag'
  58 data IndentTag
  59  =   IndentTagChildren
  60  |   IndentTagText
  61  |   IndentTagPreserve
  62  deriving (Eq,Show)
  63
  64 -- | Render some 'Markup' to a 'Builder'.
  65 --
  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
  70         where
  71         inc :: Builder
  72         inc = "  "
  73         bs_Attrs i ind t_tag attrs =
  74                 case List.reverse attrs of
  75                  [] -> mempty
  76                  [a] -> a
  77                  a0:as ->
  78                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
  79                         let ind_attr =
  80                                 case i of
  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
  91                  <> BS.fromChar '>'
  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)
 100                  <> BS.fromChar '<'
 101                  <> BS.fromText t_tag
 102                  <> bs_Attrs i ind t_tag attrs
 103                  <> BS.fromChar '>'
 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
 109                  <> BS.fromChar '>'
 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)
 118                  <> BS.fromChar '<'
 119                  <> BS.fromText t_tag
 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) =
 123                 go i ind
 124                  (  BS.copyByteString (getUtf8ByteString key)
 125                  <> bs_ChoiceString value
 126                  <> BS.fromChar '"'
 127                  : attrs ) m
 128         go i ind attrs (AddCustomAttribute key value m) =
 129                 go i ind
 130                  (  BS.fromChar ' '
 131                  <> bs_ChoiceString key
 132                  <> BS.fromByteString "=\""
 133                  <> bs_ChoiceString value
 134                  <> BS.fromChar '"'
 135                  : attrs ) m
 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
 145                         else bs_ChoiceString
 146                  ) comment
 147                  <> BS.fromByteString "-->"
 148         go i ind attrs (Append m1 m2) =
 149                 go i ind attrs m1 <>
 150                 go i ind attrs m2
 151         go _i _ind _attrs (Empty _) = mempty
 152         {-# NOINLINE go #-}
 153
 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
 157
 158 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 159 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 160
 161 bs_ChoiceString :: ChoiceString -> Builder
 162 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 163
 164 t_ChoiceString :: ChoiceString -> Text
 165 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 166
 167 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 168 indentText :: Builder -> Text -> Builder
 169 indentText ind =
 170         mconcat .
 171         List.intersperse ind .
 172         (BS.fromHtmlEscapedText <$>) .
 173         Text.splitOn "\n"
 174
 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 #-}