module Lucid.Base
(
renderText
,renderBS
,renderTextT
,renderBST
,renderToFile
,execHtmlT
,evalHtmlT
,runHtmlT
,with
,makeElement
,makeElementNoEnd
,Html
,Attr(..)
,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.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 (Builder -> 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
data Attr =
Attr {attrName :: !Builder
,attrValue :: !Text
}
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 :: Builder -> a -> r
instance (ToText a) => Mixed a Attr where
mixed s = Attr s . toText
instance (Monad m,a ~ HtmlT m r,r ~ ()) => Mixed a (HtmlT m r) where
mixed = makeElement
class With a where
with :: a
-> [Attr] -> a
instance (Monad m,a ~ ()) => With (HtmlT m a) where
with f =
\attr ->
HtmlT (do ~(f',_) <- runHtmlT f
return (\attr' m' -> f' (attr' <> mconcat (map buildAttr attr)) m',()))
where buildAttr :: Attr -> Builder
buildAttr (Attr key val) =
Blaze.fromString " " <>
key <>
if val == mempty
then mempty
else Blaze.fromString "=\"" <>
Blaze.fromText val <>
Blaze.fromText "\""
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' (attr' <>
mconcat (map buildAttr attr))
m'),
()) )
where buildAttr :: Attr -> Builder
buildAttr (Attr key val) =
Blaze.fromString " " <>
key <>
if val == mempty
then mempty
else Blaze.fromString "=\"" <>
Blaze.fromText val <>
Blaze.fromText "\""
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 <> 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 <> attr <> s ">"),
()))
where s = Blaze.fromString
encode :: Text -> Builder
encode = Blaze.fromHtmlEscapedText