{-# 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) ((Text, Text, Html ()) -> Html ())
-> (Text, Text, Html ()) -> Html ()
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) ((Text, Text, Html ()) -> Html ())
-> (Text, Text, Html ()) -> Html ()
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 PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns of
    PageConcerns
Inline -> (Text
forall a. Monoid a => a
mempty, Text
forall a. Monoid a => a
mempty, Html ()
h)
    PageConcerns
Separated -> (Text
css, Text
js, Html ()
h)
  where
    h :: Html ()
h =
      case PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageStructure -> PageStructure
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "structure" (Optic' A_Lens NoIx PageConfig PageStructure)
Optic' A_Lens NoIx PageConfig PageStructure
#structure of
        PageStructure
HeaderBody ->
          Html ()
forall (m :: * -> *). Applicative m => HtmlT m ()
doctype_
            Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with
              Html () -> Html ()
forall arg result. Term arg result => arg -> result
html_
              [Text -> Attribute
lang_ Text
"en"]
              ( Html () -> Html ()
forall arg result. Term arg result => arg -> result
head_
                  ( [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
                      [ [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"utf-8"],
                        Html ()
cssInline,
                        [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
                        Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlHeader" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlHeader
                      ]
                  )
                  Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html () -> Html ()
forall arg result. Term arg result => arg -> result
body_
                    ( [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
                        [ Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlBody" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlBody,
                          [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
                          Html ()
jsInline
                        ]
                    )
              )
        PageStructure
Headless ->
          [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
            [ Html ()
forall (m :: * -> *). Applicative m => HtmlT m ()
doctype_,
              [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"utf-8"],
              [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
              Html ()
cssInline,
              Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlHeader" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlHeader,
              Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlBody" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlBody,
              [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
              Html ()
jsInline
            ]
        PageStructure
Snippet ->
          [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
            [ [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
              Html ()
cssInline,
              Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlHeader" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlHeader,
              Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlBody" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlBody,
              [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
              Html ()
jsInline
            ]
        PageStructure
Svg ->
          Html ()
svgDocType
            Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html () -> Html ()
forall arg result. Term arg result => arg -> result
svg_
              ( Html () -> Html ()
svgDefs (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$
                  [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat
                    [ [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsCss',
                      Html ()
cssInline,
                      Page
p Page -> Optic' A_Lens NoIx Page (Html ()) -> Html ()
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "htmlBody" (Optic' A_Lens NoIx Page (Html ()))
Optic' A_Lens NoIx Page (Html ())
#htmlBody,
                      [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat [Html ()]
libsJs',
                      Html ()
jsInline
                    ]
              )
    css :: Text
css = RepCss -> Text
rendercss (Page
p Page -> Optic' A_Lens NoIx Page RepCss -> RepCss
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "cssBody" (Optic' A_Lens NoIx Page RepCss)
Optic' A_Lens NoIx Page RepCss
#cssBody)
    js :: Text
js = RepJs -> Text
renderjs (Page
p Page -> Optic' A_Lens NoIx Page RepJs -> RepJs
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "jsGlobal" (Optic' A_Lens NoIx Page RepJs)
Optic' A_Lens NoIx Page RepJs
#jsGlobal RepJs -> RepJs -> RepJs
forall a. Semigroup a => a -> a -> a
<> RepJs -> RepJs
onLoad (Page
p Page -> Optic' A_Lens NoIx Page RepJs -> RepJs
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "jsOnLoad" (Optic' A_Lens NoIx Page RepJs)
Optic' A_Lens NoIx Page RepJs
#jsOnLoad))
    renderjs :: RepJs -> Text
renderjs = PageRender -> RepJs -> Text
renderRepJs (PageRender -> RepJs -> Text) -> PageRender -> RepJs -> Text
forall a b. (a -> b) -> a -> b
$ PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageRender -> PageRender
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "pageRender" (Optic' A_Lens NoIx PageConfig PageRender)
Optic' A_Lens NoIx PageConfig PageRender
#pageRender
    rendercss :: RepCss -> Text
rendercss = PageRender -> RepCss -> Text
renderRepCss (PageRender -> RepCss -> Text) -> PageRender -> RepCss -> Text
forall a b. (a -> b) -> a -> b
$ PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageRender -> PageRender
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "pageRender" (Optic' A_Lens NoIx PageConfig PageRender)
Optic' A_Lens NoIx PageConfig PageRender
#pageRender
    cssInline :: Html ()
cssInline
      | PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns PageConcerns -> PageConcerns -> Bool
forall a. Eq a => a -> a -> Bool
== PageConcerns
Separated Bool -> Bool -> Bool
|| Text
css Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty = Html ()
forall a. Monoid a => a
mempty
      | Bool
otherwise = [Attribute] -> Text -> Html ()
forall arg result. TermRaw arg result => arg -> result
style_ [Text -> Attribute
type_ Text
"text/css"] Text
css
    jsInline :: Html ()
jsInline
      | PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns PageConcerns -> PageConcerns -> Bool
forall a. Eq a => a -> a -> Bool
== PageConcerns
Separated Bool -> Bool -> Bool
|| Text
js Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty = Html ()
forall a. Monoid a => a
mempty
      | Bool
otherwise = [Attribute] -> Text -> Html ()
forall arg result. TermRaw arg result => arg -> result
script_ [Attribute]
forall a. Monoid a => a
mempty Text
js
    libsCss' :: [Html ()]
libsCss' =
      case PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns of
        PageConcerns
Inline -> Page
p Page -> Optic' A_Lens NoIx Page [Html ()] -> [Html ()]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "libsCss" (Optic' A_Lens NoIx Page [Html ()])
Optic' A_Lens NoIx Page [Html ()]
#libsCss
        PageConcerns
Separated ->
          Page
p Page -> Optic' A_Lens NoIx Page [Html ()] -> [Html ()]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "libsCss" (Optic' A_Lens NoIx Page [Html ()])
Optic' A_Lens NoIx Page [Html ()]
#libsCss
            [Html ()] -> [Html ()] -> [Html ()]
forall a. Semigroup a => a -> a -> a
<> [Text -> Html ()
libCss (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PageConfig
pc PageConfig -> Optic' A_Lens NoIx PageConfig FilePath -> FilePath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "filenames"
  (Optic
     A_Lens
     NoIx
     PageConfig
     PageConfig
     (Concerns FilePath)
     (Concerns FilePath))
Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns FilePath)
  (Concerns FilePath)
#filenames Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns FilePath)
  (Concerns FilePath)
-> Optic
     A_Lens
     NoIx
     (Concerns FilePath)
     (Concerns FilePath)
     FilePath
     FilePath
-> Optic' A_Lens NoIx PageConfig FilePath
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
% IsLabel
  "cssConcern"
  (Optic
     A_Lens
     NoIx
     (Concerns FilePath)
     (Concerns FilePath)
     FilePath
     FilePath)
Optic
  A_Lens
  NoIx
  (Concerns FilePath)
  (Concerns FilePath)
  FilePath
  FilePath
#cssConcern)]
    libsJs' :: [Html ()]
libsJs' =
      case PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns of
        PageConcerns
Inline -> Page
p Page -> Optic' A_Lens NoIx Page [Html ()] -> [Html ()]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "libsJs" (Optic' A_Lens NoIx Page [Html ()])
Optic' A_Lens NoIx Page [Html ()]
#libsJs
        PageConcerns
Separated ->
          Page
p Page -> Optic' A_Lens NoIx Page [Html ()] -> [Html ()]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "libsJs" (Optic' A_Lens NoIx Page [Html ()])
Optic' A_Lens NoIx Page [Html ()]
#libsJs
            [Html ()] -> [Html ()] -> [Html ()]
forall a. Semigroup a => a -> a -> a
<> [Text -> Html ()
libJs (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PageConfig
pc PageConfig -> Optic' A_Lens NoIx PageConfig FilePath -> FilePath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "filenames"
  (Optic
     A_Lens
     NoIx
     PageConfig
     PageConfig
     (Concerns FilePath)
     (Concerns FilePath))
Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns FilePath)
  (Concerns FilePath)
#filenames Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns FilePath)
  (Concerns FilePath)
-> Optic
     A_Lens
     NoIx
     (Concerns FilePath)
     (Concerns FilePath)
     FilePath
     FilePath
-> Optic' A_Lens NoIx PageConfig FilePath
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
% IsLabel
  "jsConcern"
  (Optic
     A_Lens
     NoIx
     (Concerns FilePath)
     (Concerns FilePath)
     FilePath
     FilePath)
Optic
  A_Lens
  NoIx
  (Concerns FilePath)
  (Concerns FilePath)
  FilePath
  FilePath
#jsConcern)]

-- | Render Page concerns to files.
renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageToFile :: FilePath -> PageConfig -> Page -> IO ()
renderPageToFile FilePath
dir PageConfig
pc Page
page =
  Concerns (IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ (Concerns (IO ()) -> IO ()) -> Concerns (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> IO ())
-> Concerns FilePath -> Concerns FilePath -> Concerns (IO ())
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 FilePath -> FilePath -> IO ()
writeFile' (PageConfig
pc PageConfig
-> Optic
     A_Lens
     NoIx
     PageConfig
     PageConfig
     (Concerns FilePath)
     (Concerns FilePath)
-> Concerns FilePath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "filenames"
  (Optic
     A_Lens
     NoIx
     PageConfig
     PageConfig
     (Concerns FilePath)
     (Concerns FilePath))
Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns FilePath)
  (Concerns FilePath)
#filenames) ((Text -> FilePath) -> Concerns Text -> Concerns FilePath
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 = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
forall a. Monoid a => a
mempty) (FilePath -> FilePath -> IO ()
writeFile (FilePath
dir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> 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 (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Html () -> Text
forall a. Html a -> Text
toText (Html () -> Text) -> Html () -> Text
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 PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "concerns" (Optic' A_Lens NoIx PageConfig PageConcerns)
Optic' A_Lens NoIx PageConfig PageConcerns
#concerns of
    PageConcerns
Inline -> Text -> Text -> Text -> Concerns Text
forall a. a -> a -> a -> Concerns a
Concerns Text
forall a. Monoid a => a
mempty Text
forall a. Monoid a => a
mempty Text
htmlt
    PageConcerns
Separated -> Text -> Text -> Text -> Concerns Text
forall a. a -> a -> a -> Concerns a
Concerns Text
css Text
js Text
htmlt
  where
    htmlt :: Text
htmlt = Html () -> Text
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 = Text -> Html () -> Html ()
forall arg result. Term arg result => Text -> arg -> result
term Text
"defs"