module Web.Atomic.Types.Attributable where

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Text (Text)


type Name = Text
type AttValue = Text


newtype Attributes h = Attributes (Map Name AttValue)
  deriving newtype (Semigroup (Attributes h)
Attributes h
Semigroup (Attributes h) =>
Attributes h
-> (Attributes h -> Attributes h -> Attributes h)
-> ([Attributes h] -> Attributes h)
-> Monoid (Attributes h)
[Attributes h] -> Attributes h
Attributes h -> Attributes h -> Attributes h
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (h :: k). Semigroup (Attributes h)
forall k (h :: k). Attributes h
forall k (h :: k). [Attributes h] -> Attributes h
forall k (h :: k). Attributes h -> Attributes h -> Attributes h
$cmempty :: forall k (h :: k). Attributes h
mempty :: Attributes h
$cmappend :: forall k (h :: k). Attributes h -> Attributes h -> Attributes h
mappend :: Attributes h -> Attributes h -> Attributes h
$cmconcat :: forall k (h :: k). [Attributes h] -> Attributes h
mconcat :: [Attributes h] -> Attributes h
Monoid, NonEmpty (Attributes h) -> Attributes h
Attributes h -> Attributes h -> Attributes h
(Attributes h -> Attributes h -> Attributes h)
-> (NonEmpty (Attributes h) -> Attributes h)
-> (forall b. Integral b => b -> Attributes h -> Attributes h)
-> Semigroup (Attributes h)
forall b. Integral b => b -> Attributes h -> Attributes h
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (h :: k). NonEmpty (Attributes h) -> Attributes h
forall k (h :: k). Attributes h -> Attributes h -> Attributes h
forall k (h :: k) b.
Integral b =>
b -> Attributes h -> Attributes h
$c<> :: forall k (h :: k). Attributes h -> Attributes h -> Attributes h
<> :: Attributes h -> Attributes h -> Attributes h
$csconcat :: forall k (h :: k). NonEmpty (Attributes h) -> Attributes h
sconcat :: NonEmpty (Attributes h) -> Attributes h
$cstimes :: forall k (h :: k) b.
Integral b =>
b -> Attributes h -> Attributes h
stimes :: forall b. Integral b => b -> Attributes h -> Attributes h
Semigroup)


-- | Add Atts
class Attributable h where
  -- | Apply an attribute to some html
  --
  -- > el @ att "id" "main-content" $ do
  -- >   tag "img" @ att "src" "logo.png"
  -- >   tag "input" @ placeholder "message" ~ border 1
  (@) :: h -> (Attributes h -> Attributes h) -> h
  h
h @ Attributes h -> Attributes h
f =
    ((Map Name Name -> Map Name Name) -> h -> h)
-> h -> (Map Name Name -> Map Name Name) -> h
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Map Name Name -> Map Name Name) -> h -> h
forall h.
Attributable h =>
(Map Name Name -> Map Name Name) -> h -> h
modAttributes h
h ((Map Name Name -> Map Name Name) -> h)
-> (Map Name Name -> Map Name Name) -> h
forall a b. (a -> b) -> a -> b
$ \Map Name Name
m ->
      let Attributes Map Name Name
atts = Attributes h -> Attributes h
f (Attributes h -> Attributes h) -> Attributes h -> Attributes h
forall a b. (a -> b) -> a -> b
$ Map Name Name -> Attributes h
forall {k} (h :: k). Map Name Name -> Attributes h
Attributes Map Name Name
m
       in Map Name Name
atts


  modAttributes :: (Map Name AttValue -> Map Name AttValue) -> h -> h


infixl 5 @


instance {-# OVERLAPPABLE #-} (Attributable a, Attributable b) => Attributable (a -> b) where
  (@) :: (a -> b) -> (Attributes (a -> b) -> Attributes (a -> b)) -> (a -> b)
  a -> b
hh @ :: (a -> b) -> (Attributes (a -> b) -> Attributes (a -> b)) -> a -> b
@ Attributes (a -> b) -> Attributes (a -> b)
f = \a
content ->
    a -> b
hh a
content b -> (Attributes b -> Attributes b) -> b
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ \(Attributes Map Name Name
m) ->
      let Attributes Map Name Name
m2 = Attributes (a -> b) -> Attributes (a -> b)
f (Attributes (a -> b) -> Attributes (a -> b))
-> Attributes (a -> b) -> Attributes (a -> b)
forall a b. (a -> b) -> a -> b
$ Map Name Name -> Attributes (a -> b)
forall {k} (h :: k). Map Name Name -> Attributes h
Attributes Map Name Name
m
       in Map Name Name -> Attributes b
forall {k} (h :: k). Map Name Name -> Attributes h
Attributes Map Name Name
m2


  modAttributes :: (Map Name Name -> Map Name Name) -> (a -> b) -> a -> b
modAttributes Map Name Name -> Map Name Name
f a -> b
hh a
content =
    (Map Name Name -> Map Name Name) -> b -> b
forall h.
Attributable h =>
(Map Name Name -> Map Name Name) -> h -> h
modAttributes Map Name Name -> Map Name Name
f (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ a -> b
hh a
content


instance Attributable (Map Name AttValue) where
  modAttributes :: (Map Name Name -> Map Name Name) -> Map Name Name -> Map Name Name
modAttributes Map Name Name -> Map Name Name
f = Map Name Name -> Map Name Name
f


instance Attributable (Attributes h) where
  modAttributes :: (Map Name Name -> Map Name Name) -> Attributes h -> Attributes h
modAttributes Map Name Name -> Map Name Name
f (Attributes Map Name Name
m) = Map Name Name -> Attributes h
forall {k} (h :: k). Map Name Name -> Attributes h
Attributes (Map Name Name -> Attributes h) -> Map Name Name -> Attributes h
forall a b. (a -> b) -> a -> b
$ Map Name Name -> Map Name Name
f Map Name Name
m


att :: (Attributable h) => Name -> AttValue -> Attributes h -> Attributes h
att :: forall h.
Attributable h =>
Name -> Name -> Attributes h -> Attributes h
att Name
n Name
av (Attributes Map Name Name
m) =
  Map Name Name -> Attributes h
forall {k} (h :: k). Map Name Name -> Attributes h
Attributes (Map Name Name -> Attributes h) -> Map Name Name -> Attributes h
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n Name
av Map Name Name
m