{-# LANGUAGE NamedFieldPuns #-}
module Rendering where

import           Data.Aeson
import           Data.ByteString.Lazy.Char8 (unpack)
import           Unsafe.Coerce

import           Component

isOn :: Attributes a -> Bool
isOn :: forall a. Attributes a -> Bool
isOn (On String
_ Identifier
_ Maybe String -> a
_) = Bool
True
isOn Attributes a
_          = Bool
False

isGeneric :: Attributes a -> Bool
isGeneric :: forall a. Attributes a -> Bool
isGeneric (Generic String
_ String
_) = Bool
True
isGeneric Attributes a
_             = Bool
False

isClass :: Attributes a -> Bool
isClass :: forall a. Attributes a -> Bool
isClass (Generic String
"class" String
_) = Bool
True
isClass Attributes a
_                   = Bool
False

getStyle :: Attributes a -> String
getStyle :: forall a. Attributes a -> String
getStyle (Style (String
hash, String
style')) =
  -- inline styles are just given a hash of -1
  if String
hash String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-1" then String
style' else String
""
getStyle Attributes a
_ = String
""

getClassBasedStyle :: Attributes a -> String
getClassBasedStyle :: forall a. Attributes a -> String
getClassBasedStyle (Style (String
hash, String
style')) =
  -- earlier we set the style' to "" to say it's been captured
  -- also filter out things like "p123 li", which are created
  -- by nested rules in [style||] templates
  if String
style' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" Bool -> Bool -> Bool
&& Bool -> Bool
not (Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hash) then String
hash else String
""
getClassBasedStyle Attributes a
_ = String
""

renderGeneric :: Attributes a -> String
renderGeneric :: forall a. Attributes a -> String
renderGeneric Attributes a
attr = case Attributes a
attr of
  (Generic String
name String
value) -> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (String -> ByteString
forall a. ToJSON a => a -> ByteString
encode String
value)
  Attributes a
_                    -> String
""

renderAttributes :: [Attributes a] -> String
renderAttributes :: forall a. [Attributes a] -> String
renderAttributes [Attributes a]
attrs =
  let
    styles :: String
styles = (Attributes a -> String) -> [Attributes a] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Attributes a -> String
forall a. Attributes a -> String
getStyle [Attributes a]
attrs
    renderedStyle :: String
renderedStyle = if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
styles) then String
" style=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
styles else String
""

    -- TODO: this is uggo
    classStyles :: [String]
classStyles = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Attributes a -> String) -> [Attributes a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attributes a -> String
forall a. Attributes a -> String
getClassBasedStyle [Attributes a]
attrs
    existingClasses :: [String]
existingClasses = (\(Generic String
_ String
name) -> String
name) (Attributes a -> String) -> [Attributes a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Attributes a -> Bool) -> [Attributes a] -> [Attributes a]
forall a. (a -> Bool) -> [a] -> [a]
filter Attributes a -> Bool
forall a. Attributes a -> Bool
isClass [Attributes a]
attrs
    combinedClasses :: [String]
combinedClasses = [String]
classStyles [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
existingClasses

    renderedClasses :: String
renderedClasses =
      if Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
combinedClasses)
      then String
" class=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
combinedClasses String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""
      else String
""

    listeners :: [Attributes a]
listeners = (Attributes a -> Bool) -> [Attributes a] -> [Attributes a]
forall a. (a -> Bool) -> [a] -> [a]
filter Attributes a -> Bool
forall a. Attributes a -> Bool
isOn [Attributes a]
attrs
    renderedListeners :: String
renderedListeners = (Attributes a -> String) -> [Attributes a] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\(On String
name Identifier
ident Maybe String -> a
action) -> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-location=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (Identifier -> ByteString
forall a. ToJSON a => a -> ByteString
encode Identifier
ident))
      [Attributes a]
listeners
    noticeToBind :: String
noticeToBind = if [Attributes a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attributes a]
listeners then String
"" else String
" bubbling-bound"

    generics :: [Attributes a]
generics = (Attributes a -> Bool) -> [Attributes a] -> [Attributes a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Attributes a -> Bool) -> Attributes a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes a -> Bool
forall a. Attributes a -> Bool
isClass) ([Attributes a] -> [Attributes a])
-> [Attributes a] -> [Attributes a]
forall a b. (a -> b) -> a -> b
$ (Attributes a -> Bool) -> [Attributes a] -> [Attributes a]
forall a. (a -> Bool) -> [a] -> [a]
filter Attributes a -> Bool
forall a. Attributes a -> Bool
isGeneric [Attributes a]
attrs
    renderedGenerics :: String
renderedGenerics = (Attributes a -> String) -> [Attributes a] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Attributes a -> String
forall a. Attributes a -> String
renderGeneric [Attributes a]
generics
  in
    String
renderedStyle String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
noticeToBind String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderedListeners String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderedGenerics String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderedClasses

{-|

Takes the tree and turns it into HTML.  Attributes are passed down to children until
they reach a real HTML tag.

-}

render :: Purview action m -> String
render :: forall action (m :: * -> *). Purview action m -> String
render = [Attributes action] -> Purview action m -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' []

render' :: [Attributes action] -> Purview action m -> String
render' :: forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' [Attributes action]
attrs Purview action m
tree = case Purview action m
tree of
  Html String
kind [Purview action m]
rest ->
    String
"<" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
kind String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Attributes action] -> String
forall a. [Attributes a] -> String
renderAttributes [Attributes action]
attrs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Purview action m -> String) -> [Purview action m] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Attributes action] -> Purview action m -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' []) [Purview action m]
rest String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"</" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
kind String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">"

  Text String
val -> String
val

  Attribute Attributes action
attr Purview action m
rest ->
    -- collecting all the attributes till we hit html
    [Attributes action] -> Purview action m -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' (Attributes action
attrAttributes action -> [Attributes action] -> [Attributes action]
forall a. a -> [a] -> [a]
:[Attributes action]
attrs) Purview action m
rest

  EffectHandler Identifier
parentLocation Identifier
location [DirectedEvent action newEvent]
initEvents state
state newEvent
-> state -> m (state -> state, [DirectedEvent action newEvent])
_ state -> Purview newEvent m
cont ->
    String
"<div handler=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String)
-> (Identifier -> ByteString) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
forall a. ToJSON a => a -> ByteString
encode) Identifier
location String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
      [Attributes action] -> Purview action Any -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' [Attributes action]
attrs ((state -> Purview newEvent m) -> state -> Purview action Any
forall a b. a -> b
unsafeCoerce state -> Purview newEvent m
cont state
state) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"</div>"

  Handler { Identifier
identifier :: Identifier
$sel:identifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
identifier, state
state :: state
$sel:state:Attribute :: ()
state, state -> Purview newEvent m
continuation :: state -> Purview newEvent m
$sel:continuation:Attribute :: ()
continuation } ->
    String
"<div handler=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String)
-> (Identifier -> ByteString) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
forall a. ToJSON a => a -> ByteString
encode) Identifier
identifier String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
      [Attributes action] -> Purview action Any -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' [Attributes action]
attrs ((state -> Purview newEvent m) -> state -> Purview action Any
forall a b. a -> b
unsafeCoerce state -> Purview newEvent m
continuation state
state) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"</div>"

  Receiver { Identifier
parentIdentifier :: Identifier
$sel:parentIdentifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
parentIdentifier, Identifier
$sel:identifier:Attribute :: forall event (m :: * -> *). Purview event m -> Identifier
identifier :: Identifier
identifier, String
name :: String
$sel:name:Attribute :: forall action (m :: * -> *). Purview action m -> String
name, state -> Purview action m
child :: state -> Purview action m
$sel:child:Attribute :: ()
child, state
$sel:state:Attribute :: ()
state :: state
state } ->
    String
"<div" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" handler=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String)
-> (Identifier -> ByteString) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
forall a. ToJSON a => a -> ByteString
encode) Identifier
identifier String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" parent-handler=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String)
-> (Identifier -> ByteString) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
forall a. ToJSON a => a -> ByteString
encode) Identifier
parentIdentifier String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" receiver-name=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
      [Attributes action] -> Purview action m -> String
forall action (m :: * -> *).
[Attributes action] -> Purview action m -> String
render' [Attributes action]
attrs (state -> Purview action m
child state
state) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"</div>"

  Value a
a -> a -> String
forall a. Show a => a -> String
show a
a