packages feed

reflex-dom-contrib 0.1 → 0.2

raw patch · 10 files changed

+539/−151 lines, 10 filesdep +safedep ~reflexdep ~reflex-dom

Dependencies added: safe

Dependency ranges changed: reflex, reflex-dom

Files

reflex-dom-contrib.cabal view
@@ -1,5 +1,5 @@ name:                reflex-dom-contrib-version:             0.1+version:             0.2 synopsis:            A playground for experimenting with infrastructure and common code for reflex applications description:         This library is intended to be a public playground for                      developing infrastructure, higher level APIs, and widget@@ -38,6 +38,7 @@     Reflex.Dom.Contrib.Widgets.CheckboxList     Reflex.Dom.Contrib.Widgets.Common     Reflex.Dom.Contrib.Widgets.DynTabs+    Reflex.Dom.Contrib.Widgets.EditInPlace    build-depends:     aeson        >= 0.8  && < 0.10,@@ -46,18 +47,21 @@     bytestring   >= 0.10 && < 0.11,     containers   >= 0.5  && < 0.6,     data-default >= 0.5  && < 0.6,-    ghcjs-base   >= 0.1  && < 0.2,     ghcjs-dom    >= 0.1  && < 0.2,     http-types   >= 0.8  && < 0.9,     lens         >= 4.9  && < 4.13,     mtl          >= 2.0  && < 2.3,     readable     >= 0.3  && < 0.4,-    reflex       >= 0.2  && < 0.3,-    reflex-dom   >= 0.1  && < 0.2,+    reflex       >= 0.2  && < 0.4,+    reflex-dom   >= 0.1  && < 0.3,+    safe         >= 0.3  && < 0.4,     string-conv  >= 0.1  && < 0.2,     text         >= 1.2  && < 1.3,     time         >= 1.5  && < 1.6 +  if impl(ghcjs)+    build-depends:+      ghcjs-base   >= 0.1  && < 0.2    default-language:    Haskell2010
src/Reflex/Contrib/Utils.hs view
@@ -66,3 +66,30 @@     -> m (Dynamic t b) extractDyn f = liftM joinDyn . mapDyn f ++------------------------------------------------------------------------------+-- | This function has the slight flaw that if (f initValue) == False, it will+-- still get through.+filterDyn+    :: (MonadHold t m, Reflex t, Functor m)+    => (a -> Bool)+    -> Dynamic t a+    -> m (Dynamic t a)+filterDyn f d = fmap joinDyn $ holdDyn d $ fmap constDyn $+    ffilter f (updated d)+++------------------------------------------------------------------------------+-- | Similar to filterDyn, but here the initial value problem is visible+-- because of the Maybe.+fmapMaybeDyn+    :: (MonadHold t m, Reflex t, Functor m)+    => (a -> Maybe b)+    -> Dynamic t a+    -> m (Dynamic t (Maybe b))+fmapMaybeDyn f d = do+    d' <- mapDyn f d+    fmap joinDyn $ holdDyn d' $ fmap (constDyn . Just) $+      fmapMaybe f (updated d)++
src/Reflex/Dom/Contrib/KeyEvent.hs view
@@ -21,32 +21,14 @@ import           Data.Char import           GHCJS.DOM.EventM (event) import           GHCJS.DOM.Types hiding (Event)+#ifdef ghcjs_HOST_OS import           GHCJS.Types+#endif import           Reflex.Dom ------------------------------------------------------------------------------   -------------------------------------------------------------------------------#ifdef ghcjs_HOST_OS--foreign import javascript unsafe "$1.ctrlKey"-  js_uiEventGetCtrlKey :: JSRef UIEvent -> IO Bool--foreign import javascript unsafe "$1.shiftKey"-  js_uiEventGetShiftKey :: JSRef UIEvent -> IO Bool--#else--js_uiEventGetCtrlKey :: JSRef UIEvent -> IO Bool-js_uiEventGetCtrlKey = error "js_uiEventGetCtrlKey only works in GHCJS."--js_uiEventGetShiftKey :: JSRef UIEvent -> IO Bool-js_uiEventGetShiftKey = error "js_uiEventGetShiftKey only works in GHCJS."--#endif--------------------------------------------------------------------------------- -- | Data structure with the details of key events. data KeyEvent = KeyEvent    { keKeyCode :: Int@@ -79,6 +61,7 @@  ------------------------------------------------------------------------------ getKeyEvent :: ReaderT (t, UIEvent) IO KeyEvent+#ifdef ghcjs_HOST_OS getKeyEvent = do   e <- event   code <- Reflex.Dom.getKeyEvent@@ -86,4 +69,12 @@                     <*> js_uiEventGetCtrlKey (unUIEvent e)                     <*> js_uiEventGetShiftKey (unUIEvent e) +foreign import javascript unsafe "$1['ctrlKey']"+  js_uiEventGetCtrlKey :: JSRef UIEvent -> IO Bool++foreign import javascript unsafe "$1['shiftKey']"+  js_uiEventGetShiftKey :: JSRef UIEvent -> IO Bool+#else+getKeyEvent = error "getKeyEvent: can only be used with GHCJS"+#endif
src/Reflex/Dom/Contrib/Pagination.hs view
@@ -110,7 +110,7 @@ -- Some convenient type aliases type PaginationCache k v = Map k [CacheVal v] type PaginationInput k = (k, PaginationQuery)-type PaginationOutput k v = (k, CacheVal v)+type PaginationOutput k v = (k, Maybe (CacheVal v))   ------------------------------------------------------------------------------@@ -151,14 +151,14 @@   -> Event t (Map String ByteString, PaginationInput k)   -- ^ Param map and pagination structure.  k is any additional information   -- that you need to disambiguate multiple PaginationQuery entries.-  -> m (Event t (PaginationResults a))+  -> m (Event t (Maybe (PaginationResults a))) paginatedQuery pqp matchSearchString url input = do     rec pcache <- foldDyn ($) mempty (addToCache pqp <$> r)         let eme = attachWith (cachedQuery matchSearchString url)                              (current pcache) input         de <- widgetHold (return never) eme         let r = switchPromptlyDyn $ de-    return $ _pvValue . snd <$> r+    return $ fmap _pvValue . snd <$> r   ------------------------------------------------------------------------------@@ -169,8 +169,8 @@     -> PaginationCache k (PaginationResults v)     -> PaginationCache k (PaginationResults v) addToCache PQParams{..} (k, v) m =-    if _pvShouldStore v-      then M.insertWith (++) k [v] m2+    if fmap _pvShouldStore v == Just True+      then M.insertWith (++) k [fromJust v] m2       else m   where     m2 = if M.size m > pqpMaxCacheSize then prune pqpPruneAmount m else m@@ -209,7 +209,7 @@     pb <- getPostBuild     let getData = do           res <- getAndDecode (mkFullPath input <$ pb)-          return $ (\v -> (k, CacheVal pq True $ fromMaybe err v)) <$> res+          return $ (\v -> (k, CacheVal pq True <$> v)) <$> res     case M.lookup k cache of       Nothing -> getData       Just pvs ->@@ -219,9 +219,8 @@               let pv2 = pv & (pvValue . prResults) %~                              filter (matchSearchString $ _pqSearchString pq)                            & pvShouldStore .~ False-              return $ (k,pv2) <$ pb+              return $ (k,Just pv2) <$ pb   where-    err = error "Error decoding pagination results"     mkFullPath p = url <> "?" <> queryString p     queryString (ps, (_,pq)) = formEncode $       M.insert "pagination" (encode pq) ps
src/Reflex/Dom/Contrib/Utils.hs view
@@ -9,9 +9,13 @@ -}  module Reflex.Dom.Contrib.Utils-  ( confirmEvent+  ( alertEvent+  , js_alert+  , confirmEvent+  , js_confirm   , getWindowLocationPath   , windowHistoryPushState+  , setWindowLoc   , widgetHoldHelper   , putDebugLn   , putDebugLnE@@ -21,71 +25,92 @@ import           Control.Monad import           Control.Monad.Reader import           GHCJS.DOM.Types hiding (Event)+#ifdef ghcjs_HOST_OS import           GHCJS.Foreign import           GHCJS.Marshal import           GHCJS.Types+#endif import           Reflex import           Reflex.Dom ------------------------------------------------------------------------------   ------------------------------------------------------------------------------+-- | Convenient function that pops up a javascript alert dialog box when an+-- event fires with a message to display.+alertEvent :: MonadWidget t m => (a -> String) -> Event t a -> m () #ifdef ghcjs_HOST_OS--foreign import javascript unsafe-  "confirm($1)"-  js_confirm :: JSString -> IO Bool--foreign import javascript unsafe-  "$1.location.pathname"-  js_windowLocationPath :: JSRef DOMWindow ->  IO JSString+alertEvent str e = performEvent_ (alert <$> e)+  where+    alert a = liftIO $ js_alert $ toJSString $ str a  foreign import javascript unsafe-  "window.history.pushState({},\"\",$1)"-  js_windowHistoryPushState :: JSString -> IO ()-+  "alert($1)"+  js_alert :: JSString -> IO () #else--js_confirm :: JSString -> IO Bool-js_confirm = error "js_confirm only works in GHCJS."--js_windowLocationPath :: JSRef DOMWindow -> IO JSString-js_windowLocationPath _ =-    error "Window location can only be retrieved in GHCJS."--js_windowHistoryPushState :: JSString -> IO ()-js_windowHistoryPushState =-    error "Window pushState can only be changed in GHCJS."-+alertEvent = error "alertEvent: can only be used with GHCJS"+js_alert = error "js_alert: can only be used with GHCJS" #endif - ------------------------------------------------------------------------------ -- | Convenient function that pops up a javascript confirmation dialog box -- when an event fires with a message to display. confirmEvent :: MonadWidget t m => (a -> String) -> Event t a -> m (Event t a)+#ifdef ghcjs_HOST_OS confirmEvent str e = liftM (fmapMaybe id) $ performEvent (confirm <$> e)   where     confirm a = do         ok <- liftIO $ js_confirm $ toJSString $ str a         return $ if ok then Just a else Nothing +foreign import javascript unsafe+  "confirm($1)"+  js_confirm :: JSString -> IO Bool+#else+confirmEvent = error "confirmEvent: can only be used with GHCJS"+js_confirm = error "js_confirm: can only be used with GHCJS"+#endif  ------------------------------------------------------------------------------ -- | Gets the current path of the DOM Window (i.e., the contents of the -- address bar after the host, beginning with a "/"). -- https://developer.mozilla.org/en-US/docs/Web/API/Location getWindowLocationPath :: DOMWindow -> IO String+#ifdef ghcjs_HOST_OS getWindowLocationPath w = do     jw <- toJSRef w     liftM fromJSString $ js_windowLocationPath jw +foreign import javascript unsafe+  "$1['location']['pathname']"+  js_windowLocationPath :: JSRef DOMWindow ->  IO JSString+#else+getWindowLocationPath = error "getWindowLocationPath: can only be used with GHCJS"+#endif  ------------------------------------------------------------------------------ -- | Pushes a new URL to the window history. windowHistoryPushState :: String -> IO ()+#ifdef ghcjs_HOST_OS windowHistoryPushState = js_windowHistoryPushState . toJSString +foreign import javascript unsafe+  "window['history']['pushState']({},\"\",$1)"+  js_windowHistoryPushState :: JSString -> IO ()+#else+windowHistoryPushState = error "windowHistoryPushState: can only be used with GHCJS"+#endif++setWindowLoc :: String -> IO ()+#ifdef ghcjs_HOST_OS+setWindowLoc = js_setWindowLoc . toJSString++foreign import javascript unsafe+  "window.location = window['location']['origin'] + $1;"+  js_setWindowLoc :: JSString -> IO ()+#else+setWindowLoc = error "setWindowLoc: can only be used with GHCJS"+#endif  ------------------------------------------------------------------------------ -- | A common form for widgetHold calls that mirrors the pattern seen in hold
src/Reflex/Dom/Contrib/Widgets/BoundedList.hs view
@@ -31,6 +31,7 @@ import           Reflex.Dom ------------------------------------------------------------------------------ import           Reflex.Contrib.Interfaces+import           Reflex.Contrib.Utils ------------------------------------------------------------------------------  @@ -87,18 +88,18 @@ -- used items if that size is exceeded. boundedSelectList'     :: (MonadWidget t m, Show k, Ord k, Show v)-    => Event t (Map k v -> Map k v)-    -- ^ Event that updates individual item values-    -> Limit+    => Limit     -- ^ Maximum number of items to keep in the DOM at a time     -> Dynamic t k     -- ^ Currently selected item+    -> Event t (Map k v -> Map k v)+    -- ^ Event that updates individual item values     -> ReflexMap t k v     -- ^ Interface for updating the list     -> (k -> Dynamic t v -> Dynamic t Bool -> m a)     -- ^ Function to render a single item     -> m (Dynamic t (Map k a))-boundedSelectList' updateEvent itemLimit curSelected+boundedSelectList' itemLimit curSelected updateEvent                   ReflexMap{..} renderSingle = do     -- Map holding the full item list.     items <- foldDyn ($) rmInitialItems $ leftmost@@ -106,20 +107,22 @@       , rmDeleteFunc <$> rmDeleteItems       , updateEvent       ]-    +     counter <- count $ updated curSelected     curItem <- combineDyn findCurItem items curSelected-    let addCounter c (k,v) = (k, ((-c), v))+    let addCounter c (k,v) = (k, ((-c), (k, v)))         taggedInitial = M.fromList $ zipWith addCounter [1..] $                           M.toList rmInitialItems     let initMap = limitMap taggedInitial itemLimit     activeItems <- foldDyn ($) initMap $       boundedInsert itemLimit <$>-      attachDyn counter (fmapMaybe id $ updated curItem)+      attachDynWith (\c (k,v) -> (c, (k, (k,v))))+        counter (fmapMaybe id $ updated curItem)     selectViewListWithKey curSelected activeItems wrapSingle   where+    --wrapSingle :: k -> Dynamic t (BornAt, (k,v)) -> Dynamic t Bool -> m a     wrapSingle k v b = do-        v' <- mapDyn snd v+        v' <- mapDyn (snd . snd) =<< filterDyn (\x -> fst (snd x) == k) v         renderSingle k v' b  @@ -130,7 +133,7 @@ -- never deleted externally.  Instead of returning a Map of all the item -- results, this function only returns the result for the item that is -- currently selected.-boundedSelectList+boundedSelectList0     :: (MonadWidget t m, Show k, Ord k, Show v)     => Limit     -- ^ Maximum number of items to keep in the DOM at a time@@ -138,6 +141,7 @@     -- ^ Currently selected item.  New items are added to the list when the     -- currently selected item changes and the new item is not already in the     -- list.+    -> Event t (Map k v -> Map k v)     -> (a -> k)     -- ^ Gets the portion of a used as the key for the map of items     -> (a -> Maybe a)@@ -146,33 +150,70 @@     -> (Event t a -> m (Event t (k,v)))     -- ^ Gets a new key/value pair.  This function is run when curSelected     -- changes.-    -> b-    -- ^ Default value to return if nothing is in the list     -> (k -> Dynamic t v -> Dynamic t Bool -> m b)     -- ^ Function to render a single item-    -> m (Dynamic t b)-boundedSelectList itemLimit curSelected getKey shouldRunExpensive-                  expensiveGetNew defaultVal renderSingle = do+    -> m (Dynamic t (Map k b))+boundedSelectList0 itemLimit curSelected updateEvent getKey shouldRunExpensive+                   expensiveGetNew renderSingle = do     pb <- getPostBuild-    e0 <- expensiveGetNew $ tagDyn curSelected pb     rec-      let insertEvent = fmapMaybe id $-            attachDynWith isAlreadyPresent res (updated curSelected)+      let insertEvent = leftmost+            [ fmapMaybe id $+                attachDynWith isAlreadyPresent res (updated curSelected)+            , tagDyn curSelected pb+            ]       newVal <- expensiveGetNew insertEvent-      let rm = ReflexMap mempty ((:[]) <$> leftmost [newVal, e0]) never+      let rm = ReflexMap mempty ((:[]) <$> newVal) never       curK <- mapDyn getKey curSelected       res :: Dynamic t (Map k b) <--        boundedSelectList' never itemLimit curK rm renderSingle+        boundedSelectList' itemLimit curK updateEvent rm renderSingle+    return res+  where+    isAlreadyPresent fieldListMap cur =+        case M.lookup (getKey cur) fieldListMap of+          Nothing -> Just cur+          Just _ -> shouldRunExpensive cur+++------------------------------------------------------------------------------+-- | Implements a common use of boundedSelectList' where only the currently+-- selected item from a list is displayed.  In this case a Dynamic+-- representing the current selection is used to drive insertions and they are+-- never deleted externally.  Instead of returning a Map of all the item+-- results, this function only returns the result for the item that is+-- currently selected.+boundedSelectList+    :: (MonadWidget t m, Show k, Ord k, Show v)+    => Limit+    -- ^ Maximum number of items to keep in the DOM at a time+    -> Dynamic t a+    -- ^ Currently selected item.  New items are added to the list when the+    -- currently selected item changes and the new item is not already in the+    -- list.+    -> Event t (Map k v -> Map k v)+    -> (a -> k)+    -- ^ Gets the portion of a used as the key for the map of items+    -> (a -> Maybe a)+    -- ^ Decides whether to run expensiveGetNew in the case that the key is+    -- already in the cache.+    -> (Event t a -> m (Event t (k,v)))+    -- ^ Gets a new key/value pair.  This function is run when curSelected+    -- changes.+    -> b+    -- ^ Default value to return if nothing is in the list+    -> (k -> Dynamic t v -> Dynamic t Bool -> m b)+    -- ^ Function to render a single item+    -> m (Dynamic t b)+boundedSelectList itemLimit curSelected updateEvent getKey shouldRunExpensive+                  expensiveGetNew defaultVal renderSingle = do+    res <- boundedSelectList0 itemLimit curSelected updateEvent getKey+                              shouldRunExpensive expensiveGetNew renderSingle     combineDyn getCurrent curSelected res   where     getCurrent cur listMap =         case M.lookup (getKey cur) listMap of           Nothing -> defaultVal           Just v -> v-    isAlreadyPresent fieldListMap cur =-        case M.lookup (getKey cur) fieldListMap of-          Nothing -> Just cur-          Just _ -> shouldRunExpensive cur   ------------------------------------------------------------------------------
src/Reflex/Dom/Contrib/Widgets/CheckboxList.hs view
@@ -51,3 +51,45 @@           mapWidget (\b -> if b then [item] else []) cb       wconcat es ++------------------------------------------------------------------------------+-- | Takes a list of labels to make checkboxes for and returns the labels of+-- the boxes that are checked.+checkboxListView+    :: forall t m a b. (MonadWidget t m, Ord a, Show a)+    => (a -> String)+    -- ^ Function to show each item+    -> (String -> a -> Bool)+    -- ^ Function to filter each item+    -> (a -> Bool -> b)+    -> Event t Bool+    -- ^ Blanket event to apply to all list items.  Allows you to have "select+    -- all" and "select none" buttons.  Fire True to select all and False to+    -- select none.+    -> Dynamic t String+    -- ^ A search string for filtering the list of items.+    -> Set a+    -- ^ Set of items that should be initially checked+    -> [a]+    -- ^ List of items to show checkboxes for+    -> m (Event t b)+    -- ^ Events changing the selected set+checkboxListView showFunc filterFunc updateFunc blanketEvent searchString+                 onItems items = do+    el "ul" $ do+      es <- forM items $ \item -> do+        let shown = showFunc item+            mkAttrs search =+              if filterFunc search item+                then mempty+                else "style" =: "display:none"+        attrs <- liftM nubDyn $ mapDyn mkAttrs searchString+        elDynAttr "li" attrs $ el "label" $ do+          cb <- htmlCheckbox $ WidgetConfig+                  (leftmost [blanketEvent])+                  (S.member item onItems)+                  (constDyn mempty)+          text shown+          return $ updateFunc item <$> _hwidget_change cb+      return $ leftmost es+
src/Reflex/Dom/Contrib/Widgets/Common.hs view
@@ -24,12 +24,14 @@  module Reflex.Dom.Contrib.Widgets.Common where +import Debug.Trace ------------------------------------------------------------------------------ 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@@ -37,11 +39,18 @@ import           GHCJS.DOM.HTMLInputElement import           Reflex import           Reflex.Dom+import           Safe ------------------------------------------------------------------------------ import           Reflex.Contrib.Utils ------------------------------------------------------------------------------  +class HasChange a where+  type Change a :: *+  change :: a -> Change a+++ ------------------------------------------------------------------------------ -- | Generic config structure common to most widgets.  The attributes field -- may not be used for all widgets, but in that case it can just be ignored.@@ -53,6 +62,10 @@                    , _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@@ -70,8 +83,70 @@   setValue = widgetConfig_setValue  +class IsWidget w where+  ----------------------------------------------------------------------------+  -- | HtmlWidget with a constant value that never fires any events.+  constWidget :: Reflex t => a -> w t a++  ----------------------------------------------------------------------------+  -- | We can't make a Functor instance until Dynamic gets a Functor instance.+  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)++  ----------------------------------------------------------------------------+  -- | Combines multiple widgets over a Monoid operation.+  wconcat :: (MonadWidget t m, Foldable f, Monoid a) => f (w t a) -> m (w t a)+  wconcat = foldM (combineWidgets (<>)) (constWidget mempty)++  ----------------------------------------------------------------------------+  -- | Since widgets contain Dynamics and Events inside them, we can pull+  -- Dynamic widgets out of the Dynamic.+  extractWidget :: MonadWidget t m => Dynamic t (w t a) -> m (w t a)++ ------------------------------------------------------------------------------ -- | A general-purpose widget return value.+data Widget0 t a = Widget0+    { _widget0_value    :: Dynamic t a+      -- ^ The authoritative value for this widget.+    , _widget0_change   :: Event t a+      -- ^ Event that fires when the widget changes internally (not via a+      -- setValue event).+    }++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+++------------------------------------------------------------------------------+-- | A general-purpose widget return value. data HtmlWidget t a = HtmlWidget     { _hwidget_value    :: Dynamic t a       -- ^ The authoritative value for this widget.@@ -92,74 +167,43 @@   value = _hwidget_value  ---------------------------------------------------------------------------------- | Generalized form of many widget functions.-type GWidget t m a = WidgetConfig t a -> m (HtmlWidget t a)------------------------------------------------------------------------------------ | HtmlWidget with a constant value that never fires any events and does not--- have focus.-constWidget :: Reflex t => a -> HtmlWidget t a-constWidget a = HtmlWidget (constDyn a) never never never never (constDyn False)------------------------------------------------------------------------------------ | We can't make a Functor instance for HtmlWidget until Dynamic gets a--- Functor instance.  So until then, this will have to do.-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)+instance HasChange (HtmlWidget t a) where+  type Change (HtmlWidget t a) = Event t a+  change = _hwidget_change  ---------------------------------------------------------------------------------- | Combine function does the expected thing for _value and _change and--- applies leftmost to each of the widget events.-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+htmlTo0 :: HtmlWidget t a -> Widget0 t a+htmlTo0 w = Widget0 (_hwidget_value w) (_hwidget_change w)   --------------------------------------------------------------------------------- | Combines multiple widgets over a Monoid operation.-wconcat-    :: (MonadWidget t m, Foldable f, Monoid a)-    => f (HtmlWidget t a) -> m (HtmlWidget t a)-wconcat = foldM (combineWidgets (<>)) (constWidget mempty)+-- | Generalized form of many widget functions.+type GWidget t m a = WidgetConfig t a -> m (HtmlWidget t a)  ---------------------------------------------------------------------------------- | Convenience for extracting HtmlWidget from a Dynamic.-extractWidget-    :: MonadWidget t m-    => Dynamic t (HtmlWidget t a)-    -> m (HtmlWidget t a)-extractWidget dynWidget = do+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@@ -300,6 +344,59 @@   ------------------------------------------------------------------------------+-- | Dropdown widget that takes a dynamic list of items and a function+-- generating a String representation of those items.+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)+++------------------------------------------------------------------------------+-- | Dropdown widget that takes a list of items and a function generating a+-- String representation of those items.+--+-- This widget doesn't require your data type to have Read and Show instances+-- like reflex-dom's dropdown function.  It does this by using Int indices+-- into your static list of items in the actual rendered dropdown element.+--+-- But this comes with a price--it has unexpected behavior under insertions,+-- deletions, and reorderings of the list of options.  Because of this, you+-- should probably only use this for static dropdowns where the list of+-- options never changes.+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)+++------------------------------------------------------------------------------ -- | Returns an event that fires when the widget loses focus or enter is -- pressed. blurOrEnter@@ -311,6 +408,24 @@     fireEvent = leftmost [ () <$ (ffilter (==13) $ _hwidget_keypress w)                          , () <$ (ffilter not $ updated $ _hwidget_hasFocus w)                          ]+++------------------------------------------------------------------------------+-- | Allows you to restrict when a widget fires.  For instance,+-- @restrictWidget blurOrEnter@ restricts a widget so it only fires on blur+-- or when enter is pressed.+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+               }   ------------------------------------------------------------------------------
src/Reflex/Dom/Contrib/Widgets/DynTabs.hs view
@@ -29,6 +29,7 @@ ------------------------------------------------------------------------------ import qualified Data.Map as M import           Data.Monoid+import qualified Data.Set as S import           Reflex import           Reflex.Dom ------------------------------------------------------------------------------@@ -37,7 +38,7 @@   -------------------------------------------------------------------------------class Eq tab => Tab m tab where+class (Eq tab, Ord tab) => Tab m tab where     tabIndicator :: tab -> m ()  @@ -52,11 +53,13 @@     -- ^ Dynamic list of the displayed tabs     -> Event t tab     -- ^ Event updating the currently selected tab+    -> Dynamic t (S.Set tab)+    -- ^ Set containing tabs that are currently disabled     -> m (Dynamic t tab)-tabBar tabClass initialSelected initialTabs tabs curTab = do+tabBar tabClass initialSelected initialTabs tabs curTab disabledTabs = do     divClass "dyn-tab-bar" $ do       elAttr "ul" ("class" =: tabClass) $ do-        rec let tabFunc = mapM (mkTab currentTab)+        rec let tabFunc = mapM (mkTab currentTab disabledTabs)             foo <- widgetHoldHelper tabFunc initialTabs tabs             let bar :: Event t tab = switch $ fmap leftmost $ current foo             currentTab <- holdDyn initialSelected $ leftmost [bar, curTab]@@ -67,12 +70,14 @@ mkTab   :: (MonadWidget t m, Tab m tab)   => Dynamic t tab+  -> Dynamic t (S.Set tab)   -> tab   -> m (Event t tab)-mkTab currentTab t = do+mkTab currentTab disabledTabs t = do     isSelected <- mapDyn (==t) currentTab-    e <- activeHelper "li" (el "a" $ tabIndicator t) isSelected-    return (t <$ e)+    isDisabled <- mapDyn (S.member t) disabledTabs+    e <- activeHelper "li" (el "a" $ tabIndicator t) isSelected isDisabled+    return $ gate (not <$> current isDisabled) (t <$ e)   ------------------------------------------------------------------------------@@ -93,10 +98,18 @@   => String   -> m ()   -> Dynamic t Bool+  -- ^ Is selected+  -> Dynamic t Bool+  -- ^ Is disabled   -> m (Event t ())-activeHelper elName children isSelected = do-    attrs <- forDyn isSelected $ \selected ->-      if selected then "class" =: "active" else M.empty+activeHelper elName children isSelected isDisabled = do+    let mkAttrs selected disabled =+          if disabled+            then "class" =: "disabled"+            else if selected+                   then "class" =: "active"+                   else M.empty+    attrs <- combineDyn mkAttrs isSelected isDisabled     (li, _) <- elDynAttr' elName attrs children-    return $ _el_clicked li+    return $ domEvent Click li
+ src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiWayIf                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE RecursiveDo               #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}++module Reflex.Dom.Contrib.Widgets.EditInPlace+  ( editInPlace+  ) where++------------------------------------------------------------------------------+import           Control.Lens hiding ((.=))+import           Control.Monad.Trans+import           Data.Default+import           Data.Map (Map)+import           GHCJS.DOM.Element+import           Reflex+import           Reflex.Dom+import           Reflex.Dom.Contrib.Utils+import           Reflex.Dom.Contrib.Widgets.Common+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+data EditState = Viewing+               | Editing+  deriving (Eq,Show,Ord,Enum)+++------------------------------------------------------------------------------+-- | Control that can be used in place of dynText whenever you also want that+-- text to be editable in place.+--+-- This control creates a span that either holds text or a text input field+-- allowing that text to be edited.  The edit state is activated by clicking+-- on the text.  Edits are saved when the user presses enter or abandoned if+-- the user presses escape or the text input loses focus.+editInPlace+    :: MonadWidget t m+    => Behavior t Bool+    -- ^ Whether or not click-to-edit is enabled+    -> Dynamic t String+    -- ^ The definitive value of the thing being edited+    -> m (Event t String)+    -- ^ Event that fires when the text is edited+editInPlace active val = do+    rec editState <- holdDyn Viewing $ leftmost+          [ fmapMaybe id $ attachWith+              (\c n -> if c == Editing then Nothing else Just n)+              (current editState) startEditing+          , Viewing <$ sheetEdit+          ]+        cls <- mapDyn mkClass editState+        (e, sheetEdit) <- elDynAttr' "span" cls $ do+          de <- widgetHoldHelper (chooser val) Viewing (updated editState)+          return $ switch $ current de+        let selActive = tag active $ domEvent Click e+        let startEditing = fmapMaybe id $+              (\a -> if a then Just Editing else Nothing) <$> selActive+    return $ fmapMaybe e2maybe sheetEdit+++------------------------------------------------------------------------------+mkClass :: EditState -> Map String String+mkClass es = "class" =: (unwords ["editInPlace", ev])+  where+    ev = case es of+           Viewing -> "viewing"+           Editing -> "editing"+++------------------------------------------------------------------------------+e2maybe :: SheetEditEvent -> Maybe String+e2maybe EditClose = Nothing+e2maybe (NameChange s) = Just s+++------------------------------------------------------------------------------+chooser+    :: MonadWidget t m+    => Dynamic t String+    -> EditState+    -> m (Event t SheetEditEvent)+chooser name Editing = editor name+chooser name Viewing = viewer name+++------------------------------------------------------------------------------+data SheetEditEvent = NameChange String+                    | EditClose+  deriving (Read,Show,Eq,Ord)+++------------------------------------------------------------------------------+editor+    :: MonadWidget t m+    => Dynamic t String+    -> m (Event t SheetEditEvent)+editor name = do+  pb <- getPostBuild+  (e,w) <- htmlTextInput' "text" $+    def & widgetConfig_setValue .~ tagDyn name pb+  performEvent_ $ ffor pb $ \_ -> do+    liftIO $ elementFocus e+  let acceptEvent = leftmost+        [ () <$ ffilter (==13) (_hwidget_keypress w)+        , () <$ ffilter not (updated $ _hwidget_hasFocus w)+        ]+  return $ leftmost+    [ NameChange <$> tag (current $ value w) acceptEvent+    , EditClose <$ ffilter (==27) (_hwidget_keydown w)+    ]+++------------------------------------------------------------------------------+viewer+    :: MonadWidget t m+    => Dynamic t String+    -> m (Event t SheetEditEvent)+viewer name = do+  dynText name+  return never+