monoidalWidget.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
import Control.Monad (ap)
import Control.Monad.Trans (lift)
import Data.Semigroup (First (..))
import Data.Text (Text)
import qualified Data.Text as T
import Reflex.Dom

newtype MonoidalWidget t m e = MonoidalWidget { unMonoidalWidget :: EventWriterT t (First e) m () }

runMonoidalWidget :: (Reflex t, Monad m) => MonoidalWidget t m e -> m (Event t e)
runMonoidalWidget (MonoidalWidget w) = fmap getFirst . snd <$> runEventWriterT w

instance Monad m => Monoid (MonoidalWidget t m e) where
  mempty = MonoidalWidget $ return ()
  mappend (MonoidalWidget a) (MonoidalWidget b) = MonoidalWidget $ a >> b

div_ :: MonadWidget t m => [MonoidalWidget t m e] -> MonoidalWidget t m e
div_ w = MonoidalWidget $ el "div" $ unMonoidalWidget $ mconcat w

text_ :: MonadWidget t m => Text -> MonoidalWidget t m e
text_ t = MonoidalWidget $ text t

hello :: MonadWidget t m => MonoidalWidget t m e
hello = div_
  [ text_ "Hello, "
  , text_ "world!"
  ]

instance (Reflex t, Monad m) => Functor (MonoidalWidget t m) where
  -- | Map over the output events that the widget produces
  fmap f w = MonoidalWidget $ do
    -- Run the widget
    outputEvent <- lift $ runMonoidalWidget w

    -- Transform its output and emit it
    tellEvent $ First . f <$> outputEvent

instance MonadWidget t m => Applicative (MonoidalWidget t m) where
  -- | Produce an output event (once) after the widget is built
  pure a = MonoidalWidget $ do
    -- Get an event that will fire after the widget is finished building
    postBuild <- getPostBuild
    -- Give that event the requested value, then emit it
    tellEvent $ First a <$ postBuild
  (<*>) = ap

instance MonadWidget t m => Monad (MonoidalWidget t m) where
  -- For performance in a real implementation, we would want to use a single
  -- 'widgetHold' at the top level rather than one in each bind; this ends up
  -- being a bit uglier, but not too bad.  Something like that is here:
  -- https://github.com/reflex-frp/reflex-platform/blob/1c19f94435a15779edca641c532255174de90f00/workflow.hs#L18
  -- | Run one widget, then another based on the output of the first
  x >>= f = MonoidalWidget $ do
    rec xEvent <- widgetHold (lift $ runMonoidalWidget x) $ ffor (switch (current xEvent)) $ \xResult -> do
          unMonoidalWidget $ f xResult
          return never
    return ()

button_ :: MonadWidget t m => Text -> MonoidalWidget t m ()
button_ t = MonoidalWidget $ do
  clicked <- button t
  tellEvent $ First () <$ clicked

main :: IO ()
main = mainWidget $ do
  _ <- runMonoidalWidget $ div_
    [ text_ "Hi!"
    , do buttonClicked <- div_
           [ 1 <$ button_ "1"
           , 2 <$ button_ "2"
           ]
         text_ $ T.pack $ show buttonClicked
    ]
  return ()