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
  91 -- * Type 'StateMarkup'
  92 -- | Composing state and markups.
  93 type StateMarkup st = Compose (S.State st) B.MarkupM
  94 instance Monad (StateMarkup st) where
  95         return = pure
  96         Compose sma >>= a2csmb =
  97                 Compose $ sma >>= \ma ->
  98                         case ma >>= B.Empty . a2csmb of
  99                          B.Append _ma (B.Empty csmb) ->
 100                                 B.Append ma <$> getCompose csmb
 101                          _ -> undefined
 102 instance IsString (StateMarkup st ()) where
 103         fromString = Compose . return . fromString
 104
 105 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
 106 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
 107 ($$) f m = Compose $ f <$> getCompose m
 108 infixr 0 $$
 109
 110 liftStateMarkup :: S.State st a -> StateMarkup st a
 111 liftStateMarkup = Compose . (return <$>)
 112
 113 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
 114 runStateMarkup st = (`S.runState` st) . getCompose
 115
 116 local :: Monad m => (s -> s) -> S.StateT s m b -> S.StateT s m b
 117 local f a = do
 118         s <- S.get
 119         S.put (f s)
 120         r <- a
 121         S.put s
 122         return r
 123
 124 -- * Type 'IndentTag'
 125 data IndentTag
 126  =   IndentTagChildren
 127  |   IndentTagText
 128  |   IndentTagPreserve
 129  deriving (Eq,Show)
 130
 131 -- | Render some 'Markup' to a 'Builder'.
 132 --
 133 -- An 'IndentTag' is queried on each tag
 134 -- to indent tags differently according to their names.
 135 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
 136 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
 137         where
 138         inc :: Builder
 139         inc = "  "
 140         bs_Attrs i ind t_tag attrs =
 141                 case {-List.reverse-} attrs of
 142                  [] -> mempty
 143                  [a] -> a
 144                  a0:as ->
 145                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
 146                         let ind_attr =
 147                                 case i of
 148                                  IndentTagChildren -> ind<>ind_key
 149                                  IndentTagPreserve -> mempty
 150                                  IndentTagText -> mempty in
 151                         a0 <> foldMap (ind_attr <>) as
 152         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
 153         go i ind attrs (Parent tag open close content) =
 154                 let i' = indentTag (getText tag) in
 155                 (if i==IndentTagChildren then ind else mempty)
 156                  <> BS.copyByteString (getUtf8ByteString open)
 157                  <> bs_Attrs i ind (getText tag) attrs
 158                  <> BS.fromChar '>'
 159                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 160                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 161                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 162                  <> BS.copyByteString (getUtf8ByteString close)
 163         go i ind attrs (CustomParent tag content) =
 164                 let i' = indentTag (t_ChoiceString tag) in
 165                 let t_tag = t_ChoiceString tag in
 166                 (if i==IndentTagChildren then ind else mempty)
 167                  <> BS.fromChar '<'
 168                  <> BS.fromText t_tag
 169                  <> bs_Attrs i ind t_tag attrs
 170                  <> BS.fromChar '>'
 171                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 172                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 173                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 174                  <> BS.fromByteString "</"
 175                  <> bs_ChoiceString tag
 176                  <> BS.fromChar '>'
 177         go i ind attrs (Leaf tag begin end _) =
 178                 (if i==IndentTagChildren then ind else mempty)
 179                  <> BS.copyByteString (getUtf8ByteString begin)
 180                  <> bs_Attrs i ind (getText tag) attrs
 181                  <> BS.copyByteString (getUtf8ByteString end)
 182         go i ind attrs (CustomLeaf tag close _) =
 183                 let t_tag = t_ChoiceString tag in
 184                 (if i==IndentTagChildren then ind else mempty)
 185                  <> BS.fromChar '<'
 186                  <> BS.fromText t_tag
 187                  <> bs_Attrs i ind t_tag attrs
 188                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 189         go i ind attrs (AddAttribute _ key value m) =
 190                 go i ind
 191                  (  BS.copyByteString (getUtf8ByteString key)
 192                  <> bs_ChoiceString value
 193                  <> BS.fromChar '"'
 194                  : attrs ) m
 195         go i ind attrs (AddCustomAttribute key value m) =
 196                 go i ind
 197                  (  BS.fromChar ' '
 198                  <> bs_ChoiceString key
 199                  <> BS.fromByteString "=\""
 200                  <> bs_ChoiceString value
 201                  <> BS.fromChar '"'
 202                  : attrs ) m
 203         go i ind _attrs (Content content _) =
 204                 if i/=IndentTagPreserve
 205                 then indentChoiceString ind content
 206                 else bs_ChoiceString content
 207         go i ind _attrs (Comment comment _) =
 208                 (if i==IndentTagChildren then ind else mempty)
 209                  <> BS.fromByteString "<!--"
 210                  <> (if i==IndentTagChildren
 211                         then indentChoiceString ind
 212                         else bs_ChoiceString
 213                  ) comment
 214                  <> BS.fromByteString "-->"
 215         go i ind attrs (Append m1 m2) =
 216                 go i ind attrs m1 <>
 217                 go i ind attrs m2
 218         go _i _ind _attrs (Empty _) = mempty
 219         {-# NOINLINE go #-}
 220
 221 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 222 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 223 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 224
 225 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 226 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 227
 228 bs_ChoiceString :: ChoiceString -> Builder
 229 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 230
 231 t_ChoiceString :: ChoiceString -> Text
 232 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 233
 234 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 235 indentText :: Builder -> Text -> Builder
 236 indentText ind =
 237         mconcat .
 238         List.intersperse ind .
 239         (BS.fromHtmlEscapedText <$>) .
 240         Text.splitOn "\n"
 241
 242 -- | Render an indented 'ChoiceString'.
 243 indentChoiceString :: Builder -> ChoiceString -> Builder
 244 indentChoiceString ind (Static s)     = indentText ind $ getText s
 245 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 246 indentChoiceString ind (Text s)       = indentText ind s
 247 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 248 indentChoiceString ind (PreEscaped x) = case x of
 249          String s -> indentText ind $ Text.pack s
 250          Text   s -> indentText ind s
 251          s        -> indentChoiceString ind s
 252 indentChoiceString ind (External x) = case x of
 253          -- Check that the sequence "</" is *not* in the external data.
 254          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 255          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 256          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 257          s            -> indentChoiceString ind s
 258 indentChoiceString ind (AppendChoiceString x y) =
 259         indentChoiceString ind x <>
 260         indentChoiceString ind y
 261 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 262 {-# INLINE indentChoiceString #-}