module Halogen.VDom.Driver
  ( runUI
  , module Halogen.IO.Driver
  )
where

import Control.Exception.Safe
import Control.Monad.Fork
import Control.Monad.Parallel
import Control.Monad.UUID
import Data.Coerce
import Data.Foreign
import HPrelude
import Halogen.Component
import Halogen.HTML.Core (HTML (..))
import Halogen.IO.Driver (HalogenSocket)
import Halogen.IO.Driver qualified as AD
import Halogen.IO.Driver.State
import Halogen.Query.Input
import Halogen.VDom qualified as V
import Halogen.VDom.DOM.Monad qualified as DOM
import Halogen.VDom.DOM.Prop
import Halogen.VDom.DOM.Prop qualified as VP
import Halogen.VDom.Thunk (Thunk)
import Halogen.VDom.Thunk qualified as Thunk
import Web.DOM.Internal.Types
import Web.DOM.Internal.Types qualified as DOM
import Web.DOM.ParentNode (ParentNode, toParentNode)

#if defined(javascript_HOST_ARCH)
{-# SPECIALISE substInParent :: DOM.Node -> Maybe DOM.Node -> Maybe ParentNode -> IO () #-}
{-# SPECIALISE removeChild :: forall state action slots output. RenderState IO state action slots output -> IO () #-}
{-# SPECIALISE renderSpec :: DOM.Document -> DOM.HTMLElement -> AD.RenderSpec IO (RenderState IO) #-}
{-# SPECIALISE runUI :: forall query input output. Component query input output IO -> input -> DOM.HTMLElement -> IO (HalogenSocket query output IO) #-}
{-# SPECIALISE mkSpec :: forall action slots. (Input action -> IO ()) -> IORef (ChildRenderer IO action slots) -> DOM.Document -> V.VDomSpec IO [Prop (Input action)] (ComponentSlot slots IO action) #-}
#endif

type VHTML m action slots =
  V.VDom [Prop (Input action)] (ComponentSlot slots m action)

type ChildRenderer m action slots = ComponentSlotBox slots m action -> m (RenderStateX (RenderState m))

data RenderState m state action slots output
  = RenderState
  { forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output -> Node
node :: DOM.Node
  , forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output
-> Step m (VHTML m action slots) Node
machine :: V.Step m (VHTML m action slots) DOM.Node
  , forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output
-> IORef (ChildRenderer m action slots)
renderChildRef :: IORef (ChildRenderer m action slots)
  }

type HTMLThunk m slots action =
  Thunk (HTML (ComponentSlot slots m action)) action

type WidgetState m slots action =
  Maybe (V.Step m (HTMLThunk m slots action) DOM.Node)

mkSpec
  :: forall m action slots
   . (MonadIO m, DOM.MonadDOM m)
  => (Input action -> m ())
  -> IORef (ChildRenderer m action slots)
  -> DOM.Document
  -> V.VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
mkSpec :: forall (m :: * -> *) action (slots :: Row (*)).
(MonadIO m, MonadDOM m) =>
(Input action -> m ())
-> IORef (ChildRenderer m action slots)
-> Document
-> VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
mkSpec Input action -> m ()
handler IORef (ChildRenderer m action slots)
renderChildRef Document
document =
  V.VDomSpec {VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
-> Machine m (ComponentSlot slots m action) Node
buildWidget :: VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
-> Machine m (ComponentSlot slots m action) Node
buildWidget :: VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
-> Machine m (ComponentSlot slots m action) Node
buildWidget, Element -> Machine m [Prop (Input action)] ()
buildAttributes :: Element -> Machine m [Prop (Input action)] ()
buildAttributes :: Element -> Machine m [Prop (Input action)] ()
buildAttributes, Document
document :: Document
document :: Document
document}
  where
    buildAttributes
      :: DOM.Element
      -> V.Machine m [Prop (Input action)] ()
    buildAttributes :: Element -> Machine m [Prop (Input action)] ()
buildAttributes = (Input action -> m ())
-> Element -> Machine m [Prop (Input action)] ()
forall (m :: * -> *) a.
(MonadIO m, MonadDOM m) =>
(a -> m ()) -> Element -> Machine m [Prop a] ()
VP.buildProp Input action -> m ()
handler

    buildWidget
      :: V.VDomSpec
           m
           [Prop (Input action)]
           (ComponentSlot slots m action)
      -> V.Machine
           m
           (ComponentSlot slots m action)
           DOM.Node
    buildWidget :: VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
-> Machine m (ComponentSlot slots m action) Node
buildWidget VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
spec = Machine m (ComponentSlot slots m action) Node
render
      where
        render :: V.Machine m (ComponentSlot slots m action) DOM.Node
        render :: Machine m (ComponentSlot slots m action) Node
render = \case
          ComponentSlot ComponentSlotBox slots m action
cs ->
            ComponentSlotBox slots m action
-> m (Step m (ComponentSlot slots m action) Node)
renderComponentSlot ComponentSlotBox slots m action
cs
          ThunkSlot Thunk (HTML (ComponentSlot slots m action)) action
t -> do
            step <- Machine m (Thunk (HTML (ComponentSlot slots m action)) action) Node
buildThunk Thunk (HTML (ComponentSlot slots m action)) action
t
            pure $ V.Step (V.extract step) (Just step) patch done

        patch
          :: WidgetState m slots action
          -> ComponentSlot slots m action
          -> m (V.Step m (ComponentSlot slots m action) DOM.Node)
        patch :: Maybe
  (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
-> Machine m (ComponentSlot slots m action) Node
patch Maybe
  (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
st ComponentSlot slots m action
slot =
          case Maybe
  (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
st of
            Just Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
step -> case ComponentSlot slots m action
slot of
              ComponentSlot ComponentSlotBox slots m action
cs -> do
                Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
-> m ()
forall (m :: * -> *) a b. Step m a b -> m ()
V.halt Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
step
                ComponentSlotBox slots m action
-> m (Step m (ComponentSlot slots m action) Node)
renderComponentSlot ComponentSlotBox slots m action
cs
              ThunkSlot Thunk (HTML (ComponentSlot slots m action)) action
t -> do
                step' <- Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
-> Machine
     m (Thunk (HTML (ComponentSlot slots m action)) action) Node
forall (m :: * -> *) a b. Step m a b -> a -> m (Step m a b)
V.step Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
step Thunk (HTML (ComponentSlot slots m action)) action
t
                pure $ V.Step (V.extract step') (Just step') patch done
            Maybe
  (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
_ -> Machine m (ComponentSlot slots m action) Node
render ComponentSlot slots m action
slot

        buildThunk :: V.Machine m (HTMLThunk m slots action) DOM.Node
        buildThunk :: Machine m (Thunk (HTML (ComponentSlot slots m action)) action) Node
buildThunk = (HTML (ComponentSlot slots m action) action
 -> VDom [Prop (Input action)] (ComponentSlot slots m action))
-> VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
-> Machine
     m (Thunk (HTML (ComponentSlot slots m action)) action) Node
forall {k} (m :: * -> *) (f :: k -> *) (i :: k) a w.
MonadDOM m =>
(f i -> VDom a w) -> VDomSpec m a w -> Machine m (Thunk f i) Node
Thunk.buildThunk HTML (ComponentSlot slots m action) action
-> VDom [Prop (Input action)] (ComponentSlot slots m action)
forall a b. Coercible a b => a -> b
coerce VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
spec

        renderComponentSlot
          :: ComponentSlotBox slots m action
          -> m (V.Step m (ComponentSlot slots m action) DOM.Node)
        renderComponentSlot :: ComponentSlotBox slots m action
-> m (Step m (ComponentSlot slots m action) Node)
renderComponentSlot ComponentSlotBox slots m action
cs = do
          renderChild <- IORef (ChildRenderer m action slots)
-> m (ChildRenderer m action slots)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (ChildRenderer m action slots)
renderChildRef
          rsx <- renderChild cs
          let node = RenderStateX (RenderState m) -> Node
getNode RenderStateX (RenderState m)
rsx
          pure $ V.Step node Nothing patch done

    done :: WidgetState m slots action -> m ()
    done :: Maybe
  (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
-> m ()
done = (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
 -> m ())
-> Maybe
     (Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node)
-> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Step m (Thunk (HTML (ComponentSlot slots m action)) action) Node
-> m ()
forall (m :: * -> *) a b. Step m a b -> m ()
V.halt

    getNode :: RenderStateX (RenderState m) -> DOM.Node
    getNode :: RenderStateX (RenderState m) -> Node
getNode (RenderStateX (RenderState {Node
node :: forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output -> Node
node :: Node
node})) = Node
node

runUI
  :: forall m query input output
   . (DOM.MonadDOM m, MonadUnliftIO m, MonadFork m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)
  => Component query input output m
  -> input
  -> DOM.HTMLElement
  -> m (HalogenSocket query output m)
runUI :: forall (m :: * -> *) (query :: * -> *) input output.
(MonadDOM m, MonadUnliftIO m, MonadFork m, MonadKill m,
 MonadParallel m, MonadMask m, MonadUUID m) =>
Component query input output m
-> input -> HTMLElement -> m (HalogenSocket query output m)
runUI Component query input output m
component input
i HTMLElement
element = do
  document <- HTMLDocument -> Document
forall a. a -> Document
toDocument (HTMLDocument -> Document) -> m HTMLDocument -> m Document
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Window -> m HTMLDocument
forall (m :: * -> *). MonadDOM m => Window -> m HTMLDocument
DOM.document (Window -> m HTMLDocument) -> m Window -> m HTMLDocument
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.window)
  AD.runUI (renderSpec document element) component i

renderSpec
  :: forall m
   . (DOM.MonadDOM m, MonadIO m)
  => DOM.Document
  -> DOM.HTMLElement
  -> AD.RenderSpec m (RenderState m)
renderSpec :: forall (m :: * -> *).
(MonadDOM m, MonadIO m) =>
Document -> HTMLElement -> RenderSpec m (RenderState m)
renderSpec Document
document HTMLElement
container =
  AD.RenderSpec
    { (Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX (RenderState m)))
-> HTML (ComponentSlot ps m act) act
-> Maybe (RenderState m s act ps o)
-> m (RenderState m s act ps o)
forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX (RenderState m)))
-> HTML (ComponentSlot ps m act) act
-> Maybe (RenderState m s act ps o)
-> m (RenderState m s act ps o)
render :: forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX (RenderState m)))
-> HTML (ComponentSlot ps m act) act
-> Maybe (RenderState m s act ps o)
-> m (RenderState m s act ps o)
render :: forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX (RenderState m)))
-> HTML (ComponentSlot ps m act) act
-> Maybe (RenderState m s act ps o)
-> m (RenderState m s act ps o)
render
    , renderChild :: forall s act (ps :: Row (*)) o.
RenderState m s act ps o -> RenderState m s act ps o
renderChild = RenderState m s act ps o -> RenderState m s act ps o
forall a. a -> a
forall s act (ps :: Row (*)) o.
RenderState m s act ps o -> RenderState m s act ps o
identity
    , RenderState m s act ps o -> m ()
forall s act (ps :: Row (*)) o. RenderState m s act ps o -> m ()
forall (m :: * -> *) state action (slots :: Row (*)) output.
MonadDOM m =>
RenderState m state action slots output -> m ()
removeChild :: forall s act (ps :: Row (*)) o. RenderState m s act ps o -> m ()
removeChild :: forall (m :: * -> *) state action (slots :: Row (*)) output.
MonadDOM m =>
RenderState m state action slots output -> m ()
removeChild
    , dispose :: forall s act (ps :: Row (*)) o. RenderState m s act ps o -> m ()
dispose = RenderState m s act ps o -> m ()
forall s act (ps :: Row (*)) o. RenderState m s act ps o -> m ()
forall (m :: * -> *) state action (slots :: Row (*)) output.
MonadDOM m =>
RenderState m state action slots output -> m ()
removeChild
    }
  where
    render
      :: forall state action slots output
       . (Input action -> m ())
      -> (ComponentSlotBox slots m action -> m (RenderStateX (RenderState m)))
      -> HTML (ComponentSlot slots m action) action
      -> Maybe (RenderState m state action slots output)
      -> m (RenderState m state action slots output)
    render :: forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX (RenderState m)))
-> HTML (ComponentSlot ps m act) act
-> Maybe (RenderState m s act ps o)
-> m (RenderState m s act ps o)
render Input action -> m ()
handler ComponentSlotBox slots m action -> m (RenderStateX (RenderState m))
child (HTML VDom [Prop (Input action)] (ComponentSlot slots m action)
vdom) =
      \case
        Maybe (RenderState m state action slots output)
Nothing -> do
          renderChildRef <- (ComponentSlotBox slots m action
 -> m (RenderStateX (RenderState m)))
-> m (IORef
        (ComponentSlotBox slots m action
         -> m (RenderStateX (RenderState m))))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef ComponentSlotBox slots m action -> m (RenderStateX (RenderState m))
child
          let spec = (Input action -> m ())
-> IORef
     (ComponentSlotBox slots m action
      -> m (RenderStateX (RenderState m)))
-> Document
-> VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
forall (m :: * -> *) action (slots :: Row (*)).
(MonadIO m, MonadDOM m) =>
(Input action -> m ())
-> IORef (ChildRenderer m action slots)
-> Document
-> VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)
mkSpec Input action -> m ()
handler IORef
  (ComponentSlotBox slots m action
   -> m (RenderStateX (RenderState m)))
renderChildRef Document
document
          machine <- V.buildVDom spec vdom
          let node = Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
-> Node
forall (m :: * -> *) a b. Step m a b -> b
V.extract Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
machine
          void $ DOM.appendChild node $ toParentNode $ toNode container
          pure $ RenderState {machine, node, renderChildRef}
        Just (RenderState {Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
machine :: forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output
-> Step m (VHTML m action slots) Node
machine :: Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
machine, Node
node :: forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output -> Node
node :: Node
node, IORef
  (ComponentSlotBox slots m action
   -> m (RenderStateX (RenderState m)))
renderChildRef :: forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output
-> IORef (ChildRenderer m action slots)
renderChildRef :: IORef
  (ComponentSlotBox slots m action
   -> m (RenderStateX (RenderState m)))
renderChildRef}) -> do
          IORef
  (ComponentSlotBox slots m action
   -> m (RenderStateX (RenderState m)))
-> (ComponentSlotBox slots m action
    -> m (RenderStateX (RenderState m)))
-> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef
  (ComponentSlotBox slots m action
   -> m (RenderStateX (RenderState m)))
renderChildRef ComponentSlotBox slots m action -> m (RenderStateX (RenderState m))
child
          parent <- Node -> m (Maybe ParentNode)
forall (m :: * -> *). MonadDOM m => Node -> m (Maybe ParentNode)
DOM.parentNode Node
node
          nextSib <- DOM.nextSibling node
          machine' <- V.step machine vdom
          let newNode = Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
-> Node
forall (m :: * -> *) a b. Step m a b -> b
V.extract Step
  m (VDom [Prop (Input action)] (ComponentSlot slots m action)) Node
machine'
          unless (node `unsafeRefEq` newNode)
            $ substInParent newNode nextSib parent
          pure $ RenderState {machine = machine', node = newNode, renderChildRef}

removeChild :: forall m state action slots output. (DOM.MonadDOM m) => RenderState m state action slots output -> m ()
removeChild :: forall (m :: * -> *) state action (slots :: Row (*)) output.
MonadDOM m =>
RenderState m state action slots output -> m ()
removeChild (RenderState {Node
node :: forall (m :: * -> *) state action (slots :: Row (*)) output.
RenderState m state action slots output -> Node
node :: Node
node}) = do
  npn <- Node -> m (Maybe ParentNode)
forall (m :: * -> *). MonadDOM m => Node -> m (Maybe ParentNode)
DOM.parentNode Node
node
  traverse_ (DOM.removeChild node) npn

substInParent :: (DOM.MonadDOM m) => DOM.Node -> Maybe DOM.Node -> Maybe ParentNode -> m ()
substInParent :: forall (m :: * -> *).
MonadDOM m =>
Node -> Maybe Node -> Maybe ParentNode -> m ()
substInParent Node
newNode (Just Node
sib) (Just ParentNode
pn) = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Node -> Node -> ParentNode -> m ()
forall (m :: * -> *).
MonadDOM m =>
Node -> Node -> ParentNode -> m ()
DOM.insertBefore Node
newNode Node
sib ParentNode
pn
substInParent Node
newNode Maybe Node
Nothing (Just ParentNode
pn) = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Node -> ParentNode -> m ()
forall (m :: * -> *). MonadDOM m => Node -> ParentNode -> m ()
DOM.appendChild Node
newNode ParentNode
pn
substInParent Node
_ Maybe Node
_ Maybe ParentNode
_ = m ()
forall (f :: * -> *). Applicative f => f ()
pass