{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Page.Render
( renderPage,
renderPageWith,
renderPageHtmlWith,
renderPageAsText,
renderPageToFile,
renderPageHtmlToFile,
)
where
import Control.Applicative
import Control.Lens
import Control.Monad
import Data.Foldable
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.IO (writeFile)
import Lucid
import qualified Lucid.Svg as Svg
import Web.Page.Html
import Web.Page.Types
import Prelude hiding (writeFile)
renderPage :: Page -> Html ()
renderPage p =
(\(_, _, x) -> x) $ renderPageWith (defaultPageConfig "default") p
renderPageHtmlWith :: PageConfig -> Page -> Html ()
renderPageHtmlWith pc p =
(\(_, _, x) -> x) $ renderPageWith pc p
renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())
renderPageWith pc p =
case pc ^. #concerns of
Inline -> (mempty, mempty, h)
Separated -> (css, js, h)
where
h =
case pc ^. #structure of
HeaderBody ->
doctype_
<> with
html_
[lang_ "en"]
( head_
( mconcat
[ meta_ [charset_ "utf-8"],
cssInline,
mconcat libsCss',
p ^. #htmlHeader
]
)
<> body_
( mconcat
[ p ^. #htmlBody,
mconcat libsJs',
jsInline
]
)
)
Headless ->
mconcat
[ doctype_,
meta_ [charset_ "utf-8"],
mconcat libsCss',
cssInline,
p ^. #htmlHeader,
p ^. #htmlBody,
mconcat libsJs',
jsInline
]
Snippet ->
mconcat
[ mconcat libsCss',
cssInline,
p ^. #htmlHeader,
p ^. #htmlBody,
mconcat libsJs',
jsInline
]
Svg ->
Svg.doctype_
<> svg_
( Svg.defs_ $
mconcat
[ mconcat libsCss',
cssInline,
p ^. #htmlBody,
mconcat libsJs',
jsInline
]
)
css = rendercss (p ^. #cssBody)
js = renderjs (p ^. #jsGlobal <> onLoad (p ^. #jsOnLoad))
renderjs = renderPageJs $ pc ^. #pageRender
rendercss = renderPageCss $ pc ^. #pageRender
cssInline
| pc ^. #concerns == Separated || css == mempty = mempty
| otherwise = style_ [type_ "text/css"] css
jsInline
| pc ^. #concerns == Separated || js == mempty = mempty
| otherwise = script_ mempty js
libsCss' =
case pc ^. #concerns of
Inline -> p ^. #libsCss
Separated ->
p ^. #libsCss
<> [libCss (Text.pack $ pc ^. #filenames . #cssConcern)]
libsJs' =
case pc ^. #concerns of
Inline -> p ^. #libsJs
Separated ->
p ^. #libsJs
<> [libJs (Text.pack $ pc ^. #filenames . #jsConcern)]
renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageToFile dir pc page =
sequenceA_ $ liftA2 writeFile' (pc ^. #filenames) (renderPageAsText pc page)
where
writeFile' fp s = unless (s == mempty) (writeFile (dir <> "/" <> fp) s)
renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageHtmlToFile file pc page =
writeFile file (toText $ renderPageHtmlWith pc page)
renderPageAsText :: PageConfig -> Page -> Concerns Text
renderPageAsText pc p =
case pc ^. #concerns of
Inline -> Concerns mempty mempty htmlt
Separated -> Concerns css js htmlt
where
htmlt = toText h
(css, js, h) = renderPageWith pc p