{-# LANGUAGE CPP, OverloadedStrings #-}
{-# LANGUAGE BangPatterns, RankNTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

-- 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
  ,generalizeHtmlT
  ,commuteHtmlT2
  ,hoistHtmlT
  -- * Combinators
  ,makeElement
  ,makeElementNoEnd
  ,makeAttributes
  ,makeAttributesRaw
  ,Attributes
   -- * Types
  ,Html
  ,HtmlT
   -- * Classes
  ,Term(..)
  ,TermRaw(..)
  ,ToHtml(..)

   -- * Deprecated
  ,relaxHtmlT
  ,commuteHtmlT
  )
  where

import           Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Fix (MonadFix(..))
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Reader (MonadReader(..))
import           Control.Monad.State.Class (MonadState(..))
import           Control.Monad.Trans (MonadTrans(..))
import           Control.Monad.Trans.State.Strict (StateT(..), modify', mapStateT)
import qualified Data.ByteString as S
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import           Data.Foldable (toList)
import           Data.Functor.Identity
import qualified Data.Map.Strict as M
import           Data.Maybe
import           Data.Sequence (Seq)
import qualified Data.Set as Set
import           Data.String
import           Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import           Data.Tuple (swap)
import           Prelude

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

-- | A simple attribute. Don't use the constructor, use
-- 'makeAttributes'.  Attributes are case sensitive, so if you want
-- attributes to be merged properly, use a single case representation.
data Attribute = Attribute !Text !Builder

-- | A list of attributes.
newtype Attributes = Attributes { Attributes -> Seq Attribute
unAttributes :: Seq Attribute }
  deriving (Semigroup Attributes
Attributes
[Attributes] -> Attributes
Attributes -> Attributes -> Attributes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Attributes] -> Attributes
$cmconcat :: [Attributes] -> Attributes
mappend :: Attributes -> Attributes -> Attributes
$cmappend :: Attributes -> Attributes -> Attributes
mempty :: Attributes
$cmempty :: Attributes
Monoid, NonEmpty Attributes -> Attributes
Attributes -> Attributes -> Attributes
forall b. Integral b => b -> Attributes -> Attributes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Attributes -> Attributes
$cstimes :: forall b. Integral b => b -> Attributes -> Attributes
sconcat :: NonEmpty Attributes -> Attributes
$csconcat :: NonEmpty Attributes -> Attributes
<> :: Attributes -> Attributes -> Attributes
$c<> :: Attributes -> Attributes -> Attributes
Semigroup)

-- | 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.
newtype HtmlT m a = HtmlT { forall (m :: * -> *) a. HtmlT m a -> StateT Builder m a
unHtmlT :: StateT Builder m a }
  deriving (forall a. a -> HtmlT m a
forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
forall a b. HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
forall {m :: * -> *}. Monad m => Applicative (HtmlT m)
forall (m :: * -> *) a. Monad m => a -> HtmlT m a
forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m b
forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> HtmlT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> HtmlT m a
>> :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m b
>>= :: forall a b. HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
Monad, forall a b. a -> HtmlT m b -> HtmlT m a
forall a b. (a -> b) -> HtmlT m a -> HtmlT m b
forall (m :: * -> *) a b. Functor m => a -> HtmlT m b -> HtmlT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HtmlT m a -> HtmlT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HtmlT m b -> HtmlT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> HtmlT m b -> HtmlT m a
fmap :: forall a b. (a -> b) -> HtmlT m a -> HtmlT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HtmlT m a -> HtmlT m b
Functor, forall a. a -> HtmlT m a
forall a b. HtmlT m a -> HtmlT m b -> HtmlT m a
forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
forall a b. HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
forall a b c. (a -> b -> c) -> HtmlT m a -> HtmlT m b -> HtmlT m c
forall {m :: * -> *}. Monad m => Functor (HtmlT m)
forall (m :: * -> *) a. Monad m => a -> HtmlT m a
forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m a
forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m b
forall (m :: * -> *) a b.
Monad m =>
HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> HtmlT m a -> HtmlT m b -> HtmlT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m a
*> :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
HtmlT m a -> HtmlT m b -> HtmlT m b
liftA2 :: forall a b c. (a -> b -> c) -> HtmlT m a -> HtmlT m b -> HtmlT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> HtmlT m a -> HtmlT m b -> HtmlT m c
<*> :: forall a b. HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
pure :: forall a. a -> HtmlT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> HtmlT m a
Applicative, forall (m :: * -> *) a. Monad m => m a -> HtmlT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> HtmlT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> HtmlT m a
MonadTrans, forall a. (a -> HtmlT m a) -> HtmlT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (HtmlT m)
forall (m :: * -> *) a. MonadFix m => (a -> HtmlT m a) -> HtmlT m a
mfix :: forall a. (a -> HtmlT m a) -> HtmlT m a
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> HtmlT m a) -> HtmlT m a
MonadFix)

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

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

-- | Run the HtmlT transformer.
runHtmlT :: Monad m => HtmlT m a -> m (Builder, a)
runHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m (Builder, a)
runHtmlT = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. HtmlT m a -> StateT Builder m a
unHtmlT

-- | Switch the underlying monad.
hoistHtmlT :: (Monad m, Monad n) => (forall a. m a -> n a) -> HtmlT m b -> HtmlT n b
hoistHtmlT :: forall (m :: * -> *) (n :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> HtmlT m b -> HtmlT n b
hoistHtmlT forall a. m a -> n a
f (HtmlT StateT Builder m b
xs) = forall (m :: * -> *) a. StateT Builder m a -> HtmlT m a
HtmlT (forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT forall a. m a -> n a
f StateT Builder m b
xs)

-- | @since 2.9.7
instance (a ~ (),Monad m) => Semigroup (HtmlT m a) where
  <> :: 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 forall a. Semigroup a => a -> a -> a
(<>)

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

-- | If you want to use IO in your HTML generation.
instance MonadIO m => MonadIO (HtmlT m) where
  liftIO :: forall a. IO a -> HtmlT m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *). Monad m => HtmlT m a -> HtmlT m ()
toHtml = forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
generalizeHtmlT
  toHtmlRaw :: forall (m :: * -> *). Monad m => HtmlT m a -> HtmlT m ()
toHtmlRaw = forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
generalizeHtmlT

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

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

instance ToHtml LT.Text where
  toHtml :: forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml    = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedLazyText
  toHtmlRaw :: forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write 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 :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtml    = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8
  toHtmlRaw :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtmlRaw = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.byteString

-- | 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 :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtml    = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromHtmlEscapedLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8
  toHtmlRaw :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtmlRaw = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.lazyByteString

-- | 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.

-- | Given attributes, expect more child input.
instance (Monad m,f ~ HtmlT m a) => Term [Attributes] (f -> HtmlT m a) where
  term :: Text -> [Attributes] -> f -> HtmlT m a
term Text
name = forall (m :: * -> *) a.
Monad m =>
Text -> [Attributes] -> HtmlT m a -> HtmlT m a
makeElement Text
name

-- | Given children immediately, just use that and expect no
-- attributes.
instance (Monad m) => Term (HtmlT m a) (HtmlT m a) where
  term :: Text -> HtmlT m a -> HtmlT m a
term Text
name = forall (m :: * -> *) a.
Monad m =>
Text -> [Attributes] -> HtmlT m a -> HtmlT m a
makeElement Text
name forall a. Monoid a => a
mempty
  {-# INLINE term #-}

-- | Some terms (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for
-- attributes as well as elements.
instance Term Text Attributes where
  term :: Text -> Text -> Attributes
term Text
key Text
value = Text -> Text -> Attributes
makeAttributes 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.

-- | Given attributes, expect more child input.
instance (Monad m,ToHtml f, a ~ ()) => TermRaw [Attributes] (f -> HtmlT m a) where
  termRaw :: Text -> [Attributes] -> f -> HtmlT m a
termRaw Text
name [Attributes]
attrs = forall (m :: * -> *) a.
Monad m =>
Text -> [Attributes] -> HtmlT m a -> HtmlT m a
makeElement Text
name [Attributes]
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  termRaw :: Text -> Text -> HtmlT m a
termRaw Text
name = forall (m :: * -> *) a.
Monad m =>
Text -> [Attributes] -> HtmlT m a -> HtmlT m a
makeElement Text
name forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Attributes where
  termRaw :: Text -> Text -> Attributes
termRaw Text
key Text
value = Text -> Text -> Attributes
makeAttributesRaw Text
key Text
value

--------------------------------------------------------------------------------
-- 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 :: forall a. String -> Html a -> IO ()
renderToFile String
fp = String -> ByteString -> IO ()
L.writeFile String
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Html a -> ByteString
renderBS = Builder -> ByteString
Blaze.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Html a -> Text
renderText = ByteString -> Text
LT.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m ByteString
renderBST = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> ByteString
Blaze.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m Text
renderTextT = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
LT.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT HtmlT m a
m =
  do (Builder
builder,a
_) <- forall (m :: * -> *) a. Monad m => HtmlT m a -> m (Builder, a)
runHtmlT HtmlT m a
m
     forall (m :: * -> *) a. Monad m => a -> m a
return Builder
builder
{-# inline execHtmlT #-}

-- | 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'.
--
generalizeHtmlT ::
     Monad m
  => HtmlT Identity a -- ^ The HTML generated purely.
  -> HtmlT m a -- ^ Same HTML accessible in a polymorphic context.
generalizeHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
generalizeHtmlT = forall (m :: * -> *) (n :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> HtmlT m b -> HtmlT n b
hoistHtmlT forall (m :: * -> *) a. Monad m => Identity a -> m a
go
   where
     go :: Monad m => Identity a -> m a
     go :: forall (m :: * -> *) a. Monad m => Identity a -> m a
go = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
-- @
--
commuteHtmlT2 :: (Monad m, Monad n)
             => HtmlT m a      -- ^ unpurely generated HTML
             -> m (HtmlT n a)  -- ^ Commuted monads. /Note:/ @n@ can be 'Identity'
commuteHtmlT2 :: forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
HtmlT m a -> m (HtmlT n a)
commuteHtmlT2 HtmlT m a
h = do
  (Builder
builder, a
a) <- forall (m :: * -> *) a. Monad m => HtmlT m a -> m (Builder, a)
runHtmlT HtmlT m a
h
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. StateT Builder m a -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (forall a. Semigroup a => a -> a -> a
<> Builder
builder) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | 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 :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m a
evalHtmlT HtmlT m a
m =
  do (Builder
_,a
a) <- forall (m :: * -> *) a. Monad m => HtmlT m a -> m (Builder, a)
runHtmlT HtmlT m a
m
     forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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

-- | Make a set of attributes.
makeAttributes :: Text -- ^ Attribute name.
               -> Text -- ^ Attribute value.
               -> Attributes
makeAttributes :: Text -> Text -> Attributes
makeAttributes Text
x Text
y = Seq Attribute -> Attributes
Attributes (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Builder -> Attribute
Attribute Text
x (Text -> Builder
Blaze.fromHtmlEscapedText Text
y)))

-- | Make a set of unescaped attributes.
makeAttributesRaw ::
     Text -- ^ Attribute name.
  -> Text -- ^ Attribute value.
  -> Attributes
makeAttributesRaw :: Text -> Text -> Attributes
makeAttributesRaw Text
x Text
y = Seq Attribute -> Attributes
Attributes (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Builder -> Attribute
Attribute Text
x (Text -> Builder
Blaze.fromText Text
y)))

-- | Make an HTML builder.
makeElement :: Monad m
            => Text       -- ^ Name.
            -> [Attributes]
            -> HtmlT m a  -- ^ Children HTML.
            -> HtmlT m a -- ^ A parent element.
{-# INLINE[1] makeElement #-}
makeElement :: forall (m :: * -> *) a.
Monad m =>
Text -> [Attributes] -> HtmlT m a -> HtmlT m a
makeElement Text
name [Attributes]
attr HtmlT m a
children = do
  forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write
    (String -> Builder
s String
"<" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name forall a. Semigroup a => a -> a -> a
<> (Text -> Builder -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Builder -> Builder
buildAttr ([Attributes] -> Seq Attribute
attributeList [Attributes]
attr) forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">")
  a
v <- HtmlT m a
children
  forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write (String -> Builder
s String
"</" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

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

-- | Build and encode an attribute.
buildAttr :: Text -> Builder -> Builder
buildAttr :: Text -> Builder -> Builder
buildAttr Text
key Builder
val = String -> Builder
s String
" " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
key forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"=\"" forall a. Semigroup a => a -> a -> a
<> Builder
val forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"\""

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

-- | Special handling for class and style, which are common things
-- people want to combine.
combineAttributes :: Text -> Builder -> Builder -> Builder
combineAttributes :: Text -> Builder -> Builder -> Builder
combineAttributes Text
"class" Builder
v2 Builder
v1 = Builder
v1 forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> Builder
v2
combineAttributes Text
"style" Builder
v2 Builder
v1 = Builder
v1 forall a. Semigroup a => a -> a -> a
<> Builder
";" forall a. Semigroup a => a -> a -> a
<> Builder
v2
combineAttributes Text
_       Builder
v2 Builder
v1 = Builder
v1 forall a. Semigroup a => a -> a -> a
<> Builder
v2

-- | Do a nubOrd, but only return Maybe if it actually removes anything.
nubOrdMaybe :: Ord a => [a] -> Maybe [a]
nubOrdMaybe :: forall a. Ord a => [a] -> Maybe [a]
nubOrdMaybe = forall {a}. Ord a => Bool -> Set a -> [a] -> [a] -> Maybe [a]
go Bool
False 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 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 (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
set) (a
x forall a. a -> [a] -> [a]
: [a]
acc) [a]
xs
    go Bool
removed Set a
_set [a]
acc [] =
      if Bool
removed
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse [a]
acc)
        else forall a. Maybe a
Nothing

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

-- | Write some HTML output.
write :: Monad m => Builder -> HtmlT m ()
write :: forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
write Builder
b = forall (m :: * -> *) a. StateT Builder m a -> HtmlT m a
HtmlT (forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (forall a. Semigroup a => a -> a -> a
<> Builder
b))
{-# inline write #-}

attributeList :: [Attributes] -> Seq Attribute
attributeList :: [Attributes] -> Seq Attribute
attributeList = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attributes -> Seq Attribute
unAttributes

--------------------------------------------------------------------------------
-- Deprecated definitions

relaxHtmlT :: Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT = forall a. HasCallStack => a
undefined
{-# DEPRECATED relaxHtmlT "DO NOT USE. This was exported accidentally and throws an exception." #-}

commuteHtmlT :: (Monad m, Monad n)
             => HtmlT m a      -- ^ unpurely generated HTML
             -> m (HtmlT n a)  -- ^ Commuted monads. /Note:/ @n@ can be 'Identity'
commuteHtmlT :: forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
HtmlT m a -> m (HtmlT n a)
commuteHtmlT HtmlT m a
h = do
  (Builder
builder, a
a) <- forall (m :: * -> *) a. Monad m => HtmlT m a -> m (Builder, a)
runHtmlT HtmlT m a
h
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. StateT Builder m a -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put Builder
builder forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# DEPRECATED commuteHtmlT "This has incorrect behavior and will lose HTML output. See commuteHtmlT2." #-}