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