Running HalogenIO subscribe function in AppM context

Main.purs

module Main where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Reader.Trans (ReaderT, runReaderT, class MonadAsk, asks, ask)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Console (logShow)
import Effect.Ref as Ref
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI)
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Type.Equality (class TypeEquals, from)



-- +------+
-- | Main |
-- +------+

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  clickCountRef <- H.liftEffect $ Ref.new 0
  let
    environment :: Env ExternalState
    environment = { state: clickCountRef }
    
    rootComponent :: forall q. H.Component HH.HTML q (Input ExternalState) Output Aff
    rootComponent = H.hoist (runAppM environment) component
    
  io <- runUI rootComponent initExternal body
  
  -- runAppM environment do
  --   io <- H.lift $ runUI component initExternal body
  --   H.lift $ io.subscribe $ CR.consumer $ case _ of
  --     Changed -> do
  --       _ <- getState
  --       pure Nothing
  
  pure unit

type ExternalState = Int

initExternal :: Input ExternalState
initExternal = { init: 0, renderState: logExternalState, updateState: (_ + 1) }

logExternalState :: Int -> String
logExternalState = show



-- +-----------+
-- | Component |
-- +-----------+

type State s =
  { enabled :: Boolean
  , renderState :: s -> String
  , cache :: s
  , updateState :: s -> s
  }

data Action = Toggle

data Output = Changed

type Input s = 
  { init :: s
  , renderState :: s -> String
  , updateState :: s -> s
  }

component :: forall q s m. ManageState m s => H.Component HH.HTML q (Input s) Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
    }

initialState :: forall s. (Input s) -> State s
initialState { init, renderState, updateState } = { enabled: false, renderState, cache: init, updateState }

render :: forall m s. State s -> H.ComponentHTML Action () m
render { enabled, renderState, cache } =
  let
    label = if enabled then "On" else "Off"
  in
    HH.button
      [ HP.title label
      , HE.onClick \_ -> Just Toggle
      ]
      [ HH.text $ label <> " - clicked " <> renderState cache <> " times"]

handleAction ∷ forall m s. ManageState m s => Action -> H.HalogenM (State s) Action () Output m Unit
handleAction = case _ of
  Toggle -> do
    update <- H.gets _.updateState
    state <- getState
    let state' = update state
    putState state'
    H.modify_ (\st -> st { enabled = not st.enabled, cache = state' })
    H.raise Changed



-- +------+
-- | AppM |
-- +------+

type Env s = { state :: Ref.Ref s }

newtype AppM s a
  = AppM (ReaderT (Env s) Aff a)

runAppM :: forall s. Env s -> AppM s ~> Aff
runAppM env (AppM m) = runReaderT m env

derive newtype instance functorAppM :: Functor (AppM s)
derive newtype instance applyAppM :: Apply (AppM s)
derive newtype instance applicativeAppM :: Applicative (AppM s)
derive newtype instance bindAppM :: Bind (AppM s)
derive newtype instance monadAppM :: Monad (AppM s)
derive newtype instance monadEffectAppM :: MonadEffect (AppM s)
derive newtype instance monadAffAppM :: MonadAff (AppM s)

instance monadAskAppM :: TypeEquals e (Env s) => MonadAsk e (AppM s) where
  ask = AppM $ asks from

class Monad ms <= ManageState ms s | ms -> s where
  getState :: ms s
  putState :: s -> ms Unit

instance manageStateHalogenM :: ManageState ms s => ManageState (H.HalogenM st act slots msg ms) s where
  getState = H.lift getState
  putState = H.lift <<< putState
  
instance manageStateAppM :: ManageState (AppM s) s where
  getState = do
    env <- ask
    liftEffect $ Ref.read env.state
  putState state' = do
    env <- ask
    liftEffect $ Ref.write state' env.state