Pass callback to Halogen child

Main.purs

module Main where

import Prelude

import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Symbol (SProxy(..))
import Effect (Effect)
import Effect.AVar as AVar
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)
import Halogen (liftEffect)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.Query.EventSource (affEventSource)
import Halogen.Query.EventSource as EventSource
import Halogen.VDom.Driver (runUI)

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI parent unit body

-- Create an `Aff` function that can be used to trigger an action in one component
-- to be evaluated in another.
mkCallback :: forall st act ps o m. MonadAff m => act -> H.HalogenM st act ps o m (Maybe (Aff Unit))
mkCallback f = do
  cbAVar <- liftEffect AVar.empty

  _ <- H.subscribe $ affEventSource \emitter -> do
    let callback = EventSource.emit emitter f 
    pure mempty <* liftEffect (AVar.tryPut callback cbAVar)

  liftEffect $ AVar.tryTake cbAVar

-- The parent is able to evaluate actions triggered in the child component by
-- passing down a callback

type ParentState = { count :: Int, cb :: Aff Unit }

type Slots = ( child :: forall q. H.Slot q Void Unit )

_child = SProxy :: SProxy "child"

data ParentAction
  = Initialize 
  | Evaluate (forall o m. H.HalogenM ParentState ParentAction Slots o m Unit)

parent :: forall q i o m. MonadAff m => H.Component HH.HTML q i o m
parent =
  H.mkComponent
    { initialState: \_ -> { count: 0, cb: pure unit }
    , render
    , eval: H.mkEval $ H.defaultEval 
        { handleAction = handleAction 
        , initialize = Just Initialize
        }
    }
  where
  render state =
    HH.div_
      [ HH.p_ [ HH.text $ "You clicked " <> show state.count <> " times" ]
      , HH.slot _child unit child { cb: state.cb } absurd
      ]

  handleAction :: ParentAction -> H.HalogenM ParentState ParentAction Slots o m Unit
  handleAction = case _ of
    Initialize -> do
      -- make the callback function
      mbCallback <- mkCallback $ Evaluate do
        H.modify_ \st -> st { count = st.count + 1 }

      -- set it in state so it can be passed to child components
      for_ mbCallback \cb -> H.modify_ _ { cb = cb }
      
    Evaluate act -> act

-- The child component is able to trigger actions in its parent without sending
-- a message, by receiving a callback passed down.

type ChildInput = { cb :: Aff Unit }

data ChildAction = Run (Aff Unit) | Receive ChildInput

child :: forall q o m. MonadAff m => H.Component HH.HTML q ChildInput o m
child =
  H.mkComponent
    { initialState: identity
    , render
    , eval: H.mkEval $ H.defaultEval 
        { handleAction = handleAction 
        , receive = Just <<< Receive
        }
    }
  where
  render state =
    HH.div_
      [ HH.button
          [ HE.onClick \_ -> Just (Run state.cb) ]
          [ HH.text "Click me (child)" ]
      ]

  handleAction = case _ of 
    Receive i -> H.put i 
    Run cb -> liftAff cb