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.Functor.Compose (Compose(..))
  16 import Data.Int (Int)
  17 import Data.Maybe (Maybe(..), maybe)
  18 import Data.Monoid (Monoid(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.String (IsString(..))
  21 import Data.Text (Text)
  22 import Prelude (Num(..), undefined)
  23 import System.IO (IO)
  24 import Text.Blaze as B
  25 import Text.Blaze.Internal as B hiding (null)
  26 import Text.Show (Show(..))
  27 import qualified Blaze.ByteString.Builder as BS
  28 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
  29 import qualified Control.Monad.Trans.State as S
  30 import qualified Data.ByteString as BS
  31 import qualified Data.ByteString.Lazy as BSL
  32 import qualified Data.List as List
  33 import qualified Data.Text as Text
  34 import qualified Data.Text.Lazy as TL
  35 import qualified Data.Text.Encoding as BS
  36 import qualified Text.Blaze.Html5 as H
  37 import qualified Text.Blaze.Renderer.Utf8 as BS
  38
  39 -- | 'Attribute' in 'Maybe'.
  40 infixl 1 !??
  41 (!??) :: Attributable h => h -> Maybe Attribute -> h
  42 (!??) h = maybe h (h !)
  43
  44 whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
  45 whenMarkup Empty{} _b = return ()
  46 whenMarkup _a b = b
  47
  48 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
  49 whenJust Nothing _f = pure ()
  50 whenJust (Just a) f = f a
  51
  52 whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
  53 whenSome x _f | null x = pure ()
  54 whenSome x f = f x
  55
  56 whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
  57 whenText "" _f = pure ()
  58 whenText t f = f t
  59
  60 instance Semigroup H.AttributeValue where
  61         (<>) = mappend
  62
  63 -- * Class 'AttrValue'
  64 class AttrValue a where
  65         attrValue :: a -> H.AttributeValue
  66 instance AttrValue Char where
  67         attrValue = fromString . pure
  68 instance AttrValue Text where
  69         attrValue = fromString . Text.unpack
  70 instance AttrValue TL.Text where
  71         attrValue = fromString . TL.unpack
  72 instance AttrValue Int where
  73         attrValue = fromString . show
  74 instance AttrValue [Char] where
  75         attrValue = fromString
  76
  77 -- * Class 'MayAttr'
  78 class MayAttr a where
  79         mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
  80 instance MayAttr a => MayAttr (Maybe a) where
  81         mayAttr a t = t >>= mayAttr a
  82 instance MayAttr Text where
  83         mayAttr _ "" = Nothing
  84         mayAttr a t  = Just (a $ fromString $ Text.unpack t)
  85 instance MayAttr Int where
  86         mayAttr a t  = Just (a $ fromString $ show t)
  87 instance MayAttr [Char] where
  88         mayAttr _ "" = Nothing
  89         mayAttr a t  = Just (a $ fromString t)
  90 instance MayAttr AttributeValue where
  91         mayAttr a = Just . a
  92
  93 -- * Type 'StateMarkup'
  94 -- | Composing state and markups.
  95 type StateMarkup st = Compose (S.State st) B.MarkupM
  96 instance Monad (StateMarkup st) where
  97         return = pure
  98         Compose sma >>= a2csmb =
  99                 Compose $ sma >>= \ma ->
 100                         case ma >>= B.Empty . a2csmb of
 101                          B.Append _ma (B.Empty csmb) ->
 102                                 B.Append ma <$> getCompose csmb
 103                          _ -> undefined
 104 instance IsString (StateMarkup st ()) where
 105         fromString = Compose . return . fromString
 106
 107 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
 108 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
 109 ($$) f m = Compose $ f <$> getCompose m
 110 infixr 0 $$
 111
 112 liftStateMarkup :: S.State st a -> StateMarkup st a
 113 liftStateMarkup = Compose . (return <$>)
 114
 115 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
 116 runStateMarkup st = (`S.runState` st) . getCompose
 117
 118 -- * Type 'IndentTag'
 119 data IndentTag
 120  =   IndentTagChildren
 121  |   IndentTagText
 122  |   IndentTagPreserve
 123  deriving (Eq,Show)
 124
 125 -- | Render some 'Markup' to a 'Builder'.
 126 --
 127 -- An 'IndentTag' is queried on each tag
 128 -- to indent tags differently according to their names.
 129 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
 130 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
 131         where
 132         inc :: Builder
 133         inc = "  "
 134         bs_Attrs i ind t_tag attrs =
 135                 case {-List.reverse-} attrs of
 136                  [] -> mempty
 137                  [a] -> a
 138                  a0:as ->
 139                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
 140                         let ind_attr =
 141                                 case i of
 142                                  IndentTagChildren -> ind<>ind_key
 143                                  IndentTagPreserve -> mempty
 144                                  IndentTagText -> mempty in
 145                         a0 <> foldMap (ind_attr <>) as
 146         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
 147         go i ind attrs (Parent tag open close content) =
 148                 let i' = indentTag (getText tag) in
 149                 (if i==IndentTagChildren then ind else mempty)
 150                  <> BS.copyByteString (getUtf8ByteString open)
 151                  <> bs_Attrs i ind (getText tag) attrs
 152                  <> BS.fromChar '>'
 153                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 154                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 155                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 156                  <> BS.copyByteString (getUtf8ByteString close)
 157         go i ind attrs (CustomParent tag content) =
 158                 let i' = indentTag (t_ChoiceString tag) in
 159                 let t_tag = t_ChoiceString tag in
 160                 (if i==IndentTagChildren then ind else mempty)
 161                  <> BS.fromChar '<'
 162                  <> BS.fromText t_tag
 163                  <> bs_Attrs i ind t_tag attrs
 164                  <> BS.fromChar '>'
 165                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 166                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 167                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 168                  <> BS.fromByteString "</"
 169                  <> bs_ChoiceString tag
 170                  <> BS.fromChar '>'
 171         go i ind attrs (Leaf tag begin end _) =
 172                 (if i==IndentTagChildren then ind else mempty)
 173                  <> BS.copyByteString (getUtf8ByteString begin)
 174                  <> bs_Attrs i ind (getText tag) attrs
 175                  <> BS.copyByteString (getUtf8ByteString end)
 176         go i ind attrs (CustomLeaf tag close _) =
 177                 let t_tag = t_ChoiceString tag in
 178                 (if i==IndentTagChildren then ind else mempty)
 179                  <> BS.fromChar '<'
 180                  <> BS.fromText t_tag
 181                  <> bs_Attrs i ind t_tag attrs
 182                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 183         go i ind attrs (AddAttribute _ key value m) =
 184                 go i ind
 185                  (  BS.copyByteString (getUtf8ByteString key)
 186                  <> bs_ChoiceString value
 187                  <> BS.fromChar '"'
 188                  : attrs ) m
 189         go i ind attrs (AddCustomAttribute key value m) =
 190                 go i ind
 191                  (  BS.fromChar ' '
 192                  <> bs_ChoiceString key
 193                  <> BS.fromByteString "=\""
 194                  <> bs_ChoiceString value
 195                  <> BS.fromChar '"'
 196                  : attrs ) m
 197         go i ind _attrs (Content content _) =
 198                 if i/=IndentTagPreserve
 199                 then indentChoiceString ind content
 200                 else bs_ChoiceString content
 201         go i ind _attrs (Comment comment _) =
 202                 (if i==IndentTagChildren then ind else mempty)
 203                  <> BS.fromByteString "<!--"
 204                  <> (if i==IndentTagChildren
 205                         then indentChoiceString ind
 206                         else bs_ChoiceString
 207                  ) comment
 208                  <> BS.fromByteString "-->"
 209         go i ind attrs (Append m1 m2) =
 210                 go i ind attrs m1 <>
 211                 go i ind attrs m2
 212         go _i _ind _attrs (Empty _) = mempty
 213         {-# NOINLINE go #-}
 214
 215 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 216 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 217 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 218
 219 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 220 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 221
 222 bs_ChoiceString :: ChoiceString -> Builder
 223 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 224
 225 t_ChoiceString :: ChoiceString -> Text
 226 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 227
 228 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 229 indentText :: Builder -> Text -> Builder
 230 indentText ind =
 231         mconcat .
 232         List.intersperse ind .
 233         (BS.fromHtmlEscapedText <$>) .
 234         Text.splitOn "\n"
 235
 236 -- | Render an indented 'ChoiceString'.
 237 indentChoiceString :: Builder -> ChoiceString -> Builder
 238 indentChoiceString ind (Static s)     = indentText ind $ getText s
 239 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 240 indentChoiceString ind (Text s)       = indentText ind s
 241 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 242 indentChoiceString ind (PreEscaped x) = case x of
 243          String s -> indentText ind $ Text.pack s
 244          Text   s -> indentText ind s
 245          s        -> indentChoiceString ind s
 246 indentChoiceString ind (External x) = case x of
 247          -- Check that the sequence "</" is *not* in the external data.
 248          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 249          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 250          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 251          s            -> indentChoiceString ind s
 252 indentChoiceString ind (AppendChoiceString x y) =
 253         indentChoiceString ind x <>
 254         indentChoiceString ind y
 255 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 256 {-# INLINE indentChoiceString #-}