FRP Widgets

Widgets.hs

------------------------------------------------------------------------------
-- | Our version of reflex-dom's checkbox.
htmlCheckbox
    :: MonadWidget t m
    => WidgetConfig t Bool
    -> m (HtmlWidget t Bool)
htmlCheckbox cfg = do
    cb <- checkbox (_widgetConfig_initialValue cfg) $ def
      & setValue .~ _widgetConfig_setValue cfg
      & attributes .~ _widgetConfig_attributes cfg
    return $ HtmlWidget
      (_checkbox_value cb)
      (_checkbox_change cb)
      never never never
      (constDyn False)


------------------------------------------------------------------------------
-- | More convenient version that doesn't return the HTMLInputElement.
htmlTextInput
    :: MonadWidget t m
    => String
    -> WidgetConfig t String
    -> m (HtmlWidget t String)
htmlTextInput inputType cfg = do
    (_,w) <- htmlTextInput' inputType cfg
    return w


------------------------------------------------------------------------------
-- | Our version of reflex-dom's textInput.
htmlTextInput'
    :: MonadWidget t m
    => String
    -> WidgetConfig t String
    -> m (HTMLInputElement, HtmlWidget t String)
htmlTextInput' inputType cfg = do
    ti <- textInput $ def
      & setValue .~ _widgetConfig_setValue cfg
      & attributes .~ _widgetConfig_attributes cfg
      & textInputConfig_initialValue .~ _widgetConfig_initialValue cfg
      & textInputConfig_inputType .~ inputType
    let w = HtmlWidget
          (_textInput_value ti)
          (_textInput_input ti)
          (_textInput_keypress ti)
          (_textInput_keydown ti)
          (_textInput_keyup ti)
          (_textInput_hasFocus ti)
    return (_textInput_element ti, w)


------------------------------------------------------------------------------
-- | NOTE: You should not use this function with string types because the Show
-- instance will quote strings which is probably not what you want.
readableWidget
    :: (MonadWidget t m, Show a, Readable a)
    => WidgetConfig t (Maybe a)
    -> m (HtmlWidget t (Maybe a))
readableWidget cfg = do
    let setVal = maybe "" show <$> _widgetConfig_setValue cfg
    w <- htmlTextInput "text" $ WidgetConfig setVal
      (maybe "" show (_widgetConfig_initialValue cfg))
      (_widgetConfig_attributes cfg)
    let parse = fromText . toS
    mapWidget parse w

doubleWidget :: (MonadWidget t m) => TWidget t m (Maybe Double)
doubleWidget = readableWidget


intWidget :: (MonadWidget t m) => TWidget t m (Maybe Integer)
intWidget = readableWidget


------------------------------------------------------------------------------
-- | Returns an event that fires when the widget loses focus or enter is
-- pressed.
blurOrEnter
    :: Reflex t
    => HtmlWidget t a
    -> Event t a
blurOrEnter w = tagDyn (_hwidget_value w) fireEvent
  where
    fireEvent = leftmost [ () <$ (ffilter (==13) $ _hwidget_keypress w)
                         , () <$ (ffilter not $ updated $ _hwidget_hasFocus w)
                         ]


------------------------------------------------------------------------------
-- | Like readableWidget but only generates change events on blur or when
-- enter is pressed.
inputOnEnter
    :: MonadWidget t m
    => (WidgetConfig t a -> m (HtmlWidget t a))
    -> WidgetConfig t a
    -> m (Dynamic t a)
inputOnEnter wFunc cfg = do
    w <- wFunc cfg
    holdDyn (_widgetConfig_initialValue cfg) $ blurOrEnter w

WidgetTypes.hs

data WidgetConfig t a
    = WidgetConfig { _widgetConfig_setValue :: Event t a
                   , _widgetConfig_initialValue :: a
                   , _widgetConfig_attributes :: Dynamic t (Map String String)
                   }

makeLenses ''WidgetConfig

instance (Reflex t, Default a) => Default (WidgetConfig t a) where
  def = WidgetConfig { _widgetConfig_setValue = never
                     , _widgetConfig_initialValue = def
                     , _widgetConfig_attributes = constDyn mempty
                     }

instance HasAttributes (WidgetConfig t a) where
  type Attrs (WidgetConfig t a) = Dynamic t (Map String String)
  attributes = widgetConfig_attributes

instance HasSetValue (WidgetConfig t a) where
  type SetValue (WidgetConfig t a) = Event t a
  setValue = widgetConfig_setValue


extractEvent
    :: MonadWidget t m
    => (a -> Event t b)
    -> Dynamic t a
    -> m (Event t b)
extractEvent f = liftM (switch . current) . mapDyn f

extractDyn
    :: MonadWidget t m
    => (a -> Dynamic t b)
    -> Dynamic t a
    -> m (Dynamic t b)
extractDyn f = liftM joinDyn . mapDyn f

data HtmlWidget t a = HtmlWidget
    { _hwidget_value    :: Dynamic t a
    , _hwidget_change   :: Event t a
      -- ^ Event that fires when the widget changes internally (not via a
      -- setValue event).
    , _hwidget_keypress :: Event t Int
    , _hwidget_keydown  :: Event t Int
    , _hwidget_keyup    :: Event t Int
    , _hwidget_hasFocus :: Dynamic t Bool
    }

makeLenses ''HtmlWidget

constWidget :: Reflex t => a -> HtmlWidget t a
constWidget a = HtmlWidget (constDyn a) never never never never (constDyn False)

mapWidget
    :: MonadWidget t m
    => (a -> b)
    -> HtmlWidget t a
    -> m (HtmlWidget t b)
mapWidget f w = do
    newVal <- mapDyn f $ value w
    return $ HtmlWidget
      newVal
      (f <$> _hwidget_change w)
      (_hwidget_keypress w)
      (_hwidget_keydown w)
      (_hwidget_keyup w)
      (_hwidget_hasFocus w)

combineWidgets
    :: MonadWidget t m
    => (a -> b -> c)
    -> HtmlWidget t a
    -> HtmlWidget t b
    -> m (HtmlWidget t c)
combineWidgets f a b = do
    newVal <- combineDyn f (value a) (value b)
    let newChange = tag (current newVal) $ leftmost
          [() <$ _hwidget_change a, () <$ _hwidget_change b]
    newFocus <- combineDyn (||) (_hwidget_hasFocus a) (_hwidget_hasFocus b)
    return $ HtmlWidget
      newVal newChange
      (leftmost [_hwidget_keypress a, _hwidget_keypress b])
      (leftmost [_hwidget_keydown a, _hwidget_keydown b])
      (leftmost [_hwidget_keyup a, _hwidget_keyup b])
      newFocus


wconcat
    :: (MonadWidget t m, Foldable f, Monoid a)
    => f (HtmlWidget t a) -> m (HtmlWidget t a)
wconcat = foldM (combineWidgets (<>)) (constWidget mempty)

extractWidget
    :: MonadWidget t m
    => Dynamic t (HtmlWidget t a)
    -> m (HtmlWidget t a)
extractWidget dynWidget = do
    v <- extractDyn value dynWidget
    c <- extractEvent _hwidget_change dynWidget
    kp <- extractEvent _hwidget_keypress dynWidget
    kd <- extractEvent _hwidget_keydown dynWidget
    ku <- extractEvent _hwidget_keyup dynWidget
    hf <- extractDyn _hwidget_hasFocus dynWidget
    return $ HtmlWidget v c kp kd ku hf

instance HasValue (HtmlWidget t a) where
  type Value (HtmlWidget t a) = Dynamic t a
  value = _hwidget_value