6f255aa · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Make headE a primitive

6f255aaRyan Trinkle9 years ago

src/Reflex/Class.hs+17−9

compare with develop

unifiedsplit

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

104 , numberOccurrencesFrom_

105 , (<@>)

106 , (<@)

107− , headE

108 , tailE

107 , tailE

109 , headTailE

108 , headTailE

110 , takeWhileE

109 , takeWhileE

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

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

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

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

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

461 buildDynamic getV0 = lift . buildDynamic getV0

460 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'

462

469

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

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

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

471-- 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

488 holdDyn a0 = lift . holdDyn a0

495 holdDyn a0 = lift . holdDyn a0

489 holdIncremental a0 = lift . holdIncremental a0

496 holdIncremental a0 = lift . holdIncremental a0

490 buildDynamic a0 = lift . buildDynamic a0

497 buildDynamic a0 = lift . buildDynamic a0

498+ headE = lift . headE

491

499

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

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

493 sample = lift . sample

501 sample = lift . sample

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

497 holdDyn a0 = lift . holdDyn a0

505 holdDyn a0 = lift . holdDyn a0

498 holdIncremental a0 = lift . holdIncremental a0

506 holdIncremental a0 = lift . holdIncremental a0

499 buildDynamic a0 = lift . buildDynamic a0

507 buildDynamic a0 = lift . buildDynamic a0

508+ headE = lift . headE

500

509

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

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

502 sample = lift . sample

511 sample = lift . sample

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

506 holdDyn a0 = lift . holdDyn a0

515 holdDyn a0 = lift . holdDyn a0

507 holdIncremental a0 = lift . holdIncremental a0

516 holdIncremental a0 = lift . holdIncremental a0

508 buildDynamic a0 = lift . buildDynamic a0

517 buildDynamic a0 = lift . buildDynamic a0

518+ headE = lift . headE

509

519

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

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

511 sample = lift . sample

521 sample = lift . sample

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

514 hold a0 = lift . hold a0

524 hold a0 = lift . hold a0

515 holdDyn a0 = lift . holdDyn a0

525 holdDyn a0 = lift . holdDyn a0

516 holdIncremental a0 = lift . holdIncremental a0

526 holdIncremental a0 = lift . holdIncremental a0

527+ buildDynamic a0 = lift . buildDynamic a0

528+ headE = lift . headE

517

529

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

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

519 sample = lift . sample

531 sample = lift . sample

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

522 hold a0 = lift . hold a0

534 hold a0 = lift . hold a0

523 holdDyn a0 = lift . holdDyn a0

535 holdDyn a0 = lift . holdDyn a0

524 holdIncremental a0 = lift . holdIncremental a0

536 holdIncremental a0 = lift . holdIncremental a0

537+ buildDynamic a0 = lift . buildDynamic a0

538+ headE = lift . headE

525

539

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

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

527 sample = lift . sample

541 sample = lift . sample

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

530 hold a0 = lift . hold a0

544 hold a0 = lift . hold a0

531 holdDyn a0 = lift . holdDyn a0

545 holdDyn a0 = lift . holdDyn a0

532 holdIncremental a0 = lift . holdIncremental a0

546 holdIncremental a0 = lift . holdIncremental a0

547+ buildDynamic a0 = lift . buildDynamic a0

548+ headE = lift . headE

533

549

534--------------------------------------------------------------------------------

550--------------------------------------------------------------------------------

535-- Convenience functions

551-- Convenience functions

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

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

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

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

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

654

670

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−

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

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

664-- supplied 'Event'.

672-- supplied 'Event'.

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

673tailE :: (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

128 sample = lift . sample

129

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

131+ {-# INLINABLE hold #-}

131 hold v0 = lift . hold v0

132 hold v0 = lift . hold v0

133+ {-# INLINABLE holdDyn #-}

132 holdDyn v0 = lift . holdDyn v0

134 holdDyn v0 = lift . holdDyn v0

135+ {-# INLINABLE holdIncremental #-}

133 holdIncremental v0 = lift . holdIncremental v0

136 holdIncremental v0 = lift . holdIncremental v0

137+ {-# INLINABLE buildDynamic #-}

138+ buildDynamic a0 = lift . buildDynamic a0

139+ {-# INLINABLE headE #-}

140+ headE = lift . headE

134

141

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

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

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

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

src/Reflex/Optimizer.hs+6−1

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

31plugin = defaultPlugin { installCoreToDos = install }

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

34+install [] p = do

35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p

36+ let f = \case

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

38+ x -> [x]

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

39+ return $ makeInlinable : concatMap f p

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

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

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

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

37 install [] p

42 install [] p

src/Reflex/PostBuild/Base.hs+4

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

69 holdDyn v0 = lift . holdDyn v0

70 {-# INLINABLE holdIncremental #-}

71 holdIncremental v0 = lift . holdIncremental v0

72+ {-# INLINABLE buildDynamic #-}

73+ buildDynamic a0 = lift . buildDynamic a0

74+ {-# INLINABLE headE #-}

75+ headE = lift . headE

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

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

74 type Performable (PostBuildT t m) = Performable m

78 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

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

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

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

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

144

145

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

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

146 sample (Behavior_Profiled b) = ProfiledM $ sample b

147 sample (Behavior_Profiled b) = ProfiledM $ sample b

src/Reflex/Pure.hs+13

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

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

35import qualified Data.Dependent.Map as DMap

36import Data.Functor.Identity

37+import Data.IntMap (IntMap)

38+import qualified Data.IntMap as IntMap

37import Data.Maybe

39import Data.Maybe

38import Data.MemoTrie

40import Data.MemoTrie

39import Data.Monoid

41import Data.Monoid

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

125 eventCoercion Coercion = Coercion

127 eventCoercion Coercion = Coercion

126 dynamicCoercion Coercion = Coercion

128 dynamicCoercion Coercion = Coercion

127

129

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

131+

132+ mergeIntIncremental = mergeIntIncrementalImpl

133+

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

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

129mergeIncrementalImpl i = Event $ \t ->

135mergeIncrementalImpl i = Event $ \t ->

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

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

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

132 then Nothing

138 then Nothing

133 else Just results

139 else Just results

134

140

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+

135instance Functor (Dynamic (Pure t)) where

148instance Functor (Dynamic (Pure t)) where

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

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

137 in (f cur, fmap f upd)

150 in (f cur, fmap f upd)

src/Reflex/Spider/Internal.hs+37

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

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

255 return (subscription, occ')

256

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+

257data CacheSubscribed x a

294data CacheSubscribed x a

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

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

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

296 , _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

114 holdDyn v0 v' = lift $ holdDyn v0 v'

115 {-# INLINABLE holdIncremental #-}

116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117+ {-# INLINABLE buildDynamic #-}

118+ buildDynamic a0 = lift . buildDynamic a0

119+ {-# INLINABLE headE #-}

120+ headE = lift . headE

117

121

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

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

119 {-# INLINABLE runWithReplace #-}

123 {-# INLINABLE runWithReplace #-}