packages feed

reflex-transformers (empty) → 0.1

raw patch · 15 files changed

+950/−0 lines, 15 filesdep +basedep +containersdep +lenssetup-changed

Dependencies added: base, containers, lens, mtl, reflex, semigroups, stateWriter, transformers

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -Wall
+ .gitignore view
@@ -0,0 +1,15 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config
+ .travis.yml view
@@ -0,0 +1,29 @@+sudo: false+cache:+  directories:+    - $HOME/hlint+before_install:+ - travis_retry cabal-$CABALVER update+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/happy/1.19.5/bin:/opt/alex/3.1.4/bin:~/hlint/bin:$PATH+ - travis/install-hlint.sh+install:+ - cabal-$CABALVER sandbox init+ - git clone -b develop https://github.com/ryantrinkle/reflex reflex+ - cabal-$CABALVER sandbox add-source $PWD/reflex+ - cabal-$CABALVER install -v --only-dependencies --enable-tests --enable-benchmarks -j++script:+ - travis/script.sh+ - hlint src++matrix:+  allow_failures:+   - env: CABALVER=head GHCVER=head +  include:+    - env: CABALVER=1.18 GHCVER=7.8.4+      addons: {apt: {packages: [cabal-install-1.18, ghc-7.8.4, alex-3.1.4, happy-1.19.5], sources: [hvr-ghc]}}+    - env: CABALVER=1.22 GHCVER=7.10.1+      addons: {apt: {packages: [cabal-install-1.22, ghc-7.10.1, alex-3.1.4, happy-1.19.5],sources: [hvr-ghc]}}+    - env: CABALVER=head GHCVER=head+      addons: {apt: {packages: [cabal-install-head, ghc-head, alex-3.1.4, happy-1.19.5],  sources: [hvr-ghc]}}+  fast_finish: true
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2015 Benno Fünfstück++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ README.md view
@@ -0,0 +1,8 @@+reflex-transformers [![Build Status](https://secure.travis-ci.org/Saulzar/reflex-transformers.png?branch=master)](http://travis-ci.org/Saulzar/reflex-transformers)+====================++## Introduction++  This library provides a set of Monad transformers (and instances for common transformers) on top of +  widget switching primitives for reflex. For example ReaderT and WriterT which operate in the presence +  of widget switching, allowing you to pass inputs and outputs up and down the UI tree.
+ Setup.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.IORef+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..), hsSourceDirs, exeModules, libBuildInfo, buildInfo, libModules, modulePath, exeName)+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, withExeLBI, ComponentLocalBuildInfo(), LocalBuildInfo(), componentPackageDeps )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag, buildDistPref, defaultDistPref, fromFlagOrDefault )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Text (disp)+import Distribution.Verbosity ( Verbosity )+import System.Directory ( canonicalizePath )+import System.FilePath ( (</>), dropExtension )+import Text.PrettyPrint (render)++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi flags+     buildHook simpleUserHooks pkg lbi hooks flags+  }++--  Very ad-hoc implementation of difference lists+singletonDL :: a -> [a] -> [a]+singletonDL = (:)++emptyDL :: [a] -> [a]+emptyDL = id++appendDL :: ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]+appendDL x y = x . y++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO ()+generateBuildModule verbosity pkg lbi flags = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withTestLBI pkg lbi $ \suite suitelbi -> do+    srcDirs <- mapM canonicalizePath $ hsSourceDirs $ testBuildInfo suite+    distDir <- canonicalizePath $ fromFlagOrDefault defaultDistPref $ buildDistPref flags++    doctestVar <- newIORef emptyDL+    withLibLBI pkg lbi $ \lib liblbi ->+      let mods = map (render . disp) $ libModules lib in+      modifyIORef doctestVar $ appendDL . singletonDL $ doctestTarget "libary" mods (libBuildInfo lib) liblbi suitelbi+    withExeLBI pkg lbi $ \exe exelbi ->+      let mods = dropExtension (modulePath exe) : map (render . disp) (exeModules exe) in+      modifyIORef doctestVar $ appendDL . singletonDL $ doctestTarget ("executable " ++ exeName exe) mods (buildInfo exe) exelbi suitelbi+    doctestTargets <- fmap ($ []) $ readIORef doctestVar++    rewriteFile (dir </> "Build_" ++ map fixchar (testName suite) ++ ".hs") $ unlines+      [ "module Build_" ++ map fixchar (testName suite) ++ " where"+      , "getDistDir :: FilePath"+      , "getDistDir = " ++ show distDir+      , "getSrcDirs :: [FilePath]"+      , "getSrcDirs = " ++ show srcDirs+      , "doctestTargets :: [(String, [String], [FilePath], [String])]"+      , "doctestTargets = " ++ show doctestTargets+      ]++  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+    doctestTarget name mods targetbi targetlbi suitelbi = (name, mods, hsSourceDirs targetbi, formatdeps $ testDeps targetlbi suitelbi)+    fixchar '-' = '_'+    fixchar c = c++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+ reflex-transformers.cabal view
@@ -0,0 +1,79 @@+name:          reflex-transformers+version:       0.1+license:       BSD3+license-file:  LICENSE+cabal-version: >= 1.10+Category: FRP+author:        Oliver Batchelor+maintainer:    saulzar@gmail.com+stability:     experimental+homepage:      http://github.com/saulzar/reflex-transformers+bug-reports:   http://github.com/saulzar/reflex-transformers/issues+copyright:     Copyright (C) 2015 Oliver Batchelor+synopsis:      Collections and switchable Monad transformers for Reflex+description:   +  This library provides a set of Monad transformers (and instances for common transformers) on top of +  widget switching primitives for reflex. For example ReaderT and WriterT which operate in the presence +  of widget switching, allowing you to pass inputs and outputs up and down the UI tree.+  +build-type:    Simple++extra-source-files:+  .ghci+  .gitignore+  .travis.yml+  .vim.custom+  README.md++source-repository head+  type: git+  location: https://github.com/saulzar/reflex-transformers.git++  +  +library+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall +  build-depends:+    base        >= 4.4 && < 5,+    mtl >= 2.1 && < 2.3,+    containers == 0.5.*,+    reflex      >= 0.3 && < 0.5,+    transformers >= 0.2,+    lens >= 4.7 && < 4.14,+    semigroups >= 0.16 && < 0.18,+    stateWriter >= 0.2.6 && < 0.3+    +  default-extensions:+    TupleSections+    RecursiveDo+    FlexibleInstances+    FlexibleContexts+    ConstraintKinds+    StandaloneDeriving+    FunctionalDependencies+    RecordWildCards+    TypeFamilies+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    ScopedTypeVariables+    RankNTypes+    GADTs++    +  exposed-modules:+    Reflex.Monad+    Reflex.Monad.Class+    Reflex.Monad.ReflexM+    Reflex.Monad.Supply+    Reflex.Monad.ReaderWriter+    +    Reflex.Switching+    Reflex.Updated+    ++ +  ghc-options: -Wall++
+ src/Reflex/Monad.hs view
@@ -0,0 +1,144 @@++-- | Module supporting the implementation of frameworks. You should import this if you+-- want to build your own framework, along with one of the base MonadSwitch classes: +--+-- Reflex.Monad.App for MonadIO based frameworks+-- or Reflex.Monad.ReflexM for pure frameworks+--++module Reflex.Monad +  ( module Reflex.Monad.Class+  +  , holdM+  +  , collectMapM+  , collectM+  +  , collect+  +  , Flow (..)+  , flowM+  +  , Chain (..)+  , chainM+  , (>->)+  +  , loopM+  +  ) where++import Control.Applicative+import Control.Monad+import Control.Lens++import Data.Monoid+import Data.List+import Data.Functor++import Reflex.Monad.Class+import Reflex.Monad.ReflexM++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+++import Prelude +++  ++holdM :: (MonadSwitch t m) => m a -> Event t (m a) -> m (Dynamic t a)+holdM initial e = holdDyn' =<< switchM (Updated initial e)+++withIds :: (MonadReflex t m) => [a] -> Event t [a] -> m (Map Int a, Event t (Map Int a))+withIds initial added = do+  total <- current <$> foldDyn (+) (genericLength initial)  (genericLength <$> added)+  return (zipFrom 0 initial, attachWith zipFrom total added)+    where+      zipFrom n = Map.fromList . zip [n..] +    +++collect :: (MonadReflex t m) => [(a, Event t ())] -> Event t [(a, Event t ())] -> m (UpdatedMap t Int a)+collect initial added = runReflexM $ collectM (pure <$> initial)  (fmap pure <$> added)+    +    +collectM :: (MonadSwitch t m) => [m (a, Event t ())] -> Event t [m (a, Event t ())] -> m (UpdatedMap t Int a)+collectM initial added = do +  (initialMap, addedMap) <- withIds initial added+  rec+    +    (values, remove) <- fmap split <$> switchMapM $ UpdatedMap initialMap $ +        mergeWith (<>) [ fmap Just <$> addedMap, toRemove ]+      +    toRemove <- switchMerge' $ makeRemovals remove+  return values++  where+    makeRemovals = imap (\k -> fmap $ const $ Map.singleton k Nothing)    +  +  ++    ++collectMapM :: (MonadSwitch t m, Ord k) => Dynamic t (Map k v) -> (k -> Dynamic t v ->  m a) ->  m (Dynamic t (Map k a))+collectMapM input childView =  do+  inputViews <- mapDyn (Map.mapWithKey itemView) input+  let updates = shallowDiff (current inputViews) (updated inputViews)  ++  initial <- sample (current inputViews)+  holdMapDyn =<< switchMapM (UpdatedMap initial updates)+  +  where+    itemView k v = holdDyn v (fmapMaybe (Map.lookup k) (updated input)) >>= childView k  +    +    +newtype Flow t m a = Flow { unFlow :: m (a, Event t (Flow t m a)) }++flowM :: (MonadSwitch t m) => Flow t m a -> m (Dynamic t a)+flowM (Flow w) = do+  rec +    result <- holdM w $ unFlow <$> switch (snd <$> current result)+  mapDyn fst result        +    +  +  +chainM :: (MonadSwitch t m) => Chain t m a b -> a -> m (Event t b)+chainM c a = switchPromptlyDyn <$> flowM (toFlow c a)+++loopM :: (MonadSwitch t m) => (a -> m (Event t a)) -> a -> m (Event t a)+loopM f a = do+  rec+    e <- switchPromptlyDyn <$> holdM (f a) (f <$> e)+    +  return e++++  +data Chain t m a b where+    Chain :: (a -> m (Event t b)) -> Chain t m a b+    (:>>) ::  (a -> m (Event t b)) -> Chain t m b c ->  Chain t m a c+  ++infixr 9 >->+infixr 8 :>>++  +(>->) :: Chain t m a b -> Chain t m b c -> Chain t m a c  +Chain f    >-> c  =  f :>> c +(f :>> c') >-> c  =  f :>> (c' >-> c) ++toFlow :: (MonadSwitch t m) => Chain t m a b -> a -> Flow t m (Event t b)+toFlow (Chain f) a = Flow $ do +  e <- f a +  return (e, end <$ e)+    where end = Flow $ return (never, never)+    +toFlow (f :>> c) a = Flow $ do+  e <- f a+  return (never, toFlow c <$> e)+  +
+ src/Reflex/Monad/Class.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Monad.Class+  ( MonadSwitch (..)  +  +  , MonadReflex+  +  , module Reflex+  +  , module Reflex.Switching  +  , module Reflex.Updated+  +  , module Control.Monad.Writer.Class+  +  +  ) where+  ++import Reflex+import Reflex.Updated+import Reflex.Switching++import Data.Maybe+import Data.Functor++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Writer++import Control.Monad.Writer.Class++import Prelude+++-- Constraint type to capture common usage together+type MonadReflex t m = (Reflex t, MonadHold t m, MonadFix m)    ++    +class (MonadReflex t m) => MonadSwitch t m | m -> t where+  +  -- | Map the result of an initial monadic action and updates and swap +  -- it out with a new one whenever the event provided fires.+  -- returns an 'Updated' giving the initial value plus updates+  -- +    switchM ::  Updated t (m a) -> m (Updated t a)+    switchM u = do +      m <- switchMapM (toMap (Just <$> u))+      return $ fromJust <$> fromMap m+    +        +  -- | Similar to holdM but operating on a collection of widgets+  -- provided as an 'UpdatedMap'.+  -- switchM/switchM' can be implemented in terms of switchMapM +  -- therefore switchMapM is a minimal implementation.+    switchMapM ::  Ord k => UpdatedMap t k (m a) -> m (UpdatedMap t k a)+    +    +  +instance MonadSwitch t m => MonadSwitch t (ReaderT e m) where++  switchM u = do+    env   <- ask+    lift $ switchM (flip runReaderT env <$> u)+    +  +  switchMapM um = do+    env   <- ask+    lift . switchMapM $ flip runReaderT env <$> um++    ++instance (MonadSwitch t m, SwitchMerge t w) => MonadSwitch t (WriterT w m) where++  switchM u = do+    (a, w) <- lift $ split <$> switchM (runWriterT <$> u)+    tell =<< switching' w+    return a+    ++  switchMapM um = do+    (a, w) <- lift $ split <$> switchMapM (runWriterT <$> um)+    tell =<< switchMerge' w+    return a+    +  ++ -- | A few conversions for switchM in terms of switchMapM+maybeToMap :: Maybe a -> Map () a+maybeToMap Nothing  = mempty+maybeToMap (Just a) = Map.singleton () a++mapToMaybe :: Map () a -> Maybe a+mapToMaybe m = listToMaybe $ Map.elems m + +toMap :: Reflex t =>  Updated t (Maybe a) -> UpdatedMap t () a+toMap (Updated initial e) = UpdatedMap (maybeToMap initial) (Map.singleton () <$> e)+ +fromMap :: Reflex t => UpdatedMap t () a -> Updated t (Maybe a)+fromMap (UpdatedMap initial e) = Updated (mapToMaybe initial) (fmapMaybe mapToMaybe e)  ++{-# ANN module "HLint: ignore Use import/export shortcut" #-}
+ src/Reflex/Monad/ReaderWriter.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Monad.ReaderWriter+  ( ReaderWriterT +  , ReaderWriter+  +  , runReaderWriterT+  , runReaderWriter+  +  , execReaderWriterT++  ) where+++import Reflex+import Reflex.Monad.Class ++import Data.Monoid++import Control.Applicative+import Control.Monad+import Control.Monad.Identity++import Control.Monad.Trans.RSS.Strict+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Trans.Class++import Prelude++    +newtype ReaderWriterT r w m a = ReaderWriterT (RSST r w () m a)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadFix, MonadReader r, MonadWriter w)+  +  +instance MonadSample t m => MonadSample t (ReaderWriterT r w m) where+  sample = lift . sample+  +instance MonadHold t m => MonadHold t (ReaderWriterT r w m) where+  hold i = lift . hold i++++type ReaderWriter r w a = ReaderWriterT r w Identity a++instance  MonadState s m => MonadState s (ReaderWriterT r w m)  where+  get = lift  get+  put = lift . put+  +  +  +runReaderWriterT :: (Monad m, Monoid w) => ReaderWriterT r w m a -> r -> m (a, w)+runReaderWriterT (ReaderWriterT m) r = do +  (a, _, w) <- runRSST m r ()+  return (a, w)++  +execReaderWriterT :: (Monad m, Monoid w) => ReaderWriterT r w m a -> r -> m w+execReaderWriterT m r = snd <$> runReaderWriterT m r+  +  +runReaderWriter :: (Monoid w) => ReaderWriter r w a -> r -> (a, w) +runReaderWriter rw r = runIdentity $ runReaderWriterT rw r +++instance (MonadSwitch t m, SwitchMerge t w) => MonadSwitch t (ReaderWriterT r w m) where++  switchM u = do+    env   <- ask+    (a, w) <- lift $ split <$> switchM (flip runReaderWriterT env <$> u)+    tell =<< switching' w+    return a+    +  +  switchMapM um = do+    env   <- ask+    (a, w) <- lift $ split <$> switchMapM (flip runReaderWriterT env <$> um)+    tell =<< switchMerge' w+    return a+    +++
+ src/Reflex/Monad/ReflexM.hs view
@@ -0,0 +1,52 @@++module Reflex.Monad.ReflexM where+++import Control.Applicative+import Control.Monad.Fix+import Reflex.Monad.Class++import Data.Traversable++import Prelude+++newtype ReflexM t a = ReflexM { runReflexM :: forall m. MonadReflex t m => m a }++ +instance Functor (ReflexM t) where+  fmap f (ReflexM a) = ReflexM (f <$> a)++  +instance Applicative (ReflexM t) where+  pure a = ReflexM (pure a)+  (<*>) (ReflexM f) (ReflexM a) = ReflexM (f <*> a) +  +instance Monad (ReflexM t) where+  return a = ReflexM (return a)+  (>>=) (ReflexM m) f = ReflexM (m >>= runReflexM . f) +++instance MonadFix (ReflexM t) where+  mfix f = ReflexM $ mfix (runReflexM . f)++instance MonadSample t (ReflexM t) where+  sample b = ReflexM (sample b)+    +instance MonadHold t (ReflexM t) where+  hold initial e = ReflexM (hold initial e)+  ++  +instance Reflex t => MonadSwitch t (ReflexM t) where+    +    switchM (Updated initial e) = do+      a <- runReflexM initial +      return $ Updated a $ pushAlways runReflexM e+              +    switchMapM (UpdatedMap initial e) = do+      a <- traverse runReflexM initial+      return $ UpdatedMap a $ +        pushAlways (traverse $ traverse runReflexM) e+      +
+ src/Reflex/Monad/Supply.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE UndecidableInstances #-}+++module Reflex.Monad.Supply+  ( SupplyT +  , Supply+  , runSupplyT+  , evalSupplyT++  , runSupply+  , evalSupply+  , runSplit+    +  , getFresh+  , getSplit+  +  +  +  ) where+++import Reflex+import Reflex.Monad.Class +++import Control.Monad+import Control.Monad.Identity+import Control.Monad.State.Strict+import Control.Monad.Reader.Class+import Control.Applicative++import Data.Functor+import Data.Traversable++import Data.Map.Strict (Map)++import Prelude+++class Splitable s i | s -> i where+  +  freshId :: s -> (i, s)+  splitSupply :: s -> (s, s)+  ++++instance Enum a => Splitable [a] [a] where+  freshId []     = ([], [toEnum 0])+  freshId (x:xs) = (x:xs, succ x:xs)+  +  splitSupply xs = (toEnum 0:xs, xs')+    where xs' = snd (freshId xs)++    +    +newtype SupplyT s m a = SupplyT (StateT s m a)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadFix)+  +  +deriving instance MonadReader st m => MonadReader st (SupplyT s m)+deriving instance MonadWriter w m => MonadWriter w (SupplyT s m)++deriving instance MonadSample t m => MonadSample t (SupplyT s m)+deriving instance MonadHold t m => MonadHold t (SupplyT s m)++type Supply s a = SupplyT s Identity a++  +instance MonadState st m => MonadState st (SupplyT s m)  where+  get = lift get+  put = lift . put+++getFresh :: (Monad m, Splitable s i) => SupplyT s m i+getFresh = SupplyT $ state freshId+++getSplit :: (Monad m, Splitable s i) => SupplyT s m s+getSplit = SupplyT $ state splitSupply++++runSplit ::  (Monad m, Splitable s i) =>  SupplyT s m a -> Supply s (m a)+runSplit m = evalSupplyT m <$> getSplit+  ++runSupplyT :: Monad m => SupplyT s m a -> s -> m (a, s)+runSupplyT (SupplyT m) = runStateT m ++evalSupplyT :: Monad m => SupplyT s m a -> s -> m a+evalSupplyT (SupplyT m) = evalStateT m +++runSupply :: Supply s a -> s -> (a, s)+runSupply m  = runIdentity . runSupplyT m ++evalSupply :: Supply s a -> s -> a+evalSupply m = runIdentity . evalSupplyT m+++  +-- | Helpers for switchMapM implementation+runSupplyMap :: (Ord k, Monad m, Splitable s i) =>  Map k (SupplyT s m a) -> s -> (Map k (m a), s) +runSupplyMap m =  runSupply (traverse runSplit m) +  +runSupplyMap' :: (Ord k, Monad m, Splitable s i) =>  Map k (Maybe (SupplyT s m a)) -> s -> (Map k (Maybe (m a)), s) +runSupplyMap' m =  runSupply (traverse (traverse runSplit) m) + +instance (MonadSwitch t m, Splitable s i) => MonadSwitch t (SupplyT s m) where++  switchM (Updated initial e) = do    +    s <- getSplit+    rec+      (a, us) <- lift (split <$> switchM (Updated (runSupplyT initial s) $+          attachWith (flip runSupplyT) r e))+      r <- hold' us+    return a+++  switchMapM (UpdatedMap initial e) = do   +    (initial', s) <- runSupplyMap initial <$> getSplit+    +    rec+      let (um, us) = split $ attachWith (flip runSupplyMap') r e+      a <- lift (switchMapM (UpdatedMap initial' um))+      r <- hold s us+      +    return a+    +
+ src/Reflex/Switching.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Switching where+++import Reflex.Class hiding (constant)+import Reflex.Updated++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Control.Monad+import Control.Monad.Fix+import Control.Applicative+import Data.Semigroup+import Data.Maybe+import Data.Foldable++import Prelude hiding (foldl1)+++class (Reflex t) => Switching t r  where+   -- | Generalization of switchable reactive types (e.g. Event, Behavior)+   switching :: MonadHold t m => r -> Event t r -> m r+   +class (Switching t r, Monoid r) => SwitchMerge t r  where   +   switchMerge :: (MonadFix m, MonadHold t m, Ord k) => Map k r -> Event t (Map k (Maybe r)) -> m r+++instance (Switching t a, Switching t b) => Switching t (a, b) where+  switching (a, b) e = liftA2 (,) (switching a $ fst <$> e) (switching b $ snd <$> e)+  +  +instance (SwitchMerge t a, SwitchMerge t b) => SwitchMerge t (a, b) where+  switchMerge initial e = liftA2 (,) (switchMerge' a) (switchMerge' b)+      where (a, b) = split $ UpdatedMap initial e++      ++  ++-- This will hopefully become a primitive (faster!)+switchMergeEvents ::  (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Event t a) -> m (Event t (Map k a))+switchMergeEvents mapChanges = switch . fmap mergeMap  <$> holdMap mapChanges +++instance (Semigroup a, Reflex t) => SwitchMerge t (Event t a) where+  switchMerge initial updates = fmap (foldl1 (<>)) <$> switchMergeEvents (UpdatedMap initial updates)+  +  +instance (Monoid a, Reflex t) => SwitchMerge t (Behavior t a) where+  switchMerge initial updates = pull <$> joinMap <$> holdMap (UpdatedMap initial updates)+    where joinMap m = sample =<< fold <$> sample m+  ++mayConcat :: Monoid a => [a] -> Maybe a+mayConcat [] = Nothing+mayConcat xs = Just $ mconcat xs++-- We can optimise [a] a little by eliminating any empty lists before merging+instance (SwitchMerge t a, Monoid a, Reflex t) => SwitchMerge t [a] where+  switchMerge initial updates = pure <$> switchMerge initial' updates'+    where +      initial' = Map.mapMaybe mayConcat initial+      updates' = fmap (join . fmap mayConcat) <$> updates++  +instance (Switching t a, Monoid a, Reflex t) => Switching t [a]  where+  switching bs updates = pure <$> switching (mconcat bs) (mconcat <$> updates)  +  +  +instance (Reflex t) => SwitchMerge t () where+  switchMerge _ _ = pure ()  +++instance (Monoid a, Reflex t) => Switching t (Behavior t a)  where+  switching = switcher+    +instance (Semigroup a, Reflex t) => Switching t (Event t a) where+  switching e updates = switch <$> hold e updates+    +instance (Reflex t) => Switching t () where+  switching _ _ = pure ()+  +switchMerge' :: (Reflex t, SwitchMerge t r, MonadFix m, MonadHold t m, Ord k) => UpdatedMap t k r -> m r +switchMerge' (UpdatedMap initial e) = switchMerge initial e  ++switching' :: (Reflex t, Switching t r, MonadFix m, MonadHold t m) => Updated t r -> m r +switching' (Updated initial e) = switching initial e  +++
+ src/Reflex/Updated.hs view
@@ -0,0 +1,77 @@+module Reflex.Updated +  ( UpdatedMap (..)+  , Updated (..)+  , split+  , holdDyn', hold'+  , holdMapDyn, holdMap+  +  , shallowDiff+  , shallowDiff'+  +  +  ) where++import Reflex++import Data.Monoid+import Data.Maybe+import Data.Functor++import Control.Lens+import Control.Monad.Fix++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Prelude+ ++data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))   ++data Updated t a = Updated a (Event t a)+++instance Reflex t => Functor (UpdatedMap t k) where+  fmap f (UpdatedMap initial changes) = UpdatedMap (f <$> initial) (fmap (fmap f) <$> changes)+  +  +instance Reflex t => Functor (Updated t) where+  fmap f (Updated initial changes) = Updated (f initial) (f <$> changes)  +  +  +instance Reflex t => FunctorWithIndex k (UpdatedMap t k) where+  imap f (UpdatedMap initial changes) = UpdatedMap (imap f initial) (imap (fmap . f) <$> changes)+++split :: Functor f => f (a, b) -> (f a, f b)+split f = (fst <$> f, snd <$> f)+++holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (ifoldr modify)) initial changes+  +  where +    modify k Nothing items = Map.delete k items+    modify k (Just item) items = Map.insert k item items+    +    +holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))+holdMap = (current <$>) . holdMapDyn ++    +holdDyn' :: (Reflex t, MonadHold t m, MonadFix m) => Updated t a -> m (Dynamic t a)    +holdDyn' (Updated initial changes) = holdDyn initial changes++hold' :: (Reflex t, MonadHold t m, MonadFix m) => Updated t a -> m (Behavior t a)    +hold' (Updated initial changes) = hold initial changes+        +        +shallowDiff' :: (Ord k) => Map k a -> Map k b -> Map k (Maybe b)+shallowDiff' m m' = (Just <$> m' Map.\\ m)  <> (const Nothing <$>  m Map.\\ m')  +          +     +shallowDiff :: (Reflex t, Ord k) => Behavior t (Map k a) -> Event t (Map k b) -> Event t (Map k (Maybe b))+shallowDiff currentItems updatedItems = ffilter (not . Map.null) $ +  attachWith shallowDiff' currentItems updatedItems+       +