Elm/Flux style Component Architecture for Reflex-Dom

App.hs

{-# LANGUAGE OverloadedStrings #-}
module App where
import Component
import Notes
import Reflex.Dom
import Data.Semigroup ((<>))

app :: MonadWidget t m => m ()
app = do
  add <- (BlankNote <$) <$> button "New Note"
  rec remove <- render =<<
    initializeComponent memepty (WriteNote `map` ["Bend", "Cheese it"]) (add <> remove)
    -- Notice we combine both the add messages coming from above, and the remove messages propagating from below
  blank

Component.hs

{-# LANGUAGE TypeFamilies #-}
module Component where
import Control.Monad.Trans (liftIO,MonadIO)
import Data.Monoid (Endo(..))

class Component x where
  data Input x :: * -- Associated input message data
  data Output t x :: * -- Associated output message type
  -- Render a dynamic of the internal state as a component emitting Output messages --
  render :: MonadWidget t m => Dynamic t x -> m (Output t x)
  -- Evaluate an input message as a (possible effectful) action on the internal state --
  evalInput :: MonadIO m => Input x -> m (x -> x)
  
-- Convert an event of input messages into an event of state actions --
evalEvent :: (Component x, MonadWidget t m) => Event t (Input x) -> m (Event t (x -> x))
evalEvent = performEvent . fmap evalInput

-- Create an action to initialize the state, using a pure base state and list of initial setup messages --
initialize :: Component x => x -> [Input x] -> IO x
initialize empty messages = (`appEndo` empty) <$> foldMap (fmap Endo . evalInput) messages

-- create a component from an initial state and an input message source
-- the resulting Dynamic exposes the internal state --
component :: (Component x, MonadWidget t m) => m x -> Event t (Input x) -> m (Dynamic t x)
component initial input = do
  state0 <- liftIO initial
  foldDyn ($) state0 =<< evalEvent input

-- create a component from a pure initial input and message list --
initializeComponent :: (Component x, MonadWidget t m) => x -> [Input x] -> Event t (Input x) -> m (Dynamic t x)
initializeComponent empty initialMessages input = component (liftIO $ initialize empty initialMessages) input

Notes.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE FlexibleInstances #-}
module Notes where
import Component
import Reflex.Dom
import Data.Unique
import Data.Text (Text)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.String (IsString)

data Note = Note {completed :: Bool, task :: Text}
instance IsString Note where fromString s = Note {task = fromString s, completed = False}

instance Component Note where
  data Input Note = Complete
  type Output t Note = Event t (Input Note )
  render n = el "div" $ do
    el "span" $ dynText $ (\(Note completed task) -> if completed then "X" else task) <$> n
    (Complete <$) <$> button "Complete Me"
  evalInput Complete = return $ \x -> x {completed = True}
  
type Id = Unique
type Notes = Map Id Note

instance Component Notes where
  data Input Notes = NewNote (Maybe Text) | RemoveNote Id
  type Output t Notes = Event t (Input Notes)
  
  render ns = do
    fmap mergeDynMapEvents $
      el "ul" $ listWIthKey ns
        (\i note -> el "li" $ do
          rec complete <- render =<< component (sampleDyn note) complete
          delay 1 $ RemoveNote i <$ complete)
          -- NOTE: We mark the note complete and then delete it after 1 second.
          -- This contrived example shows that actions happen in the inner component
          -- independently of the outer component, providing encapsulation
          
  evalInput = \case
    NewNote task -> liftIO $ ffor newUnique (`Map.insert` maybe "New Note" (Note False) task)
    RemoveNote i -> return $ Map.delete i
    
-- Helpers --
instance Semigroup (Input Notes) where a <> _ = a  -- we drop colliding notes for simplicity

-- Flatten a dynamic container of mergeable events into a single event stream
mergeDynFoldableEvents :: (Reflex t, Semigroup a, Foldable f) => Dynamic t (f (Event t a)) -> Event t a
mergeDynFoldableEvents = switchPromptlyDyn . fmap fold

-- Sample the current value of a dynamic --
sampleDyn :: (Reflex t, MonadSample t m) => Dynamic t m -> m x
sampleDyn = sample . current
-- Convenience patterns to avoid extra Nothing and Just arguments --
pattern BlankNote = NewNote Nothing
pattern WriteNote t = NewNote (Just t)