Text/Blaze/Utils.hs

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