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