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 instance Semigroup H.AttributeValue where
  63         (<>) = mappend
  64 instance IsList H.AttributeValue where
  65         type Item AttributeValue = AttributeValue
  66         fromList = mconcat . List.intersperse " "
  67         toList   = pure
  68
  69 -- * Class 'Attrify'
  70 class Attrify a where
  71         attrify :: a -> H.AttributeValue
  72 instance Attrify Char where
  73         attrify = fromString . pure
  74 instance Attrify Text where
  75         attrify = fromString . Text.unpack
  76 instance Attrify TL.Text where
  77         attrify = fromString . TL.unpack
  78 instance Attrify Int where
  79         attrify = fromString . show
  80 instance Attrify [Char] where
  81         attrify = fromString
  82
  83 -- * Class 'MayAttr'
  84 class MayAttr a where
  85         mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
  86 instance MayAttr a => MayAttr (Maybe a) where
  87         mayAttr a t = t >>= mayAttr a
  88 instance MayAttr Text where
  89         mayAttr _ "" = Nothing
  90         mayAttr a t  = Just (a $ fromString $ Text.unpack t)
  91 instance MayAttr Int where
  92         mayAttr a t  = Just (a $ fromString $ show t)
  93 instance MayAttr [Char] where
  94         mayAttr _ "" = Nothing
  95         mayAttr a t  = Just (a $ fromString t)
  96 instance MayAttr AttributeValue where
  97         mayAttr a = Just . a
  98
  99 -- * Type 'StateMarkup'
 100 -- | Composing state and markups.
 101 type StateMarkup st = Compose (S.State st) B.MarkupM
 102 instance Semigroup (StateMarkup st a) where
 103         (<>) = (>>)
 104 instance Monoid (StateMarkup st ()) where
 105         mempty  = pure ()
 106         mappend = (<>)
 107 instance Monad (StateMarkup st) where
 108         return = pure
 109         Compose sma >>= a2csmb =
 110                 Compose $ sma >>= \ma ->
 111                         case ma >>= B.Empty . a2csmb of
 112                          B.Append _ma (B.Empty csmb) ->
 113                                 B.Append ma <$> getCompose csmb
 114                          _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
 115 {- NOTE: the 'st' may need to use the 'String', so no such instance.
 116 instance IsString (StateMarkup st ()) where
 117         fromString = Compose . return . fromString
 118 -}
 119
 120 -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
 121 ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
 122 ($$) f m = Compose $ f <$> getCompose m
 123 infixr 0 $$
 124
 125 liftStateMarkup :: S.State st a -> StateMarkup st a
 126 liftStateMarkup = Compose . (return <$>)
 127
 128 runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
 129 runStateMarkup st = (`S.runState` st) . getCompose
 130
 131 -- * Type 'IndentTag'
 132 data IndentTag
 133  =   IndentTagChildren
 134  |   IndentTagText
 135  |   IndentTagPreserve
 136  deriving (Eq,Show)
 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 -> IndentTag) -> Markup -> Builder
 143 prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
 144         where
 145         inc :: Builder
 146         inc = "  "
 147         bs_Attrs i ind t_tag attrs =
 148                 case {-List.reverse-} attrs of
 149                  [] -> mempty
 150                  [a] -> a
 151                  a0:as ->
 152                         let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
 153                         let ind_attr =
 154                                 case i of
 155                                  IndentTagChildren -> ind<>ind_key
 156                                  IndentTagPreserve -> mempty
 157                                  IndentTagText -> mempty in
 158                         a0 <> foldMap (ind_attr <>) as
 159         go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
 160         go i ind attrs (Parent tag open close content) =
 161                 let i' = indentTag (getText tag) in
 162                 (if i==IndentTagChildren then ind else mempty)
 163                  <> BS.copyByteString (getUtf8ByteString open)
 164                  <> bs_Attrs i ind (getText tag) attrs
 165                  <> BS.fromChar '>'
 166                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 167                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 168                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 169                  <> BS.copyByteString (getUtf8ByteString close)
 170         go i ind attrs (CustomParent tag content) =
 171                 let i' = indentTag (t_ChoiceString tag) in
 172                 let t_tag = t_ChoiceString tag in
 173                 (if i==IndentTagChildren then ind else mempty)
 174                  <> BS.fromChar '<'
 175                  <> BS.fromText t_tag
 176                  <> bs_Attrs i ind t_tag attrs
 177                  <> BS.fromChar '>'
 178                  <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
 179                  <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
 180                  <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
 181                  <> BS.fromByteString "</"
 182                  <> bs_ChoiceString tag
 183                  <> BS.fromChar '>'
 184         go i ind attrs (Leaf tag begin end _) =
 185                 (if i==IndentTagChildren then ind else mempty)
 186                  <> BS.copyByteString (getUtf8ByteString begin)
 187                  <> bs_Attrs i ind (getText tag) attrs
 188                  <> BS.copyByteString (getUtf8ByteString end)
 189         go i ind attrs (CustomLeaf tag close _) =
 190                 let t_tag = t_ChoiceString tag in
 191                 (if i==IndentTagChildren then ind else mempty)
 192                  <> BS.fromChar '<'
 193                  <> BS.fromText t_tag
 194                  <> bs_Attrs i ind t_tag attrs
 195                  <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
 196         go i ind attrs (AddAttribute _ key value m) =
 197                 go i ind
 198                  (  BS.copyByteString (getUtf8ByteString key)
 199                  <> bs_ChoiceString value
 200                  <> BS.fromChar '"'
 201                  : attrs ) m
 202         go i ind attrs (AddCustomAttribute key value m) =
 203                 go i ind
 204                  (  BS.fromChar ' '
 205                  <> bs_ChoiceString key
 206                  <> BS.fromByteString "=\""
 207                  <> bs_ChoiceString value
 208                  <> BS.fromChar '"'
 209                  : attrs ) m
 210         go i ind _attrs (Content content _) =
 211                 if i/=IndentTagPreserve
 212                 then indentChoiceString ind content
 213                 else bs_ChoiceString content
 214         go i ind _attrs (Comment comment _) =
 215                 (if i==IndentTagChildren then ind else mempty)
 216                  <> BS.fromByteString "<!--"
 217                  <> (if i==IndentTagChildren
 218                         then indentChoiceString ind
 219                         else bs_ChoiceString
 220                  ) comment
 221                  <> BS.fromByteString "-->"
 222         go i ind attrs (Append m1 m2) =
 223                 go i ind attrs m1 <>
 224                 go i ind attrs m2
 225         go _i _ind _attrs (Empty _) = mempty
 226         {-# NOINLINE go #-}
 227
 228 -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
 229 prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
 230 prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
 231
 232 prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
 233 prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
 234
 235 bs_ChoiceString :: ChoiceString -> Builder
 236 bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())
 237
 238 t_ChoiceString :: ChoiceString -> Text
 239 t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
 240
 241 -- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
 242 indentText :: Builder -> Text -> Builder
 243 indentText ind =
 244         mconcat .
 245         List.intersperse ind .
 246         (BS.fromHtmlEscapedText <$>) .
 247         Text.splitOn "\n"
 248
 249 -- | Render an indented 'ChoiceString'.
 250 indentChoiceString :: Builder -> ChoiceString -> Builder
 251 indentChoiceString ind (Static s)     = indentText ind $ getText s
 252 indentChoiceString ind (String s)     = indentText ind $ Text.pack s
 253 indentChoiceString ind (Text s)       = indentText ind s
 254 indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
 255 indentChoiceString ind (PreEscaped x) = case x of
 256          String s -> indentText ind $ Text.pack s
 257          Text   s -> indentText ind s
 258          s        -> indentChoiceString ind s
 259 indentChoiceString ind (External x) = case x of
 260          -- Check that the sequence "</" is *not* in the external data.
 261          String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
 262          Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
 263          ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
 264          s            -> indentChoiceString ind s
 265 indentChoiceString ind (AppendChoiceString x y) =
 266         indentChoiceString ind x <>
 267         indentChoiceString ind y
 268 indentChoiceString ind EmptyChoiceString = indentText ind mempty
 269 {-# INLINE indentChoiceString #-}