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