Text/Blaze/Utils.hs

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