Text/Blaze/Utils.hs

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