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