{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- Search for UndecidableInstances to see why this is needed
{-# LANGUAGE UndecidableInstances #-}

-- | Base types and combinators.

module Lucid.Base
  (-- * Rendering
   renderText
  ,renderBS
  ,renderTextT
  ,renderBST
  ,renderToFile
   -- * Running
  ,execHtmlT
  ,evalHtmlT
  ,runHtmlT
  ,relaxHtmlT
  ,commuteHtmlT
  -- * Combinators
  ,makeElement
  ,makeElementNoEnd
  ,makeXmlElementNoEnd
  ,makeAttribute
   -- * Types
  ,Html
  ,HtmlT(HtmlT)
  ,Attribute(..)
   -- * Classes
  ,Term(..)
  ,TermRaw(..)
  ,ToHtml(..)
  ,With(..))
  where

import           Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Morph (MFunctor(..))
import           Control.Monad.Reader (MonadReader(..))
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Fix (MonadFix(..))
import           Control.Monad.Trans (MonadTrans(..))
import           Control.Monad.Error.Class (MonadError(..))
import           Control.Monad.State.Class (MonadState(..))
import           Control.Monad.Writer.Class (MonadWriter(..))
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import           Data.Functor.Identity
import qualified Data.Map.Strict as M
import           Data.Hashable (Hashable(..))
import           Data.Semigroup (Semigroup (..))
import           Data.Monoid (Monoid (..))
import           Data.String
import           Data.Text (Text)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Encoding as T
import           Data.Typeable (Typeable)
import           Prelude
import           Data.Maybe
import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import           Data.Foldable (toList)
import qualified Data.Set as Set

--------------------------------------------------------------------------------
-- Types

-- | A simple attribute. Don't use the constructor, use
-- 'makeAttribute'.  Attributes are case sensitive, so if you want
-- attributes to be merged properly, use a single case representation.
data Attribute = Attribute !Text !Text
  deriving (Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show,Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq,Typeable)

instance Hashable Attribute where
  hashWithSalt :: Int -> Attribute -> Int
hashWithSalt Int
salt (Attribute Text
a Text
b) = Int
salt Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
a Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
b

-- | Simple HTML builder type. Defined in terms of 'HtmlT'. Check out
-- that type for instance information.
--
-- Simple use-cases will just use this type. But if you want to
-- transformer over Reader or something, you can go and use 'HtmlT'.
type Html = HtmlT Identity

-- | A monad transformer that generates HTML. Use the simpler 'Html'
-- type if you don't want to transform over some other monad.
--
-- Don't rely on the internal representation of this type. Use the
-- monad and functor classes.
newtype HtmlT m a =
  HtmlT {HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT :: m (Seq Attribute -> Builder,a)
         -- ^ This is the low-level way to run the HTML transformer,
         -- finally returning an element builder and a value. You can
         -- pass 'mempty' for this argument for a top-level call. See
         -- 'evalHtmlT' and 'execHtmlT' for easier to use functions.
         }
-- GHC 7.4 errors with
--  Can't make a derived instance of `Typeable (HtmlT m a)':
--    `HtmlT' must only have arguments of kind `*'
-- GHC 7.6 errors with
--    `HtmlT' must only have arguments of kind `*'
#if  __GLASGOW_HASKELL__ >= 707
  deriving (Typeable)
#endif

-- | @since 2.9.5
instance MFunctor HtmlT where
  hoist :: (forall a. m a -> n a) -> HtmlT m b -> HtmlT n b
hoist forall a. m a -> n a
f (HtmlT m (Seq Attribute -> Builder, b)
xs) = n (Seq Attribute -> Builder, b) -> HtmlT n b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> n (Seq Attribute -> Builder, b)
forall a. m a -> n a
f m (Seq Attribute -> Builder, b)
xs)

-- | @since 2.9.7
instance (a ~ (),Applicative m) => Semigroup (HtmlT m a) where
  <> :: HtmlT m a -> HtmlT m a -> HtmlT m a
(<>) = (a -> a -> a) -> HtmlT m a -> HtmlT m a -> HtmlT m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Monoid is right-associative, a la the 'Builder' in it.
instance (a ~ (),Applicative m) => Monoid (HtmlT m a) where
  mempty :: HtmlT m a
mempty  = a -> HtmlT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
  mappend :: HtmlT m a -> HtmlT m a -> HtmlT m a
mappend = (a -> a -> a) -> HtmlT m a -> HtmlT m a -> HtmlT m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

-- | Based on the monad instance.
instance Applicative m => Applicative (HtmlT m) where
  pure :: a -> HtmlT m a
pure a
a = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, a) -> m (Seq Attribute -> Builder, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Attribute -> Builder
forall a. Monoid a => a
mempty,a
a))
  {-# INLINE pure #-}

  HtmlT m (a -> b)
f <*> :: HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
<*> HtmlT m a
x = m (Seq Attribute -> Builder, b) -> HtmlT m b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> HtmlT m b)
-> m (Seq Attribute -> Builder, b) -> HtmlT m b
forall a b. (a -> b) -> a -> b
$ (Seq Attribute -> Builder, a -> b)
-> (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, b)
forall a t b. Semigroup a => (a, t -> b) -> (a, t) -> (a, b)
mk ((Seq Attribute -> Builder, a -> b)
 -> (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, b))
-> m (Seq Attribute -> Builder, a -> b)
-> m ((Seq Attribute -> Builder, a)
      -> (Seq Attribute -> Builder, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m (a -> b) -> m (Seq Attribute -> Builder, a -> b)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m (a -> b)
f m ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, b))
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
x
    where mk :: (a, t -> b) -> (a, t) -> (a, b)
mk ~(a
g, t -> b
f') ~(a
h, t
x') = (a
g a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
h, t -> b
f' t
x')
  {-# INLINE (<*>) #-}

  HtmlT m a
m *> :: HtmlT m a -> HtmlT m b -> HtmlT m b
*> HtmlT m b
n = m (Seq Attribute -> Builder, b) -> HtmlT m b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> HtmlT m b)
-> m (Seq Attribute -> Builder, b) -> HtmlT m b
forall a b. (a -> b) -> a -> b
$ (Seq Attribute -> Builder, a)
-> (Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, b)
forall a b b. Semigroup a => (a, b) -> (a, b) -> (a, b)
mk ((Seq Attribute -> Builder, a)
 -> (Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, b))
-> m (Seq Attribute -> Builder, a)
-> m ((Seq Attribute -> Builder, b)
      -> (Seq Attribute -> Builder, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m m ((Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, b))
-> m (Seq Attribute -> Builder, b)
-> m (Seq Attribute -> Builder, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HtmlT m b -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m b
n
    where mk :: (a, b) -> (a, b) -> (a, b)
mk ~(a
g, b
_) ~(a
h, b
b) = (a
g a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
h, b
b)
  {-# INLINE (*>) #-}

  HtmlT m a
m <* :: HtmlT m a -> HtmlT m b -> HtmlT m a
<* HtmlT m b
n = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, a) -> HtmlT m a)
-> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall a b. (a -> b) -> a -> b
$ (Seq Attribute -> Builder, a)
-> (Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, a)
forall a b b. Semigroup a => (a, b) -> (a, b) -> (a, b)
mk ((Seq Attribute -> Builder, a)
 -> (Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
-> m ((Seq Attribute -> Builder, b)
      -> (Seq Attribute -> Builder, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m m ((Seq Attribute -> Builder, b) -> (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, b)
-> m (Seq Attribute -> Builder, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HtmlT m b -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m b
n
    where mk :: (a, b) -> (a, b) -> (a, b)
mk ~(a
g, b
a) ~(a
h, b
_) = (a
g a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
h, b
a)
  {-# INLINE (<*) #-}

-- | Just re-uses Monad.
instance Functor m => Functor (HtmlT m) where
  fmap :: (a -> b) -> HtmlT m a -> HtmlT m b
fmap a -> b
f = m (Seq Attribute -> Builder, b) -> HtmlT m b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> HtmlT m b)
-> (HtmlT m a -> m (Seq Attribute -> Builder, b))
-> HtmlT m a
-> HtmlT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, b))
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b)
-> (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (m (Seq Attribute -> Builder, a)
 -> m (Seq Attribute -> Builder, b))
-> (HtmlT m a -> m (Seq Attribute -> Builder, a))
-> HtmlT m a
-> m (Seq Attribute -> Builder, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT

  <$ :: a -> HtmlT m b -> HtmlT m a
(<$) = (b -> a) -> HtmlT m b -> HtmlT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> a) -> HtmlT m b -> HtmlT m a)
-> (a -> b -> a) -> a -> HtmlT m b -> HtmlT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> a
forall a b. a -> b -> a
const
  {-# INLINE (<$) #-}

-- | Basically acts like Writer.
instance Monad m => Monad (HtmlT m) where
  return :: a -> HtmlT m a
return a
a = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, a) -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
forall a. Monoid a => a
mempty,a
a))
  {-# INLINE return #-}

  HtmlT m a
m >>= :: HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
>>= a -> HtmlT m b
f = m (Seq Attribute -> Builder, b) -> HtmlT m b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> HtmlT m b)
-> m (Seq Attribute -> Builder, b) -> HtmlT m b
forall a b. (a -> b) -> a -> b
$ do
    ~(Seq Attribute -> Builder
g,a
a) <- HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
    ~(Seq Attribute -> Builder
h,b
b) <- HtmlT m b -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT (a -> HtmlT m b
f a
a)
    (Seq Attribute -> Builder, b) -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
g (Seq Attribute -> Builder)
-> (Seq Attribute -> Builder) -> Seq Attribute -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
h,b
b)
  {-# INLINE (>>=) #-}

  HtmlT m a
m >> :: HtmlT m a -> HtmlT m b -> HtmlT m b
>> HtmlT m b
n = m (Seq Attribute -> Builder, b) -> HtmlT m b
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, b) -> HtmlT m b)
-> m (Seq Attribute -> Builder, b) -> HtmlT m b
forall a b. (a -> b) -> a -> b
$ do
    ~(Seq Attribute -> Builder
g, a
_) <- HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
    ~(Seq Attribute -> Builder
h, b
b) <- HtmlT m b -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m b
n
    (Seq Attribute -> Builder, b) -> m (Seq Attribute -> Builder, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
g (Seq Attribute -> Builder)
-> (Seq Attribute -> Builder) -> Seq Attribute -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
h, b
b)
  {-# INLINE (>>) #-}

-- | Used for 'lift'.
instance MonadTrans HtmlT where
  lift :: m a -> HtmlT m a
lift m a
m =
    m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (do a
a <- m a
m
              (Seq Attribute -> Builder, a) -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (\Seq Attribute
_ -> Builder
forall a. Monoid a => a
mempty,a
a))

instance MonadFix m => MonadFix (HtmlT m) where
  mfix :: (a -> HtmlT m a) -> HtmlT m a
mfix a -> HtmlT m a
m = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, a) -> HtmlT m a)
-> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall a b. (a -> b) -> a -> b
$ ((Seq Attribute -> Builder, a) -> m (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((Seq Attribute -> Builder, a) -> m (Seq Attribute -> Builder, a))
 -> m (Seq Attribute -> Builder, a))
-> ((Seq Attribute -> Builder, a)
    -> m (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
forall a b. (a -> b) -> a -> b
$ \ ~(Seq Attribute -> Builder
_, a
a) -> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT (HtmlT m a -> m (Seq Attribute -> Builder, a))
-> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall a b. (a -> b) -> a -> b
$ a -> HtmlT m a
m a
a

-- MonadReader, MonadState etc instances need UndecidableInstances,
-- because they do not satisfy the coverage condition.

-- | @since 2.9.7
instance MonadReader r m => MonadReader r (HtmlT m) where
  ask :: HtmlT m r
ask = m r -> HtmlT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> HtmlT m a -> HtmlT m a
local r -> r
f (HtmlT m (Seq Attribute -> Builder, a)
a) = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((r -> r)
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, a)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f m (Seq Attribute -> Builder, a)
a)

-- | @since 2.9.7
instance MonadState s m => MonadState s (HtmlT m) where
  get :: HtmlT m s
get = m s -> HtmlT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> HtmlT m ()
put = m () -> HtmlT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HtmlT m ()) -> (s -> m ()) -> s -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: (s -> (a, s)) -> HtmlT m a
state = m a -> HtmlT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HtmlT m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> HtmlT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

-- | @since 2.9.9
instance MonadError e m => MonadError e (HtmlT m) where
    throwError :: e -> HtmlT m a
throwError = m a -> HtmlT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HtmlT m a) -> (e -> m a) -> e -> HtmlT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    catchError :: HtmlT m a -> (e -> HtmlT m a) -> HtmlT m a
catchError (HtmlT m (Seq Attribute -> Builder, a)
m) e -> HtmlT m a
h = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, a) -> HtmlT m a)
-> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall a b. (a -> b) -> a -> b
$ m (Seq Attribute -> Builder, a)
-> (e -> m (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m (Seq Attribute -> Builder, a)
m (HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT (HtmlT m a -> m (Seq Attribute -> Builder, a))
-> (e -> HtmlT m a) -> e -> m (Seq Attribute -> Builder, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> HtmlT m a
h)

-- | @since 2.9.9
instance MonadWriter w m => MonadWriter w (HtmlT m) where
    tell :: w -> HtmlT m ()
tell             = m () -> HtmlT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HtmlT m ()) -> (w -> m ()) -> w -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    listen :: HtmlT m a -> HtmlT m (a, w)
listen (HtmlT m (Seq Attribute -> Builder, a)
x) = m (Seq Attribute -> Builder, (a, w)) -> HtmlT m (a, w)
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, (a, w)) -> HtmlT m (a, w))
-> m (Seq Attribute -> Builder, (a, w)) -> HtmlT m (a, w)
forall a b. (a -> b) -> a -> b
$ (((Seq Attribute -> Builder, a), w)
 -> (Seq Attribute -> Builder, (a, w)))
-> m ((Seq Attribute -> Builder, a), w)
-> m (Seq Attribute -> Builder, (a, w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Seq Attribute -> Builder, a), w)
-> (Seq Attribute -> Builder, (a, w))
forall a a b. ((a, a), b) -> (a, (a, b))
reassoc (m ((Seq Attribute -> Builder, a), w)
 -> m (Seq Attribute -> Builder, (a, w)))
-> m ((Seq Attribute -> Builder, a), w)
-> m (Seq Attribute -> Builder, (a, w))
forall a b. (a -> b) -> a -> b
$ m (Seq Attribute -> Builder, a)
-> m ((Seq Attribute -> Builder, a), w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (Seq Attribute -> Builder, a)
x
      where reassoc :: ((a, a), b) -> (a, (a, b))
reassoc ((a
a, a
b), b
c) = (a
a, (a
b, b
c))
    pass :: HtmlT m (a, w -> w) -> HtmlT m a
pass (HtmlT m (Seq Attribute -> Builder, (a, w -> w))
p)   = m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (m (Seq Attribute -> Builder, a) -> HtmlT m a)
-> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall a b. (a -> b) -> a -> b
$ m ((Seq Attribute -> Builder, a), w -> w)
-> m (Seq Attribute -> Builder, a)
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m ((Seq Attribute -> Builder, a), w -> w)
 -> m (Seq Attribute -> Builder, a))
-> m ((Seq Attribute -> Builder, a), w -> w)
-> m (Seq Attribute -> Builder, a)
forall a b. (a -> b) -> a -> b
$ ((Seq Attribute -> Builder, (a, w -> w))
 -> ((Seq Attribute -> Builder, a), w -> w))
-> m (Seq Attribute -> Builder, (a, w -> w))
-> m ((Seq Attribute -> Builder, a), w -> w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq Attribute -> Builder, (a, w -> w))
-> ((Seq Attribute -> Builder, a), w -> w)
forall a b b. (a, (b, b)) -> ((a, b), b)
assoc m (Seq Attribute -> Builder, (a, w -> w))
p
      where assoc :: (a, (b, b)) -> ((a, b), b)
assoc (a
a, (b
b, b
c)) = ((a
a, b
b), b
c)

-- | If you want to use IO in your HTML generation.
instance MonadIO m => MonadIO (HtmlT m) where
  liftIO :: IO a -> HtmlT m a
liftIO = m a -> HtmlT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HtmlT m a) -> (IO a -> m a) -> IO a -> HtmlT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | We pack it via string. Could possibly encode straight into a
-- builder. That might be faster.
instance (Monad m,a ~ ()) => IsString (HtmlT m a) where
  fromString :: String -> HtmlT m a
fromString = String -> HtmlT m a
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml

-- | Just calls 'renderText'.
instance (m ~ Identity) => Show (HtmlT m a) where
  show :: HtmlT m a -> String
show = Text -> String
LT.unpack (Text -> String) -> (Html a -> Text) -> Html a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Text
forall a. Html a -> Text
renderText

-- | Can be converted to HTML.
class ToHtml a where
  -- | Convert to HTML, doing HTML escaping.
  toHtml :: Monad m => a -> HtmlT m ()
  -- | Convert to HTML without any escaping.
  toHtmlRaw :: Monad m => a -> HtmlT m ()

-- | @since 2.9.8
instance (a ~ (), m ~ Identity) => ToHtml (HtmlT m a) where
  toHtml :: HtmlT m a -> HtmlT m ()
toHtml = HtmlT m a -> HtmlT m ()
forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT
  toHtmlRaw :: HtmlT m a -> HtmlT m ()
toHtmlRaw = HtmlT m a -> HtmlT m ()
forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT

instance ToHtml String where
  toHtml :: String -> HtmlT m ()
toHtml    = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (String -> Builder) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
Blaze.fromHtmlEscapedString
  toHtmlRaw :: String -> HtmlT m ()
toHtmlRaw = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (String -> Builder) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
Blaze.fromString

instance ToHtml Text where
  toHtml :: Text -> HtmlT m ()
toHtml    = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ()) -> (Text -> Builder) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedText
  toHtmlRaw :: Text -> HtmlT m ()
toHtmlRaw = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ()) -> (Text -> Builder) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromText

instance ToHtml LT.Text where
  toHtml :: Text -> HtmlT m ()
toHtml    = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ()) -> (Text -> Builder) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedLazyText
  toHtmlRaw :: Text -> HtmlT m ()
toHtmlRaw = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ()) -> (Text -> Builder) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromLazyText

-- | This instance requires the ByteString to contain UTF-8 encoded
-- text, for the 'toHtml' method. The 'toHtmlRaw' method doesn't care,
-- but the overall HTML rendering methods in this module assume UTF-8.
--
-- @since 2.9.5
instance ToHtml S.ByteString where
  toHtml :: ByteString -> HtmlT m ()
toHtml    = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (ByteString -> Builder) -> ByteString -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedText (Text -> Builder) -> (ByteString -> Text) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8
  toHtmlRaw :: ByteString -> HtmlT m ()
toHtmlRaw = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (ByteString -> Builder) -> ByteString -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.fromByteString

-- | This instance requires the ByteString to contain UTF-8 encoded
-- text, for the 'toHtml' method. The 'toHtmlRaw' method doesn't care,
-- but the overall HTML rendering methods in this module assume UTF-8.
--
-- @since 2.9.5
instance ToHtml L.ByteString where
  toHtml :: ByteString -> HtmlT m ()
toHtml    = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (ByteString -> Builder) -> ByteString -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedLazyText (Text -> Builder) -> (ByteString -> Text) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8
  toHtmlRaw :: ByteString -> HtmlT m ()
toHtmlRaw = Builder -> HtmlT m ()
forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build (Builder -> HtmlT m ())
-> (ByteString -> Builder) -> ByteString -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.fromLazyByteString

-- | Create an 'HtmlT' directly from a 'Builder'.
build :: Monad m => Builder -> HtmlT m ()
build :: Builder -> HtmlT m ()
build Builder
b = m (Seq Attribute -> Builder, ()) -> HtmlT m ()
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, ()) -> m (Seq Attribute -> Builder, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Seq Attribute -> Builder
forall a b. a -> b -> a
const Builder
b,()))
{-# INLINE build #-}

-- | Used to construct HTML terms.
--
-- Simplest use: p_ = term "p" yields 'Lucid.Html5.p_'.
--
-- Very overloaded for three cases:
--
-- * The first case is the basic @arg@ of @[(Text,Text)]@ which will
--   return a function that wants children.
-- * The second is an @arg@ which is @HtmlT m ()@, in which case the
--   term accepts no attributes and just the children are used for the
--   element.
-- * Finally, this is also used for overloaded attributes, like
--   `Lucid.Html5.style_` or `Lucid.Html5.title_`. If a return type of @(Text,Text)@ is inferred
--   then an attribute will be made.
--
-- The instances look intimidating but actually the constraints make
-- it very general so that type inference works well even in the
-- presence of things like @OverloadedLists@ and such.
class Term arg result | result -> arg where
  -- | Used for constructing elements e.g. @term "p"@ yields 'Lucid.Html5.p_'.
  term :: Text   -- ^ Name of the element or attribute.
       -> arg    -- ^ Either an attribute list or children.
       -> result -- ^ Result: either an element or an attribute.
  term = (Text -> [Attribute] -> arg -> result)
-> [Attribute] -> Text -> arg -> result
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [Attribute] -> arg -> result
forall arg result.
Term arg result =>
Text -> [Attribute] -> arg -> result
termWith []
  {-# INLINE term #-}

  -- | Use this if you want to make an element which inserts some
  -- pre-prepared attributes into the element.
  termWith :: Text          -- ^ Name.
           -> [Attribute]   -- ^ Attribute transformer.
           -> arg           -- ^ Some argument.
           -> result        -- ^ Result: either an element or an attribute.

-- | Given attributes, expect more child input.
instance (Applicative m,f ~ HtmlT m a) => Term [Attribute] (f -> HtmlT m a) where
  termWith :: Text -> [Attribute] -> [Attribute] -> f -> HtmlT m a
termWith Text
name [Attribute]
f = (HtmlT m a -> HtmlT m a) -> [Attribute] -> HtmlT m a -> HtmlT m a
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT m a -> HtmlT m a
forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) ([Attribute] -> HtmlT m a -> HtmlT m a)
-> ([Attribute] -> [Attribute])
-> [Attribute]
-> HtmlT m a
-> HtmlT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<> [Attribute]
f)

-- | Given children immediately, just use that and expect no
-- attributes.
instance (Applicative m) => Term (HtmlT m a) (HtmlT m a) where
  termWith :: Text -> [Attribute] -> HtmlT m a -> HtmlT m a
termWith Text
name [Attribute]
f = (HtmlT m a -> HtmlT m a) -> [Attribute] -> HtmlT m a -> HtmlT m a
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT m a -> HtmlT m a
forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) [Attribute]
f
  {-# INLINE termWith #-}

-- | Some terms (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for
-- attributes as well as elements.
instance Term Text Attribute where
  termWith :: Text -> [Attribute] -> Text -> Attribute
termWith Text
key [Attribute]
_ Text
value = Text -> Text -> Attribute
makeAttribute Text
key Text
value

-- | Same as the 'Term' class, but will not HTML escape its
-- children. Useful for elements like 'Lucid.Html5.style_' or
-- 'Lucid.Html5.script_'.
class TermRaw arg result | result -> arg where
  -- | Used for constructing elements e.g. @termRaw "p"@ yields 'Lucid.Html5.p_'.
  termRaw :: Text   -- ^ Name of the element or attribute.
       -> arg    -- ^ Either an attribute list or children.
       -> result -- ^ Result: either an element or an attribute.
  termRaw = (Text -> [Attribute] -> arg -> result)
-> [Attribute] -> Text -> arg -> result
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [Attribute] -> arg -> result
forall arg result.
TermRaw arg result =>
Text -> [Attribute] -> arg -> result
termRawWith []
  -- | Use this if you want to make an element which inserts some
  -- pre-prepared attributes into the element.
  termRawWith :: Text          -- ^ Name.
           -> [Attribute]   -- ^ Attribute transformer.
           -> arg           -- ^ Some argument.
           -> result        -- ^ Result: either an element or an attribute.

-- | Given attributes, expect more child input.
instance (Monad m,ToHtml f, a ~ ()) => TermRaw [Attribute] (f -> HtmlT m a) where
  termRawWith :: Text -> [Attribute] -> [Attribute] -> f -> HtmlT m a
termRawWith Text
name [Attribute]
f [Attribute]
attrs = (HtmlT m () -> HtmlT m ())
-> [Attribute] -> HtmlT m () -> HtmlT m ()
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT m () -> HtmlT m ()
forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) ([Attribute]
attrs [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<> [Attribute]
f) (HtmlT m () -> HtmlT m ()) -> (f -> HtmlT m ()) -> f -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw

-- | Given children immediately, just use that and expect no
-- attributes.
instance (Monad m,a ~ ()) => TermRaw Text (HtmlT m a) where
  termRawWith :: Text -> [Attribute] -> Text -> HtmlT m a
termRawWith Text
name [Attribute]
f = (HtmlT m () -> HtmlT m ())
-> [Attribute] -> HtmlT m () -> HtmlT m ()
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT m () -> HtmlT m ()
forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) [Attribute]
f (HtmlT m () -> HtmlT m ())
-> (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw

-- | Some termRaws (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for
-- attributes as well as elements.
instance TermRaw Text Attribute where
  termRawWith :: Text -> [Attribute] -> Text -> Attribute
termRawWith Text
key [Attribute]
_ Text
value = Text -> Text -> Attribute
makeAttribute Text
key Text
value

-- | With an element use these attributes. An overloaded way of adding
-- attributes either to an element accepting attributes-and-children
-- or one that just accepts attributes. See the two instances.
class With a  where
  -- | With the given element(s), use the given attributes.
  with :: a -- ^ Some element, either @Html a@ or @Html a -> Html a@.
       -> [Attribute]
       -> a

-- | For the contentless elements: 'Lucid.Html5.br_'
instance (Functor m) => With (HtmlT m a) where
  with :: HtmlT m a -> [Attribute] -> HtmlT m a
with HtmlT m a
f = \[Attribute]
attr -> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ([Attribute]
-> (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a)
forall a t b. [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [Attribute]
attr ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
f)
    where
      mk :: [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [a]
attr ~(Seq a -> t
f',b
a) = (\Seq a
attr' -> Seq a -> t
f' (Seq a
attr' Seq a -> Seq a -> Seq a
forall a. Semigroup a => a -> a -> a
<> [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList [a]
attr)
                        ,b
a)

-- | For the contentful elements: 'Lucid.Html5.div_'
instance (Functor m) => With (HtmlT m a -> HtmlT m a) where
  with :: (HtmlT m a -> HtmlT m a) -> [Attribute] -> HtmlT m a -> HtmlT m a
with HtmlT m a -> HtmlT m a
f = \[Attribute]
attr HtmlT m a
inner -> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ([Attribute]
-> (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a)
forall a t b. [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [Attribute]
attr ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT (HtmlT m a -> HtmlT m a
f HtmlT m a
inner))
    where
      mk :: [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [a]
attr ~(Seq a -> t
f',b
a) = (\Seq a
attr' -> Seq a -> t
f' (Seq a
attr' Seq a -> Seq a -> Seq a
forall a. Semigroup a => a -> a -> a
<> [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList [a]
attr)
                        ,b
a)

--------------------------------------------------------------------------------
-- Running

-- | Render the HTML to a lazy 'ByteString'.
--
-- This is a convenience function defined in terms of 'execHtmlT',
-- 'runIdentity' and 'Blaze.toLazyByteString'. Check the source if
-- you're interested in the lower-level behaviour.
--
renderToFile :: FilePath -> Html a -> IO ()
renderToFile :: String -> Html a -> IO ()
renderToFile String
fp = String -> ByteString -> IO ()
L.writeFile String
fp (ByteString -> IO ()) -> (Html a -> ByteString) -> Html a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString (Builder -> ByteString)
-> (Html a -> Builder) -> Html a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Html a -> Identity Builder) -> Html a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Identity Builder
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT

-- | Render the HTML to a lazy 'ByteString'.
--
-- This is a convenience function defined in terms of 'execHtmlT',
-- 'runIdentity' and 'Blaze.toLazyByteString'. Check the source if
-- you're interested in the lower-level behaviour.
--
renderBS :: Html a -> ByteString
renderBS :: Html a -> ByteString
renderBS = Builder -> ByteString
Blaze.toLazyByteString (Builder -> ByteString)
-> (Html a -> Builder) -> Html a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Html a -> Identity Builder) -> Html a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Identity Builder
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT

-- | Render the HTML to a lazy 'Text'.
--
-- This is a convenience function defined in terms of 'execHtmlT',
-- 'runIdentity' and 'Blaze.toLazyByteString', and
-- 'LT.decodeUtf8'. Check the source if you're interested in the
-- lower-level behaviour.
--
renderText :: Html a -> LT.Text
renderText :: Html a -> Text
renderText = ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> (Html a -> ByteString) -> Html a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString (Builder -> ByteString)
-> (Html a -> Builder) -> Html a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Html a -> Identity Builder) -> Html a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html a -> Identity Builder
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT

-- | Render the HTML to a lazy 'ByteString', but in a monad.
--
-- This is a convenience function defined in terms of 'execHtmlT' and
-- 'Blaze.toLazyByteString'. Check the source if you're interested in
-- the lower-level behaviour.
--
renderBST :: Monad m => HtmlT m a -> m ByteString
renderBST :: HtmlT m a -> m ByteString
renderBST = (Builder -> ByteString) -> m Builder -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> ByteString
Blaze.toLazyByteString (m Builder -> m ByteString)
-> (HtmlT m a -> m Builder) -> HtmlT m a -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlT m a -> m Builder
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT

-- | Render the HTML to a lazy 'Text', but in a monad.
--
-- This is a convenience function defined in terms of 'execHtmlT' and
-- 'Blaze.toLazyByteString', and 'LT.decodeUtf8'. Check the source if
-- you're interested in the lower-level behaviour.
--
renderTextT :: Monad m => HtmlT m a -> m LT.Text
renderTextT :: HtmlT m a -> m Text
renderTextT = (Builder -> Text) -> m Builder -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> (Builder -> ByteString) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString) (m Builder -> m Text)
-> (HtmlT m a -> m Builder) -> HtmlT m a -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlT m a -> m Builder
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT

--------------------------------------------------------------------------------
-- Running, transformer versions

-- | Build the HTML. Analogous to @execState@.
--
-- You might want to use this is if you want to do something with the
-- raw 'Builder'. Otherwise for simple cases you can just use
-- 'renderText' or 'renderBS'.
execHtmlT :: Monad m
          => HtmlT m a  -- ^ The HTML to generate.
          -> m Builder  -- ^ The @a@ is discarded.
execHtmlT :: HtmlT m a -> m Builder
execHtmlT HtmlT m a
m =
  do (Seq Attribute -> Builder
f,a
_) <- HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
     Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
f Seq Attribute
forall a. Monoid a => a
mempty)

-- | Generalize the underlying monad.
--
-- Some builders are happy to deliver results in a pure underlying
-- monad, here 'Identity', but have trouble maintaining the polymorphic
-- type. This utility generalizes from 'Identity'.
--
-- @since 2.9.6
relaxHtmlT :: Monad m
           => HtmlT Identity a  -- ^ The HTML generated purely.
           -> HtmlT m a         -- ^ Same HTML accessible in a polymorphic context.
relaxHtmlT :: HtmlT Identity a -> HtmlT m a
relaxHtmlT = (forall a. Identity a -> m a) -> HtmlT Identity a -> HtmlT m a
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. Identity a -> m a
forall (m :: * -> *) a. Monad m => Identity a -> m a
go
  where
    go :: Monad m => Identity a -> m a
    go :: Identity a -> m a
go = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Identity a -> a) -> Identity a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity

-- | Commute inner @m@ to the front.
--
-- This is useful when you have impure HTML generation, e.g. using `StateT`.
-- Recall, there is `MonadState s HtmlT` instance.
--
-- @
-- exampleHtml :: MonadState Int m => HtmlT m ()
-- exampleHtml = ul_ $ replicateM_ 5 $ do
--   x <- get
--   put (x + 1)
--   li_ $ toHtml $ show x
--
-- exampleHtml' :: Monad m => HtmlT m ()
-- exampleHtml' = evalState (commuteHtmlT exampleHtml) 1
-- @
--
-- @since 2.9.9
commuteHtmlT :: (Functor m, Monad n)
             => HtmlT m a      -- ^ unpurely generated HTML
             -> m (HtmlT n a)  -- ^ Commuted monads. /Note:/ @n@ can be 'Identity'
commuteHtmlT :: HtmlT m a -> m (HtmlT n a)
commuteHtmlT (HtmlT m (Seq Attribute -> Builder, a)
xs) = ((Seq Attribute -> Builder, a) -> HtmlT n a)
-> m (Seq Attribute -> Builder, a) -> m (HtmlT n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (n (Seq Attribute -> Builder, a) -> HtmlT n a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (n (Seq Attribute -> Builder, a) -> HtmlT n a)
-> ((Seq Attribute -> Builder, a)
    -> n (Seq Attribute -> Builder, a))
-> (Seq Attribute -> Builder, a)
-> HtmlT n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq Attribute -> Builder, a) -> n (Seq Attribute -> Builder, a)
forall (m :: * -> *) a. Monad m => a -> m a
return) m (Seq Attribute -> Builder, a)
xs

-- | Evaluate the HTML to its return value. Analogous to @evalState@.
--
-- Use this if you want to ignore the HTML output of an action
-- completely and just get the result.
--
-- For using with the 'Html' type, you'll need 'runIdentity' e.g.
--
-- >>> runIdentity (evalHtmlT (p_ "Hello!"))
-- ()
--
evalHtmlT :: Monad m
          => HtmlT m a -- ^ HTML monad to evaluate.
          -> m a       -- ^ Ignore the HTML output and just return the value.
evalHtmlT :: HtmlT m a -> m a
evalHtmlT HtmlT m a
m =
  do (Seq Attribute -> Builder
_,a
a) <- HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
     a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

--------------------------------------------------------------------------------
-- Combinators

-- | Make an attribute builder.
makeAttribute :: Text -- ^ Attribute name.
              -> Text -- ^ Attribute value.
              -> Attribute
makeAttribute :: Text -> Text -> Attribute
makeAttribute Text
x Text
y = Text -> Text -> Attribute
Attribute Text
x Text
y

-- | Make an HTML builder.
makeElement :: Functor m
            => Text       -- ^ Name.
            -> HtmlT m a  -- ^ Children HTML.
            -> HtmlT m a -- ^ A parent element.
{-# INLINE[1] makeElement #-}
makeElement :: Text -> HtmlT m a -> HtmlT m a
makeElement Text
name = \HtmlT m a
m' -> m (Seq Attribute -> Builder, a) -> HtmlT m a
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a)
mk ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a))
-> m (Seq Attribute -> Builder, a)
-> m (Seq Attribute -> Builder, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HtmlT m a -> m (Seq Attribute -> Builder, a)
forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m')
  where
    mk :: (Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a)
mk ~(Seq Attribute -> Builder
f,a
a) =
      (\Seq Attribute
attr ->
        String -> Builder
s String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
f Seq Attribute
forall a. Monoid a => a
mempty
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">"
      ,a
a)

-- | Make an HTML builder for elements which have no ending tag.
makeElementNoEnd :: Applicative m
                 => Text       -- ^ Name.
                 -> HtmlT m () -- ^ A parent element.
makeElementNoEnd :: Text -> HtmlT m ()
makeElementNoEnd Text
name =
  m (Seq Attribute -> Builder, ()) -> HtmlT m ()
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, ()) -> m (Seq Attribute -> Builder, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Seq Attribute
attr -> String -> Builder
s String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name
                        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">",
                 ()))

-- | Make an XML builder for elements which have no ending tag.
makeXmlElementNoEnd :: Applicative m
                    => Text       -- ^ Name.
                    -> HtmlT m () -- ^ A parent element.
makeXmlElementNoEnd :: Text -> HtmlT m ()
makeXmlElementNoEnd Text
name =
  m (Seq Attribute -> Builder, ()) -> HtmlT m ()
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, ()) -> m (Seq Attribute -> Builder, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Seq Attribute
attr -> String -> Builder
s String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name
                        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"/>",
                 ()))

-- | Build and encode an attribute.
buildAttr :: Text -> Text -> Builder
buildAttr :: Text -> Text -> Builder
buildAttr Text
key Text
val =
  String -> Builder
s String
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Text -> Builder
Blaze.fromText Text
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  if Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
     then Builder
forall a. Monoid a => a
mempty
     else String -> Builder
s String
"=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromHtmlEscapedText Text
val Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"\""

-- | Folding and monoidally appending attributes.
foldlMapWithKey :: (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey :: (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
f Seq Attribute
attributes =
  case [Text] -> Maybe [Text]
forall a. Ord a => [a] -> Maybe [a]
nubOrdMaybe (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
pairs) of
    Just [Text]
keyList ->
      (Text -> Builder) -> [Text] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Text
k -> Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe Builder
forall a. Monoid a => a
mempty ((Text -> Builder) -> Maybe Text -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Builder
f Text
k) (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
k Map Text Text
values))) [Text]
keyList
      where values :: Map Text Text
values = (Text -> Text -> Text) -> [(Text, Text)] -> Map Text Text
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) [(Text, Text)]
pairs
    Maybe [Text]
Nothing -> (Attribute -> Builder) -> Seq Attribute -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Attribute Text
k Text
v) -> Text -> Text -> Builder
f Text
k Text
v) Seq Attribute
attributes
  where
    pairs :: [(Text, Text)]
pairs = (Attribute -> (Text, Text)) -> [Attribute] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Attribute Text
k Text
v) -> (Text
k,Text
v)) (Seq Attribute -> [Attribute]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Attribute
attributes)

-- | Do a nubOrd, but only return Maybe if it actually removes anything.
nubOrdMaybe :: Ord a => [a] -> Maybe [a]
nubOrdMaybe :: [a] -> Maybe [a]
nubOrdMaybe = Bool -> Set a -> [a] -> [a] -> Maybe [a]
forall a. Ord a => Bool -> Set a -> [a] -> [a] -> Maybe [a]
go Bool
False Set a
forall a. Set a
Set.empty []
  where
    go :: Bool -> Set a -> [a] -> [a] -> Maybe [a]
go (!Bool
removed) Set a
set [a]
acc (a
x:[a]
xs)
      | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
set = Bool -> Set a -> [a] -> [a] -> Maybe [a]
go Bool
True Set a
set [a]
acc [a]
xs
      | Bool
otherwise = Bool -> Set a -> [a] -> [a] -> Maybe [a]
go Bool
removed (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
set) (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) [a]
xs
    go Bool
removed Set a
_set [a]
acc [] =
      if Bool
removed
        then [a] -> Maybe [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)
        else Maybe [a]
forall a. Maybe a
Nothing

-- | Convenience function for constructing builders.
s :: String -> Builder
s :: String -> Builder
s = String -> Builder
Blaze.fromString
{-# INLINE s #-}