{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}

module Web.View.Render where

import Data.ByteString.Lazy qualified as BL
import Data.Function ((&))
import Data.List (foldl')
import Data.Map qualified as M
import Data.Maybe (mapMaybe)
import Data.String.Interpolate (i)
import Data.Text (Text, intercalate, pack, toLower)
import Data.Text qualified as T
import Data.Text.Lazy qualified as L
import Data.Text.Lazy.Encoding qualified as LE
import HTMLEntities.Text qualified as HE
import Web.View.Types
import Web.View.View (View, ViewState (..), runView)


{- | 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


data Line
  = Line {Line -> LineEnd
end :: LineEnd, Line -> Int
indent :: Int, Line -> Text
text :: Text}
  deriving (Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Line -> ShowS
showsPrec :: Int -> Line -> ShowS
$cshow :: Line -> String
show :: Line -> String
$cshowList :: [Line] -> ShowS
showList :: [Line] -> ShowS
Show)


data LineEnd
  = Newline
  | Inline
  deriving (LineEnd -> LineEnd -> Bool
(LineEnd -> LineEnd -> Bool)
-> (LineEnd -> LineEnd -> Bool) -> Eq LineEnd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineEnd -> LineEnd -> Bool
== :: LineEnd -> LineEnd -> Bool
$c/= :: LineEnd -> LineEnd -> Bool
/= :: LineEnd -> LineEnd -> Bool
Eq, Int -> LineEnd -> ShowS
[LineEnd] -> ShowS
LineEnd -> String
(Int -> LineEnd -> ShowS)
-> (LineEnd -> String) -> ([LineEnd] -> ShowS) -> Show LineEnd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LineEnd -> ShowS
showsPrec :: Int -> LineEnd -> ShowS
$cshow :: LineEnd -> String
show :: LineEnd -> String
$cshowList :: [LineEnd] -> ShowS
showList :: [LineEnd] -> ShowS
Show)


-- | Render lines to text
renderLines :: [Line] -> Text
renderLines :: [Line] -> Text
renderLines = (Bool, Text) -> Text
forall a b. (a, b) -> b
snd ((Bool, Text) -> Text)
-> ([Line] -> (Bool, Text)) -> [Line] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Text) -> Line -> (Bool, Text))
-> (Bool, Text) -> [Line] -> (Bool, Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bool, Text) -> Line -> (Bool, Text)
nextLine (Bool
False, Text
"")
 where
  nextLine :: (Bool, Text) -> Line -> (Bool, Text)
  nextLine :: (Bool, Text) -> Line -> (Bool, Text)
nextLine (Bool
newline, Text
t) Line
l = (Line -> Bool
forall {r}. HasField "end" r LineEnd => r -> Bool
nextNewline Line
l, Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Line -> Text
currentLine Bool
newline Line
l)

  currentLine :: Bool -> Line -> Text
  currentLine :: Bool -> Line -> Text
currentLine Bool
newline Line
l
    | Bool
newline = Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Line
l.indent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Line
l.text
    | Bool
otherwise = Line
l.text

  nextNewline :: r -> Bool
nextNewline r
l = r
l.end LineEnd -> LineEnd -> Bool
forall a. Eq a => a -> a -> Bool
== LineEnd
Newline

  spaces :: Int -> Text
spaces Int
n = Int -> Text -> Text
T.replicate Int
n Text
" "


{- | 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 ()
vw =
  let vst :: ViewState
vst = c -> View c () -> ViewState
forall context. context -> View context () -> ViewState
runView c
c View c ()
vw
      css :: [Text]
css = CSS -> [Text]
renderCSS ViewState
vst.css
   in [Text] -> Text -> Text
addCss [Text]
css (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Line] -> Text
renderLines ([Line] -> Text) -> [Line] -> Text
forall a b. (a -> b) -> a -> b
$ [[Line]] -> [Line]
forall a. Monoid a => [a] -> a
mconcat ([[Line]] -> [Line]) -> [[Line]] -> [Line]
forall a b. (a -> b) -> a -> b
$ (Content -> [Line]) -> [Content] -> [[Line]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Content -> [Line]
renderContent Int
2) ViewState
vst.contents
 where
  addCss :: [Text] -> Text -> Text
  addCss :: [Text] -> Text -> Text
addCss [] Text
cnt = Text
cnt
  addCss [Text]
css Text
cnt = do
    [Line] -> Text
renderLines (Int -> Content -> [Line]
renderContent Int
2 (Content -> [Line]) -> Content -> [Line]
forall a b. (a -> b) -> a -> b
$ [Text] -> Content
styleElement [Text]
css) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cnt

  styleElement :: [Text] -> Content
  styleElement :: [Text] -> Content
styleElement [Text]
css =
    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")]) ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ do
      Content -> [Content]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Content -> [Content]) -> Content -> [Content]
forall a b. (a -> b) -> a -> b
$ Text -> Content
Text (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"\n" [Text]
css Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"


renderContent :: Int -> Content -> [Line]
renderContent :: Int -> Content -> [Line]
renderContent Int
ind (Node Element
t) = Int -> Element -> [Line]
renderTag Int
ind Element
t
renderContent Int
_ (Text Text
t) = [LineEnd -> Int -> Text -> Line
Line LineEnd
Inline Int
0 (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ Text -> Text
HE.text Text
t]
renderContent Int
_ (Raw Text
t) = [LineEnd -> Int -> Text -> Line
Line LineEnd
Newline Int
0 Text
t]


renderTag :: Int -> Element -> [Line]
renderTag :: Int -> Element -> [Line]
renderTag Int
ind Element
tag =
  case Element
tag.children of
    [] ->
      -- auto closing creates a bug in chrome. An auto-closed div
      -- absorbs the next children
      [Text -> Line
line (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ 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 -> Line
line (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ 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 -> Text
HE.text Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
close]
    [Content]
_ ->
      [[Line]] -> [Line]
forall a. Monoid a => [a] -> a
mconcat
        [ [Text -> Line
line (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ 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
">"]
        , (Line -> Line) -> [Line] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Line -> Line
addIndent Int
ind) ([Line] -> [Line]) -> [Line] -> [Line]
forall a b. (a -> b) -> a -> b
$ [Content] -> [Line]
htmlChildren Element
tag.children
        , [Text -> Line
line 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
">"

  line :: Text -> Line
line Text
t =
    if Element
tag.inline
      then LineEnd -> Int -> Text -> Line
Line LineEnd
Inline Int
0 Text
t
      else LineEnd -> Int -> Text -> Line
Line LineEnd
Newline Int
0 Text
t

  htmlChildren :: [Content] -> [Line]
  htmlChildren :: [Content] -> [Line]
htmlChildren [Content]
cts =
    [[Line]] -> [Line]
forall a. Monoid a => [a] -> a
mconcat ([[Line]] -> [Line]) -> [[Line]] -> [Line]
forall a b. (a -> b) -> a -> b
$
      (Content -> [Line]) -> [Content] -> [[Line]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Content -> [Line]
renderContent Int
ind) [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
T.unwords (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
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 :: (Text, Text) -> Text
htmlAtt (Text
k, Text
v) =
      Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
HE.text Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"


addIndent :: Int -> Line -> Line
addIndent :: Int -> Line -> Line
addIndent Int
n (Line LineEnd
e Int
ind Text
t) = LineEnd -> Int -> Text -> Line
Line LineEnd
e (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Text
t


renderCSS :: CSS -> [Text]
renderCSS :: CSS -> [Text]
renderCSS = (Class -> Maybe Text) -> [Class] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe 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 -> Maybe Text
  renderClass :: Class -> Maybe Text
renderClass Class
c | Map Text StyleValue -> Bool
forall k a. Map k a -> Bool
M.null Class
c.properties = Maybe Text
forall a. Maybe a
Nothing
  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 Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [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
T.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