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