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.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function ((.), ($))
  15 import Data.Functor ((<$>))
  16 import Data.Functor.Compose (Compose(..))
  17 import Data.Int (Int)
  18 import Data.Maybe (Maybe(..), maybe)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.String (IsString(..))
  22 import Data.Text (Text)
  23 import GHC.Exts (IsList(..))
  24 import Prelude (Num(..), undefined)
  25 import System.IO (IO)
  26 import Text.Blaze as B
  27 import Text.Blaze.Internal as B hiding (null)
  28 import Text.Show (Show(..))
  29 import qualified Blaze.ByteString.Builder as BS
  30 import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
  31 import qualified Control.Monad.Trans.State as S
  32 import qualified Data.ByteString as BS
  33 import qualified Data.ByteString.Lazy as BSL
  34 import qualified Data.List as List
  35 import qualified Data.Text as Text
  36 import qualified Data.Text.Lazy as TL
  37 import qualified Data.Text.Encoding as BS
  38 import qualified Text.Blaze.Html5 as H
  39 import qualified Text.Blaze.Renderer.Utf8 as BS
  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 'StateMarkup'
 105 -- | Composing state and markups.
 106 type StateMarkup st = Compose (S.State st) B.MarkupM
 107 instance Semigroup (StateMarkup st a) where
 108         (<>) = (>>)
 109 instance Monoid (StateMarkup st ()) where
 110         mempty  = pure ()
 111         mappend = (<>)
 112 instance Monad (StateMarkup st) where
 113         return = pure
 114         Compose sma >>= a2csmb =
 115                 Compose $ sma >>= \ma ->
 116                         case ma >>= B.Empty . a2csmb of
 117                          B.Append _ma (B.Empty csmb) ->
 118                                 B.Append ma <$> getCompose csmb
 119                          _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
 120 {- NOTE: the 'st' may need to use the 'String', so no such instance.
 121 instance IsString (StateMarkup st ()) where
 122         fromString = Compose . return . fromString
 123 -}
 124
 125 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
 126 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
 127 ($$) f m = Compose $ f <$> getCompose m
 128 infixr 0 $$
 129
 130 liftStateMarkup :: S.State st a -> StateMarkup st a
 131 liftStateMarkup = Compose . (return <$>)
 132
 133 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
 134 runStateMarkup st = (`S.runState` st) . getCompose
 135
 136 -- * Type 'IndentTag'
 137 data IndentTag
 138  =   IndentTagChildren
 139  |   IndentTagText
 140  |   IndentTagPreserve
 141  deriving (Eq,Show)
 142
 143 -- | Render some 'Markup' to a 'Builder'.
 144 --
 145 -- An 'IndentTag' is queried on each tag
 146 -- to indent tags differently according to their names.
 147 prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
 148 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
 149         where
 150         inc :: Builder
 151         inc = "  "
 152         bs_Attrs i ind t_tag attrs =
 153                 case {-List.reverse-} attrs of
 154                  [] -> mempty
 155                  [a] -> a
 156                  a0:as ->
 157                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
 158                         let ind_attr =
 159                                 case i of
 160                                  IndentTagChildren -> ind<>ind_key
 161                                  IndentTagPreserve -> mempty
 162                                  IndentTagText -> mempty in
 163                         a0 <> foldMap (ind_attr <>) as
 164         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
 165         go i ind attrs (Parent tag open close content) =
 166                 let i' = indentTag (getText tag) in
 167                 (if i==IndentTagChildren then ind else mempty)
 168                  <> BS.copyByteString (getUtf8ByteString open)
 169                  <> bs_Attrs i ind (getText tag) attrs
 170                  <> BS.fromChar '>'
 171                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 172                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 173                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 174                  <> BS.copyByteString (getUtf8ByteString close)
 175         go i ind attrs (CustomParent tag content) =
 176                 let i' = indentTag (t_ChoiceString tag) in
 177                 let t_tag = t_ChoiceString tag in
 178                 (if i==IndentTagChildren then ind else mempty)
 179                  <> BS.fromChar '<'
 180                  <> BS.fromText t_tag
 181                  <> bs_Attrs i ind t_tag attrs
 182                  <> BS.fromChar '>'
 183                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 184                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 185                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 186                  <> BS.fromByteString "</"
 187                  <> bs_ChoiceString tag
 188                  <> BS.fromChar '>'
 189         go i ind attrs (Leaf tag begin end _) =
 190                 (if i==IndentTagChildren then ind else mempty)
 191                  <> BS.copyByteString (getUtf8ByteString begin)
 192                  <> bs_Attrs i ind (getText tag) attrs
 193                  <> BS.copyByteString (getUtf8ByteString end)
 194         go i ind attrs (CustomLeaf tag close _) =
 195                 let t_tag = t_ChoiceString tag in
 196                 (if i==IndentTagChildren then ind else mempty)
 197                  <> BS.fromChar '<'
 198                  <> BS.fromText t_tag
 199                  <> bs_Attrs i ind t_tag attrs
 200                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 201         go i ind attrs (AddAttribute _ key value m) =
 202                 go i ind
 203                  (  BS.copyByteString (getUtf8ByteString key)
 204                  <> bs_ChoiceString value
 205                  <> BS.fromChar '"'
 206                  : attrs ) m
 207         go i ind attrs (AddCustomAttribute key value m) =
 208                 go i ind
 209                  (  BS.fromChar ' '
 210                  <> bs_ChoiceString key
 211                  <> BS.fromByteString "=\""
 212                  <> bs_ChoiceString value
 213                  <> BS.fromChar '"'
 214                  : attrs ) m
 215         go i ind _attrs (Content content _) =
 216                 if i/=IndentTagPreserve
 217                 then indentChoiceString ind content
 218                 else bs_ChoiceString content
 219         go i ind _attrs (Comment comment _) =
 220                 (if i==IndentTagChildren then ind else mempty)
 221                  <> BS.fromByteString "<!--"
 222                  <> (if i==IndentTagChildren
 223                         then indentChoiceString ind
 224                         else bs_ChoiceString
 225                  ) comment
 226                  <> BS.fromByteString "-->"
 227         go i ind attrs (Append m1 m2) =
 228                 go i ind attrs m1 <>
 229                 go i ind attrs m2
 230         go _i _ind _attrs (Empty _) = mempty
 231         {-# NOINLINE go #-}
 232
 233 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 234 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 235 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 236
 237 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 238 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 239
 240 bs_ChoiceString :: ChoiceString -> Builder
 241 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 242
 243 t_ChoiceString :: ChoiceString -> Text
 244 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 245
 246 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 247 indentText :: Builder -> Text -> Builder
 248 indentText ind =
 249         mconcat .
 250         List.intersperse ind .
 251         (BS.fromHtmlEscapedText <$>) .
 252         Text.splitOn "\n"
 253
 254 -- | Render an indented 'ChoiceString'.
 255 indentChoiceString :: Builder -> ChoiceString -> Builder
 256 indentChoiceString ind (Static s)     = indentText ind $ getText s
 257 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 258 indentChoiceString ind (Text s)       = indentText ind s
 259 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 260 indentChoiceString ind (PreEscaped x) = case x of
 261          String s -> indentText ind $ Text.pack s
 262          Text   s -> indentText ind s
 263          s        -> indentChoiceString ind s
 264 indentChoiceString ind (External x) = case x of
 265          -- Check that the sequence "</" is *not* in the external data.
 266          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 267          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 268          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 269          s            -> indentChoiceString ind s
 270 indentChoiceString ind (AppendChoiceString x y) =
 271         indentChoiceString ind x <>
 272         indentChoiceString ind y
 273 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 274 {-# INLINE indentChoiceString #-}