{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Rep.Render
( renderPage,
renderPageWith,
renderPageHtmlWith,
renderPageAsText,
renderPageToFile,
renderPageHtmlToFile,
)
where
import Control.Applicative
import Control.Monad
import Data.Foldable
import Data.Text (Text, pack, unpack)
import Lucid
import Optics.Core
import Web.Rep.Html
import Web.Rep.Page
renderPage :: Page -> Html ()
renderPage :: Page -> Html ()
renderPage Page
p =
(\(Text
_, Text
_, Html ()
x) -> Html ()
x) forall a b. (a -> b) -> a -> b
$ PageConfig -> Page -> (Text, Text, Html ())
renderPageWith (FilePath -> PageConfig
defaultPageConfig FilePath
"default") Page
p
renderPageHtmlWith :: PageConfig -> Page -> Html ()
renderPageHtmlWith :: PageConfig -> Page -> Html ()
renderPageHtmlWith PageConfig
pc Page
p =
(\(Text
_, Text
_, Html ()
x) -> Html ()
x) forall a b. (a -> b) -> a -> b
$ PageConfig -> Page -> (Text, Text, Html ())
renderPageWith PageConfig
pc Page
p
renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())
renderPageWith :: PageConfig -> Page -> (Text, Text, Html ())
renderPageWith PageConfig
pc Page
p =
case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns of
PageConcerns
Inline -> (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, Html ()
h)
PageConcerns
Separated -> (Text
css, Text
js, Html ()
h)
where
h :: Html ()
h =
case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "structure" a => a
#structure of
PageStructure
HeaderBody ->
forall (m :: * -> *). Applicative m => HtmlT m ()
doctype_
forall a. Semigroup a => a -> a -> a
<> forall a. With a => a -> [Attribute] -> a
with
forall arg result. Term arg result => arg -> result
html_
[Text -> Attribute
lang_ Text
"en"]
( forall arg result. Term arg result => arg -> result
head_
( forall a. Monoid a => [a] -> a
mconcat
[ forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"utf-8"],
Html ()
cssInline,
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlHeader" a => a
#htmlHeader
]
)
forall a. Semigroup a => a -> a -> a
<> forall arg result. Term arg result => arg -> result
body_
( forall a. Monoid a => [a] -> a
mconcat
[ Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlBody" a => a
#htmlBody,
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
Html ()
jsInline
]
)
)
PageStructure
Headless ->
forall a. Monoid a => [a] -> a
mconcat
[ forall (m :: * -> *). Applicative m => HtmlT m ()
doctype_,
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"utf-8"],
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
Html ()
cssInline,
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlHeader" a => a
#htmlHeader,
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlBody" a => a
#htmlBody,
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
Html ()
jsInline
]
PageStructure
Snippet ->
forall a. Monoid a => [a] -> a
mconcat
[ forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
Html ()
cssInline,
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlHeader" a => a
#htmlHeader,
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlBody" a => a
#htmlBody,
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
Html ()
jsInline
]
PageStructure
Svg ->
Html ()
svgDocType
forall a. Semigroup a => a -> a -> a
<> forall arg result. Term arg result => arg -> result
svg_
( Html () -> Html ()
svgDefs forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
Html ()
cssInline,
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "htmlBody" a => a
#htmlBody,
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
Html ()
jsInline
]
)
css :: Text
css = RepCss -> Text
rendercss (Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "cssBody" a => a
#cssBody)
js :: Text
js = RepJs -> Text
renderjs (Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "jsGlobal" a => a
#jsGlobal forall a. Semigroup a => a -> a -> a
<> RepJs -> RepJs
onLoad (Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "jsOnLoad" a => a
#jsOnLoad))
renderjs :: RepJs -> Text
renderjs = PageRender -> RepJs -> Text
renderRepJs forall a b. (a -> b) -> a -> b
$ PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "pageRender" a => a
#pageRender
rendercss :: RepCss -> Text
rendercss = PageRender -> RepCss -> Text
renderRepCss forall a b. (a -> b) -> a -> b
$ PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "pageRender" a => a
#pageRender
cssInline :: Html ()
cssInline
| PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns forall a. Eq a => a -> a -> Bool
== PageConcerns
Separated Bool -> Bool -> Bool
|| Text
css forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall a. Monoid a => a
mempty
| Bool
otherwise = forall arg result. TermRaw arg result => arg -> result
style_ [Text -> Attribute
type_ Text
"text/css"] Text
css
jsInline :: Html ()
jsInline
| PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns forall a. Eq a => a -> a -> Bool
== PageConcerns
Separated Bool -> Bool -> Bool
|| Text
js forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall a. Monoid a => a
mempty
| Bool
otherwise = forall arg result. TermRaw arg result => arg -> result
script_ forall a. Monoid a => a
mempty Text
js
libsCss' :: [Html ()]
libsCss' =
case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns of
PageConcerns
Inline -> Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "libsCss" a => a
#libsCss
PageConcerns
Separated ->
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "libsCss" a => a
#libsCss
forall a. Semigroup a => a -> a -> a
<> [Text -> Html ()
libCss (FilePath -> Text
pack forall a b. (a -> b) -> a -> b
$ PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "filenames" a => a
#filenames forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "cssConcern" a => a
#cssConcern)]
libsJs' :: [Html ()]
libsJs' =
case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns of
PageConcerns
Inline -> Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "libsJs" a => a
#libsJs
PageConcerns
Separated ->
Page
p forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "libsJs" a => a
#libsJs
forall a. Semigroup a => a -> a -> a
<> [Text -> Html ()
libJs (FilePath -> Text
pack forall a b. (a -> b) -> a -> b
$ PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "filenames" a => a
#filenames forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "jsConcern" a => a
#jsConcern)]
renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageToFile FilePath
dir PageConfig
pc Page
page =
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 FilePath -> FilePath -> IO ()
writeFile' (PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "filenames" a => a
#filenames) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
unpack (PageConfig -> Page -> Concerns Text
renderPageAsText PageConfig
pc Page
page))
where
writeFile' :: FilePath -> FilePath -> IO ()
writeFile' FilePath
fp FilePath
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
s forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) (FilePath -> FilePath -> IO ()
writeFile (FilePath
dir forall a. Semigroup a => a -> a -> a
<> FilePath
"/" forall a. Semigroup a => a -> a -> a
<> FilePath
fp) FilePath
s)
renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageHtmlToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageHtmlToFile FilePath
file PageConfig
pc Page
page =
FilePath -> FilePath -> IO ()
writeFile FilePath
file (Text -> FilePath
unpack forall a b. (a -> b) -> a -> b
$ forall a. Html a -> Text
toText forall a b. (a -> b) -> a -> b
$ PageConfig -> Page -> Html ()
renderPageHtmlWith PageConfig
pc Page
page)
renderPageAsText :: PageConfig -> Page -> Concerns Text
renderPageAsText :: PageConfig -> Page -> Concerns Text
renderPageAsText PageConfig
pc Page
p =
case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns of
PageConcerns
Inline -> forall a. a -> a -> a -> Concerns a
Concerns forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Text
htmlt
PageConcerns
Separated -> forall a. a -> a -> a -> Concerns a
Concerns Text
css Text
js Text
htmlt
where
htmlt :: Text
htmlt = forall a. Html a -> Text
toText Html ()
h
(Text
css, Text
js, Html ()
h) = PageConfig -> Page -> (Text, Text, Html ())
renderPageWith PageConfig
pc Page
p
svgDocType :: Html ()
svgDocType :: Html ()
svgDocType = Html ()
"?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\""
svgDefs :: Html () -> Html ()
svgDefs :: Html () -> Html ()
svgDefs = forall arg result. Term arg result => Text -> arg -> result
term Text
"defs"