21ce2b7 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Reorganize a bit and get back to 100% documentation (except for Reflex.Spider.Internal)

21ce2b7Ryan Trinkle10 years ago

reflex.cabal+3

compare with develop

unifiedsplit

@@ -68,7 +68,10 @@ library

68 Reflex.Patch,

69 Reflex.PerformEvent.Base,

70 Reflex.PerformEvent.Class,

71+ Reflex.PostBuild.Base,

71 Reflex.PostBuild.Class,

72 Reflex.PostBuild.Class,

73+ Reflex.Requester.Base,

74+ Reflex.Requester.Class,

72 Reflex.Spider,

75 Reflex.Spider,

73 Reflex.Spider.Internal

76 Reflex.Spider.Internal

src/Data/Functor/Misc.hs+22−23

@@ -17,28 +17,28 @@

17-- which are relevant to the use of 'Functor'-based datastructures like

18-- 'Data.Dependent.Map.DMap'.

19module Data.Functor.Misc

20− ( -- * Const2

20+ ( -- * Const2

21− Const2 (..)

21+ Const2 (..)

22− , dmapToMap

22+ , dmapToMap

23− , mapToDMap

23+ , mapToDMap

24− -- * WrapArg

24+ -- * WrapArg

25− , WrapArg (..)

25+ , WrapArg (..)

26− -- * Convenience functions for DMap

26+ -- * Convenience functions for DMap

27− , mapWithFunctorToDMap

27+ , mapWithFunctorToDMap

28− , mapKeyValuePairsMonotonic

28+ , mapKeyValuePairsMonotonic

29− , combineDMapsWithKey

29+ , combineDMapsWithKey

30− , EitherTag (..)

30+ , EitherTag (..)

31− , dmapToThese

31+ , dmapToThese

32− , eitherToDSum

32+ , eitherToDSum

33− , dsumToEither

33+ , dsumToEither

34− -- * Deprecated functions

34+ -- * Deprecated functions

35− , sequenceDmap

35+ , sequenceDmap

36− , wrapDMap

36+ , wrapDMap

37− , rewrapDMap

37+ , rewrapDMap

38− , unwrapDMap

38+ , unwrapDMap

39− , unwrapDMapMaybe

39+ , unwrapDMapMaybe

40− , extractFunctorDMap

40+ , extractFunctorDMap

41− ) where

41+ ) where

43import Control.Applicative (Applicative, (<$>))

44import Control.Monad.Identity

@@ -190,7 +190,6 @@ dsumToEither = \case

190 (LeftTag :=> Identity a) -> Left a

191 (RightTag :=> Identity b) -> Right b

192

193−

194--------------------------------------------------------------------------------

193--------------------------------------------------------------------------------

195-- Deprecated functions

194-- Deprecated functions

196--------------------------------------------------------------------------------

195--------------------------------------------------------------------------------

src/Data/WeakBag.hs+8−8

@@ -9,14 +9,14 @@

9-- This is useful for situations where a value needs to be inspected or modified

10-- if it is still alive, but can be ignored if it is dead.

11module Data.WeakBag

12− ( WeakBag

12+ ( WeakBag

13− , WeakBagTicket

13+ , WeakBagTicket

14− , empty

14+ , empty

15− , singleton

15+ , singleton

16− , insert

16+ , insert

17− , traverse

17+ , traverse

18− , remove

18+ , remove

19− ) where

19+ ) where

21import Control.Exception

22import Control.Monad hiding (forM_, mapM_)

src/Reflex.hs+7−1

@@ -1,6 +1,8 @@

1-- | This module exports all of the commonly-used functionality of Reflex; if

2-- you are just getting started with Reflex, this is probably what you want.

3−module Reflex (module X) where

3+module Reflex

4+ ( module X

5+ ) where

5import Reflex.Class as X

7import Reflex.Class as X

6import Reflex.Dynamic as X

8import Reflex.Dynamic as X

@@ -8,5 +10,9 @@ import Reflex.Dynamic.TH as X

8import Reflex.Dynamic.Uniq as X

10import Reflex.Dynamic.Uniq as X

9import Reflex.DynamicWriter as X

11import Reflex.DynamicWriter as X

10import Reflex.PerformEvent.Class as X

12import Reflex.PerformEvent.Class as X

13+import Reflex.PerformEvent.Base as X

11import Reflex.PostBuild.Class as X

14import Reflex.PostBuild.Class as X

15+import Reflex.PostBuild.Base as X

16+import Reflex.Requester.Class as X

17+import Reflex.Requester.Base as X

12import Reflex.Spider as X

18import Reflex.Spider as X

src/Reflex/Class.hs+111−100

@@ -25,108 +25,108 @@

25-- convenience functions for working with 'Event's, 'Behavior's, and other

26-- signals.

27module Reflex.Class

28− ( module Reflex.Patch

28+ ( module Reflex.Patch

29− -- * Primitives

29+ -- * Primitives

30− , Reflex (..)

30+ , Reflex (..)

31− , coerceBehavior

31+ , coerceBehavior

32− , coerceEvent

32+ , coerceEvent

33− , coerceDynamic

33+ , coerceDynamic

34− , MonadSample (..)

34+ , MonadSample (..)

35− , MonadHold (..)

35+ , MonadHold (..)

36− -- ** 'fan'-related types

36+ -- ** 'fan'-related types

37− , EventSelector (..)

37+ , EventSelector (..)

38− -- ** 'Incremental'-related types

38+ -- ** 'Incremental'-related types

39− -- * Convenience functions

39+ -- * Convenience functions

40− , constDyn

40+ , constDyn

41− , pushAlways

41+ , pushAlways

42− -- ** Combining 'Event's

42+ -- ** Combining 'Event's

43− , leftmost

43+ , leftmost

44− , mergeMap

44+ , mergeMap

45− , mergeList

45+ , mergeList

46− , mergeWith

46+ , mergeWith

47− , difference

47+ , difference

48− -- ** Breaking up 'Event's

48+ -- ** Breaking up 'Event's

49− , splitE

49+ , splitE

50− , fanEither

50+ , fanEither

51− , fanThese

51+ , fanThese

52− , fanMap

52+ , fanMap

53− , dmapToThese

53+ , dmapToThese

54− , EitherTag (..)

54+ , EitherTag (..)

55− , eitherToDSum

55+ , eitherToDSum

56− , dsumToEither

56+ , dsumToEither

57− -- ** Switching between 'Event's

57+ -- ** Switching between 'Event's

58− , switchPromptly

58+ , switchPromptly

59− , switchPromptOnly

59+ , switchPromptOnly

60− -- ** Using 'Event's to sample 'Behavior's

60+ -- ** Using 'Event's to sample 'Behavior's

61− , tag

61+ , tag

62− , attach

62+ , attach

63− , attachWith

63+ , attachWith

64− , attachWithMaybe

64+ , attachWithMaybe

65− -- ** Blocking an 'Event' based on a 'Behavior'

65+ -- ** Blocking an 'Event' based on a 'Behavior'

66− , gate

66+ , gate

67− -- ** Combining 'Dynamic's

67+ -- ** Combining 'Dynamic's

68− , distributeDMapOverDynPure

68+ , distributeDMapOverDynPure

69− , distributeListOverDyn

69+ , distributeListOverDyn

70− , distributeListOverDynWith

70+ , distributeListOverDynWith

71− , zipDyn

71+ , zipDyn

72− , zipDynWith

72+ , zipDynWith

73− -- ** Accumulating state

73+ -- ** Accumulating state

74− , Accumulator (..)

74+ , Accumulator (..)

75− , mapAccum_

75+ , mapAccum_

76− , mapAccumM_

76+ , mapAccumM_

77− , mapAccumMaybe_

77+ , mapAccumMaybe_

78− , mapAccumMaybeM_

78+ , mapAccumMaybeM_

79− , zipListWithEvent

79+ , zipListWithEvent

80− , headE

80+ , headE

81− , tailE

81+ , tailE

82− , headTailE

82+ , headTailE

83− , switcher

83+ , switcher

84− -- * Debugging functions

84+ -- * Debugging functions

85− , traceEvent

85+ , traceEvent

86− , traceEventWith

86+ , traceEventWith

87− -- * Unsafe functions

87+ -- * Unsafe functions

88− , unsafeDynamic

88+ , unsafeDynamic

89− -- * 'FunctorMaybe'

89+ -- * 'FunctorMaybe'

90− , FunctorMaybe (..)

90+ , FunctorMaybe (..)

91− , fforMaybe

91+ , fforMaybe

92− , ffilter

92+ , ffilter

93− -- * Miscellaneous convenience functions

93+ -- * Miscellaneous convenience functions

94− , ffor

94+ , ffor

95− , MonadAdjust (..)

95+ , MonadAdjust (..)

96− -- * Deprecated functions

96+ -- * Deprecated functions

97− , appendEvents

97+ , appendEvents

98− , onceE

98+ , onceE

99− , sequenceThese

99+ , sequenceThese

100#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

101− , Spider

101+ , Spider

102− , SpiderEnv

102+ , SpiderEnv

103− , SpiderTimeline

103+ , SpiderTimeline

104− , Global

104+ , Global

105− , Behavior (..)

105+ , Behavior (..)

106− , Event (..)

106+ , Event (..)

107− , Dynamic (..)

107+ , Dynamic (..)

108− , Incremental (..)

108+ , Incremental (..)

109− , never

109+ , never

110− , constant

110+ , constant

111− , push

111+ , push

112− , pull

112+ , pull

113− , merge

113+ , merge

114− , fan

114+ , fan

115− , switch

115+ , switch

116− , coincidence

116+ , coincidence

117− , current

117+ , current

118− , updated

118+ , updated

119− , unsafeBuildDynamic

119+ , unsafeBuildDynamic

120− , unsafeBuildIncremental

120+ , unsafeBuildIncremental

121− , mergeIncremental

121+ , mergeIncremental

122− , currentIncremental

122+ , currentIncremental

123− , updatedIncremental

123+ , updatedIncremental

124− , incrementalToDynamic

124+ , incrementalToDynamic

125− , behaviorCoercion

125+ , behaviorCoercion

126− , eventCoercion

126+ , eventCoercion

127− , dynamicCoercion

127+ , dynamicCoercion

128#endif

129− ) where

129+ ) where

130

131import Control.Applicative

132import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

@@ -698,6 +698,10 @@ switchPromptly ea0 eea = do

698 eCoincidences = coincidence eea

699 return $ leftmost [eCoincidences, eLag]

700

701+-- | 'switch'es to a new event whenever it receives one. At the moment of

702+-- switching, the old event will be ignored if it fires, and the new one will be

703+-- used if it fires; this is the opposite of 'switch', which will use only the

704+-- old value.

701switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

705switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

702switchPromptOnly e0 e' = do

706switchPromptOnly e0 e' = do

703 eLag <- switch <$> hold e0 e'

707 eLag <- switch <$> hold e0 e'

@@ -871,6 +875,12 @@ zipListWithEvent f l e = do

871 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

875 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

872 mapAccumMaybe_ f' l e

876 mapAccumMaybe_ f' l e

873

877

878+-- | A 'Monad' that supports adjustment over time. After an action has been

879+-- run, if the given events fire, it will adjust itself so that its net effect

880+-- is as though it had originally been run with the new value. Note that there

881+-- is some issue here with persistent side-effects: obviously, IO (and some

882+-- other side-effects) cannot be undone, so it is up to the instance implementer

883+-- to determine what the best meaning for this class is in such cases.

874class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

884class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

875 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

885 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

876 sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

886 sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

@@ -901,6 +911,7 @@ appendEvents = alignWith $ mergeThese mappend

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

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

902onceE = headE

912onceE = headE

903

913

914+-- | Run both sides of a 'These' monadically, combining the results.

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

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

905{-# ANN sequenceThese "HLint: ignore Use fmap" #-}

916{-# ANN sequenceThese "HLint: ignore Use fmap" #-}

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

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

src/Reflex/Dynamic.hs+66−57

@@ -18,62 +18,66 @@

18-- | This module contains various functions for working with 'Dynamic' values.

19-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.

20module Reflex.Dynamic

21− ( -- * Basics

21+ ( -- * Basics

22− Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

22+ Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

23− , current

23+ , current

24− , updated

24+ , updated

25− , holdDyn

25+ , holdDyn

26− , constDyn

26+ , constDyn

27− , uniqDyn

27+ , uniqDyn

28− , uniqDynBy

28+ , uniqDynBy

29− , count

29+ , count

30− , toggle

30+ , toggle

31− , switchPromptlyDyn

31+ , switchPromptlyDyn

32− , tagPromptlyDyn

32+ , tagPromptlyDyn

33− , attachPromptlyDyn

33+ , attachPromptlyDyn

34− , attachPromptlyDynWith

34+ , attachPromptlyDynWith

35− , attachPromptlyDynWithMaybe

35+ , attachPromptlyDynWithMaybe

36− , foldDyn

36+ , foldDyn

37− , foldDynM

37+ , foldDynM

38− , foldDynMaybe

38+ , foldDynMaybe

39− , foldDynMaybeM

39+ , foldDynMaybeM

40− , joinDynThroughMap

40+ , joinDynThroughMap

41− , traceDyn

41+ , traceDyn

42− , traceDynWith

42+ , traceDynWith

43− , splitDynPure

43+ , splitDynPure

44− , distributeMapOverDynPure

44+ , distributeMapOverDynPure

45− , distributeDMapOverDynPure

45+ , distributeDMapOverDynPure

46− , distributeListOverDynPure

46+ , distributeListOverDynPure

47− , Demux

47+ , Demux

48− , demux

48+ , demux

49− , demuxed

49+ , demuxed

50− -- Things that probably aren't very useful:

50+ -- Things that probably aren't very useful:

51− , HList (..)

51+ , HList (..)

52− , FHList (..)

52+ , FHList (..)

53− , collectDynPure

53+ , collectDynPure

54+ , RebuildSortedHList (..)

55+ , IsHList (..)

56+ , AllAreFunctors (..)

57+ , HListPtr (..)

54− , distributeFHListOverDynPure

58+ , distributeFHListOverDynPure

55− -- Unsafe

59+ -- Unsafe

56− , unsafeDynamic

60+ , unsafeDynamic

57− -- * Deprecated functions

61+ -- * Deprecated functions

58− , apDyn

62+ , apDyn

59− , attachDyn

63+ , attachDyn

60− , attachDynWith

64+ , attachDynWith

61− , attachDynWithMaybe

65+ , attachDynWithMaybe

62− , collectDyn

66+ , collectDyn

63− , combineDyn

67+ , combineDyn

64− , distributeDMapOverDyn

68+ , distributeDMapOverDyn

65− , distributeFHListOverDyn

69+ , distributeFHListOverDyn

66− , forDyn

70+ , forDyn

67− , forDynM

71+ , forDynM

68− , getDemuxed

72+ , getDemuxed

69− , joinDyn

73+ , joinDyn

70− , mapDyn

74+ , mapDyn

71− , mapDynM

75+ , mapDynM

72− , mconcatDyn

76+ , mconcatDyn

73− , nubDyn

77+ , nubDyn

74− , splitDyn

78+ , splitDyn

75− , tagDyn

79+ , tagDyn

76− ) where

80+ ) where

78import Prelude hiding (mapM, mapM_)

82import Prelude hiding (mapM, mapM_)

@@ -338,6 +342,7 @@ instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dma

338 HTailPtr _ `gcompare` HHeadPtr = GGT

342 HTailPtr _ `gcompare` HHeadPtr = GGT

339 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b

343 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b

340

344

345+-- | A typed index into a typed heterogeneous list.

341data HListPtr l a where

346data HListPtr l a where

342 HHeadPtr :: HListPtr (h ': t) h

347 HHeadPtr :: HListPtr (h ': t) h

343 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

348 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

@@ -349,6 +354,8 @@ fhlistToDMap = DMap.fromList . go

349 FHNil -> []

354 FHNil -> []

350 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)

351

356

357+-- | This class allows 'HList's and 'FHlist's to be built from regular lists;

358+-- they must be contiguous and sorted.

352class RebuildSortedHList l where

359class RebuildSortedHList l where

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

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

354 rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l

361 rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l

@@ -378,6 +385,8 @@ dmapToHList = rebuildSortedHList . DMap.toList

378distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)

385distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)

379distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l

386distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l

380

387

388+-- | Indicates that all elements in a type-level list are applications of the

389+-- same functor.

381class AllAreFunctors (f :: a -> *) (l :: [a]) where

390class AllAreFunctors (f :: a -> *) (l :: [a]) where

382 type FunctorList f l :: [*]

391 type FunctorList f l :: [*]

383 toFHList :: HList (FunctorList f l) -> FHList f l

392 toFHList :: HList (FunctorList f l) -> FHList f l

@@ -412,7 +421,7 @@ collectDynPure :: ( RebuildSortedHList (HListElems b)

412 ) => a -> Dynamic t b

421 ) => a -> Dynamic t b

413collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds

422collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds

414

423

415−-- Poor man's Generic

424+-- | Poor man's 'Generic's for product types only.

416class IsHList a where

425class IsHList a where

417 type HListElems a :: [*]

426 type HListElems a :: [*]

418 toHList :: a -> HList (HListElems a)

427 toHList :: a -> HList (HListElems a)

src/Reflex/Dynamic/TH.hs+35−7

@@ -9,7 +9,14 @@

9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

10#endif

11-- | Template Haskell helper functions for building complex 'Dynamic' values.

12−module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where

12+module Reflex.Dynamic.TH

13+ ( qDynPure

14+ , unqDyn

15+ , mkDynPure

16+ -- * Deprecated functions

17+ , qDyn

18+ , mkDyn

19+ ) where

14import Reflex.Dynamic

21import Reflex.Dynamic

@@ -26,8 +33,8 @@ import qualified Language.Haskell.TH.Syntax as TH

26-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use

33-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use

27-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the

34-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the

28-- unquoted result will be of type @a@

35-- unquoted result will be of type @a@

29−qDyn :: Q Exp -> Q Exp

36+qDynPure :: Q Exp -> Q Exp

30−qDyn qe = do

37+qDynPure qe = do

31 e <- qe

38 e <- qe

32 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d

39 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d

33 f d = case eqT of

40 f d = case eqT of

@@ -42,7 +49,7 @@ qDyn qe = do

42 let exprs = reverse exprsReversed

49 let exprs = reverse exprsReversed

43 arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs

50 arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs

44 param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs

51 param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs

45− [| return $ $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

52+ [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

47-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

54-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

48-- 'qDyn' quotation.

55-- 'qDyn' quotation.

@@ -68,8 +75,8 @@ unqMarker = error "An unqDyn expression was used outside of a qDyn expression"

68-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]

75-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]

69--

76--

70-- would have a very cumbersome 'Applicative' encoding.

77-- would have a very cumbersome 'Applicative' encoding.

71−mkDyn :: QuasiQuoter

78+mkDynPure :: QuasiQuoter

72−mkDyn = QuasiQuoter

79+mkDynPure = QuasiQuoter

73 { quoteExp = mkDynExp

80 { quoteExp = mkDynExp

74 , quotePat = error "mkDyn: pattern splices are not supported"

81 , quotePat = error "mkDyn: pattern splices are not supported"

75 , quoteType = error "mkDyn: type splices are not supported"

82 , quoteType = error "mkDyn: type splices are not supported"

@@ -79,7 +86,7 @@ mkDyn = QuasiQuoter

79mkDynExp :: String -> Q Exp

86mkDynExp :: String -> Q Exp

80mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of

87mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of

81 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err

88 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err

82− Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e

89+ Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e

83 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker

90 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker

84 antiE x = case x of

91 antiE x = case x of

85 Hs.SpliceExp se ->

92 Hs.SpliceExp se ->

@@ -90,3 +97,24 @@ mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ H

90 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

97 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

91 | modName == modName' && occName == occName' = 'unqMarker

98 | modName == modName' && occName == occName' = 'unqMarker

92 reinstateUnqDyn x = x

99 reinstateUnqDyn x = x

100+

101+--------------------------------------------------------------------------------

102+-- Deprecated

103+--------------------------------------------------------------------------------

104+

105+{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-}

106+-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is

107+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

108+qDyn :: Q Exp -> Q Exp

109+qDyn qe = [| return $(qDynPure qe) |]

110+

111+{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-}

112+-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is

113+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

114+mkDyn :: QuasiQuoter

115+mkDyn = QuasiQuoter

116+ { quoteExp = \s -> [| return $(mkDynExp s) |]

117+ , quotePat = error "mkDyn: pattern splices are not supported"

118+ , quoteType = error "mkDyn: type splices are not supported"

119+ , quoteDec = error "mkDyn: declaration splices are not supported"

120+ }

src/Reflex/Dynamic/Uniq.hs+5−5

@@ -8,11 +8,11 @@

8-- | This module provides a variation of 'Dynamic' values that uses cheap

9-- pointer equality checks to reduce the amount of signal propagation needed.

10module Reflex.Dynamic.Uniq

11− ( UniqDynamic

11+ ( UniqDynamic

12− , uniqDynamic

12+ , uniqDynamic

13− , fromUniqDynamic

13+ , fromUniqDynamic

14− , alreadyUniqDynamic

14+ , alreadyUniqDynamic

15− ) where

15+ ) where

17import Control.Applicative (Applicative (..))

18import GHC.Exts

src/Reflex/DynamicWriter.hs+24−56

@@ -1,3 +1,5 @@

1+-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard

2+-- implementation.

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

@@ -12,7 +14,12 @@

12#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

14#endif

16#endif

15−module Reflex.DynamicWriter where

17+module Reflex.DynamicWriter

18+ ( MonadDynamicWriter (..)

19+ , DynamicWriterT (..)

20+ , runDynamicWriterT

21+ , withDynamicWriterT

22+ ) where

17import Control.Monad.Exception

24import Control.Monad.Exception

18import Control.Monad.Identity

25import Control.Monad.Identity

@@ -29,19 +36,14 @@ import Data.Semigroup

29import Data.Some (Some)

36import Data.Some (Some)

30import qualified Data.Some as Some

37import qualified Data.Some as Some

31import Reflex.Class

38import Reflex.Class

32−import Reflex.Dynamic

33import Reflex.Host.Class

39import Reflex.Host.Class

34import Reflex.PerformEvent.Class

40import Reflex.PerformEvent.Class

35import Reflex.PostBuild.Class

41import Reflex.PostBuild.Class

42+import Reflex.Requester.Class

37instance MonadTrans (DynamicWriterT t w) where

44instance MonadTrans (DynamicWriterT t w) where

38 lift = DynamicWriterT . lift

45 lift = DynamicWriterT . lift

40−mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v, Ord k) => Map k v -> Event t (PatchMap k v) -> m (Dynamic t v)

41−mconcatIncremental m0 e = do

42− d <- foldDynMaybe apply m0 e

43− return $ fmap (mconcat . Map.elems) d

44−

45mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')

47mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')

46mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

48mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

@@ -57,25 +59,13 @@ incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(Pa

57mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)

59mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)

58mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

60mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

60−holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap k (Replaceable t v)) -> m (Incremental t (PatchMap k v))

61−holdIncrementalReplaceableMap m0 m' = do

62− rec vals <- holdIncremental m0 $ m' <> valChanges

63− let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

64− return $ mapIncrementalMapValues _replaceable_value vals

65−

66mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

62mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

67mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

63mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

68 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

64 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

69 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

65 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

71−data Replaceable t w = Replaceable

67+-- | A basic implementation of 'MonadDynamicWriter'.

72− { _replaceable_value :: w

73− , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored

74− }

75−

76−type DynamicWriterAccumulator t w = [Dynamic t w]

77−

78−newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

68+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

80instance MonadRef m => MonadRef (DynamicWriterT t w m) where

70instance MonadRef m => MonadRef (DynamicWriterT t w m) where

81 type Ref (DynamicWriterT t w m) = Ref m

71 type Ref (DynamicWriterT t w m) = Ref m

@@ -90,38 +80,19 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWrit

90 newEventWithTrigger = lift . newEventWithTrigger

80 newEventWithTrigger = lift . newEventWithTrigger

91 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

81 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

93−runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)

83+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided

94−runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []

84+-- along with the result of the action.

95−

96−mconcatIncrementalReplaceableDynMap :: forall m t k v.

97− (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)

98− => Map k (Replaceable t (Dynamic t v))

99− -> Event t (PatchMap k (Replaceable t (Dynamic t v)))

100− -> Event t ()

101− -> m (Replaceable t (Dynamic t v))

102−mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

103− rec vals <- holdIncremental m0 $ m' <> valChanges

104− let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

105− let i = mapIncrementalMapValues _replaceable_value vals

106− noMoreAdditions <- holdDyn False $ True <$ additionsCeased

107− let replaceSelf nma x = do

108− guard nma

109− case Map.toList x of

110− [] -> return Nothing -- Delete self

111− [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?

112− _ -> mzero

113− result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i

114− return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals

115−

116runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

85runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

117runDynamicWriterT (DynamicWriterT a) = do

86runDynamicWriterT (DynamicWriterT a) = do

118 (result, ws) <- runStateT a []

87 (result, ws) <- runStateT a []

119 return (result, mconcat $ reverse ws)

88 return (result, mconcat $ reverse ws)

120

90+-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'

91+-- and combines them monoidally to provide a 'Dynamic' result.

121−class Monad m => MonadDynamicWriter t w m | m -> t w where

92+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where

122 tellDyn :: Dynamic t w -> m ()

93 tellDyn :: Dynamic t w -> m ()

123

124−instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

95+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

125 tellDyn w = DynamicWriterT $ modify (w :)

96 tellDyn w = DynamicWriterT $ modify (w :)

126

127instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

98instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

@@ -129,13 +100,6 @@ instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

129 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

100 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

130 reader = lift . reader

101 reader = lift . reader

131

102

132−liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)

133−liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

134− s <- get

135− (b, (a, newS)) <- lift $ f $ runStateT child s

136− put newS

137− return (b, a)

138−

139instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

103instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

140 type Performable (DynamicWriterT t w m) = Performable m

104 type Performable (DynamicWriterT t w m) = Performable m

141 performEvent_ = lift . performEvent_

105 performEvent_ = lift . performEvent_

@@ -156,8 +120,11 @@ instance MonadState s m => MonadState s (DynamicWriterT t w m) where

156 get = lift get

120 get = lift get

157 put = lift . put

121 put = lift . put

158

122

159−newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }

123+newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult (v, Dynamic t w)

160

124

125+-- | When the execution of a 'DynamicWriterT' action is adjusted using

126+-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to

127+-- match.

161instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where

128instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where

162 runWithReplace a0 a' = do

129 runWithReplace a0 a' = do

163 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

130 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

@@ -182,7 +149,8 @@ instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Mon

182 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i

149 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i

183 return (liftedResult0, liftedResult')

150 return (liftedResult0, liftedResult')

184

151

152+-- | Map a function over the output of a 'DynamicWriterT'.

185−withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)

153+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)

186 => (w -> w')

154 => (w -> w')

187 -> DynamicWriterT t w m a

155 -> DynamicWriterT t w m a

188 -> DynamicWriterT t w' m a

156 -> DynamicWriterT t w' m a

@@ -194,7 +162,7 @@ withDynamicWriterT f dw = do

194 tellDyn d

162 tellDyn d

195 return r

163 return r

196

164

197−instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where

165+instance Requester t m => Requester t (DynamicWriterT t w m) where

198 type Request (DynamicWriterT t w m) = Request m

166 type Request (DynamicWriterT t w m) = Request m

199 type Response (DynamicWriterT t w m) = Response m

167 type Response (DynamicWriterT t w m) = Response m

200 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

168 withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

src/Reflex/FunctorMaybe.hs+6−2

@@ -1,4 +1,8 @@

1+-- | This module defines the FunctorMaybe class, which extends Functors with the

2+-- ability to delete values.

1−module Reflex.FunctorMaybe where

3+module Reflex.FunctorMaybe

4+ ( FunctorMaybe (..)

5+ ) where

3import Data.Maybe

7import Data.Maybe

@@ -20,6 +24,6 @@ class FunctorMaybe f where

20 -- | Combined mapping and filtering function.

24 -- | Combined mapping and filtering function.

21 fmapMaybe :: (a -> Maybe b) -> f a -> f b

25 fmapMaybe :: (a -> Maybe b) -> f a -> f b

27+-- | @fmapMaybe f = catMaybes . fmap f@

23instance FunctorMaybe [] where

28instance FunctorMaybe [] where

24 fmapMaybe f = catMaybes . fmap f

29 fmapMaybe f = catMaybes . fmap f

25−

src/Reflex/Host/Class.hs+10−10

@@ -17,16 +17,16 @@

17-- should only be necessary if you're writing a binding or some other library

18-- that provides a core event loop.

19module Reflex.Host.Class

20− ( ReflexHost (..)

20+ ( ReflexHost (..)

21− , MonadSubscribeEvent (..)

21+ , MonadSubscribeEvent (..)

22− , MonadReadEvent (..)

22+ , MonadReadEvent (..)

23− , MonadReflexCreateTrigger (..)

23+ , MonadReflexCreateTrigger (..)

24− , MonadReflexHost (..)

24+ , MonadReflexHost (..)

25− , fireEvents

25+ , fireEvents

26− , newEventWithTriggerRef

26+ , newEventWithTriggerRef

27− , fireEventRef

27+ , fireEventRef

28− , fireEventRefAndRead

28+ , fireEventRefAndRead

29− ) where

29+ ) where

31import Reflex.Class

src/Reflex/Optimizer.hs+10−2

@@ -1,7 +1,13 @@

1+-- | This module provides a GHC plugin designed to improve code that uses

2+-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level

3+-- definition that doesn't have an explicit inlining pragma. In the future,

4+-- additional optimizations are likely to be added.

1{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

2{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

4−module Reflex.Optimizer (plugin) where

8+module Reflex.Optimizer

9+ ( plugin

10+ ) where

6#ifdef ghcjs_HOST_OS

12#ifdef ghcjs_HOST_OS

7import Plugins

13import Plugins

@@ -14,11 +20,13 @@ import GhcPlugins

15#ifdef ghcjs_HOST_OS

21#ifdef ghcjs_HOST_OS

23+-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used.

17plugin :: Plugin

24plugin :: Plugin

18−plugin = undefined

25+plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS."

20#else

27#else

29+-- | The GHC plugin itself. See "GhcPlugins" for more details.

22plugin :: Plugin

30plugin :: Plugin

23plugin = defaultPlugin { installCoreToDos = install }

31plugin = defaultPlugin { installCoreToDos = install }

src/Reflex/Patch.hs+6−1

@@ -1,3 +1,5 @@

1+-- | This module defines the 'Patch' class, which is used by Reflex to manage

2+-- changes to 'Reflex.Class.Incremental' values.

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

@@ -36,7 +38,8 @@ instance Patch (Identity a) where

36 type PatchTarget (Identity a) = a

38 type PatchTarget (Identity a) = a

37 apply (Identity a) _ = Just a

39 apply (Identity a) _ = Just a

39−-- | A set of changes to a 'DMap'. Only DMap types are allowed for @a@.

41+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or

42+-- deleted.

40newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

43newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

42instance GCompare k => Semigroup (PatchDMap k v) where

45instance GCompare k => Semigroup (PatchDMap k v) where

@@ -64,6 +67,8 @@ instance GCompare k => Patch (PatchDMap k v) where

64 Nothing -> Just $ Constant ()

67 Nothing -> Just $ Constant ()

65 Just _ -> Nothing

68 Just _ -> Nothing

70+-- | A set of changes to a 'Map'. Any element may be inserted/updated or

71+-- deleted.

67newtype PatchMap k v = PatchMap (Map k (Maybe v))

72newtype PatchMap k v = PatchMap (Map k (Maybe v))

69instance Ord k => Patch (PatchMap k v) where

74instance Ord k => Patch (PatchMap k v) where

src/Reflex/PerformEvent/Base.hs+26−195

@@ -1,3 +1,5 @@

1+-- | This module provides 'PerformEventT', the standard implementation of

2+-- 'PerformEvent'.

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

2{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

@@ -17,12 +19,17 @@

17#ifdef USE_REFLEX_OPTIMIZER

19#ifdef USE_REFLEX_OPTIMIZER

18{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

20{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

19#endif

21#endif

20−module Reflex.PerformEvent.Base where

22+module Reflex.PerformEvent.Base

23+ ( PerformEventT (..)

24+ , FireCommand (..)

25+ , hostPerformEventT

26+ ) where

22import Reflex.Class

28import Reflex.Class

23import Reflex.Host.Class

29import Reflex.Host.Class

24import Reflex.PerformEvent.Class

30import Reflex.PerformEvent.Class

25−import Reflex.PostBuild.Class

31+import Reflex.Requester.Base

32+import Reflex.Requester.Class

27import Control.Lens

34import Control.Lens

28import Control.Monad.Exception

35import Control.Monad.Exception

@@ -30,25 +37,20 @@ import Control.Monad.Identity

30import Control.Monad.Primitive

37import Control.Monad.Primitive

31import Control.Monad.Reader

38import Control.Monad.Reader

32import Control.Monad.Ref

39import Control.Monad.Ref

33−import Control.Monad.State.Strict

34import Data.Coerce

40import Data.Coerce

35−import Data.Dependent.Map (DMap, GCompare (..), Some)

41+import Data.Dependent.Map (DMap)

36import qualified Data.Dependent.Map as DMap

42import qualified Data.Dependent.Map as DMap

37import Data.Dependent.Sum

43import Data.Dependent.Sum

38−import Data.Functor.Misc

39−import qualified Data.List.NonEmpty as NonEmpty

40−import Data.Maybe

41−import Data.Semigroup

42−import qualified Data.Some as Some

43−import Data.These

44−import Data.Tuple

45−import Data.Unique.Tag

46−

47−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

45+-- | A function that fires events for the given 'EventTrigger's and then runs

46+-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

47+-- action will be run once for the initial trigger execution as well as once for

48+-- each followup.

49newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

51+-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the

52+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.

51−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequestT t (HostFrame t) Identity (HostFrame t) a }

53+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }

53deriving instance ReflexHost t => Functor (PerformEventT t m)

55deriving instance ReflexHost t => Functor (PerformEventT t m)

54deriving instance ReflexHost t => Applicative (PerformEventT t m)

56deriving instance ReflexHost t => Applicative (PerformEventT t m)

@@ -66,17 +68,17 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

66 {-# INLINABLE performEvent_ #-}

68 {-# INLINABLE performEvent_ #-}

67 performEvent_ = PerformEventT . requesting_

69 performEvent_ = PerformEventT . requesting_

68 {-# INLINABLE performEvent #-}

70 {-# INLINABLE performEvent #-}

69− performEvent = PerformEventT . fmap (fmap runIdentity) . requesting

71+ performEvent = PerformEventT . requestingIdentity

71instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

73instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

72− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequestTWith f (coerce outerA0) (coerceEvent outerA')

74+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')

73− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequestT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

75+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

74 f a0 a' = do

76 f a0 a' = do

75 result0 <- lift a0

77 result0 <- lift a0

76 result' <- requesting a'

78 result' <- requesting a'

77 return (result0, fmap runIdentity result')

79 return (result0, fmap runIdentity result')

78− sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (coerceEvent outerDm')

80+ sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith f (coerce outerDm0) (coerceEvent outerDm')

79− where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))

81+ where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))

80 f dm0 dm' = do

82 f dm0 dm' = do

81 result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0

83 result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0

82 result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do

84 result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do

@@ -89,6 +91,9 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

89 {-# INLINABLE newFanEventWithTrigger #-}

91 {-# INLINABLE newFanEventWithTrigger #-}

90 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

92 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

94+-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the

95+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run

96+-- at the appropriate time.

92{-# INLINABLE hostPerformEventT #-}

97{-# INLINABLE hostPerformEventT #-}

93hostPerformEventT :: forall t m a.

98hostPerformEventT :: forall t m a.

94 ( Monad m

99 ( Monad m

@@ -101,7 +106,7 @@ hostPerformEventT :: forall t m a.

101 -> m (a, FireCommand t m)

106 -> m (a, FireCommand t m)

102hostPerformEventT a = do

107hostPerformEventT a = do

103 (response, responseTrigger) <- newEventWithTriggerRef

108 (response, responseTrigger) <- newEventWithTriggerRef

104− (result, eventToPerform) <- runHostFrame $ runRequestT (unPerformEventT a) response

109+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response

105 eventToPerformHandle <- subscribeEvent eventToPerform

110 eventToPerformHandle <- subscribeEvent eventToPerform

106 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do

111 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do

107 let go :: [DSum (EventTrigger t) Identity] -> m [a']

112 let go :: [DSum (EventTrigger t) Identity] -> m [a']

@@ -145,177 +150,3 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)

145instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where

150instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where

146 {-# INLINABLE atomicModifyRef #-}

151 {-# INLINABLE atomicModifyRef #-}

147 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

152 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

148−

149−--------------------------------------------------------------------------------

150−-- RequestT

151−--------------------------------------------------------------------------------

152−

153−newtype RequestT t request response m a

154− = RequestT { unRequestT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

155− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

156−

157−instance MonadTrans (RequestT t request response) where

158− lift = RequestT . lift . lift

159−

160−runRequestT :: forall t m a request response.

161− ( Reflex t

162− , Monad m

163− )

164− => RequestT t request response m a

165− -> Event t (DMap (Tag (PrimState m)) response)

166− -> m (a, Event t (DMap (Tag (PrimState m)) request))

167−runRequestT (RequestT a) responses = do

168− (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

169− return (result, mergeWith DMap.union requests)

170−

171−instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where

172− type Request (RequestT t request response m) = request

173− type Response (RequestT t request response m) = response

174− withRequesting a = do

175− t <- lift newTag

176− s <- RequestT ask

177− (req, result) <- a $ select s $ WrapArg t

178− RequestT $ modify $ (:) $ DMap.singleton t <$> req

179− return result

180−

181−data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

182−

183−mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'

184−mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p

185−

186−mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

187−mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

188− DMapTransform f g -> f k :=> g v

189−

190−instance MonadSample t m => MonadSample t (RequestT t request response m) where

191− sample = lift . sample

192−

193−instance MonadHold t m => MonadHold t (RequestT t request response m) where

194− hold v0 = lift . hold v0

195− holdDyn v0 = lift . holdDyn v0

196− holdIncremental v0 = lift . holdIncremental v0

197−

198−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where

199− runWithReplace = runWithReplaceRequestTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

200− sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

201−

202−runWithReplaceRequestTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

203− => (forall a' b'.

204− m a'

205− -> Event t (m b')

206− -> RequestT t request response m (a', Event t b')

207− )

208− -> RequestT t request response m a

209− -> Event t (RequestT t request response m b)

210− -> RequestT t request response m (a, Event t b)

211−runWithReplaceRequestTWith f a0 a' = do

212− response <- RequestT ask

213− let g :: RequestT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])

214− g (RequestT r) = runReaderT (runStateT r mempty) response

215− (result0, result') <- f (g a0) $ g <$> a'

216− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'

217− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

218− RequestT $ modify $ (:) $ coincidence $ updated request

219− RequestT $ modify $ (:) $ switch $ current request

220− return (fst result0, fst <$> result')

221−

222−sequenceDMapWithAdjustRequestTWith :: (GCompare k, Reflex t, MonadHold t m)

223− => (forall k'. GCompare k'

224− => DMap k' m

225− -> Event t (PatchDMap k' m)

226− -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))

227− )

228− -> DMap k (RequestT t request response m)

229− -> Event t (PatchDMap k (RequestT t request response m))

230− -> RequestT t request response m (DMap k Identity, Event t (PatchDMap k Identity))

231−sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do

232− response <- RequestT ask

233− let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m

234− inputTransform = DMapTransform WrapArg (\(RequestT v) -> swap <$> runReaderT (runStateT v mempty) response)

235− (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

236− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

237− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

238− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p

239− requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

240− requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

241− requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))

242− requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

243− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

244− childRequestMap <- holdIncremental requests0 requests'

245− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

246− RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

247− RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

248− mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

249− return (result0, result')

250−

251−instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

252− type Performable (RequestT t request response m) = Performable m

253− performEvent_ = lift . performEvent_

254− performEvent = lift . performEvent

255−

256−instance PostBuild t m => PostBuild t (RequestT t request response m) where

257− getPostBuild = lift getPostBuild

258−

259−instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where

260− newTriggerEvent = lift newTriggerEvent

261− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

262− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

263−

264−instance MonadReader r m => MonadReader r (RequestT t request response m) where

265− ask = lift ask

266− local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a

267− reader = lift . reader

268−

269−{-

270−withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).

271− (Reflex t, MonadHold t m, MonadFix m)

272− => (forall x. request x -> request' x)

273− -> (forall x. response' x -> response x)

274− -> RequestT t request response m a

275− -> RequestT t request' response m a

276−withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)

277− where

278− f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]

279− f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req

280−-}

281−

282−instance MonadRef m => MonadRef (RequestT t request response m) where

283− type Ref (RequestT t request response m) = Ref m

284− newRef = lift . newRef

285− readRef = lift . readRef

286− writeRef r = lift . writeRef r

287−

288−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where

289− newEventWithTrigger = lift . newEventWithTrigger

290− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

291−

292−

293−--------------------------------------------------------------------------------

294−-- Helpers

295−--------------------------------------------------------------------------------

296−

297−{-# INLINABLE numberWith #-}

298−numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)

299−numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)

300−

301−{-# INLINABLE mergeSelfDeletingEvents #-}

302−mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)

303− => DMap (Const2 k (These v ())) (Event t)

304− -> Event t (PatchDMap (Const2 k (These v ())) (Event t))

305− -> m (Event t [v])

306−mergeSelfDeletingEvents initial eAddNew = do

307− rec events :: Incremental t (PatchDMap (Const2 k (These v ())) (Event t))

308− <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings

309− let event = mergeWith DMap.union

310− [ mergeIncremental events

311− , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getComposeMaybe) m

312− ]

313− eDelete :: Event t (PatchDMap (Const2 k (These v ())) (Event t))

314− eDelete = fforMaybe event $

315− fmap (PatchDMap . DMap.fromDistinctAscList) .

316− (\l -> if null l then Nothing else Just l) .

317− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> ComposeMaybe Nothing) <$ x ^? there) .

318− DMap.toList

319− return $ ffor event $

320− fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .

321− DMap.toList

src/Reflex/PerformEvent/Class.hs+40−47

@@ -1,3 +1,6 @@

1+-- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the

2+-- interaction between a "Reflex"-based program and the external side-effecting

3+-- actions such as 'IO'.

1{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE FunctionalDependencies #-}

@@ -8,31 +11,59 @@

8{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

10{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

11−module Reflex.PerformEvent.Class where

14+module Reflex.PerformEvent.Class

15+ ( PerformEvent (..)

16+ , performEventAsync

17+ , TriggerEvent (..)

18+ ) where

13import Reflex.Class

20import Reflex.Class

15−import Control.Monad.Identity

16import Control.Monad.Reader

22import Control.Monad.Reader

17−import qualified Control.Monad.State.Lazy as Lazy

18−import Control.Monad.State.Strict

24+-- | 'PerformEvent' represents actions that can trigger other actions based on

25+-- 'Event's.

20class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where

26class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where

27+ -- | The type of action to be triggered; this is often not the same type as

28+ -- the triggering action.

21 type Performable m :: * -> *

29 type Performable m :: * -> *

30+ -- | Perform the action contained in the given 'Event' whenever the 'Event'

31+ -- fires. Return the result in another 'Event'. Note that the output 'Event'

32+ -- will generally occur later than the input 'Event', since most 'Performable'

33+ -- actions cannot be performed during 'Event' propagation.

22 performEvent :: Event t (Performable m a) -> m (Event t a)

34 performEvent :: Event t (Performable m a) -> m (Event t a)

35+ -- | Like 'performEvent', but do not return the result. May have slightly

36+ -- better performance.

23 performEvent_ :: Event t (Performable m ()) -> m ()

37 performEvent_ :: Event t (Performable m ()) -> m ()

25--TODO: Shouldn't have IO hard-coded

39--TODO: Shouldn't have IO hard-coded

40+-- | 'TriggerEvent' represents actions that can create 'Event's that can be

41+-- triggered from the IO monad.

26class Monad m => TriggerEvent t m | m -> t where

42class Monad m => TriggerEvent t m | m -> t where

43+ -- | Create a triggerable 'Event'. Whenever the resulting function is called,

44+ -- the resulting 'Event' will fire at some point in the future. Note that

45+ -- this may not be synchronous.

27 newTriggerEvent :: m (Event t a, a -> IO ())

46 newTriggerEvent :: m (Event t a, a -> IO ())

47+ -- | Like 'newTriggerEvent', but the callback itself takes another callback,

48+ -- to be invoked once the requested 'Event' occurrence has finished firing.

49+ -- This allows synchronous operation.

28 newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow

50 newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow

51+ -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown. This

52+ -- relatively complex type signature allows any external listeners to be

53+ -- subscribed lazily and then removed whenever the returned 'Event' is no

54+ -- longer being listened to. Note that the setup/teardown may happen multiple

55+ -- times, and there is no guarantee that the teardown will be executed

56+ -- promptly, or even at all, in the case of program termination.

29 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

57 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

31−class (Reflex t, Monad m) => MonadRequest t m | m -> t where

59+-- | Like 'performEvent', but the resulting 'Event' occurs only when the

32− type Request m :: * -> *

60+-- callback (@a -> IO ()@) is called, not when the included action finishes.

33− type Response m :: * -> *

61+--

34− withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

62+-- NOTE: Despite the name, 'performEventAsync' does not run its action in a

35−

63+-- separate thread - although the action is free to invoke forkIO and then call

64+-- the callback whenever it is ready. This will work properly, even in GHCJS

65+-- (which fully implements concurrency even though JavaScript does not have

66+-- built in concurrency).

36{-# INLINABLE performEventAsync #-}

67{-# INLINABLE performEventAsync #-}

37performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)

68performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)

38performEventAsync e = do

69performEventAsync e = do

@@ -53,41 +84,3 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

53 newTriggerEvent = lift newTriggerEvent

84 newTriggerEvent = lift newTriggerEvent

54 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

85 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

55 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

86 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

56−

57−instance MonadRequest t m => MonadRequest t (ReaderT r m) where

58− type Request (ReaderT r m) = Request m

59− type Response (ReaderT r m) = Response m

60− withRequesting f = do

61− r <- ask

62− lift $ withRequesting $ (`runReaderT` r) . f

63−

64−instance MonadRequest t m => MonadRequest t (StateT s m) where

65− type Request (StateT s m) = Request m

66− type Response (StateT s m) = Response m

67− withRequesting f = do

68− old <- get

69− (result, new) <- lift $ withRequesting $ \x -> do

70− ((request, result), new) <- runStateT (f x) old

71− return (request, (result, new))

72− put new

73− return result

74−

75−instance MonadRequest t m => MonadRequest t (Lazy.StateT s m) where

76− type Request (Lazy.StateT s m) = Request m

77− type Response (Lazy.StateT s m) = Response m

78− withRequesting f = do

79− old <- Lazy.get

80− (result, new) <- lift $ withRequesting $ \x -> do

81− ((request, result), new) <- Lazy.runStateT (f x) old

82− return (request, (result, new))

83− Lazy.put new

84− return result

85−

86−requesting :: MonadRequest t m => Event t (Request m a) -> m (Event t (Response m a))

87−requesting req = withRequesting $ return . (,) req

88−

89−requesting_ :: MonadRequest t m => Event t (Request m a) -> m ()

90−requesting_ req = withRequesting $ \_ -> return (req, ())

91−

92−requestingIdentity :: (MonadRequest t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

93−requestingIdentity = fmap (fmap runIdentity) . requesting

src/Reflex/PostBuild/Base.hsnew file+119

@@ -0,0 +1,119 @@

1+-- | This module defines 'PostBuildT', the standard implementation of

2+-- 'PostBuild'.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE RecursiveDo #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+#ifdef USE_REFLEX_OPTIMIZER

15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

16+#endif

17+module Reflex.PostBuild.Base

18+ ( PostBuildT (..)

19+ , runPostBuildT

20+ ) where

21+

22+import Reflex.Class

23+import Reflex.Host.Class

24+import Reflex.PerformEvent.Class

25+import Reflex.PostBuild.Class

26+

27+import Control.Monad.Exception

28+import Control.Monad.Primitive

29+import Control.Monad.Reader

30+import Control.Monad.Ref

31+import Control.Monad.Trans.Control

32+import qualified Data.Dependent.Map as DMap

33+

34+-- | Provides a basic implementation of 'PostBuild'.

35+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

36+

37+-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires

38+-- immediately after the action is finished running; no other 'Event's should

39+-- fire first.

40+{-# INLINABLE runPostBuildT #-}

41+runPostBuildT :: PostBuildT t m a -> Event t () -> m a

42+runPostBuildT (PostBuildT a) = runReaderT a

43+

44+instance PrimMonad m => PrimMonad (PostBuildT x m) where

45+ type PrimState (PostBuildT x m) = PrimState m

46+ primitive = lift . primitive

47+

48+instance MonadTransControl (PostBuildT t) where

49+ type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

50+ {-# INLINABLE liftWith #-}

51+ liftWith = defaultLiftWith PostBuildT unPostBuildT

52+ {-# INLINABLE restoreT #-}

53+ restoreT = defaultRestoreT PostBuildT

54+

55+instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

56+ {-# INLINABLE getPostBuild #-}

57+ getPostBuild = PostBuildT ask

58+

59+instance MonadSample t m => MonadSample t (PostBuildT t m) where

60+ {-# INLINABLE sample #-}

61+ sample = lift . sample

62+

63+instance MonadHold t m => MonadHold t (PostBuildT t m) where

64+ {-# INLINABLE hold #-}

65+ hold v0 = lift . hold v0

66+ {-# INLINABLE holdDyn #-}

67+ holdDyn v0 = lift . holdDyn v0

68+ {-# INLINABLE holdIncremental #-}

69+ holdIncremental v0 = lift . holdIncremental v0

70+

71+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

72+ type Performable (PostBuildT t m) = PostBuildT t (Performable m)

73+ {-# INLINABLE performEvent_ #-}

74+ performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

75+ {-# INLINABLE performEvent #-}

76+ performEvent e = liftWith $ \run -> performEvent $ fmap run e

77+

78+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

79+ {-# INLINABLE newEventWithTrigger #-}

80+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger

81+ {-# INLINABLE newFanEventWithTrigger #-}

82+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f

83+

84+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where

85+ {-# INLINABLE newTriggerEvent #-}

86+ newTriggerEvent = lift newTriggerEvent

87+ {-# INLINABLE newTriggerEventWithOnComplete #-}

88+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

89+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

90+

91+instance MonadRef m => MonadRef (PostBuildT t m) where

92+ type Ref (PostBuildT t m) = Ref m

93+ {-# INLINABLE newRef #-}

94+ newRef = lift . newRef

95+ {-# INLINABLE readRef #-}

96+ readRef = lift . readRef

97+ {-# INLINABLE writeRef #-}

98+ writeRef r = lift . writeRef r

99+

100+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where

101+ {-# INLINABLE atomicModifyRef #-}

102+ atomicModifyRef r = lift . atomicModifyRef r

103+

104+instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where

105+ runWithReplace a0 a' = do

106+ postBuild <- getPostBuild

107+ lift $ do

108+ rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

109+ let voidResult' = void result'

110+ return result

111+ sequenceDMapWithAdjust dm0 dm' = do

112+ postBuild <- getPostBuild

113+ let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0

114+ lift $ do

115+ rec (result0, result') <- sequenceDMapWithAdjust loweredDm0 loweredDm'

116+ let voidResult' = void result'

117+ let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

118+ DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE voidResult') . getComposeMaybe) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

119+ return (result0, result')

src/Reflex/PostBuild/Class.hs+14−92

@@ -1,3 +1,5 @@

1+-- | This module defines 'PostBuild', which indicates that an action will be

2+-- notified when it, and any action it's a part of, has finished executing.

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -12,103 +14,23 @@

12#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

14#endif

16#endif

15−module Reflex.PostBuild.Class where

17+module Reflex.PostBuild.Class

18+ ( PostBuild (..)

19+ ) where

17−import Control.Monad.Exception

18−import Control.Monad.Primitive

19−import Control.Monad.Reader

20−import Control.Monad.Ref

21−import Control.Monad.Trans.Control

22−import qualified Data.Dependent.Map as DMap

23import Reflex.Class

21import Reflex.Class

24−import Reflex.Host.Class

25−import Reflex.PerformEvent.Class

23+import Control.Monad.Reader

24+

25+-- | 'PostBuild' represents an action that is notified via an 'Event' when it

26+-- has finished executing. Note that the specific definition of "finished" is

27+-- determined by the instance of 'PostBuild', but the intent is to allow

28+-- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they

29+-- were created, when the post-build 'Event' fires. The post-build 'Event' will

30+-- fire exactly once for an given action.

27class (Reflex t, Monad m) => PostBuild t m | m -> t where

31class (Reflex t, Monad m) => PostBuild t m | m -> t where

32+ -- | Retrieve the post-build 'Event' for this action.

28 getPostBuild :: m (Event t ())

33 getPostBuild :: m (Event t ())

30−newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

31−

32−instance PrimMonad m => PrimMonad (PostBuildT x m) where

33− type PrimState (PostBuildT x m) = PrimState m

34− primitive = lift . primitive

35−

36−instance MonadTransControl (PostBuildT t) where

37− type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

38− {-# INLINABLE liftWith #-}

39− liftWith = defaultLiftWith PostBuildT unPostBuildT

40− {-# INLINABLE restoreT #-}

41− restoreT = defaultRestoreT PostBuildT

42−

43−instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

44− {-# INLINABLE getPostBuild #-}

45− getPostBuild = PostBuildT ask

46−

47−instance MonadSample t m => MonadSample t (PostBuildT t m) where

48− {-# INLINABLE sample #-}

49− sample = lift . sample

50−

51−instance MonadHold t m => MonadHold t (PostBuildT t m) where

52− {-# INLINABLE hold #-}

53− hold v0 = lift . hold v0

54− {-# INLINABLE holdDyn #-}

55− holdDyn v0 = lift . holdDyn v0

56− {-# INLINABLE holdIncremental #-}

57− holdIncremental v0 = lift . holdIncremental v0

58−

59−instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

60− type Performable (PostBuildT t m) = PostBuildT t (Performable m)

61− {-# INLINABLE performEvent_ #-}

62− performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

63− {-# INLINABLE performEvent #-}

64− performEvent e = liftWith $ \run -> performEvent $ fmap run e

65−

66−instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

67− {-# INLINABLE newEventWithTrigger #-}

68− newEventWithTrigger = PostBuildT . lift . newEventWithTrigger

69− {-# INLINABLE newFanEventWithTrigger #-}

70− newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f

71−

72−instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where

73− {-# INLINABLE newTriggerEvent #-}

74− newTriggerEvent = lift newTriggerEvent

75− {-# INLINABLE newTriggerEventWithOnComplete #-}

76− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

77− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

78−

79−instance MonadRef m => MonadRef (PostBuildT t m) where

80− type Ref (PostBuildT t m) = Ref m

81− {-# INLINABLE newRef #-}

82− newRef = lift . newRef

83− {-# INLINABLE readRef #-}

84− readRef = lift . readRef

85− {-# INLINABLE writeRef #-}

86− writeRef r = lift . writeRef r

87−

88−instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where

89− {-# INLINABLE atomicModifyRef #-}

90− atomicModifyRef r = lift . atomicModifyRef r

91−

92−{-# INLINABLE runPostBuildT #-}

93−runPostBuildT :: PostBuildT t m a -> Event t () -> m a

94−runPostBuildT (PostBuildT a) = runReaderT a

95−

96instance PostBuild t m => PostBuild t (ReaderT r m) where

35instance PostBuild t m => PostBuild t (ReaderT r m) where

97 getPostBuild = lift getPostBuild

36 getPostBuild = lift getPostBuild

98−

99−instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where

100− runWithReplace a0 a' = do

101− postBuild <- getPostBuild

102− lift $ do

103− rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

104− let voidResult' = void result'

105− return result

106− sequenceDMapWithAdjust dm0 dm' = do

107− postBuild <- getPostBuild

108− let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0

109− lift $ do

110− rec (result0, result') <- sequenceDMapWithAdjust loweredDm0 loweredDm'

111− let voidResult' = void result'

112− let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

113− DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE voidResult') . getComposeMaybe) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

114− return (result0, result')

src/Reflex/Pure.hs+15−7

@@ -18,7 +18,13 @@

18-- serve as a reference for the semantics of the Reflex class. All

19-- implementations of Reflex should produce the same results as this

20-- implementation, although performance and laziness/strictness may differ.

21−module Reflex.Pure where

21+module Reflex.Pure

22+ ( Pure

23+ , Behavior (..)

24+ , Event (..)

25+ , Dynamic (..)

26+ , Incremental (..)

27+ ) where

23#if !MIN_VERSION_base(4,8,0)

29#if !MIN_VERSION_base(4,8,0)

24import Control.Applicative

30import Control.Applicative

@@ -34,6 +40,8 @@ import Data.Monoid

34import Data.Type.Coercion

40import Data.Type.Coercion

35import Reflex.Class

41import Reflex.Class

43+-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

44+-- with the type @t@.

37data Pure t

45data Pure t

39-- | The Enum instance of t must be dense: for all x :: t, there must not exist

47-- | The Enum instance of t must be dense: for all x :: t, there must not exist

@@ -97,18 +105,18 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

97 --a) -> Incremental (Pure t) p a

105 --a) -> Incremental (Pure t) p a

98 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

106 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

107

100− mergeIncremental (Incremental f) = Event $ \t ->

108+ mergeIncremental i = Event $ \t ->

101− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ f t

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

102 in if DMap.null results

110 in if DMap.null results

103 then Nothing

111 then Nothing

104 else Just results

112 else Just results

105

113

106− currentIncremental (Incremental f) = Behavior $ \t -> fst $ f t

114+ currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

107

115

108− updatedIncremental (Incremental f) = Event $ \t -> snd $ f t

116+ updatedIncremental i = Event $ \t -> snd $ unIncremental i t

109

117

110− incrementalToDynamic (Incremental f) = Dynamic $ \t ->

118+ incrementalToDynamic i = Dynamic $ \t ->

111− let (old, mPatch) = f t

119+ let (old, mPatch) = unIncremental i t

112 e = case mPatch of

120 e = case mPatch of

113 Nothing -> Nothing

121 Nothing -> Nothing

114 Just patch -> apply patch old

122 Just patch -> apply patch old

src/Reflex/Requester/Base.hsnew file+179

@@ -0,0 +1,179 @@

1+-- | This module provides 'RequesterT', the standard implementation of

2+-- 'Requester'.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+#ifdef USE_REFLEX_OPTIMIZER

14+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

15+#endif

16+module Reflex.Requester.Base

17+ ( RequesterT (..)

18+ , runRequesterT

19+ , runWithReplaceRequesterTWith

20+ , sequenceDMapWithAdjustRequesterTWith

21+ ) where

22+

23+import Reflex.Class

24+import Reflex.Host.Class

25+import Reflex.PerformEvent.Class

26+import Reflex.PostBuild.Class

27+import Reflex.Requester.Class

28+

29+import Control.Monad.Exception

30+import Control.Monad.Identity

31+import Control.Monad.Primitive

32+import Control.Monad.Reader

33+import Control.Monad.Ref

34+import Control.Monad.State.Strict

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

36+import qualified Data.Dependent.Map as DMap

37+import Data.Functor.Misc

38+import qualified Data.List.NonEmpty as NonEmpty

39+import Data.Maybe

40+import Data.Some (Some)

41+import qualified Data.Some as Some

42+import Data.Tuple

43+import Data.Unique.Tag

44+

45+-- | A basic implementation of 'Requester'.

46+newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

47+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

48+

49+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

50+-- requests are made, and responses should be provided in the input 'Event'.

51+-- The 'Tag' keys will be used to return the responses to the same place the

52+-- requests were issued.

53+runRequesterT :: (Reflex t, Monad m)

54+ => RequesterT t request response m a

55+ -> Event t (DMap (Tag (PrimState m)) response)

56+ -> m (a, Event t (DMap (Tag (PrimState m)) request))

57+runRequesterT (RequesterT a) responses = do

58+ (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

59+ return (result, mergeWith DMap.union requests)

60+

61+instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

62+ type Request (RequesterT t request response m) = request

63+ type Response (RequesterT t request response m) = response

64+ withRequesting a = do

65+ t <- lift newTag

66+ s <- RequesterT ask

67+ (req, result) <- a $ select s $ WrapArg t

68+ RequesterT $ modify $ (:) $ DMap.singleton t <$> req

69+ return result

70+

71+instance MonadTrans (RequesterT t request response) where

72+ lift = RequesterT . lift . lift

73+

74+instance MonadSample t m => MonadSample t (RequesterT t request response m) where

75+ sample = lift . sample

76+

77+instance MonadHold t m => MonadHold t (RequesterT t request response m) where

78+ hold v0 = lift . hold v0

79+ holdDyn v0 = lift . holdDyn v0

80+ holdIncremental v0 = lift . holdIncremental v0

81+

82+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

83+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

84+ sequenceDMapWithAdjust = sequenceDMapWithAdjustRequesterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

85+

86+-- | Given a function like 'runWithReplace' for the underlying monad, implement

87+-- 'runWithReplace' for 'RequesterT'. This is necessary when the underlying

88+-- monad doesn't have a 'MonadAdjust' instance or to override the default

89+-- 'MonadAdjust' behavior.

90+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

91+ => (forall a' b'.

92+ m a'

93+ -> Event t (m b')

94+ -> RequesterT t request response m (a', Event t b')

95+ )

96+ -> RequesterT t request response m a

97+ -> Event t (RequesterT t request response m b)

98+ -> RequesterT t request response m (a, Event t b)

99+runWithReplaceRequesterTWith f a0 a' = do

100+ response <- RequesterT ask

101+ let g :: RequesterT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])

102+ g (RequesterT r) = runReaderT (runStateT r mempty) response

103+ (result0, result') <- f (g a0) $ g <$> a'

104+ request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'

105+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

106+ RequesterT $ modify $ (:) $ coincidence $ updated request

107+ RequesterT $ modify $ (:) $ switch $ current request

108+ return (fst result0, fst <$> result')

109+

110+-- | Like 'runWithReplaceRequesterTWith', but for 'sequenceDMapWithAdjust'.

111+sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)

112+ => (forall k'. GCompare k'

113+ => DMap k' m

114+ -> Event t (PatchDMap k' m)

115+ -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))

116+ )

117+ -> DMap k (RequesterT t request response m)

118+ -> Event t (PatchDMap k (RequesterT t request response m))

119+ -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))

120+sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' = do

121+ response <- RequesterT ask

122+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequesterT t request response m) m

123+ inputTransform = DMapTransform WrapArg (\(RequesterT v) -> swap <$> runReaderT (runStateT v mempty) response)

124+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

125+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

126+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

127+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p

128+ requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

129+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

130+ requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))

131+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

132+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

133+ childRequestMap <- holdIncremental requests0 requests'

134+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

135+ RequesterT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

136+ RequesterT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

137+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

138+ return (result0, result')

139+

140+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

141+ type Performable (RequesterT t request response m) = Performable m

142+ performEvent_ = lift . performEvent_

143+ performEvent = lift . performEvent

144+

145+instance PostBuild t m => PostBuild t (RequesterT t request response m) where

146+ getPostBuild = lift getPostBuild

147+

148+instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m) where

149+ newTriggerEvent = lift newTriggerEvent

150+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

151+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

152+

153+instance MonadReader r m => MonadReader r (RequesterT t request response m) where

154+ ask = lift ask

155+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

156+ reader = lift . reader

157+

158+instance MonadRef m => MonadRef (RequesterT t request response m) where

159+ type Ref (RequesterT t request response m) = Ref m

160+ newRef = lift . newRef

161+ readRef = lift . readRef

162+ writeRef r = lift . writeRef r

163+

164+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

165+ newEventWithTrigger = lift . newEventWithTrigger

166+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

167+

168+--------------------------------------------------------------------------------

169+-- Internal functions

170+--------------------------------------------------------------------------------

171+

172+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

173+

174+mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'

175+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p

176+

177+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

178+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

179+ DMapTransform f g -> f k :=> g v

src/Reflex/Requester/Class.hsnew file+87

@@ -0,0 +1,87 @@

1+-- | This module defines 'Requester', which indicates that an action can make

2+-- requests and receive responses to them. Typically, this is used for things

3+-- like a WebSocket, where it's desirable to collect many potential sources of

4+-- events and send them over a single channel, then distribute the results back

5+-- out efficiently to their original request sites.

6+{-# LANGUAGE CPP #-}

7+{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE FunctionalDependencies #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+#ifdef USE_REFLEX_OPTIMIZER

13+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

14+#endif

15+module Reflex.Requester.Class

16+ ( Requester (..)

17+ , requesting

18+ , requesting_

19+ , requestingIdentity

20+ ) where

21+

22+import Control.Monad.Identity

23+import Control.Monad.Reader

24+import qualified Control.Monad.State.Lazy as Lazy

25+import Control.Monad.State.Strict

26+import Reflex.Class

27+

28+-- | A 'Requester' action can trigger requests of type @Request m a@ based on

29+-- 'Event's, and receive responses of type @Response m a@ in return. Note that

30+-- the @a@ type can vary within the 'Requester' action, but will be linked for a

31+-- given request. For example, if @Request m@ is 'IO' and @Response m@ is

32+-- 'Identity', then 'requestingIdentity' has the same type as

33+-- 'Reflex.PerformEvent.Class.performEvent'.

34+class (Reflex t, Monad m) => Requester t m | m -> t where

35+ -- | The type of requests that this 'Requester' can emit

36+ type Request m :: * -> *

37+ -- | The type of responses that this 'Requester' can receive

38+ type Response m :: * -> *

39+ -- | Usually, end-user code should use 'requesting', 'requesting_', or

40+ -- 'requestingIdentity'. For implementers of 'Requester', this function

41+ -- provides a convenient way to define instances of the typeclass that

42+ -- efficiently support the underlying operations without needing to use

43+ -- 'Control.Monad.Fix.MonadFix'.

44+ withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

45+

46+instance Requester t m => Requester t (ReaderT r m) where

47+ type Request (ReaderT r m) = Request m

48+ type Response (ReaderT r m) = Response m

49+ withRequesting f = do

50+ r <- ask

51+ lift $ withRequesting $ (`runReaderT` r) . f

52+

53+instance Requester t m => Requester t (StateT s m) where

54+ type Request (StateT s m) = Request m

55+ type Response (StateT s m) = Response m

56+ withRequesting f = do

57+ old <- get

58+ (result, new) <- lift $ withRequesting $ \x -> do

59+ ((request, result), new) <- runStateT (f x) old

60+ return (request, (result, new))

61+ put new

62+ return result

63+

64+instance Requester t m => Requester t (Lazy.StateT s m) where

65+ type Request (Lazy.StateT s m) = Request m

66+ type Response (Lazy.StateT s m) = Response m

67+ withRequesting f = do

68+ old <- Lazy.get

69+ (result, new) <- lift $ withRequesting $ \x -> do

70+ ((request, result), new) <- Lazy.runStateT (f x) old

71+ return (request, (result, new))

72+ Lazy.put new

73+ return result

74+

75+-- | Emit a request whenever the given 'Event' fires, and return responses in

76+-- the resulting 'Event'.

77+requesting :: Requester t m => Event t (Request m a) -> m (Event t (Response m a))

78+requesting req = withRequesting $ return . (,) req

79+

80+-- | Emit a request whenever the given 'Event' fires, and ignore all responses.

81+requesting_ :: Requester t m => Event t (Request m a) -> m ()

82+requesting_ req = withRequesting $ \_ -> return (req, ())

83+

84+-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

85+-- before returning them. @Response m@ must be 'Identity'.

86+requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

87+requestingIdentity = fmap (fmap runIdentity) . requesting

src/Reflex/Spider/Internal.hs+3

@@ -680,6 +680,9 @@ data Hold x p

680#endif

681 }

682

683+-- | A statically allocated 'SpiderTimeline'; this is the only instance of

684+-- 'SpiderTimeline' that can used when using

685+-- -fspecialize-to-spidertimeline-global.

683data Global

686data Global

684

687

685{-# NOINLINE globalSpiderTimelineEnv #-}

688{-# NOINLINE globalSpiderTimelineEnv #-}

src/Reflex/Spider/SpiderTimeline.include.hs+1

@@ -117,5 +117,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

117-- Deprecated items

118--------------------------------------------------------------------------------

119

120+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'

120{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

121{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

121type SpiderEnv = SpiderTimeline

122type SpiderEnv = SpiderTimeline