Skip to content

Instantly share code, notes, and snippets.

@daig daig/App.hs

Last active Jun 27, 2017
What would you like to do?
Elm/Flux style Component Architecture for Reflex-Dom
{-# 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
{-# 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
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.