module Reflex.Switching
( Switching (..)
, SwitchMerge (..)
, switching'
, switchMerge'
) 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
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
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
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