{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Page rendering
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

-- | Render a Page with the default configuration into Html.
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

-- | Render a Page into Html.
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

-- | Render a Page into css text, js text and html.
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)]

-- | Render Page concerns to files.
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)

-- | Render a page to just a Html file.
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)

-- | Render a Page as Text.
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"