b55c607 · reflex · git.iko.soy

git.iko.soy/reflex

Add factorEvent; fix hlint

commitb55c6079a9c5029ae84afa40ff3415d95411be9c authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 27 Jul 2018, 21:01 (8 years ago) parentb95bf51

2 files changed+45−21

compare with develop

unifiedsplit

src/Reflex/Class.hs+36−2 src/Reflex/Dynamic.hs+9−19

src/Reflex/Class.hs+36−2

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

99{-# LANGUAGE LambdaCase #-}

1010{-# LANGUAGE MultiParamTypeClasses #-}

1111{-# LANGUAGE NoMonomorphismRestriction #-}

12+{-# LANGUAGE PolyKinds #-}

1213{-# LANGUAGE RankNTypes #-}

1314{-# LANGUAGE RecursiveDo #-}

1415{-# LANGUAGE RoleAnnotations #-}

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

5960 , EitherTag (..)

6061 , eitherToDSum

6162 , dsumToEither

63+ , factorEvent

6264 -- ** Collapsing 'Event . Event'

6365 , switchHold

6466 , switchHoldPromptly

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

157159import Data.Bifunctor

158160import Data.Coerce

159161import Data.Default

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

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

161163import qualified Data.Dependent.Map as DMap

164+import Data.Functor.Compose

165+import Data.Functor.Product

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

162167import Data.FastMutableIntMap (PatchIntMap)

163168import Data.Foldable

164169import Data.Functor.Bind

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

169174import Data.List.NonEmpty (NonEmpty (..))

170175import Data.Map (Map)

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

177+import Data.Some (Some)

178+import qualified Data.Some as Some

172179import Data.String

173180import Data.These

174181import Data.Type.Coercion

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

592599 => (a -> Bool)

593600 -> Event t a

594601 -> m (Event t a)

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

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

596603

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

598605-- event returns 'Just b'.

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

897904 $ merge

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

899906

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)

900934

901935--------------------------------------------------------------------------------

902936-- Accumulator

src/Reflex/Dynamic.hs+9−19

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

102102import Data.Dependent.Map (DMap)

103103import qualified Data.Dependent.Map as DMap

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

105+import Data.Functor.Product

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

106107import Data.Map (Map)

107108import Data.Maybe

108−import Data.Monoid

109+import Data.Monoid hiding (Product)

109110import Data.These

110111

111112import Debug.Trace

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

326327

327328factorDyn :: 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)))

328329factorDyn 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

346− holdDyn o0 update

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'

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

347337

348338--------------------------------------------------------------------------------

349339-- Demux