{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant <$>" #-}
module Halogen.VDom.DOM.Prop
  ( Prop (..)
  , ElemRef (..)
  , PropValue (..)
  , buildProp
  )
where

import Data.Foreign
import Data.Map.Strict qualified as M
import HPrelude hiding (state)
import Halogen.VDom.DOM.Monad
import Halogen.VDom.Machine qualified as V
import Halogen.VDom.Types
import Halogen.VDom.Utils qualified as Util
import Web.DOM.Element
import Web.DOM.Internal.Types qualified as DOM
import Web.Event.Event
import Web.Event.Event qualified as DOM
import Web.HTML.Common

data Prop msg
  = Attribute (Maybe Namespace) AttrName Text
  | forall val. Property (PropName val) (PropValue val)
  | Handler EventType (Event -> Maybe msg)
  | Ref (ElemRef Element -> Maybe msg)

deriving instance Functor Prop

data ElemRef a
  = Created a
  | Removed a
  deriving ((forall a b. (a -> b) -> ElemRef a -> ElemRef b)
-> (forall a b. a -> ElemRef b -> ElemRef a) -> Functor ElemRef
forall a b. a -> ElemRef b -> ElemRef a
forall a b. (a -> b) -> ElemRef a -> ElemRef b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ElemRef a -> ElemRef b
fmap :: forall a b. (a -> b) -> ElemRef a -> ElemRef b
$c<$ :: forall a b. a -> ElemRef b -> ElemRef a
<$ :: forall a b. a -> ElemRef b -> ElemRef a
Functor)

type EventMap m a = Map Text (DOM.EventListener, IORef (Event -> Maybe a))

data PropState m a = PropState
  { forall {k} (m :: k) a. PropState m a -> IORef (EventMap m a)
events :: IORef (EventMap m a)
  , forall {k} (m :: k) a. PropState m a -> Map Text (Prop a)
props :: Map Text (Prop a)
  }

propToStrKey :: Prop i -> Text
propToStrKey :: forall i. Prop i -> Text
propToStrKey = \case
  Attribute (Just (Namespace Text
ns)) (AttrName Text
attr) Text
_ -> Text
"attr/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr
  Attribute Maybe Namespace
_ (AttrName Text
attr) Text
_ -> Text
"attr/:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr
  Property (PropName Text
prop) PropValue val
_ -> Text
"prop/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prop
  Handler (DOM.EventType Text
ty) Event -> Maybe i
_ -> Text
"handler/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty
  Ref ElemRef Element -> Maybe i
_ -> Text
"ref"

#if defined(javascript_HOST_ARCH)
{-# SPECIALISE buildProp :: (a -> IO ()) -> DOM.Element -> V.Machine IO [Prop a] () #-}
#endif
buildProp
  :: forall m a
   . (MonadIO m, MonadDOM m)
  => (a -> m ())
  -> DOM.Element
  -> V.Machine m [Prop a] ()
buildProp :: forall (m :: * -> *) a.
(MonadIO m, MonadDOM m) =>
(a -> m ()) -> Element -> Machine m [Prop a] ()
buildProp a -> m ()
emit Element
el = Machine m [Prop a] ()
renderProp
  where
    renderProp :: V.Machine m [Prop a] ()
    renderProp :: Machine m [Prop a] ()
renderProp [Prop a]
ps1 = do
      events <- Map Text (EventListener, IORef (Event -> Maybe a))
-> m (IORef (Map Text (EventListener, IORef (Event -> Maybe a))))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map Text (EventListener, IORef (Event -> Maybe a))
forall a. Monoid a => a
mempty
      ps1' <- Util.strMapWithIxE ps1 propToStrKey (applyProp events)
      let state =
            PropState
              { IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events
              , props :: Map Text (Prop a)
props = Map Text (Prop a)
ps1'
              }
      pure $ V.Step () state patchProp haltProp

    patchProp :: PropState m a -> [Prop a] -> m (V.Step m [Prop a] ())
    patchProp :: PropState m a -> Machine m [Prop a] ()
patchProp PropState m a
state [Prop a]
ps2 = do
      events <- Map Text (EventListener, IORef (Event -> Maybe a))
-> m (IORef (Map Text (EventListener, IORef (Event -> Maybe a))))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map Text (EventListener, IORef (Event -> Maybe a))
forall a. Monoid a => a
mempty
      let PropState {events = prevEvents, props = ps1} = state
          onThese = IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text
-> Int
-> Prop a
-> Prop a
-> m (Prop a)
diffProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events
          onThis = IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text -> Prop a -> m ()
removeProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents
          onThat = IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text -> Int -> Prop a -> m (Prop a)
applyProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events
      props <- Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
      let nextState =
            PropState
              { IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events
              , Map Text (Prop a)
props :: Map Text (Prop a)
props :: Map Text (Prop a)
props
              }
      pure $ V.Step () nextState patchProp haltProp

    haltProp :: PropState m a -> m ()
haltProp PropState m a
state = do
      case Text -> Map Text (Prop a) -> Maybe (Prop a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"ref" PropState m a
state.props of
        Just (Ref ElemRef Element -> Maybe a
f) ->
          Maybe a -> m ()
mbEmit (ElemRef Element -> Maybe a
f (Element -> ElemRef Element
forall a. a -> ElemRef a
Removed Element
el))
        Maybe (Prop a)
_ -> m ()
forall (f :: * -> *). Applicative f => f ()
pass

    mbEmit :: Maybe a -> m ()
mbEmit = (a -> m ()) -> Maybe a -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> m ()
emit

    applyProp :: IORef (EventMap m a) -> Text -> Int -> Prop a -> m (Prop a)
    applyProp :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text -> Int -> Prop a -> m (Prop a)
applyProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events Text
_ Int
_ Prop a
v =
      case Prop a
v of
        Attribute Maybe Namespace
ns AttrName
attr Text
val -> do
          Maybe Namespace -> AttrName -> Text -> Element -> m ()
forall (m :: * -> *).
MonadDOM m =>
Maybe Namespace -> AttrName -> Text -> Element -> m ()
setAttribute Maybe Namespace
ns AttrName
attr Text
val Element
el
          Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v
        Property PropName val
prop PropValue val
val -> do
          PropName val -> PropValue val -> Element -> m ()
forall a. PropName a -> PropValue a -> Element -> m ()
forall (m :: * -> *) a.
MonadDOM m =>
PropName a -> PropValue a -> Element -> m ()
setProperty PropName val
prop PropValue val
val Element
el
          Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v
        Handler evty :: EventType
evty@(DOM.EventType Text
ty) Event -> Maybe a
f -> do
          Text
-> Map Text (EventListener, IORef (Event -> Maybe a))
-> Maybe (EventListener, IORef (Event -> Maybe a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ty
            (Map Text (EventListener, IORef (Event -> Maybe a))
 -> Maybe (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (Maybe (EventListener, IORef (Event -> Maybe a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events
            m (Maybe (EventListener, IORef (Event -> Maybe a)))
-> (Maybe (EventListener, IORef (Event -> Maybe a)) -> m (Prop a))
-> m (Prop a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just (EventListener, IORef (Event -> Maybe a))
handler -> do
                IORef (Event -> Maybe a) -> (Event -> Maybe a) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef ((EventListener, IORef (Event -> Maybe a))
-> IORef (Event -> Maybe a)
forall a b. (a, b) -> b
snd (EventListener, IORef (Event -> Maybe a))
handler) Event -> Maybe a
f
                Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v
              Maybe (EventListener, IORef (Event -> Maybe a))
_ -> do
                ref <- (Event -> Maybe a) -> m (IORef (Event -> Maybe a))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Event -> Maybe a
f
                listener <- mkEventListener $ \Event
ev -> do
                  f' <- IORef (Event -> Maybe a) -> m (Event -> Maybe a)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Event -> Maybe a)
ref
                  mbEmit (f' ev)
                atomicModifyIORef'_ events (M.insert ty (listener, ref))
                addEventListener evty listener $ toEventTarget el
                pure v
        Ref ElemRef Element -> Maybe a
f -> do
          Maybe a -> m ()
mbEmit (ElemRef Element -> Maybe a
f (Element -> ElemRef Element
forall a. a -> ElemRef a
Created Element
el))
          Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v

    diffProp
      :: IORef (EventMap m a)
      -> IORef (EventMap m a)
      -> Text
      -> Int
      -> Prop a
      -> Prop a
      -> m (Prop a)
    diffProp :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text
-> Int
-> Prop a
-> Prop a
-> m (Prop a)
diffProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
events Text
_ Int
_ Prop a
v1 Prop a
v2 = do
      case (Prop a
v1, Prop a
v2) of
        (Attribute Maybe Namespace
_ AttrName
_ Text
val1, Attribute Maybe Namespace
ns2 AttrName
attr2 Text
val2) ->
          if Text
val1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
val2
            then Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v2
            else do
              Maybe Namespace -> AttrName -> Text -> Element -> m ()
forall (m :: * -> *).
MonadDOM m =>
Maybe Namespace -> AttrName -> Text -> Element -> m ()
setAttribute Maybe Namespace
ns2 AttrName
attr2 Text
val2 Element
el
              Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v2
        (Property PropName val
_ PropValue val
val1, Property PropName val
prop2 PropValue val
val2) ->
          case (PropValue val
val1 PropValue val -> PropValue val -> Bool
forall a b. a -> b -> Bool
`unsafeRefEq'` PropValue val
val2, PropName val
prop2) of
            (Bool
True, PropName val
_) ->
              Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v2
            (Bool
_, PropName val
"value") -> do
              elVal <- PropName (PropValue val) -> Element -> m (PropValue val)
forall a. PropName a -> Element -> m a
forall (m :: * -> *) a. MonadDOM m => PropName a -> Element -> m a
unsafeGetProperty PropName (PropValue val)
"value" Element
el
              if elVal `unsafeRefEq` val2
                then pure v2
                else do
                  setProperty prop2 val2 el
                  pure v2
            (Bool
_, PropName val
_) -> do
              PropName val -> PropValue val -> Element -> m ()
forall a. PropName a -> PropValue a -> Element -> m ()
forall (m :: * -> *) a.
MonadDOM m =>
PropName a -> PropValue a -> Element -> m ()
setProperty PropName val
prop2 PropValue val
val2 Element
el
              Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v2
        (Handler EventType
_ Event -> Maybe a
_, Handler (DOM.EventType Text
ty) Event -> Maybe a
f) -> do
          handler <- (Map Text (EventListener, IORef (Event -> Maybe a))
-> Text -> (EventListener, IORef (Event -> Maybe a))
forall k a. Ord k => Map k a -> k -> a
M.! Text
ty) (Map Text (EventListener, IORef (Event -> Maybe a))
 -> (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (EventListener, IORef (Event -> Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents
          atomicWriteIORef (snd handler) f
          atomicModifyIORef'_ events (M.insert ty handler)
          pure v2
        (Prop a
_, Prop a
_) ->
          Prop a -> m (Prop a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prop a
v2

    removeProp :: IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> Text -> Prop a -> m ()
removeProp IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents Text
_ Prop a
v =
      case Prop a
v of
        Attribute Maybe Namespace
ns AttrName
attr Text
_ ->
          Maybe Namespace -> AttrName -> Element -> m ()
forall (m :: * -> *).
MonadDOM m =>
Maybe Namespace -> AttrName -> Element -> m ()
removeAttribute Maybe Namespace
ns AttrName
attr Element
el
        Property PropName val
prop PropValue val
_ ->
          PropName val -> Element -> m ()
forall {k} (a :: k). PropName a -> Element -> m ()
forall (m :: * -> *) {k} (a :: k).
MonadDOM m =>
PropName a -> Element -> m ()
removeProperty PropName val
prop Element
el
        Handler evty :: EventType
evty@(DOM.EventType Text
ty) Event -> Maybe a
_ -> do
          handler <- (Map Text (EventListener, IORef (Event -> Maybe a))
-> Text -> (EventListener, IORef (Event -> Maybe a))
forall k a. Ord k => Map k a -> k -> a
M.! Text
ty) (Map Text (EventListener, IORef (Event -> Maybe a))
 -> (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (EventListener, IORef (Event -> Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
-> m (Map Text (EventListener, IORef (Event -> Maybe a)))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map Text (EventListener, IORef (Event -> Maybe a)))
prevEvents
          removeEventListener evty (fst handler) $ toEventTarget el
        Ref ElemRef Element -> Maybe a
_ -> m ()
forall (f :: * -> *). Applicative f => f ()
pass