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

{-# HLINT ignore "Eta reduce" #-}
module Halogen.VDom.Thunk where

import Data.Foreign
import HPrelude hiding (state)
import Halogen.VDom qualified as V
import Halogen.VDom.DOM.Monad
import Unsafe.Coerce
import Web.DOM.Internal.Types

newtype ThunkId = ThunkId (Foreign ThunkId)

unsafeThunkId :: a -> ThunkId
unsafeThunkId :: forall a. a -> ThunkId
unsafeThunkId = a -> ThunkId
forall a b. a -> b
unsafeCoerce

data Thunk f i = forall a. Thunk ThunkId (a -> a -> Bool) (a -> f i) a

deriving instance (Functor f) => Functor (Thunk f)

unsafeEqThunk :: forall f i. Thunk f i -> Thunk f i -> Bool
unsafeEqThunk :: forall {k} (f :: k -> *) (i :: k). Thunk f i -> Thunk f i -> Bool
unsafeEqThunk (Thunk ThunkId
a1 a -> a -> Bool
b1 a -> f i
_ a
d1) (Thunk ThunkId
a2 a -> a -> Bool
b2 a -> f i
_ a
d2) =
  ThunkId -> ThunkId -> Bool
forall a. a -> a -> Bool
unsafeRefEq ThunkId
a1 ThunkId
a2
    Bool -> Bool -> Bool
&& (a -> a -> Bool) -> (a -> a -> Bool) -> Bool
forall a b. a -> b -> Bool
unsafeRefEq' a -> a -> Bool
b1 a -> a -> Bool
b2
    Bool -> Bool -> Bool
&& a -> a -> Bool
b1 a
d1 (a -> a
forall a b. a -> b
unsafeCoerce a
d2)

data ThunkState m f i a w = ThunkState
  { forall {k} (m :: * -> *) (f :: k -> *) (i :: k) a w.
ThunkState m f i a w -> Step m (VDom a w) Node
vdom :: V.Step m (V.VDom a w) Node
  , forall {k} (m :: * -> *) (f :: k -> *) (i :: k) a w.
ThunkState m f i a w -> Thunk f i
thunk :: Thunk f i
  }

hoist :: forall f g a. (forall x. f x -> g x) -> Thunk f a -> Thunk g a
hoist :: forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(forall (x :: k). f x -> g x) -> Thunk f a -> Thunk g a
hoist forall (x :: k). f x -> g x
f = (f a -> g a) -> Thunk f a -> Thunk g a
forall {k} {k} (f :: k -> *) (g :: k -> *) (i :: k) (j :: k).
(f i -> g j) -> Thunk f i -> Thunk g j
mapThunk f a -> g a
forall (x :: k). f x -> g x
f

mapThunk :: forall f g i j. (f i -> g j) -> Thunk f i -> Thunk g j
mapThunk :: forall {k} {k} (f :: k -> *) (g :: k -> *) (i :: k) (j :: k).
(f i -> g j) -> Thunk f i -> Thunk g j
mapThunk f i -> g j
k (Thunk ThunkId
a a -> a -> Bool
b a -> f i
c a
d) = ThunkId -> (a -> a -> Bool) -> (a -> g j) -> a -> Thunk g j
forall {k} (f :: k -> *) (i :: k) a.
ThunkId -> (a -> a -> Bool) -> (a -> f i) -> a -> Thunk f i
Thunk ThunkId
a a -> a -> Bool
b (f i -> g j
k (f i -> g j) -> (a -> f i) -> a -> g j
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f i
c) a
d

runThunk :: forall f i. Thunk f i -> f i
runThunk :: forall {k} (f :: k -> *) (i :: k). Thunk f i -> f i
runThunk (Thunk ThunkId
_ a -> a -> Bool
_ a -> f i
render a
arg) = a -> f i
render a
arg

#if defined(javascript_HOST_ARCH)
{-# SPECIALISE buildThunk :: (f i -> V.VDom a w) -> V.VDomSpec IO a w -> V.Machine IO (Thunk f i) Node #-}
#endif
buildThunk
  :: forall m f i a w
   . (MonadDOM m)
  => (f i -> V.VDom a w)
  -> V.VDomSpec m a w
  -> V.Machine m (Thunk f i) Node
buildThunk :: 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
buildThunk f i -> VDom a w
toVDom = VDomSpec m a w -> Machine m (Thunk f i) Node
renderThunk
  where
    renderThunk :: V.VDomSpec m a w -> V.Machine m (Thunk f i) Node
    renderThunk :: VDomSpec m a w -> Machine m (Thunk f i) Node
renderThunk VDomSpec m a w
spec Thunk f i
t = do
      vdom <- VDomSpec m a w -> VDomMachine m a w
forall (m :: * -> *) a w.
MonadDOM m =>
VDomSpec m a w -> VDomMachine m a w
V.buildVDom VDomSpec m a w
spec (f i -> VDom a w
toVDom (Thunk f i -> f i
forall {k} (f :: k -> *) (i :: k). Thunk f i -> f i
runThunk Thunk f i
t))
      pure $ V.Step (V.extract vdom) (ThunkState {thunk = t, vdom}) patchThunk haltThunk

    patchThunk :: ThunkState m f i a w -> Thunk f i -> m (V.Step m (Thunk f i) Node)
    patchThunk :: ThunkState m f i a w -> Machine m (Thunk f i) Node
patchThunk ThunkState m f i a w
state Thunk f i
t2 = do
      let ThunkState {vdom :: forall {k} (m :: * -> *) (f :: k -> *) (i :: k) a w.
ThunkState m f i a w -> Step m (VDom a w) Node
vdom = Step m (VDom a w) Node
prev, thunk :: forall {k} (m :: * -> *) (f :: k -> *) (i :: k) a w.
ThunkState m f i a w -> Thunk f i
thunk = Thunk f i
t1} = ThunkState m f i a w
state
      if Thunk f i -> Thunk f i -> Bool
forall {k} (f :: k -> *) (i :: k). Thunk f i -> Thunk f i -> Bool
unsafeEqThunk Thunk f i
t1 Thunk f i
t2
        then Step m (Thunk f i) Node -> m (Step m (Thunk f i) Node)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Step m (Thunk f i) Node -> m (Step m (Thunk f i) Node))
-> Step m (Thunk f i) Node -> m (Step m (Thunk f i) Node)
forall a b. (a -> b) -> a -> b
$ Node
-> ThunkState m f i a w
-> (ThunkState m f i a w -> Machine m (Thunk f i) Node)
-> (ThunkState m f i a w -> m ())
-> Step m (Thunk f i) Node
forall (m :: * -> *) a b s.
b -> s -> (s -> a -> m (Step m a b)) -> (s -> m ()) -> Step m a b
V.Step (Step m (VDom a w) Node -> Node
forall (m :: * -> *) a b. Step m a b -> b
V.extract Step m (VDom a w) Node
prev) ThunkState m f i a w
state ThunkState m f i a w -> Machine m (Thunk f i) Node
patchThunk ThunkState m f i a w -> m ()
haltThunk
        else do
          vdom <- Step m (VDom a w) Node -> VDomMachine m a w
forall (m :: * -> *) a b. Step m a b -> a -> m (Step m a b)
V.step Step m (VDom a w) Node
prev (f i -> VDom a w
toVDom (Thunk f i -> f i
forall {k} (f :: k -> *) (i :: k). Thunk f i -> f i
runThunk Thunk f i
t2))
          pure $ V.Step (V.extract vdom) (ThunkState {vdom, thunk = t2}) patchThunk haltThunk

    haltThunk :: ThunkState m f i a w -> m ()
    haltThunk :: ThunkState m f i a w -> m ()
haltThunk ThunkState m f i a w
state = Step m (VDom a w) Node -> m ()
forall (m :: * -> *) a b. Step m a b -> m ()
V.halt ThunkState m f i a w
state.vdom