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