module Lucid.Base
(
renderText
,renderBS
,renderTextT
,renderBST
,renderToFile
,execHtmlT
,evalHtmlT
,runHtmlT
,with
,makeElement
,makeElementNoEnd
,Html
,HtmlT
,ToHtml(..)
,Mixed(..)
,MixedRaw(..)
,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 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 (a ~ Text) => Mixed a (Text,Text) where
mixed key value = (key,value)
instance (Monad m,a ~ HtmlT m r,r ~ ()) => Mixed a (HtmlT m r) where
mixed = makeElement . Blaze.fromText
class MixedRaw a r where
mixedRaw :: Text -> a -> r
instance (a ~ Text) => MixedRaw a (Text,Text) where
mixedRaw key value = (key,value)
instance (Monad m,ToHtml a,r ~ ()) => MixedRaw a (HtmlT m r) where
mixedRaw n = makeElement (Blaze.fromText n) . toHtmlRaw
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 <> foldlMapWithKey buildAttr attr <> s ">"
<> m <> f mempty mempty
<> s "</" <> name <> s ">",
()))
makeElementNoEnd :: Monad m
=> Builder
-> HtmlT m ()
makeElementNoEnd name =
HtmlT (return (\attr _ -> s "<" <> name <> foldlMapWithKey buildAttr attr <> s ">",
()))
buildAttr :: Text -> Text -> Builder
buildAttr key val =
s " " <>
Blaze.fromText key <>
if val == mempty
then mempty
else s "=\"" <> encode val <> s "\""
foldlMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey f = M.foldlWithKey' (\m k v -> m <> f k v) mempty
s :: String -> Builder
s = Blaze.fromString
encode :: Text -> Builder
encode = Blaze.fromHtmlEscapedText