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.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 GHC.Exts (IsList(..))
  23 import Prelude (Num(..), undefined)
  24 import System.IO (IO)
  25 import Text.Blaze as B
  26 import Text.Blaze.Internal as B hiding (null)
  27 import Text.Show (Show(..))
  28 import qualified Blaze.ByteString.Builder as BS
  29 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
  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 Data.Text.Lazy as TL
  36 import qualified Text.Blaze.Html5 as H
  37 import qualified Text.Blaze.Renderer.Utf8 as BS
  38
  39 import Control.Monad.Utils
  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 {-
  63 instance Semigroup H.AttributeValue where
  64         (<>) = mappend
  65 -}
  66 instance IsList H.AttributeValue where
  67         type Item AttributeValue = AttributeValue
  68         fromList = mconcat . List.intersperse " "
  69         toList   = pure
  70
  71 -- * Class 'Attrify'
  72 class Attrify a where
  73         attrify :: a -> H.AttributeValue
  74 instance Attrify Char where
  75         attrify = fromString . pure
  76 instance Attrify Text where
  77         attrify = fromString . Text.unpack
  78 instance Attrify TL.Text where
  79         attrify = fromString . TL.unpack
  80 instance Attrify Int where
  81         attrify = fromString . show
  82 instance Attrify [Char] where
  83         attrify = fromString
  84
  85 -- * Class 'MayAttr'
  86 class MayAttr a where
  87         mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
  88 instance MayAttr a => MayAttr (Maybe a) where
  89         mayAttr a t = t >>= mayAttr a
  90 instance MayAttr Text where
  91         mayAttr _ "" = Nothing
  92         mayAttr a t  = Just (a $ fromString $ Text.unpack t)
  93 instance MayAttr TL.Text where
  94         mayAttr _ "" = Nothing
  95         mayAttr a t  = Just (a $ fromString $ TL.unpack t)
  96 instance MayAttr Int where
  97         mayAttr a t  = Just (a $ fromString $ show t)
  98 instance MayAttr [Char] where
  99         mayAttr _ "" = Nothing
 100         mayAttr a t  = Just (a $ fromString t)
 101 instance MayAttr AttributeValue where
 102         mayAttr a = Just . a
 103
 104 -- * Type 'ComposeState'
 105 instance Semigroup (ComposeState st B.MarkupM a) where
 106         (<>) = (>>)
 107 instance Monoid (ComposeState st B.MarkupM ()) where
 108         mempty  = pure ()
 109         mappend = (<>)
 110 instance Monad (ComposeState st B.MarkupM) where
 111         return = pure
 112         Compose sma >>= a2csmb =
 113                 Compose $ sma >>= \ma ->
 114                         case ma >>= B.Empty . a2csmb of
 115                          B.Append _ma (B.Empty csmb) ->
 116                                 B.Append ma <$> getCompose csmb
 117                          _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
 118
 119 -- * Type 'ComposeRWS'
 120 instance Monoid w => Semigroup (ComposeRWS r w s B.MarkupM a) where
 121         (<>) = (>>)
 122 instance Monoid w => Monoid (ComposeRWS r w s B.MarkupM ()) where
 123         mempty  = pure ()
 124         mappend = (<>)
 125 instance Monoid w => Monad (ComposeRWS r w s B.MarkupM) where
 126         return = pure
 127         Compose sma >>= a2csmb =
 128                 Compose $ sma >>= \ma ->
 129                         case ma >>= B.Empty . a2csmb of
 130                          B.Append _ma (B.Empty csmb) ->
 131                                 B.Append ma <$> getCompose csmb
 132                          _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
 133
 134 -- | Render some 'Markup' to a 'Builder'.
 135 --
 136 -- An 'IndentTag' is queried on each tag
 137 -- to indent tags differently according to their names.
 138 prettyMarkupBuilder :: (Text -> Bool) -> Markup -> Builder
 139 prettyMarkupBuilder isInlinedElement ms = go (noIndent "" ms) "\n" mempty ms
 140         where
 141         inc :: Builder
 142         inc = "  "
 143         noIndent :: Text -> MarkupM b -> Bool
 144         noIndent e children =
 145                 isInlinedElement e ||
 146                 allInlined children && not (allComment children)
 147                 where
 148                 allInlined :: MarkupM b -> Bool
 149                 allInlined = \case
 150                  Append x y -> allInlined x && allInlined y
 151                  CustomParent tag _m              -> isInlinedElement $ t_ChoiceString tag
 152                  CustomLeaf tag _close _          -> isInlinedElement $ t_ChoiceString tag
 153                  Parent tag _open _close _m       -> isInlinedElement $ getText tag
 154                  Leaf tag _begin _end _           -> isInlinedElement $ getText tag
 155                  AddAttribute _ _key _value m     -> allInlined m
 156                  AddCustomAttribute _key _value m -> allInlined m
 157                  Comment{} -> True
 158                  Content{} -> True
 159                  Empty{} -> True
 160                 allComment :: MarkupM b -> Bool
 161                 allComment = \case
 162                  Append x y -> allComment x && allComment y
 163                  AddAttribute _ _key _value m     -> allComment m
 164                  AddCustomAttribute _key _value m -> allComment m
 165                  Comment{} -> True
 166                  Empty{} -> True
 167                  _ -> False
 168         goAttrs :: Bool -> Builder -> Text -> [Builder] -> Builder
 169         goAttrs noInd ind t_tag attrs =
 170                 case attrs of
 171                  [] -> mempty
 172                  [a] -> a
 173                  a0:as ->
 174                         let ind_key = BS.fromString $ List.replicate (Text.length t_tag + 1) ' ' in
 175                         let ind_attr = if noInd then mempty else ind<>ind_key in
 176                         a0 <> foldMap (ind_attr <>) as
 177         go :: Bool -> Builder -> [Builder] -> MarkupM b -> Builder
 178         go noInd ind attrs = \case
 179          Parent tag open close content ->
 180                 let noInd' = noIndent (getText tag) content in
 181                 (if noInd then mempty else ind)
 182                  <> BS.copyByteString (getUtf8ByteString open)
 183                  <> goAttrs noInd ind (getText tag) attrs
 184                  <> BS.fromChar '>'
 185                  <> go noInd' (if noInd then ind else ind<>inc) mempty content
 186                  <> (if noInd' then mempty else ind)
 187                  <> BS.copyByteString (getUtf8ByteString close)
 188          CustomParent tag content ->
 189                 let t_tag  = t_ChoiceString tag in
 190                 let noInd' = noIndent t_tag content in
 191                 (if noInd then mempty else ind)
 192                  <> BS.fromChar '<'
 193                  <> BS.fromText t_tag
 194                  <> goAttrs noInd ind t_tag attrs
 195                  <> BS.fromChar '>'
 196                  <> go noInd' (if noInd' then ind else ind<>inc) mempty content
 197                  <> (if noInd' then mempty else ind)
 198                  <> BS.fromByteString "</"
 199                  <> bs_ChoiceString tag
 200                  <> BS.fromChar '>'
 201          Leaf tag begin end _ ->
 202                 (if noInd then mempty else ind)
 203                  <> BS.copyByteString (getUtf8ByteString begin)
 204                  <> goAttrs noInd ind (getText tag) attrs
 205                  <> BS.copyByteString (getUtf8ByteString end)
 206          CustomLeaf tag close _ ->
 207                 let t_tag = t_ChoiceString tag in
 208                 (if noInd then mempty else ind)
 209                  <> BS.fromChar '<'
 210                  <> BS.fromText t_tag
 211                  <> goAttrs noInd ind t_tag attrs
 212                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 213          AddAttribute _ key value m ->
 214                 go noInd ind
 215                  (  BS.copyByteString (getUtf8ByteString key)
 216                  <> bs_ChoiceString value
 217                  <> BS.fromChar '"'
 218                  : attrs ) m
 219          AddCustomAttribute key value m ->
 220                 go noInd ind
 221                  (  BS.fromChar ' '
 222                  <> bs_ChoiceString key
 223                  <> BS.fromByteString "=\""
 224                  <> bs_ChoiceString value
 225                  <> BS.fromChar '"'
 226                  : attrs ) m
 227          Content c _ -> bs_ChoiceString c
 228          Comment comment _ ->
 229                 (if noInd then mempty else ind)
 230                  <> BS.fromByteString "<!--"
 231                  <> indentChoiceString (ind <> "    ") comment
 232                  <> (if noInd then mempty else ind)
 233                  <> BS.fromByteString "-->"
 234          Append m1 m2 ->
 235                 go noInd ind attrs m1 <>
 236                 go noInd ind attrs m2
 237          Empty _ -> mempty
 238
 239 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 240 prettyMarkup :: (Text -> Bool) -> Markup -> BSL.ByteString
 241 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 242
 243 prettyMarkupIO :: (Text -> Bool) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 244 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 245
 246 bs_ChoiceString :: ChoiceString -> Builder
 247 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 248
 249 t_ChoiceString :: ChoiceString -> Text
 250 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 251
 252 -- | @indentText ind txt@ indent 'txt' with 'ind' at newlines.
 253 indentText :: Builder -> Text -> Builder
 254 indentText ind =
 255         mconcat .
 256         List.intersperse ind .
 257         (BS.fromHtmlEscapedText <$>) .
 258         Text.splitOn "\n"
 259
 260 -- | Render an indented 'ChoiceString'.
 261 indentChoiceString :: Builder -> ChoiceString -> Builder
 262 indentChoiceString ind (Static s)     = indentText ind $ getText s
 263 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 264 indentChoiceString ind (Text s)       = indentText ind s
 265 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 266 indentChoiceString ind (PreEscaped x) = case x of
 267          String s -> indentText ind $ Text.pack s
 268          Text   s -> indentText ind s
 269          s        -> indentChoiceString ind s
 270 indentChoiceString ind (External x) = case x of
 271          -- Check that the sequence "</" is *not* in the external data.
 272          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 273          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 274          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 275          s            -> indentChoiceString ind s
 276 indentChoiceString ind (AppendChoiceString x y) =
 277         indentChoiceString ind x <>
 278         indentChoiceString ind y
 279 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 280 {-# INLINE indentChoiceString #-}