b55c607 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Add factorEvent; fix hlint

b55c607Ryan Trinkle8 years ago

src/Reflex/Class.hs+36−2

compare with develop

unifiedsplit

@@ -9,6 +9,7 @@

9{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE NoMonomorphismRestriction #-}

12+{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RoleAnnotations #-}

15{-# LANGUAGE RoleAnnotations #-}

@@ -59,6 +60,7 @@ module Reflex.Class

59 , EitherTag (..)

60 , EitherTag (..)

60 , eitherToDSum

61 , eitherToDSum

61 , dsumToEither

62 , dsumToEither

63+ , factorEvent

62 -- ** Collapsing 'Event . Event'

64 -- ** Collapsing 'Event . Event'

63 , switchHold

65 , switchHold

64 , switchHoldPromptly

66 , switchHoldPromptly

@@ -157,8 +159,11 @@ import Data.Align

157import Data.Bifunctor

159import Data.Bifunctor

158import Data.Coerce

160import Data.Coerce

159import Data.Default

161import Data.Default

160−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

162+import Data.Dependent.Map (DMap, DSum (..))

161import qualified Data.Dependent.Map as DMap

163import qualified Data.Dependent.Map as DMap

164+import Data.Functor.Compose

165+import Data.Functor.Product

166+import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))

162import Data.FastMutableIntMap (PatchIntMap)

167import Data.FastMutableIntMap (PatchIntMap)

163import Data.Foldable

168import Data.Foldable

164import Data.Functor.Bind

169import Data.Functor.Bind

@@ -169,6 +174,8 @@ import qualified Data.IntMap.Strict as IntMap

169import Data.List.NonEmpty (NonEmpty (..))

174import Data.List.NonEmpty (NonEmpty (..))

170import Data.Map (Map)

175import Data.Map (Map)

171import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

176import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

177+import Data.Some (Some)

178+import qualified Data.Some as Some

172import Data.String

179import Data.String

173import Data.These

180import Data.These

174import Data.Type.Coercion

181import Data.Type.Coercion

@@ -592,7 +599,7 @@ takeWhileE

592 => (a -> Bool)

599 => (a -> Bool)

593 -> Event t a

600 -> Event t a

594 -> m (Event t a)

601 -> m (Event t a)

595−takeWhileE f e = takeWhileJustE (\v -> guard (f v) $> v) e

602+takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v

596

603

597-- | Take the streak of occurrences starting at the current time for which the

604-- | Take the streak of occurrences starting at the current time for which the

598-- event returns 'Just b'.

605-- event returns 'Just b'.

@@ -897,6 +904,33 @@ alignEventWithMaybe f ea eb =

897 $ merge

904 $ merge

898 $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

905 $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

899

906

907+factorEvent

908+ :: forall t m k v a.

909+ ( Reflex t

910+ , MonadFix m

911+ , MonadHold t m

912+ , GEq k

913+ )

914+ => k a

915+ -> Event t (DSum k v)

916+ -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))

917+factorEvent k0 kv' = do

918+ key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'

919+ let inner :: forall m' b. (MonadFix m', MonadHold t m') => k b -> m' (Event t (v b))

920+ inner k = do

921+ let f :: DSum k v -> Maybe (v b)

922+ f (newK :=> newV) = case newK `geq` k of

923+ Just Refl -> Just newV

924+ Nothing -> Nothing

925+ takeWhileJustE f kv'

926+ update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

927+ Some.This oldKey -> case newKey `geq` oldKey of

928+ Just Refl -> return Nothing

929+ Nothing -> do

930+ newInner <- inner newKey

931+ return $ Just $ newKey :=> Pair newVal (Compose newInner)

932+ eInitial <- inner k0

933+ return (eInitial, update)

900

934

901--------------------------------------------------------------------------------

935--------------------------------------------------------------------------------

902-- Accumulator

936-- Accumulator

src/Reflex/Dynamic.hs+9−19

@@ -102,10 +102,11 @@ import Data.Align

102import Data.Dependent.Map (DMap)

103import qualified Data.Dependent.Map as DMap

104import Data.Dependent.Sum (DSum (..))

105+import Data.Functor.Product

105import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

106import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

106import Data.Map (Map)

107import Data.Map (Map)

107import Data.Maybe

108import Data.Maybe

108−import Data.Monoid

109+import Data.Monoid hiding (Product)

109import Data.These

110import Data.These

110

111

111import Debug.Trace

112import Debug.Trace

@@ -326,24 +327,13 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

326

327

327factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

328factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

328factorDyn d = do

329factorDyn d = do

329− let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a))

330− inner k v0 = (=<<) (holdDyn v0) $ flip takeWhileJustE (updated d) $

331− \(newK :=> newV) -> case newK `geq` k of

332− Just Refl -> Just newV

333− Nothing -> Nothing

334− getInitial = do

335− k0 :=> (v0 :: v a) <- sample $ current d

336− i0 <- inner k0 v0

337− return $ k0 :=> Compose i0

338− update = flip push (updated d) $ \(newKey :=> newVal) -> do

339− (oldKey :=> _) <- sample $ current d

340− case newKey `geq` oldKey of

341− Just Refl -> return Nothing

342− Nothing -> do

343− newInner <- inner newKey newVal

344− return $ Just $ newKey :=> Compose newInner

345− o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic

330+ k0 :=> v0 <- sample $ current d --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic

331+ (initialEvent, update) <- factorEvent k0 $ updated d

332+ initialD <- holdDyn v0 initialEvent

333+ let f (k :=> Pair v (Compose v')) = do

334+ d' <- holdDyn v v'

335+ pure $ k :=> Compose d'

346− holdDyn o0 update

336+ holdDyn (k0 :=> Compose initialD) $ pushAlwaysCheap f update

347

337

348--------------------------------------------------------------------------------

338--------------------------------------------------------------------------------

349-- Demux

339-- Demux