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 (Monad(..))
   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 Attribute -> h
  39 (!??) h = maybe h (h !)
  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 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
  50 whenSome x _f | null x = pure ()
  51 whenSome x f = f x
  52
  53 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
  54 whenText "" _f = pure ()
  55 whenText t f = f t
  56
  57 instance Semigroup H.AttributeValue where
  58         (<>) = mappend
  59
  60 -- * Class 'AttrValue'
  61 class AttrValue a where
  62         attrValue :: a -> H.AttributeValue
  63 instance AttrValue Text where
  64         attrValue = fromString . Text.unpack
  65 instance AttrValue Int where
  66         attrValue = fromString . show
  67 instance AttrValue [Char] where
  68         attrValue = fromString
  69
  70 -- * Class 'MayAttr'
  71 class MayAttr a where
  72         mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
  73 instance MayAttr a => MayAttr (Maybe a) where
  74         mayAttr a t = t >>= mayAttr a
  75 instance MayAttr Text where
  76         mayAttr _ "" = Nothing
  77         mayAttr a t  = Just (a $ fromString $ Text.unpack t)
  78 instance MayAttr Int where
  79         mayAttr a t  = Just (a $ fromString $ show t)
  80 instance MayAttr [Char] where
  81         mayAttr _ "" = Nothing
  82         mayAttr a t  = Just (a $ fromString t)
  83
  84 -- * Type 'IndentTag'
  85 data IndentTag
  86  =   IndentTagChildren
  87  |   IndentTagText
  88  |   IndentTagPreserve
  89  deriving (Eq,Show)
  90
  91 -- | Render some 'Markup' to a 'Builder'.
  92 --
  93 -- An 'IndentTag' is queried on each tag
  94 -- to indent tags differently according to their names.
  95 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
  96 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
  97         where
  98         inc :: Builder
  99         inc = "  "
 100         bs_Attrs i ind t_tag attrs =
 101                 case {-List.reverse-} attrs of
 102                  [] -> mempty
 103                  [a] -> a
 104                  a0:as ->
 105                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
 106                         let ind_attr =
 107                                 case i of
 108                                  IndentTagChildren -> ind<>ind_key
 109                                  IndentTagPreserve -> mempty
 110                                  IndentTagText -> mempty in
 111                         a0 <> foldMap (ind_attr <>) as
 112         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
 113         go i ind attrs (Parent tag open close content) =
 114                 let i' = indentTag (getText tag) in
 115                 (if i==IndentTagChildren then ind else mempty)
 116                  <> BS.copyByteString (getUtf8ByteString open)
 117                  <> bs_Attrs i ind (getText tag) attrs
 118                  <> BS.fromChar '>'
 119                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 120                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 121                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 122                  <> BS.copyByteString (getUtf8ByteString close)
 123         go i ind attrs (CustomParent tag content) =
 124                 let i' = indentTag (t_ChoiceString tag) in
 125                 let t_tag = t_ChoiceString tag in
 126                 (if i==IndentTagChildren then ind else mempty)
 127                  <> BS.fromChar '<'
 128                  <> BS.fromText t_tag
 129                  <> bs_Attrs i ind t_tag attrs
 130                  <> BS.fromChar '>'
 131                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 132                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 133                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 134                  <> BS.fromByteString "</"
 135                  <> bs_ChoiceString tag
 136                  <> BS.fromChar '>'
 137         go i ind attrs (Leaf tag begin end _) =
 138                 (if i==IndentTagChildren then ind else mempty)
 139                  <> BS.copyByteString (getUtf8ByteString begin)
 140                  <> bs_Attrs i ind (getText tag) attrs
 141                  <> BS.copyByteString (getUtf8ByteString end)
 142         go i ind attrs (CustomLeaf tag close _) =
 143                 let t_tag = t_ChoiceString tag in
 144                 (if i==IndentTagChildren then ind else mempty)
 145                  <> BS.fromChar '<'
 146                  <> BS.fromText t_tag
 147                  <> bs_Attrs i ind t_tag attrs
 148                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 149         go i ind attrs (AddAttribute _ key value m) =
 150                 go i ind
 151                  (  BS.copyByteString (getUtf8ByteString key)
 152                  <> bs_ChoiceString value
 153                  <> BS.fromChar '"'
 154                  : attrs ) m
 155         go i ind attrs (AddCustomAttribute key value m) =
 156                 go i ind
 157                  (  BS.fromChar ' '
 158                  <> bs_ChoiceString key
 159                  <> BS.fromByteString "=\""
 160                  <> bs_ChoiceString value
 161                  <> BS.fromChar '"'
 162                  : attrs ) m
 163         go i ind _attrs (Content content _) =
 164                 if i/=IndentTagPreserve
 165                 then indentChoiceString ind content
 166                 else bs_ChoiceString content
 167         go i ind _attrs (Comment comment _) =
 168                 (if i==IndentTagChildren then ind else mempty)
 169                  <> BS.fromByteString "<!--"
 170                  <> (if i==IndentTagChildren
 171                         then indentChoiceString ind
 172                         else bs_ChoiceString
 173                  ) comment
 174                  <> BS.fromByteString "-->"
 175         go i ind attrs (Append m1 m2) =
 176                 go i ind attrs m1 <>
 177                 go i ind attrs m2
 178         go _i _ind _attrs (Empty _) = mempty
 179         {-# NOINLINE go #-}
 180
 181 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 182 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 183 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 184
 185 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 186 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 187
 188 bs_ChoiceString :: ChoiceString -> Builder
 189 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 190
 191 t_ChoiceString :: ChoiceString -> Text
 192 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 193
 194 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 195 indentText :: Builder -> Text -> Builder
 196 indentText ind =
 197         mconcat .
 198         List.intersperse ind .
 199         (BS.fromHtmlEscapedText <$>) .
 200         Text.splitOn "\n"
 201
 202 -- | Render an indented 'ChoiceString'.
 203 indentChoiceString :: Builder -> ChoiceString -> Builder
 204 indentChoiceString ind (Static s)     = indentText ind $ getText s
 205 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 206 indentChoiceString ind (Text s)       = indentText ind s
 207 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 208 indentChoiceString ind (PreEscaped x) = case x of
 209          String s -> indentText ind $ Text.pack s
 210          Text   s -> indentText ind s
 211          s        -> indentChoiceString ind s
 212 indentChoiceString ind (External x) = case x of
 213          -- Check that the sequence "</" is *not* in the external data.
 214          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 215          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 216          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 217          s            -> indentChoiceString ind s
 218 indentChoiceString ind (AppendChoiceString x y) =
 219         indentChoiceString ind x <>
 220         indentChoiceString ind y
 221 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 222 {-# INLINE indentChoiceString #-}