module Lucid.Base
(
renderText
,renderBS
,renderTextT
,renderBST
,renderToFile
,execHtmlT
,evalHtmlT
,runHtmlT
,with
,makeElement
,makeElementNoEnd
,Html
,HtmlT
,ToText(..)
,ToHtml(..)
,Mixed(..)
,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.Reader
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Functor.Identity
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
type Html = HtmlT Identity
newtype HtmlT m a =
HtmlT {runHtmlT :: m (HashMap Text Text -> Builder -> Builder,a)
}
instance Monoid a => Monoid (Html a) where
mempty = HtmlT (return (\_ _ -> mempty,mempty))
mappend (HtmlT get_f_a) (HtmlT get_g_b) =
HtmlT (do ~(f,a) <- get_f_a
~(g,b) <- get_g_b
return (\attr inner ->
f attr inner <>
g attr inner
,a <> b))
instance Monad m => Applicative (HtmlT m) where
pure = return
(<*>) = ap
instance Monad m => Functor (HtmlT m) where
fmap = liftM
instance Monad m => Monad (HtmlT m) where
return a = HtmlT (return (\_ _ -> mempty,a))
HtmlT get_g_a >>= f =
HtmlT (do ~(g,a) <- get_g_a
let HtmlT get_f'_b = f a
~(f',b) <- get_f'_b
return (\attr inner ->
g attr inner <>
f' attr inner
,b))
instance MonadTrans HtmlT where
lift m =
HtmlT (do a <- m
return (\_ _ -> mempty,a))
instance MonadIO m => MonadIO (HtmlT m) where
liftIO = lift . liftIO
instance (Monad m,a ~ ()) => IsString (HtmlT m a) where
fromString m' =
HtmlT (return (\_ _ -> encode (T.pack m'),()))
instance (m ~ Identity) => Show (HtmlT m a) where
show = LT.unpack . renderText
class ToText a where
toText :: a -> Text
instance ToText String where
toText = T.pack
instance ToText Text where
toText = id
class ToHtml a where
toHtml :: Monad m => a -> HtmlT m ()
toHtmlRaw :: Monad m => a -> HtmlT m ()
instance ToHtml String where
toHtml = fromString
toHtmlRaw m = HtmlT (return ((\_ _ -> Blaze.fromString m),()))
instance ToHtml Text where
toHtml m = HtmlT (return ((\_ _ -> encode m),()))
toHtmlRaw m = HtmlT (return ((\_ _ -> Blaze.fromText m),()))
class Mixed a r where
mixed :: Text -> a -> r
instance (ToText a) => Mixed a (Text,Text) where
mixed key value = (key,toText value)
instance (Monad m,a ~ HtmlT m r,r ~ ()) => Mixed a (HtmlT m r) where
mixed = makeElement . Blaze.fromText
class With a where
with :: a
-> [(Text,Text)] -> a
instance (Monad m,a ~ ()) => With (HtmlT m a) where
with f =
\attr ->
HtmlT (do ~(f',_) <- runHtmlT f
return (\attr' m' ->
f' (unionArgs (M.fromList attr) attr') m'
,()))
instance (Monad m,a ~ ()) => With (HtmlT m a -> HtmlT m a) where
with f =
\attr inner ->
HtmlT (do ~(f',_) <- runHtmlT (f inner)
return ((\attr' m' ->
f' (unionArgs (M.fromList attr) attr') m')
,()))
unionArgs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text
unionArgs = M.unionWith (<>)
renderToFile :: FilePath -> Html a -> IO ()
renderToFile fp = L.writeFile fp . Blaze.toLazyByteString . runIdentity . execHtmlT
renderBS :: Html a -> ByteString
renderBS = Blaze.toLazyByteString . runIdentity . execHtmlT
renderText :: Html a -> LT.Text
renderText = LT.decodeUtf8 . Blaze.toLazyByteString . runIdentity . execHtmlT
renderBST :: Monad m => HtmlT m a -> m ByteString
renderBST = liftM Blaze.toLazyByteString . execHtmlT
renderTextT :: Monad m => HtmlT m a -> m LT.Text
renderTextT = liftM (LT.decodeUtf8 . Blaze.toLazyByteString) . execHtmlT
execHtmlT :: Monad m
=> HtmlT m a
-> m Builder
execHtmlT m =
do (f,_) <- runHtmlT m
return (f mempty mempty)
evalHtmlT :: Monad m
=> HtmlT m a
-> m a
evalHtmlT m =
do (_,a) <- runHtmlT m
return a
makeElement :: Monad m
=> Builder
-> HtmlT m a
-> HtmlT m ()
makeElement name =
\m' ->
HtmlT (do ~(f,_) <- runHtmlT m'
return ((\attr m -> s "<" <> name <> mconcat (map buildAttr (M.toList attr)) <> s ">" <> m <> f mempty mempty <> s "</" <>
name <> s ">"),
()))
where s = Blaze.fromString
makeElementNoEnd :: Monad m
=> Builder
-> HtmlT m ()
makeElementNoEnd name =
HtmlT (return ((\attr _ -> s "<" <> name <> mconcat (map buildAttr (M.toList attr)) <> s ">"),
()))
where s = Blaze.fromString
buildAttr :: (Text,Text) -> Builder
buildAttr (key,val) =
Blaze.fromString " " <>
Blaze.fromText key <>
if val == mempty
then mempty
else Blaze.fromString "=\"" <>
Blaze.fromText val <>
Blaze.fromText "\""
encode :: Text -> Builder
encode = Blaze.fromHtmlEscapedText