module Reflex.Dom.Contrib.Widgets.Common where
import Control.Lens
import Control.Monad
import Data.Default
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Readable
import Data.String.Conv
import Data.Time
import GHCJS.DOM.HTMLInputElement hiding (setValue)
import Reflex
import Reflex.Dom
import Safe
import Reflex.Contrib.Utils
class HasChange a where
type Change a :: *
change :: a -> Change a
data WidgetConfig t a
= WidgetConfig { _widgetConfig_setValue :: Event t a
, _widgetConfig_initialValue :: a
, _widgetConfig_attributes :: Dynamic t (Map String String)
}
instance Reflex t => Functor (WidgetConfig t) where
fmap f (WidgetConfig sv iv a) = WidgetConfig (f <$> sv) (f iv) a
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
class IsWidget w where
constWidget :: Reflex t => a -> w t a
mapWidget :: MonadWidget t m => (a -> b) -> w t a -> m (w t b)
combineWidgets :: MonadWidget t m => (a -> b -> c) -> w t a -> w t b -> m (w t c)
wconcat :: (MonadWidget t m, Foldable f, Monoid a) => f (w t a) -> m (w t a)
wconcat = foldM (combineWidgets (<>)) (constWidget mempty)
extractWidget :: MonadWidget t m => Dynamic t (w t a) -> m (w t a)
data Widget0 t a = Widget0
{ _widget0_value :: Dynamic t a
, _widget0_change :: Event t a
}
makeLenses ''Widget0
instance HasValue (Widget0 t a) where
type Value (Widget0 t a) = Dynamic t a
value = _widget0_value
instance HasChange (Widget0 t a) where
type Change (Widget0 t a) = Event t a
change = _widget0_change
instance IsWidget Widget0 where
constWidget a = Widget0 (constDyn a) never
mapWidget f w = do
b <- mapDyn f $ value w
return $ Widget0 b (f <$> _widget0_change w)
combineWidgets f a b = do
c <- combineDyn f (value a) (value b)
let cChange = tagDyn c $ leftmost
[() <$ _widget0_change a, () <$ _widget0_change b]
return $ Widget0 c cChange
extractWidget dw = do
v <- extractDyn value dw
c <- extractEvent _widget0_change dw
return $ Widget0 v c
data HtmlWidget t a = HtmlWidget
{ _hwidget_value :: Dynamic t a
, _hwidget_change :: Event t a
, _hwidget_keypress :: Event t Int
, _hwidget_keydown :: Event t Int
, _hwidget_keyup :: Event t Int
, _hwidget_hasFocus :: Dynamic t Bool
}
makeLenses ''HtmlWidget
instance HasValue (HtmlWidget t a) where
type Value (HtmlWidget t a) = Dynamic t a
value = _hwidget_value
instance HasChange (HtmlWidget t a) where
type Change (HtmlWidget t a) = Event t a
change = _hwidget_change
htmlTo0 :: HtmlWidget t a -> Widget0 t a
htmlTo0 w = Widget0 (_hwidget_value w) (_hwidget_change w)
type GWidget t m a = WidgetConfig t a -> m (HtmlWidget t a)
instance IsWidget HtmlWidget where
constWidget a = HtmlWidget (constDyn a) never never never never (constDyn False)
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 f a b = do
newVal <- combineDyn f (value a) (value b)
let newChange = tagDyn 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
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
dateTimeWidget
:: (MonadWidget t m)
=> GWidget t m (Maybe UTCTime)
dateTimeWidget cfg = do
let wValue = _widgetConfig_setValue cfg
setDate = maybe "" (formatTime defaultTimeLocale dfmt)
setTime = maybe "" (formatTime defaultTimeLocale tfmt)
el "div" $ do
di <- htmlTextInput "date" $ def
& setValue .~ (setDate <$> wValue)
& attributes .~ _widgetConfig_attributes cfg
& widgetConfig_initialValue .~ setDate
(_widgetConfig_initialValue cfg)
ti <- htmlTextInput "time" $ def
& setValue .~ (setTime <$> wValue)
& attributes .~ _widgetConfig_attributes cfg
& widgetConfig_initialValue .~ setTime
(_widgetConfig_initialValue cfg)
combineWidgets (\d t -> parseTimeM True defaultTimeLocale "%F %X" $
toS $ d ++ " " ++ t ++ ":00")
di ti
where
dfmt = "%F"
tfmt = "%X"
dateWidget
:: (MonadWidget t m)
=> GWidget t m (Maybe Day)
dateWidget cfg = do
let setVal = showD <$> _widgetConfig_setValue cfg
di <- htmlTextInput "date" $ def
& setValue .~ setVal
& attributes .~ _widgetConfig_attributes cfg
& widgetConfig_initialValue .~ showD
(_widgetConfig_initialValue cfg)
mapWidget (parseTimeM True defaultTimeLocale fmt) di
where
fmt = "%F"
showD = maybe "" (formatTime defaultTimeLocale fmt)
htmlCheckbox
:: MonadWidget t m
=> GWidget t m 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)
htmlTextInput
:: MonadWidget t m
=> String
-> GWidget t m String
htmlTextInput inputType cfg = do
(_,w) <- htmlTextInput' inputType cfg
return w
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)
readableWidget
:: (MonadWidget t m, Show a, Readable a)
=> GWidget t m (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) => GWidget t m (Maybe Double)
doubleWidget = readableWidget
integerWidget :: (MonadWidget t m) => GWidget t m (Maybe Integer)
integerWidget = readableWidget
intWidget :: (MonadWidget t m) => GWidget t m (Maybe Int)
intWidget = readableWidget
htmlDropdown
:: (MonadWidget t m, Eq b)
=> Dynamic t [a]
-> (a -> String)
-> (a -> b)
-> WidgetConfig t b
-> m (Widget0 t b)
htmlDropdown items f payload cfg = do
pairs <- mapDyn (zip [(0::Int)..]) items
m <- mapDyn M.fromList pairs
dynItems <- mapDyn (M.map f) m
let findIt ps a = maybe 0 fst $ headMay (filter (\ (_,x) -> payload x == a) ps)
let setVal = attachDynWith findIt pairs $ _widgetConfig_setValue cfg
d <- dropdown 0 dynItems $
DropdownConfig setVal (_widgetConfig_attributes cfg)
val <- combineDyn (\k x -> payload $ fromJust $ M.lookup k x) (_dropdown_value d) m
return $ Widget0 val (tagDyn val $ _dropdown_change d)
htmlDropdownStatic
:: (MonadWidget t m, Eq b)
=> [a]
-> (a -> String)
-> (a -> b)
-> WidgetConfig t b
-> m (Widget0 t b)
htmlDropdownStatic items f payload cfg = do
let pairs = zip [(0::Int)..] items
m = M.fromList pairs
dynItems = M.map f m
let findIt a = maybe 0 fst $ headMay (filter (\ (_,x) -> payload x == a) pairs)
let setVal = findIt <$> _widgetConfig_setValue cfg
d <- dropdown (findIt $ _widgetConfig_initialValue cfg) (constDyn dynItems) $
DropdownConfig setVal (_widgetConfig_attributes cfg)
val <- mapDyn (\k -> payload $ fromJust $ M.lookup k m) (_dropdown_value d)
return $ Widget0 val (tagDyn val $ _dropdown_change d)
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)
]
blurOrEnterEvent :: Reflex t => HtmlWidget t a -> Event t ()
blurOrEnterEvent w = leftmost
[ () <$ (ffilter (==13) $ _hwidget_keypress w)
, () <$ (ffilter not $ updated $ _hwidget_hasFocus w)
]
enforcingWidget
:: MonadWidget t m
=> (HtmlWidget t (Maybe a) -> Event t ())
-> GWidget t m (Maybe a)
-> GWidget t m a
enforcingWidget restrictEvent wFunc cfg = do
rec
let iv = Just $ _widgetConfig_initialValue cfg
newSetValue = leftmost [ Just <$> _widgetConfig_setValue cfg
, Just <$> resetEvent
]
w <- wFunc $ WidgetConfig newSetValue iv
(_widgetConfig_attributes cfg)
let eMay = tag (current $ value w) $ restrictEvent w
e = fmapMaybe id eMay
v <- holdDyn (_widgetConfig_initialValue cfg) e
let resetEvent = tag (current v) $ ffilter isNothing eMay
return $ HtmlWidget { _hwidget_value = v
, _hwidget_change = e
, _hwidget_keypress = _hwidget_keypress w
, _hwidget_keydown = _hwidget_keydown w
, _hwidget_keyup = _hwidget_keyup w
, _hwidget_hasFocus = _hwidget_hasFocus w
}
restrictWidget
:: MonadWidget t m
=> (HtmlWidget t a -> Event t a)
-> GWidget t m a
-> GWidget t m a
restrictWidget restrictFunc wFunc cfg = do
w <- wFunc cfg
let e = restrictFunc w
v <- holdDyn (_widgetConfig_initialValue cfg) e
return $ w { _hwidget_value = v
, _hwidget_change = e
}
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
listDropdown :: (MonadWidget t m)
=> Dynamic t [a]
-> (a -> String)
-> Dynamic t (Map String String)
-> String
-> m (Dynamic t (Maybe a))
listDropdown xs f attrs defS = do
m <- mapDyn (M.fromList . zip [(1::Int)..]) xs
opts <- mapDyn ((M.insert 0 defS) . M.map f) m
sel <- liftM _dropdown_value $ dropdown 0 opts $ def & attributes .~ attrs
combineDyn M.lookup sel m