eventWriter01.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Demo:
-- | 1) config and state (model) accessible everywhere without pushing
-- parameters around in a reflex app.
-- | 2) Pushing more than one event to 'EventWriter' and using
-- 'coincidence' to extract them.
-- | 3) Implementation of (<>) for `EventBubble` is **broken**. To fix
-- it, see comment and also see
-- https://www.reddit.com/r/reflexfrp/comments/85ov8a/how_to_share_auth_tokens_throughout_all_the_app/
-- | Thanks to Robert.

import Reflex
import Reflex.Dom
import Control.Monad.Reader
import Data.Semigroup
import Data.Text
import Control.Lens


data Model t = Model
  { _model_config :: AppConfig
  , _model_a :: Dynamic t Int
  , _model_b :: Dynamic t Int
  }
  
data AppConfig = AppConfig
  { _cfg_baseUri :: Text
  } -- etc.

defaultConfig = AppConfig "http://example.com" -- etc.

data EventBubble t = EventBubble
  { _evbub_evA :: Event t ()
  , _evbub_evB :: Event t ()
  }

makeLenses ''EventBubble

instance (Reflex t) => Semigroup (EventBubble t) where
  (<>) a _ = a
  -- This is broken for the A||B button, i.e. for events occurring a the same time.  
  -- Replace it with the folling implementation to fix it:
  --(<>) a b = EventBubble
  --           (a^.evbub_evA <> b^.evbub_evA)
  --           (a^.evbub_evB <> b^.evbub_evB)

defaultEventBubble :: (Reflex t) => EventBubble t
defaultEventBubble = EventBubble never never

main :: IO ()
main = mainWidget (appWidget defaultConfig)


appModel :: MonadWidget t m => Event t (EventBubble t) -> AppConfig -> m (Model t)
appModel bubble conf = do
  -- extract the right event using coincidence:
  let evA = coincidence (_evbub_evA <$> bubble)
  a <- foldDyn (+) (0 :: Int) (1 <$ evA)
  let evB = coincidence (_evbub_evB <$> bubble)
  b <- foldDyn (+) (0 :: Int) (10 <$ evB)
  return $ Model conf a b

-- | Should we name it AppController?
appWidget :: MonadWidget t m => AppConfig -> m ()
appWidget conf = do
  rec
    model <- appModel eventBubble conf
    (_, eventBubble) <- runEventWriterT $ flip runReaderT model $ do
      appView
  pure ()

appView :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
appView = do
  buttonA
  buttonB
  simultaneous
  parallel
  showClicks

buttonA :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
buttonA = el "div" $ do
  ev <- button "A"
  -- push Event t (EventBubble ev never) to the event writer.
  tellEvent $ fmap (const $ defaultEventBubble & evbub_evA .~ ev) ev

buttonB :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
buttonB = el "div" $ do
  ev <- button "B"
  tellEvent $ fmap (const $ defaultEventBubble & evbub_evB .~ ev) ev
  
simultaneous :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
simultaneous = el "div" $ do
  ev <- button "both"
  tellEvent $ fmap (const $ defaultEventBubble
                     & evbub_evA .~ ev
                     & evbub_evB .~ ev) ev

-- | This is really simualtaneous and demonstrates to events occuring at the same time.
parallel :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
parallel = el "div" $ do
  ev <- button "A||B"
  tellEvent $ fmap (const $ defaultEventBubble & evbub_evA .~ ev) ev  
  tellEvent $ fmap (const $ defaultEventBubble & evbub_evB .~ ev) ev

showClicks :: (MonadReader (Model t) m, EventWriter t (EventBubble t) m, MonadWidget t m) => m ()
showClicks = el "div" $ do
  text "A: "
  a <- asks _model_a
  dynText $ fmap (pack . show) a
  el "br" blank
  text "B: "
  b <- asks _model_b
  dynText $ fmap (pack . show) b