{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

-- | A container component which renders a sub-tree to a DOM node not in the
-- | tree. This is useful for when a child component needs to 'break out' of a
-- | parent, like dialogs, modals, and tooltips, especially if the parent has
-- | z-indexing or overflow: hidden set.
module Halogen.Portal where

import Control.Monad.Fork
import Control.Monad.Parallel
import Control.Monad.UUID
import Data.Functor.Coyoneda (Coyoneda (..), hoistCoyoneda)
import Data.NT
import Data.Row
import HPrelude hiding (State)
import Halogen as H hiding (ChildQuery, State)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.IO.Util (awaitBody)
import Halogen.Subscription qualified as HS
import Halogen.VDom.DOM.Monad
import Halogen.VDom.Driver as VDom
import Web.DOM.Internal.Types

data Input query input output m = Input
  { forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> input
input :: input
  , forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> Component query input output m
child :: H.Component query input output m
  , forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> Maybe HTMLElement
targetElement :: Maybe HTMLElement
  }

data State query input output m = State
  { forall (query :: * -> *) input output (m :: * -> *).
State query input output m
-> Maybe (HalogenSocket (Query input query) output m)
socket :: Maybe (H.HalogenSocket (Query input query) output m)
  , forall (query :: * -> *) input output (m :: * -> *).
State query input output m -> input
input :: input
  , forall (query :: * -> *) input output (m :: * -> *).
State query input output m -> Component query input output m
child :: H.Component query input output m
  , forall (query :: * -> *) input output (m :: * -> *).
State query input output m -> Maybe HTMLElement
targetElement :: Maybe HTMLElement
  }

portal
  :: forall label
    ->forall query action input output slots slot m
   . ( HasType label (H.Slot query output slot) slots
     , MonadUnliftIO m
     , MonadDOM m
     , MonadKill m
     , MonadParallel m
     , MonadMask m
     , MonadUUID m
     )
  => (KnownSymbol label)
  => (Ord slot)
  => slot
  -> H.Component query input output m
  -> input
  -> Maybe HTMLElement
  -> (output -> action)
  -> H.ComponentHTML action slots m
portal :: forall (label :: Symbol) ->
forall (query :: * -> *) action input output (slots :: Row (*))
       slot (m :: * -> *).
(HasType label (Slot query output slot) slots, MonadUnliftIO m,
 MonadDOM m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m,
 KnownSymbol label, Ord slot) =>
slot
-> Component query input output m
-> input
-> Maybe HTMLElement
-> (output -> action)
-> ComponentHTML action slots m
portal label' slot
slot' Component query input output m
child input
input' Maybe HTMLElement
htmlElement output -> action
handler' =
  slot
-> Component query (Input query input output m) output m
-> Input query input output m
-> (output -> action)
-> ComponentHTML action slots m
forall (label :: Symbol) ->
forall (query :: * -> *) action input output (slots :: Row (*))
       (m :: * -> *) slot.
(HasType label (Slot query output slot) slots, KnownSymbol label,
 Ord slot) =>
slot
-> Component query input output m
-> input
-> (output -> action)
-> ComponentHTML action slots m
forall (query :: * -> *) action input output (slots :: Row (*))
       (m :: * -> *) slot.
(HasType label (Slot query output slot) slots, KnownSymbol label,
 Ord slot) =>
slot
-> Component query input output m
-> input
-> (output -> action)
-> ComponentHTML action slots m
HH.slot
    label'
    slot
slot'
    Component query (Input query input output m) output m
forall (q :: * -> *) i o (m :: * -> *).
(MonadDOM m, MonadUnliftIO m, MonadKill m, MonadParallel m,
 MonadMask m, MonadUUID m) =>
Component q (Input q i o m) o m
component
    ( Input
        { Component query input output m
child :: Component query input output m
child :: Component query input output m
child
        , input :: input
input = input
input'
        , targetElement :: Maybe HTMLElement
targetElement = Maybe HTMLElement
htmlElement
        }
    )
    output -> action
handler'

data Query input query a
  = SetInput input a
  | ChildQuery (query a)

-- wraps the portalled component and provides a SetInput query
-- that can be used by the Portal component to update the child's
-- input when it receives new values from the parent
wrapper
  :: forall query input output m
   . (MonadIO m)
  => H.Component (Query input query) (State query input output m) output m
wrapper :: forall (query :: * -> *) input output (m :: * -> *).
MonadIO m =>
Component (Query input query) (State query input output m) output m
wrapper =
  ComponentSpec
  (State query input output m)
  (Query input query)
  output
  ('R '["content" ':-> Slot query output ()])
  (State query input output m)
  output
  m
-> Component
     (Query input query) (State query input output m) output m
forall state (query :: * -> *) action (slots :: Row (*)) input
       output (m :: * -> *).
ComponentSpec state query action slots input output m
-> Component query input output m
H.mkComponent
    (ComponentSpec
   (State query input output m)
   (Query input query)
   output
   ('R '["content" ':-> Slot query output ()])
   (State query input output m)
   output
   m
 -> Component
      (Query input query) (State query input output m) output m)
-> ComponentSpec
     (State query input output m)
     (Query input query)
     output
     ('R '["content" ':-> Slot query output ()])
     (State query input output m)
     output
     m
-> Component
     (Query input query) (State query input output m) output m
forall a b. (a -> b) -> a -> b
$ H.ComponentSpec
      { initialState :: State query input output m -> m (State query input output m)
initialState = State query input output m -> m (State query input output m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      , State query input output m
-> HTML
     (ComponentSlot
        ('R '["content" ':-> Slot query output ()]) m output)
     output
forall {slots :: Row (*)} {query :: * -> *} {i} {input}
       {m :: * -> *}.
((slots .! "content") ~ Slot query i ()) =>
State query input i m -> HTML (ComponentSlot slots m i) i
render :: forall {slots :: Row (*)} {query :: * -> *} {i} {input}
       {m :: * -> *}.
((slots .! "content") ~ Slot query i ()) =>
State query input i m -> HTML (ComponentSlot slots m i) i
render :: State query input output m
-> HTML
     (ComponentSlot
        ('R '["content" ':-> Slot query output ()]) m output)
     output
render
      , eval :: HalogenQ (Query input query) output (State query input output m)
~> HalogenM
     (State query input output m)
     output
     ('R '["content" ':-> Slot query output ()])
     output
     m
eval =
          EvalSpec
  (State query input output m)
  (Query input query)
  output
  ('R '["content" ':-> Slot query output ()])
  (State query input output m)
  output
  m
-> HalogenQ (Query input query) output (State query input output m)
   ~> HalogenM
        (State query input output m)
        output
        ('R '["content" ':-> Slot query output ()])
        output
        m
forall state (query :: * -> *) action (slots :: Row (*)) input
       output (m :: * -> *).
EvalSpec state query action slots input output m
-> HalogenQ query action input
   ~> HalogenM state action slots output m
H.mkEval
            (EvalSpec
   (State query input output m)
   (Query input query)
   output
   ('R '["content" ':-> Slot query output ()])
   (State query input output m)
   output
   m
 -> HalogenQ (Query input query) output (State query input output m)
    ~> HalogenM
         (State query input output m)
         output
         ('R '["content" ':-> Slot query output ()])
         output
         m)
-> EvalSpec
     (State query input output m)
     (Query input query)
     output
     ('R '["content" ':-> Slot query output ()])
     (State query input output m)
     output
     m
-> HalogenQ (Query input query) output (State query input output m)
   ~> HalogenM
        (State query input output m)
        output
        ('R '["content" ':-> Slot query output ()])
        output
        m
forall a b. (a -> b) -> a -> b
$ EvalSpec
  (ZonkAny 4)
  (ZonkAny 3)
  output
  (ZonkAny 2)
  (State query input output m)
  (ZonkAny 1)
  (ZonkAny 0)
forall state (query :: * -> *) action (slots :: Row (*)) input
       output (m :: * -> *).
EvalSpec state query action slots input output m
H.defaultEval
              { H.handleQuery = handleQuery
              , H.handleAction = H.raise
              }
      }
  where
    render :: State query input i m -> HTML (ComponentSlot slots m i) i
render (State {input
input :: forall (query :: * -> *) input output (m :: * -> *).
State query input output m -> input
input :: input
input, Component query input i m
child :: forall (query :: * -> *) input output (m :: * -> *).
State query input output m -> Component query input output m
child :: Component query input i m
child}) =
      Node HTMLdiv (ComponentSlot slots m i) i
forall w i. Node HTMLdiv w i
HH.div
        [Text
-> IProp
     ('R
        '["accessKey" ':-> Text, "class" ':-> Text,
          "contentEditable" ':-> Bool, "dir" ':-> DirValue,
          "draggable" ':-> Bool, "hidden" ':-> Bool, "id" ':-> Text,
          "lang" ':-> Text, "onAuxClick" ':-> MouseEvent,
          "onBeforeInput" ':-> Event, "onBlur" ':-> FocusEvent,
          "onClick" ':-> MouseEvent, "onContextMenu" ':-> Event,
          "onCopy" ':-> ClipboardEvent, "onCut" ':-> ClipboardEvent,
          "onDoubleClick" ':-> MouseEvent, "onDrag" ':-> DragEvent,
          "onDragEnd" ':-> DragEvent, "onDragEnter" ':-> DragEvent,
          "onDragExit" ':-> DragEvent, "onDragLeave" ':-> DragEvent,
          "onDragOver" ':-> DragEvent, "onDragStart" ':-> DragEvent,
          "onDrop" ':-> DragEvent, "onFocus" ':-> FocusEvent,
          "onFocusIn" ':-> FocusEvent, "onFocusOut" ':-> FocusEvent,
          "onGotPointerCapture" ':-> PointerEvent, "onInput" ':-> Event,
          "onKeyDown" ':-> KeyboardEvent, "onKeyPress" ':-> KeyboardEvent,
          "onKeyUp" ':-> KeyboardEvent,
          "onLostPointerCapture" ':-> PointerEvent,
          "onMouseDown" ':-> MouseEvent, "onMouseEnter" ':-> MouseEvent,
          "onMouseLeave" ':-> MouseEvent, "onMouseMove" ':-> MouseEvent,
          "onMouseOut" ':-> MouseEvent, "onMouseOver" ':-> MouseEvent,
          "onMouseUp" ':-> MouseEvent, "onPaste" ':-> ClipboardEvent,
          "onPointerCancel" ':-> PointerEvent,
          "onPointerDown" ':-> PointerEvent,
          "onPointerEnter" ':-> PointerEvent,
          "onPointerLeave" ':-> PointerEvent,
          "onPointerMove" ':-> PointerEvent,
          "onPointerOut" ':-> PointerEvent,
          "onPointerOver" ':-> PointerEvent, "onPointerUp" ':-> PointerEvent,
          "onScroll" ':-> Event, "onTouchCancel" ':-> TouchEvent,
          "onTouchEnd" ':-> TouchEvent, "onTouchEnter" ':-> TouchEvent,
          "onTouchLeave" ':-> TouchEvent, "onTouchMove" ':-> TouchEvent,
          "onTouchStart" ':-> TouchEvent, "onTransitionEnd" ':-> Event,
          "onWheel" ':-> WheelEvent, "spellcheck" ':-> Bool,
          "style" ':-> Text, "tabIndex" ':-> Int, "title" ':-> Text])
     i
forall (r :: Row (*)) i.
HasType "style" Text r =>
Text -> IProp r i
HP.styleText Text
"display: contents"]
        [()
-> Component query input i m
-> input
-> (i -> i)
-> HTML (ComponentSlot slots m i) i
forall (label :: Symbol) ->
forall (query :: * -> *) action input output (slots :: Row (*))
       (m :: * -> *) slot.
(HasType label (Slot query output slot) slots, KnownSymbol label,
 Ord slot) =>
slot
-> Component query input output m
-> input
-> (output -> action)
-> ComponentHTML action slots m
forall (query :: * -> *) action input output (slots :: Row (*))
       (m :: * -> *) slot.
(HasType "content" (Slot query output slot) slots,
 KnownSymbol "content", Ord slot) =>
slot
-> Component query input output m
-> input
-> (output -> action)
-> ComponentHTML action slots m
HH.slot "content" () Component query input i m
child input
input i -> i
forall a. a -> a
identity]

    handleQuery
      :: forall action a
       . Query input query a
      -> H.HalogenM (State query input output m) action ("content" .== H.Slot _ _ _) output m (Maybe a)
    handleQuery :: Query input query a
-> HalogenM
     (State query input output m)
     action
     ("content" .== Slot query output' ())
     output
     m
     (Maybe a)
handleQuery = \case
      SetInput input
input a
a -> do
        (State query input output m -> State query input output m)
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State query input output m -> State query input output m)
 -> HalogenM
      (State query input output m)
      action
      ('R '["content" ':-> Slot query output' ()])
      output
      m
      ())
-> (State query input output m -> State query input output m)
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     ()
forall a b. (a -> b) -> a -> b
$ \State query input output m
s -> State query input output m
s {input} :: State query input output m
        Maybe a
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     (Maybe a)
forall a.
a
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a
 -> HalogenM
      (State query input output m)
      action
      ('R '["content" ':-> Slot query output' ()])
      output
      m
      (Maybe a))
-> Maybe a
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
      ChildQuery query a
query -> do
        res <- ()
-> query a
-> HalogenM
     (State query input output m)
     action
     ('R '["content" ':-> Slot query output' ()])
     output
     m
     (Maybe a)
forall (label :: Symbol) ->
forall state action output (m :: * -> *) (slots :: Row (*))
       (query :: * -> *) output' slot a.
(HasType label (Slot query output' slot) slots, KnownSymbol label,
 Ord slot, Functor m) =>
slot -> query a -> HalogenM state action slots output m (Maybe a)
forall state action output (m :: * -> *) (slots :: Row (*))
       (query :: * -> *) output' slot a.
(HasType "content" (Slot query output' slot) slots,
 KnownSymbol "content", Ord slot, Functor m) =>
slot -> query a -> HalogenM state action slots output m (Maybe a)
H.query "content" () query a
query
        pure res

component
  :: forall q i o m
   . (MonadDOM m, MonadUnliftIO m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)
  => H.Component q (Input q i o m) o m
component :: forall (q :: * -> *) i o (m :: * -> *).
(MonadDOM m, MonadUnliftIO m, MonadKill m, MonadParallel m,
 MonadMask m, MonadUUID m) =>
Component q (Input q i o m) o m
component =
  ComponentSpec (State q i o m) q o Empty (Input q i o m) o m
-> Component q (Input q i o m) o m
forall state (query :: * -> *) action (slots :: Row (*)) input
       output (m :: * -> *).
ComponentSpec state query action slots input output m
-> Component query input output m
H.mkComponent
    (ComponentSpec (State q i o m) q o Empty (Input q i o m) o m
 -> Component q (Input q i o m) o m)
-> ComponentSpec (State q i o m) q o Empty (Input q i o m) o m
-> Component q (Input q i o m) o m
forall a b. (a -> b) -> a -> b
$ H.ComponentSpec
      { initialState :: Input q i o m -> m (State q i o m)
initialState = \Input {i
Maybe HTMLElement
Component q i o m
input :: forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> input
child :: forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> Component query input output m
targetElement :: forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> Maybe HTMLElement
input :: i
child :: Component q i o m
targetElement :: Maybe HTMLElement
..} -> State q i o m -> m (State q i o m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State {socket :: Maybe (HalogenSocket (Query i q) o m)
socket = Maybe (HalogenSocket (Query i q) o m)
forall a. Maybe a
Nothing, i
Maybe HTMLElement
Component q i o m
input :: i
child :: Component q i o m
targetElement :: Maybe HTMLElement
input :: i
child :: Component q i o m
targetElement :: Maybe HTMLElement
..}
      , State q i o m -> HTML (ComponentSlot Empty m o) o
render :: State q i o m -> HTML (ComponentSlot Empty m o) o
render :: State q i o m -> HTML (ComponentSlot Empty m o) o
render
      , HalogenQ q o (Input q i o m)
~> HalogenM (State q i o m) o Empty o m
eval :: HalogenQ q o (Input q i o m)
~> HalogenM (State q i o m) o Empty o m
eval :: HalogenQ q o (Input q i o m)
~> HalogenM (State q i o m) o Empty o m
eval
      }
  where
    eval
      :: H.HalogenQ q o (Input q i o m) ~> H.HalogenM (State q i o m) o Empty o m
    eval :: HalogenQ q o (Input q i o m)
~> HalogenM (State q i o m) o Empty o m
eval = (forall a.
 HalogenQ q o (Input q i o m) a
 -> HalogenM (State q i o m) o Empty o m a)
-> HalogenQ q o (Input q i o m)
   ~> HalogenM (State q i o m) o Empty o m
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a) -> m ~> n
NT ((forall a.
  HalogenQ q o (Input q i o m) a
  -> HalogenM (State q i o m) o Empty o m a)
 -> HalogenQ q o (Input q i o m)
    ~> HalogenM (State q i o m) o Empty o m)
-> (forall a.
    HalogenQ q o (Input q i o m) a
    -> HalogenM (State q i o m) o Empty o m a)
-> HalogenQ q o (Input q i o m)
   ~> HalogenM (State q i o m) o Empty o m
forall a b. (a -> b) -> a -> b
$ \case
      H.Initialize a
a -> do
        state <- HalogenM (State q i o m) o Empty o m (State q i o m)
forall s (m :: * -> *). MonadState s m => m s
get
        UnliftIO f <- lift askUnliftIO
        -- The target element can either be the one supplied by the user, or the
        -- document body. Either way, we'll run the sub-tree at the target and
        -- save the resulting interface.
        target <- maybe (lift awaitBody) pure state.targetElement
        socket@H.HalogenSocket {messages = HS.Emitter k} <- lift $ VDom.runUI wrapper state target
        -- Subscribe to the child component's messages
        void $ H.subscribe $ HS.Emitter $ \o -> IO ()
emit' ->
          (Subscription m -> Subscription IO)
-> IO (Subscription m) -> IO (Subscription IO)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m ~> IO) -> Subscription m -> Subscription IO
forall (m :: * -> *) (n :: * -> *).
(m ~> n) -> Subscription m -> Subscription n
HS.hoistSubscription ((forall a. m a -> IO a) -> m ~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a) -> m ~> n
NT m a -> IO a
forall a. m a -> IO a
f)) (IO (Subscription m) -> IO (Subscription IO))
-> IO (Subscription m) -> IO (Subscription IO)
forall a b. (a -> b) -> a -> b
$ m (Subscription m) -> IO (Subscription m)
forall a. m a -> IO a
f (m (Subscription m) -> IO (Subscription m))
-> m (Subscription m) -> IO (Subscription m)
forall a b. (a -> b) -> a -> b
$ (o -> m ()) -> m (Subscription m)
k ((o -> m ()) -> m (Subscription m))
-> (o -> m ()) -> m (Subscription m)
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (o -> IO ()) -> o -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> IO ()
emit'
        modify $ \State q i o m
s -> State q i o m
s {socket = Just socket} :: State q i o m
        pure a
      H.Finalize a
a -> do
        (State q i o m -> Maybe (HalogenSocket (Query i q) o m))
-> HalogenM
     (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (.socket) HalogenM
  (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
-> (Maybe (HalogenSocket (Query i q) o m)
    -> HalogenM (State q i o m) o Empty o m ())
-> HalogenM (State q i o m) o Empty o m ()
forall a b.
HalogenM (State q i o m) o Empty o m a
-> (a -> HalogenM (State q i o m) o Empty o m b)
-> HalogenM (State q i o m) o Empty o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HalogenSocket (Query i q) o m
 -> HalogenM (State q i o m) o Empty o m ())
-> Maybe (HalogenSocket (Query i q) o m)
-> HalogenM (State q i o m) o Empty o m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (m () -> HalogenM (State q i o m) o Empty o m ()
forall (m :: * -> *) a.
Monad m =>
m a -> HalogenM (State q i o m) o Empty o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HalogenM (State q i o m) o Empty o m ())
-> (HalogenSocket (Query i q) o m -> m ())
-> HalogenSocket (Query i q) o m
-> HalogenM (State q i o m) o Empty o m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.dispose))
        a -> HalogenM (State q i o m) o Empty o m a
forall a. a -> HalogenM (State q i o m) o Empty o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      H.Receive (Input {i
input :: forall (query :: * -> *) input output (m :: * -> *).
Input query input output m -> input
input :: i
input}) a
a ->
        (State q i o m -> Maybe (HalogenSocket (Query i q) o m))
-> HalogenM
     (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (.socket)
          HalogenM
  (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
-> (Maybe (HalogenSocket (Query i q) o m)
    -> HalogenM (State q i o m) o Empty o m a)
-> HalogenM (State q i o m) o Empty o m a
forall a b.
HalogenM (State q i o m) o Empty o m a
-> (a -> HalogenM (State q i o m) o Empty o m b)
-> HalogenM (State q i o m) o Empty o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (HalogenSocket (Query i q) o m)
Nothing -> a -> HalogenM (State q i o m) o Empty o m a
forall a. a -> HalogenM (State q i o m) o Empty o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
            Just HalogenSocket (Query i q) o m
io -> do
              HalogenM (State q i o m) o Empty o m (Maybe a)
-> HalogenM (State q i o m) o Empty o m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (HalogenM (State q i o m) o Empty o m (Maybe a)
 -> HalogenM (State q i o m) o Empty o m ())
-> HalogenM (State q i o m) o Empty o m (Maybe a)
-> HalogenM (State q i o m) o Empty o m ()
forall a b. (a -> b) -> a -> b
$ m (Maybe a) -> HalogenM (State q i o m) o Empty o m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
m a -> HalogenM (State q i o m) o Empty o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe a) -> HalogenM (State q i o m) o Empty o m (Maybe a))
-> m (Maybe a) -> HalogenM (State q i o m) o Empty o m (Maybe a)
forall a b. (a -> b) -> a -> b
$ HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)
forall a.
HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)
ioq HalogenSocket (Query i q) o m
io (i -> a -> Query i q a
forall input (query :: * -> *) a. input -> a -> Query input query a
SetInput i
input a
a)
              a -> HalogenM (State q i o m) o Empty o m a
forall a. a -> HalogenM (State q i o m) o Empty o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      H.Action o
output a
a -> do
        o -> HalogenM (State q i o m) o Empty o m ()
forall state action (slots :: Row (*)) output (m :: * -> *).
Functor m =>
output -> HalogenM state action slots output m ()
H.raise o
output
        a -> HalogenM (State q i o m) o Empty o m a
forall a. a -> HalogenM (State q i o m) o Empty o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      H.Query Coyoneda q a
query () -> a
fail ->
        (State q i o m -> Maybe (HalogenSocket (Query i q) o m))
-> HalogenM
     (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (.socket)
          HalogenM
  (State q i o m) o Empty o m (Maybe (HalogenSocket (Query i q) o m))
-> (Maybe (HalogenSocket (Query i q) o m)
    -> HalogenM (State q i o m) o Empty o m a)
-> HalogenM (State q i o m) o Empty o m a
forall a b.
HalogenM (State q i o m) o Empty o m a
-> (a -> HalogenM (State q i o m) o Empty o m b)
-> HalogenM (State q i o m) o Empty o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (HalogenSocket (Query i q) o m)
Nothing -> a -> HalogenM (State q i o m) o Empty o m a
forall a. a -> HalogenM (State q i o m) o Empty o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> HalogenM (State q i o m) o Empty o m a)
-> a -> HalogenM (State q i o m) o Empty o m a
forall a b. (a -> b) -> a -> b
$ () -> a
fail ()
            Just HalogenSocket (Query i q) o m
io -> m a -> HalogenM (State q i o m) o Empty o m a
forall (m :: * -> *) a.
Monad m =>
m a -> HalogenM (State q i o m) o Empty o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HalogenM (State q i o m) o Empty o m a)
-> m a -> HalogenM (State q i o m) o Empty o m a
forall a b. (a -> b) -> a -> b
$ case (forall a. q a -> Query i q a)
-> Coyoneda q a -> Coyoneda (Query i q) a
forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Coyoneda f b -> Coyoneda g b
hoistCoyoneda q a -> Query i q a
forall a. q a -> Query i q a
forall input (query :: * -> *) a. query a -> Query input query a
ChildQuery Coyoneda q a
query of
              Coyoneda b -> a
k Query i q b
q -> a -> (b -> a) -> Maybe b -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> a
fail ()) b -> a
k (Maybe b -> a) -> m (Maybe b) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HalogenSocket (Query i q) o m -> Query i q b -> m (Maybe b)
forall a.
HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)
ioq HalogenSocket (Query i q) o m
io Query i q b
q

    -- We don't need to render anything; this component is explicitly meant to be
    -- passed through.
    render :: State q i o m -> H.ComponentHTML o Empty m
    render :: State q i o m -> HTML (ComponentSlot Empty m o) o
render State q i o m
_ = Text -> HTML (ComponentSlot Empty m o) o
forall w i. Text -> HTML w i
HH.text Text
""

    -- This is needed for a hint to the typechecker. Without it there's an
    -- impredicativity issue with `a` when `HalogenIO` is taken from `State`.
    ioq :: forall a. H.HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)
    ioq :: forall a.
HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)
ioq H.HalogenSocket {forall a. Query i q a -> m (Maybe a)
query :: forall a. Query i q a -> m (Maybe a)
query :: forall (query :: * -> *) output (m :: * -> *).
HalogenSocket query output m -> forall a. query a -> m (Maybe a)
query} = Query i q a -> m (Maybe a)
forall a. Query i q a -> m (Maybe a)
query