Skip to content

Instantly share code, notes, and snippets.

@mightybyte

mightybyte/WidgetTypes.hs

Last active May 30, 2017 22:09
Show Gist options
  • Save mightybyte/8e3ef7dde443cdc0a599 to your computer and use it in GitHub Desktop.
Save mightybyte/8e3ef7dde443cdc0a599 to your computer and use it in GitHub Desktop.
Download ZIP
FRP Widgets
Raw
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
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment