{-# LANGUAGE OverloadedLists #-}

module Web.Atomic.Render where

import Data.ByteString.Lazy qualified as BL
import Data.List qualified as L
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Maybe (mapMaybe)
import Data.String (IsString (..))
import Data.Text (Text, intercalate, pack)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TLE
import HTMLEntities.Text qualified as HE
import Web.Atomic.Html
import Web.Atomic.Types


renderLazyText :: Html () -> TL.Text
renderLazyText :: Html () -> Text
renderLazyText = StrictText -> Text
TL.fromStrict (StrictText -> Text) -> (Html () -> StrictText) -> Html () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html () -> StrictText
renderText


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


renderText :: Html () -> Text
renderText :: Html () -> StrictText
renderText Html ()
html =
  let cs :: [Line]
cs = Map Selector Rule -> [Line]
cssRulesLines (Map Selector Rule -> [Line]) -> Map Selector Rule -> [Line]
forall a b. (a -> b) -> a -> b
$ Html () -> Map Selector Rule
forall a. Html a -> Map Selector Rule
htmlCSSRules Html ()
html
   in [Line] -> StrictText
renderLines ([Line] -> StrictText) -> [Line] -> StrictText
forall a b. (a -> b) -> a -> b
$ [Line] -> [Line] -> [Line]
addCss [Line]
cs ([Line] -> [Line]) -> [Line] -> [Line]
forall a b. (a -> b) -> a -> b
$ Int -> Html () -> [Line]
forall a. Int -> Html a -> [Line]
htmlLines Int
2 Html ()
html
 where
  addCss :: [Line] -> [Line] -> [Line]
  addCss :: [Line] -> [Line] -> [Line]
addCss [] [Line]
cnt = [Line]
cnt
  addCss [Line]
cs [Line]
cnt = do
    [Line] -> [Line]
styleLines [Line]
cs [Line] -> [Line] -> [Line]
forall a. Semigroup a => a -> a -> a
<> (LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 StrictText
"" Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
: [Line]
cnt)


htmlLines :: Int -> Html a -> [Line]
htmlLines :: forall a. Int -> Html a -> [Line]
htmlLines Int
ind (Html a
_ [Node]
ns) = Int -> [Node] -> [Line]
nodesLines Int
ind [Node]
ns


nodesLines :: Int -> [Node] -> [Line]
nodesLines :: Int -> [Node] -> [Line]
nodesLines Int
ind [Node]
ns = [[Line]] -> [Line]
forall a. Monoid a => [a] -> a
mconcat ([[Line]] -> [Line]) -> [[Line]] -> [Line]
forall a b. (a -> b) -> a -> b
$ (Node -> [Line]) -> [Node] -> [[Line]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Node -> [Line]
nodeLines Int
ind) [Node]
ns


nodeLines :: Int -> Node -> [Line]
nodeLines :: Int -> Node -> [Line]
nodeLines Int
ind (Elem Element
e) = Int -> Element -> [Line]
elementLines Int
ind Element
e
nodeLines Int
_ (Text StrictText
t) = [LineEnd -> Int -> StrictText -> Line
Line LineEnd
Inline Int
0 (StrictText -> Line) -> StrictText -> Line
forall a b. (a -> b) -> a -> b
$ StrictText -> StrictText
HE.text StrictText
t]
nodeLines Int
_ (Raw StrictText
t) = [LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 StrictText
t]


elementLines :: Int -> Element -> [Line]
elementLines :: Int -> Element -> [Line]
elementLines Int
ind Element
elm =
  -- special rendering cases for the children
  case (Element
elm.content :: [Node]) of
    [] ->
      -- auto closing creates a bug in chrome. An auto-closed div
      -- absorbs the next children
      [StrictText -> Line
line (StrictText -> Line) -> StrictText -> Line
forall a b. (a -> b) -> a -> b
$ StrictText
open StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> StrictText
renderAttributes (Element -> FlatAttributes
elementAttributes Element
elm) StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
">" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
close]
    [Text StrictText
t] ->
      -- SINGLE text node, just display it indented
      [StrictText -> Line
line (StrictText -> Line) -> StrictText -> Line
forall a b. (a -> b) -> a -> b
$ StrictText
open StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> StrictText
renderAttributes (Element -> FlatAttributes
elementAttributes Element
elm) StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
">" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText -> StrictText
HE.text StrictText
t StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
close]
    [Node]
children ->
      -- normal indented rendering
      [[Line]] -> [Line]
forall a. Monoid a => [a] -> a
mconcat
        [ [StrictText -> Line
line (StrictText -> Line) -> StrictText -> Line
forall a b. (a -> b) -> a -> b
$ StrictText
open StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> FlatAttributes -> StrictText
renderAttributes (Element -> FlatAttributes
elementAttributes Element
elm) StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
">"]
        , (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
$ Int -> [Node] -> [Line]
nodesLines Int
ind [Node]
children
        , [StrictText -> Line
line StrictText
close]
        ]
 where
  open :: StrictText
open = StrictText
"<" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> Element
elm.name
  close :: StrictText
close = StrictText
"</" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> Element
elm.name StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
">"

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


-- Attributes ---------------------------------------------------

-- | Element's attributes do not include class, which is separated. FlatAttributes generate the class attribute and include it
newtype FlatAttributes = FlatAttributes (Map Name AttValue)
  deriving newtype (FlatAttributes -> FlatAttributes -> Bool
(FlatAttributes -> FlatAttributes -> Bool)
-> (FlatAttributes -> FlatAttributes -> Bool) -> Eq FlatAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlatAttributes -> FlatAttributes -> Bool
== :: FlatAttributes -> FlatAttributes -> Bool
$c/= :: FlatAttributes -> FlatAttributes -> Bool
/= :: FlatAttributes -> FlatAttributes -> Bool
Eq)


-- | The 'FlatAttributes' for an element, inclusive of class.
elementAttributes :: Element -> FlatAttributes
elementAttributes :: Element -> FlatAttributes
elementAttributes Element
e =
  Map StrictText StrictText -> FlatAttributes
FlatAttributes (Map StrictText StrictText -> FlatAttributes)
-> Map StrictText StrictText -> FlatAttributes
forall a b. (a -> b) -> a -> b
$
    StrictText
-> Map StrictText StrictText -> Map StrictText StrictText
addClasses
      (Element -> StrictText
styleClass Element
e)
      Element
e.attributes
 where
  addClasses :: AttValue -> Map Name AttValue -> Map Name AttValue
  addClasses :: StrictText
-> Map StrictText StrictText -> Map StrictText StrictText
addClasses StrictText
"" Map StrictText StrictText
as = Map StrictText StrictText
as
  addClasses StrictText
av Map StrictText StrictText
as = (StrictText -> StrictText -> StrictText)
-> StrictText
-> StrictText
-> Map StrictText StrictText
-> Map StrictText StrictText
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\StrictText
a StrictText
b -> StrictText
a StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
" " StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
b) StrictText
"class" StrictText
av Map StrictText StrictText
as

  styleClass :: Element -> AttValue
  styleClass :: Element -> StrictText
styleClass Element
elm =
    [ClassName] -> StrictText
classesAttValue (Element -> [ClassName]
elementClasses Element
elm)


renderAttributes :: FlatAttributes -> Text
renderAttributes :: FlatAttributes -> StrictText
renderAttributes (FlatAttributes Map StrictText StrictText
m) =
  case Map StrictText StrictText
m of
    [] -> StrictText
""
    Map StrictText StrictText
as -> StrictText
" " StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> [StrictText] -> StrictText
T.unwords (((StrictText, StrictText) -> StrictText)
-> [(StrictText, StrictText)] -> [StrictText]
forall a b. (a -> b) -> [a] -> [b]
map (StrictText, StrictText) -> StrictText
htmlAtt ([(StrictText, StrictText)] -> [StrictText])
-> [(StrictText, StrictText)] -> [StrictText]
forall a b. (a -> b) -> a -> b
$ Map StrictText StrictText -> [(StrictText, StrictText)]
forall k a. Map k a -> [(k, a)]
M.toList Map StrictText StrictText
as)
 where
  htmlAtt :: (StrictText, StrictText) -> StrictText
htmlAtt (StrictText
k, StrictText
v) =
    StrictText
k StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
"=" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
"'" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText -> StrictText
HE.text StrictText
v StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
"'"


-- REnder CSS --------------------------------------------

cssRulesLines :: Map Selector Rule -> [Line]
cssRulesLines :: Map Selector Rule -> [Line]
cssRulesLines = (Rule -> Maybe Line) -> [Rule] -> [Line]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Rule -> Maybe Line
cssRuleLine ([Rule] -> [Line])
-> (Map Selector Rule -> [Rule]) -> Map Selector Rule -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Selector Rule -> [Rule]
forall k a. Map k a -> [a]
M.elems


cssRuleLine :: Rule -> Maybe Line
cssRuleLine :: Rule -> Maybe Line
cssRuleLine Rule
r | [Declaration] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Rule
r.properties = Maybe Line
forall a. Maybe a
Nothing
cssRuleLine Rule
r =
  let sel :: StrictText
sel = (Rule -> Selector
ruleSelector Rule
r).text
      props :: StrictText
props = StrictText -> [StrictText] -> StrictText
intercalate StrictText
"; " ((Declaration -> StrictText) -> [Declaration] -> [StrictText]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> StrictText
renderProp Rule
r.properties)
      med :: MediaQuery
med = [MediaQuery] -> MediaQuery
forall a. Monoid a => [a] -> a
mconcat ([MediaQuery] -> MediaQuery) -> [MediaQuery] -> MediaQuery
forall a b. (a -> b) -> a -> b
$ (Media -> MediaQuery) -> [Media] -> [MediaQuery]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Media -> MediaQuery
mediaCriteria Rule
r.media
   in Line -> Maybe Line
forall a. a -> Maybe a
Just (Line -> Maybe Line) -> Line -> Maybe Line
forall a b. (a -> b) -> a -> b
$ LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 (StrictText -> Line) -> StrictText -> Line
forall a b. (a -> b) -> a -> b
$ MediaQuery -> StrictText -> StrictText
wrapMedia MediaQuery
med (StrictText -> StrictText) -> StrictText -> StrictText
forall a b. (a -> b) -> a -> b
$ StrictText
sel StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
" { " StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
props StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
" }"
 where
  renderProp :: Declaration -> Text
  renderProp :: Declaration -> StrictText
renderProp ((Property StrictText
p) :. Style
cv) = StrictText
p StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
":" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> Style -> StrictText
renderStyle Style
cv

  renderStyle :: Style -> Text
  renderStyle :: Style -> StrictText
renderStyle (Style String
v) = String -> StrictText
pack String
v


wrapMedia :: MediaQuery -> Text -> Text
wrapMedia :: MediaQuery -> StrictText -> StrictText
wrapMedia [] StrictText
cnt = StrictText
cnt
wrapMedia MediaQuery
mqs StrictText
cnt =
  StrictText
"@media " StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> MediaQuery -> StrictText
mediaConditionsText MediaQuery
mqs StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
" { " StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
cnt StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
" }"
 where
  mediaConditionsText :: MediaQuery -> Text
  mediaConditionsText :: MediaQuery -> StrictText
mediaConditionsText (MediaQuery [StrictText]
cons) =
    StrictText -> [StrictText] -> StrictText
T.intercalate StrictText
" and " ([StrictText] -> StrictText) -> [StrictText] -> StrictText
forall a b. (a -> b) -> a -> b
$ (StrictText -> StrictText) -> [StrictText] -> [StrictText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\StrictText
c -> StrictText
"(" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
c StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> StrictText
")") [StrictText]
cons


styleLines :: [Line] -> [Line]
styleLines :: [Line] -> [Line]
styleLines [] = []
styleLines [Line]
rulesLines =
  [LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 StrictText
"<style type='text/css'>"]
    [Line] -> [Line] -> [Line]
forall a. Semigroup a => a -> a -> a
<> [Line]
rulesLines
    [Line] -> [Line] -> [Line]
forall a. Semigroup a => a -> a -> a
<> [LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 StrictText
"</style>"]


-- Lines ---------------------------------------
-- control inline vs newlines and indent

data Line = Line {Line -> LineEnd
end :: LineEnd, Line -> Int
indent :: Int, Line -> StrictText
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, Line -> Line -> Bool
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
/= :: Line -> Line -> Bool
Eq)


instance IsString Line where
  fromString :: String -> Line
fromString String
s = LineEnd -> Int -> StrictText -> Line
Line LineEnd
Newline Int
0 (String -> StrictText
pack String
s)


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)


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


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

  currentLine :: Bool -> Line -> Text
  currentLine :: Bool -> Line -> StrictText
currentLine Bool
newline Line
l
    | Bool
newline = StrictText
"\n" StrictText -> StrictText -> StrictText
forall a. Semigroup a => a -> a -> a
<> Int -> StrictText
spaces Line
l.indent StrictText -> StrictText -> StrictText
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 -> StrictText
spaces Int
n = Int -> StrictText -> StrictText
T.replicate Int
n StrictText
" "