{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
module Lucid.Base
(
renderText
,renderBS
,renderTextT
,renderBST
,renderToFile
,execHtmlT
,evalHtmlT
,runHtmlT
,relaxHtmlT
,commuteHtmlT
,makeElement
,makeElementNoEnd
,makeXmlElementNoEnd
,makeAttribute
,Html
,HtmlT(HtmlT)
,Attribute(..)
,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
data Attribute = Attribute !Text !Text
deriving (Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
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
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 forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
a forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
b
type Html = HtmlT Identity
newtype HtmlT m a =
HtmlT {forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT :: m (Seq Attribute -> Builder,a)
}
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#endif
instance MFunctor HtmlT where
hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(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) = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall a. m a -> n a
f m (Seq Attribute -> Builder, b)
xs)
instance (a ~ (),Applicative 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
(<>)
instance (a ~ (),Applicative 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
instance Applicative m => Applicative (HtmlT m) where
pure :: forall a. a -> HtmlT m a
pure a
a = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty,a
a))
{-# INLINE pure #-}
HtmlT m (a -> b)
f <*> :: forall a b. HtmlT m (a -> b) -> HtmlT m a -> HtmlT m b
<*> HtmlT m a
x = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall {a} {t} {b}. Semigroup a => (a, t -> b) -> (a, t) -> (a, b)
mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a. Semigroup a => a -> a -> a
<> a
h, t -> b
f' t
x')
{-# INLINE (<*>) #-}
HtmlT m a
m *> :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
*> HtmlT m b
n = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall {a} {b} {b}. Semigroup a => (a, b) -> (a, b) -> (a, b)
mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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 forall a. Semigroup a => a -> a -> a
<> a
h, b
b)
{-# INLINE (*>) #-}
HtmlT m a
m <* :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m a
<* HtmlT m b
n = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall {a} {b} {b}. Semigroup a => (a, b) -> (a, b) -> (a, b)
mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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 forall a. Semigroup a => a -> a -> a
<> a
h, b
a)
{-# INLINE (<*) #-}
instance Functor m => Functor (HtmlT m) where
fmap :: forall a b. (a -> b) -> HtmlT m a -> HtmlT m b
fmap a -> b
f = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT
<$ :: forall a b. a -> HtmlT m b -> HtmlT m a
(<$) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# INLINE (<$) #-}
instance Monad m => Monad (HtmlT m) where
return :: forall a. a -> HtmlT m a
return a
a = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty,a
a))
{-# INLINE return #-}
HtmlT m a
m >>= :: forall a b. HtmlT m a -> (a -> HtmlT m b) -> HtmlT m b
>>= a -> HtmlT m b
f = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ do
~(Seq Attribute -> Builder
g,a
a) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
~(Seq Attribute -> Builder
h,b
b) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT (a -> HtmlT m b
f a
a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
g forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
h,b
b)
{-# INLINE (>>=) #-}
HtmlT m a
m >> :: forall a b. HtmlT m a -> HtmlT m b -> HtmlT m b
>> HtmlT m b
n = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ do
~(Seq Attribute -> Builder
g, a
_) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
~(Seq Attribute -> Builder
h, b
b) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m b
n
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
g forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
h, b
b)
{-# INLINE (>>) #-}
instance MonadTrans HtmlT where
lift :: forall (m :: * -> *) a. Monad m => m a -> HtmlT m a
lift m a
m =
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (do a
a <- m a
m
forall (m :: * -> *) a. Monad m => a -> m a
return (\Seq Attribute
_ -> forall a. Monoid a => a
mempty,a
a))
instance MonadFix m => MonadFix (HtmlT m) where
mfix :: forall a. (a -> HtmlT m a) -> HtmlT m a
mfix a -> HtmlT m a
m = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \ ~(Seq Attribute -> Builder
_, a
a) -> forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT forall a b. (a -> b) -> a -> b
$ a -> HtmlT m a
m a
a
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 m (Seq Attribute -> Builder, a)
a) = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f m (Seq Attribute -> Builder, a)
a)
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
instance MonadError e m => MonadError e (HtmlT m) where
throwError :: forall a. e -> HtmlT m a
throwError = 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError
catchError :: forall a. HtmlT m a -> (e -> HtmlT m a) -> HtmlT m a
catchError (HtmlT m (Seq Attribute -> Builder, a)
m) e -> HtmlT m a
h = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m (Seq Attribute -> Builder, a)
m (forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> HtmlT m a
h)
instance MonadWriter w m => MonadWriter w (HtmlT m) where
tell :: w -> HtmlT m ()
tell = 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 w (m :: * -> *). MonadWriter w m => w -> m ()
tell
listen :: forall a. HtmlT m a -> HtmlT m (a, w)
listen (HtmlT m (Seq Attribute -> Builder, a)
x) = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {b}. ((a, a), b) -> (a, (a, b))
reassoc forall a b. (a -> b) -> a -> b
$ 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 :: forall a. HtmlT m (a, w -> w) -> HtmlT m a
pass (HtmlT m (Seq Attribute -> Builder, (a, w -> w))
p) = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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)
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
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
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
class ToHtml a where
toHtml :: Monad m => a -> HtmlT m ()
toHtmlRaw :: Monad m => a -> HtmlT m ()
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
relaxHtmlT
toHtmlRaw :: forall (m :: * -> *). Monad m => HtmlT m a -> HtmlT m ()
toHtmlRaw = forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT
instance ToHtml String where
toHtml :: forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtml = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build 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 ()
build 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 ()
build 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 ()
build 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 ()
build 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 ()
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Blaze.fromLazyText
instance ToHtml S.ByteString where
toHtml :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtml = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build 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 ()
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.fromByteString
instance ToHtml L.ByteString where
toHtml :: forall (m :: * -> *). Monad m => ByteString -> HtmlT m ()
toHtml = forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build 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 ()
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
Blaze.fromLazyByteString
build :: Monad m => Builder -> HtmlT m ()
build :: forall (m :: * -> *). Monad m => Builder -> HtmlT m ()
build Builder
b = forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const Builder
b,()))
{-# INLINE build #-}
class Term arg result | result -> arg where
term :: Text
-> arg
-> result
term = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall arg result.
Term arg result =>
Text -> [Attribute] -> arg -> result
termWith []
{-# INLINE term #-}
termWith :: Text
-> [Attribute]
-> arg
-> result
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 = forall a. With a => a -> [Attribute] -> a
with (forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> [Attribute]
f)
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 = forall a. With a => a -> [Attribute] -> a
with (forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) [Attribute]
f
{-# INLINE termWith #-}
instance Term Text Attribute where
termWith :: Text -> [Attribute] -> Text -> Attribute
termWith Text
key [Attribute]
_ Text
value = Text -> Text -> Attribute
makeAttribute Text
key Text
value
class TermRaw arg result | result -> arg where
termRaw :: Text
-> arg
-> result
termRaw = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall arg result.
TermRaw arg result =>
Text -> [Attribute] -> arg -> result
termRawWith []
termRawWith :: Text
-> [Attribute]
-> arg
-> result
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 = forall a. With a => a -> [Attribute] -> a
with (forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) ([Attribute]
attrs forall a. Semigroup a => a -> a -> a
<> [Attribute]
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw
instance (Monad m,a ~ ()) => TermRaw Text (HtmlT m a) where
termRawWith :: Text -> [Attribute] -> Text -> HtmlT m a
termRawWith Text
name [Attribute]
f = forall a. With a => a -> [Attribute] -> a
with (forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name) [Attribute]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw
instance TermRaw Text Attribute where
termRawWith :: Text -> [Attribute] -> Text -> Attribute
termRawWith Text
key [Attribute]
_ Text
value = Text -> Text -> Attribute
makeAttribute Text
key Text
value
class With a where
with :: a
-> [Attribute]
-> a
instance (Functor m) => With (HtmlT m a) where
with :: HtmlT m a -> [Attribute] -> HtmlT m a
with HtmlT m a
f = \[Attribute]
attr -> forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall {a} {t} {b}. [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [Attribute]
attr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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' forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Seq a
Seq.fromList [a]
attr)
,b
a)
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 -> forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall {a} {t} {b}. [a] -> (Seq a -> t, b) -> (Seq a -> t, b)
mk [Attribute]
attr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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' forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Seq a
Seq.fromList [a]
attr)
,b
a)
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
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
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
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
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
execHtmlT :: Monad m
=> HtmlT m a
-> m Builder
execHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m Builder
execHtmlT HtmlT m a
m =
do (Seq Attribute -> Builder
f,a
_) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Attribute -> Builder
f forall a. Monoid a => a
mempty)
relaxHtmlT :: Monad m
=> HtmlT Identity a
-> HtmlT m a
relaxHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT Identity a -> HtmlT m a
relaxHtmlT = 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 (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
commuteHtmlT :: (Functor m, Monad n)
=> HtmlT m a
-> m (HtmlT n a)
commuteHtmlT :: forall (m :: * -> *) (n :: * -> *) a.
(Functor m, Monad n) =>
HtmlT m a -> m (HtmlT n a)
commuteHtmlT (HtmlT m (Seq Attribute -> Builder, a)
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) m (Seq Attribute -> Builder, a)
xs
evalHtmlT :: Monad m
=> HtmlT m a
-> m a
evalHtmlT :: forall (m :: * -> *) a. Monad m => HtmlT m a -> m a
evalHtmlT HtmlT m a
m =
do (Seq Attribute -> Builder
_,a
a) <- forall (m :: * -> *) a.
HtmlT m a -> m (Seq Attribute -> Builder, a)
runHtmlT HtmlT m a
m
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
makeAttribute :: Text
-> Text
-> Attribute
makeAttribute :: Text -> Text -> Attribute
makeAttribute Text
x Text
y = Text -> Text -> Attribute
Attribute Text
x Text
y
makeElement :: Functor m
=> Text
-> HtmlT m a
-> HtmlT m a
{-# INLINE[1] makeElement #-}
makeElement :: forall (m :: * -> *) a. Functor m => Text -> HtmlT m a -> HtmlT m a
makeElement Text
name = \HtmlT m a
m' -> forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT ((Seq Attribute -> Builder, a) -> (Seq Attribute -> Builder, a)
mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
"<" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromText Text
name
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">"
forall a. Semigroup a => a -> a -> a
<> Seq Attribute -> Builder
f forall a. Monoid a => a
mempty
forall a. Semigroup a => a -> a -> a
<> 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
">"
,a
a)
makeElementNoEnd :: Applicative m
=> Text
-> HtmlT m ()
makeElementNoEnd :: forall (m :: * -> *). Applicative m => Text -> HtmlT m ()
makeElementNoEnd Text
name =
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Seq Attribute
attr -> 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 -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
">",
()))
makeXmlElementNoEnd :: Applicative m
=> Text
-> HtmlT m ()
makeXmlElementNoEnd :: forall (m :: * -> *). Applicative m => Text -> HtmlT m ()
makeXmlElementNoEnd Text
name =
forall (m :: * -> *) a.
m (Seq Attribute -> Builder, a) -> HtmlT m a
HtmlT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Seq Attribute
attr -> 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 -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> Builder
buildAttr Seq Attribute
attr forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"/>",
()))
buildAttr :: Text -> Text -> Builder
buildAttr :: Text -> Text -> Builder
buildAttr Text
key Text
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
<>
if Text
val forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
then forall a. Monoid a => a
mempty
else String -> Builder
s String
"=\"" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Blaze.fromHtmlEscapedText Text
val forall a. Semigroup a => a -> a -> a
<> String -> Builder
s String
"\""
foldlMapWithKey :: (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey :: (Text -> Text -> Builder) -> Seq Attribute -> Builder
foldlMapWithKey Text -> Text -> 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, Text)]
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 -> Text -> Builder
f Text
k) (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 = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Semigroup a => a -> a -> a
(<>) [(Text, Text)]
pairs
Maybe [Text]
Nothing -> 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(Attribute Text
k Text
v) -> (Text
k,Text
v)) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Attribute
attributes)
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
s :: String -> Builder
s :: String -> Builder
s = String -> Builder
Blaze.fromString
{-# INLINE s #-}