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