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