{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Web.View.Render where

import Data.ByteString.Lazy qualified as BL
import Data.Function ((&))
import Data.Map qualified as M
import Data.String.Interpolate (i)
import Data.Text (Text, intercalate, pack, toLower, unlines, unwords)
import Data.Text.Lazy qualified as L
import Data.Text.Lazy.Encoding qualified as LE
import Web.View.View (View, ViewState (..), runView, viewInsertContents)
import Prelude hiding (unlines, unwords)

-- import Debug.Trace
import Web.View.Types


{- | Renders a 'View' as HTML with embedded CSS class definitions

>>> renderText $ el bold "Hello"
<style type='text/css'>.bold { font-weight:bold }</style>
<div class='bold'>Hello</div>
-}
renderText :: View () () -> Text
renderText :: View () () -> Text
renderText = () -> View () () -> Text
forall c. c -> View c () -> Text
renderText' ()


renderLazyText :: View () () -> L.Text
renderLazyText :: View () () -> Text
renderLazyText = Text -> Text
L.fromStrict (Text -> Text) -> (View () () -> Text) -> View () () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View () () -> Text
renderText


renderLazyByteString :: View () () -> BL.ByteString
renderLazyByteString :: View () () -> ByteString
renderLazyByteString = Text -> ByteString
LE.encodeUtf8 (Text -> ByteString)
-> (View () () -> Text) -> View () () -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View () () -> Text
renderLazyText


{- | Render with the specified view context

> renderText' () $ el bold "Hello"
-}
renderText' :: c -> View c () -> Text
renderText' :: forall c. c -> View c () -> Text
renderText' c
c View c ()
u = Text -> [Text] -> Text
intercalate Text
"\n" [Text]
content
 where
  -- T.intercalate "\n" (content <> style css)
  content :: [Text]
  content :: [Text]
content = (Content -> Text) -> [Content] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
unlines ([Text] -> Text) -> (Content -> [Text]) -> Content -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> [Text]
renderContent) ([Content] -> [Text])
-> (ViewState -> [Content]) -> ViewState -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.contents) (ViewState -> [Text]) -> ViewState -> [Text]
forall a b. (a -> b) -> a -> b
$ c -> View c () -> ViewState
forall context. context -> View context () -> ViewState
runView c
c View c ()
addCss

  addCss :: View c ()
addCss = do
    [Content] -> View c ()
forall c. [Content] -> View c ()
viewInsertContents [Item [Content]
Content
styleElement]
    View c ()
u

  css :: [Text]
  css :: [Text]
css = CSS -> [Text]
renderCSS (CSS -> [Text]) -> CSS -> [Text]
forall a b. (a -> b) -> a -> b
$ (.css) (ViewState -> CSS) -> ViewState -> CSS
forall a b. (a -> b) -> a -> b
$ c -> View c () -> ViewState
forall context. context -> View context () -> ViewState
runView c
c View c ()
u

  styleElement :: Content
  styleElement :: Content
styleElement =
    Element -> Content
Node (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> [Content] -> Element
Element Text
"style" ([Class] -> Map Text Text -> Attributes
Attributes [] [(Text
"type", Text
"text/css")]) [Text -> Content
Text (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
intercalate Text
"\n" [Text]
css]

  renderContent :: Content -> [Text]
  renderContent :: Content -> [Text]
renderContent (Node Element
t) = (Text -> Text) -> Element -> [Text]
renderTag Text -> Text
indent Element
t
  renderContent (Text Text
t) = [Item [Text]
Text
t]
  renderContent (Raw Text
t) = [Item [Text]
Text
t]


renderTag :: (Text -> Text) -> Element -> [Text]
renderTag :: (Text -> Text) -> Element -> [Text]
renderTag Text -> Text
ind Element
tag =
  case Element
tag.children of
    [] ->
      -- auto closing creates a bug in chrome. An auto-closed div
      -- absorbs the next children
      [Text
open Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> Text
htmlAtts (Element -> FlatAttributes
flatAttributes Element
tag) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
close]
    -- single text node
    [Text Text
t] ->
      -- SINGLE text node, just display it indented
      [Text
open Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> Text
htmlAtts (Element -> FlatAttributes
flatAttributes Element
tag) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
close]
    [Content]
_ ->
      [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat
        [ [Text
open Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> Text
htmlAtts (Element -> FlatAttributes
flatAttributes Element
tag) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"]
        , Text -> Text
ind (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Content] -> [Text]
htmlChildren Element
tag.children
        , [Item [Text]
Text
close]
        ]
 where
  open :: Text
open = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element
tag.name
  close :: Text
close = Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element
tag.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"

  htmlContent :: Content -> [Text]
  htmlContent :: Content -> [Text]
htmlContent (Node Element
t) = (Text -> Text) -> Element -> [Text]
renderTag Text -> Text
ind Element
t
  htmlContent (Text Text
t) = [Item [Text]
Text
t]
  htmlContent (Raw Text
t) = [Item [Text]
Text
t]

  htmlChildren :: [Content] -> [Text]
  htmlChildren :: [Content] -> [Text]
htmlChildren [Content]
cts =
    [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat
      ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Content -> [Text]) -> [Content] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Content -> [Text]
htmlContent [Content]
cts

  htmlAtts :: FlatAttributes -> Text
  htmlAtts :: FlatAttributes -> Text
htmlAtts (FlatAttributes []) = Text
""
  htmlAtts (FlatAttributes Map Text Text
as) =
    Text
" "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unwords (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall {a}. (Semigroup a, IsString a) => (a, a) -> a
htmlAtt ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
as)
   where
    htmlAtt :: (a, a) -> a
htmlAtt (a
k, a
v) =
      a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"


renderCSS :: CSS -> [Text]
renderCSS :: CSS -> [Text]
renderCSS = (Class -> Text) -> [Class] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Class -> Text
renderClass ([Class] -> [Text]) -> (CSS -> [Class]) -> CSS -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSS -> [Class]
forall k a. Map k a -> [a]
M.elems
 where
  renderClass :: Class -> Text
  renderClass :: Class -> Text
renderClass Class
c =
    let sel :: Text
sel = Selector -> Text
selectorText Class
c.selector
        props :: Text
props = Text -> [Text] -> Text
intercalate Text
"; " (((Text, StyleValue) -> Text) -> [(Text, StyleValue)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, StyleValue) -> Text
renderProp ([(Text, StyleValue)] -> [Text]) -> [(Text, StyleValue)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text StyleValue -> [(Text, StyleValue)]
forall k a. Map k a -> [(k, a)]
M.toList Class
c.properties)
     in [i|#{sel} { #{props} }|] Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Maybe Media -> Text -> Text
forall {src}.
(Interpolatable (IsCustomSink src) src src,
 Interpolatable (IsCustomSink src) Text src) =>
Maybe Media -> src -> src
addMedia Class
c.selector.media

  addMedia :: Maybe Media -> src -> src
addMedia Maybe Media
Nothing src
css = src
css
  addMedia (Just Media
m) src
css =
    let mc :: Text
mc = Media -> Text
mediaCriteria Media
m
     in [i|@media #{mc} { #{css} }|]

  mediaCriteria :: Media -> Text
  mediaCriteria :: Media -> Text
mediaCriteria (MinWidth Int
n) = [i|(min-width: #{n}px)|]
  mediaCriteria (MaxWidth Int
n) = [i|(max-width: #{n}px)|]

  renderProp :: (Text, StyleValue) -> Text
  renderProp :: (Text, StyleValue) -> Text
renderProp (Text
p, StyleValue
cv) = Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StyleValue -> Text
renderStyle StyleValue
cv

  renderStyle :: StyleValue -> Text
  renderStyle :: StyleValue -> Text
renderStyle (StyleValue String
v) = String -> Text
pack String
v


indent :: Text -> Text
indent :: Text -> Text
indent Text
t = Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t


-- | The css selector for this style
selectorText :: Selector -> Text
selectorText :: Selector -> Text
selectorText Selector
s =
  Maybe Text -> Text
forall {a}. (IsString a, Semigroup a) => Maybe a -> a
parent Selector
s.parent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Pseudo -> Text -> Text
addPseudo Selector
s.pseudo (Maybe Media -> Maybe Text -> Maybe Pseudo -> ClassName -> Text
classNameElementText Selector
s.media Selector
s.parent Maybe Pseudo
forall a. Maybe a
Nothing Selector
s.className)
 where
  parent :: Maybe a -> a
parent Maybe a
Nothing = a
""
  parent (Just a
p) = a
"." a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
p a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" "

  addPseudo :: Maybe Pseudo -> Text -> Text
addPseudo Maybe Pseudo
Nothing Text
c = Text
c
  addPseudo (Just Pseudo
p) Text
c =
    Pseudo -> Text
pseudoText Pseudo
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\\:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pseudo -> Text
pseudoSuffix Pseudo
p

  pseudoSuffix :: Pseudo -> Text
  pseudoSuffix :: Pseudo -> Text
pseudoSuffix Pseudo
Even = Text
"nth-child(even)"
  pseudoSuffix Pseudo
Odd = Text
"nth-child(odd)"
  pseudoSuffix Pseudo
p = Pseudo -> Text
pseudoText Pseudo
p


-- | The class name as it appears in the element
classNameElementText :: Maybe Media -> Maybe Text -> Maybe Pseudo -> ClassName -> Text
classNameElementText :: Maybe Media -> Maybe Text -> Maybe Pseudo -> ClassName -> Text
classNameElementText Maybe Media
mm Maybe Text
mp Maybe Pseudo
mps ClassName
c =
  Maybe Media -> Text -> Text
addMedia Maybe Media
mm (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Pseudo -> Text -> Text
addPseudo Maybe Pseudo
mps (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text -> Text
forall {p}. (Semigroup p, IsString p) => Maybe p -> p -> p
addParent Maybe Text
mp (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ClassName
c.text
 where
  addParent :: Maybe p -> p -> p
addParent Maybe p
Nothing p
cn = p
cn
  addParent (Just p
p) p
cn = p
p p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"-" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
cn

  addPseudo :: Maybe Pseudo -> Text -> Text
  addPseudo :: Maybe Pseudo -> Text -> Text
addPseudo Maybe Pseudo
Nothing Text
cn = Text
cn
  addPseudo (Just Pseudo
p) Text
cn =
    Pseudo -> Text
pseudoText Pseudo
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn

  addMedia :: Maybe Media -> Text -> Text
  addMedia :: Maybe Media -> Text -> Text
addMedia Maybe Media
Nothing Text
cn = Text
cn
  addMedia (Just (MinWidth Int
n)) Text
cn =
    [i|mmnw#{n}-#{cn}|]
  addMedia (Just (MaxWidth Int
n)) Text
cn =
    [i|mmxw#{n}-#{cn}|]


pseudoText :: Pseudo -> Text
pseudoText :: Pseudo -> Text
pseudoText Pseudo
p = Text -> Text
toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Pseudo -> String
forall a. Show a => a -> String
show Pseudo
p


-- | The 'Web.View.Types.Attributes' for an element, inclusive of class.
flatAttributes :: Element -> FlatAttributes
flatAttributes :: Element -> FlatAttributes
flatAttributes Element
t =
  Map Text Text -> FlatAttributes
FlatAttributes
    (Map Text Text -> FlatAttributes)
-> Map Text Text -> FlatAttributes
forall a b. (a -> b) -> a -> b
$ [Class] -> Map Text Text -> Map Text Text
forall {k}.
(Ord k, IsString k) =>
[Class] -> Map k Text -> Map k Text
addClass Element
t.attributes.classes Element
t.attributes.other
 where
  addClass :: [Class] -> Map k Text -> Map k Text
addClass [] Map k Text
atts = Map k Text
atts
  addClass [Class]
cx Map k Text
atts = k -> Text -> Map k Text -> Map k Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
"class" ([Class] -> Text
classAttValue [Class]
cx) Map k Text
atts

  classAttValue :: [Class] -> Text
  classAttValue :: [Class] -> Text
classAttValue [Class]
cx =
    [Text] -> Text
unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Class -> Text) -> [Class] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Class
c -> Maybe Media -> Maybe Text -> Maybe Pseudo -> ClassName -> Text
classNameElementText Class
c.selector.media Class
c.selector.parent Class
c.selector.pseudo Class
c.selector.className) [Class]
cx

-- showView :: c -> View c () -> Text
-- showView c v =
--   let st = runView c v
--    in unlines $ mconcat $ map renderContent st.contents