content: {-# 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 {value :: a, nodes :: [Node]}
  
  
  instance IsList (Html ()) where
    type Item (Html ()) = Node
    fromList = Html () . fromList
    toList (Html _ ns) = ns
  
  
  instance IsString (Html ()) where
    fromString s = Html () [fromString s]
  
  
  instance Functor Html where
    fmap f (Html a ns) = Html (f a) ns
  
  
  instance Applicative Html where
    pure a = Html a []
    (<*>) :: Html (a -> b) -> Html a -> Html b
    Html f nfs <*> Html a nas =
      Html (f a) (nfs <> nas)
  
  
  -- ha *> hb = ha <> hb
  instance Monad Html where
    (>>=) :: forall a b. Html a -> (a -> Html b) -> Html b
    Html a nas >>= famb =
      let Html b nbs = famb a :: Html b
       in Html b (nas <> nbs)
  
  
  el :: Html () -> Html ()
  el = tag "div"
  
  
  tag :: Text -> Html () -> Html ()
  tag nm (Html _ content) = do
    fromElement $ (element nm){content}
  
  
  tag' :: Bool -> Text -> Html () -> Html ()
  tag' inline nm (Html _ content) =
    fromElement $ (element nm){content, inline}
  
  
  fromElement :: Element -> Html ()
  fromElement elm =
    Html () [Elem elm]
  
  
  text :: Text -> Html ()
  text t = Html () [Text t]
  
  
  none :: Html ()
  none = pure ()
  
  
  raw :: Text -> Html ()
  raw t = Html () [Raw t]
  
  
  -- | A single 'Html' element. Note that the class attribute is generated separately from the css rules, rather than the attributes
  data Element = Element
    { inline :: Bool
    , name :: Text
    , css :: [Rule]
    , attributes :: Map Name AttValue
    , content :: [Node]
    }
  
  
  data Node
    = Elem Element
    | Text Text
    | Raw Text
  
  
  instance IsString Node where
    fromString s = Text (pack s)
  
  
  mapElement :: (Element -> Element) -> Html a -> Html a
  mapElement f (Html a ns) = Html a $ fmap (mapNodeElement f) ns
  
  
  mapNodeElement :: (Element -> Element) -> Node -> Node
  mapNodeElement f (Elem e) = Elem $ f e
  mapNodeElement _ n = n
  
  
  element :: Text -> Element
  element nm = Element False nm mempty mempty mempty
  
  
  instance Attributable (Html a) where
    modAttributes f =
      mapElement (\elm -> elm{attributes = f elm.attributes})
  
  
  instance Styleable (Html a) where
    modCSS f =
      mapElement (\elm -> elm{css = f elm.css})
  
  
  htmlCSSRules :: Html a -> Map Selector Rule
  htmlCSSRules (Html _ ns) = mconcat $ fmap nodeCSSRules ns
  
  
  nodeCSSRules :: Node -> Map Selector Rule
  nodeCSSRules = \case
    Elem elm -> elementCSSRules elm
    _ -> []
  
  
  elementCSSRules :: Element -> Map Selector Rule
  elementCSSRules elm =
    ruleMap elm.css <> mconcat (fmap nodeCSSRules elm.content)
  
  
  elementClasses :: Element -> [ClassName]
  elementClasses elm =
    L.sort $ fmap ruleClassName elm.css
  