6f255aa · patch · git.iko.soy

git.iko.soy/patch

Make headE a primitive

commit6f255aab95752ec11a359baf2fc2bdfd5eaa630f authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 2 Sep 2017, 19:09 (9 years ago) parent93eb18c

8 files changed+89−10

compare with develop

unifiedsplit

src/Reflex/Class.hs+17−9 src/Reflex/EventWriter.hs+7 src/Reflex/Optimizer.hs+6−1 src/Reflex/PostBuild/Base.hs+4 src/Reflex/Profiled.hs+1 src/Reflex/Pure.hs+13 src/Reflex/Spider/Internal.hs+37 src/Reflex/TriggerEvent/Base.hs+4

src/Reflex/Class.hs+17−9

@@ -104,7 +104,6 @@ module Reflex.Class

104104 , numberOccurrencesFrom_

105105 , (<@>)

106106 , (<@)

107− , headE

108107 , tailE

109108 , headTailE

110109 , takeWhileE

@@ -459,6 +458,14 @@ class MonadSample t m => MonadHold t m where

459458 buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)

460459 default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)

461460 buildDynamic getV0 = lift . buildDynamic getV0

461+ -- | Create a new 'Event' that only occurs only once, on the first occurence of

462+ -- the supplied 'Event'.

463+ headE :: Event t a -> m (Event t a)

464+ default headE :: (Reflex t, MonadFix m) => Event t a -> m (Event t a)

465+ headE e = do

466+ rec be <- hold e $ fmapCheap (const never) e'

467+ let e' = switch be

468+ return e'

462469

463470-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

464471-- key. This is much more efficient than filtering for each key with

@@ -488,6 +495,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

488495 holdDyn a0 = lift . holdDyn a0

489496 holdIncremental a0 = lift . holdIncremental a0

490497 buildDynamic a0 = lift . buildDynamic a0

498+ headE = lift . headE

491499

492500instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

493501 sample = lift . sample

@@ -497,6 +505,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

497505 holdDyn a0 = lift . holdDyn a0

498506 holdIncremental a0 = lift . holdIncremental a0

499507 buildDynamic a0 = lift . buildDynamic a0

508+ headE = lift . headE

500509

501510instance MonadSample t m => MonadSample t (StateT s m) where

502511 sample = lift . sample

@@ -506,6 +515,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where

506515 holdDyn a0 = lift . holdDyn a0

507516 holdIncremental a0 = lift . holdIncremental a0

508517 buildDynamic a0 = lift . buildDynamic a0

518+ headE = lift . headE

509519

510520instance MonadSample t m => MonadSample t (ExceptT e m) where

511521 sample = lift . sample

@@ -514,6 +524,8 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

514524 hold a0 = lift . hold a0

515525 holdDyn a0 = lift . holdDyn a0

516526 holdIncremental a0 = lift . holdIncremental a0

527+ buildDynamic a0 = lift . buildDynamic a0

528+ headE = lift . headE

517529

518530instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where

519531 sample = lift . sample

@@ -522,6 +534,8 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

522534 hold a0 = lift . hold a0

523535 holdDyn a0 = lift . holdDyn a0

524536 holdIncremental a0 = lift . holdIncremental a0

537+ buildDynamic a0 = lift . buildDynamic a0

538+ headE = lift . headE

525539

526540instance MonadSample t m => MonadSample t (ContT r m) where

527541 sample = lift . sample

@@ -530,6 +544,8 @@ instance MonadHold t m => MonadHold t (ContT r m) where

530544 hold a0 = lift . hold a0

531545 holdDyn a0 = lift . holdDyn a0

532546 holdIncremental a0 = lift . holdIncremental a0

547+ buildDynamic a0 = lift . buildDynamic a0

548+ headE = lift . headE

533549

534550--------------------------------------------------------------------------------

535551-- Convenience functions

@@ -652,14 +668,6 @@ attachWith f = attachWithMaybe $ \a b -> Just $ f a b

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

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

654670

655−-- | Create a new 'Event' that only occurs only once, on the first occurence of

656−-- the supplied 'Event'.

657−headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

658−headE e = do

659− rec be <- hold e $ fmapCheap (const never) e'

660− let e' = switch be

661− return e'

662−

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

664672-- supplied 'Event'.

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

src/Reflex/EventWriter.hs+7

@@ -128,9 +128,16 @@ instance MonadSample t m => MonadSample t (EventWriterT t w m) where

128128 sample = lift . sample

129129

130130instance MonadHold t m => MonadHold t (EventWriterT t w m) where

131+ {-# INLINABLE hold #-}

131132 hold v0 = lift . hold v0

133+ {-# INLINABLE holdDyn #-}

132134 holdDyn v0 = lift . holdDyn v0

135+ {-# INLINABLE holdIncremental #-}

133136 holdIncremental v0 = lift . holdIncremental v0

137+ {-# INLINABLE buildDynamic #-}

138+ buildDynamic a0 = lift . buildDynamic a0

139+ {-# INLINABLE headE #-}

140+ headE = lift . headE

134141

135142instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

136143 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

src/Reflex/Optimizer.hs+6−1

@@ -31,7 +31,12 @@ plugin :: Plugin

3131plugin = defaultPlugin { installCoreToDos = install }

3232

3333install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

34−install [] p = return $ makeInlinable : p

34+install [] p = do

35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p

36+ let f = \case

37+ simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]

38+ x -> [x]

39+ return $ makeInlinable : concatMap f p

3540install options@(_:_) p = do

3641 warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"

3742 install [] p

src/Reflex/PostBuild/Base.hs+4

@@ -69,6 +69,10 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

6969 holdDyn v0 = lift . holdDyn v0

7070 {-# INLINABLE holdIncremental #-}

7171 holdIncremental v0 = lift . holdIncremental v0

72+ {-# INLINABLE buildDynamic #-}

73+ buildDynamic a0 = lift . buildDynamic a0

74+ {-# INLINABLE headE #-}

75+ headE = lift . headE

7276

7377instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

7478 type Performable (PostBuildT t m) = Performable m

src/Reflex/Profiled.hs+1

@@ -141,6 +141,7 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

141141 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'

142142 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

143143 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

144+ headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

144145

145146instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

146147 sample (Behavior_Profiled b) = ProfiledM $ sample b

src/Reflex/Pure.hs+13

@@ -34,6 +34,8 @@ import Control.Monad

3434import Data.Dependent.Map (DMap, GCompare)

3535import qualified Data.Dependent.Map as DMap

3636import Data.Functor.Identity

37+import Data.IntMap (IntMap)

38+import qualified Data.IntMap as IntMap

3739import Data.Maybe

3840import Data.MemoTrie

3941import Data.Monoid

@@ -125,6 +127,10 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

125127 eventCoercion Coercion = Coercion

126128 dynamicCoercion Coercion = Coercion

127129

130+ fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

131+

132+ mergeIntIncremental = mergeIntIncrementalImpl

133+

128134mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)

129135mergeIncrementalImpl i = Event $ \t ->

130136 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t

@@ -132,6 +138,13 @@ mergeIncrementalImpl i = Event $ \t ->

132138 then Nothing

133139 else Just results

134140

141+mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)

142+mergeIntIncrementalImpl i = Event $ \t ->

143+ let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t

144+ in if IntMap.null results

145+ then Nothing

146+ else Just results

147+

135148instance Functor (Dynamic (Pure t)) where

136149 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

137150 in (f cur, fmap f upd)

src/Reflex/Spider/Internal.hs+37

@@ -254,6 +254,43 @@ pushCheap !f e = Event $ \sub -> do

254254 occ' <- join <$> mapM f occ

255255 return (subscription, occ')

256256

257+-- | A subscriber that never triggers other 'Event's

258+{-# INLINE terminalSubscriber #-}

259+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a

260+terminalSubscriber p = Subscriber

261+ { subscriberPropagate = p

262+ , subscriberInvalidateHeight = \_ -> return ()

263+ , subscriberRecalculateHeight = \_ -> return ()

264+ }

265+

266+-- | Subscribe to an Event only for the duration of one occurrence

267+{-# INLINE subscribeAndReadHead #-}

268+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

269+subscribeAndReadHead e sub = do

270+ subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

271+ (subscription, occ) <- subscribeAndRead e $ sub

272+ { subscriberPropagate = \a -> do

273+ liftIO $ unsubscribe =<< readIORef subscriptionRef

274+ subscriberPropagate sub a

275+ }

276+ liftIO $ case occ of

277+ Nothing -> writeIORef subscriptionRef $! subscription

278+ Just _ -> unsubscribe subscription

279+ return (subscription, occ)

280+

281+--TODO: Make this lazy in its input event

282+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)

283+headE originalE = do

284+ parent <- liftIO $ newIORef $ Just originalE

285+ defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

286+ let clearParent = liftIO $ writeIORef parent Nothing

287+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent

288+ when (isJust occ) clearParent

289+ return $ Event $ \sub -> do

290+ liftIO (readIORef parent) >>= \case

291+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)

292+ Just e -> subscribeAndReadHead e sub

293+

257294data CacheSubscribed x a

258295 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

259296 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

src/Reflex/TriggerEvent/Base.hs+4

@@ -114,6 +114,10 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

114114 holdDyn v0 v' = lift $ holdDyn v0 v'

115115 {-# INLINABLE holdIncremental #-}

116116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117+ {-# INLINABLE buildDynamic #-}

118+ buildDynamic a0 = lift . buildDynamic a0

119+ {-# INLINABLE headE #-}

120+ headE = lift . headE

117121

118122instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

119123 {-# INLINABLE runWithReplace #-}