src/Text/BlazeT/Internal.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 {-# LANGUAGE CPP #-}
   6 #if MIN_VERSION_blaze_markup(0,7,1)
   7 #define PRE_BUILDER
   8 #endif
   9 module Text.BlazeT.Internal
  10     (
  11       -- * Important types.
  12       B.ChoiceString (..)
  13     , B.StaticString (..)
  14     , MarkupM
  15     , Markup
  16     , B.Tag
  17     , B.Attribute
  18     , B.AttributeValue
  19
  20       -- * Creating custom tags and attributes.
  21     , customParent
  22     , customLeaf
  23     , B.attribute
  24     , B.dataAttribute
  25     , B.customAttribute
  26
  27       -- * Converting values to Markup.
  28     , text
  29     , preEscapedText
  30     , lazyText
  31     , preEscapedLazyText
  32     , textBuilder
  33     , preEscapedTextBuilder
  34     , string
  35     , preEscapedString
  36     , unsafeByteString
  37     , unsafeLazyByteString
  38
  39       -- * Comments
  40     , B.textComment
  41     , B.lazyTextComment
  42     , B.stringComment
  43     , B.unsafeByteStringComment
  44     , B.unsafeLazyByteStringComment
  45
  46       -- * Converting values to tags.
  47     , B.textTag
  48     , B.stringTag
  49
  50       -- * Converting values to attribute values.
  51     , B.textValue
  52     , B.preEscapedTextValue
  53     , B.lazyTextValue
  54     , B.preEscapedLazyTextValue
  55     , B.textBuilderValue
  56     , B.preEscapedTextBuilderValue
  57     , B.stringValue
  58     , B.preEscapedStringValue
  59     , B.unsafeByteStringValue
  60     , B.unsafeLazyByteStringValue
  61
  62       -- * Setting attributes
  63     , B.Attributable
  64     , (B.!)
  65     , (B.!?)
  66
  67       -- * Modifying Markup elements
  68     , contents
  69     , external
  70
  71       -- * Querying Markup elements
  72     , null
  73
  74     -- * BlazeT new stuff
  75     ,Markup2
  76     ,mapMarkupT
  77     ,MarkupT
  78     ,runMarkup
  79     ,runMarkupT
  80     ,execMarkup
  81     ,execMarkupT
  82     ,wrapMarkup
  83     ,wrapMarkupT
  84     ,wrapMarkup2
  85     ,wrapMarkupT2
  86   ) where
  87
  88 import           Control.Monad.Identity
  89 import           Control.Monad.Trans.Class
  90 import           Control.Monad.Writer.Strict
  91 import qualified Data.ByteString as BS
  92 import qualified Data.ByteString.Lazy as BL
  93 import           Data.String
  94 import qualified Data.Text as T
  95 import qualified Data.Text.Lazy as LT
  96 import qualified Data.Text.Lazy.Builder as LTB
  97 import qualified Text.Blaze as B
  98 import qualified Text.Blaze.Internal as B
  99
 100 newtype MarkupT m a= MarkupT { fromMarkupT :: WriterT B.Markup m a }
 101                      deriving (Functor
 102 #if MIN_VERSION_base(4,8,0)
 103                               ,Applicative
 104 #endif
 105                               ,Monad
 106                               ,MonadWriter B.Markup
 107                               ,MonadTrans
 108                               )
 109
 110 -- | Map both the return value and markup of a computation using the
 111 -- given function
 112 mapMarkupT :: (m (a,B.Markup) -> n (b,B.Markup)) -> MarkupT m a -> MarkupT n b
 113 mapMarkupT f = MarkupT . mapWriterT f . fromMarkupT
 114 {-# INLINE mapMarkupT #-}
 115
 116 type MarkupM = MarkupT Identity
 117 type Markup = forall m . Monad m => MarkupT m ()
 118 type Markup2 = forall m . Monad m => MarkupT m () -> MarkupT m ()
 119
 120 runMarkupT :: MarkupT m a -> m (a,B.Markup)
 121 runMarkupT = runWriterT . fromMarkupT
 122 {-# INLINE runMarkupT #-}
 123
 124 execMarkupT :: Monad m => MarkupT m a -> m B.Markup
 125 execMarkupT = liftM snd . runMarkupT
 126 {-# INLINE execMarkupT #-}
 127
 128 runMarkup :: MarkupM a -> (a,B.Markup)
 129 runMarkup = runIdentity . runMarkupT
 130 {-# INLINE runMarkup #-}
 131
 132 execMarkup :: MarkupM a -> B.Markup
 133 execMarkup = snd . runMarkup
 134 {-# INLINE execMarkup #-}
 135
 136 -- instance MonadTrans MarkupT where
 137
 138
 139 instance (Monad m,Monoid a) => Monoid (MarkupT m a) where
 140   mempty = return mempty
 141   {-# INLINE mempty #-}
 142   a `mappend` b = do {a' <- a; b >>= return . (mappend a')}
 143   {-# INLINE mappend #-}
 144
 145
 146 instance Monad m => B.Attributable (MarkupT m a) where
 147   h ! a = wrapMarkupT2 (B.! a) h
 148   {-# INLINE (!) #-}
 149
 150 instance Monad m => B.Attributable (a -> MarkupT m b) where
 151   h ! a = \x -> wrapMarkupT2 (B.! a) $ h x
 152   {-# INLINE (!) #-}
 153
 154 instance Monad m => IsString (MarkupT m ()) where
 155   fromString = wrapMarkup . fromString
 156   {-# INLINE fromString #-}
 157
 158 wrapMarkupT :: Monad m => B.Markup -> MarkupT m ()
 159 wrapMarkupT = tell
 160 {-# INLINE wrapMarkupT #-}
 161
 162 wrapMarkup :: B.Markup -> Markup
 163 wrapMarkup = wrapMarkupT
 164 {-# INLINE wrapMarkup #-}
 165
 166 wrapMarkupT2 ::  Monad m => (B.Markup -> B.Markup)
 167                  -> MarkupT m a -> MarkupT m a
 168 wrapMarkupT2 = censor
 169 {-# INLINE wrapMarkupT2 #-}
 170
 171 wrapMarkup2 :: (B.Markup -> B.Markup) -> Markup2
 172 wrapMarkup2 = wrapMarkupT2
 173 {-# INLINE wrapMarkup2 #-}
 174
 175 unsafeByteString :: BS.ByteString -> Markup
 176 unsafeByteString = wrapMarkup . B.unsafeByteString
 177 {-# INLINE unsafeByteString #-}
 178
 179 -- | Insert a lazy 'BL.ByteString'. See 'unsafeByteString' for reasons why this
 180 -- is an unsafe operation.
 181 --
 182 unsafeLazyByteString :: BL.ByteString  -- ^ Value to insert
 183                      -> Markup         -- ^ Resulting HTML fragment
 184 unsafeLazyByteString = wrapMarkup . B.unsafeLazyByteString
 185 {-# INLINE unsafeLazyByteString #-}
 186
 187 external :: Monad m => MarkupT m a -> MarkupT m a
 188 external = wrapMarkupT2  B.external
 189 {-# INLINE external #-}
 190
 191 contents :: Monad m => MarkupT m a -> MarkupT m a
 192 contents = wrapMarkupT2  B.contents
 193 {-# INLINE contents #-}
 194
 195 customParent ::B.Tag -> Markup2
 196 customParent = wrapMarkup2 . B.customParent
 197 {-# INLINE customParent #-}
 198
 199 customLeaf :: B.Tag -> Bool -> Markup
 200 customLeaf = fmap wrapMarkup . B.customLeaf
 201 {-# INLINE customLeaf #-}
 202
 203 preEscapedText :: T.Text -> Markup
 204 preEscapedText = wrapMarkup . B.preEscapedText
 205 {-# INLINE preEscapedText #-}
 206
 207 preEscapedLazyText :: LT.Text -> Markup
 208 preEscapedLazyText = wrapMarkup . B.preEscapedLazyText
 209 {-# INLINE preEscapedLazyText #-}
 210
 211 preEscapedTextBuilder :: LTB.Builder -> Markup
 212 textBuilder :: LTB.Builder -> Markup
 213
 214 #ifdef PRE_BUILDER
 215 preEscapedTextBuilder = wrapMarkup . B.preEscapedTextBuilder
 216 textBuilder = wrapMarkup . B.textBuilder
 217 {-# INLINE preEscapedTextBuilder #-}
 218 {-# INLINE textBuilder #-}
 219 #else
 220 preEscapedTextBuilder = error "This function needs blaze-markup 0.7.1.0"
 221 textBuilder = error "This function needs blaze-markup 0.7.1.0"
 222 #endif
 223
 224 preEscapedString :: String -> Markup
 225 preEscapedString = wrapMarkup . B.preEscapedString
 226 {-# INLINE preEscapedString #-}
 227
 228 string :: String -> Markup
 229 string = wrapMarkup . B.string
 230 {-# INLINE string #-}
 231
 232 text :: T.Text -> Markup
 233 text = wrapMarkup . B.text
 234 {-# INLINE text #-}
 235
 236 lazyText :: LT.Text -> Markup
 237 lazyText = wrapMarkup . B.lazyText
 238 {-# INLINE lazyText #-}