packages feed

reflex-dom-contrib (empty) → 0.1

raw patch · 13 files changed

+1531/−0 lines, 13 filesdep +aesondep +basedep +bifunctorssetup-changed

Dependencies added: aeson, base, bifunctors, bytestring, containers, data-default, ghcjs-base, ghcjs-dom, http-types, lens, mtl, readable, reflex, reflex-dom, string-conv, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Doug Beardsley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Doug Beardsley nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reflex-dom-contrib.cabal view
@@ -0,0 +1,64 @@+name:                reflex-dom-contrib+version:             0.1+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+                     libraries for reflex FRP applications. This library is+                     experimental and does not have a strong commitment to+                     preserving backwards compatibility. It will not have a+                     high bar for the quality of contributions. That being+                     said, we prefer commits that add new things rather than+                     changing existing ones. If you are wondering if there is+                     some convenience code or abstractions and you don't find+                     them in reflex or reflex-dom, look here and see if anyone+                     has already done it. If you have general-purpose reflex+                     code that you find useful that is not already here, add+                     it to this repository and send us a pull request.+homepage:            https://github.com/reflex-frp/reflex-dom-contrib+license:             BSD3+license-file:        LICENSE+author:              Doug Beardsley+maintainer:          mightybyte@gmail.com+copyright:           Soostone Inc, other authors+category:            FRP+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs: src++  exposed-modules:     +    Reflex.Contrib.Interfaces+    Reflex.Contrib.Utils+    Reflex.Dom.Contrib.KeyEvent+    Reflex.Dom.Contrib.Pagination+    Reflex.Dom.Contrib.Utils+    Reflex.Dom.Contrib.Xhr+    Reflex.Dom.Contrib.Widgets.BoundedList+    Reflex.Dom.Contrib.Widgets.CheckboxList+    Reflex.Dom.Contrib.Widgets.Common+    Reflex.Dom.Contrib.Widgets.DynTabs++  build-depends:+    aeson        >= 0.8  && < 0.10,+    base         >= 4.6  && < 4.9,+    bifunctors   >= 4.0  && < 5.1,+    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,+    string-conv  >= 0.1  && < 0.2,+    text         >= 1.2  && < 1.3,+    time         >= 1.5  && < 1.6+++  default-language:    Haskell2010++  ghc-options: -Wall -fwarn-tabs
+ src/Reflex/Contrib/Interfaces.hs view
@@ -0,0 +1,109 @@+{-# 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.Contrib.Interfaces+  ( ReflexMap(..)+  , ReflexList(..)+  , rlist2rmap+  , toReflexMap+  , rmDeleteFunc+  , selectViewListWithKey+  ) where++------------------------------------------------------------------------------+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Set (Set)+import qualified Data.Set as S+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | A reflex interface to lists.  It has a pure list of initial items, an+-- event for inserting multiple items, and an event for deleting multiple+-- items.+data ReflexList t v = ReflexList+    { rlInitialItems :: [v]+    , rlInsertItems  :: Event t [v]+    , rlDeleteItems  :: Event t [v]+    }+++------------------------------------------------------------------------------+-- | Converts a ReflexList to a ReflexMap with integer keys.+rlist2rmap+    :: (Reflex t, Eq v)+    => ReflexList t v+    -> Dynamic t (Map Int v)+    -> ReflexMap t Int v+rlist2rmap ReflexList{..} curMap = ReflexMap+    { rmInitialItems = M.fromList $ zip [0..] rlInitialItems+    , rmInsertItems = attachDynWith f curMap rlInsertItems+    , rmDeleteItems = attachDynWith g curMap rlDeleteItems+    }+  where+    f m is = zip [nextKey m..] is+    g m is = M.keysSet $ M.filter (`elem` is) m+    nextKey m = succ $ fst (M.findMax m)+++------------------------------------------------------------------------------+-- | A reflex interface to maps that allows inserting and deleting multiple+-- items at a time.+data ReflexMap t k v = ReflexMap+    { rmInitialItems :: Map k v+    , rmInsertItems  :: Event t [(k,v)]+    -- ^ We use a list of key-value pairs here because order is important+    , rmDeleteItems  :: Event t (Set k)+    }+++------------------------------------------------------------------------------+-- | Converts a ReflexList to a Dynamic list.+toReflexMap+    :: (MonadWidget t m, Eq a)+    => ReflexList t a+    -> (ReflexMap t Int a -> m (Dynamic t (Map Int a)))+    -> m (Dynamic t [a])+toReflexMap rlist f = do+    rec let rmap = rlist2rmap rlist m+        m <- f rmap+    mapDyn M.elems m+++------------------------------------------------------------------------------+-- | Takes a set of keys and returns a function that deletes these keys from+-- a map.+rmDeleteFunc :: Ord k => Set k -> Map k v -> Map k v+rmDeleteFunc s m = foldr M.delete m (S.toList s)+++------------------------------------------------------------------------------+-- | A generalized version of the one in reflex-dom.+selectViewListWithKey+    :: forall t m k v a. (MonadWidget t m, Ord k)+    => Dynamic t k+    -> Dynamic t (Map k v)+    -> (k -> Dynamic t v -> Dynamic t Bool -> m a)+    -> m (Dynamic t (Map k a))+selectViewListWithKey selection vals mkChild = do+  let selectionDemux = demux selection+  listWithKey vals $ \k v -> do+    selected <- getDemuxed selectionDemux k+    mkChild k v selected+++
+ src/Reflex/Contrib/Utils.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI            #-}+{-# LANGUAGE RecursiveDo              #-}++module Reflex.Contrib.Utils where++------------------------------------------------------------------------------+import           Control.Monad+import           Reflex+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | A small amount of convenience for return ().+end :: Monad m => m ()+end = return ()+++------------------------------------------------------------------------------+-- | fmapMaybe twice+fmapMaybe2 :: Reflex t => Event t (Maybe (Maybe a)) -> Event t a+fmapMaybe2 = fmapMaybe id . fmapMaybe id+++------------------------------------------------------------------------------+-- | Construct an event with a tuple of (current,updated).+attachDynSelf :: Reflex t => Dynamic t a -> Event t (a,a)+attachDynSelf d = attach (current d) (updated d)+++------------------------------------------------------------------------------+-- | Partitions an event into a pair of events that fire when the predicate+-- function evaluates to True and False respectively.+partitionEvent+    :: Reflex t+    => (a -> Bool)+    -> Event t a+    -> (Event t a, Event t a)+partitionEvent f e = ( fmapMaybe (\(b, x) -> if b then Just x else Nothing) e'+                     , fmapMaybe (\(b, x) -> if b then Nothing else Just x) e'+                     )+  where e' = fmap (\x -> (f x, x)) e+++------------------------------------------------------------------------------+-- | Sometimes you end up with a Dynamic t Foo where Foo contains an Event+-- field.  This function collapses the two levels of Dynamic Event into just+-- an Event.+extractEvent+    :: (Reflex t, MonadHold t m)+    => (a -> Event t b)+    -> Dynamic t a+    -> m (Event t b)+extractEvent f = liftM (switch . current) . mapDyn f+++------------------------------------------------------------------------------+-- | Sometimes you end up with a Dynamic t Foo where Foo contains a Dynamic+-- field.  This function collapses the two levels of Dynamic Dynamic into a+-- single Dynamic.+extractDyn+    :: (Reflex t, MonadHold t m)+    => (a -> Dynamic t b)+    -> Dynamic t a+    -> m (Dynamic t b)+extractDyn f = liftM joinDyn . mapDyn f+
+ src/Reflex/Dom/Contrib/KeyEvent.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI            #-}++{-|++API for dealing with keyboard events.++-}++module Reflex.Dom.Contrib.KeyEvent+  ( KeyEvent(..)+  , key+  , shift+  , ctrlKey+  , Reflex.Dom.Contrib.KeyEvent.getKeyEvent+  ) where++------------------------------------------------------------------------------+import           Control.Monad.Reader+import           Data.Char+import           GHCJS.DOM.EventM (event)+import           GHCJS.DOM.Types hiding (Event)+import           GHCJS.Types+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+   , keCtrl :: Bool+   , keShift :: Bool+   } deriving (Show, Read, Eq, Ord)+++------------------------------------------------------------------------------+-- | Convenience constructor for KeyEvent with no modifiers pressed.+key :: Char -> KeyEvent+key k = KeyEvent+   { keKeyCode = ord k+   , keCtrl = False+   , keShift = False+   }+++------------------------------------------------------------------------------+-- | Set the shift modifier of a KeyEvent.+shift :: KeyEvent -> KeyEvent+shift ke = ke { keShift = True }+++------------------------------------------------------------------------------+-- | Set the ctrl modifier of a KeyEvent.+ctrlKey :: Char -> KeyEvent+ctrlKey k = (key $ toUpper k) { keCtrl = True }+++------------------------------------------------------------------------------+getKeyEvent :: ReaderT (t, UIEvent) IO KeyEvent+getKeyEvent = do+  e <- event+  code <- Reflex.Dom.getKeyEvent+  liftIO $ KeyEvent <$> pure code+                    <*> js_uiEventGetCtrlKey (unUIEvent e)+                    <*> js_uiEventGetShiftKey (unUIEvent e)++
+ src/Reflex/Dom/Contrib/Pagination.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE RecursiveDo         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}++module Reflex.Dom.Contrib.Pagination where++------------------------------------------------------------------------------+import           Control.Lens         hiding ((.=))+import           Data.Aeson+import           Data.ByteString.Lazy (ByteString)+import           Data.Default+import           Data.Function        (on)+import           Data.List+import           Data.Ord+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Monoid+import           Data.Time+import           Data.Word+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+import           Reflex.Dom.Contrib.Xhr+------------------------------------------------------------------------------+++                                  -----------------+                                  -- Data Types  --+                                  -----------------++------------------------------------------------------------------------------+-- | General data structure needed for running queries with paginated results.+data PaginationQuery = PaginationQuery+  { _pqLimit        :: Word64+  , _pqOffset       :: Word64+  , _pqSearchString :: String+  } deriving (Eq,Show,Read,Ord)++makeLenses ''PaginationQuery+++------------------------------------------------------------------------------+instance Default PaginationQuery where+    def = PaginationQuery 5000 0 ""+++------------------------------------------------------------------------------+instance FromJSON PaginationQuery where+    parseJSON (Object o) = PaginationQuery+        <$> o .:? "limit" .!= 5000+        <*> o .:? "offset" .!= 0+        <*> o .: "searchString"+    parseJSON _ = fail "PaginationQuery JSON representation must be an object"+++------------------------------------------------------------------------------+instance ToJSON PaginationQuery where+    toJSON (PaginationQuery l o s) =+      object+        [ "limit"        .= l+        , "offset"       .= o+        , "searchString" .= s+        ]+++------------------------------------------------------------------------------+-- | Data structure wrapping results.+data PaginationResults a = PaginationResults+  { _prOffset     :: Word64+  , _prTotalCount :: Word64+  , _prTimestamp  :: UTCTime+  , _prResults    :: [a]+  } deriving (Eq,Show,Read,Ord)++makeLenses ''PaginationResults+++------------------------------------------------------------------------------+instance FromJSON a => FromJSON (PaginationResults a) where+    parseJSON (Object o) = PaginationResults+        <$> o .: "offset"+        <*> o .: "totalCount"+        <*> o .: "timestamp"+        <*> o .: "results"+    parseJSON _ = fail "PaginationResults JSON representation must be an object"+++------------------------------------------------------------------------------+instance ToJSON a => ToJSON (PaginationResults a) where+    toJSON (PaginationResults o c t r) =+      object $+        [ "offset"     .= o+        , "totalCount" .= c+        , "timestamp"  .= t+        , "results"    .= r+        ]++                             -------------------------+                             -- Front-end Functions --+                             -------------------------++------------------------------------------------------------------------------+-- Some convenient type aliases+type PaginationCache k v = Map k [CacheVal v]+type PaginationInput k = (k, PaginationQuery)+type PaginationOutput k v = (k, CacheVal v)+++------------------------------------------------------------------------------+-- | Along with the query results we also need to store the PaginationQuery+-- structure that generated it as well as a flag indicating whether this data+-- should be stored in the cache.  This prevents results that are sub-searches+-- of a previous search from overwriting the results of a more general query.+data CacheVal a = CacheVal+    { _pvQuery       :: PaginationQuery+    , _pvShouldStore :: Bool+    , _pvValue       :: a+    } deriving (Eq, Show, Ord)++makeLenses ''CacheVal+++------------------------------------------------------------------------------+data PQParams = PQParams+    { pqpMaxCacheSize :: Int+    -- ^ The max number of queries to cache+    , pqpPruneAmount  :: Int+    -- ^ The number of queries to discard when we reach the size limit+    } deriving (Eq, Show, Ord)+++instance Default PQParams where+    def = PQParams 5 3+    --def = PQParams 20 5+++------------------------------------------------------------------------------+-- | Paginated querying with built-in search and results caching.+paginatedQuery+  :: forall t m k a. (MonadWidget t m, Show k, Ord k, FromJSON a)+  => PQParams+  -> (String -> a -> Bool)+  -> String+  -> 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))+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+++------------------------------------------------------------------------------+addToCache+    :: Ord k+    => PQParams+    -> PaginationOutput k (PaginationResults v)+    -> PaginationCache k (PaginationResults v)+    -> PaginationCache k (PaginationResults v)+addToCache PQParams{..} (k, v) m =+    if _pvShouldStore v+      then M.insertWith (++) k [v] m2+      else m+  where+    m2 = if M.size m > pqpMaxCacheSize then prune pqpPruneAmount m else m+++------------------------------------------------------------------------------+-- | Prunes the PaginationCache of the oldest n entries.  This is not the+-- oldest (k,v) pairs.  It is the oldest vs out of all the (k,[v]) pairs.+prune+    :: Ord k+    => Int+    -> PaginationCache k (PaginationResults v)+    -> PaginationCache k (PaginationResults v)+prune n m = +    M.fromList $ map g $ groupBy ((==) `on` fst) $ sortBy (comparing fst) $+    drop n $ sortBy (comparing $ _prTimestamp . _pvValue . snd) $+    concatMap f $ M.toList m+  where+    f (k,vs) = map (k,) vs+    g [] = error "prune impossible error"+    g ps = (fst $ head ps, map snd ps)+++------------------------------------------------------------------------------+-- | Checks a cache and makes a request to the supplied URL if the cached data+-- cannot be used to serve the results of the current requested query.+cachedQuery+    :: (MonadWidget t m, Show k, Ord k, FromJSON a)+    => (String -> a -> Bool)+    -> String+    -> PaginationCache k (PaginationResults a)+    -> (Map String ByteString, PaginationInput k)+    -> m (Event t (PaginationOutput k (PaginationResults a)))+cachedQuery matchSearchString url cache input = do+    let (k, pq) = snd input+    pb <- getPostBuild+    let getData = do+          res <- getAndDecode (mkFullPath input <$ pb)+          return $ (\v -> (k, CacheVal pq True $ fromMaybe err v)) <$> res+    case M.lookup k cache of+      Nothing -> getData+      Just pvs ->+          case filter (isSubSearch pq) pvs of+            [] -> getData+            pv:_ -> do+              let pv2 = pv & (pvValue . prResults) %~+                             filter (matchSearchString $ _pqSearchString pq)+                           & pvShouldStore .~ False+              return $ (k,pv2) <$ pb+  where+    err = error "Error decoding pagination results"+    mkFullPath p = url <> "?" <> queryString p+    queryString (ps, (_,pq)) = formEncode $+      M.insert "pagination" (encode pq) ps+++------------------------------------------------------------------------------+-- | Checks whether a previous cached search string is a substring of the+-- current search string.  In this case we don't need to requery the server.+isSubSearch+    :: PaginationQuery+    -> CacheVal (PaginationResults a)+    -- ^ Cached query results+    -> Bool+isSubSearch pq pv =+    (_pqSearchString (_pvQuery pv) `isInfixOf` _pqSearchString pq) &&+    (_prTotalCount pr == fromIntegral (length (_prResults pr))) &&+    (_prOffset pr == 0)+  where+    pr = _pvValue pv+
+ src/Reflex/Dom/Contrib/Utils.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI            #-}++{-|++Misc reflex-dom helper functions.++-}++module Reflex.Dom.Contrib.Utils+  ( confirmEvent+  , getWindowLocationPath+  , windowHistoryPushState+  , widgetHoldHelper+  , putDebugLn+  , putDebugLnE+  ) where++------------------------------------------------------------------------------+import           Control.Monad+import           Control.Monad.Reader+import           GHCJS.DOM.Types hiding (Event)+import           GHCJS.Foreign+import           GHCJS.Marshal+import           GHCJS.Types+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+#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++foreign import javascript unsafe+  "window.history.pushState({},\"\",$1)"+  js_windowHistoryPushState :: 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."++#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)+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+++------------------------------------------------------------------------------+-- | 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+getWindowLocationPath w = do+    jw <- toJSRef w+    liftM fromJSString $ js_windowLocationPath jw+++------------------------------------------------------------------------------+-- | Pushes a new URL to the window history.+windowHistoryPushState :: String -> IO ()+windowHistoryPushState = js_windowHistoryPushState . toJSString+++------------------------------------------------------------------------------+-- | A common form for widgetHold calls that mirrors the pattern seen in hold+-- and holdDyn.+widgetHoldHelper+    :: MonadWidget t m+    => (a -> m b)+    -> a+    -> Event t a+    -> m (Dynamic t b)+widgetHoldHelper f eDef e = widgetHold (f eDef) (f <$> e)+++------------------------------------------------------------------------------+-- | Simple debug function that prints a message on postBuild.+putDebugLn :: MonadWidget t m => String -> m ()+putDebugLn str = do+    pb <- getPostBuild+    putDebugLnE pb (const str)+++------------------------------------------------------------------------------+-- | Prints a string when an event fires.  This differs slightly from+-- traceEvent because it will print even if the event is otherwise unused.+putDebugLnE :: MonadWidget t m => Event t a -> (a -> String) -> m ()+putDebugLnE e mkStr = do+    performEvent_ (liftIO . putStrLn . mkStr <$> e)+
+ src/Reflex/Dom/Contrib/Widgets/BoundedList.hs view
@@ -0,0 +1,205 @@+{-# 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.BoundedList+  ( boundedSelectList+  , boundedSelectList'+  , mkHiding+  , keyToMaybe+  ) where++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad+import           Data.Bifunctor+import           Data.List+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Monoid+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+import           Reflex.Contrib.Interfaces+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+findCurItem :: Ord k => Map k v -> k -> Maybe (k,v)+findCurItem m k = M.lookupLE k m <|> M.lookupGT k m+++-- Limit on the number of items in the DOM.  Might make this more+-- sophisticated in the future.+type Limit = Maybe Int++-- An Int counter that we use in lieu of a timestamp for LRU calculations+type BornAt = Int+++------------------------------------------------------------------------------+limitMap :: Ord k => Map k v -> Limit -> Map k v+limitMap m Nothing = m+limitMap m (Just lim) = M.fromList $ take lim $ M.toList m+++------------------------------------------------------------------------------+boundedInsert+    :: Ord k+    => Limit+    -> (BornAt, (k,v))+    -> Map k (BornAt,v)+    -> Map k (BornAt,v)+boundedInsert Nothing (c, (k, v)) m = M.insert k (c,v) m+boundedInsert (Just lim) (c, (k, v)) m =+    if M.size m < lim then ins m else ins pruned+  where+    ins = M.insert k (c,v)+    pruned = M.fromList $ tail $ sortOn (fst . snd) $ M.toList m+++------------------------------------------------------------------------------+-- | A widget with generalized handling for dynamically sized lists.  There+-- are many possible approaches to rendering lists that have one visible+-- current selection.  One way is to keep all the items in the DOM and manage+-- the selection by managing visibility through something like display:none or+-- visibility:hidden.  Another way is to only keep the currently selected item+-- in the DOM and swap it out every time the selection is changed.+--+-- The problem with keeping all items in the DOM is that this might use too+-- much memory either because there are many items or the items are large.+-- The problem with keeping only the currently selected item in the DOM is+-- that performance might be too slow if removing the old item's DOM elements+-- and building the new one takes too long.+--+-- This widget provides a middle ground.  It lets the user decide how many+-- elements are kept in the DOM at any one time and prunes the least recently+-- 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+    -- ^ Maximum number of items to keep in the DOM at a time+    -> Dynamic t k+    -- ^ Currently selected item+    -> 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+                  ReflexMap{..} renderSingle = do+    -- Map holding the full item list.+    items <- foldDyn ($) rmInitialItems $ leftmost+      [ M.union . M.fromList <$> rmInsertItems+      , rmDeleteFunc <$> rmDeleteItems+      , updateEvent+      ]+    +    counter <- count $ updated curSelected+    curItem <- combineDyn findCurItem items curSelected+    let addCounter c (k,v) = (k, ((-c), 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)+    selectViewListWithKey curSelected activeItems wrapSingle+  where+    wrapSingle k v b = do+        v' <- mapDyn snd v+        renderSingle k v' b+++------------------------------------------------------------------------------+-- | 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.+    -> (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 getKey shouldRunExpensive+                  expensiveGetNew defaultVal renderSingle = do+    pb <- getPostBuild+    e0 <- expensiveGetNew $ tagDyn curSelected pb+    rec+      let insertEvent = fmapMaybe id $+            attachDynWith isAlreadyPresent res (updated curSelected)+      newVal <- expensiveGetNew insertEvent+      let rm = ReflexMap mempty ((:[]) <$> leftmost [newVal, e0]) never+      curK <- mapDyn getKey curSelected+      res :: Dynamic t (Map k b) <-+        boundedSelectList' never itemLimit curK rm 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+++------------------------------------------------------------------------------+-- | Wraps a widget with a dynamically hidden div that uses display:none to+-- hide.+mkHiding+    :: (MonadWidget t m)+    => Map String String+    -> m a+    -> Dynamic t Bool+    -- ^ Function of a dynamic active flag+    -> m a+mkHiding staticAttrs w active = do+    attrs <- mapDyn mkAttrs active+    elDynAttr "div" attrs w+  where+    mkAttrs True = staticAttrs+    mkAttrs False = staticAttrs <> "style" =: "display:none"+++------------------------------------------------------------------------------+-- | Small helper for a common pattern that comes up with the expensiveGetNew+-- parameter to boundedSelectList.+keyToMaybe+    :: MonadWidget t m+    => (Event t a -> m (Event t (b,c)))+    -> Event t (Maybe a)+    -> m (Event t (Maybe b, c))+keyToMaybe f = liftM (fmap $ first Just) . f . fmapMaybe id+
+ src/Reflex/Dom/Contrib/Widgets/CheckboxList.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables      #-}++module Reflex.Dom.Contrib.Widgets.CheckboxList where++------------------------------------------------------------------------------+import           Control.Monad+import           Data.Set (Set)+import qualified Data.Set as S+import           Reflex+import           Reflex.Dom+import           Reflex.Dom.Contrib.Widgets.Common+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Takes a list of labels to make checkboxes for and returns the labels of+-- the boxes that are checked.+checkboxList+    :: forall t m a. (MonadWidget t m, Ord a, Show a)+    => (a -> String)+    -- ^ Function to show each item+    -> (String -> a -> Bool)+    -- ^ Function to filter each item+    -> 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 (HtmlWidget t [a])+    -- ^ Dynamic list of checked items+checkboxList showFunc filterFunc 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+          mapWidget (\b -> if b then [item] else []) cb+      wconcat es+
+ src/Reflex/Dom/Contrib/Widgets/Common.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE MultiWayIf                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE RecursiveDo               #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}++{-|++Infrastructure common to a wide variety of widgets.  WidgetConfig holds the+core inputs needed by most widgets, while HtmlWidget holds the core Dynamics+and Events returned by most widgets.  Encapsulating widget inputs and outputs+this way makes it easier to compose and transform widgets.++-}++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.Monoid+import           Data.Readable+import           Data.String.Conv+import           Data.Time+import           GHCJS.DOM.HTMLInputElement+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+import           Reflex.Contrib.Utils+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | 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.+-- We may want to change this in the future, but it seems like a reasonable+-- start for now.+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+++------------------------------------------------------------------------------+-- | A general-purpose widget return value.+data HtmlWidget t a = HtmlWidget+    { _hwidget_value    :: Dynamic t a+      -- ^ The authoritative value for this widget.+    , _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+++instance HasValue (HtmlWidget t a) where+  type Value (HtmlWidget t a) = Dynamic t a+  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)+++------------------------------------------------------------------------------+-- | 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+++------------------------------------------------------------------------------+-- | 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)+++------------------------------------------------------------------------------+-- | Convenience for extracting HtmlWidget from a Dynamic.+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+++------------------------------------------------------------------------------+-- | Input widget for datetime values.+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"+++------------------------------------------------------------------------------+-- | Input widget for dates.+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)+++------------------------------------------------------------------------------+-- | HtmlWidget version of reflex-dom's checkbox.+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)+++------------------------------------------------------------------------------+-- | HtmlWidget version of reflex-dom's textInput.+htmlTextInput+    :: MonadWidget t m+    => String+    -> GWidget t m String+htmlTextInput inputType cfg = do+    (_,w) <- htmlTextInput' inputType cfg+    return w+++------------------------------------------------------------------------------+-- | HtmlWidget version of reflex-dom's textInput that also returns the+-- HTMLInputElement.+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 probably not use this function with string types because+-- the Show instance will quote strings.+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+++------------------------------------------------------------------------------+-- | Widget that parses its input to a Double.+doubleWidget :: (MonadWidget t m) => GWidget t m (Maybe Double)+doubleWidget = readableWidget+++------------------------------------------------------------------------------+-- | Widget that parses its input to an Integer.+integerWidget :: (MonadWidget t m) => GWidget t m (Maybe Integer)+integerWidget = readableWidget+++------------------------------------------------------------------------------+-- | Widget that parses its input to an Int.+intWidget :: (MonadWidget t m) => GWidget t m (Maybe Int)+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+++------------------------------------------------------------------------------+-- | A list dropdown widget.+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+
+ src/Reflex/Dom/Contrib/Widgets/DynTabs.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE MultiWayIf                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE RecursiveDo               #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeFamilies              #-}++{-|++An API for constructing a tab bar where the list of tabs in the bar is+determined dynamically.++-}++module Reflex.Dom.Contrib.Widgets.DynTabs+  ( Tab(..)+  , tabBar+  , tabPane+  , activeHelper+  ) where++------------------------------------------------------------------------------+import qualified Data.Map as M+import           Data.Monoid+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+import           Reflex.Dom.Contrib.Utils+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+class Eq tab => Tab m tab where+    tabIndicator :: tab -> m ()+++------------------------------------------------------------------------------+tabBar+    :: forall t m tab. (MonadWidget t m, Tab m tab)+    => String+    -> tab+    -- ^ Initial open tab+    -> [tab]+    -> Event t [tab]+    -- ^ Dynamic list of the displayed tabs+    -> Event t tab+    -- ^ Event updating the currently selected tab+    -> m (Dynamic t tab)+tabBar tabClass initialSelected initialTabs tabs curTab = do+    divClass "dyn-tab-bar" $ do+      elAttr "ul" ("class" =: tabClass) $ do+        rec let tabFunc = mapM (mkTab currentTab)+            foo <- widgetHoldHelper tabFunc initialTabs tabs+            let bar :: Event t tab = switch $ fmap leftmost $ current foo+            currentTab <- holdDyn initialSelected $ leftmost [bar, curTab]+        return currentTab+++------------------------------------------------------------------------------+mkTab+  :: (MonadWidget t m, Tab m tab)+  => Dynamic t tab+  -> tab+  -> m (Event t tab)+mkTab currentTab t = do+    isSelected <- mapDyn (==t) currentTab+    e <- activeHelper "li" (el "a" $ tabIndicator t) isSelected+    return (t <$ e)+++------------------------------------------------------------------------------+tabPane :: (MonadWidget t m, Eq tab) => Dynamic t tab -> tab -> m a -> m a+tabPane currentTab t child = do+    isShown <- mapDyn (\c ->+      if c == t then klass+                else klass <> "style" =: "display: none") currentTab+    elDynAttr "div" isShown child+  where+    klass = "class" =: "dyn-tab-pane"+++------------------------------------------------------------------------------+-- | Sets the \"active\" class +activeHelper+  :: MonadWidget t m+  => String+  -> m ()+  -> Dynamic t Bool+  -> m (Event t ())+activeHelper elName children isSelected = do+    attrs <- forDyn isSelected $ \selected ->+      if selected then "class" =: "active" else M.empty+    (li, _) <- elDynAttr' elName attrs children+    return $ _el_clicked li+
+ src/Reflex/Dom/Contrib/Xhr.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecursiveDo         #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|++Convenience functions for dealing with XMLHttpRequest.++-}++module Reflex.Dom.Contrib.Xhr where++------------------------------------------------------------------------------+import           Control.Lens+import           Control.Monad.Reader+import           Data.Aeson+import           Data.ByteString.Lazy (ByteString)+import           Data.Default+import           Data.List+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.String.Conv+import qualified Data.Text as T+import           Network.HTTP.Types.URI+------------------------------------------------------------------------------+import           Reflex+import           Reflex.Dom+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | URL encodes a map of key-value pairs.+formEncode :: Map String ByteString -> String+formEncode m =+    intercalate "&" $+      map (\(k,v) -> k ++ "=" ++ (encodeToString v)) $ M.toList m+  where+    encodeToString :: ByteString -> String+    encodeToString = toS . urlEncode True . toS+++------------------------------------------------------------------------------+-- | Form encodes a JSON object.+formEncodeJSON :: ToJSON a => a -> String+formEncodeJSON a = case toJSON a of+    Object m ->+      formEncode $ M.fromList $ map (bimap T.unpack encode) $ itoList m+    _ -> error "formEncodeJSON requires an Object"+++------------------------------------------------------------------------------+-- | Convenience function for constructing a POST request.+toPost+    :: String+    -- ^ URL+    -> String+    -- ^ The post data+    -> XhrRequest+toPost url d =+    XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc+                                , _xhrRequestConfig_sendData = Just d+                                }+  where+    headerUrlEnc :: Map String String+    headerUrlEnc = "Content-type" =: "application/x-www-form-urlencoded"+++------------------------------------------------------------------------------+-- | This is the foundational primitive for the XHR API because it gives you+-- full control over request generation and response parsing and also allows+-- you to match things that generated the request with their corresponding+-- responses.+performAJAX+    :: (MonadWidget t m)+    => (a -> XhrRequest)+    -- ^ Function to build the request+    -> (XhrResponse -> b)+    -- ^ Function to parse the response+    -> Event t a+    -> m (Event t (a, b))+performAJAX mkRequest parseResponse req =+    performEventAsync $ ffor req $ \a cb -> do+      _ <- newXMLHttpRequest (mkRequest a) $ \response ->+             liftIO $ cb (a, parseResponse response)+      return ()+++------------------------------------------------------------------------------+-- | Performs an async XHR taking a JSON object as input and another JSON+-- object as output.+performJsonAjax+    :: (MonadWidget t m, ToJSON a, FromJSON b)+    => Event t (String, a)+    -- ^ Event with a URL and a JSON object to be sent+    -> m (Event t (a, Maybe b))+performJsonAjax req =+    performEventAsync $ ffor req $ \(url,a) cb -> do+      _ <- newXMLHttpRequest (mkRequest url a) $ \response ->+             liftIO $ cb (a, decodeXhrResponse response)+      return ()+  where+    mkRequest url a = toPost url (formEncodeJSON a)++