{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}

module Web.Atomic.Html where

import Data.List qualified as L
import Data.Map.Strict (Map)
import Data.String (IsString (..))
import Data.Text (Text, pack)
import GHC.Exts (IsList (..))
import Web.Atomic.Types


{- | Html monad

@
import Web.Atomic

example = do
  'el' ~ pad 10 $ do
    'el' ~ fontSize 24 . bold $ "My Links"
    a '@' href "hoogle.haskell.org" ~ link $ \"Hoogle\"
    a '@' href "hackage.haskell.org" ~ link $ \"Hackage\"

link = underline . color Primary
a = 'tag' "a"
href = 'att' "href"
@
-}
data Html a = Html {forall a. Html a -> a
value :: a, forall a. Html a -> [Node]
nodes :: [Node]}


instance IsList (Html ()) where
  type Item (Html ()) = Node
  fromList :: [Item (Html ())] -> Html ()
fromList = () -> [Node] -> Html ()
forall a. a -> [Node] -> Html a
Html () ([Node] -> Html ()) -> ([Node] -> [Node]) -> [Node] -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item [Node]] -> [Node]
[Node] -> [Node]
forall l. IsList l => [Item l] -> l
fromList
  toList :: Html () -> [Item (Html ())]
toList (Html ()
_ [Node]
ns) = [Item (Html ())]
[Node]
ns


instance IsString (Html ()) where
  fromString :: String -> Html ()
fromString String
s = () -> [Node] -> Html ()
forall a. a -> [Node] -> Html a
Html () [String -> Node
forall a. IsString a => String -> a
fromString String
s]


instance Functor Html where
  fmap :: forall a b. (a -> b) -> Html a -> Html b
fmap a -> b
f (Html a
a [Node]
ns) = b -> [Node] -> Html b
forall a. a -> [Node] -> Html a
Html (a -> b
f a
a) [Node]
ns


instance Applicative Html where
  pure :: forall a. a -> Html a
pure a
a = a -> [Node] -> Html a
forall a. a -> [Node] -> Html a
Html a
a []
  (<*>) :: Html (a -> b) -> Html a -> Html b
  Html a -> b
f [Node]
nfs <*> :: forall a b. Html (a -> b) -> Html a -> Html b
<*> Html a
a [Node]
nas =
    b -> [Node] -> Html b
forall a. a -> [Node] -> Html a
Html (a -> b
f a
a) ([Node]
nfs [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
nas)


-- ha *> hb = ha <> hb
instance Monad Html where
  (>>=) :: forall a b. Html a -> (a -> Html b) -> Html b
  Html a
a [Node]
nas >>= :: forall a b. Html a -> (a -> Html b) -> Html b
>>= a -> Html b
famb =
    let Html b
b [Node]
nbs = a -> Html b
famb a
a :: Html b
     in b -> [Node] -> Html b
forall a. a -> [Node] -> Html a
Html b
b ([Node]
nas [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
nbs)


el :: Html () -> Html ()
el :: Html () -> Html ()
el = Text -> Html () -> Html ()
tag Text
"div"


tag :: Text -> Html () -> Html ()
tag :: Text -> Html () -> Html ()
tag Text
nm (Html ()
_ [Node]
content) = do
  () -> [Node] -> Html ()
forall a. a -> [Node] -> Html a
Html () [Element -> Node
Elem (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ (Text -> Element
element Text
nm){content}]


text :: Text -> Html ()
text :: Text -> Html ()
text Text
t = () -> [Node] -> Html ()
forall a. a -> [Node] -> Html a
Html () [Text -> Node
Text Text
t]


none :: Html ()
none :: Html ()
none = () -> Html ()
forall a. a -> Html a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


raw :: Text -> Html ()
raw :: Text -> Html ()
raw Text
t = () -> [Node] -> Html ()
forall a. a -> [Node] -> Html a
Html () [Text -> Node
Raw Text
t]


-- | A single 'Html' element. Note that the class attribute is generated separately from the css rules, rather than the attributes
data Element = Element
  { Element -> Bool
inline :: Bool
  , Element -> Text
name :: Text
  , Element -> [Rule]
css :: [Rule]
  , Element -> Map Text Text
attributes :: Map Name AttValue
  , Element -> [Node]
content :: [Node]
  }


data Node
  = Elem Element
  | Text Text
  | Raw Text


instance IsString Node where
  fromString :: String -> Node
fromString String
s = Text -> Node
Text (String -> Text
pack String
s)


mapElement :: (Element -> Element) -> Html a -> Html a
mapElement :: forall a. (Element -> Element) -> Html a -> Html a
mapElement Element -> Element
f (Html a
a [Node]
ns) = a -> [Node] -> Html a
forall a. a -> [Node] -> Html a
Html a
a ([Node] -> Html a) -> [Node] -> Html a
forall a b. (a -> b) -> a -> b
$ (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Element -> Element) -> Node -> Node
mapNodeElement Element -> Element
f) [Node]
ns


mapNodeElement :: (Element -> Element) -> Node -> Node
mapNodeElement :: (Element -> Element) -> Node -> Node
mapNodeElement Element -> Element
f (Elem Element
e) = Element -> Node
Elem (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Element -> Element
f Element
e
mapNodeElement Element -> Element
_ Node
n = Node
n


element :: Text -> Element
element :: Text -> Element
element Text
nm = Bool -> Text -> [Rule] -> Map Text Text -> [Node] -> Element
Element Bool
False Text
nm [Rule]
forall a. Monoid a => a
mempty Map Text Text
forall a. Monoid a => a
mempty [Node]
forall a. Monoid a => a
mempty


instance Attributable (Html a) where
  modAttributes :: (Map Text Text -> Map Text Text) -> Html a -> Html a
modAttributes Map Text Text -> Map Text Text
f =
    (Element -> Element) -> Html a -> Html a
forall a. (Element -> Element) -> Html a -> Html a
mapElement (\Element
elm -> Element
elm{attributes = f elm.attributes})


instance Styleable (Html a) where
  modCSS :: ([Rule] -> [Rule]) -> Html a -> Html a
modCSS [Rule] -> [Rule]
f =
    (Element -> Element) -> Html a -> Html a
forall a. (Element -> Element) -> Html a -> Html a
mapElement (\Element
elm -> Element
elm{css = f elm.css})


htmlCSSRules :: Html a -> Map Selector Rule
htmlCSSRules :: forall a. Html a -> Map Selector Rule
htmlCSSRules (Html a
_ [Node]
ns) = [Map Selector Rule] -> Map Selector Rule
forall a. Monoid a => [a] -> a
mconcat ([Map Selector Rule] -> Map Selector Rule)
-> [Map Selector Rule] -> Map Selector Rule
forall a b. (a -> b) -> a -> b
$ (Node -> Map Selector Rule) -> [Node] -> [Map Selector Rule]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Map Selector Rule
nodeCSSRules [Node]
ns


nodeCSSRules :: Node -> Map Selector Rule
nodeCSSRules :: Node -> Map Selector Rule
nodeCSSRules = \case
  Elem Element
elm -> Element -> Map Selector Rule
elementCSSRules Element
elm
  Node
_ -> []


elementCSSRules :: Element -> Map Selector Rule
elementCSSRules :: Element -> Map Selector Rule
elementCSSRules Element
elm =
  [Rule] -> Map Selector Rule
ruleMap Element
elm.css Map Selector Rule -> Map Selector Rule -> Map Selector Rule
forall a. Semigroup a => a -> a -> a
<> [Map Selector Rule] -> Map Selector Rule
forall a. Monoid a => [a] -> a
mconcat ((Node -> Map Selector Rule) -> [Node] -> [Map Selector Rule]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Map Selector Rule
nodeCSSRules Element
elm.content)


elementClasses :: Element -> [ClassName]
elementClasses :: Element -> [ClassName]
elementClasses Element
elm =
  [ClassName] -> [ClassName]
forall a. Ord a => [a] -> [a]
L.sort ([ClassName] -> [ClassName]) -> [ClassName] -> [ClassName]
forall a b. (a -> b) -> a -> b
$ (Rule -> ClassName) -> [Rule] -> [ClassName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rule -> ClassName
ruleClassName Element
elm.css