4e930a4 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Fix hlint warnings

4e930a4Ryan Trinkle10 years ago

bench/Main.hs+1−1

compare with develop

unifiedsplit

@@ -96,7 +96,7 @@ setupMerge :: Int

96 )

97setupMerge num = do

98 (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef

99− let !m = DMap.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs]

99+ let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]

100 pure (merge m, triggers)

101

102subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)

bench/RunAll.hs+2−2

@@ -81,7 +81,7 @@ instance NFData (Behavior t a) where

81 rnf !_ = ()

83instance NFData (Firing t) where

84− rnf !(Firing _ _) = ()

84+ rnf !_ = ()

86-- Measure the running time

87benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO ()

@@ -107,7 +107,7 @@ waitForFinalizers = do

107 performGC

108 fix $ \loop -> do

109 f <- readIORef isFinalized

110− if f then return () else do

110+ unless f $ do

111 threadDelay 1

112 loop

113

reflex.cabal+8−2

@@ -82,7 +82,7 @@ benchmark spider-bench

82 dependent-sum,

83 dependent-map,

84 transformers >= 0.3,

85− stm == 2.4.*,

85+ stm,

86 deepseq >= 1.3 && < 1.5,

87 mtl,

88 primitive,

@@ -104,7 +104,7 @@ benchmark saulzar-bench

104 dependent-sum,

105 dependent-map,

106 transformers >= 0.3,

107− stm == 2.4.*,

107+ stm,

108 deepseq >= 1.3 && < 1.5,

109 mtl,

110 primitive,

@@ -115,6 +115,12 @@ benchmark saulzar-bench

115 loch-th,

116 process

117

118+test-suite hlint

119+ build-depends: base, hlint == 1.9.*

120+ hs-source-dirs: test

121+ main-is: hlint.hs

122+ type: exitcode-stdio-1.0

123+

118source-repository head

124source-repository head

119 type: git

125 type: git

120 location: https://github.com/reflex-frp/reflex

126 location: https://github.com/reflex-frp/reflex

src/Data/Functor/Misc.hs+1−1

@@ -25,7 +25,7 @@ data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

25 WrapArg :: f a -> WrapArg g f (g a)

27instance GEq f => GEq (WrapArg g f) where

28− geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b

28+ geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b

30instance GCompare f => GCompare (WrapArg g f) where

31 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of

src/Data/WeakBag.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE BangPatterns #-}

2module Data.WeakBag (WeakBag, WeakBagTicket, empty, singleton, insert, Data.WeakBag.traverse, remove) where

1module Data.WeakBag (WeakBag, WeakBagTicket, empty, singleton, insert, Data.WeakBag.traverse, remove) where

4import Control.Concurrent.STM

3import Control.Concurrent.STM

src/Reflex.hs+6−11

@@ -1,12 +1,7 @@

1−module Reflex ( module Reflex.Class

1+module Reflex (module X) where

2− , module Reflex.Dynamic

3− , module Reflex.Dynamic.Nub

4− , module Reflex.Dynamic.TH

5− , module Reflex.Spider

6− ) where

8−import Reflex.Class

3+import Reflex.Class as X

9−import Reflex.Dynamic

4+import Reflex.Dynamic as X

10−import Reflex.Dynamic.Nub

5+import Reflex.Dynamic.Nub as X

11−import Reflex.Dynamic.TH

6+import Reflex.Dynamic.TH as X

12−import Reflex.Spider

7+import Reflex.Spider as X

src/Reflex/Class.hs+10−16

@@ -1,20 +1,14 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE EmptyDataDecls #-}

4{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE FunctionalDependencies #-}

7{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE NoMonomorphismRestriction #-}

8{-# LANGUAGE NoMonomorphismRestriction #-}

12−{-# LANGUAGE PackageImports #-}

13{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE RecursiveDo #-}

15{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

16−{-# LANGUAGE StandaloneDeriving #-}

17−{-# LANGUAGE TemplateHaskell #-}

18{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

19{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

20{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

@@ -128,7 +122,7 @@ instance GCompare k => Monoid (PatchDMap (DMap k v)) where

128

122

129instance Patch PatchDMap where

123instance Patch PatchDMap where

130 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

124 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

131− where insertions = DMap.mapMaybeWithKey (const $ id . getCompose) diff

125+ where insertions = DMap.mapMaybeWithKey (const $ getCompose) diff

132 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff

126 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff

133 nothingToJust = \case

127 nothingToJust = \case

134 Nothing -> Just $ Constant ()

128 Nothing -> Just $ Constant ()

@@ -215,14 +209,14 @@ instance MonadHold t m => MonadHold t (ContT r m) where

215-- | Create an Event from another Event.

209-- | Create an Event from another Event.

216-- The provided function can sample 'Behavior's and hold 'Event's.

210-- The provided function can sample 'Behavior's and hold 'Event's.

217pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

211pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

218−pushAlways f = push (liftM Just . f)

212+pushAlways f = push (fmap Just . f)

219

213

220-- | Flipped version of 'fmap'.

214-- | Flipped version of 'fmap'.

221ffor :: Functor f => f a -> (a -> b) -> f b

215ffor :: Functor f => f a -> (a -> b) -> f b

222ffor = flip fmap

216ffor = flip fmap

223

217

224instance Reflex t => Functor (Behavior t) where

218instance Reflex t => Functor (Behavior t) where

225− fmap f = pull . liftM f . sample

219+ fmap f = pull . fmap f . sample

226

220

227instance Reflex t => Applicative (Behavior t) where

221instance Reflex t => Applicative (Behavior t) where

228 pure = constant

222 pure = constant

@@ -238,7 +232,7 @@ instance Reflex t => Monad (Behavior t) where

238

232

239instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

233instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

240 a <> b = pull $ liftM2 (<>) (sample a) (sample b)

234 a <> b = pull $ liftM2 (<>) (sample a) (sample b)

241− sconcat = pull . liftM sconcat . mapM sample

235+ sconcat = pull . fmap sconcat . mapM sample

242#if MIN_VERSION_semigroups(0,17,0)

236#if MIN_VERSION_semigroups(0,17,0)

243 stimes n = fmap $ stimes n

237 stimes n = fmap $ stimes n

244#else

238#else

@@ -248,7 +242,7 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

248instance (Reflex t, Monoid a) => Monoid (Behavior t a) where

242instance (Reflex t, Monoid a) => Monoid (Behavior t a) where

249 mempty = constant mempty

243 mempty = constant mempty

250 mappend a b = pull $ liftM2 mappend (sample a) (sample b)

244 mappend a b = pull $ liftM2 mappend (sample a) (sample b)

251− mconcat = pull . liftM mconcat . mapM sample

245+ mconcat = pull . fmap mconcat . mapM sample

252

246

253--TODO: See if there's a better class in the standard libraries already

247--TODO: See if there's a better class in the standard libraries already

254-- | A class for values that combines filtering and mapping using 'Maybe'.

248-- | A class for values that combines filtering and mapping using 'Maybe'.

@@ -293,7 +287,7 @@ attachWith f = attachWithMaybe $ \a b -> Just $ f a b

293-- value of the 'Behavior'. The occurrence is discarded if the combining function

287-- value of the 'Behavior'. The occurrence is discarded if the combining function

294-- returns Nothing

288-- returns Nothing

295attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

289attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

296−attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b

290+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b

297

291

298-- | Alias for 'headE'

292-- | Alias for 'headE'

299onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

293onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

@@ -311,7 +305,7 @@ headE e = do

311-- | Create a new 'Event' that occurs on all but the first occurence

305-- | Create a new 'Event' that occurs on all but the first occurence

312-- of the supplied 'Event'.

306-- of the supplied 'Event'.

313tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

307tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

314−tailE e = liftM snd $ headTailE e

308+tailE e = snd <$> headTailE e

315

309

316-- | Create a tuple of two 'Event's with the first one occuring only

310-- | Create a tuple of two 'Event's with the first one occuring only

317-- the first time the supplied 'Event' occurs and the second occuring

311-- the first time the supplied 'Event' occurs and the second occuring

@@ -400,9 +394,9 @@ appendEvents e1 e2 = mergeThese mappend <$> align e1 e2

400{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

394{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

401sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

395sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

402sequenceThese t = case t of

396sequenceThese t = case t of

403− This ma -> liftM This ma

397+ This ma -> fmap This ma

404 These ma mb -> liftM2 These ma mb

398 These ma mb -> liftM2 These ma mb

405− That mb -> liftM That mb

399+ That mb -> fmap That mb

406

400

407instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

401instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

408 (<>) = alignWith (mergeThese (<>))

402 (<>) = alignWith (mergeThese (<>))

@@ -425,7 +419,7 @@ mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

425mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

419mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

426 . merge

420 . merge

427 . DMap.fromDistinctAscList

421 . DMap.fromDistinctAscList

428− . map (\(k, v) -> (Const2 k) :=> v)

422+ . map (\(k, v) -> Const2 k :=> v)

429 $ zip [0 :: Int ..] es

423 $ zip [0 :: Int ..] es

430

424

431-- | Create a new 'Event' that occurs if at least one of the 'Event's

425-- | Create a new 'Event' that occurs if at least one of the 'Event's

src/Reflex/Dynamic.hs+2−10

@@ -1,22 +1,14 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveDataTypeable #-}

4−{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE NoMonomorphismRestriction #-}

8{-# LANGUAGE NoMonomorphismRestriction #-}

13−{-# LANGUAGE PackageImports #-}

14{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

16−{-# LANGUAGE RecursiveDo #-}

17{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE StandaloneDeriving #-}

19−{-# LANGUAGE TemplateHaskell #-}

20{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

21{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

22{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

@@ -105,7 +97,7 @@ class HBuild' l r where

105

106instance (l' ~ HRevApp l '[])

98instance (l' ~ HRevApp l '[])

107 => HBuild' l (HList l') where

99 => HBuild' l (HList l') where

108− hBuild' l = hReverse l

100+ hBuild' = hReverse

109

101

110instance HBuild' (a ': l) r

102instance HBuild' (a ': l) r

111 => HBuild' l (a->r) where

103 => HBuild' l (a->r) where

@@ -360,7 +352,7 @@ fhlistToDMap = DMap.fromList . go

360 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

352 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

361 go = \case

353 go = \case

362 FHNil -> []

354 FHNil -> []

363− FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t)

355+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)

364

356

365class RebuildSortedHList l where

357class RebuildSortedHList l where

366 rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l

358 rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l

src/Reflex/Host/Class.hs+2−5

@@ -1,13 +1,10 @@

1−{-# LANGUAGE EmptyDataDecls #-}

2{-# LANGUAGE ExistentialQuantification #-}

1{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE RoleAnnotations #-}

8{-# LANGUAGE RoleAnnotations #-}

12{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

@@ -98,7 +95,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona

98 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

95 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

99 -- and then fires the corresponding events using this function. The read callback can be used

96 -- and then fires the corresponding events using this function. The read callback can be used

100 -- to read output events and perform a corresponding response action to the external event.

97 -- to read output events and perform a corresponding response action to the external event.

101− fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a

98+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a

102

103 -- | Run a frame without any events firing.

100 -- | Run a frame without any events firing.

104 --

101 --

@@ -145,7 +142,7 @@ fireEventRefAndRead mtRef input e = do

145 mGetValue <- readEvent e

142 mGetValue <- readEvent e

146 case mGetValue of

143 case mGetValue of

147 Nothing -> return Nothing

144 Nothing -> return Nothing

148− Just getValue -> liftM Just getValue

145+ Just getValue -> fmap Just getValue

149

146

150

147

151--------------------------------------------------------------------------------

148--------------------------------------------------------------------------------

src/Reflex/Spider/Internal.hs+63−69

@@ -13,12 +13,10 @@

13{-# LANGUAGE MultiParamTypeClasses #-}

14{-# LANGUAGE MultiWayIf #-}

15{-# LANGUAGE RankNTypes #-}

16−{-# LANGUAGE RecursiveDo #-}

17{-# LANGUAGE RoleAnnotations #-}

16{-# LANGUAGE RoleAnnotations #-}

18{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

19{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

20{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE TypeOperators #-}

21−{-# LANGUAGE UnboxedTuples #-}

22{-# LANGUAGE UndecidableInstances #-}

20{-# LANGUAGE UndecidableInstances #-}

23module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where

21module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where

@@ -322,7 +320,7 @@ getHoldEventSubscription h = do

322 v <- liftIO $ evaluate $ holdValue h

320 v <- liftIO $ evaluate $ holdValue h

323 i <- liftIO $ evaluate $ holdInvalidators h

321 i <- liftIO $ evaluate $ holdInvalidators h

324 defer $ SomeAssignment v i new

322 defer $ SomeAssignment v i new

325− liftIO $ writeIORef (holdParent h) $! Right subscription

323+ liftIO $ writeIORef (holdParent h) $ Right subscription

326 return subscription

324 return subscription

327

325

328type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])

326type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])

@@ -534,6 +532,7 @@ data Switch a

534 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))

532 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))

535 }

533 }

536

534

535+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}

537data CoincidenceSubscribed a

536data CoincidenceSubscribed a

538 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))

537 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))

539 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))

538 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))

@@ -706,10 +705,10 @@ updated = \case

706 DynamicDynIdentity d -> EventDynIdentity d

705 DynamicDynIdentity d -> EventDynIdentity d

707

706

708newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b

707newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b

709−newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (fmap (Identity . f . runIdentity) $ updated d)

708+newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (Identity . f . runIdentity <$> updated d)

710

709

711instance Functor (Dynamic Identity) where

710instance Functor (Dynamic Identity) where

712− fmap f d = newMapDyn f d

711+ fmap = newMapDyn

713

712

714instance Applicative (Dynamic Identity) where

713instance Applicative (Dynamic Identity) where

715 pure = DynamicConst

714 pure = DynamicConst

@@ -760,8 +759,8 @@ newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a

760newJoinDyn d =

759newJoinDyn d =

761 let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)

760 let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)

762 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d

761 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d

763− eInner = switch $ fmap updated $ current d

762+ eInner = switch $ updated <$> current d

764− eBoth = coincidence $ fmap (updated . runIdentity) $ updated d

763+ eBoth = coincidence $ updated . runIdentity <$> updated d

765 v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

764 v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

766 in unsafeDyn readV0 v'

765 in unsafeDyn readV0 v'

767

766

@@ -785,7 +784,7 @@ instance Functor Event where

785 fmap f = push $ return . Just . f

784 fmap f = push $ return . Just . f

786

785

787instance Functor Behavior where

786instance Functor Behavior where

788− fmap f = pull . liftM f . readBehaviorTracked

787+ fmap f = pull . fmap f . readBehaviorTracked

789

788

790{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly

789{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly

791push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b

790push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b

@@ -859,7 +858,7 @@ run roots after = do

859 m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed

858 m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed

860 liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! DMap.empty

859 liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! DMap.empty

861 --TODO: Assert that m is not empty

860 --TODO: Assert that m is not empty

862− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $! Just m

861+ liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m

863 scheduleClear $ mergeSubscribedOccurrence subscribed

862 scheduleClear $ mergeSubscribedOccurrence subscribed

864 propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m

863 propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m

865 go

864 go

@@ -1022,7 +1021,7 @@ propagate a subscribers = withIncreasedDepth $ do

1022 SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a

1021 SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a

1023 SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do

1022 SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do

1024 tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed

1023 tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed

1025− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $! Just a

1024+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

1026 scheduleClear $ switchSubscribedOccurrence subscribed

1025 scheduleClear $ switchSubscribedOccurrence subscribed

1027 propagate a $ switchSubscribedSubscribers subscribed

1026 propagate a $ switchSubscribedSubscribers subscribed

1028 SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do

1027 SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do

@@ -1032,7 +1031,7 @@ propagate a subscribers = withIncreasedDepth $ do

1032 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

1031 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

1033 tracePropagate $ " isJust occ = " <> show (isJust occ)

1032 tracePropagate $ " isJust occ = " <> show (isJust occ)

1034 tracePropagate $ " innerHeight = " <> show innerHeight

1033 tracePropagate $ " innerHeight = " <> show innerHeight

1035− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $! Just innerSubd

1034+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

1036 scheduleClear $ coincidenceSubscribedInnerParent subscribed

1035 scheduleClear $ coincidenceSubscribedInnerParent subscribed

1037 case occ of

1036 case occ of

1038 Nothing -> do

1037 Nothing -> do

@@ -1050,7 +1049,7 @@ propagate a subscribers = withIncreasedDepth $ do

1050 case occ of

1049 case occ of

1051 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

1050 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

1052 Nothing -> do

1051 Nothing -> do

1053− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $! Just a

1052+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

1054 scheduleClear $ coincidenceSubscribedOccurrence subscribed

1053 scheduleClear $ coincidenceSubscribedOccurrence subscribed

1055 propagate a $ coincidenceSubscribedSubscribers subscribed

1054 propagate a $ coincidenceSubscribedSubscribers subscribed

1056 SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"

1055 SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"

@@ -1094,13 +1093,13 @@ runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubsc

1094runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1093runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1095

1094

1096askInvalidator :: BehaviorM (Maybe (Weak Invalidator))

1095askInvalidator :: BehaviorM (Maybe (Weak Invalidator))

1097−askInvalidator = liftM (fmap fst . fst) $ BehaviorM ask

1096+askInvalidator = fmap fst . fst <$> BehaviorM ask

1098

1097

1099askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))

1098askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))

1100−askParentsRef = liftM (fmap snd . fst) $ BehaviorM ask

1099+askParentsRef = fmap snd . fst <$> BehaviorM ask

1101

1100

1102askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])

1101askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])

1103−askBehaviorHoldInits = liftM snd $ BehaviorM ask

1102+askBehaviorHoldInits = snd <$> BehaviorM ask

1104

1103

1105readBehaviorTracked :: Behavior a -> BehaviorM a

1104readBehaviorTracked :: Behavior a -> BehaviorM a

1106readBehaviorTracked b = case b of

1105readBehaviorTracked b = case b of

@@ -1129,7 +1128,7 @@ readBehaviorTracked b = case b of

1129 , pullSubscribedOwnInvalidator = i

1128 , pullSubscribedOwnInvalidator = i

1130 , pullSubscribedParents = parents

1129 , pullSubscribedParents = parents

1131 }

1130 }

1132− liftIO $ writeIORef (pullValue p) $! Just subscribed

1131+ liftIO $ writeIORef (pullValue p) $ Just subscribed

1133 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

1132 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

1134 return a

1133 return a

1135 BehaviorDyn d -> readHoldTracked =<< getDynHold d

1134 BehaviorDyn d -> readHoldTracked =<< getDynHold d

@@ -1153,13 +1152,13 @@ getDynHold d = do

1153 holdInits <- getDeferralQueue

1152 holdInits <- getDeferralQueue

1154 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1153 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1155 h <- hold v0 v'

1154 h <- hold v0 v'

1156− liftIO $ writeIORef (unDyn d) $! Right h

1155+ liftIO $ writeIORef (unDyn d) $ Right h

1157 return h

1156 return h

1158

1157

1159{-

1158{-

1160readEvent :: Event a -> ResultM (Maybe a)

1159readEvent :: Event a -> ResultM (Maybe a)

1161readEvent e = case e of

1160readEvent e = case e of

1162− EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r

1161+ EventRoot k r -> liftIO . fmap (coerce . DMap.lookup k) . readIORef $ rootOccurrence r

1163 EventNever -> return Nothing

1162 EventNever -> return Nothing

1164 EventPush p -> do

1163 EventPush p -> do

1165 subscribed <- getPushSubscribed p

1164 subscribed <- getPushSubscribed p

@@ -1266,25 +1265,25 @@ subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (Subs

1266subscribeEventSubscribed es sub = case es of

1265subscribeEventSubscribed es sub = case es of

1267 EventSubscribedRoot r -> do

1266 EventSubscribedRoot r -> do

1268 traceSubscribe $ "subscribeEventSubscribed Root"

1267 traceSubscribe $ "subscribeEventSubscribed Root"

1269− fmap Just $ subscribeRootSubscribed r sub

1268+ Just <$> subscribeRootSubscribed r sub

1270 EventSubscribedNever -> do

1269 EventSubscribedNever -> do

1271 traceSubscribe $ "subscribeEventSubscribed Never"

1270 traceSubscribe $ "subscribeEventSubscribed Never"

1272 return Nothing

1271 return Nothing

1273 EventSubscribedPush subscribed -> do

1272 EventSubscribedPush subscribed -> do

1274 traceSubscribe $ "subscribeEventSubscribed Push"

1273 traceSubscribe $ "subscribeEventSubscribed Push"

1275− fmap Just $ subscribePushSubscribed subscribed sub

1274+ Just <$> subscribePushSubscribed subscribed sub

1276 EventSubscribedFan k subscribed -> do

1275 EventSubscribedFan k subscribed -> do

1277 traceSubscribe $ "subscribeEventSubscribed Fan"

1276 traceSubscribe $ "subscribeEventSubscribed Fan"

1278− fmap Just $ subscribeFanSubscribed k subscribed sub

1277+ Just <$> subscribeFanSubscribed k subscribed sub

1279 EventSubscribedMerge subscribed -> do

1278 EventSubscribedMerge subscribed -> do

1280 traceSubscribe $ "subscribeEventSubscribed Merge"

1279 traceSubscribe $ "subscribeEventSubscribed Merge"

1281− fmap Just $ subscribeMergeSubscribed subscribed sub

1280+ Just <$> subscribeMergeSubscribed subscribed sub

1282 EventSubscribedSwitch subscribed -> do

1281 EventSubscribedSwitch subscribed -> do

1283 traceSubscribe $ "subscribeEventSubscribed Switch"

1282 traceSubscribe $ "subscribeEventSubscribed Switch"

1284− fmap Just $ subscribeSwitchSubscribed subscribed sub

1283+ Just <$> subscribeSwitchSubscribed subscribed sub

1285 EventSubscribedCoincidence subscribed -> do

1284 EventSubscribedCoincidence subscribed -> do

1286 traceSubscribe $ "subscribeEventSubscribed Coincidence"

1285 traceSubscribe $ "subscribeEventSubscribed Coincidence"

1287− fmap Just $ subscribeCoincidenceSubscribed subscribed sub

1286+ Just <$> subscribeCoincidenceSubscribed subscribed sub

1288

1287

1289{-# INLINE eventSubscribedHeightRef #-}

1288{-# INLINE eventSubscribedHeightRef #-}

1290eventSubscribedHeightRef :: EventSubscribed a -> IORef Height

1289eventSubscribedHeightRef :: EventSubscribed a -> IORef Height

@@ -1317,7 +1316,7 @@ eventSubscribedGetParents = \case

1317 EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

1316 EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

1318 EventSubscribedMerge subscribed -> do

1317 EventSubscribedMerge subscribed -> do

1319 ps <- readIORef $ mergeSubscribedParents subscribed

1318 ps <- readIORef $ mergeSubscribedParents subscribed

1320− return $ fmap (\(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v) $ DMap.toList ps

1319+ return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v

1321 EventSubscribedSwitch subscribed -> do

1320 EventSubscribedSwitch subscribed -> do

1322 s <- readIORef $ switchSubscribedCurrentParent subscribed

1321 s <- readIORef $ switchSubscribedCurrentParent subscribed

1323 return [Some.This $ _eventSubscription_subscribed s]

1322 return [Some.This $ _eventSubscription_subscribed s]

@@ -1354,7 +1353,7 @@ getRootSubscribed k r sub = do

1354 let subscribed = RootSubscribed

1353 let subscribed = RootSubscribed

1355 { rootSubscribedKey = k

1354 { rootSubscribedKey = k

1356 , rootSubscribedCachedSubscribed = cached

1355 , rootSubscribedCachedSubscribed = cached

1357− , rootSubscribedOccurrence = liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1356+ , rootSubscribedOccurrence = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1358 , rootSubscribedSubscribers = subs

1357 , rootSubscribedSubscribers = subs

1359 , rootSubscribedUninit = uninit

1358 , rootSubscribedUninit = uninit

1360 , rootSubscribedWeakSelf = weakSelf

1359 , rootSubscribedWeakSelf = weakSelf

@@ -1366,6 +1365,7 @@ getRootSubscribed k r sub = do

1366 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it

1365 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it

1367 return (sln, subscribed)

1366 return (sln, subscribed)

1368

1367

1368+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}

1369cleanupRootSubscribed :: RootSubscribed a -> IO ()

1370cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do

1371 rootSubscribedUninit self

@@ -1390,7 +1390,7 @@ getPushSubscribed p sub = do

1390 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe

1391 subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s

1392 parentOcc <- liftIO $ readEventSubscribed subd

1393− occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc

1393+ occ <- runComputeM $ join <$> mapM (pushCompute p) parentOcc

1394 occRef <- liftIO $ newIORef occ

1395 when (isJust occ) $ scheduleClear occRef

1396 weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"

@@ -1410,13 +1410,13 @@ getPushSubscribed p sub = do

1410 }

1411 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

1412 liftIO $ writeIORef subscribedRef $! subscribed

1413− liftIO $ writeIORef (pushSubscribed p) $! Just subscribed

1413+ liftIO $ writeIORef (pushSubscribed p) $ Just subscribed

1414 return (sln, subscribed)

1415

1416cleanupPushSubscribed :: PushSubscribed a b -> IO ()

1417cleanupPushSubscribed self = do

1418 unsubscribe $ pushSubscribedParent self

1419− writeIORef (pushSubscribedCachedSubscribed self) $! Nothing

1419+ writeIORef (pushSubscribedCachedSubscribed self) $ Nothing

1420

1421{-# INLINE subscribePushSubscribed #-}

1422subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)

@@ -1439,18 +1439,18 @@ getMergeSubscribed m sub = do

1439 subscription@(EventSubscription _ parentSubd) <- subscribe e s

1440 parentOcc <- liftIO $ readEventSubscribed parentSubd

1441 height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

1442− return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))

1442+ return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)

1443− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers

1443+ let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1444 heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1445 myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1446− myHeight = if any (== invalidHeight) heights

1446+ myHeight = if invalidHeight `elem` heights

1447 then invalidHeight

1448 else succHeight $ heightBagMax myHeightBag

1449 currentHeight <- getCurrentHeight

1450 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1451 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1452 else (Nothing, dm)

1453− when (not $ DMap.null accum) $ do

1453+ unless (DMap.null accum) $ do

1454 scheduleMerge myHeight subscribedUnsafe

1455 occRef <- liftIO $ newIORef occ

1456 when (isJust occ) $ scheduleClear occRef

@@ -1478,7 +1478,7 @@ getMergeSubscribed m sub = do

1478 defer $ SomeMergeInit subscribed $ updated $ mergeParents m

1479 liftIO $ writeIORef subscribedRef $! subscribed

1480 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"

1481− liftIO $ writeIORef (mergeSubscribed m) $! Just subscribed

1481+ liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed

1482 return (sln, subscribed)

1483

1484cleanupMergeSubscribed :: MergeSubscribed k -> IO ()

@@ -1486,7 +1486,7 @@ cleanupMergeSubscribed subscribed = do

1486 parents <- readIORef $ mergeSubscribedParents subscribed

1487 forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp

1488 -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty

1489− writeIORef (mergeSubscribedCachedSubscribed subscribed) $! Nothing -- Get rid of the cached subscribed

1489+ writeIORef (mergeSubscribedCachedSubscribed subscribed) $ Nothing -- Get rid of the cached subscribed

1490

1491{-# INLINE subscribeMergeSubscribed #-}

1492subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))

@@ -1520,7 +1520,7 @@ getFanSubscribed k f sub = do

1520 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf

1521 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"

1522 liftIO $ writeIORef subscribedRef $! subscribed

1523− liftIO $ writeIORef (fanSubscribed f) $! Just subscribed

1523+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1524 return (slnForSub, subscribed)

1525

1526cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()

@@ -1531,7 +1531,7 @@ cleanupFanSubscribed (k, subscribed) = do

1531 then do

1532 unsubscribe $ fanSubscribedParent subscribed

1533 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers

1534− writeIORef (fanSubscribedCachedSubscribed subscribed) $! Nothing

1534+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing

1535 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1536

1537{-# INLINE subscribeFanSubscribed #-}

@@ -1590,14 +1590,14 @@ getSwitchSubscribed s sub = do

1590 }

1591 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

1592 liftIO $ writeIORef subscribedRef $! subscribed

1593− liftIO $ writeIORef (switchSubscribed s) $! Just subscribed

1593+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed

1594 return (slnForSub, subscribed)

1595

1596cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()

1597cleanupSwitchSubscribed subscribed = do

1598 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)

1599 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead

1600− writeIORef (switchSubscribedCachedSubscribed subscribed) $! Nothing

1600+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing

1601

1602{-# INLINE subscribeSwitchSubscribed #-}

1603subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)

@@ -1645,13 +1645,13 @@ getCoincidenceSubscribed c sub = do

1645 }

1646 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

1647 liftIO $ writeIORef subscribedRef $! subscribed

1648− liftIO $ writeIORef (coincidenceSubscribed c) $! Just subscribed

1648+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1649 return (slnForSub, subscribed)

1650

1651cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()

1652cleanupCoincidenceSubscribed subscribed = do

1653 unsubscribe $ coincidenceSubscribedOuterParent subscribed

1654− writeIORef (coincidenceSubscribedCachedSubscribed subscribed) $! Nothing

1654+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing

1655

1656{-# INLINE subscribeCoincidenceSubscribed #-}

1657subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)

@@ -1674,33 +1674,27 @@ fan e =

1674 }

1675 in EventSelector $ \k -> EventFan k f

1676

1677−{- SPECIALIZE runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x () #-}

1678−--runHoldInits :: (CanSubscribe x m, Defer SomeMergeUpdate m) => IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> m ()

1679runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()

1677runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()

1680runHoldInits holdInitRef mergeInitRef = do

1678runHoldInits holdInitRef mergeInitRef = do

1681 holdInits <- liftIO $ readIORef holdInitRef

1679 holdInits <- liftIO $ readIORef holdInitRef

1682 mergeInits <- liftIO $ readIORef mergeInitRef

1680 mergeInits <- liftIO $ readIORef mergeInitRef

1683− if null holdInits && null mergeInits then return () else do

1681+ unless (null holdInits && null mergeInits) $ do

1684− liftIO $ writeIORef holdInitRef $! []

1682+ liftIO $ writeIORef holdInitRef []

1685− liftIO $ writeIORef mergeInitRef $! []

1683+ liftIO $ writeIORef mergeInitRef []

1686 mapM_ initHold holdInits

1684 mapM_ initHold holdInits

1687 mapM_ initMerge mergeInits

1685 mapM_ initMerge mergeInits

1688 runHoldInits holdInitRef mergeInitRef

1686 runHoldInits holdInitRef mergeInitRef

1689

1687

1690−{- SPECIALIZE initHold :: SomeHoldInit -> EventM x () #-}

1691−--initHold :: CanSubscribe x m => SomeHoldInit -> m ()

1692initHold :: SomeHoldInit -> EventM x ()

1688initHold :: SomeHoldInit -> EventM x ()

1693initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1689initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1694

1690

1695−{- SPECIALIZE initMerge :: SomeMergeInit -> EventM x () #-}

1696−--initMerge :: (CanSubscribe x m, Defer SomeMergeUpdate m) => SomeMergeInit -> m ()

1697initMerge :: SomeMergeInit -> EventM x ()

1691initMerge :: SomeMergeInit -> EventM x ()

1698initMerge (SomeMergeInit subscribed changed) = do

1692initMerge (SomeMergeInit subscribed changed) = do

1699 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1693 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1700 EventSubscription _ changeSubd <- subscribe changed changeSub

1694 EventSubscription _ changeSubd <- subscribe changed changeSub

1701 change <- liftIO $ readEventSubscribed changeSubd

1695 change <- liftIO $ readEventSubscribed changeSubd

1702 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1696 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1703− liftIO $ writeIORef (mergeSubscribedChange subscribed) $! (changeSub, changeSubd)

1697+ liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

1704

1698

1705-- | Run an event action outside of a frame

1699-- | Run an event action outside of a frame

1706runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1700runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

@@ -1724,7 +1718,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1724 return result

1718 return result

1725 result <- runEventM go env

1719 result <- runEventM go env

1726 toClear <- readIORef toClearRef

1720 toClear <- readIORef toClearRef

1727− forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref $! Nothing

1721+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

1728 toClearRoot <- readIORef toClearRootRef

1722 toClearRoot <- readIORef toClearRootRef

1729 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1723 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1730 toAssign <- readIORef toAssignRef

1724 toAssign <- readIORef toAssignRef

@@ -1735,7 +1729,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1735 when debugInvalidate $ putStrLn $ "Invalidating Hold"

1729 when debugInvalidate $ putStrLn $ "Invalidating Hold"

1736 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1730 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1737 mergeUpdates <- readIORef mergeUpdateRef

1731 mergeUpdates <- readIORef mergeUpdateRef

1738− writeIORef mergeUpdateRef $! []

1732+ writeIORef mergeUpdateRef []

1739 let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]

1733 let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]

1740 updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do

1734 updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do

1741 oldParents <- readIORef $ mergeSubscribedParents m

1735 oldParents <- readIORef $ mergeSubscribedParents m

@@ -1768,15 +1762,15 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1768 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

1762 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

1769 wi' <- mkWeakPtrWithDebug i "wi'"

1763 wi' <- mkWeakPtrWithDebug i "wi'"

1770 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'

1764 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'

1771− writeIORef (switchSubscribedBehaviorParents subscribed) $! []

1765+ writeIORef (switchSubscribedBehaviorParents subscribed) []

1772− writeIORef holdInitRef $! [] --TODO: Should we reuse this?

1766+ writeIORef holdInitRef [] --TODO: Should we reuse this?

1773 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef

1767 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef

1774 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

1768 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

1775 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1769 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1776 sub <- newSubscriberSwitch subscribed

1770 sub <- newSubscriberSwitch subscribed

1777 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

1771 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

1778 {-

1772 {-

1779− stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1773+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1780 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1774 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1781 EventRoot _ -> "EventRoot"

1775 EventRoot _ -> "EventRoot"

1782 EventNever -> "EventNever"

1776 EventNever -> "EventNever"

@@ -1987,7 +1981,7 @@ invalidate toReconnectRef wis = do

1987 traceInvalidate $ "invalidate: Pull" <> showNodeId p

1981 traceInvalidate $ "invalidate: Pull" <> showNodeId p

1988 mVal <- readIORef $ pullValue p

1982 mVal <- readIORef $ pullValue p

1989 forM_ mVal $ \val -> do

1983 forM_ mVal $ \val -> do

1990− writeIORef (pullValue p) $! Nothing

1984+ writeIORef (pullValue p) Nothing

1991 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)

1985 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)

1992 InvalidatorSwitch subscribed -> do

1986 InvalidatorSwitch subscribed -> do

1993 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed

1987 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed

@@ -2085,7 +2079,7 @@ instance R.Reflex (SpiderEnv x) where

2085 {-# INLINABLE incrementalToDynamic #-}

2079 {-# INLINABLE incrementalToDynamic #-}

2086 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do

2080 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do

2087 c <- readBehaviorUntracked $ current i

2081 c <- readBehaviorUntracked $ current i

2088− return $ fmap Identity $ R.apply p c --TODO: Avoid the redundant 'apply'

2082+ return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'

2089

2083

2090instance R.MonadSample (SpiderEnv x) (EventM x) where

2084instance R.MonadSample (SpiderEnv x) (EventM x) where

2091 {-# INLINABLE sample #-}

2085 {-# INLINABLE sample #-}

@@ -2100,13 +2094,13 @@ instance R.MonadHold (SpiderEnv x) (EventM x) where

2100 holdIncremental = holdIncrementalSpiderEventM

2094 holdIncremental = holdIncrementalSpiderEventM

2101

2095

2102holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)

2096holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)

2103−holdSpiderEventM v0 e = liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2097+holdSpiderEventM v0 e = fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2104

2098

2105holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)

2099holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)

2106−holdDynSpiderEventM v0 e = liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2100+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2107

2101

2108holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)

2102holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)

2109−holdIncrementalSpiderEventM v0 e = liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e

2103+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e

2110

2104

2111instance R.MonadHold (SpiderEnv x) (SpiderHost x) where

2105instance R.MonadHold (SpiderEnv x) (SpiderHost x) where

2112 {-# INLINABLE hold #-}

2106 {-# INLINABLE hold #-}

@@ -2132,9 +2126,9 @@ instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where

2132 {-# INLINABLE hold #-}

2126 {-# INLINABLE hold #-}

2133 hold v0 e = R.current <$> R.holdDyn v0 e

2127 hold v0 e = R.current <$> R.holdDyn v0 e

2134 {-# INLINABLE holdDyn #-}

2128 {-# INLINABLE holdDyn #-}

2135− holdDyn v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e

2129+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e

2136 {-# INLINABLE holdIncremental #-}

2130 {-# INLINABLE holdIncremental #-}

2137− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderIncremental . DynamicHold) $ hold v0 e

2131+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . DynamicHold <$> hold v0 e

2138

2132

2139data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)

2133data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)

2140newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }

2134newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }

@@ -2152,7 +2146,7 @@ instance R.ReflexHost (SpiderEnv x) where

2152

2146

2153instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2147instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2154 {-# INLINABLE readEvent #-}

2148 {-# INLINABLE readEvent #-}

2155− readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do

2149+ readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2156 let EventSubscription sln subscribed = unSpiderEventHandle h

2150 let EventSubscription sln subscribed = unSpiderEventHandle h

2157 result <- readEventSubscribed subscribed

2151 result <- readEventSubscribed subscribed

2158 touch sln

2152 touch sln

@@ -2207,11 +2201,11 @@ addIdentity = unsafeCoerce

2207

2201

2208instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where

2202instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where

2209 {-# INLINABLE hold #-}

2203 {-# INLINABLE hold #-}

2210− hold v0 e = SpiderHostFrame $ liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2204+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2211 {-# INLINABLE holdDyn #-}

2205 {-# INLINABLE holdDyn #-}

2212− holdDyn v0 e = SpiderHostFrame $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2206+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e

2213 {-# INLINABLE holdIncremental #-}

2207 {-# INLINABLE holdIncremental #-}

2214− holdIncremental v0 e = SpiderHostFrame $ liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e

2208+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e

2215

2209

2216newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)

2210newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)

2217newEventWithTriggerIO f = do

2211newEventWithTriggerIO f = do

@@ -2230,13 +2224,13 @@ newFanEventWithTriggerIO f = do

2230 return $ EventSelector $ \k -> EventRoot k r

2224 return $ EventSelector $ \k -> EventRoot k r

2231

2225

2232instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where

2226instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where

2233− newEventWithTrigger = SpiderHost . lift . liftM SpiderEvent . newEventWithTriggerIO

2227+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2234 newFanEventWithTrigger f = SpiderHost $ lift $ do

2228 newFanEventWithTrigger f = SpiderHost $ lift $ do

2235 es <- newFanEventWithTriggerIO f

2229 es <- newFanEventWithTriggerIO f

2236 return $ R.EventSelector $ SpiderEvent . select es

2230 return $ R.EventSelector $ SpiderEvent . select es

2237

2231

2238instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where

2232instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where

2239− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO

2233+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2240 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2234 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2241 es <- newFanEventWithTriggerIO f

2235 es <- newFanEventWithTriggerIO f

2242 return $ R.EventSelector $ SpiderEvent . select es

2236 return $ R.EventSelector $ SpiderEvent . select es

test/Reflex/Bench/Focused.hs+2−3

@@ -2,7 +2,6 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RecursiveDo #-}

7{-# LANGUAGE RecursiveDo #-}

@@ -104,7 +103,7 @@ fanMerge n e = leftmost $ s <$> [0..n - 1] where

104-- Dumb version of the above using simple fmapMaybe to filter

103-- Dumb version of the above using simple fmapMaybe to filter

105fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word

104fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word

106fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where

105fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where

107− s k = flip fmapMaybe e $ \j -> if (k == j `mod` n)

106+ s k = flip fmapMaybe e $ \j -> if k == j `mod` n

108 then Just k

107 then Just k

109 else Nothing

108 else Nothing

110

109

@@ -181,7 +180,7 @@ switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges

181-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)

180-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)

182

181

183switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))

182switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))

184−switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges

183+switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges

185 where joinMap m = traverse sample =<< sample m

184 where joinMap m = traverse sample =<< sample m

186

185

187-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value

186-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value

test/Reflex/Plan/Reflex.hs−2

@@ -1,12 +1,10 @@

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE StandaloneDeriving #-}

12{-# LANGUAGE UndecidableInstances #-}

10{-# LANGUAGE UndecidableInstances #-}

test/Reflex/Pure.hs+6−9

@@ -23,6 +23,7 @@ import Data.Dependent.Map (DMap, GCompare)

23import qualified Data.Dependent.Map as DMap

24import Data.Functor.Identity

25import Data.Functor.Misc

26+import Data.Maybe

26import Data.MemoTrie

27import Data.MemoTrie

27import Data.Monoid

28import Data.Monoid

28import Reflex.Class

29import Reflex.Class

@@ -127,7 +128,7 @@ instance MonadSample (Pure t) ((->) t) where

127

128

128instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

129instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

129

130

130− hold :: a -> Event (Pure t) a -> (t -> (Behavior (Pure t) a))

131+ hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a

131 hold initialValue e initialTime = Behavior f

132 hold initialValue e initialTime = Behavior f

132 where f = memo $ \sampleTime ->

133 where f = memo $ \sampleTime ->

133 -- Really, the sampleTime should never be prior to the initialTime,

134 -- Really, the sampleTime should never be prior to the initialTime,

@@ -135,16 +136,14 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

135 if sampleTime <= initialTime

136 if sampleTime <= initialTime

136 then initialValue

137 then initialValue

137 else let lastTime = pred sampleTime

138 else let lastTime = pred sampleTime

138− in case unEvent e lastTime of

139+ in fromMaybe (f lastTime) $ unEvent e lastTime

139− Nothing -> f lastTime

140− Just x -> x

141

140

142− holdDyn :: a -> Event (Pure t) a -> (t -> (Dynamic (Pure t) a))

141+ holdDyn :: a -> Event (Pure t) a -> t -> Dynamic (Pure t) a

143 holdDyn initialValue e initialTime =

142 holdDyn initialValue e initialTime =

144 let Behavior f = hold initialValue e initialTime

143 let Behavior f = hold initialValue e initialTime

145 in Dynamic $ \t -> (f t, unEvent e t)

144 in Dynamic $ \t -> (f t, unEvent e t)

146

145

147− holdIncremental :: Patch p => a -> Event (Pure t) (p a) -> (t -> (Incremental (Pure t) p a))

146+ holdIncremental :: Patch p => a -> Event (Pure t) (p a) -> t -> Incremental (Pure t) p a

148 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)

147 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)

149 where f = memo $ \sampleTime ->

148 where f = memo $ \sampleTime ->

150 -- Really, the sampleTime should never be prior to the initialTime,

149 -- Really, the sampleTime should never be prior to the initialTime,

@@ -155,6 +154,4 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

155 lastValue = f lastTime

154 lastValue = f lastTime

156 in case unEvent e lastTime of

155 in case unEvent e lastTime of

157 Nothing -> lastValue

156 Nothing -> lastValue

158− Just x -> case apply x lastValue of

157+ Just x -> fromMaybe lastValue $ apply x lastValue

159− Nothing -> lastValue

160− Just v' -> v'

test/Reflex/Test.hs−1

@@ -2,7 +2,6 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

test/Reflex/Test/CrossImpl.hs+18−22

@@ -1,21 +1,14 @@

1{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE EmptyDataDecls #-}

4{-# LANGUAGE ExistentialQuantification #-}

2{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE NoMonomorphismRestriction #-}

9{-# LANGUAGE NoMonomorphismRestriction #-}

13−{-# LANGUAGE PackageImports #-}

14{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

15−{-# LANGUAGE RecursiveDo #-}

16{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

17−{-# LANGUAGE StandaloneDeriving #-}

18−{-# LANGUAGE TemplateHaskell #-}

19{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

20{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

21{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

@@ -93,7 +86,7 @@ testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

93 outputs <- forM times $ \t -> do

86 outputs <- forM times $ \t -> do

94 forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger

87 forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger

95 bOutput <- sample b'

88 bOutput <- sample b'

96− eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do

89+ eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do

97 mret <- readRef reTrigger

90 mret <- readRef reTrigger

98 let firing = case mret of

91 let firing = case mret of

99 Just ret -> [ret :=> Identity val]

92 Just ret -> [ret :=> Identity val]

@@ -131,7 +124,7 @@ testCases =

131 b' <- hold "123" e

124 b' <- hold "123" e

132 return (b', e)

125 return (b', e)

133 , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do

126 , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do

134− e' <- liftM updated $ count e

127+ e' <- updated <$> count e

135 b' <- hold (0 :: Int) e'

128 b' <- hold (0 :: Int) e'

136 return (b', e')

129 return (b', e')

137 , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

130 , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

@@ -144,23 +137,19 @@ testCases =

144 return (b, e'')

137 return (b, e'')

145 , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

138 , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

146 let e' = flip pushAlways e $ const $ do

139 let e' = flip pushAlways e $ const $ do

147− let ea = fmap (const "a") e

140+ let eab = splitRecombineEvent e

148− let eb = fmap (const "b") e

149− let eab = leftmost [ea, eb]

150− liftM switch $ hold eab never

141+ switch <$> hold eab never

151 e'' = coincidence e'

142 e'' = coincidence e'

152 return (b, e'')

143 return (b, e'')

153 , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

144 , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

154 let e' = flip pushAlways e $ const $ do

145 let e' = flip pushAlways e $ const $ do

155− let ea = fmap (const "a") e

146+ let eab = splitRecombineEvent e

156− let eb = fmap (const "b") e

157− let eab = leftmost [ea, eb]

158− liftM switch $ hold eab (fmap (const e) e)

147+ switch <$> hold eab (fmap (const e) e)

159 e'' = coincidence e'

148 e'' = coincidence e'

160 return (b, e'')

149 return (b, e'')

161 , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

150 , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

162 let e' = leftmost [e, e]

151 let e' = leftmost [e, e]

163− e'' <- liftM switch $ hold e' (fmap (const e) e)

152+ e'' <- switch <$> hold e' (fmap (const e) e)

164 return (b, e'')

153 return (b, e'')

165 , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

154 , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

166 let e' = fmap (const e) e

155 let e' = fmap (const e) e

@@ -180,11 +169,11 @@ testCases =

180 return (b, e'')

169 return (b, e'')

181 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

170 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

182 let e' = leftmost [e, e]

171 let e' = leftmost [e, e]

183− e'' <- liftM switch $ hold never (fmap (const e') e)

172+ e'' <- switch <$> hold never (fmap (const e') e)

184 return (b, e'')

173 return (b, e'')

185 , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

174 , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

186 let e' = flip push e $ \_ -> do

175 let e' = flip push e $ \_ -> do

187− return . Just =<< onceE e

176+ Just <$> onceE e

188 e'' <- switchPromptly never e'

177 e'' <- switchPromptly never e'

189 return (b, e'')

178 return (b, e'')

190 , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

179 , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

@@ -193,7 +182,7 @@ testCases =

193 e'' <- switchPromptly never e'

182 e'' <- switchPromptly never e'

194 return (b, e'')

183 return (b, e'')

195 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

184 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

196− let e' = flip pushAlways e $ \_ -> return $ fmap id e

185+ let e' = flip pushAlways e $ \_ -> return e

197 e'' = coincidence e'

186 e'' = coincidence e'

198 return (b, e'')

187 return (b, e'')

199 , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

188 , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

@@ -232,12 +221,19 @@ testCases =

232 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

221 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

233 bb <- hold "b" e

222 bb <- hold "b" e

234 bd <- hold never . fmap (const e) =<< onceE e

223 bd <- hold never . fmap (const e) =<< onceE e

235− eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e

224+ eOuter <- pushAlways sample . fmap (const bb) <$> onceE e

236 let eInner = switch bd

225 let eInner = switch bd

237 e' = leftmost [eOuter, eInner]

226 e' = leftmost [eOuter, eInner]

238 return (b, e')

227 return (b, e')

239 ]

228 ]

240

229

230+splitRecombineEvent :: Reflex t => Event t a -> Event t String

231+splitRecombineEvent e =

232+ let ea = "a" <$ e

233+ eb = "b" <$ e

234+ in leftmost [ea, eb]

235+

236+

241test :: IO ()

237test :: IO ()

242test = do

238test = do

243 results <- forM testCases $ \(name, TestCase inputs builder) -> do

239 results <- forM testCases $ \(name, TestCase inputs builder) -> do

test/Reflex/Test/Micro.hs+6−7

@@ -2,7 +2,6 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

@@ -33,16 +32,16 @@ testCases =

34 , testB "pull-1" $ do

33 , testB "pull-1" $ do

35 b <- hold "0" =<< events1

34 b <- hold "0" =<< events1

36− return (id <$> id <$> b)

35+ return (pull $ sample $ pull $ sample b)

38 , testB "pull-2" $ do

37 , testB "pull-2" $ do

39 b1 <- behavior1

38 b1 <- behavior1

40− return (id <$> pull $ liftA2 (<>) (sample b1) (sample b1))

39+ return (pull $ liftA2 (<>) (sample b1) (sample b1))

42 , testB "pull-3" $ do

41 , testB "pull-3" $ do

43 b1 <- behavior1

42 b1 <- behavior1

44 b2 <- behavior2

43 b2 <- behavior2

45− return (id <$> pull $ liftA2 (<>) (sample b1) (sample b2))

44+ return (pull $ liftA2 (<>) (sample b1) (sample b2))

47 , testB "pull-4" $ do

46 , testB "pull-4" $ do

48 es <- planList ["a", "b", "c"]

47 es <- planList ["a", "b", "c"]

@@ -154,7 +153,7 @@ testCases =

154 , testE "coincidence-1" $ do

153 , testE "coincidence-1" $ do

155 e <- events1

154 e <- events1

156 return $ coincidence $ flip pushAlways e $

155 return $ coincidence $ flip pushAlways e $

157− const $ return (id <$> e)

156+ const $ return e

158

157

159 , testE "coincidence-2" $ do

158 , testE "coincidence-2" $ do

160 e <- events1

159 e <- events1

@@ -228,7 +227,7 @@ testCases =

228 return (mergeList es)

227 return (mergeList es)

229

228

230 , testE "fan-3" $ do

229 , testE "fan-3" $ do

231− f <- fanMap <$> fmap toMap <$> events3

230+ f <- fanMap . fmap toMap <$> events3

232 return $ select f (Const2 'c')

231 return $ select f (Const2 'c')

233

232

234 , testE "fan-4" $ do

233 , testE "fan-4" $ do

@@ -240,7 +239,7 @@ testCases =

240 return $ toUpper <$> select (fanMap e) (Const2 'c')

239 return $ toUpper <$> select (fanMap e) (Const2 'c')

241

240

242 , testE "fan-6" $ do

241 , testE "fan-6" $ do

243− f <- fanMap <$> fmap toMap <$> events1

242+ f <- fanMap . fmap toMap <$> events1

244 return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]

243 return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]

245

244

246 ] where

245 ] where

test/Reflex/Test/RunAll.hs−1

@@ -2,7 +2,6 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

test/Reflex/TestPlan.hs−4

@@ -1,14 +1,10 @@

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE StandaloneDeriving #-}

12{-# LANGUAGE UndecidableInstances #-}

8{-# LANGUAGE UndecidableInstances #-}

13module Reflex.TestPlan

9module Reflex.TestPlan

14 ( TestPlan(..)

10 ( TestPlan(..)

test/hlint.hsnew file+16

@@ -0,0 +1,16 @@

1+import Language.Haskell.HLint3 (hlint)

2+import System.Exit (exitFailure, exitSuccess)

4+main :: IO ()

5+main = do

6+ ideas <- hlint

7+ [ "."

8+ , "--ignore=Redundant do"

9+ , "--ignore=Use camelCase"

10+ , "--ignore=Redundant $"

11+ , "--ignore=Use &&&"

12+ , "--ignore=Use const"

13+ , "--ignore=Use >=>"

14+ , "--ignore=Use ."

15+ ]

16+ if null ideas then exitSuccess else exitFailure