{-# LANGUAGE FlexibleInstances, FlexibleContexts, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Happstack.Server.HSP.HTML
( defaultTemplate
) where
import Control.Monad.Trans (MonadIO(), liftIO)
import Data.Monoid ((<>))
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Builder as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy (Text)
import Language.Haskell.HSX.QQ (hsx)
import Control.Monad (liftM)
import Happstack.Server
( ToMessage(toMessage, toContentType, toResponse)
, Response
)
import HSP
import HSP.HTML4
instance ToMessage (Maybe XMLMetaData, XML) where
toContentType :: (Maybe XMLMetaData, XML) -> ByteString
toContentType (Just XMLMetaData
md,XML
_) = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict (XMLMetaData -> Text
contentType XMLMetaData
md)
toContentType (Maybe XMLMetaData, XML)
_ = ByteString
"text/html;charset=utf-8"
toMessage :: (Maybe XMLMetaData, XML) -> ByteString
toMessage (Just (XMLMetaData (Bool
showDt, Text
dt) Text
_ XML -> Builder
pr), XML
xml) =
Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> Text
TL.toLazyText ((if Bool
showDt then ((Text -> Builder
TL.fromLazyText Text
dt) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) else Builder -> Builder
forall a. a -> a
id) (XML -> Builder
pr XML
xml))
toMessage (Maybe XMLMetaData
Nothing, XML
xml) =
Text -> ByteString
TL.encodeUtf8 (XML -> Text
renderAsHTML XML
xml)
instance ToMessage XML where
toContentType :: XML -> ByteString
toContentType XML
_ = ByteString
"text/html;charset=utf-8"
toMessage :: XML -> ByteString
toMessage XML
xml = (Maybe XMLMetaData, XML) -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage (Maybe XMLMetaData
html4Strict, XML
xml)
defaultTemplate :: ( XMLGenerator m, EmbedAsChild m headers
, EmbedAsChild m body, StringType m ~ Text) =>
TL.Text
-> headers
-> body
-> m (XMLType m)
defaultTemplate :: Text -> headers -> body -> m (XMLType m)
defaultTemplate Text
title headers
headers body
body =
XMLGenT m (XMLType m) -> m (XMLType m)
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT m (XMLType m) -> m (XMLType m))
-> XMLGenT m (XMLType m) -> m (XMLType m)
forall a b. (a -> b) -> a -> b
$ [hsx|
<html>
<head>
<title><% title %></title>
<% headers %>
</head>
<body>
<% body %>
</body>
</html>
|]